From c77992558a957dc72b2ab5517e797d7ad77b1258 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 1 Apr 2021 11:45:15 -0400 Subject: [PATCH 0001/1324] Format patterns nicely in contexts. --- src/Facet/Print.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 526873d2b..9a09e9404 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -227,10 +227,10 @@ printPattern Options{ rname } = \case vpat = \case PWildcard -> pretty '_' PVar n -> n - PCon n ps -> parens (hsep (annotate Con (rname n):map vpat (toList ps))) + PCon n ps -> parens (annotate Con (rname n) $$* map vpat (toList ps)) epat = \case PAll n -> n - POp q ps k -> brackets (hsep (pretty q : map vpat (toList ps)) <+> semi <+> k) + POp q ps k -> brackets (pretty q $$* (group . vpat <$> ps) semi <+> group k) printModule :: C.Module -> Print printModule (C.Module mname is _ ds) = module_ From bdf6e483909e7f5a2aea82fcc1d1956b6a4123bf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 1 Apr 2021 13:25:54 -0400 Subject: [PATCH 0002/1324] Align. --- src/Facet/Elab/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index be28a42c3..ba9f2b6ac 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -245,7 +245,7 @@ abstractTerm body = go Nil Nil VArrow n q _A _B -> do d <- depth check (lam [(patternForArgType _A (fromMaybe __ n), go ts (fs :> \ d' -> XVar (Free (LName (levelToIndex d' d) (fromMaybe __ n)))))] ::: VArrow n q _A _B) - _T -> do + _T -> do d <- depth pure $ body (TVar . Free . Right . fmap (levelToIndex d) <$> ts) (fs <*> pure d) From f8bd4fa330ab9c83a451120ebad4bbe1ead9377b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 1 Apr 2021 14:21:03 -0400 Subject: [PATCH 0003/1324] Factor Check out of Bind. --- src/Facet/Elab/Term.hs | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index ba9f2b6ac..cb0dd051f 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -125,7 +125,7 @@ tlam b = Check $ \ _T -> do lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern Name), Check m Expr)] -> Check m Expr lam cs = Check $ \ _T -> do (_A, _B) <- assertTacitFunction _T - XLam <$> traverse (\ (p, b) -> check (bind (p ::: _A) b ::: _B)) cs + XLam <$> traverse (\ (p, b) -> bind (p ::: _A) (check (b ::: _B))) cs app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Synth m a) -> (HasCallStack => Check m b) -> Synth m c app mk operator operand = Synth $ do @@ -145,39 +145,39 @@ wildcardP :: Bind m (ValuePattern Name) wildcardP = Bind $ \ _ _ -> fmap (PWildcard,) varP :: (HasCallStack, Has (Throw Err) sig m) => Name -> Bind m (ValuePattern Name) -varP n = Bind $ \ q _A b -> Check $ \ _B -> (PVar n,) <$> ((q, pvar (n ::: CT (wrap _A))) |- check (b ::: _B)) +varP n = Bind $ \ q _A b -> (PVar n,) <$> ((q, pvar (n ::: CT (wrap _A))) |- b) where wrap = \case VComp sig _A -> VArrow Nothing Many (VNe (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (VComp sig _A) _T -> _T conP :: (HasCallStack, Has (Throw Err) sig m) => QName -> [Bind m (ValuePattern Name)] -> Bind m (ValuePattern Name) -conP n ps = Bind $ \ q _A b -> Check $ \ _B -> do +conP n ps = Bind $ \ q _A b -> do n' :=: _ ::: _T <- resolveC n _T' <- maybe (pure _T) (foldl' (\ _T _A -> ($ _A) . snd <$> (_T >>= assertQuantifier)) (pure _T) . snd) (unNeutral _A) - (ps', b') <- check (bind (fieldsP (Bind (\ _q' _A' b -> ([],) <$> Check (\ _B -> unify (Exp _A) (Act _A') *> check (b ::: _B)))) ps ::: (q, _T')) b ::: _B) + (ps', b') <- bind (fieldsP (Bind (\ _q' _A' b -> ([],) <$ unify (Exp _A) (Act _A') <*> b)) ps ::: (q, _T')) b pure (PCon n' (fromList ps'), b') fieldsP :: (HasCallStack, Has (Throw Err) sig m) => Bind m [a] -> [Bind m a] -> Bind m [a] fieldsP = foldr cons where - cons p ps = Bind $ \ q _A b -> Check $ \ _B -> do + cons p ps = Bind $ \ q _A b -> do (_ ::: (q', _A'), _A'') <- assertFunction _A - (p', (ps', b')) <- check (bind (p ::: (q', _A')) (bind (ps ::: (q, _A'')) b) ::: _B) + (p', (ps', b')) <- bind (p ::: (q', _A')) (bind (ps ::: (q, _A'')) b) pure (p':ps', b') allP :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Name -> Bind m (EffectPattern Name) -allP n = Bind $ \ q _A b -> Check $ \ _B -> do +allP n = Bind $ \ q _A b -> do (sig, _T) <- assertComp _A - (PAll n,) <$> ((q, pvar (n ::: CT (VArrow Nothing Many (VNe (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (VComp sig _T)))) |- check (b ::: _B)) + (PAll n,) <$> ((q, pvar (n ::: CT (VArrow Nothing Many (VNe (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (VComp sig _T)))) |- b) effP :: (HasCallStack, Has (Throw Err) sig m) => QName -> [Bind m (ValuePattern Name)] -> Name -> Bind m (Pattern Name) -effP n ps v = Bind $ \ q _A b -> Check $ \ _B -> do +effP n ps v = Bind $ \ q _A b -> do StaticContext{ module', graph } <- ask (sig, _A') <- assertComp _A n' ::: _T <- maybe (freeVariable n) (\ (n :=: _ ::: _T) -> instantiate const (n ::: _T)) (listToMaybe (traverse unDTerm =<< lookupInSig n module' graph [sig])) - (ps', b') <- check (bind (fieldsP (Bind (\ q' _A' b -> ([],) <$> Check (\ _B -> (q', pvar (v ::: CT (VArrow Nothing Many _A' _A))) |- check (b ::: _B)))) ps ::: (q, _T)) b ::: _B) + (ps', b') <- bind (fieldsP (Bind (\ q' _A' b -> ([],) <$> ((q', pvar (v ::: CT (VArrow Nothing Many _A' _A))) |- b))) ps ::: (q, _T)) b pure (peff n' (fromList ps') v, b') @@ -414,11 +414,11 @@ mapSynth :: (Elab m (a ::: Type) -> Elab m (b ::: Type)) -> Synth m a -> Synth m mapSynth f = Synth . f . synth -bind :: Bind m a ::: (Quantity, Type) -> Check m b -> Check m (a, b) +bind :: Bind m a ::: (Quantity, Type) -> Elab m b -> Elab m (a, b) bind (p ::: (q, _T)) = runBind p q _T -newtype Bind m a = Bind { runBind :: forall x . Quantity -> Type -> Check m x -> Check m (a, x) } +newtype Bind m a = Bind { runBind :: forall x . Quantity -> Type -> Elab m x -> Elab m (a, x) } deriving (Functor) mapBind :: (forall x . Elab m (a, x) -> Elab m (b, x)) -> Bind m a -> Bind m b -mapBind f m = Bind $ \ q _A b -> mapCheck f (runBind m q _A b) +mapBind f m = Bind $ \ q _A b -> f (runBind m q _A b) From 4048bec1084b0ad0aed3672b1bfacb2ccc3443f2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 1 Apr 2021 18:24:48 -0400 Subject: [PATCH 0004/1324] Space out effect patterns when wrapping. --- src/Facet/Print.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 9a09e9404..57ce921b4 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -230,7 +230,7 @@ printPattern Options{ rname } = \case PCon n ps -> parens (annotate Con (rname n) $$* map vpat (toList ps)) epat = \case PAll n -> n - POp q ps k -> brackets (pretty q $$* (group . vpat <$> ps) semi <+> group k) + POp q ps k -> brackets (flatAlt space mempty <> pretty q $$* (group . vpat <$> ps) semi <+> group k <> flatAlt space mempty) printModule :: C.Module -> Print printModule (C.Module mname is _ ds) = module_ From b35a6c430cf05a99e81c729fb71249d308a6939a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 1 Apr 2021 20:08:52 -0400 Subject: [PATCH 0005/1324] Bind patterns in a single step. --- src/Facet/Elab/Term.hs | 59 +++++++++++++++++++++--------------------- 1 file changed, 29 insertions(+), 30 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index cb0dd051f..48ba70197 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -122,7 +122,7 @@ tlam b = Check $ \ _T -> do b' <- (zero, pvar (n ::: CK _A)) |- check (b ::: _B (T.free (LName d n))) pure $ XTLam n b' -lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern Name), Check m Expr)] -> Check m Expr +lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern (Name ::: Classifier)), Check m Expr)] -> Check m Expr lam cs = Check $ \ _T -> do (_A, _B) <- assertTacitFunction _T XLam <$> traverse (\ (p, b) -> bind (p ::: _A) (check (b ::: _B))) cs @@ -141,44 +141,43 @@ string s = Synth $ pure $ XString s ::: T.VString -- Pattern combinators -wildcardP :: Bind m (ValuePattern Name) -wildcardP = Bind $ \ _ _ -> fmap (PWildcard,) +wildcardP :: Bind m (ValuePattern (Name ::: Classifier)) +wildcardP = Bind $ \ _T k -> k PWildcard -varP :: (HasCallStack, Has (Throw Err) sig m) => Name -> Bind m (ValuePattern Name) -varP n = Bind $ \ q _A b -> (PVar n,) <$> ((q, pvar (n ::: CT (wrap _A))) |- b) +varP :: Name -> Bind m (ValuePattern (Name ::: Classifier)) +varP n = Bind $ \ _A k -> k (PVar (n ::: CT (wrap _A))) where wrap = \case VComp sig _A -> VArrow Nothing Many (VNe (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (VComp sig _A) _T -> _T -conP :: (HasCallStack, Has (Throw Err) sig m) => QName -> [Bind m (ValuePattern Name)] -> Bind m (ValuePattern Name) -conP n ps = Bind $ \ q _A b -> do +conP :: (HasCallStack, Has (Throw Err) sig m) => QName -> [Bind m (ValuePattern (Name ::: Classifier))] -> Bind m (ValuePattern (Name ::: Classifier)) +conP n fs = Bind $ \ _A k -> do n' :=: _ ::: _T <- resolveC n _T' <- maybe (pure _T) (foldl' (\ _T _A -> ($ _A) . snd <$> (_T >>= assertQuantifier)) (pure _T) . snd) (unNeutral _A) - (ps', b') <- bind (fieldsP (Bind (\ _q' _A' b -> ([],) <$ unify (Exp _A) (Act _A') <*> b)) ps ::: (q, _T')) b - pure (PCon n' (fromList ps'), b') + fs' <- runBind (fieldsP fs) _T' (\ (fs, _T) -> fs <$ unify (Exp _A) (Act _T)) + k $ PCon n' (fromList fs') -fieldsP :: (HasCallStack, Has (Throw Err) sig m) => Bind m [a] -> [Bind m a] -> Bind m [a] -fieldsP = foldr cons +fieldsP :: (HasCallStack, Has (Throw Err) sig m) => [Bind m a] -> Bind m ([a], Type) +fieldsP = foldr cons nil where - cons p ps = Bind $ \ q _A b -> do - (_ ::: (q', _A'), _A'') <- assertFunction _A - (p', (ps', b')) <- bind (p ::: (q', _A')) (bind (ps ::: (q, _A'')) b) - pure (p':ps', b') + cons p ps = Bind $ \ _A k -> do + (_ ::: (_, _A'), _A'') <- assertFunction _A + runBind p _A' $ \ p' -> runBind ps _A'' (k . first (p' :)) + nil = Bind $ \ _T k -> k ([], _T) -allP :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Name -> Bind m (EffectPattern Name) -allP n = Bind $ \ q _A b -> do +allP :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Name -> Bind m (EffectPattern (Name ::: Classifier)) +allP n = Bind $ \ _A k -> do (sig, _T) <- assertComp _A - (PAll n,) <$> ((q, pvar (n ::: CT (VArrow Nothing Many (VNe (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (VComp sig _T)))) |- b) + k (PAll (n ::: CT (VArrow Nothing Many (VNe (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (VComp sig _T)))) -effP :: (HasCallStack, Has (Throw Err) sig m) => QName -> [Bind m (ValuePattern Name)] -> Name -> Bind m (Pattern Name) -effP n ps v = Bind $ \ q _A b -> do +effP :: (HasCallStack, Has (Throw Err) sig m) => QName -> [Bind m (ValuePattern (Name ::: Classifier))] -> Name -> Bind m (Pattern (Name ::: Classifier)) +effP n ps v = Bind $ \ _A k -> do StaticContext{ module', graph } <- ask (sig, _A') <- assertComp _A n' ::: _T <- maybe (freeVariable n) (\ (n :=: _ ::: _T) -> instantiate const (n ::: _T)) (listToMaybe (traverse unDTerm =<< lookupInSig n module' graph [sig])) - (ps', b') <- bind (fieldsP (Bind (\ q' _A' b -> ([],) <$> ((q', pvar (v ::: CT (VArrow Nothing Many _A' _A))) |- b))) ps ::: (q, _T)) b - pure (peff n' (fromList ps') v, b') + runBind (fieldsP ps) _T $ \ (ps', _A') -> k (peff n' (fromList ps') (v ::: CT (VArrow Nothing Many _A' _A))) -- Expression elaboration @@ -213,10 +212,10 @@ checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in flip withS -- FIXME: check for unique variable names -bindPattern :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Pattern -> Bind m (Pattern Name) +bindPattern :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Pattern -> Bind m (Pattern (Name ::: Classifier)) bindPattern = go where go = withSpanB $ \case - S.PVal p -> Bind $ \ q _T -> bind (PVal <$> goVal p ::: (q, maybe _T snd (unComp _T))) + S.PVal p -> Bind $ \ _T -> runBind (PVal <$> goVal p) (maybe _T snd (unComp _T)) S.PEff p -> withSpanB (\ (S.POp n ps v) -> effP n (map goVal ps) v) p goVal = withSpanB $ \case @@ -249,7 +248,7 @@ abstractTerm body = go Nil Nil d <- depth pure $ body (TVar . Free . Right . fmap (levelToIndex d) <$> ts) (fs <*> pure d) -patternForArgType :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Type -> Name -> Bind m (Pattern Name) +patternForArgType :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Type -> Name -> Bind m (Pattern (Name ::: Classifier)) patternForArgType = \case VComp{} -> fmap PEff . allP _ -> fmap PVal . varP @@ -414,11 +413,11 @@ mapSynth :: (Elab m (a ::: Type) -> Elab m (b ::: Type)) -> Synth m a -> Synth m mapSynth f = Synth . f . synth -bind :: Bind m a ::: (Quantity, Type) -> Elab m b -> Elab m (a, b) -bind (p ::: (q, _T)) = runBind p q _T +bind :: Has (Throw Err) sig m => Bind m (Pattern (Name ::: Classifier)) ::: (Quantity, Type) -> Elab m b -> Elab m (Pattern Name, b) +bind (p ::: (q, _T)) m = runBind p _T (\ p' -> (tm <$> p',) <$> ((q, p') |- m)) -newtype Bind m a = Bind { runBind :: forall x . Quantity -> Type -> Elab m x -> Elab m (a, x) } +newtype Bind m a = Bind { runBind :: forall x . Type -> (a -> Elab m x) -> Elab m x } deriving (Functor) -mapBind :: (forall x . Elab m (a, x) -> Elab m (b, x)) -> Bind m a -> Bind m b -mapBind f m = Bind $ \ q _A b -> f (runBind m q _A b) +mapBind :: (forall x . Elab m x -> Elab m x) -> Bind m a -> Bind m a +mapBind f m = Bind $ \ _A k -> runBind m _A (f . k) From d4d4f612342ddc491fe98f52f72452eaa6da154c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Apr 2021 09:34:35 -0400 Subject: [PATCH 0006/1324] Continuations in effect patterns are bound as patterns. --- src/Facet/Core/Pattern.hs | 4 ++-- src/Facet/Elab/Term.hs | 8 +++++--- src/Facet/Eval.hs | 2 +- src/Facet/Parser.hs | 2 +- src/Facet/Print.hs | 2 +- src/Facet/Surface.hs | 2 +- 6 files changed, 11 insertions(+), 9 deletions(-) diff --git a/src/Facet/Core/Pattern.hs b/src/Facet/Core/Pattern.hs index 6c550f261..03c2666a8 100644 --- a/src/Facet/Core/Pattern.hs +++ b/src/Facet/Core/Pattern.hs @@ -23,7 +23,7 @@ data ValuePattern a data EffectPattern a = PAll a - | POp RName (Snoc (ValuePattern a)) a + | POp RName (Snoc (ValuePattern a)) (ValuePattern a) deriving (Eq, Foldable, Functor, Ord, Show, Traversable) data Pattern a @@ -37,7 +37,7 @@ pvar = PVal . PVar pcon :: RName -> Snoc (ValuePattern a) -> Pattern a pcon n fs = PVal $ PCon n fs -peff :: RName -> Snoc (ValuePattern a) -> a -> Pattern a +peff :: RName -> Snoc (ValuePattern a) -> ValuePattern a -> Pattern a peff o vs k = PEff $ POp o vs k diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 48ba70197..91c1addf9 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -172,12 +172,14 @@ allP n = Bind $ \ _A k -> do (sig, _T) <- assertComp _A k (PAll (n ::: CT (VArrow Nothing Many (VNe (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (VComp sig _T)))) -effP :: (HasCallStack, Has (Throw Err) sig m) => QName -> [Bind m (ValuePattern (Name ::: Classifier))] -> Name -> Bind m (Pattern (Name ::: Classifier)) +effP :: (HasCallStack, Has (Throw Err) sig m) => QName -> [Bind m (ValuePattern (Name ::: Classifier))] -> Bind m (ValuePattern (Name ::: Classifier)) -> Bind m (Pattern (Name ::: Classifier)) effP n ps v = Bind $ \ _A k -> do StaticContext{ module', graph } <- ask (sig, _A') <- assertComp _A n' ::: _T <- maybe (freeVariable n) (\ (n :=: _ ::: _T) -> instantiate const (n ::: _T)) (listToMaybe (traverse unDTerm =<< lookupInSig n module' graph [sig])) - runBind (fieldsP ps) _T $ \ (ps', _A') -> k (peff n' (fromList ps') (v ::: CT (VArrow Nothing Many _A' _A))) + runBind (fieldsP ps) _T $ \ (ps', _A') -> + runBind v (VArrow Nothing Many _A' _A) $ \ v' -> + k (peff n' (fromList ps') v') -- Expression elaboration @@ -216,7 +218,7 @@ bindPattern :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.P bindPattern = go where go = withSpanB $ \case S.PVal p -> Bind $ \ _T -> runBind (PVal <$> goVal p) (maybe _T snd (unComp _T)) - S.PEff p -> withSpanB (\ (S.POp n ps v) -> effP n (map goVal ps) v) p + S.PEff p -> withSpanB (\ (S.POp n ps v) -> effP n (map goVal ps) (goVal v)) p goVal = withSpanB $ \case S.PWildcard -> wildcardP diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 89610da92..793b1e04c 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -72,7 +72,7 @@ app :: (HasCallStack, Has (Reader Graph :+: Reader Module) sig m, MonadFail m) = app envCallSite hdl f a = f >>= \case VLam env cs -> k a where (h, k) = foldl' (\ (es, vs) -> \case - (PEff (POp n ps nk), b) -> ((n, Handler $ \ sp k -> traverse ($ (h <> hdl)) sp >>= \ sp -> eval (bindSpine env ps sp |> pvar (nk :=: VCont k)) hdl b) : es, vs) + (PEff (POp n ps nk), b) -> ((n, Handler $ \ sp k -> traverse ($ (h <> hdl)) sp >>= \ sp -> eval (bindSpine env ps sp |> PVal ((:=: VCont k) <$> nk)) hdl b) : es, vs) (PEff (PAll n), b) -> (es, \ a -> eval (env |> pvar (n :=: VLam envCallSite [(pvar __, a)])) hdl b) (PVal p, b) -> (es, eval envCallSite (h <> hdl) >=> fromMaybe (vs a) . matchV (\ vs -> eval (env |> PVal vs) hdl b) p)) ([], const (fail "non-exhaustive patterns in lambda")) cs VCont k -> k =<< eval envCallSite hdl a diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index 9b6949200..a2a6c4e4b 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -265,7 +265,7 @@ valuePattern = choice compPattern :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Pattern) compPattern = choice [ anned (S.PVal <$> valuePattern) - , anned (S.PEff <$> try (brackets (anned (S.POp <$> qname ename <*> many valuePattern <* symbolic ';' <*> (ename <|> N.__ <$ wildcard))))) + , anned (S.PEff <$> try (brackets (anned (S.POp <$> qname ename <*> many valuePattern <* symbolic ';' <*> valuePattern)))) ] "pattern" diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 57ce921b4..477241062 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -230,7 +230,7 @@ printPattern Options{ rname } = \case PCon n ps -> parens (annotate Con (rname n) $$* map vpat (toList ps)) epat = \case PAll n -> n - POp q ps k -> brackets (flatAlt space mempty <> pretty q $$* (group . vpat <$> ps) semi <+> group k <> flatAlt space mempty) + POp q ps k -> brackets (flatAlt space mempty <> pretty q $$* (group . vpat <$> ps) semi <+> group (vpat k) <> flatAlt space mempty) printModule :: C.Module -> Print printModule (C.Module mname is _ ds) = module_ diff --git a/src/Facet/Surface.hs b/src/Facet/Surface.hs index 189587342..d3d8d28b8 100644 --- a/src/Facet/Surface.hs +++ b/src/Facet/Surface.hs @@ -89,7 +89,7 @@ data ValPattern | PCon QName [Ann ValPattern] deriving (Eq, Show) -data EffPattern = POp QName [Ann ValPattern] Name +data EffPattern = POp QName [Ann ValPattern] (Ann ValPattern) deriving (Eq, Show) From a319e40cae86b20fb46dc4f10a2dc543e3af27cd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Apr 2021 12:49:30 -0400 Subject: [PATCH 0007/1324] :fire: effect patterns from the core language. --- src/Facet/Core/Pattern.hs | 30 +++------------------ src/Facet/Core/Term.hs | 1 - src/Facet/Core/Type.hs | 2 +- src/Facet/Elab/Term.hs | 56 +++++++++++++++++---------------------- src/Facet/Elab/Type.hs | 2 +- src/Facet/Eval.hs | 47 +++++++++----------------------- src/Facet/Norm.hs | 10 +------ src/Facet/Print.hs | 16 ++++------- src/Facet/REPL.hs | 18 ++++++------- src/Facet/Unify.hs | 2 +- 10 files changed, 58 insertions(+), 126 deletions(-) diff --git a/src/Facet/Core/Pattern.hs b/src/Facet/Core/Pattern.hs index 03c2666a8..cc921f180 100644 --- a/src/Facet/Core/Pattern.hs +++ b/src/Facet/Core/Pattern.hs @@ -1,11 +1,6 @@ module Facet.Core.Pattern ( -- * Patterns - ValuePattern(..) -, EffectPattern(..) -, Pattern(..) -, pvar -, pcon -, peff + Pattern(..) , fill ) where @@ -15,31 +10,12 @@ import Facet.Snoc -- Patterns -data ValuePattern a +data Pattern a = PWildcard | PVar a - | PCon RName (Snoc (ValuePattern a)) - deriving (Eq, Foldable, Functor, Ord, Show, Traversable) - -data EffectPattern a - = PAll a - | POp RName (Snoc (ValuePattern a)) (ValuePattern a) + | PCon RName (Snoc (Pattern a)) deriving (Eq, Foldable, Functor, Ord, Show, Traversable) -data Pattern a - = PEff (EffectPattern a) - | PVal (ValuePattern a) - deriving (Eq, Foldable, Functor, Ord, Show, Traversable) - -pvar :: a -> Pattern a -pvar = PVal . PVar - -pcon :: RName -> Snoc (ValuePattern a) -> Pattern a -pcon n fs = PVal $ PCon n fs - -peff :: RName -> Snoc (ValuePattern a) -> ValuePattern a -> Pattern a -peff o vs k = PEff $ POp o vs k - fill :: Traversable t => (b -> (b, c)) -> b -> t a -> (b, t c) fill f = mapAccumL (const . f) diff --git a/src/Facet/Core/Term.hs b/src/Facet/Core/Term.hs index 7fbb247e8..d0b420484 100644 --- a/src/Facet/Core/Term.hs +++ b/src/Facet/Core/Term.hs @@ -20,5 +20,4 @@ data Expr | XApp Expr Expr | XCon RName (Snoc Expr) | XString Text - | XOp RName (Snoc Expr) deriving (Eq, Ord, Show) diff --git a/src/Facet/Core/Type.hs b/src/Facet/Core/Type.hs index d71407c0b..8a53907ac 100644 --- a/src/Facet/Core/Type.hs +++ b/src/Facet/Core/Type.hs @@ -174,7 +174,7 @@ eval subst = go where TVar (Global n) -> global n TVar (Free (Right n)) -> index env n TVar (Free (Left m)) -> fromMaybe (metavar m) (lookupMeta m subst) - TForAll n t b -> VForAll n t (\ _T -> go (env |> pvar (n :=: _T)) b) + TForAll n t b -> VForAll n t (\ _T -> go (env |> PVar (n :=: _T)) b) TArrow n q a b -> VArrow n q (go env a) (go env b) TComp s t -> VComp (mapSignature (go env) s) (go env t) TApp f a -> go env f $$ go env a diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 91c1addf9..4bab384ff 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -17,7 +17,6 @@ module Facet.Elab.Term , conP , fieldsP , allP -, effP -- * Expression elaboration , synthExpr , checkExpr @@ -50,9 +49,10 @@ import Control.Effect.Writer (censor) import Control.Lens (at, ix) import Control.Monad ((<=<)) import Data.Bifunctor (first) +import Data.Either (partitionEithers) import Data.Foldable import Data.Functor -import Data.Maybe (catMaybes, fromMaybe, listToMaybe) +import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid (Ap(..), First(..)) import qualified Data.Set as Set import Data.Text (Text) @@ -119,7 +119,7 @@ tlam :: (HasCallStack, Has (Throw Err) sig m) => Check m Expr -> Check m Expr tlam b = Check $ \ _T -> do (n ::: _A, _B) <- assertQuantifier _T d <- depth - b' <- (zero, pvar (n ::: CK _A)) |- check (b ::: _B (T.free (LName d n))) + b' <- (zero, PVar (n ::: CK _A)) |- check (b ::: _B (T.free (LName d n))) pure $ XTLam n b' lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern (Name ::: Classifier)), Check m Expr)] -> Check m Expr @@ -127,6 +127,9 @@ lam cs = Check $ \ _T -> do (_A, _B) <- assertTacitFunction _T XLam <$> traverse (\ (p, b) -> bind (p ::: _A) (check (b ::: _B))) cs +lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Check m Expr -> Check m Expr +lam1 p b = lam [(p, b)] + app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Synth m a) -> (HasCallStack => Check m b) -> Synth m c app mk operator operand = Synth $ do f' ::: _F <- synth operator @@ -141,17 +144,17 @@ string s = Synth $ pure $ XString s ::: T.VString -- Pattern combinators -wildcardP :: Bind m (ValuePattern (Name ::: Classifier)) +wildcardP :: Bind m (Pattern (Name ::: Classifier)) wildcardP = Bind $ \ _T k -> k PWildcard -varP :: Name -> Bind m (ValuePattern (Name ::: Classifier)) +varP :: Name -> Bind m (Pattern (Name ::: Classifier)) varP n = Bind $ \ _A k -> k (PVar (n ::: CT (wrap _A))) where wrap = \case VComp sig _A -> VArrow Nothing Many (VNe (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (VComp sig _A) _T -> _T -conP :: (HasCallStack, Has (Throw Err) sig m) => QName -> [Bind m (ValuePattern (Name ::: Classifier))] -> Bind m (ValuePattern (Name ::: Classifier)) +conP :: (HasCallStack, Has (Throw Err) sig m) => QName -> [Bind m (Pattern (Name ::: Classifier))] -> Bind m (Pattern (Name ::: Classifier)) conP n fs = Bind $ \ _A k -> do n' :=: _ ::: _T <- resolveC n _T' <- maybe (pure _T) (foldl' (\ _T _A -> ($ _A) . snd <$> (_T >>= assertQuantifier)) (pure _T) . snd) (unNeutral _A) @@ -167,19 +170,10 @@ fieldsP = foldr cons nil nil = Bind $ \ _T k -> k ([], _T) -allP :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Name -> Bind m (EffectPattern (Name ::: Classifier)) +allP :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Name -> Bind m (Pattern (Name ::: Classifier)) allP n = Bind $ \ _A k -> do (sig, _T) <- assertComp _A - k (PAll (n ::: CT (VArrow Nothing Many (VNe (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (VComp sig _T)))) - -effP :: (HasCallStack, Has (Throw Err) sig m) => QName -> [Bind m (ValuePattern (Name ::: Classifier))] -> Bind m (ValuePattern (Name ::: Classifier)) -> Bind m (Pattern (Name ::: Classifier)) -effP n ps v = Bind $ \ _A k -> do - StaticContext{ module', graph } <- ask - (sig, _A') <- assertComp _A - n' ::: _T <- maybe (freeVariable n) (\ (n :=: _ ::: _T) -> instantiate const (n ::: _T)) (listToMaybe (traverse unDTerm =<< lookupInSig n module' graph [sig])) - runBind (fieldsP ps) _T $ \ (ps', _A') -> - runBind v (VArrow Nothing Many _A' _A) $ \ v' -> - k (peff n' (fromList ps') v') + k (PVar (n ::: CT (VArrow Nothing Many (VNe (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (VComp sig _T)))) -- Expression elaboration @@ -210,20 +204,21 @@ checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in flip withS S.String{} -> switch (synthExpr expr) where checkLam :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => [S.Clause] -> Check m Expr - checkLam cs = lam (map (\ (S.Clause p b) -> (bindPattern p, checkExpr b)) cs) + checkLam cs = lam (snd vs) + where + vs :: Has (Throw Err :+: Write Warn) sig m => ([QName :=: Check m Expr], [(Bind m (Pattern (Name ::: Classifier)), Check m Expr)]) + vs = partitionEithers (map (\ (S.Clause (S.Ann _ _ p) b) -> case p of + S.PVal p -> Right (bindPattern p, checkExpr b) + S.PEff (S.Ann s _ (S.POp n fs k)) -> Left $ n :=: mapCheck (pushSpan s) (foldr (lam1 . bindPattern) (checkExpr b) (fromList fs:>k))) cs) -- FIXME: check for unique variable names -bindPattern :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Pattern -> Bind m (Pattern (Name ::: Classifier)) +bindPattern :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.ValPattern -> Bind m (Pattern (Name ::: Classifier)) bindPattern = go where go = withSpanB $ \case - S.PVal p -> Bind $ \ _T -> runBind (PVal <$> goVal p) (maybe _T snd (unComp _T)) - S.PEff p -> withSpanB (\ (S.POp n ps v) -> effP n (map goVal ps) (goVal v)) p - - goVal = withSpanB $ \case S.PWildcard -> wildcardP S.PVar n -> varP n - S.PCon n ps -> conP n (map goVal ps) + S.PCon n ps -> conP n (map go ps) -- | Elaborate a type abstracted over another type’s parameters. @@ -233,7 +228,7 @@ abstractType :: (HasCallStack, Has (Throw Err) sig m) => Elab m TExpr -> Kind -> abstractType body = go where go = \case - KArrow (Just n) a b -> TForAll n a <$> ((zero, pvar (n ::: CK a)) |- go b) + KArrow (Just n) a b -> TForAll n a <$> ((zero, PVar (n ::: CK a)) |- go b) _ -> body abstractTerm :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => (Snoc TExpr -> Snoc Expr -> Expr) -> Check m Expr @@ -252,8 +247,8 @@ abstractTerm body = go Nil Nil patternForArgType :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Type -> Name -> Bind m (Pattern (Name ::: Classifier)) patternForArgType = \case - VComp{} -> fmap PEff . allP - _ -> fmap PVal . varP + VComp{} -> allP + _ -> varP -- Declarations @@ -280,12 +275,9 @@ elabInterfaceDef -> [S.Ann (Name ::: S.Ann S.Type)] -> m [Name :=: Def] elabInterfaceDef (dname ::: _T) constructors = do - mname <- view name_ cs <- for constructors $ \ (S.Ann _ _ (n ::: t)) -> do _T' <- elabType $ abstractType (checkIsType (synthType t ::: KType)) _T - -- FIXME: check that the interface is a member of the sig. - op' <- elabTerm $ check (abstractTerm (const (XOp (mname :.: n))) ::: _T') - pure $ n :=: DTerm (Just op') _T' + pure $ n :=: DTerm Nothing _T' pure [ dname :=: DInterface (scopeFromList cs) _T ] -- FIXME: add a parameter for the effect signature. @@ -299,7 +291,7 @@ elabTermDef _T expr@(S.Ann s _ _) = do where go k = Check $ \ _T -> case _T of VForAll{} -> check (tlam (go k) ::: _T) - VArrow (Just n) q _A _B -> check (lam [(PVal <$> varP n, go k)] ::: VArrow Nothing q _A _B) + VArrow (Just n) q _A _B -> check (lam [(varP n, go k)] ::: VArrow Nothing q _A _B) -- FIXME: this doesn’t do what we want for tacit definitions, i.e. where _T is itself a telescope. -- FIXME: eta-expanding here doesn’t help either because it doesn’t change the way elaboration of the surface term occurs. -- we’ve exhausted the named parameters; the rest is up to the body. diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 0940a819e..c66e48271 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -60,7 +60,7 @@ _String = IsType $ pure $ TString ::: KType forAll :: (HasCallStack, Has (Throw Err) sig m) => Name ::: IsType m Kind -> IsType m TExpr -> IsType m TExpr forAll (n ::: t) b = IsType $ do t' <- checkIsType (t ::: KType) - b' <- (zero, pvar (n ::: CK t')) |- checkIsType (b ::: KType) + b' <- (zero, PVar (n ::: CK t')) |- checkIsType (b ::: KType) pure $ TForAll n t' b' ::: KType arrow :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> IsType m a -> IsType m b -> IsType m c diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 793b1e04c..5c4467b6c 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -5,7 +5,6 @@ module Facet.Eval ( -- * Evaluation eval -- * Machinery -, Handler(..) , Eval(..) -- * Values , Value(..) @@ -14,7 +13,7 @@ module Facet.Eval , quoteV ) where -import Control.Algebra hiding (Handler) +import Control.Algebra import Control.Carrier.Reader import Control.Monad (ap, guard, liftM, (>=>)) import Control.Monad.Trans.Class @@ -36,17 +35,16 @@ import Facet.Syntax import GHC.Stack (HasCallStack) import Prelude hiding (zipWith) -eval :: (HasCallStack, Has (Reader Graph :+: Reader Module) sig m, MonadFail m) => Env (Value (Eval m)) -> [(RName, Handler (Eval m))] -> Expr -> Eval m (Value (Eval m)) -eval env hdl = \case - XVar (Global n) -> global n >>= eval env hdl +eval :: (HasCallStack, Has (Reader Graph :+: Reader Module) sig m, MonadFail m) => Env (Value (Eval m)) -> Expr -> Eval m (Value (Eval m)) +eval env = \case + XVar (Global n) -> global n >>= eval env XVar (Free n) -> var env n - XTLam _ b -> tlam (eval env hdl b) - XInst f t -> inst (eval env hdl f) t + XTLam _ b -> tlam (eval env b) + XInst f t -> inst (eval env f) t XLam cs -> lam env cs - XApp f a -> app env hdl (eval env hdl f) a - XCon n fs -> con n (eval env hdl <$> fs) + XApp f a -> app env (eval env f) a + XCon n fs -> con n (eval env <$> fs) XString s -> string s - XOp n sp -> op hdl n (flip (eval env) <$> sp) global :: Has (Reader Graph :+: Reader Module) sig m => RName -> Eval m Expr global n = do @@ -68,14 +66,11 @@ inst = const lam :: Env (Value (Eval m)) -> [(Pattern Name, Expr)] -> Eval m (Value (Eval m)) lam env cs = pure $ VLam env cs -app :: (HasCallStack, Has (Reader Graph :+: Reader Module) sig m, MonadFail m) => Env (Value (Eval m)) -> [(RName, Handler (Eval m))] -> Eval m (Value (Eval m)) -> Expr -> Eval m (Value (Eval m)) -app envCallSite hdl f a = f >>= \case +app :: (HasCallStack, Has (Reader Graph :+: Reader Module) sig m, MonadFail m) => Env (Value (Eval m)) -> Eval m (Value (Eval m)) -> Expr -> Eval m (Value (Eval m)) +app envCallSite f a = f >>= \case VLam env cs -> k a where - (h, k) = foldl' (\ (es, vs) -> \case - (PEff (POp n ps nk), b) -> ((n, Handler $ \ sp k -> traverse ($ (h <> hdl)) sp >>= \ sp -> eval (bindSpine env ps sp |> PVal ((:=: VCont k) <$> nk)) hdl b) : es, vs) - (PEff (PAll n), b) -> (es, \ a -> eval (env |> pvar (n :=: VLam envCallSite [(pvar __, a)])) hdl b) - (PVal p, b) -> (es, eval envCallSite (h <> hdl) >=> fromMaybe (vs a) . matchV (\ vs -> eval (env |> PVal vs) hdl b) p)) ([], const (fail "non-exhaustive patterns in lambda")) cs - VCont k -> k =<< eval envCallSite hdl a + k = foldl' (\ vs (p, b) -> eval envCallSite >=> fromMaybe (vs a) . matchV (\ vs -> eval (env |> vs) b) p) (const (fail "non-exhaustive patterns in lambda")) cs + VCont k -> k =<< eval envCallSite a _ -> fail "expected lambda/continuation" string :: Text -> Eval m (Value (Eval m)) @@ -84,14 +79,9 @@ string = pure . VString con :: RName -> Snoc (Eval m (Value (Eval m))) -> Eval m (Value (Eval m)) con n fs = VCon n <$> sequenceA fs -op :: MonadFail m => [(RName, Handler (Eval m))] -> RName -> Snoc ([(RName, Handler (Eval m))] -> Eval m (Value (Eval m))) -> Eval m (Value (Eval m)) -op hdl n sp = Eval $ \ k -> maybe (fail ("unhandled operation: " <> show n)) (\ (_, h) -> runEval (runHandler h sp pure) k) (find ((n ==) . fst) hdl) - -- Machinery -newtype Handler m = Handler { runHandler :: Snoc ([(RName, Handler m)] -> m (Value m)) -> (Value m -> m (Value m)) -> m (Value m) } - newtype Eval m a = Eval { runEval :: forall r . (a -> m r) -> m r } instance Functor (Eval m) where @@ -134,7 +124,7 @@ unit = VCon (NE.FromList ["Data", "Unit"] :.: U "unit") Nil -- Elimination -matchV :: (ValuePattern (Name :=: Value m) -> a) -> ValuePattern Name -> Value m -> Maybe a +matchV :: (Pattern (Name :=: Value m) -> a) -> Pattern Name -> Value m -> Maybe a matchV k p s = case p of PWildcard -> pure (k PWildcard) PVar n -> pure (k (PVar (n :=: s))) @@ -142,17 +132,6 @@ matchV k p s = case p of | VCon n' fs <- s -> k . PCon n' <$ guard (n == n') <*> zipWithM (matchV id) ps fs PCon{} -> Nothing -bindValue :: Env (Value m) -> ValuePattern Name -> Value m -> Env (Value m) -bindValue env PWildcard _ = env -bindValue env (PVar n) v = env |> pvar (n :=: v) -bindValue env (PCon _ ps) (VCon _ fs) = bindSpine env ps fs -bindValue env _ _ = env -- FIXME: probably not a good idea to fail silently - -bindSpine :: Env (Value m) -> Snoc (ValuePattern Name) -> Snoc (Value m) -> Env (Value m) -bindSpine env Nil Nil = env -bindSpine env (tp :> hp) (ts :> hs) = bindValue (bindSpine env tp ts) hp hs -bindSpine env _ _ = env -- FIXME: probably not a good idea to fail silently - -- Quotation diff --git a/src/Facet/Norm.hs b/src/Facet/Norm.hs index 96c8a0f66..ef438f492 100644 --- a/src/Facet/Norm.hs +++ b/src/Facet/Norm.hs @@ -26,7 +26,6 @@ data Norm | NTLam Name (T.Type -> Norm) | NLam [(Pattern Name, Pattern (Name :=: Norm) -> Norm)] | NNe (Var (LName Level)) (Snoc Elim) - | NOp RName (Snoc Norm) instance Eq Norm where (==) = (==) `on` quote 0 @@ -46,7 +45,6 @@ quote d = \case NTLam n b -> XTLam n (quote (succ d) (b (T.free (LName d n)))) NLam cs -> XLam (map (\ (p, b) -> let (d', p') = mapAccumL (\ d n -> (succ d, n :=: NNe (Free (LName d n)) Nil)) d p in (p, quote d' (b p'))) cs) NNe v sp -> foldl' quoteElim (XVar (fmap (levelToIndex d) <$> v)) sp - NOp n sp -> XOp n (quote d <$> sp) where quoteElim h = \case EApp n -> XApp h (quote d n) @@ -66,7 +64,6 @@ norm env = \case -- XInst f t -> norm env f `ninst` T.eval mempty env t XApp f a -> norm env f `napp` norm env a XLam cs -> NLam (map (\ (p, b) -> (p, \ p' -> norm (env |> p') b)) cs) - XOp n sp -> NOp n (norm env <$> sp) napp :: Norm -> Norm -> Norm @@ -79,15 +76,10 @@ napp f a = case f of match :: Norm -> Pattern Name -> Maybe (Pattern (Name :=: Norm)) match s = \case - PVal p' -> PVal <$> matchV s p' - PEff _ -> Nothing - -matchV :: Norm -> ValuePattern Name -> Maybe (ValuePattern (Name :=: Norm)) -matchV s = \case PWildcard -> Just PWildcard PVar n -> Just (PVar (n :=: s)) PCon n ps -> case s of - NCon n' fs -> PCon n' <$ guard (n == n') <*> zipWithM matchV fs ps + NCon n' fs -> PCon n' <$ guard (n == n') <*> zipWithM match fs ps _ -> Nothing -- ninst :: Norm -> T.Type -> Norm diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 477241062..b1e4a6c24 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -178,7 +178,7 @@ printTExpr opts@Options{ rname } = go C.TVar (Global n) -> qvar n C.TVar (Free (Right n)) -> fromMaybe (lname (indexToLevel d <$> n)) $ Env.lookup env n C.TVar (Free (Left m)) -> meta m - C.TForAll n t b -> braces (ann (intro n d ::: printKind env t)) --> go (env |> pvar (n :=: intro n d)) b + C.TForAll n t b -> braces (ann (intro n d ::: printKind env t)) --> go (env |> PVar (n :=: intro n d)) b C.TArrow Nothing q a b -> mult q (go env a) --> go env b C.TArrow (Just n) q a b -> parens (ann (intro n d ::: mult q (go env a))) --> go env b C.TComp s t -> if s == mempty then go env t else sig s <+> go env t @@ -205,12 +205,11 @@ printExpr opts@Options{ rname, instantiation } = go go env = \case C.XVar (Global n) -> qvar n C.XVar (Free n) -> fromMaybe (lname (indexToLevel d <$> n)) $ Env.lookup env n - C.XTLam n b -> let { d = level env ; v = tintro n d } in braces (braces v <+> arrow <+> go (env |> pvar (__ :=: v)) b) + C.XTLam n b -> let { d = level env ; v = tintro n d } in braces (braces v <+> arrow <+> go (env |> PVar (__ :=: v)) b) C.XInst e t -> go env e `instantiation` braces (printTExpr opts env t) C.XLam cs -> comp (commaSep (map (clause env) cs)) C.XApp f a -> go env f $$ go env a C.XCon n p -> qvar n $$* (group . go env <$> p) - C.XOp n p -> qvar n $$* (group . go env <$> p) C.XString s -> annotate Lit $ pretty (show s) where d = level env @@ -220,17 +219,12 @@ printExpr opts@Options{ rname, instantiation } = go p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) printPattern :: Options -> Pattern Print -> Print -printPattern Options{ rname } = \case - PVal p -> vpat p - PEff p -> epat p +printPattern Options{ rname } = go where - vpat = \case + go = \case PWildcard -> pretty '_' PVar n -> n - PCon n ps -> parens (annotate Con (rname n) $$* map vpat (toList ps)) - epat = \case - PAll n -> n - POp q ps k -> brackets (flatAlt space mempty <> pretty q $$* (group . vpat <$> ps) semi <+> group (vpat k) <> flatAlt space mempty) + PCon n ps -> parens (annotate Con (rname n) $$* map go (toList ps)) printModule :: C.Module -> Print printModule (C.Module mname is _ ds) = module_ diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index 600d1fda7..d35dbe870 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -204,15 +204,15 @@ showEval e = Action $ do outputDocLn (getPrint (ann (printExpr opts mempty e'' ::: printType opts mempty _T))) runEvalMain :: (Has (Error (Notice.Notice (Doc Style)) :+: Output :+: Reader Graph :+: Reader Module :+: State Options) sig m, MonadFail m) => Expr -> m Expr -runEvalMain e = runEval (E.quoteV 0 =<< eval mempty hdl e) pure - where - hdl = [(write, Handler handle)] - write = fromList ["Effect", "Console"] :.: U "write" - handle (FromList [o]) k = do - E.VString s <- o hdl - outputText s *> k unit - handle _ _ = unhandled - unhandled = throwError $ Notice.Notice (Just Notice.Error) [] (fillSep @(Doc Style) [reflow "unhandled effect operator"]) [] +runEvalMain e = runEval (E.quoteV 0 =<< eval mempty e) pure + -- where + -- hdl = [(write, Handler handle)] + -- write = fromList ["Effect", "Console"] :.: U "write" + -- handle (FromList [o]) k = do + -- E.VString s <- o hdl + -- outputText s *> k unit + -- handle _ _ = unhandled + -- unhandled = throwError $ Notice.Notice (Just Notice.Error) [] (fillSep @(Doc Style) [reflow "unhandled effect operator"]) [] showKind :: S.Ann S.Type -> Action showKind _T = Action $ do diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index a8ae3862d..bbc2277bf 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -56,7 +56,7 @@ unifyType = curry $ \case (VNe (Free (Left v1)) Nil, VNe (Free (Left v2)) Nil) -> flexFlex v1 v2 (VNe (Free (Left v1)) Nil, t2) -> solve v1 t2 (t1, VNe (Free (Left v2)) Nil) -> solve v2 t1 - (VForAll _ t1 b1, VForAll n t2 b2) -> depth >>= \ d -> evalTExpr =<< mkForAll d n <$> unifyKind t1 t2 <*> ((zero, pvar (n ::: CK t2)) |- unifyType (b1 (free (LName d n))) (b2 (free (LName d n)))) + (VForAll _ t1 b1, VForAll n t2 b2) -> depth >>= \ d -> evalTExpr =<< mkForAll d n <$> unifyKind t1 t2 <*> ((zero, PVar (n ::: CK t2)) |- unifyType (b1 (free (LName d n))) (b2 (free (LName d n)))) (VForAll{}, _) -> mismatch (VArrow _ _ a1 b1, VArrow n q a2 b2) -> VArrow n q <$> unifyType a1 a2 <*> unifyType b1 b2 (VArrow{}, _) -> mismatch From 33432bb2809d088bb1a874061e1a8a2443573bc0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Apr 2021 12:54:50 -0400 Subject: [PATCH 0008/1324] Add a note about type patterns. --- TODO.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/TODO.md b/TODO.md index 6b4e95976..14f36bc65 100644 --- a/TODO.md +++ b/TODO.md @@ -60,6 +60,8 @@ _Caveat lector: there are no guarantees of correctness or completeness on the co - Ideally, emit DWARF data. +- Type patterns, for use with type lambdas & probably quantifiers. + ### Surface From d1b6ca49cf8667bbbfb0fef2f95bc79e88a271a2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Apr 2021 12:55:24 -0400 Subject: [PATCH 0009/1324] Add a note about dictionary patterns. --- TODO.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/TODO.md b/TODO.md index 14f36bc65..90339a3ad 100644 --- a/TODO.md +++ b/TODO.md @@ -62,6 +62,8 @@ _Caveat lector: there are no guarantees of correctness or completeness on the co - Type patterns, for use with type lambdas & probably quantifiers. +- Dictionary patterns, to bind the operations of an effect interface in the scope of a handler. + ### Surface From e7e85f020b85378642faa4be8005afd9d6068cba Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Apr 2021 12:59:20 -0400 Subject: [PATCH 0010/1324] Represent constructors with lists instead of snoc lists. --- src/Facet/Core/Pattern.hs | 3 +-- src/Facet/Core/Term.hs | 3 +-- src/Facet/Elab/Term.hs | 2 +- src/Facet/Eval.hs | 7 +++---- src/Facet/Norm.hs | 2 +- 5 files changed, 7 insertions(+), 10 deletions(-) diff --git a/src/Facet/Core/Pattern.hs b/src/Facet/Core/Pattern.hs index cc921f180..c623dbe99 100644 --- a/src/Facet/Core/Pattern.hs +++ b/src/Facet/Core/Pattern.hs @@ -6,14 +6,13 @@ module Facet.Core.Pattern import Data.Traversable (mapAccumL) import Facet.Name -import Facet.Snoc -- Patterns data Pattern a = PWildcard | PVar a - | PCon RName (Snoc (Pattern a)) + | PCon RName [Pattern a] deriving (Eq, Foldable, Functor, Ord, Show, Traversable) diff --git a/src/Facet/Core/Term.hs b/src/Facet/Core/Term.hs index d0b420484..c18208139 100644 --- a/src/Facet/Core/Term.hs +++ b/src/Facet/Core/Term.hs @@ -7,7 +7,6 @@ import Data.Text (Text) import Facet.Core.Pattern import qualified Facet.Core.Type as T import Facet.Name -import Facet.Snoc import Facet.Syntax -- Term expressions @@ -18,6 +17,6 @@ data Expr | XInst Expr T.TExpr | XLam [(Pattern Name, Expr)] | XApp Expr Expr - | XCon RName (Snoc Expr) + | XCon RName [Expr] | XString Text deriving (Eq, Ord, Show) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 4bab384ff..1b6c71960 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -263,7 +263,7 @@ elabDataDef (dname ::: _K) constructors = do mname <- view name_ cs <- for constructors $ \ (S.Ann _ _ (n ::: t)) -> do c_T <- elabType $ abstractType (checkIsType (synthType t ::: KType)) _K - con' <- elabTerm $ check (abstractTerm (const (XCon (mname :.: n))) ::: c_T) + con' <- elabTerm $ check (abstractTerm (const (XCon (mname :.: n) . toList)) ::: c_T) pure $ n :=: DTerm (Just con') c_T pure $ (dname :=: DData (scopeFromList cs) _K) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 5c4467b6c..348b2f517 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -29,7 +29,6 @@ import Facet.Env as Env import Facet.Graph import Facet.Name hiding (Op) import Facet.Semialign (zipWithM) -import Facet.Snoc import Facet.Snoc.NonEmpty as NE hiding ((|>)) import Facet.Syntax import GHC.Stack (HasCallStack) @@ -76,7 +75,7 @@ app envCallSite f a = f >>= \case string :: Text -> Eval m (Value (Eval m)) string = pure . VString -con :: RName -> Snoc (Eval m (Value (Eval m))) -> Eval m (Value (Eval m)) +con :: RName -> [Eval m (Value (Eval m))] -> Eval m (Value (Eval m)) con n fs = VCon n <$> sequenceA fs @@ -110,7 +109,7 @@ data Value m -- | Neutral; variables, only used during quotation = VVar (Var (LName Level)) -- | Value; data constructors. - | VCon RName (Snoc (Value m)) + | VCon RName [Value m] -- | Value; strings. | VString Text -- | Computation; lambdas. @@ -119,7 +118,7 @@ data Value m | VCont (Value m -> m (Value m)) unit :: Value m -unit = VCon (NE.FromList ["Data", "Unit"] :.: U "unit") Nil +unit = VCon (NE.FromList ["Data", "Unit"] :.: U "unit") [] -- Elimination diff --git a/src/Facet/Norm.hs b/src/Facet/Norm.hs index ef438f492..d6ca45849 100644 --- a/src/Facet/Norm.hs +++ b/src/Facet/Norm.hs @@ -22,7 +22,7 @@ import Facet.Syntax data Norm = NString Text - | NCon RName (Snoc Norm) + | NCon RName [Norm] | NTLam Name (T.Type -> Norm) | NLam [(Pattern Name, Pattern (Name :=: Norm) -> Norm)] | NNe (Var (LName Level)) (Snoc Elim) From 8d67a9dd85e074fa36ecb96d603ffa716ec898ac Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Apr 2021 13:05:23 -0400 Subject: [PATCH 0011/1324] Define dictionary patterns. --- src/Facet/Core/Pattern.hs | 2 ++ src/Facet/Eval.hs | 1 + src/Facet/Norm.hs | 1 + src/Facet/Print.hs | 1 + 4 files changed, 5 insertions(+) diff --git a/src/Facet/Core/Pattern.hs b/src/Facet/Core/Pattern.hs index c623dbe99..55e050a14 100644 --- a/src/Facet/Core/Pattern.hs +++ b/src/Facet/Core/Pattern.hs @@ -6,6 +6,7 @@ module Facet.Core.Pattern import Data.Traversable (mapAccumL) import Facet.Name +import Facet.Syntax -- Patterns @@ -13,6 +14,7 @@ data Pattern a = PWildcard | PVar a | PCon RName [Pattern a] + | PDict [RName :=: a] deriving (Eq, Foldable, Functor, Ord, Show, Traversable) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 348b2f517..7eadb0619 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -130,6 +130,7 @@ matchV k p s = case p of PCon n ps | VCon n' fs <- s -> k . PCon n' <$ guard (n == n') <*> zipWithM (matchV id) ps fs PCon{} -> Nothing + PDict _ -> Nothing -- Quotation diff --git a/src/Facet/Norm.hs b/src/Facet/Norm.hs index d6ca45849..835f0edfe 100644 --- a/src/Facet/Norm.hs +++ b/src/Facet/Norm.hs @@ -81,6 +81,7 @@ match s = \case PCon n ps -> case s of NCon n' fs -> PCon n' <$ guard (n == n') <*> zipWithM match fs ps _ -> Nothing + PDict _ -> Nothing -- ninst :: Norm -> T.Type -> Norm -- ninst f t = case f of diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index b1e4a6c24..6bf98fbd4 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -225,6 +225,7 @@ printPattern Options{ rname } = go PWildcard -> pretty '_' PVar n -> n PCon n ps -> parens (annotate Con (rname n) $$* map go (toList ps)) + PDict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> rname n <+> equals <+> group v) os) <> flatAlt space line) printModule :: C.Module -> Print printModule (C.Module mname is _ ds) = module_ From eff807a8f34c2a0cc91629e4c7cd1328a45c365f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Apr 2021 20:41:30 -0400 Subject: [PATCH 0012/1324] Add dictionary values, normal forms, and expressions. --- src/Facet/Core/Term.hs | 1 + src/Facet/Eval.hs | 3 +++ src/Facet/Norm.hs | 3 +++ src/Facet/Print.hs | 1 + 4 files changed, 8 insertions(+) diff --git a/src/Facet/Core/Term.hs b/src/Facet/Core/Term.hs index c18208139..eed00bba6 100644 --- a/src/Facet/Core/Term.hs +++ b/src/Facet/Core/Term.hs @@ -19,4 +19,5 @@ data Expr | XApp Expr Expr | XCon RName [Expr] | XString Text + | XDict [RName :=: Expr] deriving (Eq, Ord, Show) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 7eadb0619..662740378 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -44,6 +44,7 @@ eval env = \case XApp f a -> app env (eval env f) a XCon n fs -> con n (eval env <$> fs) XString s -> string s + XDict os -> VDict <$> traverse (traverse (eval env)) os global :: Has (Reader Graph :+: Reader Module) sig m => RName -> Eval m Expr global n = do @@ -116,6 +117,7 @@ data Value m | VLam (Env (Value m)) [(Pattern Name, Expr)] -- | Computation; continuations, used in effect handlers. | VCont (Value m -> m (Value m)) + | VDict [RName :=: Value m] unit :: Value m unit = VCon (NE.FromList ["Data", "Unit"] :.: U "unit") [] @@ -142,3 +144,4 @@ quoteV d = \case VVar v -> pure (XVar (fmap (levelToIndex d) <$> v)) VCon n fs -> XCon n <$> traverse (quoteV d) fs VString s -> pure $ XString s + VDict os -> XDict <$> traverse (traverse (quoteV d)) os diff --git a/src/Facet/Norm.hs b/src/Facet/Norm.hs index 835f0edfe..8ea7b6a7d 100644 --- a/src/Facet/Norm.hs +++ b/src/Facet/Norm.hs @@ -26,6 +26,7 @@ data Norm | NTLam Name (T.Type -> Norm) | NLam [(Pattern Name, Pattern (Name :=: Norm) -> Norm)] | NNe (Var (LName Level)) (Snoc Elim) + | NDict [RName :=: Norm] instance Eq Norm where (==) = (==) `on` quote 0 @@ -45,6 +46,7 @@ quote d = \case NTLam n b -> XTLam n (quote (succ d) (b (T.free (LName d n)))) NLam cs -> XLam (map (\ (p, b) -> let (d', p') = mapAccumL (\ d n -> (succ d, n :=: NNe (Free (LName d n)) Nil)) d p in (p, quote d' (b p'))) cs) NNe v sp -> foldl' quoteElim (XVar (fmap (levelToIndex d) <$> v)) sp + NDict os -> XDict (map (fmap (quote d)) os) where quoteElim h = \case EApp n -> XApp h (quote d n) @@ -64,6 +66,7 @@ norm env = \case -- XInst f t -> norm env f `ninst` T.eval mempty env t XApp f a -> norm env f `napp` norm env a XLam cs -> NLam (map (\ (p, b) -> (p, \ p' -> norm (env |> p') b)) cs) + XDict os -> NDict (map (fmap (norm env)) os) napp :: Norm -> Norm -> Norm diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 6bf98fbd4..8ec035aaa 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -211,6 +211,7 @@ printExpr opts@Options{ rname, instantiation } = go C.XApp f a -> go env f $$ go env a C.XCon n p -> qvar n $$* (group . go env <$> p) C.XString s -> annotate Lit $ pretty (show s) + C.XDict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> rname n <+> equals <+> group (go env v)) os) <> flatAlt space line) where d = level env qvar = group . setPrec Var . rname From 4c38c0de69a98276a94b49d7570c42073c05fb90 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Apr 2021 20:45:58 -0400 Subject: [PATCH 0013/1324] Match dictionary values with dictionary patterns. --- src/Facet/Eval.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 662740378..584985d2f 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -132,7 +132,9 @@ matchV k p s = case p of PCon n ps | VCon n' fs <- s -> k . PCon n' <$ guard (n == n') <*> zipWithM (matchV id) ps fs PCon{} -> Nothing - PDict _ -> Nothing + PDict ps + | VDict os <- s -> k . PDict <$> zipWithM (\ (n1 :=: p) (n2 :=: o) -> (n1 :=: (p :=: o)) <$ guard (n1 == n2)) ps os + PDict{} -> Nothing -- Quotation From fb1f3f6daef59b39065e1e96a7a3de62c7b08069 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 2 Apr 2021 20:47:51 -0400 Subject: [PATCH 0014/1324] Match dictionary norms with dictionary patterns. --- src/Facet/Norm.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Facet/Norm.hs b/src/Facet/Norm.hs index 8ea7b6a7d..cd833a838 100644 --- a/src/Facet/Norm.hs +++ b/src/Facet/Norm.hs @@ -84,7 +84,9 @@ match s = \case PCon n ps -> case s of NCon n' fs -> PCon n' <$ guard (n == n') <*> zipWithM match fs ps _ -> Nothing - PDict _ -> Nothing + PDict ps -> case s of + NDict os -> PDict <$> zipWithM (\ (n1 :=: o) (n2 :=: p) -> (n1 :=: (p :=: o)) <$ guard (n1 == n2)) os ps + _ -> Nothing -- ninst :: Norm -> T.Type -> Norm -- ninst f t = case f of From 386c7362d6172ce9d5b6f4a9a36cae9e522ac11f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 3 Apr 2021 07:10:21 -0400 Subject: [PATCH 0015/1324] Define a bunch of typed expression constructors. --- src/Facet/Core/Term.hs | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/src/Facet/Core/Term.hs b/src/Facet/Core/Term.hs index eed00bba6..46ac52245 100644 --- a/src/Facet/Core/Term.hs +++ b/src/Facet/Core/Term.hs @@ -1,8 +1,16 @@ module Facet.Core.Term ( -- * Term expressions Expr(..) +, T(..) +, xtlam +, xinst +, xlam +, xapp +, xcon +, xstring ) where +import Control.Arrow ((***)) import Data.Text (Text) import Facet.Core.Pattern import qualified Facet.Core.Type as T @@ -21,3 +29,24 @@ data Expr | XString Text | XDict [RName :=: Expr] deriving (Eq, Ord, Show) + + +newtype T a t = T { getT :: a } + +xtlam :: Name -> T Expr b -> T Expr (T.TExpr -> b) +xtlam n (T b) = T (XTLam n b) + +xinst :: T Expr (T.TExpr -> b) -> T.TExpr -> T Expr b +xinst (T b) t = T (XInst b t) + +xlam :: [(T (Pattern Name) a, T Expr b)] -> T Expr (a -> b) +xlam cs = T (XLam (map (getT *** getT) cs)) + +xapp :: T Expr (a -> b) -> T Expr a -> T Expr b +xapp (T f) (T a) = T (XApp f a) + +xcon :: RName -> [Expr] -> T Expr c +xcon n fs = T (XCon n fs) + +xstring :: Text -> T Expr Text +xstring = T . XString From 1a44d3bcfe23ec3a501e430a1f4f3bc65088abe2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 3 Apr 2021 07:10:28 -0400 Subject: [PATCH 0016/1324] Revert "Define a bunch of typed expression constructors." This reverts commit 386c7362d6172ce9d5b6f4a9a36cae9e522ac11f. --- src/Facet/Core/Term.hs | 29 ----------------------------- 1 file changed, 29 deletions(-) diff --git a/src/Facet/Core/Term.hs b/src/Facet/Core/Term.hs index 46ac52245..eed00bba6 100644 --- a/src/Facet/Core/Term.hs +++ b/src/Facet/Core/Term.hs @@ -1,16 +1,8 @@ module Facet.Core.Term ( -- * Term expressions Expr(..) -, T(..) -, xtlam -, xinst -, xlam -, xapp -, xcon -, xstring ) where -import Control.Arrow ((***)) import Data.Text (Text) import Facet.Core.Pattern import qualified Facet.Core.Type as T @@ -29,24 +21,3 @@ data Expr | XString Text | XDict [RName :=: Expr] deriving (Eq, Ord, Show) - - -newtype T a t = T { getT :: a } - -xtlam :: Name -> T Expr b -> T Expr (T.TExpr -> b) -xtlam n (T b) = T (XTLam n b) - -xinst :: T Expr (T.TExpr -> b) -> T.TExpr -> T Expr b -xinst (T b) t = T (XInst b t) - -xlam :: [(T (Pattern Name) a, T Expr b)] -> T Expr (a -> b) -xlam cs = T (XLam (map (getT *** getT) cs)) - -xapp :: T Expr (a -> b) -> T Expr a -> T Expr b -xapp (T f) (T a) = T (XApp f a) - -xcon :: RName -> [Expr] -> T Expr c -xcon n fs = T (XCon n fs) - -xstring :: Text -> T Expr Text -xstring = T . XString From 73e9cd3513fd03e04210d270596cb06aa5a8fb04 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 3 Apr 2021 08:35:03 -0400 Subject: [PATCH 0017/1324] Generalize the ascription rule to allow checking of non-TExpr types. --- src/Facet/Elab/Term.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 1b6c71960..a41e7a7f0 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -86,9 +86,9 @@ switch (Synth m) = Check $ \ _Exp -> m >>= \case a ::: VComp req _Act -> require req >> unify (Exp _Exp) (Act _Act) $> a a ::: _Act -> unify (Exp _Exp) (Act _Act) $> a -as :: (HasCallStack, Has (Throw Err) sig m) => Check m Expr ::: IsType m TExpr -> Synth m Expr +as :: (HasCallStack, Has (Throw Err) sig m) => Check m Expr ::: IsType m Type -> Synth m Expr as (m ::: _T) = Synth $ do - _T' <- evalTExpr =<< checkIsType (_T ::: KType) + _T' <- checkIsType (_T ::: KType) a <- check (m ::: _T') pure $ a ::: _T' @@ -191,7 +191,7 @@ synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanS $ \ca synthApp :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Expr -> Synth m Expr synthApp f a = app XApp (synthExpr f) (checkExpr a) synthAs :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Type -> Synth m Expr - synthAs t _T = as (checkExpr t ::: synthType _T) + synthAs t _T = as (checkExpr t ::: mapIsType (>>= (\ (_T ::: _K) -> (::: _K) <$> evalTExpr _T)) (synthType _T)) checkExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Check m Expr From 3b0aa443997d246d3dde66215772d31f96f3b30c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 3 Apr 2021 15:48:01 -0400 Subject: [PATCH 0018/1324] Define let expressions. --- src/Facet/Core/Term.hs | 1 + src/Facet/Eval.hs | 1 + src/Facet/Norm.hs | 17 +++++++++-------- src/Facet/Print.hs | 1 + 4 files changed, 12 insertions(+), 8 deletions(-) diff --git a/src/Facet/Core/Term.hs b/src/Facet/Core/Term.hs index eed00bba6..6344940c3 100644 --- a/src/Facet/Core/Term.hs +++ b/src/Facet/Core/Term.hs @@ -20,4 +20,5 @@ data Expr | XCon RName [Expr] | XString Text | XDict [RName :=: Expr] + | XLet Name Expr Expr deriving (Eq, Ord, Show) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 584985d2f..235cc9420 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -45,6 +45,7 @@ eval env = \case XCon n fs -> con n (eval env <$> fs) XString s -> string s XDict os -> VDict <$> traverse (traverse (eval env)) os + XLet n v b -> eval env v >>= \ v' -> eval (env |> PVar (n :=: v')) b global :: Has (Reader Graph :+: Reader Module) sig m => RName -> Eval m Expr global n = do diff --git a/src/Facet/Norm.hs b/src/Facet/Norm.hs index cd833a838..762935271 100644 --- a/src/Facet/Norm.hs +++ b/src/Facet/Norm.hs @@ -54,19 +54,20 @@ quote d = \case norm :: Env Norm -> Expr -> Norm norm env = \case - XString s -> NString s - XVar v -> NNe (fmap (indexToLevel (level env)) <$> v) Nil - XCon n sp -> NCon n (norm env <$> sp) + XString s -> NString s + XVar v -> NNe (fmap (indexToLevel (level env)) <$> v) Nil + XCon n sp -> NCon n (norm env <$> sp) -- FIXME: define type patterns and extend @env@ so we can normalize XTLam correctly - XTLam _ b -> norm env b + XTLam _ b -> norm env b -- XTLam n b -> NTLam n (\ _T -> norm (env |> pvar (n :=: _T)) b) -- FIXME: define type patterns and extend @env@ so we can normalize XInst correctly -- FIXME: take a @Subst@ so we can apply substitutions in the type at the same time - XInst f _ -> norm env f + XInst f _ -> norm env f -- XInst f t -> norm env f `ninst` T.eval mempty env t - XApp f a -> norm env f `napp` norm env a - XLam cs -> NLam (map (\ (p, b) -> (p, \ p' -> norm (env |> p') b)) cs) - XDict os -> NDict (map (fmap (norm env)) os) + XApp f a -> norm env f `napp` norm env a + XLam cs -> NLam (map (\ (p, b) -> (p, \ p' -> norm (env |> p') b)) cs) + XDict os -> NDict (map (fmap (norm env)) os) + XLet n v b -> norm (env |> PVar (n :=: norm env v)) b napp :: Norm -> Norm -> Norm diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 8ec035aaa..e2d4a7c07 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -212,6 +212,7 @@ printExpr opts@Options{ rname, instantiation } = go C.XCon n p -> qvar n $$* (group . go env <$> p) C.XString s -> annotate Lit $ pretty (show s) C.XDict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> rname n <+> equals <+> group (go env v)) os) <> flatAlt space line) + C.XLet n v b -> let p = PVar (n :=: local n d) in pretty "let" <+> braces (printPattern opts (def <$> p) equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p) b where d = level env qvar = group . setPrec Var . rname From ea3b3ef8af818fa0545b117cbda3cec261fd73ac Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 3 Apr 2021 15:49:42 -0400 Subject: [PATCH 0019/1324] Let expressions bind a whole pattern. --- src/Facet/Core/Term.hs | 2 +- src/Facet/Eval.hs | 2 +- src/Facet/Norm.hs | 2 +- src/Facet/Print.hs | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Core/Term.hs b/src/Facet/Core/Term.hs index 6344940c3..548fef262 100644 --- a/src/Facet/Core/Term.hs +++ b/src/Facet/Core/Term.hs @@ -20,5 +20,5 @@ data Expr | XCon RName [Expr] | XString Text | XDict [RName :=: Expr] - | XLet Name Expr Expr + | XLet (Pattern Name) Expr Expr deriving (Eq, Ord, Show) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 235cc9420..3e9a725c5 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -45,7 +45,7 @@ eval env = \case XCon n fs -> con n (eval env <$> fs) XString s -> string s XDict os -> VDict <$> traverse (traverse (eval env)) os - XLet n v b -> eval env v >>= \ v' -> eval (env |> PVar (n :=: v')) b + XLet p v b -> eval env v >>= \ v' -> eval (env |> fmap (:=: v') p) b global :: Has (Reader Graph :+: Reader Module) sig m => RName -> Eval m Expr global n = do diff --git a/src/Facet/Norm.hs b/src/Facet/Norm.hs index 762935271..932955a92 100644 --- a/src/Facet/Norm.hs +++ b/src/Facet/Norm.hs @@ -67,7 +67,7 @@ norm env = \case XApp f a -> norm env f `napp` norm env a XLam cs -> NLam (map (\ (p, b) -> (p, \ p' -> norm (env |> p') b)) cs) XDict os -> NDict (map (fmap (norm env)) os) - XLet n v b -> norm (env |> PVar (n :=: norm env v)) b + XLet p v b -> norm (env |> fmap (:=: norm env v) p) b napp :: Norm -> Norm -> Norm diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index e2d4a7c07..ad5dbb53f 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -212,7 +212,7 @@ printExpr opts@Options{ rname, instantiation } = go C.XCon n p -> qvar n $$* (group . go env <$> p) C.XString s -> annotate Lit $ pretty (show s) C.XDict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> rname n <+> equals <+> group (go env v)) os) <> flatAlt space line) - C.XLet n v b -> let p = PVar (n :=: local n d) in pretty "let" <+> braces (printPattern opts (def <$> p) equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p) b + C.XLet p v b -> let p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) in pretty "let" <+> braces (printPattern opts (def <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p') b where d = level env qvar = group . setPrec Var . rname From 9797d12599bbaadf0b1cc1dbe21a939d9edfab4e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 3 Apr 2021 16:14:05 -0400 Subject: [PATCH 0020/1324] Pattern match in norm and eval. --- src/Facet/Eval.hs | 2 +- src/Facet/Norm.hs | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 3e9a725c5..fb4e423a0 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -45,7 +45,7 @@ eval env = \case XCon n fs -> con n (eval env <$> fs) XString s -> string s XDict os -> VDict <$> traverse (traverse (eval env)) os - XLet p v b -> eval env v >>= \ v' -> eval (env |> fmap (:=: v') p) b + XLet p v b -> eval env v >>= \ v' -> eval (env |> fromMaybe (error "eval: non-exhaustive pattern in let") (matchV id p v')) b global :: Has (Reader Graph :+: Reader Module) sig m => RName -> Eval m Expr global n = do diff --git a/src/Facet/Norm.hs b/src/Facet/Norm.hs index 932955a92..b8899a855 100644 --- a/src/Facet/Norm.hs +++ b/src/Facet/Norm.hs @@ -8,6 +8,7 @@ module Facet.Norm import Control.Monad (guard) import Data.Foldable (foldl') import Data.Function (on) +import Data.Maybe (fromMaybe) import Data.Monoid import Data.Text (Text) import Data.Traversable (mapAccumL) @@ -67,7 +68,7 @@ norm env = \case XApp f a -> norm env f `napp` norm env a XLam cs -> NLam (map (\ (p, b) -> (p, \ p' -> norm (env |> p') b)) cs) XDict os -> NDict (map (fmap (norm env)) os) - XLet p v b -> norm (env |> fmap (:=: norm env v) p) b + XLet p v b -> norm (env |> fromMaybe (error "norm: non-exhaustive pattern in let") (match (norm env v) p)) b napp :: Norm -> Norm -> Norm From ad2c6e7657df6c162eca0bbf1cf0a993117161f9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 3 Apr 2021 20:58:30 -0400 Subject: [PATCH 0021/1324] Propagate callstacks through bind. --- src/Facet/Elab/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index a41e7a7f0..36dd5854a 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -407,7 +407,7 @@ mapSynth :: (Elab m (a ::: Type) -> Elab m (b ::: Type)) -> Synth m a -> Synth m mapSynth f = Synth . f . synth -bind :: Has (Throw Err) sig m => Bind m (Pattern (Name ::: Classifier)) ::: (Quantity, Type) -> Elab m b -> Elab m (Pattern Name, b) +bind :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) ::: (Quantity, Type) -> Elab m b -> Elab m (Pattern Name, b) bind (p ::: (q, _T)) m = runBind p _T (\ p' -> (tm <$> p',) <$> ((q, p') |- m)) newtype Bind m a = Bind { runBind :: forall x . Type -> (a -> Elab m x) -> Elab m x } From 0206a8e37af7fa553a457544dacfe52d92f31c1a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 3 Apr 2021 21:10:02 -0400 Subject: [PATCH 0022/1324] Define an elab combinator for let bindings. --- src/Facet/Elab/Term.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 36dd5854a..d7f7acd76 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -11,6 +11,7 @@ module Facet.Elab.Term , lam , app , string +, let' -- * Pattern combinators , wildcardP , varP @@ -142,6 +143,13 @@ string :: Text -> Synth m Expr string s = Synth $ pure $ XString s ::: T.VString +let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Synth m Expr -> Check m Expr -> Check m Expr +let' p a b = Check $ \ _B -> do + a' ::: _A <- synth a + (p', b') <- bind (p ::: (Many, _A)) (check (b ::: _B)) + pure $ XLet p' a' b' + + -- Pattern combinators wildcardP :: Bind m (Pattern (Name ::: Classifier)) From fb55fc028a6900bb39f97c4cb82e7355ac4df703 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 4 Apr 2021 02:32:58 -0400 Subject: [PATCH 0023/1324] Parameterize Scope by the type of definitions. --- src/Facet/Core/Module.hs | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/Facet/Core/Module.hs b/src/Facet/Core/Module.hs index c16984d38..31e22014d 100644 --- a/src/Facet/Core/Module.hs +++ b/src/Facet/Core/Module.hs @@ -43,7 +43,7 @@ data Module = Module -- FIXME: record source references to operators to contextualize parse errors. , operators :: [(Op, Assoc)] -- FIXME: record source references to definitions to contextualize ambiguous name errors. - , scope :: Scope + , scope :: Scope Def } name_ :: Lens' Module MName @@ -52,7 +52,7 @@ name_ = lens (\ Module{ name } -> name) (\ m name -> (m :: Module){ name }) imports_ :: Lens' Module [Import] imports_ = lens imports (\ m imports -> m{ imports }) -scope_ :: Lens' Module Scope +scope_ :: Lens' Module (Scope Def) scope_ = lens scope (\ m scope -> m{ scope }) @@ -85,19 +85,19 @@ lookupD :: Has Empty sig m => Name -> Module -> m (RName :=: Def) lookupD n Module{ name, scope } = maybe empty (pure . first (name:.:)) (lookupScope n scope) -newtype Scope = Scope { decls :: Map.Map Name Def } +newtype Scope a = Scope { decls :: Map.Map Name a } deriving (Monoid, Semigroup) -decls_ :: Lens' Scope (Map.Map Name Def) +decls_ :: Lens' (Scope Def) (Map.Map Name Def) decls_ = coerced -scopeFromList :: [Name :=: Def] -> Scope +scopeFromList :: [Name :=: Def] -> Scope Def scopeFromList = Scope . Map.fromList . map (\ (n :=: v) -> (n, v)) -scopeToList :: Scope -> [Name :=: Def] +scopeToList :: Scope Def -> [Name :=: Def] scopeToList = map (uncurry (:=:)) . Map.toList . decls -lookupScope :: Has Empty sig m => Name -> Scope -> m (Name :=: Def) +lookupScope :: Has Empty sig m => Name -> Scope Def -> m (Name :=: Def) lookupScope n (Scope ds) = maybe empty (pure . (n :=:)) (Map.lookup n ds) @@ -106,21 +106,21 @@ newtype Import = Import { name :: MName } data Def = DTerm (Maybe Expr) Type - | DData Scope Kind - | DInterface Scope Kind - | DModule Scope Kind + | DData (Scope Def) Kind + | DInterface (Scope Def) Kind + | DModule (Scope Def) Kind unDTerm :: Has Empty sig m => Def -> m (Maybe Expr ::: Type) unDTerm = \case DTerm expr _T -> pure $ expr ::: _T _ -> empty -unDData :: Has Empty sig m => Def -> m (Scope ::: Kind) +unDData :: Has Empty sig m => Def -> m (Scope Def ::: Kind) unDData = \case DData cs _K -> pure $ cs ::: _K _ -> empty -unDInterface :: Has Empty sig m => Def -> m (Scope ::: Kind) +unDInterface :: Has Empty sig m => Def -> m (Scope Def ::: Kind) unDInterface = \case DInterface cs _K -> pure $ cs ::: _K _ -> empty From ae44d6c5fa9184f403b1eb333947e979ec194a24 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 4 Apr 2021 02:38:27 -0400 Subject: [PATCH 0024/1324] Define a Constructor type. --- src/Facet/Core/Module.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Core/Module.hs b/src/Facet/Core/Module.hs index 31e22014d..47ab4e5ff 100644 --- a/src/Facet/Core/Module.hs +++ b/src/Facet/Core/Module.hs @@ -18,6 +18,7 @@ module Facet.Core.Module , unDTerm , unDData , unDInterface +, Constructor(..) ) where import Control.Algebra @@ -124,3 +125,6 @@ unDInterface :: Has Empty sig m => Def -> m (Scope Def ::: Kind) unDInterface = \case DInterface cs _K -> pure $ cs ::: _K _ -> empty + + +newtype Constructor = Constructor { fieldTypes :: [Type] } From c092ebbca859b6ef36d6830aa30e24715092a526 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 4 Apr 2021 02:40:29 -0400 Subject: [PATCH 0025/1324] Revert "Define a Constructor type." This reverts commit ae44d6c5fa9184f403b1eb333947e979ec194a24. --- src/Facet/Core/Module.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Facet/Core/Module.hs b/src/Facet/Core/Module.hs index 47ab4e5ff..31e22014d 100644 --- a/src/Facet/Core/Module.hs +++ b/src/Facet/Core/Module.hs @@ -18,7 +18,6 @@ module Facet.Core.Module , unDTerm , unDData , unDInterface -, Constructor(..) ) where import Control.Algebra @@ -125,6 +124,3 @@ unDInterface :: Has Empty sig m => Def -> m (Scope Def ::: Kind) unDInterface = \case DInterface cs _K -> pure $ cs ::: _K _ -> empty - - -newtype Constructor = Constructor { fieldTypes :: [Type] } From 12246b25832f9d4b613a735890cecf16c43e6244 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 4 Apr 2021 21:26:17 -0400 Subject: [PATCH 0026/1324] Define a module for Kind. --- facet.cabal | 1 + src/Facet/Core/Kind.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Core/Kind.hs diff --git a/facet.cabal b/facet.cabal index ef92f755b..d56e861ce 100644 --- a/facet.cabal +++ b/facet.cabal @@ -74,6 +74,7 @@ library Facet.Carrier.Write.Inject Facet.CLI Facet.Context + Facet.Core.Kind Facet.Core.Module Facet.Core.Pattern Facet.Core.Term diff --git a/src/Facet/Core/Kind.hs b/src/Facet/Core/Kind.hs new file mode 100644 index 000000000..ad3a5e0c8 --- /dev/null +++ b/src/Facet/Core/Kind.hs @@ -0,0 +1,2 @@ +module Facet.Core.Kind +() where From 71f7778b09d3e04e1d76c1133fc574b0fdc71089 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 4 Apr 2021 21:29:06 -0400 Subject: [PATCH 0027/1324] Move Kind into its own module. --- src/Facet/Core/Kind.hs | 13 ++++++++++++- src/Facet/Core/Type.hs | 10 +--------- 2 files changed, 13 insertions(+), 10 deletions(-) diff --git a/src/Facet/Core/Kind.hs b/src/Facet/Core/Kind.hs index ad3a5e0c8..e71a11e2e 100644 --- a/src/Facet/Core/Kind.hs +++ b/src/Facet/Core/Kind.hs @@ -1,2 +1,13 @@ module Facet.Core.Kind -() where +( Kind(..) +) where + +import Facet.Name + +-- Kinds + +data Kind + = KType + | KInterface + | KArrow (Maybe Name) Kind Kind + deriving (Eq, Ord, Show) diff --git a/src/Facet/Core/Type.hs b/src/Facet/Core/Type.hs index 8a53907ac..4cda0903a 100644 --- a/src/Facet/Core/Type.hs +++ b/src/Facet/Core/Type.hs @@ -33,6 +33,7 @@ import Data.Foldable (foldl') import Data.Function (on, (&)) import Data.Maybe (fromMaybe) import qualified Data.Set as Set +import Facet.Core.Kind import Facet.Core.Pattern import Facet.Env hiding (empty) import Facet.Name @@ -43,15 +44,6 @@ import Facet.Usage hiding (singleton) import GHC.Stack import Prelude hiding (lookup) --- Kinds - -data Kind - = KType - | KInterface - | KArrow (Maybe Name) Kind Kind - deriving (Eq, Ord, Show) - - -- Types data Interface a = Interface RName (Snoc a) From 16fb5d3b5afb9d81b97fe7660e8dd6dbf56dc8aa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 4 Apr 2021 21:29:44 -0400 Subject: [PATCH 0028/1324] Define a Facet.Core.Type.Norm module. --- facet.cabal | 1 + src/Facet/Core/Type/Norm.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Core/Type/Norm.hs diff --git a/facet.cabal b/facet.cabal index d56e861ce..e31034b7f 100644 --- a/facet.cabal +++ b/facet.cabal @@ -79,6 +79,7 @@ library Facet.Core.Pattern Facet.Core.Term Facet.Core.Type + Facet.Core.Type.Norm Facet.Diff Facet.Driver Facet.Effect.Parser diff --git a/src/Facet/Core/Type/Norm.hs b/src/Facet/Core/Type/Norm.hs new file mode 100644 index 000000000..3e803e32a --- /dev/null +++ b/src/Facet/Core/Type/Norm.hs @@ -0,0 +1,2 @@ +module Facet.Core.Type.Norm +() where From 55f49b78d4b4cbd0a13730318462945adab6ee5f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 4 Apr 2021 21:30:21 -0400 Subject: [PATCH 0029/1324] Define a Facet.Core.Type.Expr module. --- facet.cabal | 1 + src/Facet/Core/Type/Expr.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Core/Type/Expr.hs diff --git a/facet.cabal b/facet.cabal index e31034b7f..9912592ed 100644 --- a/facet.cabal +++ b/facet.cabal @@ -79,6 +79,7 @@ library Facet.Core.Pattern Facet.Core.Term Facet.Core.Type + Facet.Core.Type.Expr Facet.Core.Type.Norm Facet.Diff Facet.Driver diff --git a/src/Facet/Core/Type/Expr.hs b/src/Facet/Core/Type/Expr.hs new file mode 100644 index 000000000..91382f919 --- /dev/null +++ b/src/Facet/Core/Type/Expr.hs @@ -0,0 +1,2 @@ +module Facet.Core.Type.Expr +() where From 8c739e41ad8096c2f1d255a962db94426dd80f6b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 4 Apr 2021 21:32:54 -0400 Subject: [PATCH 0030/1324] Define a Facet.Core.Interface module. --- facet.cabal | 1 + src/Facet/Core/Interface.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Core/Interface.hs diff --git a/facet.cabal b/facet.cabal index 9912592ed..73432e196 100644 --- a/facet.cabal +++ b/facet.cabal @@ -74,6 +74,7 @@ library Facet.Carrier.Write.Inject Facet.CLI Facet.Context + Facet.Core.Interface Facet.Core.Kind Facet.Core.Module Facet.Core.Pattern diff --git a/src/Facet/Core/Interface.hs b/src/Facet/Core/Interface.hs new file mode 100644 index 000000000..7a2779578 --- /dev/null +++ b/src/Facet/Core/Interface.hs @@ -0,0 +1,2 @@ +module Facet.Core.Interface +() where From 57966c397902d1a1881c368f3bdbb0f9a13fb78c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 4 Apr 2021 21:34:04 -0400 Subject: [PATCH 0031/1324] Extract Interface & Signature to Facet.Core.Interface. --- src/Facet/Core/Interface.hs | 30 ++++++++++++++++++++++- src/Facet/Core/Type.hs | 49 ++++++++++++------------------------- 2 files changed, 44 insertions(+), 35 deletions(-) diff --git a/src/Facet/Core/Interface.hs b/src/Facet/Core/Interface.hs index 7a2779578..6a77d94e8 100644 --- a/src/Facet/Core/Interface.hs +++ b/src/Facet/Core/Interface.hs @@ -1,2 +1,30 @@ module Facet.Core.Interface -() where +( Interface(..) +, Signature(..) +, fromInterfaces +, singleton +, interfaces +, mapSignature +) where + +import qualified Data.Set as Set +import Facet.Name +import Facet.Snoc + +data Interface a = Interface RName (Snoc a) + deriving (Eq, Foldable, Functor, Ord, Show, Traversable) + +newtype Signature a = Signature { getSignature :: Set.Set (Interface a) } + deriving (Eq, Foldable, Monoid, Ord, Semigroup, Show) + +fromInterfaces :: Ord a => [Interface a] -> Signature a +fromInterfaces = Signature . Set.fromList + +singleton :: Interface a -> Signature a +singleton = Signature . Set.singleton + +interfaces :: Signature a -> [Interface a] +interfaces = Set.toList . getSignature + +mapSignature :: Ord b => (a -> b) -> Signature a -> Signature b +mapSignature f = Signature . Set.map (fmap f) . getSignature diff --git a/src/Facet/Core/Type.hs b/src/Facet/Core/Type.hs index 4cda0903a..a81e74806 100644 --- a/src/Facet/Core/Type.hs +++ b/src/Facet/Core/Type.hs @@ -28,43 +28,24 @@ module Facet.Core.Type , apply ) where -import Control.Effect.Empty -import Data.Foldable (foldl') -import Data.Function (on, (&)) -import Data.Maybe (fromMaybe) -import qualified Data.Set as Set -import Facet.Core.Kind -import Facet.Core.Pattern -import Facet.Env hiding (empty) -import Facet.Name -import Facet.Snoc -import Facet.Subst -import Facet.Syntax -import Facet.Usage hiding (singleton) -import GHC.Stack -import Prelude hiding (lookup) +import Control.Effect.Empty +import Data.Foldable (foldl') +import Data.Function (on, (&)) +import Data.Maybe (fromMaybe) +import Facet.Core.Interface +import Facet.Core.Kind +import Facet.Core.Pattern +import Facet.Env hiding (empty) +import Facet.Name +import Facet.Snoc +import Facet.Subst +import Facet.Syntax +import Facet.Usage hiding (singleton) +import GHC.Stack +import Prelude hiding (lookup) -- Types -data Interface a = Interface RName (Snoc a) - deriving (Eq, Foldable, Functor, Ord, Show, Traversable) - -newtype Signature a = Signature { getSignature :: Set.Set (Interface a) } - deriving (Eq, Foldable, Monoid, Ord, Semigroup, Show) - -fromInterfaces :: Ord a => [Interface a] -> Signature a -fromInterfaces = Signature . Set.fromList - -singleton :: Interface a -> Signature a -singleton = Signature . Set.singleton - -interfaces :: Signature a -> [Interface a] -interfaces = Set.toList . getSignature - -mapSignature :: Ord b => (a -> b) -> Signature a -> Signature b -mapSignature f = Signature . Set.map (fmap f) . getSignature - - data Type = VString | VForAll Name Kind (Type -> Type) From 57d337b9e5aa255b505672e3101900dfc5b198f5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 4 Apr 2021 21:36:29 -0400 Subject: [PATCH 0032/1324] Move type expressions into Facet.Core.Type.Expr. --- src/Facet/Core/Type.hs | 13 +------------ src/Facet/Core/Type/Expr.hs | 18 +++++++++++++++++- 2 files changed, 18 insertions(+), 13 deletions(-) diff --git a/src/Facet/Core/Type.hs b/src/Facet/Core/Type.hs index a81e74806..0d3f2cfdf 100644 --- a/src/Facet/Core/Type.hs +++ b/src/Facet/Core/Type.hs @@ -35,6 +35,7 @@ import Data.Maybe (fromMaybe) import Facet.Core.Interface import Facet.Core.Kind import Facet.Core.Pattern +import Facet.Core.Type.Expr import Facet.Env hiding (empty) import Facet.Name import Facet.Snoc @@ -118,18 +119,6 @@ _ $$ _ = error "can’t apply non-neutral/forall type" infixl 9 $$, $$* --- Type expressions - -data TExpr - = TString - | TVar (Var (Either Meta (LName Index))) - | TForAll Name Kind TExpr - | TArrow (Maybe Name) Quantity TExpr TExpr - | TComp (Signature TExpr) TExpr - | TApp TExpr TExpr - deriving (Eq, Ord, Show) - - -- Quotation quote :: Level -> Type -> TExpr diff --git a/src/Facet/Core/Type/Expr.hs b/src/Facet/Core/Type/Expr.hs index 91382f919..19036a319 100644 --- a/src/Facet/Core/Type/Expr.hs +++ b/src/Facet/Core/Type/Expr.hs @@ -1,2 +1,18 @@ module Facet.Core.Type.Expr -() where +( TExpr(..) +) where + +import Facet.Core.Interface +import Facet.Core.Kind +import Facet.Name +import Facet.Syntax +import Facet.Usage + +data TExpr + = TString + | TVar (Var (Either Meta (LName Index))) + | TForAll Name Kind TExpr + | TArrow (Maybe Name) Quantity TExpr TExpr + | TComp (Signature TExpr) TExpr + | TApp TExpr TExpr + deriving (Eq, Ord, Show) From e27b2f786418005069f8dc01f8002657ac7a934a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 4 Apr 2021 21:39:51 -0400 Subject: [PATCH 0033/1324] Move Type into Facet.Core.Type.Norm. --- src/Facet/Core/Type.hs | 113 +----------------------------- src/Facet/Core/Type/Norm.hs | 135 +++++++++++++++++++++++++++++++++++- 2 files changed, 135 insertions(+), 113 deletions(-) diff --git a/src/Facet/Core/Type.hs b/src/Facet/Core/Type.hs index 0d3f2cfdf..7449b5d85 100644 --- a/src/Facet/Core/Type.hs +++ b/src/Facet/Core/Type.hs @@ -28,118 +28,7 @@ module Facet.Core.Type , apply ) where -import Control.Effect.Empty -import Data.Foldable (foldl') -import Data.Function (on, (&)) -import Data.Maybe (fromMaybe) import Facet.Core.Interface import Facet.Core.Kind -import Facet.Core.Pattern import Facet.Core.Type.Expr -import Facet.Env hiding (empty) -import Facet.Name -import Facet.Snoc -import Facet.Subst -import Facet.Syntax -import Facet.Usage hiding (singleton) -import GHC.Stack -import Prelude hiding (lookup) - --- Types - -data Type - = VString - | VForAll Name Kind (Type -> Type) - | VArrow (Maybe Name) Quantity Type Type - | VNe (Var (Either Meta (LName Level))) (Snoc Type) - | VComp (Signature Type) Type - -instance Eq Type where - (==) = (==) `on` quote 0 - -instance Ord Type where - compare = compare `on` quote 0 - - -global :: RName -> Type -global = var . Global - -free :: LName Level -> Type -free = var . Free . Right - -metavar :: Meta -> Type -metavar = var . Free . Left - - -var :: Var (Either Meta (LName Level)) -> Type -var v = VNe v Nil - - -unNeutral :: Has Empty sig m => Type -> m (Var (Either Meta (LName Level)), Snoc Type) -unNeutral = \case - VNe h sp -> pure (h, sp) - _ -> empty - -unComp :: Has Empty sig m => Type -> m (Signature Type, Type) -unComp = \case - VComp sig _T -> pure (sig, _T) - _T -> empty - - -data Classifier - = CK Kind - | CT Type - -classifierType :: Classifier -> Maybe Type -classifierType = \case - CK _K -> empty - CT _T -> pure _T - - -occursIn :: Meta -> Level -> Type -> Bool -occursIn p = go - where - go d = \case - VForAll n _ b -> go (succ d) (b (free (LName d n))) - VArrow _ _ a b -> go d a || go d b - VComp s t -> any (go d) s || go d t - VNe h sp -> any (either (== p) (const False)) h || any (go d) sp - VString -> False - - --- Elimination - -($$) :: HasCallStack => Type -> Type -> Type -VNe h es $$ a = VNe h (es :> a) -_ $$ _ = error "can’t apply non-neutral/forall type" - -($$*) :: (HasCallStack, Foldable t) => Type -> t Type -> Type -($$*) = foldl' ($$) - -infixl 9 $$, $$* - - --- Quotation - -quote :: Level -> Type -> TExpr -quote d = \case - VString -> TString - VForAll n t b -> TForAll n t (quote (succ d) (b (free (LName d n)))) - VArrow n q a b -> TArrow n q (quote d a) (quote d b) - VComp s t -> TComp (mapSignature (quote d) s) (quote d t) - VNe n sp -> foldl' (&) (TVar (fmap (fmap (levelToIndex d)) <$> n)) (flip TApp . quote d <$> sp) - -eval :: HasCallStack => Subst Type -> Env Type -> TExpr -> Type -eval subst = go where - go env = \case - TString -> VString - TVar (Global n) -> global n - TVar (Free (Right n)) -> index env n - TVar (Free (Left m)) -> fromMaybe (metavar m) (lookupMeta m subst) - TForAll n t b -> VForAll n t (\ _T -> go (env |> PVar (n :=: _T)) b) - TArrow n q a b -> VArrow n q (go env a) (go env b) - TComp s t -> VComp (mapSignature (go env) s) (go env t) - TApp f a -> go env f $$ go env a - -apply :: HasCallStack => Subst Type -> Env Type -> Type -> Type -apply subst env = eval subst env . quote (level env) +import Facet.Core.Type.Norm diff --git a/src/Facet/Core/Type/Norm.hs b/src/Facet/Core/Type/Norm.hs index 3e803e32a..f6ded69f7 100644 --- a/src/Facet/Core/Type/Norm.hs +++ b/src/Facet/Core/Type/Norm.hs @@ -1,2 +1,135 @@ module Facet.Core.Type.Norm -() where +( -- * Types + Type(..) +, global +, free +, metavar +, unNeutral +, unComp +, Classifier(..) +, classifierType +, occursIn + -- ** Elimination +, ($$) +, ($$*) + -- * Quotation +, quote +, eval +, apply +) where + +import Control.Effect.Empty +import Data.Foldable (foldl') +import Data.Function (on, (&)) +import Data.Maybe (fromMaybe) +import Facet.Core.Interface +import Facet.Core.Kind +import Facet.Core.Pattern +import Facet.Core.Type.Expr +import Facet.Env hiding (empty) +import Facet.Name +import Facet.Snoc +import Facet.Subst +import Facet.Syntax +import Facet.Usage hiding (singleton) +import GHC.Stack +import Prelude hiding (lookup) + +-- Types + +data Type + = VString + | VForAll Name Kind (Type -> Type) + | VArrow (Maybe Name) Quantity Type Type + | VNe (Var (Either Meta (LName Level))) (Snoc Type) + | VComp (Signature Type) Type + +instance Eq Type where + (==) = (==) `on` quote 0 + +instance Ord Type where + compare = compare `on` quote 0 + + +global :: RName -> Type +global = var . Global + +free :: LName Level -> Type +free = var . Free . Right + +metavar :: Meta -> Type +metavar = var . Free . Left + + +var :: Var (Either Meta (LName Level)) -> Type +var v = VNe v Nil + + +unNeutral :: Has Empty sig m => Type -> m (Var (Either Meta (LName Level)), Snoc Type) +unNeutral = \case + VNe h sp -> pure (h, sp) + _ -> empty + +unComp :: Has Empty sig m => Type -> m (Signature Type, Type) +unComp = \case + VComp sig _T -> pure (sig, _T) + _T -> empty + + +data Classifier + = CK Kind + | CT Type + +classifierType :: Classifier -> Maybe Type +classifierType = \case + CK _K -> empty + CT _T -> pure _T + + +occursIn :: Meta -> Level -> Type -> Bool +occursIn p = go + where + go d = \case + VForAll n _ b -> go (succ d) (b (free (LName d n))) + VArrow _ _ a b -> go d a || go d b + VComp s t -> any (go d) s || go d t + VNe h sp -> any (either (== p) (const False)) h || any (go d) sp + VString -> False + + +-- Elimination + +($$) :: HasCallStack => Type -> Type -> Type +VNe h es $$ a = VNe h (es :> a) +_ $$ _ = error "can’t apply non-neutral/forall type" + +($$*) :: (HasCallStack, Foldable t) => Type -> t Type -> Type +($$*) = foldl' ($$) + +infixl 9 $$, $$* + + +-- Quotation + +quote :: Level -> Type -> TExpr +quote d = \case + VString -> TString + VForAll n t b -> TForAll n t (quote (succ d) (b (free (LName d n)))) + VArrow n q a b -> TArrow n q (quote d a) (quote d b) + VComp s t -> TComp (mapSignature (quote d) s) (quote d t) + VNe n sp -> foldl' (&) (TVar (fmap (fmap (levelToIndex d)) <$> n)) (flip TApp . quote d <$> sp) + +eval :: HasCallStack => Subst Type -> Env Type -> TExpr -> Type +eval subst = go where + go env = \case + TString -> VString + TVar (Global n) -> global n + TVar (Free (Right n)) -> index env n + TVar (Free (Left m)) -> fromMaybe (metavar m) (lookupMeta m subst) + TForAll n t b -> VForAll n t (\ _T -> go (env |> PVar (n :=: _T)) b) + TArrow n q a b -> VArrow n q (go env a) (go env b) + TComp s t -> VComp (mapSignature (go env) s) (go env t) + TApp f a -> go env f $$ go env a + +apply :: HasCallStack => Subst Type -> Env Type -> Type -> Type +apply subst env = eval subst env . quote (level env) From 54e47743de0ed69e81c5b601e62ce3ae32b2c463 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 4 Apr 2021 21:52:41 -0400 Subject: [PATCH 0034/1324] :fire: re-exports of kinds/interfaces. --- src/Facet/Core/Module.hs | 1 + src/Facet/Core/Type.hs | 14 ++------------ src/Facet/Elab.hs | 2 ++ src/Facet/Elab/Term.hs | 2 ++ src/Facet/Elab/Type.hs | 2 ++ src/Facet/Notice/Elab.hs | 3 ++- src/Facet/Print.hs | 20 +++++++++++--------- src/Facet/REPL.hs | 4 ++-- src/Facet/Unify.hs | 2 ++ test/Facet/Core/Type/Test.hs | 1 + 10 files changed, 27 insertions(+), 24 deletions(-) diff --git a/src/Facet/Core/Module.hs b/src/Facet/Core/Module.hs index 31e22014d..87568b9b7 100644 --- a/src/Facet/Core/Module.hs +++ b/src/Facet/Core/Module.hs @@ -28,6 +28,7 @@ import Control.Monad ((<=<)) import Data.Bifunctor (first) import Data.Coerce import qualified Data.Map as Map +import Facet.Core.Kind import Facet.Core.Term import Facet.Core.Type import Facet.Name diff --git a/src/Facet/Core/Type.hs b/src/Facet/Core/Type.hs index 7449b5d85..d52d4e8e9 100644 --- a/src/Facet/Core/Type.hs +++ b/src/Facet/Core/Type.hs @@ -1,14 +1,6 @@ module Facet.Core.Type -( -- * Kinds - Kind(..) - -- * Types -, Interface(..) -, Signature(..) -, fromInterfaces -, singleton -, interfaces -, mapSignature -, Type(..) +( -- * Types + Type(..) , global , free , metavar @@ -28,7 +20,5 @@ module Facet.Core.Type , apply ) where -import Facet.Core.Interface -import Facet.Core.Kind import Facet.Core.Type.Expr import Facet.Core.Type.Norm diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index d3044bbeb..73e7f3e47 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -61,6 +61,8 @@ import Control.Monad (unless, (<=<)) import Data.Foldable (for_) import Facet.Context hiding (empty) import qualified Facet.Context as Context (empty) +import Facet.Core.Interface +import Facet.Core.Kind import Facet.Core.Module import Facet.Core.Pattern import Facet.Core.Term as E diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index d7f7acd76..c8cb33106 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -59,6 +59,8 @@ import qualified Data.Set as Set import Data.Text (Text) import Data.Traversable (for, mapAccumL) import Facet.Context (toEnv) +import Facet.Core.Interface +import Facet.Core.Kind import Facet.Core.Module as Module import Facet.Core.Pattern import Facet.Core.Term as E diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index c66e48271..adbda17f3 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -22,6 +22,8 @@ import Control.Monad (unless) import Data.Bifunctor (first) import Data.Foldable (foldl') import Data.Functor (($>)) +import Facet.Core.Interface +import Facet.Core.Kind import Facet.Core.Module import Facet.Core.Pattern import Facet.Core.Type diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index a4653f90a..05041952b 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -9,7 +9,8 @@ import Data.Semigroup (stimes) import qualified Facet.Carrier.Throw.Inject as L import qualified Facet.Carrier.Write.Inject as L import Facet.Context -import Facet.Core.Type (Classifier(..), apply, free, interfaces, metavar) +import Facet.Core.Interface (interfaces) +import Facet.Core.Type (Classifier(..), apply, free, metavar) import Facet.Elab as Elab import qualified Facet.Env as Env import Facet.Name (LName(..)) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index ad5dbb53f..c4747a152 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -35,6 +35,8 @@ import Data.Foldable (foldl', toList) import Data.Maybe (fromMaybe) import qualified Data.Text as T import Data.Traversable (mapAccumL) +import Facet.Core.Interface +import Facet.Core.Kind import qualified Facet.Core.Module as C import Facet.Core.Pattern import qualified Facet.Core.Term as C @@ -155,19 +157,19 @@ printSubject opts env = \case C.CK k -> printKind env k C.CT t -> printType opts env t -printKind :: Env Print -> C.Kind -> Print +printKind :: Env Print -> Kind -> Print printKind env = \case - C.KType -> annotate Type $ pretty "Type" - C.KInterface -> annotate Type $ pretty "Interface" - C.KArrow Nothing a b -> printKind env a --> printKind env b - C.KArrow (Just n) a b -> parens (ann (intro n d ::: printKind env a)) --> printKind env b + KType -> annotate Type $ pretty "Type" + KInterface -> annotate Type $ pretty "Interface" + KArrow Nothing a b -> printKind env a --> printKind env b + KArrow (Just n) a b -> parens (ann (intro n d ::: printKind env a)) --> printKind env b where d = level env printType :: Options -> Env Print -> C.Type -> Print printType opts env = printTExpr opts env . CT.quote (level env) -printInterface :: Options -> Env Print -> C.Interface C.Type -> Print +printInterface :: Options -> Env Print -> Interface C.Type -> Print printInterface = printInterfaceWith printType printTExpr :: Options -> Env Print -> C.TExpr -> Print @@ -186,15 +188,15 @@ printTExpr opts@Options{ rname } = go C.TString -> annotate Type $ pretty "String" where d = level env - sig s = brackets (commaSep (map (interface env) (C.interfaces s))) + sig s = brackets (commaSep (map (interface env) (interfaces s))) interface = printInterfaceWith printTExpr opts mult q = if | q == zero -> (pretty '0' <+>) | q == one -> (pretty '1' <+>) | otherwise -> id -printInterfaceWith :: (Options -> Env Print -> a -> Print) -> Options -> Env Print -> C.Interface a -> Print -printInterfaceWith with opts@Options{ rname } env (C.Interface h sp) = rname h $$* fmap (with opts env) sp +printInterfaceWith :: (Options -> Env Print -> a -> Print) -> Options -> Env Print -> Interface a -> Print +printInterfaceWith with opts@Options{ rname } env (Interface h sp) = rname h $$* fmap (with opts env) sp printNorm :: Options -> Env Print -> N.Norm -> Print printNorm opts env = printExpr opts env . N.quote (level env) diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index d35dbe870..f87748619 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -29,9 +29,9 @@ import Facet.Carrier.Readline.Haskeline import qualified Facet.Carrier.Throw.Inject as I import Facet.Carrier.Write.General import qualified Facet.Carrier.Write.Inject as I +import Facet.Core.Interface as I import Facet.Core.Module import Facet.Core.Term (Expr) -import Facet.Core.Type as T hiding (eval) import Facet.Driver import qualified Facet.Elab as Elab import qualified Facet.Elab.Term as Elab @@ -198,7 +198,7 @@ showType e = Action $ do outputDocLn (getPrint (ann (printExpr opts mempty e ::: printType opts mempty _T))) showEval e = Action $ do - e' ::: _T <- runElab $ Elab.elabSynthTerm $ locally Elab.sig_ (T.singleton (T.Interface (["Effect", "Console"]:.:U "Output") Nil) :) $ Elab.synth (Elab.synthExpr e) + e' ::: _T <- runElab $ Elab.elabSynthTerm $ locally Elab.sig_ (I.singleton (I.Interface (["Effect", "Console"]:.:U "Output") Nil) :) $ Elab.synth (Elab.synthExpr e) e'' <- runElab $ runEvalMain e' opts <- get outputDocLn (getPrint (ann (printExpr opts mempty e'' ::: printType opts mempty _T))) diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index bbc2277bf..09e79ccd5 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -18,6 +18,8 @@ import Control.Effect.Sum import Control.Effect.Writer import Control.Monad (unless) import Facet.Carrier.Throw.Inject +import Facet.Core.Interface +import Facet.Core.Kind import Facet.Core.Pattern import Facet.Core.Type import Facet.Elab diff --git a/test/Facet/Core/Type/Test.hs b/test/Facet/Core/Type/Test.hs index fe4856fec..844fca038 100644 --- a/test/Facet/Core/Type/Test.hs +++ b/test/Facet/Core/Type/Test.hs @@ -4,6 +4,7 @@ module Facet.Core.Type.Test ( tests ) where +import Facet.Core.Kind import Facet.Core.Type import Facet.Env import Facet.Name From 7af0b3cade1a7911b5d0f7d99ad49fccf07cf4ff Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 4 Apr 2021 21:53:28 -0400 Subject: [PATCH 0035/1324] Re-export the entire Type module. --- src/Facet/Core/Type.hs | 18 +----------------- 1 file changed, 1 insertion(+), 17 deletions(-) diff --git a/src/Facet/Core/Type.hs b/src/Facet/Core/Type.hs index d52d4e8e9..a7a332f7e 100644 --- a/src/Facet/Core/Type.hs +++ b/src/Facet/Core/Type.hs @@ -1,23 +1,7 @@ module Facet.Core.Type -( -- * Types - Type(..) -, global -, free -, metavar -, unNeutral -, unComp -, Classifier(..) -, classifierType -, occursIn - -- ** Elimination -, ($$) -, ($$*) +( module Facet.Core.Type.Norm -- * Type expressions , TExpr(..) - -- * Quotation -, quote -, eval -, apply ) where import Facet.Core.Type.Expr From 12819d2ea6957933474427fa2008e3c48e8c4a85 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 4 Apr 2021 21:54:00 -0400 Subject: [PATCH 0036/1324] Re-export the entire type expression module. --- src/Facet/Core/Type.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Core/Type.hs b/src/Facet/Core/Type.hs index a7a332f7e..b585b8e8d 100644 --- a/src/Facet/Core/Type.hs +++ b/src/Facet/Core/Type.hs @@ -1,7 +1,7 @@ module Facet.Core.Type ( module Facet.Core.Type.Norm -- * Type expressions -, TExpr(..) +, module Facet.Core.Type.Expr ) where import Facet.Core.Type.Expr From 4f5003f021d660286f97456a1b32e0d7e2a7ebbc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 4 Apr 2021 21:56:51 -0400 Subject: [PATCH 0037/1324] :fire: the re-export of Facet.Core.Type.Expr. --- src/Facet/Core/Term.hs | 2 +- src/Facet/Core/Type.hs | 3 --- src/Facet/Elab.hs | 1 + src/Facet/Elab/Term.hs | 1 + src/Facet/Elab/Type.hs | 1 + src/Facet/Eval.hs | 2 +- src/Facet/Print.hs | 21 +++++++++++---------- src/Facet/Unify.hs | 1 + test/Facet/Core/Type/Test.hs | 3 ++- 9 files changed, 19 insertions(+), 16 deletions(-) diff --git a/src/Facet/Core/Term.hs b/src/Facet/Core/Term.hs index 548fef262..62657ab1a 100644 --- a/src/Facet/Core/Term.hs +++ b/src/Facet/Core/Term.hs @@ -5,7 +5,7 @@ module Facet.Core.Term import Data.Text (Text) import Facet.Core.Pattern -import qualified Facet.Core.Type as T +import qualified Facet.Core.Type.Expr as T import Facet.Name import Facet.Syntax diff --git a/src/Facet/Core/Type.hs b/src/Facet/Core/Type.hs index b585b8e8d..375756144 100644 --- a/src/Facet/Core/Type.hs +++ b/src/Facet/Core/Type.hs @@ -1,8 +1,5 @@ module Facet.Core.Type ( module Facet.Core.Type.Norm - -- * Type expressions -, module Facet.Core.Type.Expr ) where -import Facet.Core.Type.Expr import Facet.Core.Type.Norm diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 73e7f3e47..24b48ed17 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -67,6 +67,7 @@ import Facet.Core.Module import Facet.Core.Pattern import Facet.Core.Term as E import Facet.Core.Type as T +import Facet.Core.Type.Expr as T import Facet.Effect.Write import qualified Facet.Env as Env import Facet.Graph as Graph diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index c8cb33106..cfabb742e 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -65,6 +65,7 @@ import Facet.Core.Module as Module import Facet.Core.Pattern import Facet.Core.Term as E import Facet.Core.Type as T hiding (global) +import Facet.Core.Type.Expr import Facet.Effect.Write import Facet.Elab import Facet.Elab.Type diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index adbda17f3..5d86de5c0 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -27,6 +27,7 @@ import Facet.Core.Kind import Facet.Core.Module import Facet.Core.Pattern import Facet.Core.Type +import Facet.Core.Type.Expr import Facet.Elab import Facet.Name import Facet.Semiring (Few(..), one, zero) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index fb4e423a0..053baec52 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -24,7 +24,7 @@ import Data.Text (Text) import Facet.Core.Module import Facet.Core.Pattern import Facet.Core.Term -import Facet.Core.Type (TExpr) +import Facet.Core.Type.Expr (TExpr) import Facet.Env as Env import Facet.Graph import Facet.Name hiding (Op) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index c4747a152..5a8d1a81e 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -42,6 +42,7 @@ import Facet.Core.Pattern import qualified Facet.Core.Term as C import qualified Facet.Core.Type as C import qualified Facet.Core.Type as CT +import qualified Facet.Core.Type.Expr as TX import Facet.Env as Env import Facet.Name as Name import qualified Facet.Norm as N @@ -172,20 +173,20 @@ printType opts env = printTExpr opts env . CT.quote (level env) printInterface :: Options -> Env Print -> Interface C.Type -> Print printInterface = printInterfaceWith printType -printTExpr :: Options -> Env Print -> C.TExpr -> Print +printTExpr :: Options -> Env Print -> TX.TExpr -> Print printTExpr opts@Options{ rname } = go where qvar = group . setPrec Var . rname go env = \case - C.TVar (Global n) -> qvar n - C.TVar (Free (Right n)) -> fromMaybe (lname (indexToLevel d <$> n)) $ Env.lookup env n - C.TVar (Free (Left m)) -> meta m - C.TForAll n t b -> braces (ann (intro n d ::: printKind env t)) --> go (env |> PVar (n :=: intro n d)) b - C.TArrow Nothing q a b -> mult q (go env a) --> go env b - C.TArrow (Just n) q a b -> parens (ann (intro n d ::: mult q (go env a))) --> go env b - C.TComp s t -> if s == mempty then go env t else sig s <+> go env t - C.TApp f a -> group (go env f) $$ group (go env a) - C.TString -> annotate Type $ pretty "String" + TX.TVar (Global n) -> qvar n + TX.TVar (Free (Right n)) -> fromMaybe (lname (indexToLevel d <$> n)) $ Env.lookup env n + TX.TVar (Free (Left m)) -> meta m + TX.TForAll n t b -> braces (ann (intro n d ::: printKind env t)) --> go (env |> PVar (n :=: intro n d)) b + TX.TArrow Nothing q a b -> mult q (go env a) --> go env b + TX.TArrow (Just n) q a b -> parens (ann (intro n d ::: mult q (go env a))) --> go env b + TX.TComp s t -> if s == mempty then go env t else sig s <+> go env t + TX.TApp f a -> group (go env f) $$ group (go env a) + TX.TString -> annotate Type $ pretty "String" where d = level env sig s = brackets (commaSep (map (interface env) (interfaces s))) diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index 09e79ccd5..bf88e974d 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -22,6 +22,7 @@ import Facet.Core.Interface import Facet.Core.Kind import Facet.Core.Pattern import Facet.Core.Type +import Facet.Core.Type.Expr import Facet.Elab import Facet.Name import Facet.Semialign diff --git a/test/Facet/Core/Type/Test.hs b/test/Facet/Core/Type/Test.hs index 844fca038..82006a122 100644 --- a/test/Facet/Core/Type/Test.hs +++ b/test/Facet/Core/Type/Test.hs @@ -5,7 +5,8 @@ module Facet.Core.Type.Test ) where import Facet.Core.Kind -import Facet.Core.Type +import Facet.Core.Type.Expr +import Facet.Core.Type.Norm import Facet.Env import Facet.Name import Facet.Semiring From b1a41160cc0053b2bfee12ec70adbcda6c3eb9b4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 4 Apr 2021 22:10:10 -0400 Subject: [PATCH 0038/1324] :fire: Facet.Core.Type. --- facet.cabal | 1 - src/Facet/Context.hs | 2 +- src/Facet/Core/Module.hs | 2 +- src/Facet/Core/Type.hs | 5 ----- src/Facet/Elab.hs | 2 +- src/Facet/Elab/Term.hs | 2 +- src/Facet/Elab/Type.hs | 2 +- src/Facet/Norm.hs | 2 +- src/Facet/Notice/Elab.hs | 2 +- src/Facet/Print.hs | 15 +++++++-------- src/Facet/Unify.hs | 2 +- 11 files changed, 15 insertions(+), 22 deletions(-) delete mode 100644 src/Facet/Core/Type.hs diff --git a/facet.cabal b/facet.cabal index 73432e196..60235671c 100644 --- a/facet.cabal +++ b/facet.cabal @@ -79,7 +79,6 @@ library Facet.Core.Module Facet.Core.Pattern Facet.Core.Term - Facet.Core.Type Facet.Core.Type.Expr Facet.Core.Type.Norm Facet.Diff diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index 908b89a73..72382e736 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -13,7 +13,7 @@ module Facet.Context import qualified Control.Effect.Empty as E import Data.Foldable (find, toList) import Facet.Core.Pattern -import Facet.Core.Type +import Facet.Core.Type.Norm import qualified Facet.Env as Env import Facet.Name import qualified Facet.Snoc as S diff --git a/src/Facet/Core/Module.hs b/src/Facet/Core/Module.hs index 87568b9b7..8246175bf 100644 --- a/src/Facet/Core/Module.hs +++ b/src/Facet/Core/Module.hs @@ -30,7 +30,7 @@ import Data.Coerce import qualified Data.Map as Map import Facet.Core.Kind import Facet.Core.Term -import Facet.Core.Type +import Facet.Core.Type.Norm import Facet.Name import Facet.Syntax diff --git a/src/Facet/Core/Type.hs b/src/Facet/Core/Type.hs deleted file mode 100644 index 375756144..000000000 --- a/src/Facet/Core/Type.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Facet.Core.Type -( module Facet.Core.Type.Norm -) where - -import Facet.Core.Type.Norm diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 24b48ed17..d638efd6a 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -66,8 +66,8 @@ import Facet.Core.Kind import Facet.Core.Module import Facet.Core.Pattern import Facet.Core.Term as E -import Facet.Core.Type as T import Facet.Core.Type.Expr as T +import Facet.Core.Type.Norm as T import Facet.Effect.Write import qualified Facet.Env as Env import Facet.Graph as Graph diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index cfabb742e..faf323890 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -64,8 +64,8 @@ import Facet.Core.Kind import Facet.Core.Module as Module import Facet.Core.Pattern import Facet.Core.Term as E -import Facet.Core.Type as T hiding (global) import Facet.Core.Type.Expr +import Facet.Core.Type.Norm as T hiding (global) import Facet.Effect.Write import Facet.Elab import Facet.Elab.Type diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 5d86de5c0..d0f2329d0 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -26,8 +26,8 @@ import Facet.Core.Interface import Facet.Core.Kind import Facet.Core.Module import Facet.Core.Pattern -import Facet.Core.Type import Facet.Core.Type.Expr +import Facet.Core.Type.Norm import Facet.Elab import Facet.Name import Facet.Semiring (Few(..), one, zero) diff --git a/src/Facet/Norm.hs b/src/Facet/Norm.hs index b8899a855..ac51cb6c3 100644 --- a/src/Facet/Norm.hs +++ b/src/Facet/Norm.hs @@ -14,7 +14,7 @@ import Data.Text (Text) import Data.Traversable (mapAccumL) import Facet.Core.Pattern import Facet.Core.Term -import qualified Facet.Core.Type as T +import qualified Facet.Core.Type.Norm as T import Facet.Env import Facet.Name import Facet.Semialign (zipWithM) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 05041952b..cd6d55cca 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -10,7 +10,7 @@ import qualified Facet.Carrier.Throw.Inject as L import qualified Facet.Carrier.Write.Inject as L import Facet.Context import Facet.Core.Interface (interfaces) -import Facet.Core.Type (Classifier(..), apply, free, metavar) +import Facet.Core.Type.Norm (Classifier(..), apply, free, metavar) import Facet.Elab as Elab import qualified Facet.Env as Env import Facet.Name (LName(..)) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 5a8d1a81e..0341cc482 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -40,9 +40,8 @@ import Facet.Core.Kind import qualified Facet.Core.Module as C import Facet.Core.Pattern import qualified Facet.Core.Term as C -import qualified Facet.Core.Type as C -import qualified Facet.Core.Type as CT import qualified Facet.Core.Type.Expr as TX +import qualified Facet.Core.Type.Norm as TN import Facet.Env as Env import Facet.Name as Name import qualified Facet.Norm as N @@ -153,10 +152,10 @@ suppressInstantiation = const -- Core printers -printSubject :: Options -> Env Print -> C.Classifier -> Print +printSubject :: Options -> Env Print -> TN.Classifier -> Print printSubject opts env = \case - C.CK k -> printKind env k - C.CT t -> printType opts env t + TN.CK k -> printKind env k + TN.CT t -> printType opts env t printKind :: Env Print -> Kind -> Print printKind env = \case @@ -167,10 +166,10 @@ printKind env = \case where d = level env -printType :: Options -> Env Print -> C.Type -> Print -printType opts env = printTExpr opts env . CT.quote (level env) +printType :: Options -> Env Print -> TN.Type -> Print +printType opts env = printTExpr opts env . TN.quote (level env) -printInterface :: Options -> Env Print -> Interface C.Type -> Print +printInterface :: Options -> Env Print -> Interface TN.Type -> Print printInterface = printInterfaceWith printType printTExpr :: Options -> Env Print -> TX.TExpr -> Print diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index bf88e974d..3dcba4b16 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -21,8 +21,8 @@ import Facet.Carrier.Throw.Inject import Facet.Core.Interface import Facet.Core.Kind import Facet.Core.Pattern -import Facet.Core.Type import Facet.Core.Type.Expr +import Facet.Core.Type.Norm import Facet.Elab import Facet.Name import Facet.Semialign From 3770b4fabc49bf54e289b4706f457e84f11abd98 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 4 Apr 2021 22:15:54 -0400 Subject: [PATCH 0039/1324] Drop the Core part of the module names. --- facet.cabal | 14 +++++++------- src/Facet/Context.hs | 4 ++-- src/Facet/Driver.hs | 2 +- src/Facet/Elab.hs | 14 +++++++------- src/Facet/Elab/Term.hs | 14 +++++++------- src/Facet/Elab/Type.hs | 12 ++++++------ src/Facet/Env.hs | 2 +- src/Facet/Eval.hs | 8 ++++---- src/Facet/Graph.hs | 2 +- src/Facet/{Core => }/Interface.hs | 2 +- src/Facet/{Core => }/Kind.hs | 2 +- src/Facet/{Core => }/Module.hs | 8 ++++---- src/Facet/Norm.hs | 6 +++--- src/Facet/Notice/Elab.hs | 4 ++-- src/Facet/{Core => }/Pattern.hs | 2 +- src/Facet/Print.hs | 14 +++++++------- src/Facet/REPL.hs | 6 +++--- src/Facet/{Core => }/Term.hs | 6 +++--- src/Facet/{Core => }/Type/Expr.hs | 6 +++--- src/Facet/{Core => }/Type/Norm.hs | 10 +++++----- src/Facet/Unify.hs | 10 +++++----- test/Facet/Core/Type/Test.hs | 6 +++--- 22 files changed, 77 insertions(+), 77 deletions(-) rename src/Facet/{Core => }/Interface.hs (96%) rename src/Facet/{Core => }/Kind.hs (86%) rename src/Facet/{Core => }/Module.hs (96%) rename src/Facet/{Core => }/Pattern.hs (93%) rename src/Facet/{Core => }/Term.hs (80%) rename src/Facet/{Core => }/Type/Expr.hs (79%) rename src/Facet/{Core => }/Type/Norm.hs (95%) diff --git a/facet.cabal b/facet.cabal index 60235671c..30f50a3fe 100644 --- a/facet.cabal +++ b/facet.cabal @@ -74,13 +74,6 @@ library Facet.Carrier.Write.Inject Facet.CLI Facet.Context - Facet.Core.Interface - Facet.Core.Kind - Facet.Core.Module - Facet.Core.Pattern - Facet.Core.Term - Facet.Core.Type.Expr - Facet.Core.Type.Norm Facet.Diff Facet.Driver Facet.Effect.Parser @@ -97,8 +90,11 @@ library Facet.Flag Facet.Format Facet.Graph + Facet.Interface + Facet.Kind Facet.Lens Facet.Lexer + Facet.Module Facet.Name Facet.Norm Facet.Notice @@ -106,6 +102,7 @@ library Facet.Notice.Parser Facet.Parser Facet.Parser.Table + Facet.Pattern Facet.Pretty Facet.Print Facet.REPL @@ -121,7 +118,10 @@ library Facet.Subst Facet.Surface Facet.Syntax + Facet.Term Facet.Timing + Facet.Type.Expr + Facet.Type.Norm Facet.Unify Facet.Usage Facet.Vars diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index 72382e736..535ae7037 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -12,12 +12,12 @@ module Facet.Context import qualified Control.Effect.Empty as E import Data.Foldable (find, toList) -import Facet.Core.Pattern -import Facet.Core.Type.Norm import qualified Facet.Env as Env import Facet.Name +import Facet.Pattern import qualified Facet.Snoc as S import Facet.Syntax +import Facet.Type.Norm import Facet.Usage import GHC.Stack import Prelude hiding (lookup) diff --git a/src/Facet/Driver.hs b/src/Facet/Driver.hs index 7b66613c1..baf248cfa 100644 --- a/src/Facet/Driver.hs +++ b/src/Facet/Driver.hs @@ -34,12 +34,12 @@ import qualified Data.Text as TS import Data.Traversable (for) import Facet.Carrier.Parser.Church import qualified Facet.Carrier.Throw.Inject as I -import Facet.Core.Module hiding (Import(name), imports, imports_) import Facet.Effect.Readline import Facet.Effect.Write import qualified Facet.Elab.Term as Elab import Facet.Graph import Facet.Lens +import Facet.Module hiding (Import(name), imports, imports_) import Facet.Name import qualified Facet.Notice as Notice import Facet.Notice.Elab (rethrowElabErrors, rethrowElabWarnings) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index d638efd6a..f8c76acc3 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -61,18 +61,15 @@ import Control.Monad (unless, (<=<)) import Data.Foldable (for_) import Facet.Context hiding (empty) import qualified Facet.Context as Context (empty) -import Facet.Core.Interface -import Facet.Core.Kind -import Facet.Core.Module -import Facet.Core.Pattern -import Facet.Core.Term as E -import Facet.Core.Type.Expr as T -import Facet.Core.Type.Norm as T import Facet.Effect.Write import qualified Facet.Env as Env import Facet.Graph as Graph +import Facet.Interface +import Facet.Kind import Facet.Lens +import Facet.Module import Facet.Name hiding (L, R) +import Facet.Pattern import Facet.Semiring import Facet.Snoc import Facet.Snoc.NonEmpty (toSnoc) @@ -80,6 +77,9 @@ import Facet.Source (Source, slice) import Facet.Span (Span(..)) import Facet.Subst import Facet.Syntax +import Facet.Term as E +import Facet.Type.Expr as T +import Facet.Type.Norm as T import Facet.Usage as Usage import Facet.Vars as Vars import GHC.Stack diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index faf323890..227fff33f 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -59,19 +59,16 @@ import qualified Data.Set as Set import Data.Text (Text) import Data.Traversable (for, mapAccumL) import Facet.Context (toEnv) -import Facet.Core.Interface -import Facet.Core.Kind -import Facet.Core.Module as Module -import Facet.Core.Pattern -import Facet.Core.Term as E -import Facet.Core.Type.Expr -import Facet.Core.Type.Norm as T hiding (global) import Facet.Effect.Write import Facet.Elab import Facet.Elab.Type import Facet.Graph +import Facet.Interface +import Facet.Kind import Facet.Lens (locally) +import Facet.Module as Module import Facet.Name +import Facet.Pattern import Facet.Semiring (Few(..), zero, (><<)) import Facet.Snoc import Facet.Snoc.NonEmpty as NE @@ -79,6 +76,9 @@ import Facet.Source (Source) import Facet.Subst import qualified Facet.Surface as S import Facet.Syntax +import Facet.Term as E +import Facet.Type.Expr +import Facet.Type.Norm as T hiding (global) import Facet.Unify import Facet.Usage hiding (restrict) import GHC.Stack diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index d0f2329d0..c05b02c02 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -22,18 +22,18 @@ import Control.Monad (unless) import Data.Bifunctor (first) import Data.Foldable (foldl') import Data.Functor (($>)) -import Facet.Core.Interface -import Facet.Core.Kind -import Facet.Core.Module -import Facet.Core.Pattern -import Facet.Core.Type.Expr -import Facet.Core.Type.Norm import Facet.Elab +import Facet.Interface +import Facet.Kind +import Facet.Module import Facet.Name +import Facet.Pattern import Facet.Semiring (Few(..), one, zero) import Facet.Snoc import qualified Facet.Surface as S import Facet.Syntax +import Facet.Type.Expr +import Facet.Type.Norm import GHC.Stack tvar :: (HasCallStack, Has (Throw Err) sig m) => QName -> IsType m TExpr diff --git a/src/Facet/Env.hs b/src/Facet/Env.hs index 16f73c609..3d91fdaf7 100644 --- a/src/Facet/Env.hs +++ b/src/Facet/Env.hs @@ -10,8 +10,8 @@ module Facet.Env import Control.Applicative ((<|>)) import Control.Monad (guard) import Data.Maybe (fromMaybe) -import Facet.Core.Pattern import Facet.Name +import Facet.Pattern import Facet.Snoc import Facet.Syntax import GHC.Stack diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 053baec52..d675e8901 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -21,16 +21,16 @@ import Data.Foldable import Data.Function import Data.Maybe (fromMaybe) import Data.Text (Text) -import Facet.Core.Module -import Facet.Core.Pattern -import Facet.Core.Term -import Facet.Core.Type.Expr (TExpr) import Facet.Env as Env import Facet.Graph +import Facet.Module import Facet.Name hiding (Op) +import Facet.Pattern import Facet.Semialign (zipWithM) import Facet.Snoc.NonEmpty as NE hiding ((|>)) import Facet.Syntax +import Facet.Term +import Facet.Type.Expr (TExpr) import GHC.Stack (HasCallStack) import Prelude hiding (zipWith) diff --git a/src/Facet/Graph.hs b/src/Facet/Graph.hs index bcf0f507d..afe7d968c 100644 --- a/src/Facet/Graph.hs +++ b/src/Facet/Graph.hs @@ -27,7 +27,7 @@ import Data.Foldable (for_) import qualified Data.Map as Map import Data.Monoid (Endo(..)) import qualified Data.Set as Set -import Facet.Core.Module +import Facet.Module import Facet.Name import Facet.Snoc import Facet.Snoc.NonEmpty (fromSnoc, toSnoc) diff --git a/src/Facet/Core/Interface.hs b/src/Facet/Interface.hs similarity index 96% rename from src/Facet/Core/Interface.hs rename to src/Facet/Interface.hs index 6a77d94e8..3beeee297 100644 --- a/src/Facet/Core/Interface.hs +++ b/src/Facet/Interface.hs @@ -1,4 +1,4 @@ -module Facet.Core.Interface +module Facet.Interface ( Interface(..) , Signature(..) , fromInterfaces diff --git a/src/Facet/Core/Kind.hs b/src/Facet/Kind.hs similarity index 86% rename from src/Facet/Core/Kind.hs rename to src/Facet/Kind.hs index e71a11e2e..dd1d2e4f5 100644 --- a/src/Facet/Core/Kind.hs +++ b/src/Facet/Kind.hs @@ -1,4 +1,4 @@ -module Facet.Core.Kind +module Facet.Kind ( Kind(..) ) where diff --git a/src/Facet/Core/Module.hs b/src/Facet/Module.hs similarity index 96% rename from src/Facet/Core/Module.hs rename to src/Facet/Module.hs index 8246175bf..90b09055c 100644 --- a/src/Facet/Core/Module.hs +++ b/src/Facet/Module.hs @@ -1,4 +1,4 @@ -module Facet.Core.Module +module Facet.Module ( -- * Modules Module(..) , name_ @@ -28,11 +28,11 @@ import Control.Monad ((<=<)) import Data.Bifunctor (first) import Data.Coerce import qualified Data.Map as Map -import Facet.Core.Kind -import Facet.Core.Term -import Facet.Core.Type.Norm +import Facet.Kind import Facet.Name import Facet.Syntax +import Facet.Term +import Facet.Type.Norm -- Modules diff --git a/src/Facet/Norm.hs b/src/Facet/Norm.hs index ac51cb6c3..ce228aaf7 100644 --- a/src/Facet/Norm.hs +++ b/src/Facet/Norm.hs @@ -12,14 +12,14 @@ import Data.Maybe (fromMaybe) import Data.Monoid import Data.Text (Text) import Data.Traversable (mapAccumL) -import Facet.Core.Pattern -import Facet.Core.Term -import qualified Facet.Core.Type.Norm as T import Facet.Env import Facet.Name +import Facet.Pattern import Facet.Semialign (zipWithM) import Facet.Snoc import Facet.Syntax +import Facet.Term +import qualified Facet.Type.Norm as T data Norm = NString Text diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index cd6d55cca..4a161c565 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -9,10 +9,9 @@ import Data.Semigroup (stimes) import qualified Facet.Carrier.Throw.Inject as L import qualified Facet.Carrier.Write.Inject as L import Facet.Context -import Facet.Core.Interface (interfaces) -import Facet.Core.Type.Norm (Classifier(..), apply, free, metavar) import Facet.Elab as Elab import qualified Facet.Env as Env +import Facet.Interface (interfaces) import Facet.Name (LName(..)) import Facet.Notice as Notice hiding (level) import Facet.Pretty @@ -22,6 +21,7 @@ import Facet.Snoc import Facet.Style import Facet.Subst (metas) import Facet.Syntax +import Facet.Type.Norm (Classifier(..), apply, free, metavar) import GHC.Stack import Prelude hiding (unlines) import Silkscreen diff --git a/src/Facet/Core/Pattern.hs b/src/Facet/Pattern.hs similarity index 93% rename from src/Facet/Core/Pattern.hs rename to src/Facet/Pattern.hs index 55e050a14..f3d493fdb 100644 --- a/src/Facet/Core/Pattern.hs +++ b/src/Facet/Pattern.hs @@ -1,4 +1,4 @@ -module Facet.Core.Pattern +module Facet.Pattern ( -- * Patterns Pattern(..) , fill diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 0341cc482..5d2a9391f 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -35,21 +35,21 @@ import Data.Foldable (foldl', toList) import Data.Maybe (fromMaybe) import qualified Data.Text as T import Data.Traversable (mapAccumL) -import Facet.Core.Interface -import Facet.Core.Kind -import qualified Facet.Core.Module as C -import Facet.Core.Pattern -import qualified Facet.Core.Term as C -import qualified Facet.Core.Type.Expr as TX -import qualified Facet.Core.Type.Norm as TN import Facet.Env as Env +import Facet.Interface +import Facet.Kind +import qualified Facet.Module as C import Facet.Name as Name import qualified Facet.Norm as N +import Facet.Pattern import Facet.Pretty (lower, upper) import Facet.Semiring (one, zero) import Facet.Snoc import Facet.Style import Facet.Syntax +import qualified Facet.Term as C +import qualified Facet.Type.Expr as TX +import qualified Facet.Type.Norm as TN import qualified Prettyprinter as PP import Silkscreen as P import Silkscreen.Printer.Prec hiding (Level) diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index f87748619..dbdd542cf 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -29,16 +29,15 @@ import Facet.Carrier.Readline.Haskeline import qualified Facet.Carrier.Throw.Inject as I import Facet.Carrier.Write.General import qualified Facet.Carrier.Write.Inject as I -import Facet.Core.Interface as I -import Facet.Core.Module -import Facet.Core.Term (Expr) import Facet.Driver import qualified Facet.Elab as Elab import qualified Facet.Elab.Term as Elab import qualified Facet.Elab.Type as Elab import Facet.Eval as E import Facet.Graph +import Facet.Interface as I import Facet.Lens +import Facet.Module import Facet.Name as Name import qualified Facet.Notice as Notice import Facet.Notice.Elab @@ -52,6 +51,7 @@ import Facet.Source (Source(..), sourceFromString) import Facet.Style as Style import qualified Facet.Surface as S import Facet.Syntax +import Facet.Term (Expr) import Prelude hiding (span, unlines) import Silkscreen as S hiding (Ann, line) import System.Console.ANSI diff --git a/src/Facet/Core/Term.hs b/src/Facet/Term.hs similarity index 80% rename from src/Facet/Core/Term.hs rename to src/Facet/Term.hs index 62657ab1a..4252b5f26 100644 --- a/src/Facet/Core/Term.hs +++ b/src/Facet/Term.hs @@ -1,13 +1,13 @@ -module Facet.Core.Term +module Facet.Term ( -- * Term expressions Expr(..) ) where import Data.Text (Text) -import Facet.Core.Pattern -import qualified Facet.Core.Type.Expr as T import Facet.Name +import Facet.Pattern import Facet.Syntax +import qualified Facet.Type.Expr as T -- Term expressions diff --git a/src/Facet/Core/Type/Expr.hs b/src/Facet/Type/Expr.hs similarity index 79% rename from src/Facet/Core/Type/Expr.hs rename to src/Facet/Type/Expr.hs index 19036a319..f02bd5aa8 100644 --- a/src/Facet/Core/Type/Expr.hs +++ b/src/Facet/Type/Expr.hs @@ -1,9 +1,9 @@ -module Facet.Core.Type.Expr +module Facet.Type.Expr ( TExpr(..) ) where -import Facet.Core.Interface -import Facet.Core.Kind +import Facet.Interface +import Facet.Kind import Facet.Name import Facet.Syntax import Facet.Usage diff --git a/src/Facet/Core/Type/Norm.hs b/src/Facet/Type/Norm.hs similarity index 95% rename from src/Facet/Core/Type/Norm.hs rename to src/Facet/Type/Norm.hs index f6ded69f7..fdef0e800 100644 --- a/src/Facet/Core/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -1,4 +1,4 @@ -module Facet.Core.Type.Norm +module Facet.Type.Norm ( -- * Types Type(..) , global @@ -22,15 +22,15 @@ import Control.Effect.Empty import Data.Foldable (foldl') import Data.Function (on, (&)) import Data.Maybe (fromMaybe) -import Facet.Core.Interface -import Facet.Core.Kind -import Facet.Core.Pattern -import Facet.Core.Type.Expr import Facet.Env hiding (empty) +import Facet.Interface +import Facet.Kind import Facet.Name +import Facet.Pattern import Facet.Snoc import Facet.Subst import Facet.Syntax +import Facet.Type.Expr import Facet.Usage hiding (singleton) import GHC.Stack import Prelude hiding (lookup) diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index 3dcba4b16..32c06f26e 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -18,11 +18,11 @@ import Control.Effect.Sum import Control.Effect.Writer import Control.Monad (unless) import Facet.Carrier.Throw.Inject -import Facet.Core.Interface -import Facet.Core.Kind -import Facet.Core.Pattern -import Facet.Core.Type.Expr -import Facet.Core.Type.Norm +import Facet.Interface +import Facet.Kind +import Facet.Pattern +import Facet.Type.Expr +import Facet.Type.Norm import Facet.Elab import Facet.Name import Facet.Semialign diff --git a/test/Facet/Core/Type/Test.hs b/test/Facet/Core/Type/Test.hs index 82006a122..7168dbb56 100644 --- a/test/Facet/Core/Type/Test.hs +++ b/test/Facet/Core/Type/Test.hs @@ -4,13 +4,13 @@ module Facet.Core.Type.Test ( tests ) where -import Facet.Core.Kind -import Facet.Core.Type.Expr -import Facet.Core.Type.Norm import Facet.Env +import Facet.Kind import Facet.Name import Facet.Semiring import Facet.Syntax +import Facet.Type.Expr +import Facet.Type.Norm import Hedgehog hiding (Var, eval) tests :: IO Bool From 1db31fc516f9319ebad7672df15c8b40331fb072 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 4 Apr 2021 22:19:55 -0400 Subject: [PATCH 0040/1324] Rename the Norm.Type constructors. --- src/Facet/Elab.hs | 4 ++-- src/Facet/Elab/Term.hs | 38 +++++++++++++++--------------- src/Facet/Type/Norm.hs | 52 +++++++++++++++++++++--------------------- src/Facet/Unify.hs | 36 ++++++++++++++--------------- 4 files changed, 65 insertions(+), 65 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index f8c76acc3..72593c8c4 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -102,7 +102,7 @@ instantiate :: Algebra sig m => (a -> TExpr -> a) -> a ::: Type -> Elab m (a ::: instantiate inst = go where go (e ::: _T) = case _T of - VForAll _ _T _B -> do + T.ForAll _ _T _B -> do m <- meta _T go (inst e (TVar (Free (Left m))) ::: _B (metavar m)) _ -> pure $ e ::: _T @@ -284,7 +284,7 @@ assertMatch :: (HasCallStack, Has (Throw Err) sig m) => (Classifier -> Maybe out assertMatch pat exp _T = maybe (mismatch (Exp (Left exp)) (Act _T)) pure (pat _T) assertFunction :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Maybe Name ::: (Quantity, Type), Type) -assertFunction = assertMatch (\case{ CT (VArrow n q t b) -> pure (n ::: (q, t), b) ; _ -> Nothing }) "_ -> _" . CT +assertFunction = assertMatch (\case{ CT (T.Arrow n q t b) -> pure (n ::: (q, t), b) ; _ -> Nothing }) "_ -> _" . CT -- Unification diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 227fff33f..cf4597aeb 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -87,8 +87,8 @@ import GHC.Stack switch :: (HasCallStack, Has (Throw Err) sig m) => Synth m a -> Check m a switch (Synth m) = Check $ \ _Exp -> m >>= \case - a ::: VComp req _Act -> require req >> unify (Exp _Exp) (Act _Act) $> a - a ::: _Act -> unify (Exp _Exp) (Act _Act) $> a + a ::: T.Comp req _Act -> require req >> unify (Exp _Exp) (Act _Act) $> a + a ::: _Act -> unify (Exp _Exp) (Act _Act) $> a as :: (HasCallStack, Has (Throw Err) sig m) => Check m Expr ::: IsType m Type -> Synth m Expr as (m ::: _T) = Synth $ do @@ -143,7 +143,7 @@ app mk operator operand = Synth $ do string :: Text -> Synth m Expr -string s = Synth $ pure $ XString s ::: T.VString +string s = Synth $ pure $ XString s ::: T.String let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Synth m Expr -> Check m Expr -> Check m Expr @@ -162,8 +162,8 @@ varP :: Name -> Bind m (Pattern (Name ::: Classifier)) varP n = Bind $ \ _A k -> k (PVar (n ::: CT (wrap _A))) where wrap = \case - VComp sig _A -> VArrow Nothing Many (VNe (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (VComp sig _A) - _T -> _T + T.Comp sig _A -> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (T.Comp sig _A) + _T -> _T conP :: (HasCallStack, Has (Throw Err) sig m) => QName -> [Bind m (Pattern (Name ::: Classifier))] -> Bind m (Pattern (Name ::: Classifier)) conP n fs = Bind $ \ _A k -> do @@ -184,7 +184,7 @@ fieldsP = foldr cons nil allP :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Name -> Bind m (Pattern (Name ::: Classifier)) allP n = Bind $ \ _A k -> do (sig, _T) <- assertComp _A - k (PVar (n ::: CT (VArrow Nothing Many (VNe (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (VComp sig _T)))) + k (PVar (n ::: CT (T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (T.Comp sig _T)))) -- Expression elaboration @@ -246,20 +246,20 @@ abstractTerm :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => (Snoc TE abstractTerm body = go Nil Nil where go ts fs = Check $ \case - VForAll n _T _B -> do + T.ForAll n _T _B -> do d <- depth - check (tlam (go (ts :> LName d n) fs) ::: VForAll n _T _B) - VArrow n q _A _B -> do + check (tlam (go (ts :> LName d n) fs) ::: T.ForAll n _T _B) + T.Arrow n q _A _B -> do d <- depth - check (lam [(patternForArgType _A (fromMaybe __ n), go ts (fs :> \ d' -> XVar (Free (LName (levelToIndex d' d) (fromMaybe __ n)))))] ::: VArrow n q _A _B) + check (lam [(patternForArgType _A (fromMaybe __ n), go ts (fs :> \ d' -> XVar (Free (LName (levelToIndex d' d) (fromMaybe __ n)))))] ::: T.Arrow n q _A _B) _T -> do d <- depth pure $ body (TVar . Free . Right . fmap (levelToIndex d) <$> ts) (fs <*> pure d) patternForArgType :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Type -> Name -> Bind m (Pattern (Name ::: Classifier)) patternForArgType = \case - VComp{} -> allP - _ -> varP + T.Comp{} -> allP + _ -> varP -- Declarations @@ -301,12 +301,12 @@ elabTermDef _T expr@(S.Ann s _ _) = do elabTerm $ pushSpan s $ check (go (checkExpr expr) ::: _T) where go k = Check $ \ _T -> case _T of - VForAll{} -> check (tlam (go k) ::: _T) - VArrow (Just n) q _A _B -> check (lam [(varP n, go k)] ::: VArrow Nothing q _A _B) + T.ForAll{} -> check (tlam (go k) ::: _T) + T.Arrow (Just n) q _A _B -> check (lam [(varP n, go k)] ::: T.Arrow Nothing q _A _B) -- FIXME: this doesn’t do what we want for tacit definitions, i.e. where _T is itself a telescope. -- FIXME: eta-expanding here doesn’t help either because it doesn’t change the way elaboration of the surface term occurs. -- we’ve exhausted the named parameters; the rest is up to the body. - _ -> check (k ::: _T) + _ -> check (k ::: _T) -- Modules @@ -351,11 +351,11 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os -- Errors assertQuantifier :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Name ::: Kind, Type -> Type) -assertQuantifier = assertMatch (\case{ CT (VForAll n t b) -> pure (n ::: t, b) ; _ -> Nothing }) "{_} -> _" . CT +assertQuantifier = assertMatch (\case{ CT (T.ForAll n t b) -> pure (n ::: t, b) ; _ -> Nothing }) "{_} -> _" . CT -- | Expect a tacit (non-variable-binding) function type. assertTacitFunction :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m ((Quantity, Type), Type) -assertTacitFunction = assertMatch (\case{ CT (VArrow Nothing q t b) -> pure ((q, t), b) ; _ -> Nothing }) "_ -> _" . CT +assertTacitFunction = assertMatch (\case{ CT (T.Arrow Nothing q t b) -> pure ((q, t), b) ; _ -> Nothing }) "_ -> _" . CT -- | Expect a computation type with effects. assertComp :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Signature Type, Type) @@ -399,8 +399,8 @@ findMaybeM p = getAp . fmap getFirst . foldMap (Ap . fmap First . p) check :: Algebra sig m => (Check m a ::: Type) -> Elab m a check (m ::: _T) = case _T of - VComp sig _T -> provide sig $ runCheck m _T - _T -> runCheck m _T + T.Comp sig _T -> provide sig $ runCheck m _T + _T -> runCheck m _T newtype Check m a = Check { runCheck :: Type -> Elab m a } deriving (Applicative, Functor) via ReaderC Type (Elab m) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index fdef0e800..9670d20c7 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -38,11 +38,11 @@ import Prelude hiding (lookup) -- Types data Type - = VString - | VForAll Name Kind (Type -> Type) - | VArrow (Maybe Name) Quantity Type Type - | VNe (Var (Either Meta (LName Level))) (Snoc Type) - | VComp (Signature Type) Type + = String + | ForAll Name Kind (Type -> Type) + | Arrow (Maybe Name) Quantity Type Type + | Ne (Var (Either Meta (LName Level))) (Snoc Type) + | Comp (Signature Type) Type instance Eq Type where (==) = (==) `on` quote 0 @@ -62,18 +62,18 @@ metavar = var . Free . Left var :: Var (Either Meta (LName Level)) -> Type -var v = VNe v Nil +var v = Ne v Nil unNeutral :: Has Empty sig m => Type -> m (Var (Either Meta (LName Level)), Snoc Type) unNeutral = \case - VNe h sp -> pure (h, sp) - _ -> empty + Ne h sp -> pure (h, sp) + _ -> empty unComp :: Has Empty sig m => Type -> m (Signature Type, Type) unComp = \case - VComp sig _T -> pure (sig, _T) - _T -> empty + Comp sig _T -> pure (sig, _T) + _T -> empty data Classifier @@ -90,18 +90,18 @@ occursIn :: Meta -> Level -> Type -> Bool occursIn p = go where go d = \case - VForAll n _ b -> go (succ d) (b (free (LName d n))) - VArrow _ _ a b -> go d a || go d b - VComp s t -> any (go d) s || go d t - VNe h sp -> any (either (== p) (const False)) h || any (go d) sp - VString -> False + ForAll n _ b -> go (succ d) (b (free (LName d n))) + Arrow _ _ a b -> go d a || go d b + Comp s t -> any (go d) s || go d t + Ne h sp -> any (either (== p) (const False)) h || any (go d) sp + String -> False -- Elimination ($$) :: HasCallStack => Type -> Type -> Type -VNe h es $$ a = VNe h (es :> a) -_ $$ _ = error "can’t apply non-neutral/forall type" +Ne h es $$ a = Ne h (es :> a) +_ $$ _ = error "can’t apply non-neutral/forall type" ($$*) :: (HasCallStack, Foldable t) => Type -> t Type -> Type ($$*) = foldl' ($$) @@ -113,22 +113,22 @@ infixl 9 $$, $$* quote :: Level -> Type -> TExpr quote d = \case - VString -> TString - VForAll n t b -> TForAll n t (quote (succ d) (b (free (LName d n)))) - VArrow n q a b -> TArrow n q (quote d a) (quote d b) - VComp s t -> TComp (mapSignature (quote d) s) (quote d t) - VNe n sp -> foldl' (&) (TVar (fmap (fmap (levelToIndex d)) <$> n)) (flip TApp . quote d <$> sp) + String -> TString + ForAll n t b -> TForAll n t (quote (succ d) (b (free (LName d n)))) + Arrow n q a b -> TArrow n q (quote d a) (quote d b) + Comp s t -> TComp (mapSignature (quote d) s) (quote d t) + Ne n sp -> foldl' (&) (TVar (fmap (fmap (levelToIndex d)) <$> n)) (flip TApp . quote d <$> sp) eval :: HasCallStack => Subst Type -> Env Type -> TExpr -> Type eval subst = go where go env = \case - TString -> VString + TString -> String TVar (Global n) -> global n TVar (Free (Right n)) -> index env n TVar (Free (Left m)) -> fromMaybe (metavar m) (lookupMeta m subst) - TForAll n t b -> VForAll n t (\ _T -> go (env |> PVar (n :=: _T)) b) - TArrow n q a b -> VArrow n q (go env a) (go env b) - TComp s t -> VComp (mapSignature (go env) s) (go env t) + TForAll n t b -> ForAll n t (\ _T -> go (env |> PVar (n :=: _T)) b) + TArrow n q a b -> Arrow n q (go env a) (go env b) + TComp s t -> Comp (mapSignature (go env) s) (go env t) TApp f a -> go env f $$ go env a apply :: HasCallStack => Subst Type -> Env Type -> Type -> Type diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index 32c06f26e..2434a48ae 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -18,18 +18,18 @@ import Control.Effect.Sum import Control.Effect.Writer import Control.Monad (unless) import Facet.Carrier.Throw.Inject +import Facet.Elab import Facet.Interface import Facet.Kind -import Facet.Pattern -import Facet.Type.Expr -import Facet.Type.Norm -import Facet.Elab import Facet.Name +import Facet.Pattern import Facet.Semialign import Facet.Semiring import Facet.Snoc import Facet.Subst import Facet.Syntax +import Facet.Type.Expr +import Facet.Type.Norm as T import Facet.Usage import GHC.Stack @@ -53,20 +53,20 @@ occurs v t = withFrozenCallStack $ throwError $ WithCallStack GHC.Stack.callStac unifyType :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Type -> Type -> m Type unifyType = curry $ \case - (VComp s1 t1, VComp s2 t2) -> VComp . fromInterfaces <$> unifySpine unifyInterface (interfaces s1) (interfaces s2) <*> unifyType t1 t2 - (VComp s1 t1, t2) -> VComp s1 <$> unifyType t1 t2 - (t1, VComp s2 t2) -> VComp s2 <$> unifyType t1 t2 - (VNe (Free (Left v1)) Nil, VNe (Free (Left v2)) Nil) -> flexFlex v1 v2 - (VNe (Free (Left v1)) Nil, t2) -> solve v1 t2 - (t1, VNe (Free (Left v2)) Nil) -> solve v2 t1 - (VForAll _ t1 b1, VForAll n t2 b2) -> depth >>= \ d -> evalTExpr =<< mkForAll d n <$> unifyKind t1 t2 <*> ((zero, PVar (n ::: CK t2)) |- unifyType (b1 (free (LName d n))) (b2 (free (LName d n)))) - (VForAll{}, _) -> mismatch - (VArrow _ _ a1 b1, VArrow n q a2 b2) -> VArrow n q <$> unifyType a1 a2 <*> unifyType b1 b2 - (VArrow{}, _) -> mismatch - (VNe v1 sp1, VNe v2 sp2) -> VNe <$> unifyVar v1 v2 <*> unifySpine unifyType sp1 sp2 - (VNe{}, _) -> mismatch - (VString, VString) -> pure VString - (VString, _) -> mismatch + (T.Comp s1 t1, T.Comp s2 t2) -> T.Comp . fromInterfaces <$> unifySpine unifyInterface (interfaces s1) (interfaces s2) <*> unifyType t1 t2 + (T.Comp s1 t1, t2) -> T.Comp s1 <$> unifyType t1 t2 + (t1, T.Comp s2 t2) -> T.Comp s2 <$> unifyType t1 t2 + (T.Ne (Free (Left v1)) Nil, T.Ne (Free (Left v2)) Nil) -> flexFlex v1 v2 + (T.Ne (Free (Left v1)) Nil, t2) -> solve v1 t2 + (t1, T.Ne (Free (Left v2)) Nil) -> solve v2 t1 + (T.ForAll _ t1 b1, T.ForAll n t2 b2) -> depth >>= \ d -> evalTExpr =<< mkForAll d n <$> unifyKind t1 t2 <*> ((zero, PVar (n ::: CK t2)) |- unifyType (b1 (free (LName d n))) (b2 (free (LName d n)))) + (T.ForAll{}, _) -> mismatch + (T.Arrow _ _ a1 b1, T.Arrow n q a2 b2) -> T.Arrow n q <$> unifyType a1 a2 <*> unifyType b1 b2 + (T.Arrow{}, _) -> mismatch + (T.Ne v1 sp1, T.Ne v2 sp2) -> T.Ne <$> unifyVar v1 v2 <*> unifySpine unifyType sp1 sp2 + (T.Ne{}, _) -> mismatch + (T.String, T.String) -> pure T.String + (T.String, _) -> mismatch where mkForAll d n k b = TForAll n k (quote (succ d) b) From 8a0bfd6277ed60850d4cf5e1ec873f75f8eab863 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 4 Apr 2021 23:20:44 -0400 Subject: [PATCH 0041/1324] Rename the import of normal types. --- src/Facet/Elab.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 72593c8c4..96d044e64 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -79,7 +79,7 @@ import Facet.Subst import Facet.Syntax import Facet.Term as E import Facet.Type.Expr as T -import Facet.Type.Norm as T +import Facet.Type.Norm as TN import Facet.Usage as Usage import Facet.Vars as Vars import GHC.Stack @@ -102,10 +102,10 @@ instantiate :: Algebra sig m => (a -> TExpr -> a) -> a ::: Type -> Elab m (a ::: instantiate inst = go where go (e ::: _T) = case _T of - T.ForAll _ _T _B -> do + TN.ForAll _ _T _B -> do m <- meta _T go (inst e (TVar (Free (Left m))) ::: _B (metavar m)) - _ -> pure $ e ::: _T + _ -> pure $ e ::: _T resolveWith @@ -164,7 +164,7 @@ sat a b evalTExpr :: Has (Reader ElabContext :+: State (Subst Type)) sig m => TExpr -> m Type -evalTExpr texpr = T.eval <$> get <*> views context_ toEnv <*> pure texpr +evalTExpr texpr = TN.eval <$> get <*> views context_ toEnv <*> pure texpr depth :: Has (Reader ElabContext) sig m => m Level depth = views context_ level @@ -284,7 +284,7 @@ assertMatch :: (HasCallStack, Has (Throw Err) sig m) => (Classifier -> Maybe out assertMatch pat exp _T = maybe (mismatch (Exp (Left exp)) (Act _T)) pure (pat _T) assertFunction :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Maybe Name ::: (Quantity, Type), Type) -assertFunction = assertMatch (\case{ CT (T.Arrow n q t b) -> pure (n ::: (q, t), b) ; _ -> Nothing }) "_ -> _" . CT +assertFunction = assertMatch (\case{ CT (TN.Arrow n q t b) -> pure (n ::: (q, t), b) ; _ -> Nothing }) "_ -> _" . CT -- Unification @@ -329,13 +329,13 @@ elabKind :: Has (Reader Graph :+: Reader Module :+: Reader Source) sig m => Elab elabKind = elabWith zero (const pure) elabType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m TExpr -> m Type -elabType = elabWith zero (\ subst t -> pure (T.eval subst Env.empty t)) +elabType = elabWith zero (\ subst t -> pure (TN.eval subst Env.empty t)) elabTerm :: Has (Reader Graph :+: Reader Module :+: Reader Source) sig m => Elab m Expr -> m Expr elabTerm = elabWith one (const pure) elabSynthTerm :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (Expr ::: Type) -> m (Expr ::: Type) -elabSynthTerm = elabWith one (\ subst (e ::: _T) -> pure (e ::: T.eval subst Env.empty (T.quote 0 _T))) +elabSynthTerm = elabWith one (\ subst (e ::: _T) -> pure (e ::: TN.eval subst Env.empty (TN.quote 0 _T))) elabSynthType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (TExpr ::: Kind) -> m (Type ::: Kind) -elabSynthType = elabWith zero (\ subst (_T ::: _K) -> pure (T.eval subst Env.empty _T ::: _K)) +elabSynthType = elabWith zero (\ subst (_T ::: _K) -> pure (TN.eval subst Env.empty _T ::: _K)) From c74b3eb892e750be51b1f2d06c77af2a73455657 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 5 Apr 2021 00:54:44 -0400 Subject: [PATCH 0042/1324] Rename the import of Facet.Type.Norm into Facet.Unify. --- src/Facet/Unify.hs | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index 2434a48ae..9f74f2262 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -29,7 +29,7 @@ import Facet.Snoc import Facet.Subst import Facet.Syntax import Facet.Type.Expr -import Facet.Type.Norm as T +import Facet.Type.Norm as TN import Facet.Usage import GHC.Stack @@ -53,20 +53,20 @@ occurs v t = withFrozenCallStack $ throwError $ WithCallStack GHC.Stack.callStac unifyType :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Type -> Type -> m Type unifyType = curry $ \case - (T.Comp s1 t1, T.Comp s2 t2) -> T.Comp . fromInterfaces <$> unifySpine unifyInterface (interfaces s1) (interfaces s2) <*> unifyType t1 t2 - (T.Comp s1 t1, t2) -> T.Comp s1 <$> unifyType t1 t2 - (t1, T.Comp s2 t2) -> T.Comp s2 <$> unifyType t1 t2 - (T.Ne (Free (Left v1)) Nil, T.Ne (Free (Left v2)) Nil) -> flexFlex v1 v2 - (T.Ne (Free (Left v1)) Nil, t2) -> solve v1 t2 - (t1, T.Ne (Free (Left v2)) Nil) -> solve v2 t1 - (T.ForAll _ t1 b1, T.ForAll n t2 b2) -> depth >>= \ d -> evalTExpr =<< mkForAll d n <$> unifyKind t1 t2 <*> ((zero, PVar (n ::: CK t2)) |- unifyType (b1 (free (LName d n))) (b2 (free (LName d n)))) - (T.ForAll{}, _) -> mismatch - (T.Arrow _ _ a1 b1, T.Arrow n q a2 b2) -> T.Arrow n q <$> unifyType a1 a2 <*> unifyType b1 b2 - (T.Arrow{}, _) -> mismatch - (T.Ne v1 sp1, T.Ne v2 sp2) -> T.Ne <$> unifyVar v1 v2 <*> unifySpine unifyType sp1 sp2 - (T.Ne{}, _) -> mismatch - (T.String, T.String) -> pure T.String - (T.String, _) -> mismatch + (TN.Comp s1 t1, TN.Comp s2 t2) -> TN.Comp . fromInterfaces <$> unifySpine unifyInterface (interfaces s1) (interfaces s2) <*> unifyType t1 t2 + (TN.Comp s1 t1, t2) -> TN.Comp s1 <$> unifyType t1 t2 + (t1, TN.Comp s2 t2) -> TN.Comp s2 <$> unifyType t1 t2 + (TN.Ne (Free (Left v1)) Nil, TN.Ne (Free (Left v2)) Nil) -> flexFlex v1 v2 + (TN.Ne (Free (Left v1)) Nil, t2) -> solve v1 t2 + (t1, TN.Ne (Free (Left v2)) Nil) -> solve v2 t1 + (TN.ForAll _ t1 b1, TN.ForAll n t2 b2) -> depth >>= \ d -> evalTExpr =<< mkForAll d n <$> unifyKind t1 t2 <*> ((zero, PVar (n ::: CK t2)) |- unifyType (b1 (free (LName d n))) (b2 (free (LName d n)))) + (TN.ForAll{}, _) -> mismatch + (TN.Arrow _ _ a1 b1, TN.Arrow n q a2 b2) -> TN.Arrow n q <$> unifyType a1 a2 <*> unifyType b1 b2 + (TN.Arrow{}, _) -> mismatch + (TN.Ne v1 sp1, TN.Ne v2 sp2) -> TN.Ne <$> unifyVar v1 v2 <*> unifySpine unifyType sp1 sp2 + (TN.Ne{}, _) -> mismatch + (TN.String, TN.String) -> pure TN.String + (TN.String, _) -> mismatch where mkForAll d n k b = TForAll n k (quote (succ d) b) From bafc3ea999e4040f1551d5af87089948730deba0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 5 Apr 2021 01:04:51 -0400 Subject: [PATCH 0043/1324] Rename TExpr to Type. --- src/Facet/Elab.hs | 12 ++++---- src/Facet/Elab/Term.hs | 10 +++---- src/Facet/Elab/Type.hs | 30 ++++++++++---------- src/Facet/Eval.hs | 4 +-- src/Facet/Print.hs | 2 +- src/Facet/Term.hs | 4 +-- src/Facet/Type/Expr.hs | 12 ++++---- src/Facet/Type/Norm.hs | 63 +++++++++++++++++++++--------------------- src/Facet/Unify.hs | 46 +++++++++++++++--------------- 9 files changed, 92 insertions(+), 91 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 96d044e64..404df46e9 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -78,7 +78,7 @@ import Facet.Span (Span(..)) import Facet.Subst import Facet.Syntax import Facet.Term as E -import Facet.Type.Expr as T +import qualified Facet.Type.Expr as TX import Facet.Type.Norm as TN import Facet.Usage as Usage import Facet.Vars as Vars @@ -98,13 +98,13 @@ meta :: Has (State (Subst Type)) sig m => Kind -> m Meta meta _T = state (declareMeta @Type) -instantiate :: Algebra sig m => (a -> TExpr -> a) -> a ::: Type -> Elab m (a ::: Type) +instantiate :: Algebra sig m => (a -> TX.Type -> a) -> a ::: Type -> Elab m (a ::: Type) instantiate inst = go where go (e ::: _T) = case _T of TN.ForAll _ _T _B -> do m <- meta _T - go (inst e (TVar (Free (Left m))) ::: _B (metavar m)) + go (inst e (TX.TVar (Free (Left m))) ::: _B (metavar m)) _ -> pure $ e ::: _T @@ -163,7 +163,7 @@ sat a b | otherwise = True -evalTExpr :: Has (Reader ElabContext :+: State (Subst Type)) sig m => TExpr -> m Type +evalTExpr :: Has (Reader ElabContext :+: State (Subst Type)) sig m => TX.Type -> m Type evalTExpr texpr = TN.eval <$> get <*> views context_ toEnv <*> pure texpr depth :: Has (Reader ElabContext) sig m => m Level @@ -328,7 +328,7 @@ elabWith scale k m = runState k mempty . runWriter (const pure) $ do elabKind :: Has (Reader Graph :+: Reader Module :+: Reader Source) sig m => Elab m Kind -> m Kind elabKind = elabWith zero (const pure) -elabType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m TExpr -> m Type +elabType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m TX.Type -> m Type elabType = elabWith zero (\ subst t -> pure (TN.eval subst Env.empty t)) elabTerm :: Has (Reader Graph :+: Reader Module :+: Reader Source) sig m => Elab m Expr -> m Expr @@ -337,5 +337,5 @@ elabTerm = elabWith one (const pure) elabSynthTerm :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (Expr ::: Type) -> m (Expr ::: Type) elabSynthTerm = elabWith one (\ subst (e ::: _T) -> pure (e ::: TN.eval subst Env.empty (TN.quote 0 _T))) -elabSynthType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (TExpr ::: Kind) -> m (Type ::: Kind) +elabSynthType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (TX.Type ::: Kind) -> m (Type ::: Kind) elabSynthType = elabWith zero (\ subst (_T ::: _K) -> pure (TN.eval subst Env.empty _T ::: _K)) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index cf4597aeb..8382a06e7 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -77,7 +77,7 @@ import Facet.Subst import qualified Facet.Surface as S import Facet.Syntax import Facet.Term as E -import Facet.Type.Expr +import qualified Facet.Type.Expr as TX import Facet.Type.Norm as T hiding (global) import Facet.Unify import Facet.Usage hiding (restrict) @@ -235,14 +235,14 @@ bindPattern = go where -- | Elaborate a type abstracted over another type’s parameters. -- -- This is used to elaborate data constructors & effect operations, which receive the type/interface parameters as implicit parameters ahead of their own explicit ones. -abstractType :: (HasCallStack, Has (Throw Err) sig m) => Elab m TExpr -> Kind -> Elab m TExpr +abstractType :: (HasCallStack, Has (Throw Err) sig m) => Elab m TX.Type -> Kind -> Elab m TX.Type abstractType body = go where go = \case - KArrow (Just n) a b -> TForAll n a <$> ((zero, PVar (n ::: CK a)) |- go b) + KArrow (Just n) a b -> TX.TForAll n a <$> ((zero, PVar (n ::: CK a)) |- go b) _ -> body -abstractTerm :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => (Snoc TExpr -> Snoc Expr -> Expr) -> Check m Expr +abstractTerm :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => (Snoc TX.Type -> Snoc Expr -> Expr) -> Check m Expr abstractTerm body = go Nil Nil where go ts fs = Check $ \case @@ -254,7 +254,7 @@ abstractTerm body = go Nil Nil check (lam [(patternForArgType _A (fromMaybe __ n), go ts (fs :> \ d' -> XVar (Free (LName (levelToIndex d' d) (fromMaybe __ n)))))] ::: T.Arrow n q _A _B) _T -> do d <- depth - pure $ body (TVar . Free . Right . fmap (levelToIndex d) <$> ts) (fs <*> pure d) + pure $ body (TX.TVar . Free . Right . fmap (levelToIndex d) <$> ts) (fs <*> pure d) patternForArgType :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Type -> Name -> Bind m (Pattern (Name ::: Classifier)) patternForArgType = \case diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index c05b02c02..544585c7e 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -32,16 +32,16 @@ import Facet.Semiring (Few(..), one, zero) import Facet.Snoc import qualified Facet.Surface as S import Facet.Syntax -import Facet.Type.Expr +import qualified Facet.Type.Expr as TX import Facet.Type.Norm import GHC.Stack -tvar :: (HasCallStack, Has (Throw Err) sig m) => QName -> IsType m TExpr +tvar :: (HasCallStack, Has (Throw Err) sig m) => QName -> IsType m TX.Type tvar n = IsType $ views context_ (lookupInContext n) >>= \case - [(n', q, CK _K)] -> use n' q $> (TVar (Free (Right n')) ::: _K) + [(n', q, CK _K)] -> use n' q $> (TX.TVar (Free (Right n')) ::: _K) _ -> resolveQ n >>= \case - q :=: DData _ _K -> pure $ TVar (Global q) ::: _K - q :=: DInterface _ _K -> pure $ TVar (Global q) ::: _K + q :=: DData _ _K -> pure $ TX.TVar (Global q) ::: _K + q :=: DInterface _ _K -> pure $ TX.TVar (Global q) ::: _K _ -> freeVariable n ivar :: (HasCallStack, Has (Throw Err) sig m) => QName -> IsType m RName @@ -56,15 +56,15 @@ _Type = IsType $ pure $ KType ::: KType _Interface :: IsType m Kind _Interface = IsType $ pure $ KInterface ::: KType -_String :: IsType m TExpr -_String = IsType $ pure $ TString ::: KType +_String :: IsType m TX.Type +_String = IsType $ pure $ TX.TString ::: KType -forAll :: (HasCallStack, Has (Throw Err) sig m) => Name ::: IsType m Kind -> IsType m TExpr -> IsType m TExpr +forAll :: (HasCallStack, Has (Throw Err) sig m) => Name ::: IsType m Kind -> IsType m TX.Type -> IsType m TX.Type forAll (n ::: t) b = IsType $ do t' <- checkIsType (t ::: KType) b' <- (zero, PVar (n ::: CK t')) |- checkIsType (b ::: KType) - pure $ TForAll n t' b' ::: KType + pure $ TX.TForAll n t' b' ::: KType arrow :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> IsType m a -> IsType m b -> IsType m c arrow mk a b = IsType $ do @@ -82,12 +82,12 @@ app mk f a = IsType $ do pure $ mk f' a' ::: _B -comp :: (HasCallStack, Has (Throw Err) sig m) => [IsType m (Interface TExpr)] -> IsType m TExpr -> IsType m TExpr +comp :: (HasCallStack, Has (Throw Err) sig m) => [IsType m (Interface TX.Type)] -> IsType m TX.Type -> IsType m TX.Type comp s t = IsType $ do s' <- traverse (checkIsType . (::: KInterface)) s -- FIXME: polarize types and check that this is a value type being returned t' <- checkIsType (t ::: KType) - pure $ TComp (fromInterfaces s') t' ::: KType + pure $ TX.TComp (fromInterfaces s') t' ::: KType synthKind :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Kind -> IsType m Kind @@ -97,20 +97,20 @@ synthKind (S.Ann s _ e) = mapIsType (pushSpan s) $ case e of S.KInterface -> _Interface -synthType :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Type -> IsType m TExpr +synthType :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Type -> IsType m TX.Type synthType (S.Ann s _ e) = mapIsType (pushSpan s) $ case e of S.TVar n -> tvar n S.TString -> _String S.TForAll n t b -> forAll (n ::: synthKind t) (synthType b) - S.TArrow n q a b -> arrow (TArrow n (maybe Many interpretMul q)) (synthType a) (synthType b) + S.TArrow n q a b -> arrow (TX.TArrow n (maybe Many interpretMul q)) (synthType a) (synthType b) S.TComp s t -> comp (map synthInterface s) (synthType t) - S.TApp f a -> app TApp (synthType f) (synthType a) + S.TApp f a -> app TX.TApp (synthType f) (synthType a) where interpretMul = \case S.Zero -> zero S.One -> one -synthInterface :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Interface -> IsType m (Interface TExpr) +synthInterface :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Interface -> IsType m (Interface TX.Type) synthInterface (S.Ann s _ (S.Interface (S.Ann sh _ h) sp)) = IsType $ pushSpan s $ do -- FIXME: check that the application actually result in an Interface h' ::: _ <- pushSpan sh (isType (ivar h)) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index d675e8901..6a6658ad0 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -30,7 +30,7 @@ import Facet.Semialign (zipWithM) import Facet.Snoc.NonEmpty as NE hiding ((|>)) import Facet.Syntax import Facet.Term -import Facet.Type.Expr (TExpr) +import Facet.Type.Expr (Type) import GHC.Stack (HasCallStack) import Prelude hiding (zipWith) @@ -61,7 +61,7 @@ var env n = pure (index env n) tlam :: Eval m (Value (Eval m)) -> Eval m (Value (Eval m)) tlam = id -inst :: Eval m (Value (Eval m)) -> TExpr -> Eval m (Value (Eval m)) +inst :: Eval m (Value (Eval m)) -> Type -> Eval m (Value (Eval m)) inst = const lam :: Env (Value (Eval m)) -> [(Pattern Name, Expr)] -> Eval m (Value (Eval m)) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 5d2a9391f..47bd15e48 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -172,7 +172,7 @@ printType opts env = printTExpr opts env . TN.quote (level env) printInterface :: Options -> Env Print -> Interface TN.Type -> Print printInterface = printInterfaceWith printType -printTExpr :: Options -> Env Print -> TX.TExpr -> Print +printTExpr :: Options -> Env Print -> TX.Type -> Print printTExpr opts@Options{ rname } = go where qvar = group . setPrec Var . rname diff --git a/src/Facet/Term.hs b/src/Facet/Term.hs index 4252b5f26..769e3c7f0 100644 --- a/src/Facet/Term.hs +++ b/src/Facet/Term.hs @@ -7,14 +7,14 @@ import Data.Text (Text) import Facet.Name import Facet.Pattern import Facet.Syntax -import qualified Facet.Type.Expr as T +import qualified Facet.Type.Expr as TX -- Term expressions data Expr = XVar (Var (LName Index)) | XTLam Name Expr - | XInst Expr T.TExpr + | XInst Expr TX.Type | XLam [(Pattern Name, Expr)] | XApp Expr Expr | XCon RName [Expr] diff --git a/src/Facet/Type/Expr.hs b/src/Facet/Type/Expr.hs index f02bd5aa8..b7f2073c0 100644 --- a/src/Facet/Type/Expr.hs +++ b/src/Facet/Type/Expr.hs @@ -1,5 +1,5 @@ module Facet.Type.Expr -( TExpr(..) +( Type(..) ) where import Facet.Interface @@ -8,11 +8,11 @@ import Facet.Name import Facet.Syntax import Facet.Usage -data TExpr +data Type = TString | TVar (Var (Either Meta (LName Index))) - | TForAll Name Kind TExpr - | TArrow (Maybe Name) Quantity TExpr TExpr - | TComp (Signature TExpr) TExpr - | TApp TExpr TExpr + | TForAll Name Kind Type + | TArrow (Maybe Name) Quantity Type Type + | TComp (Signature Type) Type + | TApp Type Type deriving (Eq, Ord, Show) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 9670d20c7..14885a32f 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ImportQualifiedPost #-} module Facet.Type.Norm ( -- * Types Type(..) @@ -18,22 +19,22 @@ module Facet.Type.Norm , apply ) where -import Control.Effect.Empty -import Data.Foldable (foldl') -import Data.Function (on, (&)) -import Data.Maybe (fromMaybe) -import Facet.Env hiding (empty) -import Facet.Interface -import Facet.Kind -import Facet.Name -import Facet.Pattern -import Facet.Snoc -import Facet.Subst -import Facet.Syntax -import Facet.Type.Expr -import Facet.Usage hiding (singleton) -import GHC.Stack -import Prelude hiding (lookup) +import Control.Effect.Empty +import Data.Foldable (foldl') +import Data.Function (on, (&)) +import Data.Maybe (fromMaybe) +import Facet.Env hiding (empty) +import Facet.Interface +import Facet.Kind +import Facet.Name +import Facet.Pattern +import Facet.Snoc +import Facet.Subst +import Facet.Syntax +import qualified Facet.Type.Expr as TX +import Facet.Usage hiding (singleton) +import GHC.Stack +import Prelude hiding (lookup) -- Types @@ -111,25 +112,25 @@ infixl 9 $$, $$* -- Quotation -quote :: Level -> Type -> TExpr +quote :: Level -> Type -> TX.Type quote d = \case - String -> TString - ForAll n t b -> TForAll n t (quote (succ d) (b (free (LName d n)))) - Arrow n q a b -> TArrow n q (quote d a) (quote d b) - Comp s t -> TComp (mapSignature (quote d) s) (quote d t) - Ne n sp -> foldl' (&) (TVar (fmap (fmap (levelToIndex d)) <$> n)) (flip TApp . quote d <$> sp) + String -> TX.TString + ForAll n t b -> TX.TForAll n t (quote (succ d) (b (free (LName d n)))) + Arrow n q a b -> TX.TArrow n q (quote d a) (quote d b) + Comp s t -> TX.TComp (mapSignature (quote d) s) (quote d t) + Ne n sp -> foldl' (&) (TX.TVar (fmap (fmap (levelToIndex d)) <$> n)) (flip TX.TApp . quote d <$> sp) -eval :: HasCallStack => Subst Type -> Env Type -> TExpr -> Type +eval :: HasCallStack => Subst Type -> Env Type -> TX.Type -> Type eval subst = go where go env = \case - TString -> String - TVar (Global n) -> global n - TVar (Free (Right n)) -> index env n - TVar (Free (Left m)) -> fromMaybe (metavar m) (lookupMeta m subst) - TForAll n t b -> ForAll n t (\ _T -> go (env |> PVar (n :=: _T)) b) - TArrow n q a b -> Arrow n q (go env a) (go env b) - TComp s t -> Comp (mapSignature (go env) s) (go env t) - TApp f a -> go env f $$ go env a + TX.TString -> String + TX.TVar (Global n) -> global n + TX.TVar (Free (Right n)) -> index env n + TX.TVar (Free (Left m)) -> fromMaybe (metavar m) (lookupMeta m subst) + TX.TForAll n t b -> ForAll n t (\ _T -> go (env |> PVar (n :=: _T)) b) + TX.TArrow n q a b -> Arrow n q (go env a) (go env b) + TX.TComp s t -> Comp (mapSignature (go env) s) (go env t) + TX.TApp f a -> go env f $$ go env a apply :: HasCallStack => Subst Type -> Env Type -> Type -> Type apply subst env = eval subst env . quote (level env) diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index 9f74f2262..d93d75ee2 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -10,28 +10,28 @@ module Facet.Unify , unifyInterface ) where -import Control.Carrier.Empty.Church -import Control.Carrier.Error.Church -import Control.Effect.Reader -import Control.Effect.State -import Control.Effect.Sum -import Control.Effect.Writer -import Control.Monad (unless) -import Facet.Carrier.Throw.Inject -import Facet.Elab -import Facet.Interface -import Facet.Kind -import Facet.Name -import Facet.Pattern -import Facet.Semialign -import Facet.Semiring -import Facet.Snoc -import Facet.Subst -import Facet.Syntax -import Facet.Type.Expr -import Facet.Type.Norm as TN -import Facet.Usage -import GHC.Stack +import Control.Carrier.Empty.Church +import Control.Carrier.Error.Church +import Control.Effect.Reader +import Control.Effect.State +import Control.Effect.Sum +import Control.Effect.Writer +import Control.Monad (unless) +import Facet.Carrier.Throw.Inject +import Facet.Elab +import Facet.Interface +import Facet.Kind +import Facet.Name +import Facet.Pattern +import Facet.Semialign +import Facet.Semiring +import Facet.Snoc +import Facet.Subst +import Facet.Syntax +import qualified Facet.Type.Expr as TX +import Facet.Type.Norm as TN +import Facet.Usage +import GHC.Stack -- Unification @@ -68,7 +68,7 @@ unifyType = curry $ \case (TN.String, TN.String) -> pure TN.String (TN.String, _) -> mismatch where - mkForAll d n k b = TForAll n k (quote (succ d) b) + mkForAll d n k b = TX.TForAll n k (quote (succ d) b) unifyKind :: Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m => Kind -> Kind -> m Kind unifyKind k1 k2 = if k1 == k2 then pure k2 else mismatch From 9faa9d4cb688e1dc8bb8c1005900e9d324d04736 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 5 Apr 2021 01:10:07 -0400 Subject: [PATCH 0044/1324] Rename the Expr.Type constructors. --- src/Facet/Elab.hs | 2 +- src/Facet/Elab/Term.hs | 4 ++-- src/Facet/Elab/Type.hs | 16 ++++++++-------- src/Facet/Print.hs | 18 +++++++++--------- src/Facet/Type/Expr.hs | 12 ++++++------ src/Facet/Type/Norm.hs | 26 +++++++++++++------------- src/Facet/Unify.hs | 2 +- test/Facet/Core/Type/Test.hs | 4 ++-- 8 files changed, 42 insertions(+), 42 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 404df46e9..acc416f73 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -104,7 +104,7 @@ instantiate inst = go go (e ::: _T) = case _T of TN.ForAll _ _T _B -> do m <- meta _T - go (inst e (TX.TVar (Free (Left m))) ::: _B (metavar m)) + go (inst e (TX.Var (Free (Left m))) ::: _B (metavar m)) _ -> pure $ e ::: _T diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 8382a06e7..fe43ee842 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -239,7 +239,7 @@ abstractType :: (HasCallStack, Has (Throw Err) sig m) => Elab m TX.Type -> Kind abstractType body = go where go = \case - KArrow (Just n) a b -> TX.TForAll n a <$> ((zero, PVar (n ::: CK a)) |- go b) + KArrow (Just n) a b -> TX.ForAll n a <$> ((zero, PVar (n ::: CK a)) |- go b) _ -> body abstractTerm :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => (Snoc TX.Type -> Snoc Expr -> Expr) -> Check m Expr @@ -254,7 +254,7 @@ abstractTerm body = go Nil Nil check (lam [(patternForArgType _A (fromMaybe __ n), go ts (fs :> \ d' -> XVar (Free (LName (levelToIndex d' d) (fromMaybe __ n)))))] ::: T.Arrow n q _A _B) _T -> do d <- depth - pure $ body (TX.TVar . Free . Right . fmap (levelToIndex d) <$> ts) (fs <*> pure d) + pure $ body (TX.Var . Free . Right . fmap (levelToIndex d) <$> ts) (fs <*> pure d) patternForArgType :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Type -> Name -> Bind m (Pattern (Name ::: Classifier)) patternForArgType = \case diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 544585c7e..c7034aeaa 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -38,10 +38,10 @@ import GHC.Stack tvar :: (HasCallStack, Has (Throw Err) sig m) => QName -> IsType m TX.Type tvar n = IsType $ views context_ (lookupInContext n) >>= \case - [(n', q, CK _K)] -> use n' q $> (TX.TVar (Free (Right n')) ::: _K) + [(n', q, CK _K)] -> use n' q $> (TX.Var (Free (Right n')) ::: _K) _ -> resolveQ n >>= \case - q :=: DData _ _K -> pure $ TX.TVar (Global q) ::: _K - q :=: DInterface _ _K -> pure $ TX.TVar (Global q) ::: _K + q :=: DData _ _K -> pure $ TX.Var (Global q) ::: _K + q :=: DInterface _ _K -> pure $ TX.Var (Global q) ::: _K _ -> freeVariable n ivar :: (HasCallStack, Has (Throw Err) sig m) => QName -> IsType m RName @@ -57,14 +57,14 @@ _Interface :: IsType m Kind _Interface = IsType $ pure $ KInterface ::: KType _String :: IsType m TX.Type -_String = IsType $ pure $ TX.TString ::: KType +_String = IsType $ pure $ TX.String ::: KType forAll :: (HasCallStack, Has (Throw Err) sig m) => Name ::: IsType m Kind -> IsType m TX.Type -> IsType m TX.Type forAll (n ::: t) b = IsType $ do t' <- checkIsType (t ::: KType) b' <- (zero, PVar (n ::: CK t')) |- checkIsType (b ::: KType) - pure $ TX.TForAll n t' b' ::: KType + pure $ TX.ForAll n t' b' ::: KType arrow :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> IsType m a -> IsType m b -> IsType m c arrow mk a b = IsType $ do @@ -87,7 +87,7 @@ comp s t = IsType $ do s' <- traverse (checkIsType . (::: KInterface)) s -- FIXME: polarize types and check that this is a value type being returned t' <- checkIsType (t ::: KType) - pure $ TX.TComp (fromInterfaces s') t' ::: KType + pure $ TX.Comp (fromInterfaces s') t' ::: KType synthKind :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Kind -> IsType m Kind @@ -102,9 +102,9 @@ synthType (S.Ann s _ e) = mapIsType (pushSpan s) $ case e of S.TVar n -> tvar n S.TString -> _String S.TForAll n t b -> forAll (n ::: synthKind t) (synthType b) - S.TArrow n q a b -> arrow (TX.TArrow n (maybe Many interpretMul q)) (synthType a) (synthType b) + S.TArrow n q a b -> arrow (TX.Arrow n (maybe Many interpretMul q)) (synthType a) (synthType b) S.TComp s t -> comp (map synthInterface s) (synthType t) - S.TApp f a -> app TX.TApp (synthType f) (synthType a) + S.TApp f a -> app TX.App (synthType f) (synthType a) where interpretMul = \case S.Zero -> zero diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 47bd15e48..37246b13e 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -177,15 +177,15 @@ printTExpr opts@Options{ rname } = go where qvar = group . setPrec Var . rname go env = \case - TX.TVar (Global n) -> qvar n - TX.TVar (Free (Right n)) -> fromMaybe (lname (indexToLevel d <$> n)) $ Env.lookup env n - TX.TVar (Free (Left m)) -> meta m - TX.TForAll n t b -> braces (ann (intro n d ::: printKind env t)) --> go (env |> PVar (n :=: intro n d)) b - TX.TArrow Nothing q a b -> mult q (go env a) --> go env b - TX.TArrow (Just n) q a b -> parens (ann (intro n d ::: mult q (go env a))) --> go env b - TX.TComp s t -> if s == mempty then go env t else sig s <+> go env t - TX.TApp f a -> group (go env f) $$ group (go env a) - TX.TString -> annotate Type $ pretty "String" + TX.Var (Global n) -> qvar n + TX.Var (Free (Right n)) -> fromMaybe (lname (indexToLevel d <$> n)) $ Env.lookup env n + TX.Var (Free (Left m)) -> meta m + TX.ForAll n t b -> braces (ann (intro n d ::: printKind env t)) --> go (env |> PVar (n :=: intro n d)) b + TX.Arrow Nothing q a b -> mult q (go env a) --> go env b + TX.Arrow (Just n) q a b -> parens (ann (intro n d ::: mult q (go env a))) --> go env b + TX.Comp s t -> if s == mempty then go env t else sig s <+> go env t + TX.App f a -> group (go env f) $$ group (go env a) + TX.String -> annotate Type $ pretty "String" where d = level env sig s = brackets (commaSep (map (interface env) (interfaces s))) diff --git a/src/Facet/Type/Expr.hs b/src/Facet/Type/Expr.hs index b7f2073c0..61d70fe51 100644 --- a/src/Facet/Type/Expr.hs +++ b/src/Facet/Type/Expr.hs @@ -9,10 +9,10 @@ import Facet.Syntax import Facet.Usage data Type - = TString - | TVar (Var (Either Meta (LName Index))) - | TForAll Name Kind Type - | TArrow (Maybe Name) Quantity Type Type - | TComp (Signature Type) Type - | TApp Type Type + = String + | Var (Var (Either Meta (LName Index))) + | ForAll Name Kind Type + | Arrow (Maybe Name) Quantity Type Type + | Comp (Signature Type) Type + | App Type Type deriving (Eq, Ord, Show) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 14885a32f..d5e217032 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -114,23 +114,23 @@ infixl 9 $$, $$* quote :: Level -> Type -> TX.Type quote d = \case - String -> TX.TString - ForAll n t b -> TX.TForAll n t (quote (succ d) (b (free (LName d n)))) - Arrow n q a b -> TX.TArrow n q (quote d a) (quote d b) - Comp s t -> TX.TComp (mapSignature (quote d) s) (quote d t) - Ne n sp -> foldl' (&) (TX.TVar (fmap (fmap (levelToIndex d)) <$> n)) (flip TX.TApp . quote d <$> sp) + String -> TX.String + ForAll n t b -> TX.ForAll n t (quote (succ d) (b (free (LName d n)))) + Arrow n q a b -> TX.Arrow n q (quote d a) (quote d b) + Comp s t -> TX.Comp (mapSignature (quote d) s) (quote d t) + Ne n sp -> foldl' (&) (TX.Var (fmap (fmap (levelToIndex d)) <$> n)) (flip TX.App . quote d <$> sp) eval :: HasCallStack => Subst Type -> Env Type -> TX.Type -> Type eval subst = go where go env = \case - TX.TString -> String - TX.TVar (Global n) -> global n - TX.TVar (Free (Right n)) -> index env n - TX.TVar (Free (Left m)) -> fromMaybe (metavar m) (lookupMeta m subst) - TX.TForAll n t b -> ForAll n t (\ _T -> go (env |> PVar (n :=: _T)) b) - TX.TArrow n q a b -> Arrow n q (go env a) (go env b) - TX.TComp s t -> Comp (mapSignature (go env) s) (go env t) - TX.TApp f a -> go env f $$ go env a + TX.String -> String + TX.Var (Global n) -> global n + TX.Var (Free (Right n)) -> index env n + TX.Var (Free (Left m)) -> fromMaybe (metavar m) (lookupMeta m subst) + TX.ForAll n t b -> ForAll n t (\ _T -> go (env |> PVar (n :=: _T)) b) + TX.Arrow n q a b -> Arrow n q (go env a) (go env b) + TX.Comp s t -> Comp (mapSignature (go env) s) (go env t) + TX.App f a -> go env f $$ go env a apply :: HasCallStack => Subst Type -> Env Type -> Type -> Type apply subst env = eval subst env . quote (level env) diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index d93d75ee2..b52eb8700 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -68,7 +68,7 @@ unifyType = curry $ \case (TN.String, TN.String) -> pure TN.String (TN.String, _) -> mismatch where - mkForAll d n k b = TX.TForAll n k (quote (succ d) b) + mkForAll d n k b = TX.ForAll n k (quote (succ d) b) unifyKind :: Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m => Kind -> Kind -> m Kind unifyKind k1 k2 = if k1 == k2 then pure k2 else mismatch diff --git a/test/Facet/Core/Type/Test.hs b/test/Facet/Core/Type/Test.hs index 7168dbb56..37a87bf61 100644 --- a/test/Facet/Core/Type/Test.hs +++ b/test/Facet/Core/Type/Test.hs @@ -10,12 +10,12 @@ import Facet.Name import Facet.Semiring import Facet.Syntax import Facet.Type.Expr -import Facet.Type.Norm +import Facet.Type.Norm (eval, quote) import Hedgehog hiding (Var, eval) tests :: IO Bool tests = checkParallel $$(discover) prop_quotation_inverse = property $ do - let init = TForAll (U "A") KType (TArrow (Just (U "x")) Many (TVar (Free (Right (LName 0 (U "A"))))) (TComp mempty (TVar (Free (Right (LName 0 (U "A"))))))) + let init = ForAll (U "A") KType (Arrow (Just (U "x")) Many (Var (Free (Right (LName 0 (U "A"))))) (Comp mempty (Var (Free (Right (LName 0 (U "A"))))))) quote 0 (eval mempty empty init) === init From 19c7883dae40054e96c049555abda3d42f5523f6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 5 Apr 2021 21:04:22 -0400 Subject: [PATCH 0045/1324] Add computation terms. --- src/Facet/Eval.hs | 1 + src/Facet/Norm.hs | 1 + src/Facet/Print.hs | 1 + src/Facet/Term.hs | 1 + 4 files changed, 4 insertions(+) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 6a6658ad0..9ceb00b5f 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -46,6 +46,7 @@ eval env = \case XString s -> string s XDict os -> VDict <$> traverse (traverse (eval env)) os XLet p v b -> eval env v >>= \ v' -> eval (env |> fromMaybe (error "eval: non-exhaustive pattern in let") (matchV id p v')) b + XComp p b -> lam env [(PDict p, b)] -- FIXME: this won’t roundtrip correctly global :: Has (Reader Graph :+: Reader Module) sig m => RName -> Eval m Expr global n = do diff --git a/src/Facet/Norm.hs b/src/Facet/Norm.hs index ce228aaf7..4f2e4d700 100644 --- a/src/Facet/Norm.hs +++ b/src/Facet/Norm.hs @@ -69,6 +69,7 @@ norm env = \case XLam cs -> NLam (map (\ (p, b) -> (p, \ p' -> norm (env |> p') b)) cs) XDict os -> NDict (map (fmap (norm env)) os) XLet p v b -> norm (env |> fromMaybe (error "norm: non-exhaustive pattern in let") (match (norm env v) p)) b + XComp p b -> NLam [(PDict p, \ p' -> norm (env |> p') b)] -- FIXME: this won’t roundtrip correctly napp :: Norm -> Norm -> Norm diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 37246b13e..4a9d42919 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -215,6 +215,7 @@ printExpr opts@Options{ rname, instantiation } = go C.XString s -> annotate Lit $ pretty (show s) C.XDict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> rname n <+> equals <+> group (go env v)) os) <> flatAlt space line) C.XLet p v b -> let p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) in pretty "let" <+> braces (printPattern opts (def <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p') b + C.XComp p b -> comp (clause env (PDict p, b)) where d = level env qvar = group . setPrec Var . rname diff --git a/src/Facet/Term.hs b/src/Facet/Term.hs index 769e3c7f0..994c61b32 100644 --- a/src/Facet/Term.hs +++ b/src/Facet/Term.hs @@ -21,4 +21,5 @@ data Expr | XString Text | XDict [RName :=: Expr] | XLet (Pattern Name) Expr Expr + | XComp [RName :=: Name] Expr -- ^ NB: the first argument is a specialization of @'Pattern' 'Name'@ to the 'PDict' constructor deriving (Eq, Ord, Show) From 92a52257d4fb3fe42f9114b000209a99ac8651ed Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 5 Apr 2021 23:18:53 -0400 Subject: [PATCH 0046/1324] Generalize the decls_ lens over the definition parameter. --- src/Facet/Module.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 90b09055c..44f754202 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -23,7 +23,7 @@ module Facet.Module import Control.Algebra import Control.Effect.Choose import Control.Effect.Empty -import Control.Lens (Lens', coerced, lens) +import Control.Lens (Lens, Lens', coerced, lens) import Control.Monad ((<=<)) import Data.Bifunctor (first) import Data.Coerce @@ -89,7 +89,7 @@ lookupD n Module{ name, scope } = maybe empty (pure . first (name:.:)) (lookupSc newtype Scope a = Scope { decls :: Map.Map Name a } deriving (Monoid, Semigroup) -decls_ :: Lens' (Scope Def) (Map.Map Name Def) +decls_ :: Lens (Scope a) (Scope b) (Map.Map Name a) (Map.Map Name b) decls_ = coerced scopeFromList :: [Name :=: Def] -> Scope Def From 77b9d698c39d3363fa5b9abe4c214fcae2e8284a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 5 Apr 2021 23:19:16 -0400 Subject: [PATCH 0047/1324] Generalize scopeFromList. --- src/Facet/Module.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 44f754202..00ec9e578 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -92,7 +92,7 @@ newtype Scope a = Scope { decls :: Map.Map Name a } decls_ :: Lens (Scope a) (Scope b) (Map.Map Name a) (Map.Map Name b) decls_ = coerced -scopeFromList :: [Name :=: Def] -> Scope Def +scopeFromList :: [Name :=: a] -> Scope a scopeFromList = Scope . Map.fromList . map (\ (n :=: v) -> (n, v)) scopeToList :: Scope Def -> [Name :=: Def] From 33681ff451281186ce21e235ee1e7df268af26c0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 5 Apr 2021 23:19:30 -0400 Subject: [PATCH 0048/1324] Generalize scopeToList. --- src/Facet/Module.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 00ec9e578..332027e60 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -95,7 +95,7 @@ decls_ = coerced scopeFromList :: [Name :=: a] -> Scope a scopeFromList = Scope . Map.fromList . map (\ (n :=: v) -> (n, v)) -scopeToList :: Scope Def -> [Name :=: Def] +scopeToList :: Scope a -> [Name :=: a] scopeToList = map (uncurry (:=:)) . Map.toList . decls lookupScope :: Has Empty sig m => Name -> Scope Def -> m (Name :=: Def) From fae000ac6a30361bc282dfc1c2df3f9e865bd2cd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 5 Apr 2021 23:19:45 -0400 Subject: [PATCH 0049/1324] Generalize lookupScope. --- src/Facet/Module.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 332027e60..b9987f4eb 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -98,7 +98,7 @@ scopeFromList = Scope . Map.fromList . map (\ (n :=: v) -> (n, v)) scopeToList :: Scope a -> [Name :=: a] scopeToList = map (uncurry (:=:)) . Map.toList . decls -lookupScope :: Has Empty sig m => Name -> Scope Def -> m (Name :=: Def) +lookupScope :: Has Empty sig m => Name -> Scope a -> m (Name :=: a) lookupScope n (Scope ds) = maybe empty (pure . (n :=:)) (Map.lookup n ds) From 42fa5c89dbaf3671e2d2bc972e07904e86b167c8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Apr 2021 02:15:27 -0400 Subject: [PATCH 0050/1324] Effect operations are found in the context now. --- src/Facet/Elab/Term.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index fe43ee842..187495071 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -107,10 +107,9 @@ global (q ::: _T) = Synth $ instantiate XInst (XVar (Global q) ::: _T) -- FIXME: effect ops not in the sig are reported as not in scope -- FIXME: effect ops in the sig are available whether or not they’re in scope var :: (HasCallStack, Has (Throw Err) sig m) => QName -> Synth m Expr -var n = Synth $ ask >>= \ StaticContext{ module', graph } -> ask >>= \ ElabContext{ context, sig } -> if - | [(n', q, CT _T)] <- lookupInContext n context -> use n' q $> (XVar (Free n') ::: _T) - | [_ :=: DTerm (Just x) _T] <- lookupInSig n module' graph sig -> instantiate XInst (x ::: _T) - | otherwise -> resolveQ n >>= \case +var n = Synth $ views context_ (lookupInContext n) >>= \case + [(n', q, CT _T)] -> use n' q $> (XVar (Free n') ::: _T) + _ -> resolveQ n >>= \case n :=: DTerm _ _T -> synth $ global (n ::: _T) _ :=: _ -> freeVariable n From aff1d49cf89ecf2028381eb357becad0efb1d380 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Apr 2021 02:18:14 -0400 Subject: [PATCH 0051/1324] =?UTF-8?q?Interface=20scopes=20only=20hold=20op?= =?UTF-8?q?erations=E2=80=99=20types.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Elab.hs | 2 +- src/Facet/Elab/Term.hs | 2 +- src/Facet/Module.hs | 8 ++++---- src/Facet/Print.hs | 2 +- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index acc416f73..66b5e519c 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -131,7 +131,7 @@ lookupInContext (m:.n) -- FIXME: probably we should instead look up the effect op globally, then check for membership in the sig -- FIXME: return the index in the sig; it’s vital for evaluation of polymorphic effects when there are multiple such -lookupInSig :: Has (Choose :+: Empty) sig m => QName -> Module -> Graph -> [Signature Type] -> m (RName :=: Def) +lookupInSig :: Has (Choose :+: Empty) sig m => QName -> Module -> Graph -> [Signature Type] -> m (RName :=: Type) lookupInSig (m :. n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':.:_) _) -> do guard (m == Nil || m == toSnoc m') defs <- interfaceScope =<< lookupQ graph mod (toQ q) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 187495071..207e261a0 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -287,7 +287,7 @@ elabInterfaceDef elabInterfaceDef (dname ::: _T) constructors = do cs <- for constructors $ \ (S.Ann _ _ (n ::: t)) -> do _T' <- elabType $ abstractType (checkIsType (synthType t ::: KType)) _T - pure $ n :=: DTerm Nothing _T' + pure $ n :=: _T' pure [ dname :=: DInterface (scopeFromList cs) _T ] -- FIXME: add a parameter for the effect signature. diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index b9987f4eb..12fe76725 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -25,7 +25,7 @@ import Control.Effect.Choose import Control.Effect.Empty import Control.Lens (Lens, Lens', coerced, lens) import Control.Monad ((<=<)) -import Data.Bifunctor (first) +import Data.Bifunctor (Bifunctor(bimap), first) import Data.Coerce import qualified Data.Map as Map import Facet.Kind @@ -80,7 +80,7 @@ lookupC n Module{ name, scope } = foldMapC matchDef (decls scope) lookupE :: Has (Choose :+: Empty) sig m => Name -> Module -> m (RName :=: Def) lookupE n Module{ name, scope } = foldMapC matchDef (decls scope) where - matchDef = fmap (first (name:.:)) . lookupScope n . tm <=< unDInterface + matchDef = fmap (bimap (name:.:) (DTerm Nothing)) . lookupScope n . tm <=< unDInterface lookupD :: Has Empty sig m => Name -> Module -> m (RName :=: Def) lookupD n Module{ name, scope } = maybe empty (pure . first (name:.:)) (lookupScope n scope) @@ -108,7 +108,7 @@ newtype Import = Import { name :: MName } data Def = DTerm (Maybe Expr) Type | DData (Scope Def) Kind - | DInterface (Scope Def) Kind + | DInterface (Scope Type) Kind | DModule (Scope Def) Kind unDTerm :: Has Empty sig m => Def -> m (Maybe Expr ::: Type) @@ -121,7 +121,7 @@ unDData = \case DData cs _K -> pure $ cs ::: _K _ -> empty -unDInterface :: Has Empty sig m => Def -> m (Scope Def ::: Kind) +unDInterface :: Has Empty sig m => Def -> m (Scope Type ::: Kind) unDInterface = \case DInterface cs _K -> pure $ cs ::: _K _ -> empty diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 4a9d42919..b3a1d49f5 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -247,7 +247,7 @@ printModule (C.Module mname is _ ds) = module_ C.DData cs _K -> annotate Keyword (pretty "data") <+> declList (map def (C.scopeToList cs)) C.DInterface os _K -> annotate Keyword (pretty "interface") <+> declList - (map def (C.scopeToList os)) + (map (def . fmap (C.DTerm Nothing)) (C.scopeToList os)) C.DModule ds _K -> block (concatWith (surround hardline) (map ((hardline <>) . def) (C.scopeToList ds))) declList = block . group . concatWith (surround (hardline <> comma <> space)) . map group import' n = pretty "import" <+> braces (setPrec Var (prettyMName n)) From c3e1bac2ecd077aa1a6f9897ecd10854881db3c5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Apr 2021 02:19:45 -0400 Subject: [PATCH 0052/1324] Factor out the printer for the body of definitions. --- src/Facet/Print.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index b3a1d49f5..e8d6bf0d6 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -241,14 +241,15 @@ printModule (C.Module mname is _ ds) = module_ where def (n :=: d) = ann $ qvar (Nil:.n) - ::: case d of - C.DTerm Nothing _T -> printType opts empty _T - C.DTerm (Just b) _T -> defn (printType opts empty _T :=: printExpr opts empty b) - C.DData cs _K -> annotate Keyword (pretty "data") <+> declList - (map def (C.scopeToList cs)) - C.DInterface os _K -> annotate Keyword (pretty "interface") <+> declList - (map (def . fmap (C.DTerm Nothing)) (C.scopeToList os)) - C.DModule ds _K -> block (concatWith (surround hardline) (map ((hardline <>) . def) (C.scopeToList ds))) + ::: defBody d + defBody = \case + C.DTerm Nothing _T -> printType opts empty _T + C.DTerm (Just b) _T -> defn (printType opts empty _T :=: printExpr opts empty b) + C.DData cs _K -> annotate Keyword (pretty "data") <+> declList + (map def (C.scopeToList cs)) + C.DInterface os _K -> annotate Keyword (pretty "interface") <+> declList + (map (def . fmap (C.DTerm Nothing)) (C.scopeToList os)) + C.DModule ds _K -> block (concatWith (surround hardline) (map ((hardline <>) . def) (C.scopeToList ds))) declList = block . group . concatWith (surround (hardline <> comma <> space)) . map group import' n = pretty "import" <+> braces (setPrec Var (prettyMName n)) module_ n t is ds = ann (setPrec Var (prettyMName n) ::: t) concatWith (surround hardline) (is ++ map (hardline <>) ds) From 357f6c81d4a1b95e44719b757993c5fb9319559c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Apr 2021 02:20:13 -0400 Subject: [PATCH 0053/1324] Reformat def. --- src/Facet/Print.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index e8d6bf0d6..63d5497db 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -239,9 +239,7 @@ printModule (C.Module mname is _ ds) = module_ (map (\ (C.Import n) -> import' n) is) (map def (C.scopeToList ds)) where - def (n :=: d) = ann - $ qvar (Nil:.n) - ::: defBody d + def (n :=: d) = ann (qvar (Nil:.n) ::: defBody d) defBody = \case C.DTerm Nothing _T -> printType opts empty _T C.DTerm (Just b) _T -> defn (printType opts empty _T :=: printExpr opts empty b) From 3e47a7498df468b17488eff6d2e72ac1b0840826 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Apr 2021 02:21:31 -0400 Subject: [PATCH 0054/1324] Define def nonrecursively. --- src/Facet/Print.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 63d5497db..59ffd98a4 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -237,17 +237,17 @@ printModule (C.Module mname is _ ds) = module_ mname (qvar (fromList [T.pack "Kernel"]:.U (T.pack "Module"))) (map (\ (C.Import n) -> import' n) is) - (map def (C.scopeToList ds)) + (map (def . fmap defBody) (C.scopeToList ds)) where - def (n :=: d) = ann (qvar (Nil:.n) ::: defBody d) + def (n :=: d) = ann (qvar (Nil:.n) ::: d) defBody = \case C.DTerm Nothing _T -> printType opts empty _T C.DTerm (Just b) _T -> defn (printType opts empty _T :=: printExpr opts empty b) C.DData cs _K -> annotate Keyword (pretty "data") <+> declList - (map def (C.scopeToList cs)) + (map (def . fmap defBody) (C.scopeToList cs)) C.DInterface os _K -> annotate Keyword (pretty "interface") <+> declList - (map (def . fmap (C.DTerm Nothing)) (C.scopeToList os)) - C.DModule ds _K -> block (concatWith (surround hardline) (map ((hardline <>) . def) (C.scopeToList ds))) + (map (def . fmap (printType opts empty)) (C.scopeToList os)) + C.DModule ds _K -> block (concatWith (surround hardline) (map ((hardline <>) . def . fmap defBody) (C.scopeToList ds))) declList = block . group . concatWith (surround (hardline <> comma <> space)) . map group import' n = pretty "import" <+> braces (setPrec Var (prettyMName n)) module_ n t is ds = ann (setPrec Var (prettyMName n) ::: t) concatWith (surround hardline) (is ++ map (hardline <>) ds) From 3e9686136b5dde744d114cc4b86c96cca0651dd9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Apr 2021 02:25:34 -0400 Subject: [PATCH 0055/1324] Factor out the common structure of scope printing. --- src/Facet/Print.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 59ffd98a4..f40e7d665 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -243,12 +243,11 @@ printModule (C.Module mname is _ ds) = module_ defBody = \case C.DTerm Nothing _T -> printType opts empty _T C.DTerm (Just b) _T -> defn (printType opts empty _T :=: printExpr opts empty b) - C.DData cs _K -> annotate Keyword (pretty "data") <+> declList - (map (def . fmap defBody) (C.scopeToList cs)) - C.DInterface os _K -> annotate Keyword (pretty "interface") <+> declList - (map (def . fmap (printType opts empty)) (C.scopeToList os)) - C.DModule ds _K -> block (concatWith (surround hardline) (map ((hardline <>) . def . fmap defBody) (C.scopeToList ds))) - declList = block . group . concatWith (surround (hardline <> comma <> space)) . map group + C.DData cs _K -> annotate Keyword (pretty "data") <+> scope defBody cs + C.DInterface os _K -> annotate Keyword (pretty "interface") <+> scope (printType opts empty) os + C.DModule ds _K -> block (concatWith (surround hardline) (map ((hardline <>) . def . fmap defBody) (C.scopeToList ds))) + scope :: (a -> Print) -> C.Scope a -> Print + scope with = block . group . concatWith (surround (hardline <> comma <> space)) . map (group . def . fmap with) . C.scopeToList import' n = pretty "import" <+> braces (setPrec Var (prettyMName n)) module_ n t is ds = ann (setPrec Var (prettyMName n) ::: t) concatWith (surround hardline) (is ++ map (hardline <>) ds) defn (a :=: b) = group a <> hardline <> group b From 6e5d18b88fbc97b7f1286e0c6488fc3189f9ed8b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Apr 2021 02:25:53 -0400 Subject: [PATCH 0056/1324] :fire: a redundant type signature. --- src/Facet/Print.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index f40e7d665..07bbd40d7 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -246,7 +246,6 @@ printModule (C.Module mname is _ ds) = module_ C.DData cs _K -> annotate Keyword (pretty "data") <+> scope defBody cs C.DInterface os _K -> annotate Keyword (pretty "interface") <+> scope (printType opts empty) os C.DModule ds _K -> block (concatWith (surround hardline) (map ((hardline <>) . def . fmap defBody) (C.scopeToList ds))) - scope :: (a -> Print) -> C.Scope a -> Print scope with = block . group . concatWith (surround (hardline <> comma <> space)) . map (group . def . fmap with) . C.scopeToList import' n = pretty "import" <+> braces (setPrec Var (prettyMName n)) module_ n t is ds = ann (setPrec Var (prettyMName n) ::: t) concatWith (surround hardline) (is ++ map (hardline <>) ds) From 6e9ebfa257078665e5d7d751451479fa34426cca Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Apr 2021 03:39:33 -0400 Subject: [PATCH 0057/1324] Use toQ a little more widely. --- src/Facet/Lexer.hs | 3 +-- src/Facet/Parser.hs | 5 ++--- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Facet/Lexer.hs b/src/Facet/Lexer.hs index ab81e339a..c552864ab 100644 --- a/src/Facet/Lexer.hs +++ b/src/Facet/Lexer.hs @@ -12,7 +12,6 @@ import Data.Text (Text, pack) import Facet.Effect.Parser import Facet.Name import Facet.Snoc -import Facet.Snoc.NonEmpty import Facet.Span import Text.Parser.Char import Text.Parser.Combinators @@ -65,7 +64,7 @@ kind_ = choice , RBracket <$ char ']' "]" , LAngle <$ char '<' "<" , RAngle <$ char '>' ">" - , QIdent <$> ((:.) . toSnoc <$> mname <* dot <*> choice [ U <$> ename, U <$> tname ]) + , QIdent <$> (fmap toQ . (:.:) <$> mname <* dot <*> choice [ U <$> ename, U <$> tname ]) , MIdent <$> mname , EIdent . U <$> ename , TIdent . U <$> tname diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index a2a6c4e4b..c6e45befa 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -35,7 +35,6 @@ import Facet.Effect.Parser import qualified Facet.Name as N import Facet.Parser.Table as Op import Facet.Snoc -import Facet.Snoc.NonEmpty (toSnoc) import Facet.Span import qualified Facet.Surface as S import Facet.Syntax @@ -58,7 +57,7 @@ whole p = whiteSpace *> p <* eof makeOperator :: (N.MName, N.Op, N.Assoc) -> Operator (S.Ann S.Expr) -makeOperator (name, op, assoc) = (op, assoc, nary (toSnoc name N.:. N.O op)) +makeOperator (name, op, assoc) = (op, assoc, nary (N.toQ (name N.:.: N.O op))) where nary name es = foldl' (S.annBinary S.App) (S.Ann (S.ann (head es)) Nil (S.Var name)) es @@ -308,7 +307,7 @@ mname = token (runUnspaced (fromList <$> sepBy1 comp dot)) comp = ident tnameStyle qname :: (Has Parser sig p, TokenParsing p) => p N.Name -> p N.QName -qname name = token (runUnspaced (try ((N.:.) . toSnoc <$> mname <*> Unspaced name) <|> (Nil N.:.) <$> Unspaced name)) "name" +qname name = token (runUnspaced (try (fmap N.toQ . (N.:.:) <$> mname <*> Unspaced name) <|> (Nil N.:.) <$> Unspaced name)) "name" reserved :: HashSet.HashSet String From 2d7ae0374681c5351270d9baf606d131818b6f84 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Apr 2021 07:54:54 -0400 Subject: [PATCH 0058/1324] Extract the formatting of Op. --- src/Facet/Name.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 0c39ff9f4..9f04a257c 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -122,14 +122,17 @@ data Op | Outfix Text Text deriving (Eq, Ord, Show) +formatOp :: (a -> a -> a) -> (Text -> a) -> a -> Op -> a +formatOp (<+>) pretty place = \case + Prefix s -> pretty s <+> place + Postfix s -> place <+> pretty s + Infix s -> place <+> pretty s <+> place + Outfix s e -> pretty s <+> place <+> pretty e + -- FIXME: specify relative precedences instance P.Pretty Op where - pretty = \case - Prefix s -> P.pretty s <+> place - Postfix s -> place <+> P.pretty s - Infix s -> place <+> P.pretty s <+> place - Outfix s e -> P.pretty s <+> place <+> P.pretty e + pretty = formatOp (<+>) P.pretty place where place = P.pretty '_' From 2e5396409466a3fc16dc98c0766d01a7d5bb962d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Apr 2021 07:55:11 -0400 Subject: [PATCH 0059/1324] Export the formatting of Op. --- src/Facet/Name.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 9f04a257c..1f8b29173 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -15,6 +15,7 @@ module Facet.Name , Name(..) , Assoc(..) , Op(..) +, formatOp , OpN(..) ) where From 49e1ae73ce16b1200b3223395f6a5d3d2304abaa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Apr 2021 08:36:27 -0400 Subject: [PATCH 0060/1324] Format OpN. --- src/Facet/Name.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 1f8b29173..2d82e7a4a 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -17,9 +17,10 @@ module Facet.Name , Op(..) , formatOp , OpN(..) +, formatOpN ) where -import Data.Foldable (foldr', toList) +import Data.Foldable (foldl', foldr', toList) import Data.Functor.Classes (showsUnaryWith) import qualified Data.List.NonEmpty as NE import Data.String (IsString(..)) @@ -149,3 +150,10 @@ data OpN deriving (Eq, Ord, Show) -- FIXME: can we treat this more compositionally instead? i.e. treat an n-ary prefix operator as a composition of individual prefix operators? Then each placeholder lines up with a unary operator corresponding to the type of the tail + +formatOpN :: (a -> a -> a) -> (Text -> a) -> a -> OpN -> a +formatOpN (<+>) pretty place = \case + PrefixN s ss -> foldl' (<+>) (comp s) (map comp ss) where comp s = pretty s <+> place + PostfixN ee e -> foldr' (<+>) (comp e) (map comp ee) where comp e = place <+> pretty e + InfixN (m NE.:|mm) -> place <+> foldr' comp (pretty m) mm <+> place where comp s e = pretty s <+> place <+> e + OutfixN s mm e -> foldr' comp (pretty e) (s : mm) where comp s e = pretty s <+> place <+> e From ec49eb991efc7a2d600d9bc3873b6986caeb4971 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Apr 2021 08:41:19 -0400 Subject: [PATCH 0061/1324] Extract and combine module name showing. --- src/Facet/Name.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 2d82e7a4a..e77f61a6c 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -22,6 +22,7 @@ module Facet.Name import Data.Foldable (foldl', foldr', toList) import Data.Functor.Classes (showsUnaryWith) +import Data.List (intersperse) import qualified Data.List.NonEmpty as NE import Data.String (IsString(..)) import Data.Text (Text) @@ -65,13 +66,17 @@ type MName = NonEmpty Text prettyMName :: Printer a => MName -> a prettyMName (ns:|>n) = foldr' (surround dot . pretty) (pretty n) ns +showsModuleName :: (Foldable t, Show a, Show b) => String -> t a -> b -> Int -> ShowS +showsModuleName c m n p = showParen (p > 9) $ foldl' (.) id (intersperse (showChar '.') (shows <$> toList m)) . showString c . showsPrec 10 n + + -- | Qualified names, consisting of a module name and declaration name. data QName = Snoc Text :. Name -- FIXME: use Name on the lhs so we can accommodate datatypes with operator names deriving (Eq, Ord) instance Show QName where - showsPrec p (m :. n) = showParen (p > 9) $ shows (T.intercalate "." (toList m)) . showString ":." . showsPrec 10 n + showsPrec p (m :. n) = showsModuleName ":." m n p instance P.Pretty QName where pretty (m :. n) = foldr' (surround dot . pretty) (pretty n) m @@ -82,7 +87,7 @@ data RName = MName :.: Name deriving (Eq, Ord) instance Show RName where - showsPrec p (m :.: n) = showParen (p > 9) $ shows (T.intercalate "." (toList m)) . showString ":.:" . showsPrec 10 n + showsPrec p (m :.: n) = showsModuleName ":.:" m n p instance P.Pretty RName where pretty (m :.: n) = foldr' (surround dot . pretty) (pretty n) m From 30d147a8798aa28cb4611b0d3a43546b6b7791fc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Apr 2021 08:42:16 -0400 Subject: [PATCH 0062/1324] Module name components are Names, not just Text. --- src/Facet/Driver.hs | 7 +++++-- src/Facet/Name.hs | 4 ++-- src/Facet/Parser.hs | 2 +- src/Facet/Print.hs | 2 +- 4 files changed, 9 insertions(+), 6 deletions(-) diff --git a/src/Facet/Driver.hs b/src/Facet/Driver.hs index baf248cfa..97abe0229 100644 --- a/src/Facet/Driver.hs +++ b/src/Facet/Driver.hs @@ -85,7 +85,7 @@ kernel :: Module kernel = Module kernelName [] [] $ Scope mempty -- FIXME: include things like Type and Interface where - kernelName = fromList [TS.pack "Kernel"] + kernelName = fromList [U (TS.pack "Kernel")] -- Module loading @@ -164,7 +164,10 @@ resolveName searchPaths name = do [] -> [] _ -> [ nest 2 (reflow "search paths:" <\> concatWith (<\>) (map pretty searchPaths)) ] where - toPath components = foldr1 (FP.) (TS.unpack <$> components) + toPath components = foldr1 (FP.) (unpack <$> components) + unpack = \case + U n -> TS.unpack n + O o -> formatOp (\ a b -> a <> " " <> b) TS.unpack "_" o -- Errors diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index e77f61a6c..9d70d9b0a 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -61,7 +61,7 @@ __ :: Name __ = U T.empty -type MName = NonEmpty Text +type MName = NonEmpty Name prettyMName :: Printer a => MName -> a prettyMName (ns:|>n) = foldr' (surround dot . pretty) (pretty n) ns @@ -72,7 +72,7 @@ showsModuleName c m n p = showParen (p > 9) $ foldl' (.) id (intersperse (showCh -- | Qualified names, consisting of a module name and declaration name. -data QName = Snoc Text :. Name -- FIXME: use Name on the lhs so we can accommodate datatypes with operator names +data QName = Snoc Name :. Name deriving (Eq, Ord) instance Show QName where diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index c6e45befa..f404832de 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -203,7 +203,7 @@ signature = brackets (commaSep delta) "signature" where delta = anned $ S.Interface <$> head <*> (fromList <$> many type') head = fmap mkHead <$> token (anned (runUnspaced (sepByNonEmpty comp dot))) - mkHead cs = fromList (NE.init cs) N.:. N.U (NE.last cs) + mkHead cs = fromList (NE.init cs) N.:. NE.last cs comp = ident tnameStyle diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 07bbd40d7..bf0a255ee 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -235,7 +235,7 @@ printPattern Options{ rname } = go printModule :: C.Module -> Print printModule (C.Module mname is _ ds) = module_ mname - (qvar (fromList [T.pack "Kernel"]:.U (T.pack "Module"))) + (qvar (fromList [U (T.pack "Kernel")]:.U (T.pack "Module"))) (map (\ (C.Import n) -> import' n) is) (map (def . fmap defBody) (C.scopeToList ds)) where From 42d679276c0ad973ed9f5ba53a6af19318d1c4f9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Apr 2021 08:43:53 -0400 Subject: [PATCH 0063/1324] Define a constructor for appending onto RNames. --- src/Facet/Name.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 9d70d9b0a..7f1e36354 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -10,6 +10,7 @@ module Facet.Name , prettyMName , QName(..) , RName(..) +, (.:.) , toQ , LName(..) , Name(..) @@ -92,6 +93,10 @@ instance Show RName where instance P.Pretty RName where pretty (m :.: n) = foldr' (surround dot . pretty) (pretty n) m +-- | Append a 'Name' onto an 'RName'. +(.:.) :: RName -> Name -> RName +m :.: n .:. n' = (m |> n) :.: n' + -- | Weaken an 'RName' to a 'QName'. This is primarily used for performing lookups in the graph starting from an 'RName' where the stronger structure is not required. toQ :: RName -> QName toQ (m :.: n) = toSnoc m :. n From 03b150458ddeaf1312efa1977b6d6154c17ec04c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Apr 2021 08:45:08 -0400 Subject: [PATCH 0064/1324] Define an elab combinator for constructing computations as lambdas from dictionaries. --- src/Facet/Elab/Term.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 207e261a0..d750b41df 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -12,6 +12,7 @@ module Facet.Elab.Term , app , string , let' +, comp -- * Pattern combinators , wildcardP , varP @@ -53,7 +54,7 @@ import Data.Bifunctor (first) import Data.Either (partitionEithers) import Data.Foldable import Data.Functor -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import Data.Monoid (Ap(..), First(..)) import qualified Data.Set as Set import Data.Text (Text) @@ -152,6 +153,18 @@ let' p a b = Check $ \ _B -> do pure $ XLet p' a' b' +comp :: Has (Throw Err) sig m => Check m Expr -> Check m Expr +comp b = Check $ \ _T -> do + (sig, _B) <- assertComp _T + StaticContext{ graph, module' } <- ask + let interfacePattern :: Has (Throw Err) sig m => Interface Type -> Elab m (RName :=: (Name ::: Classifier)) + interfacePattern (Interface n _) = maybe (freeVariable (toQ n)) (\ (n' :=: _T) -> pure ((n .:. n') :=: (n' ::: CT _T))) (listToMaybe (scopeToList . tm =<< unDInterface . def =<< lookupQ graph module' (toQ n))) + p' <- traverse interfacePattern (interfaces sig) + -- FIXME: can we apply quantities to dictionaries? what would they mean? + b' <- (Many, PDict p') |- check (b ::: _B) + pure $ XComp (map (fmap tm) p') b' + + -- Pattern combinators wildcardP :: Bind m (Pattern (Name ::: Classifier)) From 9335c46ef7ced10653b953c88ca4332167c9614e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Apr 2021 08:46:34 -0400 Subject: [PATCH 0065/1324] Extract checkLam to the top level. --- src/Facet/Elab/Term.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index d750b41df..96266eb7e 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -225,14 +225,14 @@ checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in flip withS S.App{} -> switch (synthExpr expr) S.As{} -> switch (synthExpr expr) S.String{} -> switch (synthExpr expr) + +checkLam :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => [S.Clause] -> Check m Expr +checkLam cs = lam (snd vs) where - checkLam :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => [S.Clause] -> Check m Expr - checkLam cs = lam (snd vs) - where - vs :: Has (Throw Err :+: Write Warn) sig m => ([QName :=: Check m Expr], [(Bind m (Pattern (Name ::: Classifier)), Check m Expr)]) - vs = partitionEithers (map (\ (S.Clause (S.Ann _ _ p) b) -> case p of - S.PVal p -> Right (bindPattern p, checkExpr b) - S.PEff (S.Ann s _ (S.POp n fs k)) -> Left $ n :=: mapCheck (pushSpan s) (foldr (lam1 . bindPattern) (checkExpr b) (fromList fs:>k))) cs) + vs :: Has (Throw Err :+: Write Warn) sig m => ([QName :=: Check m Expr], [(Bind m (Pattern (Name ::: Classifier)), Check m Expr)]) + vs = partitionEithers (map (\ (S.Clause (S.Ann _ _ p) b) -> case p of + S.PVal p -> Right (bindPattern p, checkExpr b) + S.PEff (S.Ann s _ (S.POp n fs k)) -> Left $ n :=: mapCheck (pushSpan s) (foldr (lam1 . bindPattern) (checkExpr b) (fromList fs:>k))) cs) -- FIXME: check for unique variable names From 292bd5c0fa86ac3aeb7894e9708764bee117a2d9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Apr 2021 08:02:03 -0400 Subject: [PATCH 0066/1324] Start :memo:ing elaboration. --- docs/elaboration.md | 57 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 57 insertions(+) create mode 100644 docs/elaboration.md diff --git a/docs/elaboration.md b/docs/elaboration.md new file mode 100644 index 000000000..83a0540a3 --- /dev/null +++ b/docs/elaboration.md @@ -0,0 +1,57 @@ +# Elaboration + +Elaboration takes a syntactically valid surface program (resp. declaratio, definition, type, expression, etc) and either yields a semantically valid core program, or fails with an error (hopefully clear and informative enough to suggest a solution). The type language is simple enough that we’re going to ignore it for now and instead focus on the term language, which has some deviations from a standard bidirectional typechecker which warrant discussion. + + +## Syntax + +The syntax is mostly unsurprising, featuring such diverse elements as contexts: + +``` +Γ ::= ◊ | Γ, x : τ | Γ, X : κ +``` + +Types: + +``` +τ ::= {X : κ} -> τ | X | τ -> τ +``` + + +## Judgements + +Elaboration is performed bidrectionally, and thus consists of two judgements, checking and synthesis. + + +### Checking + +``` +Γ ⊢ M ~~> V <== τ +``` + +This judgement is used to elaborate syntax where we need to know the type in advance. + + +### Synthesis + +``` +Γ ⊢ M ~~> V ==> τ +``` + +This judgement is used to elaborate syntax where we can deduce the type from the term itselr, perhaps requiring that we are able to deduce some or all of it from its components. + + +### Syntax- vs. type-directed + +Bidirectional typecheckers are typically _syntax-directed_, meaning that we can typecheck by walking over the input syntax and alternately checking/synthesizing according to what piece of syntax we’re looking at. This has the nice property that there are no _choices_, i.e. no points at which there might be two ways to arrive at a result, each of which could fail independent of the other, and which would therefore require wasteful backtracking. + +In Facet’s case, matters are muddied slightly by computations, which are not explicit in the surface syntax for terms, but are instead indicated by the type. That is, a term at type `A` may well elaborate differently than the same syntactic term at type `[…] A`. Note that I’m saying `[…] A`, which embeds `A`, and not (for example) some unrelated type `B`; the distinction is solely on the presence or absence of a computation type around the result type. + + +### Computation types + +Computation types are computations in the CBPV/polarization sense, i.e. negative, and thus are lazily evaluated. The elaborator models this by treating them as a kind of function type mapping products of operations—dictionaries—to the computed result. + +## Strategy + +Computation types arise in arguments and returns. From 1b40d713558b823faecd245bc8741e223d1a54b6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Apr 2021 08:08:08 -0400 Subject: [PATCH 0067/1324] Fix some missed bits in Lexer. --- src/Facet/Lexer.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Lexer.hs b/src/Facet/Lexer.hs index c552864ab..3606ef454 100644 --- a/src/Facet/Lexer.hs +++ b/src/Facet/Lexer.hs @@ -64,10 +64,10 @@ kind_ = choice , RBracket <$ char ']' "]" , LAngle <$ char '<' "<" , RAngle <$ char '>' ">" - , QIdent <$> (fmap toQ . (:.:) <$> mname <* dot <*> choice [ U <$> ename, U <$> tname ]) + , QIdent <$> (fmap toQ . (:.:) <$> mname <* dot <*> choice [ U <$> ename, tname ]) , MIdent <$> mname , EIdent . U <$> ename - , TIdent . U <$> tname + , TIdent <$> tname , HIdent . U <$> ident (char '?') nameChar "hole name" ] where @@ -76,8 +76,8 @@ kind_ = choice tname = tcomp "type name" dot = char '.' "." ecomp = ident (choice [ lower, char '_' ]) nameChar - tcomp :: CharParsing p => p Text - tcomp = ident (choice [ upper, char '_' ]) nameChar + tcomp :: CharParsing p => p Name + tcomp = U <$> ident (choice [ upper, char '_' ]) nameChar ident :: CharParsing p => p Char -> p Char -> p Text ident i r = fmap pack . (:) <$> i <*> many r From d9251a8ac8d4a5833a133e63d4d023adbb78bd3f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Apr 2021 22:01:45 -0400 Subject: [PATCH 0068/1324] :memo: rules for strings and thunks. --- docs/elaboration.md | 30 +++++++++++++++++++++++++++++- 1 file changed, 29 insertions(+), 1 deletion(-) diff --git a/docs/elaboration.md b/docs/elaboration.md index 83a0540a3..baf5cff3e 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -20,7 +20,16 @@ Types: ## Judgements -Elaboration is performed bidrectionally, and thus consists of two judgements, checking and synthesis. +Elaboration is _specified_ as a single judgement relating surface terms to core terms at a core type. However, it is _performed_ bidrectionally, and thus in practice consists of two judgements, checking and synthesis. We’ll give rules for each of these as convenience allows. + + +### Elaboration + +``` +Γ ⊢ M ~~> V : τ +``` + +This judgement can be recovered by “erasing” the directionality of the two bidirectional judgements by replacing the `<==`/`==>` symbols with `:`. Note that this judgement is in general nondeterministic, and thus should not be considered as specifying an algorithm. (That’s what the bidirectional judgements are for.) ### Checking @@ -55,3 +64,22 @@ Computation types are computations in the CBPV/polarization sense, i.e. negative ## Strategy Computation types arise in arguments and returns. + +### Positive terms + +#### String literals + +``` +-------------------------- +Γ ⊢ "…" ~~> "…" ==> String +``` + +#### Thunks + +Technically these can’t appear in the surface syntax right now, but here’s the proposed rule. (It bidirectionalizes trivially by replacing `:` with `<==`/`==>` in both premise and conclusion.) + +``` + Γ ⊢ M ~~> M′ : T +-------------------------- +Γ ⊢ {M} ~~> {M′} : Thunk T +``` From 69ef2b73ea0bcdcc91992146c24f5aa2d6d0841b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Apr 2021 22:02:15 -0400 Subject: [PATCH 0069/1324] Spacing. --- docs/elaboration.md | 1 + 1 file changed, 1 insertion(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index baf5cff3e..fd657f113 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -65,6 +65,7 @@ Computation types are computations in the CBPV/polarization sense, i.e. negative Computation types arise in arguments and returns. + ### Positive terms #### String literals From 7221e94fe24a25810d3ae521913812d15e9e6c5c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Apr 2021 22:05:30 -0400 Subject: [PATCH 0070/1324] A note on polarization. --- docs/elaboration.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index fd657f113..bed28bbae 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -68,6 +68,9 @@ Computation types arise in arguments and returns. ### Positive terms +Facet’s implementation isn’t currently polarized, but it’s a good model for thinking about the structure of the system. (The primary difference in the implementation is that we don’t distinguish thunk types; nullary computations are instead encoded as functions from unit.) + + #### String literals ``` From ae598252f5186a956c916b9a8b4e32db6592d138 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Apr 2021 22:37:53 -0400 Subject: [PATCH 0071/1324] :memo: the pure case for functions. --- docs/elaboration.md | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index bed28bbae..050d990e9 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -87,3 +87,16 @@ Technically these can’t appear in the surface syntax right now, but here’s t -------------------------- Γ ⊢ {M} ~~> {M′} : Thunk T ``` + + +### Negative terms + +#### Functions + +Functions are defined using curly braces containing pattern matching clauses. These define not only functions in the typical sense, but also effect handlers, making them (paraphrasing the Frank paper, _Do Be Do Be Do_) a more general sort of coroutining construct. Here’s the pure case (functions without effect handlers), ignoring (for the moment) non-variable patterns, nested lambdas, and multiple clauses: + +``` + Γ, x : S ⊢ M ~~> M′ <== T +----------------------------------------- +Γ ⊢ { x -> M } ~~> { x -> M′ } <== S -> T +``` From 4aee6fae2c0144183993a3683d4bdc9f83abafff Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Apr 2021 23:33:15 -0400 Subject: [PATCH 0072/1324] :memo: pure applications. --- docs/elaboration.md | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index 050d990e9..b642fc9c9 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -100,3 +100,11 @@ Functions are defined using curly braces containing pattern matching clauses. Th ----------------------------------------- Γ ⊢ { x -> M } ~~> { x -> M′ } <== S -> T ``` + +Pure applications, likewise, just distribute the elaboration of the terms while synthesizing the type: + +``` +Γ ⊢ M ~~> M′ ==> S -> T Γ ⊢ N ~~> N′ <== S +-------------------------------------------- + Γ ⊢ M N ~~> M′ N′ ==> T +``` From 9dbaec3d562d556c1efda0b543ecd1ceb95ca977 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Apr 2021 23:34:03 -0400 Subject: [PATCH 0073/1324] Spacing. --- docs/elaboration.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index b642fc9c9..d0f19544b 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -61,6 +61,7 @@ In Facet’s case, matters are muddied slightly by computations, which are not e Computation types are computations in the CBPV/polarization sense, i.e. negative, and thus are lazily evaluated. The elaborator models this by treating them as a kind of function type mapping products of operations—dictionaries—to the computed result. + ## Strategy Computation types arise in arguments and returns. @@ -78,6 +79,7 @@ Facet’s implementation isn’t currently polarized, but it’s a good model fo Γ ⊢ "…" ~~> "…" ==> String ``` + #### Thunks Technically these can’t appear in the surface syntax right now, but here’s the proposed rule. (It bidirectionalizes trivially by replacing `:` with `<==`/`==>` in both premise and conclusion.) From 81e2637eadc05fdacbab552745c8c4df04377e47 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Apr 2021 23:37:21 -0400 Subject: [PATCH 0074/1324] :memo: forcing. --- docs/elaboration.md | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index d0f19544b..db9811af9 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -90,6 +90,14 @@ Technically these can’t appear in the surface syntax right now, but here’s t Γ ⊢ {M} ~~> {M′} : Thunk T ``` +Thunks are eliminated by forcing: + +``` +Γ ⊢ M ~~> M′ : Thunk T +---------------------- + Γ ⊢ M! ~~> M′! : T +``` + ### Negative terms From 34b8ee23ea88770947aa97e0744c34090a6a248f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Apr 2021 23:45:26 -0400 Subject: [PATCH 0075/1324] Talk about elaboration of types. --- docs/elaboration.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/docs/elaboration.md b/docs/elaboration.md index db9811af9..bd6390bae 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -20,7 +20,9 @@ Types: ## Judgements -Elaboration is _specified_ as a single judgement relating surface terms to core terms at a core type. However, it is _performed_ bidrectionally, and thus in practice consists of two judgements, checking and synthesis. We’ll give rules for each of these as convenience allows. +Elaboration occurs on both terms and types. The type level elaboration proceeds first, relating well-kinded surface types to core types. These core types are then used to inform the elaboration of terms. Note also that since Facet’s type system is quite simple, we enjoy an entirely inferred kinding judgement. + +Elaboration of terms is _specified_ as a single judgement relating surface terms to core terms at a core type. However, it is _performed_ bidrectionally, and thus in practice consists of two judgements, checking and synthesis. We’ll give rules for each of these as convenience allows. ### Elaboration From 168162d9e8914954ee220b03591fb3a969a2803e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Apr 2021 23:56:27 -0400 Subject: [PATCH 0076/1324] :memo: the kinding judgement. --- docs/elaboration.md | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index bd6390bae..41fb1147f 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -25,6 +25,17 @@ Elaboration occurs on both terms and types. The type level elaboration proceeds Elaboration of terms is _specified_ as a single judgement relating surface terms to core terms at a core type. However, it is _performed_ bidrectionally, and thus in practice consists of two judgements, checking and synthesis. We’ll give rules for each of these as convenience allows. +### Typing + +``` +Γ ⊢ S ~~> T ==> K +``` + +This judgement describes the elaboration of surface types `S` to core types `T` with synthesized kinds `K`. (The kind language is particularly simple, consisting of the base kinds `Type` and `Interface`, and arrow kinds.) + +Note that the same symbols this judgement employs are also used by the term-level synthesis judgement, below. The term and type languages are disjoint, so we are free to overload the symbols without ambiguity (if not _necessarily_ without confusion). + + ### Elaboration ``` From 94515eb1629f39798e02316fd29d7d7c01f63a29 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Apr 2021 00:52:25 -0400 Subject: [PATCH 0077/1324] Checking-mode elaboration of types. --- docs/elaboration.md | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index 41fb1147f..befe6d894 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -35,6 +35,22 @@ This judgement describes the elaboration of surface types `S` to core types `T` Note that the same symbols this judgement employs are also used by the term-level synthesis judgement, below. The term and type languages are disjoint, so we are free to overload the symbols without ambiguity (if not _necessarily_ without confusion). +As described above, our kinds are quite simple, so we can elaborate types entirely in synthesis mode. However, it is nevertheless convenient in the implementation to operate bidirectionally in the small, by synthesizing a type’s kind and then immediately checking it against our expectation using the ubiquitous switch rule. For that reason, we can also reference type elaboration in checking mode in premises: + +``` +Γ ⊢ S ~~> T <== K +``` + +with the understanding that proof search will immediately switch (as this is the only checking-mode conclusion in the type elaboration judgement) and check the kinds for equality: + +``` +Γ ⊢ S ~~> T ==> K′ K ≡ K′ +--------------------------- + Γ ⊢ S ~~> T <== K +``` + +(where equality of kinds is syntactic.) + ### Elaboration From 8cf0ec35d312b08244a97b75abdf8917714af93a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Apr 2021 01:07:46 -0400 Subject: [PATCH 0078/1324] :memo: computation types. --- docs/elaboration.md | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index befe6d894..4fcda858a 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -147,3 +147,18 @@ Pure applications, likewise, just distribute the elaboration of the terms while -------------------------------------------- Γ ⊢ M N ~~> M′ N′ ==> T ``` + + +### Computations + +Things get more interesting once we start talking about arguments and returns at computation types. The critical observation for the elaboration of computations is that a computation type `[σ̅] T` intuitively represents a promise to produce `T`s given facilities for the operations in `σ̅`. Further decomposing that, we have “a promise to produce `T` given _something_,” and “facilities for the operations in `σ̅`.” We already have a connective for producing `T` given _something_: `something -> T` represents precisely such a promise. And for the latter component, we can represent the facilities for an effect’s operations by a dictionary of the operations’ implementations, as provided by a handler. + +Thus, we elaborate computation _types_ into functions from dictionaries of effect handlers to the return type: + +``` +Γ ⊢ σ̅ ~~> σ̅′ <== Interface Γ ⊢ T ~~> T′ <== Type +-------------------------------------------------- + Γ ⊢ [σ̅] T ~~> [σ̅′] -> T′ ==> Type +``` + +where `[σ̅]` (to the right of the `~~>`) can now be understood as an n-ary type constructor named `[]` taking zero or more interfaces to a type. (We do not show a type formation rule for this type since it cannot appear in the surface syntax except composed into a computation type, which is already covered by the elaboration judgements.) From c80262c61ceaec64648d1175a192504fbd63c2d4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Apr 2021 09:44:15 -0400 Subject: [PATCH 0079/1324] Talk about dictionaries in applications. --- docs/elaboration.md | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index 4fcda858a..5e309c5c9 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -162,3 +162,29 @@ Thus, we elaborate computation _types_ into functions from dictionaries of effec ``` where `[σ̅]` (to the right of the `~~>`) can now be understood as an n-ary type constructor named `[]` taking zero or more interfaces to a type. (We do not show a type formation rule for this type since it cannot appear in the surface syntax except composed into a computation type, which is already covered by the elaboration judgements.) + +The meat of this approach centres on terms. Unlike other types, terms at computation type: + +1. have (almost) no corresponding explicit term-level syntax; +2. implicitly embed positive terms by returning them à la CBPV; and +3. propagate part of the context into (some) subterms + +The first point means that we can no longer elaborate with a purely syntax-directed algorithm, because the syntax alone doesn’t suffice to determine what sort of term should be output. Instead, a string literal elaborated at `[σ̅] String` should first be elaborated as a `String` before being lifted into the computation via a return; this is an example of the second point in action. + +The third point is subtler. Consider the expression `incr ; incr`, where `incr` increments a mutable variable and returns the new value, and `;` is the definition in `Data.Function`. The type of `incr` is `[State Int] Int`, which we elaborate to `[State Int] -> Int`: + +```facet +(incr : [State Int] -> Int) ; (incr : [State Int] -> Int) +``` + +Whereas before the operands to `;` were computations, now they are functions. The type of `;` (`_ ; _ : {A, B : Type} -> A -> B -> B`) is polymorphic and will accommodate them, but returning a function does not have the same semantics as running a computation. We need to arrange for the correct dictionary to be passed in. + +Note that since the type of `;` indicates that it returns the result of its second argument, not its first; thus, we could apply only the result of the expression to the dictionary. However, this would not work for many other operations, and would still not have the desired semantics, since we expect the original expression to increment the variable _twice_. + +Thus, despite the fact that the arguments to `incr` are occurring in positions not obviously of computation type, we are obligated to arrange for them to nevertheless receive the relevant dictionaries. The elaborated term should therefore be: + +```facet +(incr : [State Int] -> Int) dict ; (incr : [State Int] -> Int) dict +``` + +where `dict` is the name bound in the context for the `[State Int]` dictionary. Thus, elaboration has to resolve computation types not just at e.g. return positions in lambdas, but within applications therein. From 253b213cae03b403004a2205e226729481552500 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Apr 2021 09:55:41 -0400 Subject: [PATCH 0080/1324] Add some notes about binders. --- docs/elaboration.md | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index 5e309c5c9..3ec927321 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -188,3 +188,26 @@ Thus, despite the fact that the arguments to `incr` are occurring in positions n ``` where `dict` is the name bound in the context for the `[State Int]` dictionary. Thus, elaboration has to resolve computation types not just at e.g. return positions in lambdas, but within applications therein. + +Furthermore, we also need to know where the dictionary came into scope. Zooming out from the single expression, we’ll define a top-level term `incr2`: + +```facet +incr2 : [State Int] Int +{ incr ; incr } +``` + +Since `incr2` is typed as `[State Int] Int`, we can see that its elaboration will have type `[State Int] -> Int`. Thus, instead of the body being an application, it must now be a lambda binding the dictionary: + +```facet +incr2 : [State Int] -> Int +{ [get, put] -> … } +``` + +Here we see a slight discrepancy with the above: the dictionary is fully decomposed into its operations. Thus, when elaborating the body, we’ll need to reconstruct the dictionary to give to child terms. (This allows them to receive only the operations they require, which might be quite a small subset of the available terms, rather than the dictionary for all available effects.) In full, we now have: + +```facet +incr2 : [State Int] -> Int +{ [get, put] -> incr [get = get, put = put] ; incr [get = get, put = put] } +``` + +where the `[x̅ = y̅]` notation in the body is a record (in this case, a dictionary) giving field `x` the value `y`. From f23a06b6620eba4a80df5db1075c1f9d168efa27 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Apr 2021 12:17:35 -0400 Subject: [PATCH 0081/1324] More notes and judgements. --- docs/elaboration.md | 39 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index 3ec927321..df14f403e 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -211,3 +211,42 @@ incr2 : [State Int] -> Int ``` where the `[x̅ = y̅]` notation in the body is a record (in this case, a dictionary) giving field `x` the value `y`. + +In order to accomplish this, we need to: + +1. elaborate subterms at computation types into applications of the elaborated subterm to the dictionary of operations they require, discovered in the local environment. However, if the position is itself a handler, this is subtler still as the innermost handler should provide the dictionaries, not the outermost. + +2. elaborate lambda bodies at computation type into one more lambda binding the dictionary of required operations. + + +``` +Γ, [Dict(σ̅)] ⊢ M ~~> M′ : T +----------------------------------------- +Γ ⊢ M ~~> { [Dict(σ̅)] -> M′ } : [σ̅] T +``` + +Value/value application is standard (i.e. this rule only differs from the standard typechecking rule in using the elaboration judgements in its premise): + +``` +Γ ⊢ M ~~> M′ : S -> T Γ ⊢ N ~~> N′ : S +------------------------------------------------ +Γ ⊢ M N ~~> M′ N′ : T +``` + +Handler/computation application is standard: + +``` +Γ ⊢ M ~~> M′ : [σ̅] S -> T Γ ⊢ N ~~> N′ : [σ̅] S +------------------------------------------------ + Γ ⊢ M N ~~> M′ N′ : T +``` + +Handler/value application is standard except for a shift of the parameter: + +``` +Γ ⊢ M ~~> M′ : [σ̅] S -> T Γ ⊢ N ~~> N′ : S +-------------------------------------------- + Γ ⊢ M N ~~> M′ (↑N′) : T +``` + +where we can read the negative shift `↑` on terms as sugar for `return` in the CBPV sense, or in practical terms, the constant function sending all inputs to `N′`. From cf253ae98a78502a53a34c05eda86439705a0c27 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Apr 2021 12:18:31 -0400 Subject: [PATCH 0082/1324] Tidy. --- docs/elaboration.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/docs/elaboration.md b/docs/elaboration.md index df14f403e..18154661a 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -221,7 +221,7 @@ In order to accomplish this, we need to: ``` Γ, [Dict(σ̅)] ⊢ M ~~> M′ : T ------------------------------------------ +------------------------------------- Γ ⊢ M ~~> { [Dict(σ̅)] -> M′ } : [σ̅] T ``` @@ -229,7 +229,7 @@ Value/value application is standard (i.e. this rule only differs from the standa ``` Γ ⊢ M ~~> M′ : S -> T Γ ⊢ N ~~> N′ : S ------------------------------------------------- +---------------------------------------- Γ ⊢ M N ~~> M′ N′ : T ``` From 3838bf061c46550320fef359056d38589bc09ad6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Apr 2021 13:44:24 -0400 Subject: [PATCH 0083/1324] Rewrite the discussion of elaboration for computation types. --- docs/elaboration.md | 45 +++++++++++++++++++++++++++------------------ 1 file changed, 27 insertions(+), 18 deletions(-) diff --git a/docs/elaboration.md b/docs/elaboration.md index 18154661a..c29dc6612 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -171,39 +171,41 @@ The meat of this approach centres on terms. Unlike other types, terms at computa The first point means that we can no longer elaborate with a purely syntax-directed algorithm, because the syntax alone doesn’t suffice to determine what sort of term should be output. Instead, a string literal elaborated at `[σ̅] String` should first be elaborated as a `String` before being lifted into the computation via a return; this is an example of the second point in action. -The third point is subtler. Consider the expression `incr ; incr`, where `incr` increments a mutable variable and returns the new value, and `;` is the definition in `Data.Function`. The type of `incr` is `[State Int] Int`, which we elaborate to `[State Int] -> Int`: +The third point is subtler, and can be decomposed by analyzing the various pieces of syntax which introduce and eliminate dictionaries. -```facet -(incr : [State Int] -> Int) ; (incr : [State Int] -> Int) -``` - -Whereas before the operands to `;` were computations, now they are functions. The type of `;` (`_ ; _ : {A, B : Type} -> A -> B -> B`) is polymorphic and will accommodate them, but returning a function does not have the same semantics as running a computation. We need to arrange for the correct dictionary to be passed in. - -Note that since the type of `;` indicates that it returns the result of its second argument, not its first; thus, we could apply only the result of the expression to the dictionary. However, this would not work for many other operations, and would still not have the desired semantics, since we expect the original expression to increment the variable _twice_. - -Thus, despite the fact that the arguments to `incr` are occurring in positions not obviously of computation type, we are obligated to arrange for them to nevertheless receive the relevant dictionaries. The elaborated term should therefore be: -```facet -(incr : [State Int] -> Int) dict ; (incr : [State Int] -> Int) dict -``` - -where `dict` is the name bound in the context for the `[State Int]` dictionary. Thus, elaboration has to resolve computation types not just at e.g. return positions in lambdas, but within applications therein. +#### Introduction -Furthermore, we also need to know where the dictionary came into scope. Zooming out from the single expression, we’ll define a top-level term `incr2`: +Introduction of dictionaries occurs when terms are given computation types bringing one or more interfaces into scope. The simplest case is a top-level definition explicitly annotated with a computation type: ```facet incr2 : [State Int] Int { incr ; incr } ``` -Since `incr2` is typed as `[State Int] Int`, we can see that its elaboration will have type `[State Int] -> Int`. Thus, instead of the body being an application, it must now be a lambda binding the dictionary: +where `incr : [State Int] Int` increments the mutable variable managed by `State` and returns the new value, and `_ ; _ : {A, B : Type} -> A -> B -> B` is the definition given in `Data.Function`. + +Since `incr2` is typed as `[State Int] Int`, we can see that its elaboration must be a function effectively of type `[State Int] -> Int`. Thus, the elaborated definition must wrap the elaborated contents in a lambda binding the dictionary: ```facet incr2 : [State Int] -> Int { [get, put] -> … } ``` -Here we see a slight discrepancy with the above: the dictionary is fully decomposed into its operations. Thus, when elaborating the body, we’ll need to reconstruct the dictionary to give to child terms. (This allows them to receive only the operations they require, which might be quite a small subset of the available terms, rather than the dictionary for all available effects.) In full, we now have: +Note that the dictionary is fully decomposed into its operations; this implies that effect operations like `get` and `put` are not distinguished constructs (e.g. field projections), but are rather local variables. + +Dictionaries are constructed, but not brought into scope, by effect handlers, which can now be understood as functions applying computations (higher-order functions from dictionaries) to the dictionary consisting of their elaborated effect cases. + + +#### Elimination + +Dictionaries’ members are only brought into scope by the elaborated syntax, and are thus implicit in the surface syntax. Therefore, consumption of these dictionaries must also be implicit, part of the elaboration of the body of the computation. + +Terms of computation type within the body will have been elaborated to functions from dictionaries, and thus we must resolve the requested dictionaries with any provided by the context, applying them to eliminate the computation. + +Continuing with the example from above, we recall that `incr` has type `[State Int] Int`, and is thus such a function. `_ ; _`, on the other hand, is not. Since `_ ; _` is the outermost term, we must therefore propagate the dictionaries as elaboration proceeds inwards. This is in a sense alredy taken care of by the fact that we extended the context (and do not e.g. contract it in the premises of applications), so now all that is left is to ensure that the operands of `_ ; _` are elaborated s.t. they are applied to the appropriate dictionary. + +As noted above, the dictionary is brought into scope piecewise; therefore when elaborating the body, we reconstruct (sub-)dictionaries to pass to any terms consuming effects. (This allows them to receive only the operations they require, rather than the dictionary for the entire signature, potentially at the cost of some allocation.) In full, we now have: ```facet incr2 : [State Int] -> Int @@ -212,6 +214,13 @@ incr2 : [State Int] -> Int where the `[x̅ = y̅]` notation in the body is a record (in this case, a dictionary) giving field `x` the value `y`. +Note however that we’ve only looked at function operands; are there other positions where terms of computation type must be eliminated? And how do we account for effect handlers as shadowing outer handlers for the same effect at the same type? + +_TBD_ + + +#### Judgements + In order to accomplish this, we need to: 1. elaborate subterms at computation types into applications of the elaborated subterm to the dictionary of operations they require, discovered in the local environment. However, if the position is itself a handler, this is subtler still as the innermost handler should provide the dictionaries, not the outermost. From 86d028f90400abfde0d4cfd68882a71e72a9a3e8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Apr 2021 13:45:48 -0400 Subject: [PATCH 0084/1324] Note about thunks. --- docs/elaboration.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/elaboration.md b/docs/elaboration.md index c29dc6612..ae359809f 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -258,4 +258,4 @@ Handler/value application is standard except for a shift of the parameter: Γ ⊢ M N ~~> M′ (↑N′) : T ``` -where we can read the negative shift `↑` on terms as sugar for `return` in the CBPV sense, or in practical terms, the constant function sending all inputs to `N′`. +where we can read the negative shift `↑` on terms as sugar for `return` in the CBPV sense, or in practical terms, the constant function sending all inputs to `N′`. (Were this fully polarized, it would additionally require an enclosing thunk; this discussion leaves thunking as an exercise for the code generator.) From 48cf6c384651e69d51e7786427ccbaec86a46960 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Apr 2021 13:49:16 -0400 Subject: [PATCH 0085/1324] Add some questions. --- docs/elaboration.md | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index ae359809f..d0fd14b1a 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -259,3 +259,10 @@ Handler/value application is standard except for a shift of the parameter: ``` where we can read the negative shift `↑` on terms as sugar for `return` in the CBPV sense, or in practical terms, the constant function sending all inputs to `N′`. (Were this fully polarized, it would additionally require an enclosing thunk; this discussion leaves thunking as an exercise for the code generator.) + + +#### Questions + +1. Should `id incr` elaborate to `id (incr dict)` or `id incr dict`? + +2. Do the two above potential elaborations of `id incr` differ observationally? From f66885b241b05a372303be2e65d2ef97613f211b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Apr 2021 14:35:35 -0400 Subject: [PATCH 0086/1324] Add a question about how we apply these. --- docs/elaboration.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index d0fd14b1a..a470e9a68 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -266,3 +266,5 @@ where we can read the negative shift `↑` on terms as sugar for `return` in the 1. Should `id incr` elaborate to `id (incr dict)` or `id incr dict`? 2. Do the two above potential elaborations of `id incr` differ observationally? + +3. What should the strategy be for applying these? Can we do it in `check`, or at least `checkExpr`? From 23b6781dd9639131cfec72c2b559c56523bd1012 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Apr 2021 00:26:06 -0400 Subject: [PATCH 0087/1324] :memo: an observation about elaboration being exhaustive. --- docs/elaboration.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index a470e9a68..d5511e043 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -268,3 +268,8 @@ where we can read the negative shift `↑` on terms as sugar for `return` in the 2. Do the two above potential elaborations of `id incr` differ observationally? 3. What should the strategy be for applying these? Can we do it in `check`, or at least `checkExpr`? + + +#### Observations + +Elaboration visits the entire tree. Thus, we shouldn’t need to search around the input term for places to apply the rules, but rather apply them as we get to them, suggesting that `checkExpr` and `synthExpr` might be reasonable places to start. Since elaboration is necessarily semantics-preserving, we will have sufficient information at the nested positions to take the necessary actions. From 58923c27f147f548ea8c79cf539140ecec52c8d5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Apr 2021 00:27:23 -0400 Subject: [PATCH 0088/1324] Rename one of the cases. --- docs/elaboration.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/elaboration.md b/docs/elaboration.md index d5511e043..ccbb85018 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -234,7 +234,7 @@ In order to accomplish this, we need to: Γ ⊢ M ~~> { [Dict(σ̅)] -> M′ } : [σ̅] T ``` -Value/value application is standard (i.e. this rule only differs from the standard typechecking rule in using the elaboration judgements in its premise): +Function/value application is standard (i.e. this rule only differs from the standard typechecking rule in using the elaboration judgements in its premise): ``` Γ ⊢ M ~~> M′ : S -> T Γ ⊢ N ~~> N′ : S From 4c60809d8d53178b80a8ede2af2ae63b2019f17d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Apr 2021 00:34:28 -0400 Subject: [PATCH 0089/1324] :memo: the function/computation case. --- docs/elaboration.md | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index ccbb85018..e30f240b3 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -260,6 +260,14 @@ Handler/value application is standard except for a shift of the parameter: where we can read the negative shift `↑` on terms as sugar for `return` in the CBPV sense, or in practical terms, the constant function sending all inputs to `N′`. (Were this fully polarized, it would additionally require an enclosing thunk; this discussion leaves thunking as an exercise for the code generator.) +Function/computation application is standard except for passing the requirements of the operand through to the conclusion, which in turn means that the elaborated term is itself now a computation lambda. + +``` + Γ ⊢ M ~~> M′ : S -> T Γ ⊢ N ~~> N′ : [σ̅] S +------------------------------------------------------ +Γ ⊢ M N ~~> { [Dict(σ̅)] -> M′ (N′ [Dict(σ̅)]) } : [σ̅] T +``` + #### Questions From 1751224808e176ba1b27d9f9d717f8a02f1d0dbb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 10 Apr 2021 17:57:51 -0400 Subject: [PATCH 0090/1324] Spacing. --- src/Facet/Elab/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 96266eb7e..2eed9e8c1 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -196,7 +196,7 @@ fieldsP = foldr cons nil allP :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Name -> Bind m (Pattern (Name ::: Classifier)) allP n = Bind $ \ _A k -> do (sig, _T) <- assertComp _A - k (PVar (n ::: CT (T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (T.Comp sig _T)))) + k (PVar (n ::: CT (T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (T.Comp sig _T)))) -- Expression elaboration From 09b76aa31d56137fb69e1570f01f1337bda6830f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 10 Apr 2021 21:31:25 -0400 Subject: [PATCH 0091/1324] :fire: type lambdas & instantiation. --- src/Facet/Elab/Term.hs | 5 ++-- src/Facet/Eval.hs | 9 ------- src/Facet/Norm.hs | 53 ++++++++++++++---------------------------- src/Facet/Print.hs | 4 +--- src/Facet/Term.hs | 11 ++++----- 5 files changed, 24 insertions(+), 58 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 2eed9e8c1..03607bf40 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -102,7 +102,7 @@ as (m ::: _T) = Synth $ do -- FIXME: we’re instantiating when inspecting types in the REPL. global :: Algebra sig m => RName ::: Type -> Synth m Expr -global (q ::: _T) = Synth $ instantiate XInst (XVar (Global q) ::: _T) +global (q ::: _T) = Synth $ instantiate const (XVar (Global q) ::: _T) -- FIXME: do we need to instantiate here to deal with rank-n applications? -- FIXME: effect ops not in the sig are reported as not in scope @@ -123,8 +123,7 @@ tlam :: (HasCallStack, Has (Throw Err) sig m) => Check m Expr -> Check m Expr tlam b = Check $ \ _T -> do (n ::: _A, _B) <- assertQuantifier _T d <- depth - b' <- (zero, PVar (n ::: CK _A)) |- check (b ::: _B (T.free (LName d n))) - pure $ XTLam n b' + (zero, PVar (n ::: CK _A)) |- check (b ::: _B (T.free (LName d n))) lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern (Name ::: Classifier)), Check m Expr)] -> Check m Expr lam cs = Check $ \ _T -> do diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 9ceb00b5f..4498f552d 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -30,7 +30,6 @@ import Facet.Semialign (zipWithM) import Facet.Snoc.NonEmpty as NE hiding ((|>)) import Facet.Syntax import Facet.Term -import Facet.Type.Expr (Type) import GHC.Stack (HasCallStack) import Prelude hiding (zipWith) @@ -38,8 +37,6 @@ eval :: (HasCallStack, Has (Reader Graph :+: Reader Module) sig m, MonadFail m) eval env = \case XVar (Global n) -> global n >>= eval env XVar (Free n) -> var env n - XTLam _ b -> tlam (eval env b) - XInst f t -> inst (eval env f) t XLam cs -> lam env cs XApp f a -> app env (eval env f) a XCon n fs -> con n (eval env <$> fs) @@ -59,12 +56,6 @@ global n = do var :: (HasCallStack, Applicative m) => Env (Value m) -> LName Index -> m (Value m) var env n = pure (index env n) -tlam :: Eval m (Value (Eval m)) -> Eval m (Value (Eval m)) -tlam = id - -inst :: Eval m (Value (Eval m)) -> Type -> Eval m (Value (Eval m)) -inst = const - lam :: Env (Value (Eval m)) -> [(Pattern Name, Expr)] -> Eval m (Value (Eval m)) lam env cs = pure $ VLam env cs diff --git a/src/Facet/Norm.hs b/src/Facet/Norm.hs index 4f2e4d700..9c9bfb727 100644 --- a/src/Facet/Norm.hs +++ b/src/Facet/Norm.hs @@ -1,32 +1,29 @@ module Facet.Norm ( Norm(..) -, Elim(..) , quote , norm ) where -import Control.Monad (guard) -import Data.Foldable (foldl') -import Data.Function (on) -import Data.Maybe (fromMaybe) -import Data.Monoid -import Data.Text (Text) -import Data.Traversable (mapAccumL) -import Facet.Env -import Facet.Name -import Facet.Pattern -import Facet.Semialign (zipWithM) -import Facet.Snoc -import Facet.Syntax -import Facet.Term -import qualified Facet.Type.Norm as T +import Control.Monad (guard) +import Data.Foldable (foldl') +import Data.Function (on) +import Data.Maybe (fromMaybe) +import Data.Monoid +import Data.Text (Text) +import Data.Traversable (mapAccumL) +import Facet.Env +import Facet.Name +import Facet.Pattern +import Facet.Semialign (zipWithM) +import Facet.Snoc +import Facet.Syntax +import Facet.Term data Norm = NString Text | NCon RName [Norm] - | NTLam Name (T.Type -> Norm) | NLam [(Pattern Name, Pattern (Name :=: Norm) -> Norm)] - | NNe (Var (LName Level)) (Snoc Elim) + | NNe (Var (LName Level)) (Snoc Norm) | NDict [RName :=: Norm] instance Eq Norm where @@ -35,36 +32,20 @@ instance Eq Norm where instance Ord Norm where compare = compare `on` quote 0 -data Elim - = EApp Norm - | EInst T.Type - quote :: Level -> Norm -> Expr quote d = \case NString s -> XString s NCon n sp -> XCon n (quote d <$> sp) - NTLam n b -> XTLam n (quote (succ d) (b (T.free (LName d n)))) NLam cs -> XLam (map (\ (p, b) -> let (d', p') = mapAccumL (\ d n -> (succ d, n :=: NNe (Free (LName d n)) Nil)) d p in (p, quote d' (b p'))) cs) - NNe v sp -> foldl' quoteElim (XVar (fmap (levelToIndex d) <$> v)) sp + NNe v sp -> foldl' (\ h -> XApp h . quote d) (XVar (fmap (levelToIndex d) <$> v)) sp NDict os -> XDict (map (fmap (quote d)) os) - where - quoteElim h = \case - EApp n -> XApp h (quote d n) - EInst t -> XInst h (T.quote d t) norm :: Env Norm -> Expr -> Norm norm env = \case XString s -> NString s XVar v -> NNe (fmap (indexToLevel (level env)) <$> v) Nil XCon n sp -> NCon n (norm env <$> sp) - -- FIXME: define type patterns and extend @env@ so we can normalize XTLam correctly - XTLam _ b -> norm env b - -- XTLam n b -> NTLam n (\ _T -> norm (env |> pvar (n :=: _T)) b) - -- FIXME: define type patterns and extend @env@ so we can normalize XInst correctly - -- FIXME: take a @Subst@ so we can apply substitutions in the type at the same time - XInst f _ -> norm env f - -- XInst f t -> norm env f `ninst` T.eval mempty env t XApp f a -> norm env f `napp` norm env a XLam cs -> NLam (map (\ (p, b) -> (p, \ p' -> norm (env |> p') b)) cs) XDict os -> NDict (map (fmap (norm env)) os) @@ -77,7 +58,7 @@ napp f a = case f of NLam cs -> case getFirst (foldMap (\ (p, b) -> First (b <$> match a p)) cs) of Just a' -> a' Nothing -> error "napp: non-exhaustive patterns in lambda" - NNe h sp -> NNe h (sp :> EApp a) + NNe h sp -> NNe h (sp :> a) _ -> error "napp: ill-formed application" match :: Norm -> Pattern Name -> Maybe (Pattern (Name :=: Norm)) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index bf0a255ee..cfe4a2438 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -202,13 +202,11 @@ printNorm :: Options -> Env Print -> N.Norm -> Print printNorm opts env = printExpr opts env . N.quote (level env) printExpr :: Options -> Env Print -> C.Expr -> Print -printExpr opts@Options{ rname, instantiation } = go +printExpr opts@Options{ rname } = go where go env = \case C.XVar (Global n) -> qvar n C.XVar (Free n) -> fromMaybe (lname (indexToLevel d <$> n)) $ Env.lookup env n - C.XTLam n b -> let { d = level env ; v = tintro n d } in braces (braces v <+> arrow <+> go (env |> PVar (__ :=: v)) b) - C.XInst e t -> go env e `instantiation` braces (printTExpr opts env t) C.XLam cs -> comp (commaSep (map (clause env) cs)) C.XApp f a -> go env f $$ go env a C.XCon n p -> qvar n $$* (group . go env <$> p) diff --git a/src/Facet/Term.hs b/src/Facet/Term.hs index 994c61b32..690b155f7 100644 --- a/src/Facet/Term.hs +++ b/src/Facet/Term.hs @@ -3,18 +3,15 @@ module Facet.Term Expr(..) ) where -import Data.Text (Text) -import Facet.Name -import Facet.Pattern -import Facet.Syntax -import qualified Facet.Type.Expr as TX +import Data.Text (Text) +import Facet.Name +import Facet.Pattern +import Facet.Syntax -- Term expressions data Expr = XVar (Var (LName Index)) - | XTLam Name Expr - | XInst Expr TX.Type | XLam [(Pattern Name, Expr)] | XApp Expr Expr | XCon RName [Expr] From 73f3cdb114d2840c6ac89f8122694cf6a17032e0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 11 Apr 2021 12:41:20 -0400 Subject: [PATCH 0092/1324] Add a rule eliminating free computations using the context. --- docs/elaboration.md | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index e30f240b3..fa912ff9b 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -268,6 +268,18 @@ Function/computation application is standard except for passing the requirements Γ ⊢ M N ~~> { [Dict(σ̅)] -> M′ (N′ [Dict(σ̅)]) } : [σ̅] T ``` +As described thus far, this strategy will result in a lot of unnecessary redices (applications of computation lambdas to dictionaries at intermediate positions within terms). We could certainly rely on normalization to eliminate any non-essential computation lambdas, or we could lean on the context instead. + +This requires pushing dictionaries onto the context when elaborating terms at computation type (like any other bound pattern), and then finding them again. Applying a dictionary filling each field with the variable of the same name (e.g. `[get = get, put = put]`) will do this. + +Eliminating free computations using the dictionary bound in the context: + +``` +Γ ⊢ M ~~> { [Dict(σ̅)] -> M′ } : [σ̅] T Γ ∋ [Dict(σ̅)] +----------------------------------------------------- + Γ ⊢ M ~~> { [Dict(σ̅)] -> M′ } [Dict(σ̅)] : T +``` + #### Questions From b7dc31426bd67f1edfd1b98d879ec6046fa07717 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 11 Apr 2021 12:41:53 -0400 Subject: [PATCH 0093/1324] Add a couple of examples. --- docs/elaboration.md | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index fa912ff9b..125ee123b 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -281,6 +281,39 @@ Eliminating free computations using the dictionary bound in the context: ``` +#### Examples + +1. `modify` + + ```facet + modify : {S : Type} -> (f : S -> S) -> [State S] Unit + { put (f get) } + ``` + + ~~> + + ```facet + modify : {S : Type} -> (S -> S) -> [State S] -> Unit + { f [get, put] -> put (f get) } + ``` + +2. `modify`, with effects in the higher-order function + + ```facet + modify : {S : Type} -> (f : S -> S) -> [State S] Unit + { put (f get) } + ``` + + ~~> + + ```facet + modify : {S : Type} -> (S -> [σ] -> S) -> [State S, σ] -> Unit + { f [get, put, σ] -> put (f [σ] get) } + ``` + + Note that this effectively reinstates implicit effect polymorphism. + + #### Questions 1. Should `id incr` elaborate to `id (incr dict)` or `id incr dict`? From ab020537bdf2ee545553bbafe3de27a7fb6dd270 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 11 Apr 2021 12:42:11 -0400 Subject: [PATCH 0094/1324] Add a question about what to do when handlers are available. --- docs/elaboration.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index 125ee123b..9582d6a60 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -322,6 +322,10 @@ Eliminating free computations using the dictionary bound in the context: 3. What should the strategy be for applying these? Can we do it in `check`, or at least `checkExpr`? +4. We want to elaborate terms at type `[σ̅] T` into lambdas at type `[σ̅] -> T`. What about when the term in question is already at type `[σ̅] T`? + + - We should probably expand thus only when in checking mode. + #### Observations From d4e6e09837b3382b11b8fde59af24c22fa705001 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 11 Apr 2021 13:10:19 -0400 Subject: [PATCH 0095/1324] Define a handler for Empty. --- lib/Effect/Empty.facet | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/lib/Effect/Empty.facet b/lib/Effect/Empty.facet index 6bee4b76d..b610040ed 100644 --- a/lib/Effect/Empty.facet +++ b/lib/Effect/Empty.facet @@ -2,6 +2,7 @@ module Effect.Empty : Module import Data.Bool import Data.Function +import Data.Option import Data.Unit interface Empty : Interface @@ -9,3 +10,8 @@ interface Empty : Interface guard : (c : Bool) -> [Empty] Unit { if c id { (unit) -> empty } } + + +toOption : {A : Type} -> [Empty] A -> Option A +{ [empty ; _] -> none +, a -> some a } From 776648cb2c2cbe10b51fed1fa55ef3824930eb7b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 11 Apr 2021 13:11:59 -0400 Subject: [PATCH 0096/1324] Give an example elaboration of toOption. --- docs/elaboration.md | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index 9582d6a60..9fec2494d 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -313,6 +313,21 @@ Eliminating free computations using the dictionary bound in the context: Note that this effectively reinstates implicit effect polymorphism. +3. `toOption` + + ```facet + toOption : {A : Type} -> [Empty] A -> Option A + { [empty ; _] -> none + , a -> some a } + ``` + + ~~> + + ```facet + toOption : {A : Type} -> ([Empty] -> A) -> Option A + { a -> a [empty = { _ -> none }] { a -> some a } } + ``` + #### Questions From 1d921d216f53cfa11f3b92a8dfa21c2fba2fe658 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 11 Apr 2021 14:01:06 -0400 Subject: [PATCH 0097/1324] Correct the type of the toOption argument to be itself a CPS function. --- docs/elaboration.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/elaboration.md b/docs/elaboration.md index 9fec2494d..fe0c4d699 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -324,7 +324,7 @@ Eliminating free computations using the dictionary bound in the context: ~~> ```facet - toOption : {A : Type} -> ([Empty] -> A) -> Option A + toOption : {A : Type} -> ([Empty] -> (A -> Option A) -> Option A) -> Option A { a -> a [empty = { _ -> none }] { a -> some a } } ``` From dfaa9bf09b3d9affd7ef97b980e37d64a8c66a0d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 11 Apr 2021 20:14:56 -0400 Subject: [PATCH 0098/1324] Add some more example elaborations. --- docs/elaboration.md | 44 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index fe0c4d699..b872e0799 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -328,6 +328,50 @@ Eliminating free computations using the dictionary bound in the context: { a -> a [empty = { _ -> none }] { a -> some a } } ``` +4. `guard` + + ```facet + guard : (c : Bool) -> [Empty] Unit + { if c id { (unit) -> empty } } + ``` + + ~~> + + ```facet + guard : Bool -> [Empty] -> Unit + { c [empty] -> if c id { (unit) -> empty } } + ``` + +5. `bool` + + ```facet + bool : { A : Type } -> (e : Unit -> A) -> (t : Unit -> A) -> Bool -> A + { (true) -> t! + , (false) -> e! } + ``` + + ~~> + + ```facet + bool : { A : Type } -> (Unit -> [σ] -> A) -> (Unit -> [σ] -> A) -> Bool -> [σ] -> A + { _ t (true) -> t! + , e _ (false) -> e! } + ``` + +6. `if` + + ```facet + if : { A : Type } -> (c : Bool) -> (t : Unit -> A) -> (e : Unit -> A) -> A + { bool e t c } + ``` + + ~~> + + ```facet + if : { A : Type } -> Bool -> (Unit -> [σ] -> A) -> (Unit -> [σ] -> A) -> [σ] -> A + { c t e -> bool e t c } + ``` + #### Questions From a52a93d21746e922e7f65b9cd6be1b8fdeea03ae Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Apr 2021 09:11:46 -0400 Subject: [PATCH 0099/1324] Define a computation type. --- src/Facet/Eval.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 4498f552d..314742c78 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -140,3 +140,6 @@ quoteV d = \case VCon n fs -> XCon n <$> traverse (quoteV d) fs VString s -> pure $ XString s VDict os -> XDict <$> traverse (traverse (quoteV d)) os + + +newtype E sig r a = E (sig (E sig) r a -> (a -> r) -> r) From dc7e38fe0548f491e7978b910117bf069bc19d34 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Apr 2021 09:11:52 -0400 Subject: [PATCH 0100/1324] Define a handler for E. --- src/Facet/Eval.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 314742c78..5084e4eb2 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -143,3 +143,6 @@ quoteV d = \case newtype E sig r a = E (sig (E sig) r a -> (a -> r) -> r) + +runE :: sig (E sig) r a -> (a -> r) -> E sig r a -> r +runE h k (E run) = run h k From ed2e0cd7509654fe923dfb0137152a3d5b6e1d2a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Apr 2021 09:12:51 -0400 Subject: [PATCH 0101/1324] Define a lifting into E. This seems almost certain to be wrong. --- src/Facet/Eval.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 5084e4eb2..32ff45b6a 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -146,3 +146,6 @@ newtype E sig r a = E (sig (E sig) r a -> (a -> r) -> r) runE :: sig (E sig) r a -> (a -> r) -> E sig r a -> r runE h k (E run) = run h k + +liftE :: r -> E sig r a +liftE r = E $ \ _ _ -> r From c075c3d17c2ebd620f891ceac11c1dec2cca7862 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Apr 2021 09:14:22 -0400 Subject: [PATCH 0102/1324] Model the Empty effect. --- src/Facet/Eval.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 32ff45b6a..c695ab1ae 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -149,3 +149,6 @@ runE h k (E run) = run h k liftE :: r -> E sig r a liftE r = E $ \ _ _ -> r + + +newtype Empty m r a = Empty { empty :: forall b . (b -> m r a) -> r } From 4f73af8196ec738fbbf99d4b22de26ed95c72c92 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Apr 2021 09:14:28 -0400 Subject: [PATCH 0103/1324] Model the Reader effect. --- src/Facet/Eval.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index c695ab1ae..cbe893c9f 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -152,3 +152,6 @@ liftE r = E $ \ _ _ -> r newtype Empty m r a = Empty { empty :: forall b . (b -> m r a) -> r } + + +data Reader' e m r a = Reader' { ask' :: (e -> m r a) -> r, local' :: forall x . (e -> e) -> m x x -> (x -> m r a) -> r } From ec9f7e3f131099547e6e24115a075d605fa568fa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Apr 2021 09:14:38 -0400 Subject: [PATCH 0104/1324] Model the State effect. --- src/Facet/Eval.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index cbe893c9f..45aa32726 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -155,3 +155,6 @@ newtype Empty m r a = Empty { empty :: forall b . (b -> m r a) -> r } data Reader' e m r a = Reader' { ask' :: (e -> m r a) -> r, local' :: forall x . (e -> e) -> m x x -> (x -> m r a) -> r } + + +data State' s m r a = State' { get' :: (s -> m r a) -> r, put' :: s -> (() -> m r a) -> r } From 7ba2d597ebc034e624bfd5c67db2e71fdcb56443 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Apr 2021 09:14:45 -0400 Subject: [PATCH 0105/1324] Define a handler for Empty. --- src/Facet/Eval.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 45aa32726..c7dfc4783 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -158,3 +158,7 @@ data Reader' e m r a = Reader' { ask' :: (e -> m r a) -> r, local' :: forall x data State' s m r a = State' { get' :: (s -> m r a) -> r, put' :: s -> (() -> m r a) -> r } + + +toMaybe :: E Empty (Maybe a) a -> Maybe a +toMaybe = runE Empty{ empty = const Nothing } Just From 30aa5f2e159dbab0e3670cb716f41305822eef89 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Apr 2021 09:14:52 -0400 Subject: [PATCH 0106/1324] Define a handler for Reader. --- src/Facet/Eval.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index c7dfc4783..5e45c8cb8 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -162,3 +162,6 @@ data State' s m r a = State' { get' :: (s -> m r a) -> r, put' :: s -> (() -> m toMaybe :: E Empty (Maybe a) a -> Maybe a toMaybe = runE Empty{ empty = const Nothing } Just + +runReader' :: e -> E (Reader' e) a a -> a +runReader' e = runE Reader'{ ask' = \ k -> runReader' e (k e), local' = \ f m k -> runReader' e (k (runReader' (f e) m)) } id From bd3e7314834a1c0c86978b96359c1a73f88eb400 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Apr 2021 09:14:57 -0400 Subject: [PATCH 0107/1324] Define a handler for State. --- src/Facet/Eval.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 5e45c8cb8..b0beeb1e9 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -165,3 +165,6 @@ toMaybe = runE Empty{ empty = const Nothing } Just runReader' :: e -> E (Reader' e) a a -> a runReader' e = runE Reader'{ ask' = \ k -> runReader' e (k e), local' = \ f m k -> runReader' e (k (runReader' (f e) m)) } id + +runState' :: s -> E (State' s) (s, a) a -> (s, a) +runState' s = runE State'{ get' = \ k -> runState' s (k s), put' = \ s k -> runState' s (k ()) } (s,) From a4f1aa3d3154f8a4ce0d8d9dc46f45cb377f756d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Apr 2021 09:15:03 -0400 Subject: [PATCH 0108/1324] Define a smart constructor for get. --- src/Facet/Eval.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index b0beeb1e9..c4aad5f6b 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -168,3 +168,7 @@ runReader' e = runE Reader'{ ask' = \ k -> runReader' e (k e), local' = \ f m k runState' :: s -> E (State' s) (s, a) a -> (s, a) runState' s = runE State'{ get' = \ k -> runState' s (k s), put' = \ s k -> runState' s (k ()) } (s,) + + +get'' :: E (State' s) x s +get'' = E $ \ State'{ get' } k -> get' (liftE . k) From 5124230db7729b9b7d866aefc16835d2fa8dcd1b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Apr 2021 09:15:10 -0400 Subject: [PATCH 0109/1324] Define a smart constructor for put. --- src/Facet/Eval.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index c4aad5f6b..5192f0eb1 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -172,3 +172,6 @@ runState' s = runE State'{ get' = \ k -> runState' s (k s), put' = \ s k -> runS get'' :: E (State' s) x s get'' = E $ \ State'{ get' } k -> get' (liftE . k) + +put'' :: s -> E (State' s) x () +put'' s = E $ \ State'{ put' } k -> put' s (liftE . k) From 2b75f4f34930f8dfbaf7a0be9f8d0ac8e5a3b8a6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 16 Apr 2021 07:40:49 -0400 Subject: [PATCH 0110/1324] Extend the definitions of E &c. using profunctors. --- facet.cabal | 1 + src/Facet/Eval.hs | 123 ++++++++++++++++++++++++++++++++++++++++------ 2 files changed, 108 insertions(+), 16 deletions(-) diff --git a/facet.cabal b/facet.cabal index 30f50a3fe..577cd4afd 100644 --- a/facet.cabal +++ b/facet.cabal @@ -145,6 +145,7 @@ library , optparse-applicative , parsers , prettyprinter + , profunctors , semialign , silkscreen , terminal-size diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 5192f0eb1..3fb685e7a 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} @@ -11,15 +12,31 @@ module Facet.Eval , unit -- * Quotation , quoteV +, state' +, state'' +, E(..) +, runE +, State'(..) +, Reader'(..) +-- , Empty(..) +, toMaybe +, send' +, modify +, get'' +, put'' +, ask'' +, reader' ) where import Control.Algebra import Control.Carrier.Reader -import Control.Monad (ap, guard, liftM, (>=>)) +import Control.Monad (ap, guard, liftM, (<=<), (>=>)) import Control.Monad.Trans.Class +import Control.Monad.Trans.Cont import Data.Foldable import Data.Function import Data.Maybe (fromMaybe) +import Data.Profunctor import Data.Text (Text) import Facet.Env as Env import Facet.Graph @@ -142,36 +159,110 @@ quoteV d = \case VDict os -> XDict <$> traverse (traverse (quoteV d)) os -newtype E sig r a = E (sig (E sig) r a -> (a -> r) -> r) +class (Profunctor p, Monad m) => LeftPromodule m p | p -> m where + bindl :: (a -> (b `p` c)) -> m a -> (b `p` c) + bindl f m = joinl (fmap f m) -runE :: sig (E sig) r a -> (a -> r) -> E sig r a -> r -runE h k (E run) = run h k + joinl :: m (a `p` b) -> (a `p` b) + joinl = bindl id -liftE :: r -> E sig r a -liftE r = E $ \ _ _ -> r + {-# MINIMAL bindl | joinl #-} +class (Profunctor p, Monad m) => RightPromodule m p | p -> m where + dibind :: (a' -> m a) -> (b -> m b') -> (a `p` b) -> (a' `p` b') + dibind f g = lbind f . rbind g -newtype Empty m r a = Empty { empty :: forall b . (b -> m r a) -> r } + lbind :: (a' -> m a) -> (a `p` b) -> (a' `p` b) + lbind = (`dibind` return) + rbind :: (b -> m b') -> (a `p` b) -> (a `p` b') + rbind = (return `dibind`) -data Reader' e m r a = Reader' { ask' :: (e -> m r a) -> r, local' :: forall x . (e -> e) -> m x x -> (x -> m r a) -> r } + {-# MINIMAL dibind | (lbind, rbind) #-} -data State' s m r a = State' { get' :: (s -> m r a) -> r, put' :: s -> (() -> m r a) -> r } +newtype E sig r a = E (sig (Cont r) a r -> Cont r a) +instance Profunctor (sig (Cont r)) => Functor (E sig r) where + fmap f (E run) = E $ \ d -> f <$> run (lmap f d) + +instance RightPromodule (Cont r) (sig (Cont r)) => Applicative (E sig r) where + pure a = E $ \ _ -> pure a + (<*>) = ap + +instance RightPromodule (Cont r) (sig (Cont r)) => Monad (E sig r) where + E run >>= f = E $ \ d -> run (lbind (runE d . f) d) >>= runE d . f + +runE :: sig (Cont r) a r -> E sig r a -> Cont r a +runE d (E run) = run d + +liftE :: Cont r a -> E sig r a +liftE = E . const + + +newtype Empty m a b = Empty { empty :: forall e . (e -> m a) -> m b } + deriving (Functor) + +instance Functor m => Profunctor (Empty m) where + dimap f g Empty{ empty } = Empty{ empty = \ k -> g <$> empty (fmap f . k) } + +instance Monad m => RightPromodule m (Empty m) where + dibind f g Empty{ empty } = Empty{ empty = \ k -> g =<< empty (f <=< k) } toMaybe :: E Empty (Maybe a) a -> Maybe a -toMaybe = runE Empty{ empty = const Nothing } Just +toMaybe = (`runCont` Just) . runE Empty{ empty = \ _k -> pure Nothing } + + +data Reader' r m a b = Reader' { ask' :: (r -> m a) -> m b, local' :: forall x . (r -> r) -> m x -> (x -> m a) -> m b } + deriving (Functor) + +instance Functor m => Profunctor (Reader' r m) where + dimap f g Reader'{ ask', local' } = Reader'{ ask' = \ k -> g <$> ask' (fmap f . k), local' = \ h m k -> g <$> local' h m (fmap f . k) } + +instance Monad m => RightPromodule m (Reader' r m) where + dibind f g Reader'{ ask', local' } = Reader'{ ask' = \ k -> g =<< ask' (f <=< k), local' = \ h m k -> g =<< local' h m (f <=< k) } + + +ask'' :: E (Reader' r) x r +ask'' = E $ \ Reader'{ ask' } -> send' ask' + +reader' :: r -> E (Reader' r) a a -> Cont x a +reader' r m = reset $ runE dict m + where + dict = Reader' + { ask' = \ k -> reader' r (liftE (k r)) + -- , local' = \ f m k -> reader' r (liftE (k =<< reader' (f r) m)) + } + + +data State' s m a b = State' { get' :: (s -> m a) -> m b, put' :: s -> (() -> m a) -> m b } + deriving (Functor) + +instance Functor m => Profunctor (State' r m) where + dimap f g State'{ get', put' } = State'{ get' = \ k -> g <$> get' (fmap f . k), put' = \ s k -> g <$> put' s (fmap f . k) } + +instance Monad m => RightPromodule m (State' r m) where + dibind f g State'{ get', put' } = State'{ get' = \ k -> g =<< get' (f <=< k), put' = \ s k -> g =<< put' s (f <=< k) } + + +send' :: ((c -> Cont r b) -> Cont r r) -> Cont r c +send' hdl = ContT $ \ k -> evalContT (hdl (\ a -> ContT (\ _ -> k a))) -runReader' :: e -> E (Reader' e) a a -> a -runReader' e = runE Reader'{ ask' = \ k -> runReader' e (k e), local' = \ f m k -> runReader' e (k (runReader' (f e) m)) } id +state'' :: s -> E (State' s) (s, a) a -> Cont x (s, a) +state'' = state' (,) -runState' :: s -> E (State' s) (s, a) a -> (s, a) -runState' s = runE State'{ get' = \ k -> runState' s (k s), put' = \ s k -> runState' s (k ()) } (s,) +state' :: (s -> a -> b) -> s -> E (State' s) b a -> Cont x b +state' z s m = reset $ ContT $ \ k -> runContT (runE dict m) (k . z s) + where + dict = State' + { get' = \ k -> state' z s (liftE (k s)) + , put' = \ s k -> state' z s (liftE (k ())) } +modify :: (s -> s) -> E (State' s) x () +modify f = put'' . f =<< get'' get'' :: E (State' s) x s -get'' = E $ \ State'{ get' } k -> get' (liftE . k) +get'' = E $ \ State'{ get' } -> send' get' put'' :: s -> E (State' s) x () -put'' s = E $ \ State'{ put' } k -> put' s (liftE . k) +put'' s = E $ \ State'{ put' } -> send' (put' s) From 3571909fc27356870573337a06c701422473991d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 16 Apr 2021 07:47:57 -0400 Subject: [PATCH 0111/1324] Parameterize E by the monad. --- src/Facet/Eval.hs | 42 +++++++++++++++++++++--------------------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 3fb685e7a..b8e8324f3 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -181,23 +181,23 @@ class (Profunctor p, Monad m) => RightPromodule m p | p -> m where {-# MINIMAL dibind | (lbind, rbind) #-} -newtype E sig r a = E (sig (Cont r) a r -> Cont r a) +newtype E sig r m a = E (sig m a r -> m a) -instance Profunctor (sig (Cont r)) => Functor (E sig r) where +instance (Functor m, Profunctor (sig m)) => Functor (E sig r m) where fmap f (E run) = E $ \ d -> f <$> run (lmap f d) -instance RightPromodule (Cont r) (sig (Cont r)) => Applicative (E sig r) where +instance RightPromodule m (sig m) => Applicative (E sig r m) where pure a = E $ \ _ -> pure a (<*>) = ap -instance RightPromodule (Cont r) (sig (Cont r)) => Monad (E sig r) where +instance RightPromodule m (sig m) => Monad (E sig r m) where E run >>= f = E $ \ d -> run (lbind (runE d . f) d) >>= runE d . f -runE :: sig (Cont r) a r -> E sig r a -> Cont r a -runE d (E run) = run d +instance MonadTrans (E sig r) where + lift = E . const -liftE :: Cont r a -> E sig r a -liftE = E . const +runE :: sig m a r -> E sig r m a -> m a +runE d (E run) = run d newtype Empty m a b = Empty { empty :: forall e . (e -> m a) -> m b } @@ -209,7 +209,7 @@ instance Functor m => Profunctor (Empty m) where instance Monad m => RightPromodule m (Empty m) where dibind f g Empty{ empty } = Empty{ empty = \ k -> g =<< empty (f <=< k) } -toMaybe :: E Empty (Maybe a) a -> Maybe a +toMaybe :: E Empty (Maybe a) (Cont (Maybe a)) a -> Maybe a toMaybe = (`runCont` Just) . runE Empty{ empty = \ _k -> pure Nothing } @@ -223,15 +223,15 @@ instance Monad m => RightPromodule m (Reader' r m) where dibind f g Reader'{ ask', local' } = Reader'{ ask' = \ k -> g =<< ask' (f <=< k), local' = \ h m k -> g =<< local' h m (f <=< k) } -ask'' :: E (Reader' r) x r +ask'' :: E (Reader' r) x (Cont x) r ask'' = E $ \ Reader'{ ask' } -> send' ask' -reader' :: r -> E (Reader' r) a a -> Cont x a -reader' r m = reset $ runE dict m +reader' :: Monad m => r -> E (Reader' r) a m a -> m a +reader' r = runE dict where dict = Reader' - { ask' = \ k -> reader' r (liftE (k r)) - -- , local' = \ f m k -> reader' r (liftE (k =<< reader' (f r) m)) + { ask' = \ k -> reader' r (lift (k r)) + -- , local' = \ f m k -> reader' r (lift (k =<< reader' (f r) m)) } @@ -248,21 +248,21 @@ instance Monad m => RightPromodule m (State' r m) where send' :: ((c -> Cont r b) -> Cont r r) -> Cont r c send' hdl = ContT $ \ k -> evalContT (hdl (\ a -> ContT (\ _ -> k a))) -state'' :: s -> E (State' s) (s, a) a -> Cont x (s, a) +state'' :: s -> E (State' s) (s, a) (Cont (s, a)) a -> Cont (s, a) (s, a) state'' = state' (,) -state' :: (s -> a -> b) -> s -> E (State' s) b a -> Cont x b +state' :: (s -> a -> b) -> s -> E (State' s) b (Cont b) a -> Cont b b state' z s m = reset $ ContT $ \ k -> runContT (runE dict m) (k . z s) where dict = State' - { get' = \ k -> state' z s (liftE (k s)) - , put' = \ s k -> state' z s (liftE (k ())) } + { get' = \ k -> state' z s (lift (k s)) + , put' = \ s k -> state' z s (lift (k ())) } -modify :: (s -> s) -> E (State' s) x () +modify :: (s -> s) -> E (State' s) x (Cont x) () modify f = put'' . f =<< get'' -get'' :: E (State' s) x s +get'' :: E (State' s) x (Cont x) s get'' = E $ \ State'{ get' } -> send' get' -put'' :: s -> E (State' s) x () +put'' :: s -> E (State' s) x (Cont x) () put'' s = E $ \ State'{ put' } -> send' (put' s) From b723e12984ef2a8eb0d28b0fdbb8a32b2a3e5444 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 16 Apr 2021 08:22:24 -0400 Subject: [PATCH 0112/1324] Revert "Parameterize E by the monad." This reverts commit 3571909fc27356870573337a06c701422473991d. --- src/Facet/Eval.hs | 42 +++++++++++++++++++++--------------------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index b8e8324f3..3fb685e7a 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -181,24 +181,24 @@ class (Profunctor p, Monad m) => RightPromodule m p | p -> m where {-# MINIMAL dibind | (lbind, rbind) #-} -newtype E sig r m a = E (sig m a r -> m a) +newtype E sig r a = E (sig (Cont r) a r -> Cont r a) -instance (Functor m, Profunctor (sig m)) => Functor (E sig r m) where +instance Profunctor (sig (Cont r)) => Functor (E sig r) where fmap f (E run) = E $ \ d -> f <$> run (lmap f d) -instance RightPromodule m (sig m) => Applicative (E sig r m) where +instance RightPromodule (Cont r) (sig (Cont r)) => Applicative (E sig r) where pure a = E $ \ _ -> pure a (<*>) = ap -instance RightPromodule m (sig m) => Monad (E sig r m) where +instance RightPromodule (Cont r) (sig (Cont r)) => Monad (E sig r) where E run >>= f = E $ \ d -> run (lbind (runE d . f) d) >>= runE d . f -instance MonadTrans (E sig r) where - lift = E . const - -runE :: sig m a r -> E sig r m a -> m a +runE :: sig (Cont r) a r -> E sig r a -> Cont r a runE d (E run) = run d +liftE :: Cont r a -> E sig r a +liftE = E . const + newtype Empty m a b = Empty { empty :: forall e . (e -> m a) -> m b } deriving (Functor) @@ -209,7 +209,7 @@ instance Functor m => Profunctor (Empty m) where instance Monad m => RightPromodule m (Empty m) where dibind f g Empty{ empty } = Empty{ empty = \ k -> g =<< empty (f <=< k) } -toMaybe :: E Empty (Maybe a) (Cont (Maybe a)) a -> Maybe a +toMaybe :: E Empty (Maybe a) a -> Maybe a toMaybe = (`runCont` Just) . runE Empty{ empty = \ _k -> pure Nothing } @@ -223,15 +223,15 @@ instance Monad m => RightPromodule m (Reader' r m) where dibind f g Reader'{ ask', local' } = Reader'{ ask' = \ k -> g =<< ask' (f <=< k), local' = \ h m k -> g =<< local' h m (f <=< k) } -ask'' :: E (Reader' r) x (Cont x) r +ask'' :: E (Reader' r) x r ask'' = E $ \ Reader'{ ask' } -> send' ask' -reader' :: Monad m => r -> E (Reader' r) a m a -> m a -reader' r = runE dict +reader' :: r -> E (Reader' r) a a -> Cont x a +reader' r m = reset $ runE dict m where dict = Reader' - { ask' = \ k -> reader' r (lift (k r)) - -- , local' = \ f m k -> reader' r (lift (k =<< reader' (f r) m)) + { ask' = \ k -> reader' r (liftE (k r)) + -- , local' = \ f m k -> reader' r (liftE (k =<< reader' (f r) m)) } @@ -248,21 +248,21 @@ instance Monad m => RightPromodule m (State' r m) where send' :: ((c -> Cont r b) -> Cont r r) -> Cont r c send' hdl = ContT $ \ k -> evalContT (hdl (\ a -> ContT (\ _ -> k a))) -state'' :: s -> E (State' s) (s, a) (Cont (s, a)) a -> Cont (s, a) (s, a) +state'' :: s -> E (State' s) (s, a) a -> Cont x (s, a) state'' = state' (,) -state' :: (s -> a -> b) -> s -> E (State' s) b (Cont b) a -> Cont b b +state' :: (s -> a -> b) -> s -> E (State' s) b a -> Cont x b state' z s m = reset $ ContT $ \ k -> runContT (runE dict m) (k . z s) where dict = State' - { get' = \ k -> state' z s (lift (k s)) - , put' = \ s k -> state' z s (lift (k ())) } + { get' = \ k -> state' z s (liftE (k s)) + , put' = \ s k -> state' z s (liftE (k ())) } -modify :: (s -> s) -> E (State' s) x (Cont x) () +modify :: (s -> s) -> E (State' s) x () modify f = put'' . f =<< get'' -get'' :: E (State' s) x (Cont x) s +get'' :: E (State' s) x s get'' = E $ \ State'{ get' } -> send' get' -put'' :: s -> E (State' s) x (Cont x) () +put'' :: s -> E (State' s) x () put'' s = E $ \ State'{ put' } -> send' (put' s) From 0779cb855f79ebbe6a09d7bc4899d007d6a31f5f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 16 Apr 2021 08:48:03 -0400 Subject: [PATCH 0113/1324] Pass dictionaries through continuations. --- src/Facet/Eval.hs | 40 ++++++++++++++++++++-------------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 3fb685e7a..5b975ac19 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -181,19 +181,19 @@ class (Profunctor p, Monad m) => RightPromodule m p | p -> m where {-# MINIMAL dibind | (lbind, rbind) #-} -newtype E sig r a = E (sig (Cont r) a r -> Cont r a) +newtype E sig r a = E (sig (E sig r) a r -> Cont r a) -instance Profunctor (sig (Cont r)) => Functor (E sig r) where +instance Profunctor (sig (E sig r)) => Functor (E sig r) where fmap f (E run) = E $ \ d -> f <$> run (lmap f d) -instance RightPromodule (Cont r) (sig (Cont r)) => Applicative (E sig r) where +instance RightPromodule (E sig r) (sig (E sig r)) => Applicative (E sig r) where pure a = E $ \ _ -> pure a (<*>) = ap -instance RightPromodule (Cont r) (sig (Cont r)) => Monad (E sig r) where - E run >>= f = E $ \ d -> run (lbind (runE d . f) d) >>= runE d . f +instance RightPromodule (E sig r) (sig (E sig r)) => Monad (E sig r) where + E run >>= f = E $ \ d -> run (lbind f d) >>= runE d . f -runE :: sig (Cont r) a r -> E sig r a -> Cont r a +runE :: sig (E sig r) a r -> E sig r a -> Cont r a runE d (E run) = run d liftE :: Cont r a -> E sig r a @@ -224,14 +224,14 @@ instance Monad m => RightPromodule m (Reader' r m) where ask'' :: E (Reader' r) x r -ask'' = E $ \ Reader'{ ask' } -> send' ask' +ask'' = E $ \ d@Reader'{ ask' } -> runE d (send' ask') -reader' :: r -> E (Reader' r) a a -> Cont x a -reader' r m = reset $ runE dict m +reader' :: r -> E (Reader' r) a a -> E (Reader' r) x a +reader' r m = E $ \ _ -> reset $ runE dict m where dict = Reader' - { ask' = \ k -> reader' r (liftE (k r)) - -- , local' = \ f m k -> reader' r (liftE (k =<< reader' (f r) m)) + { ask' = \ k -> reader' r (k r) + -- , local' = \ f m k -> reader' r (k =<< reader' (f r) m) } @@ -245,24 +245,24 @@ instance Monad m => RightPromodule m (State' r m) where dibind f g State'{ get', put' } = State'{ get' = \ k -> g =<< get' (f <=< k), put' = \ s k -> g =<< put' s (f <=< k) } -send' :: ((c -> Cont r b) -> Cont r r) -> Cont r c -send' hdl = ContT $ \ k -> evalContT (hdl (\ a -> ContT (\ _ -> k a))) +send' :: RightPromodule (E sig r) (sig (E sig r)) => ((c -> E sig r c) -> E sig r r) -> E sig r c +send' hdl = E $ \ d -> cont $ \ k -> evalCont (runE (lbind (liftE . cont . const) d) (hdl (liftE . cont . const . k))) -state'' :: s -> E (State' s) (s, a) a -> Cont x (s, a) +state'' :: s -> E (State' s) (s, a) a -> E (State' s) x (s, a) state'' = state' (,) -state' :: (s -> a -> b) -> s -> E (State' s) b a -> Cont x b -state' z s m = reset $ ContT $ \ k -> runContT (runE dict m) (k . z s) +state' :: (s -> a -> b) -> s -> E (State' s) b a -> E (State' s) x b +state' z s m = E $ \ _ -> reset $ ContT $ \ k -> runContT (runE dict m) (k . z s) where dict = State' - { get' = \ k -> state' z s (liftE (k s)) - , put' = \ s k -> state' z s (liftE (k ())) } + { get' = \ k -> state' z s (k s) + , put' = \ s k -> state' z s (k ()) } modify :: (s -> s) -> E (State' s) x () modify f = put'' . f =<< get'' get'' :: E (State' s) x s -get'' = E $ \ State'{ get' } -> send' get' +get'' = E $ \ d@State'{ get' } -> runE d (send' get') put'' :: s -> E (State' s) x () -put'' s = E $ \ State'{ put' } -> send' (put' s) +put'' s = E $ \ d@State'{ put' } -> runE d (send' (put' s)) From 18a14e3886f355c3bded01cabdd4a46c679aac8b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 16 Apr 2021 08:51:33 -0400 Subject: [PATCH 0114/1324] Run state actions in Cont. --- src/Facet/Eval.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 5b975ac19..effcc196a 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -248,15 +248,15 @@ instance Monad m => RightPromodule m (State' r m) where send' :: RightPromodule (E sig r) (sig (E sig r)) => ((c -> E sig r c) -> E sig r r) -> E sig r c send' hdl = E $ \ d -> cont $ \ k -> evalCont (runE (lbind (liftE . cont . const) d) (hdl (liftE . cont . const . k))) -state'' :: s -> E (State' s) (s, a) a -> E (State' s) x (s, a) +state'' :: s -> E (State' s) (s, a) a -> Cont x (s, a) state'' = state' (,) -state' :: (s -> a -> b) -> s -> E (State' s) b a -> E (State' s) x b -state' z s m = E $ \ _ -> reset $ ContT $ \ k -> runContT (runE dict m) (k . z s) +state' :: (s -> a -> b) -> s -> E (State' s) b a -> Cont x b +state' z s m = reset $ ContT $ \ k -> runContT (runE dict m) (k . z s) where dict = State' - { get' = \ k -> state' z s (k s) - , put' = \ s k -> state' z s (k ()) } + { get' = \ k -> liftE $ state' z s (k s) + , put' = \ s k -> liftE $ state' z s (k ()) } modify :: (s -> s) -> E (State' s) x () modify f = put'' . f =<< get'' From 0faaa562f7d44a2eb9b177217147dccdd57431f7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 17 Apr 2021 01:28:36 -0400 Subject: [PATCH 0115/1324] =?UTF-8?q?Try=20to=20ensure=20we=20aren?= =?UTF-8?q?=E2=80=99t=20losing=20the=20state=20as=20we=20continue.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This doesn’t actually work. --- src/Facet/Eval.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index effcc196a..0297400ee 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -251,12 +251,14 @@ send' hdl = E $ \ d -> cont $ \ k -> evalCont (runE (lbind (liftE . cont . const state'' :: s -> E (State' s) (s, a) a -> Cont x (s, a) state'' = state' (,) -state' :: (s -> a -> b) -> s -> E (State' s) b a -> Cont x b -state' z s m = reset $ ContT $ \ k -> runContT (runE dict m) (k . z s) +state' :: forall s a b x . (s -> a -> b) -> s -> E (State' s) b a -> Cont x b +state' z s m = reset $ ContT $ \ k -> runContT (runE (dict s) m) (k . z s) where - dict = State' - { get' = \ k -> liftE $ state' z s (k s) - , put' = \ s k -> liftE $ state' z s (k ()) } + state' :: (s -> a -> b) -> s -> E (State' s) b a -> E (State' s) y b + state' z s m = E $ \ d -> reset $ ContT $ \ k -> runContT (runE (dict s) m) (k . z s) + dict s = State' + { get' = \ k -> state' z s (k s) + , put' = \ s k -> state' z s (k ()) } modify :: (s -> s) -> E (State' s) x () modify f = put'' . f =<< get'' From b0559e4bf74537002550b62438698fc35341a447 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 17 Apr 2021 17:24:56 -0400 Subject: [PATCH 0116/1324] Add parameters to E for the action and handler return types. --- src/Facet/Eval.hs | 110 +++++++++++++++------------------------------- 1 file changed, 35 insertions(+), 75 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 0297400ee..373400f4c 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -12,10 +12,10 @@ module Facet.Eval , unit -- * Quotation , quoteV -, state' -, state'' , E(..) , runE +, state' +, state'' , State'(..) , Reader'(..) -- , Empty(..) @@ -30,13 +30,12 @@ module Facet.Eval import Control.Algebra import Control.Carrier.Reader -import Control.Monad (ap, guard, liftM, (<=<), (>=>)) +import Control.Monad (ap, guard, liftM, (>=>)) import Control.Monad.Trans.Class import Control.Monad.Trans.Cont import Data.Foldable import Data.Function import Data.Maybe (fromMaybe) -import Data.Profunctor import Data.Text (Text) import Facet.Env as Env import Facet.Graph @@ -159,112 +158,73 @@ quoteV d = \case VDict os -> XDict <$> traverse (traverse (quoteV d)) os -class (Profunctor p, Monad m) => LeftPromodule m p | p -> m where - bindl :: (a -> (b `p` c)) -> m a -> (b `p` c) - bindl f m = joinl (fmap f m) - - joinl :: m (a `p` b) -> (a `p` b) - joinl = bindl id - - {-# MINIMAL bindl | joinl #-} - -class (Profunctor p, Monad m) => RightPromodule m p | p -> m where - dibind :: (a' -> m a) -> (b -> m b') -> (a `p` b) -> (a' `p` b') - dibind f g = lbind f . rbind g - - lbind :: (a' -> m a) -> (a `p` b) -> (a' `p` b) - lbind = (`dibind` return) - - rbind :: (b -> m b') -> (a `p` b) -> (a `p` b') - rbind = (return `dibind`) - - {-# MINIMAL dibind | (lbind, rbind) #-} - - -newtype E sig r a = E (sig (E sig r) a r -> Cont r a) - -instance Profunctor (sig (E sig r)) => Functor (E sig r) where - fmap f (E run) = E $ \ d -> f <$> run (lmap f d) +newtype E sig r i a = E (sig (E sig r i) i r -> Cont r a) + deriving (Functor) -instance RightPromodule (E sig r) (sig (E sig r)) => Applicative (E sig r) where +instance Functor (sig (E sig r i) i) => Applicative (E sig r i) where pure a = E $ \ _ -> pure a (<*>) = ap -instance RightPromodule (E sig r) (sig (E sig r)) => Monad (E sig r) where - E run >>= f = E $ \ d -> run (lbind f d) >>= runE d . f +instance Functor (sig (E sig r i) i) => Monad (E sig r i) where + E run >>= f = E $ \ d -> run d >>= runE d . f -runE :: sig (E sig r) a r -> E sig r a -> Cont r a +runE :: sig (E sig r i) i r -> E sig r i a -> Cont r a runE d (E run) = run d -liftE :: Cont r a -> E sig r a -liftE = E . const - newtype Empty m a b = Empty { empty :: forall e . (e -> m a) -> m b } deriving (Functor) -instance Functor m => Profunctor (Empty m) where - dimap f g Empty{ empty } = Empty{ empty = \ k -> g <$> empty (fmap f . k) } - -instance Monad m => RightPromodule m (Empty m) where - dibind f g Empty{ empty } = Empty{ empty = \ k -> g =<< empty (f <=< k) } - -toMaybe :: E Empty (Maybe a) a -> Maybe a +toMaybe :: E Empty (Maybe a) a a -> Maybe a toMaybe = (`runCont` Just) . runE Empty{ empty = \ _k -> pure Nothing } -data Reader' r m a b = Reader' { ask' :: (r -> m a) -> m b, local' :: forall x . (r -> r) -> m x -> (x -> m a) -> m b } +data Reader' r m a b = Reader' + { ask' :: (r -> m a) -> m b + , local' :: forall x . (r -> r) -> m x -> (x -> m a) -> m b } deriving (Functor) -instance Functor m => Profunctor (Reader' r m) where - dimap f g Reader'{ ask', local' } = Reader'{ ask' = \ k -> g <$> ask' (fmap f . k), local' = \ h m k -> g <$> local' h m (fmap f . k) } - -instance Monad m => RightPromodule m (Reader' r m) where - dibind f g Reader'{ ask', local' } = Reader'{ ask' = \ k -> g =<< ask' (f <=< k), local' = \ h m k -> g =<< local' h m (f <=< k) } - - -ask'' :: E (Reader' r) x r +ask'' :: E (Reader' r) b i r ask'' = E $ \ d@Reader'{ ask' } -> runE d (send' ask') -reader' :: r -> E (Reader' r) a a -> E (Reader' r) x a -reader' r m = E $ \ _ -> reset $ runE dict m +reader' :: r -> E (Reader' r) a a a -> Cont b a +reader' = fmap reset . runE . dict where - dict = Reader' + reader' :: r -> E (Reader' r) a a a -> E (Reader' r) b a a + reader' r m = E $ \ _ -> reset $ cont $ \ k -> runCont (runE (dict r) m) k + dict :: r -> Reader' r (E (Reader' r) a a) a a + dict r = Reader' { ask' = \ k -> reader' r (k r) -- , local' = \ f m k -> reader' r (k =<< reader' (f r) m) } -data State' s m a b = State' { get' :: (s -> m a) -> m b, put' :: s -> (() -> m a) -> m b } +data State' s m a b = State' + { get' :: (s -> m a) -> m b + , put' :: s -> (() -> m a) -> m b } deriving (Functor) -instance Functor m => Profunctor (State' r m) where - dimap f g State'{ get', put' } = State'{ get' = \ k -> g <$> get' (fmap f . k), put' = \ s k -> g <$> put' s (fmap f . k) } - -instance Monad m => RightPromodule m (State' r m) where - dibind f g State'{ get', put' } = State'{ get' = \ k -> g =<< get' (f <=< k), put' = \ s k -> g =<< put' s (f <=< k) } - - -send' :: RightPromodule (E sig r) (sig (E sig r)) => ((c -> E sig r c) -> E sig r r) -> E sig r c -send' hdl = E $ \ d -> cont $ \ k -> evalCont (runE (lbind (liftE . cont . const) d) (hdl (liftE . cont . const . k))) +send' :: ((c -> E sig b i i) -> E sig b i b) -> E sig b i c +send' hdl = E $ \ d -> cont $ \ k -> evalCont (runE d (hdl (E . const . cont . const . k))) -state'' :: s -> E (State' s) (s, a) a -> Cont x (s, a) +state'' :: s -> E (State' s) (s, a) a a -> Cont x (s, a) state'' = state' (,) -state' :: forall s a b x . (s -> a -> b) -> s -> E (State' s) b a -> Cont x b -state' z s m = reset $ ContT $ \ k -> runContT (runE (dict s) m) (k . z s) +state' :: (s -> a -> b) -> s -> E (State' s) b a a -> Cont x b +state' z s m = reset $ cont $ \ k -> runCont (runE (dict z s) m) (k . z s) where - state' :: (s -> a -> b) -> s -> E (State' s) b a -> E (State' s) y b - state' z s m = E $ \ d -> reset $ ContT $ \ k -> runContT (runE (dict s) m) (k . z s) - dict s = State' + state' :: (s -> a -> b) -> s -> E (State' s) b a a -> E (State' s) b a b + state' z s m = E $ \ _ -> reset $ cont $ \ k -> runCont (runE (dict z s) m) (k . z s) + dict :: (s -> a -> b) -> s -> State' s (E (State' s) b a) a b + dict z s = State' { get' = \ k -> state' z s (k s) , put' = \ s k -> state' z s (k ()) } -modify :: (s -> s) -> E (State' s) x () +modify :: (s -> s) -> E (State' s) r i () modify f = put'' . f =<< get'' -get'' :: E (State' s) x s +get'' :: E (State' s) r i s get'' = E $ \ d@State'{ get' } -> runE d (send' get') -put'' :: s -> E (State' s) x () +put'' :: s -> E (State' s) r i () put'' s = E $ \ d@State'{ put' } -> runE d (send' (put' s)) From c6d796ad532e4a57e06cade5552c8092c6c1b3ca Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 17 Apr 2021 18:22:57 -0400 Subject: [PATCH 0117/1324] Replace the state in the continuation. --- src/Facet/Eval.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 373400f4c..2e6634b20 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -218,7 +218,7 @@ state' z s m = reset $ cont $ \ k -> runCont (runE (dict z s) m) (k . z s) dict :: (s -> a -> b) -> s -> State' s (E (State' s) b a) a b dict z s = State' { get' = \ k -> state' z s (k s) - , put' = \ s k -> state' z s (k ()) } + , put' = \ s k -> state' (\ _ -> z s) s (k ()) } modify :: (s -> s) -> E (State' s) r i () modify f = put'' . f =<< get'' From de4f002930651843a0f4b126af58816425e23b12 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 17 Apr 2021 18:23:06 -0400 Subject: [PATCH 0118/1324] Revert "Replace the state in the continuation." This reverts commit c6d796ad532e4a57e06cade5552c8092c6c1b3ca. --- src/Facet/Eval.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 2e6634b20..373400f4c 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -218,7 +218,7 @@ state' z s m = reset $ cont $ \ k -> runCont (runE (dict z s) m) (k . z s) dict :: (s -> a -> b) -> s -> State' s (E (State' s) b a) a b dict z s = State' { get' = \ k -> state' z s (k s) - , put' = \ s k -> state' (\ _ -> z s) s (k ()) } + , put' = \ s k -> state' z s (k ()) } modify :: (s -> s) -> E (State' s) r i () modify f = put'' . f =<< get'' From 4890a1ddba0078ece543a86d6f61fda03b20d21c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 18 Apr 2021 08:57:12 -0400 Subject: [PATCH 0119/1324] :fire: redundant constraints. --- src/Facet/Eval.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 373400f4c..a9ebe062e 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -161,11 +161,11 @@ quoteV d = \case newtype E sig r i a = E (sig (E sig r i) i r -> Cont r a) deriving (Functor) -instance Functor (sig (E sig r i) i) => Applicative (E sig r i) where +instance Applicative (E sig r i) where pure a = E $ \ _ -> pure a (<*>) = ap -instance Functor (sig (E sig r i) i) => Monad (E sig r i) where +instance Monad (E sig r i) where E run >>= f = E $ \ d -> run d >>= runE d . f runE :: sig (E sig r i) i r -> E sig r i a -> Cont r a From fb0cc57afb74234d56db773099d8d869aa1460c2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 18 Apr 2021 08:57:33 -0400 Subject: [PATCH 0120/1324] Give signatures a parameter for the return monad. --- src/Facet/Eval.hs | 30 +++++++++++++----------------- 1 file changed, 13 insertions(+), 17 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index a9ebe062e..72a658e8d 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -158,7 +158,7 @@ quoteV d = \case VDict os -> XDict <$> traverse (traverse (quoteV d)) os -newtype E sig r i a = E (sig (E sig r i) i r -> Cont r a) +newtype E sig r i a = E (sig (E sig r i) (Cont r) i r -> Cont r a) deriving (Functor) instance Applicative (E sig r i) where @@ -168,20 +168,20 @@ instance Applicative (E sig r i) where instance Monad (E sig r i) where E run >>= f = E $ \ d -> run d >>= runE d . f -runE :: sig (E sig r i) i r -> E sig r i a -> Cont r a +runE :: sig (E sig r i) (Cont r) i r -> E sig r i a -> Cont r a runE d (E run) = run d -newtype Empty m a b = Empty { empty :: forall e . (e -> m a) -> m b } +newtype Empty m n a b = Empty { empty :: forall e . (e -> m a) -> n b } deriving (Functor) toMaybe :: E Empty (Maybe a) a a -> Maybe a toMaybe = (`runCont` Just) . runE Empty{ empty = \ _k -> pure Nothing } -data Reader' r m a b = Reader' - { ask' :: (r -> m a) -> m b - , local' :: forall x . (r -> r) -> m x -> (x -> m a) -> m b } +data Reader' r m n a b = Reader' + { ask' :: (r -> m a) -> n b + , local' :: forall x . (r -> r) -> m x -> (x -> m a) -> n b } deriving (Functor) ask'' :: E (Reader' r) b i r @@ -190,22 +190,20 @@ ask'' = E $ \ d@Reader'{ ask' } -> runE d (send' ask') reader' :: r -> E (Reader' r) a a a -> Cont b a reader' = fmap reset . runE . dict where - reader' :: r -> E (Reader' r) a a a -> E (Reader' r) b a a - reader' r m = E $ \ _ -> reset $ cont $ \ k -> runCont (runE (dict r) m) k - dict :: r -> Reader' r (E (Reader' r) a a) a a + dict :: r -> Reader' r (E (Reader' r) a a) (Cont a) a a dict r = Reader' { ask' = \ k -> reader' r (k r) -- , local' = \ f m k -> reader' r (k =<< reader' (f r) m) } -data State' s m a b = State' - { get' :: (s -> m a) -> m b - , put' :: s -> (() -> m a) -> m b } +data State' s m n a b = State' + { get' :: (s -> m a) -> n b + , put' :: s -> (() -> m a) -> n b } deriving (Functor) -send' :: ((c -> E sig b i i) -> E sig b i b) -> E sig b i c -send' hdl = E $ \ d -> cont $ \ k -> evalCont (runE d (hdl (E . const . cont . const . k))) +send' :: ((c -> E sig b i i) -> Cont b b) -> E sig b i c +send' hdl = E $ \ _ -> cont $ \ k -> evalCont (hdl (E . const . cont . const . k)) state'' :: s -> E (State' s) (s, a) a a -> Cont x (s, a) state'' = state' (,) @@ -213,9 +211,7 @@ state'' = state' (,) state' :: (s -> a -> b) -> s -> E (State' s) b a a -> Cont x b state' z s m = reset $ cont $ \ k -> runCont (runE (dict z s) m) (k . z s) where - state' :: (s -> a -> b) -> s -> E (State' s) b a a -> E (State' s) b a b - state' z s m = E $ \ _ -> reset $ cont $ \ k -> runCont (runE (dict z s) m) (k . z s) - dict :: (s -> a -> b) -> s -> State' s (E (State' s) b a) a b + dict :: (s -> a -> b) -> s -> State' s (E (State' s) b a) (Cont b) a b dict z s = State' { get' = \ k -> state' z s (k s) , put' = \ s k -> state' z s (k ()) } From 383757ff0563e9c9546b8861782127cfe58ef6bd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 18 Apr 2021 09:01:48 -0400 Subject: [PATCH 0121/1324] :fire: the return monad. --- src/Facet/Eval.hs | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 72a658e8d..7d8f8b9fd 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -158,7 +158,7 @@ quoteV d = \case VDict os -> XDict <$> traverse (traverse (quoteV d)) os -newtype E sig r i a = E (sig (E sig r i) (Cont r) i r -> Cont r a) +newtype E sig r i a = E (sig (E sig r i) i r -> Cont r a) deriving (Functor) instance Applicative (E sig r i) where @@ -168,50 +168,50 @@ instance Applicative (E sig r i) where instance Monad (E sig r i) where E run >>= f = E $ \ d -> run d >>= runE d . f -runE :: sig (E sig r i) (Cont r) i r -> E sig r i a -> Cont r a +runE :: sig (E sig r i) i r -> E sig r i a -> Cont r a runE d (E run) = run d -newtype Empty m n a b = Empty { empty :: forall e . (e -> m a) -> n b } +newtype Empty m a b = Empty { empty :: forall e . (e -> m a) -> b } deriving (Functor) toMaybe :: E Empty (Maybe a) a a -> Maybe a -toMaybe = (`runCont` Just) . runE Empty{ empty = \ _k -> pure Nothing } +toMaybe = (`runCont` Just) . runE Empty{ empty = const Nothing } -data Reader' r m n a b = Reader' - { ask' :: (r -> m a) -> n b - , local' :: forall x . (r -> r) -> m x -> (x -> m a) -> n b } +data Reader' r m a b = Reader' + { ask' :: (r -> m a) -> b + , local' :: forall x . (r -> r) -> m x -> (x -> m a) -> b } deriving (Functor) ask'' :: E (Reader' r) b i r ask'' = E $ \ d@Reader'{ ask' } -> runE d (send' ask') -reader' :: r -> E (Reader' r) a a a -> Cont b a -reader' = fmap reset . runE . dict +reader' :: r -> E (Reader' r) a a a -> a +reader' r = evalCont . runE (dict r) where - dict :: r -> Reader' r (E (Reader' r) a a) (Cont a) a a + dict :: r -> Reader' r (E (Reader' r) a a) a a dict r = Reader' { ask' = \ k -> reader' r (k r) -- , local' = \ f m k -> reader' r (k =<< reader' (f r) m) } -data State' s m n a b = State' - { get' :: (s -> m a) -> n b - , put' :: s -> (() -> m a) -> n b } +data State' s m a b = State' + { get' :: (s -> m a) -> b + , put' :: s -> (() -> m a) -> b } deriving (Functor) -send' :: ((c -> E sig b i i) -> Cont b b) -> E sig b i c -send' hdl = E $ \ _ -> cont $ \ k -> evalCont (hdl (E . const . cont . const . k)) +send' :: ((c -> E sig b i i) -> b) -> E sig b i c +send' hdl = E $ \ _ -> cont $ \ k -> hdl (E . const . cont . const . k) -state'' :: s -> E (State' s) (s, a) a a -> Cont x (s, a) +state'' :: s -> E (State' s) (s, a) a a -> (s, a) state'' = state' (,) -state' :: (s -> a -> b) -> s -> E (State' s) b a a -> Cont x b -state' z s m = reset $ cont $ \ k -> runCont (runE (dict z s) m) (k . z s) +state' :: (s -> a -> b) -> s -> E (State' s) b a a -> b +state' z s m = runCont (runE (dict z s) m) (z s) where - dict :: (s -> a -> b) -> s -> State' s (E (State' s) b a) (Cont b) a b + dict :: (s -> a -> b) -> s -> State' s (E (State' s) b a) a b dict z s = State' { get' = \ k -> state' z s (k s) , put' = \ s k -> state' z s (k ()) } From e676f982c0828930bcbc9148a571c6eed5d808af Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 18 Apr 2021 09:02:40 -0400 Subject: [PATCH 0122/1324] Correct the commented out local case. --- src/Facet/Eval.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 7d8f8b9fd..4e661a464 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -193,7 +193,7 @@ reader' r = evalCont . runE (dict r) dict :: r -> Reader' r (E (Reader' r) a a) a a dict r = Reader' { ask' = \ k -> reader' r (k r) - -- , local' = \ f m k -> reader' r (k =<< reader' (f r) m) + -- , local' = \ f m k -> reader' r (k (reader' (f r) m)) } From c53abcbed94a01128ba4a98dc69d9564cf7c54af Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 18 Apr 2021 09:08:17 -0400 Subject: [PATCH 0123/1324] Simplify effect operations. --- src/Facet/Eval.hs | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 4e661a464..f22b69e63 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -185,7 +185,7 @@ data Reader' r m a b = Reader' deriving (Functor) ask'' :: E (Reader' r) b i r -ask'' = E $ \ d@Reader'{ ask' } -> runE d (send' ask') +ask'' = send' ask' reader' :: r -> E (Reader' r) a a a -> a reader' r = evalCont . runE (dict r) @@ -202,17 +202,16 @@ data State' s m a b = State' , put' :: s -> (() -> m a) -> b } deriving (Functor) -send' :: ((c -> E sig b i i) -> b) -> E sig b i c -send' hdl = E $ \ _ -> cont $ \ k -> hdl (E . const . cont . const . k) +send' :: (sig (E sig b i) i b -> (c -> E sig b i i) -> b) -> E sig b i c +send' hdl = E $ \ d -> cont $ \ k -> hdl d (E . const . cont . const . k) state'' :: s -> E (State' s) (s, a) a a -> (s, a) state'' = state' (,) state' :: (s -> a -> b) -> s -> E (State' s) b a a -> b -state' z s m = runCont (runE (dict z s) m) (z s) +state' z s m = runCont (runE dict m) (z s) where - dict :: (s -> a -> b) -> s -> State' s (E (State' s) b a) a b - dict z s = State' + dict = State' { get' = \ k -> state' z s (k s) , put' = \ s k -> state' z s (k ()) } @@ -220,7 +219,7 @@ modify :: (s -> s) -> E (State' s) r i () modify f = put'' . f =<< get'' get'' :: E (State' s) r i s -get'' = E $ \ d@State'{ get' } -> runE d (send' get') +get'' = send' get' put'' :: s -> E (State' s) r i () -put'' s = E $ \ d@State'{ put' } -> runE d (send' (put' s)) +put'' s = send' (`put'` s) From d4c5e9f006db2ac611764d45b7bd44533cd500e9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 18 Apr 2021 09:10:48 -0400 Subject: [PATCH 0124/1324] Inline Cont into E. --- src/Facet/Eval.hs | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index f22b69e63..f05f938f8 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -32,7 +32,6 @@ import Control.Algebra import Control.Carrier.Reader import Control.Monad (ap, guard, liftM, (>=>)) import Control.Monad.Trans.Class -import Control.Monad.Trans.Cont import Data.Foldable import Data.Function import Data.Maybe (fromMaybe) @@ -158,25 +157,25 @@ quoteV d = \case VDict os -> XDict <$> traverse (traverse (quoteV d)) os -newtype E sig r i a = E (sig (E sig r i) i r -> Cont r a) +newtype E sig r i a = E (sig (E sig r i) i r -> (a -> r) -> r) deriving (Functor) instance Applicative (E sig r i) where - pure a = E $ \ _ -> pure a + pure a = E $ \ _ k -> k a (<*>) = ap instance Monad (E sig r i) where - E run >>= f = E $ \ d -> run d >>= runE d . f + E run >>= f = E $ \ d k -> run d (runE d k . f) -runE :: sig (E sig r i) i r -> E sig r i a -> Cont r a -runE d (E run) = run d +runE :: sig (E sig r i) i r -> (a -> r) -> E sig r i a -> r +runE d k (E run) = run d k newtype Empty m a b = Empty { empty :: forall e . (e -> m a) -> b } deriving (Functor) toMaybe :: E Empty (Maybe a) a a -> Maybe a -toMaybe = (`runCont` Just) . runE Empty{ empty = const Nothing } +toMaybe = runE Empty{ empty = const Nothing } Just data Reader' r m a b = Reader' @@ -188,7 +187,7 @@ ask'' :: E (Reader' r) b i r ask'' = send' ask' reader' :: r -> E (Reader' r) a a a -> a -reader' r = evalCont . runE (dict r) +reader' r = runE (dict r) id where dict :: r -> Reader' r (E (Reader' r) a a) a a dict r = Reader' @@ -203,13 +202,13 @@ data State' s m a b = State' deriving (Functor) send' :: (sig (E sig b i) i b -> (c -> E sig b i i) -> b) -> E sig b i c -send' hdl = E $ \ d -> cont $ \ k -> hdl d (E . const . cont . const . k) +send' hdl = E $ \ d k -> hdl d (E . const . const . k) state'' :: s -> E (State' s) (s, a) a a -> (s, a) state'' = state' (,) state' :: (s -> a -> b) -> s -> E (State' s) b a a -> b -state' z s m = runCont (runE dict m) (z s) +state' z s = runE dict (z s) where dict = State' { get' = \ k -> state' z s (k s) From efbb655ec075f7be4026e9a777918a4db59aa5fa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 18 Apr 2021 10:36:16 -0400 Subject: [PATCH 0125/1324] Thread state through the continuation. --- src/Facet/Eval.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index f05f938f8..b2bee357e 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -204,15 +204,15 @@ data State' s m a b = State' send' :: (sig (E sig b i) i b -> (c -> E sig b i i) -> b) -> E sig b i c send' hdl = E $ \ d k -> hdl d (E . const . const . k) -state'' :: s -> E (State' s) (s, a) a a -> (s, a) +state'' :: s -> E (State' s) (s -> (s, a)) a a -> (s, a) state'' = state' (,) -state' :: (s -> a -> b) -> s -> E (State' s) b a a -> b -state' z s = runE dict (z s) +state' :: (s -> a -> b) -> s -> E (State' s) (s -> b) a a -> b +state' z s m = runE dict (flip z) m s where dict = State' - { get' = \ k -> state' z s (k s) - , put' = \ s k -> state' z s (k ()) } + { get' = \ k s -> state' z s (k s) + , put' = \ s k _ -> state' z s (k ()) } modify :: (s -> s) -> E (State' s) r i () modify f = put'' . f =<< get'' From 7303cfbf3bcc98159aa436a981a5eee818bb99b3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 18 Apr 2021 10:38:08 -0400 Subject: [PATCH 0126/1324] Thread the environment through the continuation. --- src/Facet/Eval.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index b2bee357e..5c8c80f8d 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -186,13 +186,12 @@ data Reader' r m a b = Reader' ask'' :: E (Reader' r) b i r ask'' = send' ask' -reader' :: r -> E (Reader' r) a a a -> a -reader' r = runE (dict r) id +reader' :: r -> E (Reader' r) (r -> a) a a -> a +reader' r m = runE dict const m r where - dict :: r -> Reader' r (E (Reader' r) a a) a a - dict r = Reader' - { ask' = \ k -> reader' r (k r) - -- , local' = \ f m k -> reader' r (k (reader' (f r) m)) + dict = Reader' + { ask' = \ k r -> reader' r (k r) + -- , local' = \ f m k r -> reader' r (k (reader' (f r) m)) } From 7ad7c1eeeb644b7d57c7d6a005ba1b73822917a5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 18 Apr 2021 12:16:56 -0400 Subject: [PATCH 0127/1324] Quantify over the action result type. --- src/Facet/Eval.hs | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 5c8c80f8d..d8c8243d2 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -157,24 +157,24 @@ quoteV d = \case VDict os -> XDict <$> traverse (traverse (quoteV d)) os -newtype E sig r i a = E (sig (E sig r i) i r -> (a -> r) -> r) +newtype E sig r a = E (forall i . sig (E sig r) i r -> (a -> r) -> r) deriving (Functor) -instance Applicative (E sig r i) where +instance Applicative (E sig r) where pure a = E $ \ _ k -> k a (<*>) = ap -instance Monad (E sig r i) where +instance Monad (E sig r) where E run >>= f = E $ \ d k -> run d (runE d k . f) -runE :: sig (E sig r i) i r -> (a -> r) -> E sig r i a -> r +runE :: sig (E sig r) i r -> (a -> r) -> E sig r a -> r runE d k (E run) = run d k newtype Empty m a b = Empty { empty :: forall e . (e -> m a) -> b } deriving (Functor) -toMaybe :: E Empty (Maybe a) a a -> Maybe a +toMaybe :: E Empty (Maybe a) a -> Maybe a toMaybe = runE Empty{ empty = const Nothing } Just @@ -183,10 +183,10 @@ data Reader' r m a b = Reader' , local' :: forall x . (r -> r) -> m x -> (x -> m a) -> b } deriving (Functor) -ask'' :: E (Reader' r) b i r +ask'' :: E (Reader' r) b r ask'' = send' ask' -reader' :: r -> E (Reader' r) (r -> a) a a -> a +reader' :: r -> E (Reader' r) (r -> a) a -> a reader' r m = runE dict const m r where dict = Reader' @@ -200,24 +200,24 @@ data State' s m a b = State' , put' :: s -> (() -> m a) -> b } deriving (Functor) -send' :: (sig (E sig b i) i b -> (c -> E sig b i i) -> b) -> E sig b i c -send' hdl = E $ \ d k -> hdl d (E . const . const . k) +send' :: (forall i . sig (E sig b) i b -> (c -> E sig b i) -> b) -> E sig b c +send' hdl = E $ \ d k -> hdl d (\ c -> E (\ _ _ -> k c)) -state'' :: s -> E (State' s) (s -> (s, a)) a a -> (s, a) +state'' :: s -> E (State' s) (s -> (s, a)) a -> (s, a) state'' = state' (,) -state' :: (s -> a -> b) -> s -> E (State' s) (s -> b) a a -> b +state' :: (s -> a -> b) -> s -> E (State' s) (s -> b) a -> b state' z s m = runE dict (flip z) m s where dict = State' { get' = \ k s -> state' z s (k s) , put' = \ s k _ -> state' z s (k ()) } -modify :: (s -> s) -> E (State' s) r i () +modify :: (s -> s) -> E (State' s) r () modify f = put'' . f =<< get'' -get'' :: E (State' s) r i s +get'' :: E (State' s) r s get'' = send' get' -put'' :: s -> E (State' s) r i () +put'' :: s -> E (State' s) r () put'' s = send' (`put'` s) From 271b6f96d37535bcb61f6e6dd2bb419e37eee27a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 18 Apr 2021 12:52:39 -0400 Subject: [PATCH 0128/1324] Define a C monad wrapping E and quantifying over r. --- src/Facet/Eval.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index d8c8243d2..8c65d9956 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -157,6 +157,17 @@ quoteV d = \case VDict os -> XDict <$> traverse (traverse (quoteV d)) os +newtype C sig a = C { runC :: forall r . E sig r a } + deriving (Functor) + +instance Applicative (C sig) where + pure a = C (pure a) + (<*>) = ap + +instance Monad (C sig) where + C m >>= f = C (m >>= runC . f) + + newtype E sig r a = E (forall i . sig (E sig r) i r -> (a -> r) -> r) deriving (Functor) From b1848f5b39b2975a0d52a3c5eb9ff806f25cf221 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 18 Apr 2021 12:55:18 -0400 Subject: [PATCH 0129/1324] Wrap handler bodies in C. --- src/Facet/Eval.hs | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 8c65d9956..6066df6ff 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -185,8 +185,8 @@ runE d k (E run) = run d k newtype Empty m a b = Empty { empty :: forall e . (e -> m a) -> b } deriving (Functor) -toMaybe :: E Empty (Maybe a) a -> Maybe a -toMaybe = runE Empty{ empty = const Nothing } Just +toMaybe :: C Empty a -> Maybe a +toMaybe = runE Empty{ empty = const Nothing } Just . runC data Reader' r m a b = Reader' @@ -197,12 +197,13 @@ data Reader' r m a b = Reader' ask'' :: E (Reader' r) b r ask'' = send' ask' -reader' :: r -> E (Reader' r) (r -> a) a -> a -reader' r m = runE dict const m r +reader' :: r -> C (Reader' r) a -> a +reader' r = go r . runC where + go r m = runE dict const m r dict = Reader' - { ask' = \ k r -> reader' r (k r) - -- , local' = \ f m k r -> reader' r (k (reader' (f r) m)) + { ask' = \ k r -> go r (k r) + -- , local' = \ f m k r -> go r (k (reader' (f r) m)) } @@ -214,15 +215,16 @@ data State' s m a b = State' send' :: (forall i . sig (E sig b) i b -> (c -> E sig b i) -> b) -> E sig b c send' hdl = E $ \ d k -> hdl d (\ c -> E (\ _ _ -> k c)) -state'' :: s -> E (State' s) (s -> (s, a)) a -> (s, a) +state'' :: s -> C (State' s) a -> (s, a) state'' = state' (,) -state' :: (s -> a -> b) -> s -> E (State' s) (s -> b) a -> b -state' z s m = runE dict (flip z) m s +state' :: (s -> a -> b) -> s -> C (State' s) a -> b +state' z s = go z s . runC where + go z s m = runE dict (flip z) m s dict = State' - { get' = \ k s -> state' z s (k s) - , put' = \ s k _ -> state' z s (k ()) } + { get' = \ k s -> go z s (k s) + , put' = \ s k _ -> go z s (k ()) } modify :: (s -> s) -> E (State' s) r () modify f = put'' . f =<< get'' From 97a5330de46600b5b77bb1a894489781421e736e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 18 Apr 2021 12:55:53 -0400 Subject: [PATCH 0130/1324] Export C. --- src/Facet/Eval.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 6066df6ff..c970bc722 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -12,6 +12,7 @@ module Facet.Eval , unit -- * Quotation , quoteV +, C(..) , E(..) , runE , state' From 9c5be634a67301c2703032552225d5edb5e975ed Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 18 Apr 2021 13:01:49 -0400 Subject: [PATCH 0131/1324] Revert "Export C." This reverts commit 97a5330de46600b5b77bb1a894489781421e736e. --- src/Facet/Eval.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index c970bc722..6066df6ff 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -12,7 +12,6 @@ module Facet.Eval , unit -- * Quotation , quoteV -, C(..) , E(..) , runE , state' From ae4171b57bbf58512717f3ca36c19c9c427ee723 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 18 Apr 2021 13:01:52 -0400 Subject: [PATCH 0132/1324] Revert "Wrap handler bodies in C." This reverts commit b1848f5b39b2975a0d52a3c5eb9ff806f25cf221. --- src/Facet/Eval.hs | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 6066df6ff..8c65d9956 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -185,8 +185,8 @@ runE d k (E run) = run d k newtype Empty m a b = Empty { empty :: forall e . (e -> m a) -> b } deriving (Functor) -toMaybe :: C Empty a -> Maybe a -toMaybe = runE Empty{ empty = const Nothing } Just . runC +toMaybe :: E Empty (Maybe a) a -> Maybe a +toMaybe = runE Empty{ empty = const Nothing } Just data Reader' r m a b = Reader' @@ -197,13 +197,12 @@ data Reader' r m a b = Reader' ask'' :: E (Reader' r) b r ask'' = send' ask' -reader' :: r -> C (Reader' r) a -> a -reader' r = go r . runC +reader' :: r -> E (Reader' r) (r -> a) a -> a +reader' r m = runE dict const m r where - go r m = runE dict const m r dict = Reader' - { ask' = \ k r -> go r (k r) - -- , local' = \ f m k r -> go r (k (reader' (f r) m)) + { ask' = \ k r -> reader' r (k r) + -- , local' = \ f m k r -> reader' r (k (reader' (f r) m)) } @@ -215,16 +214,15 @@ data State' s m a b = State' send' :: (forall i . sig (E sig b) i b -> (c -> E sig b i) -> b) -> E sig b c send' hdl = E $ \ d k -> hdl d (\ c -> E (\ _ _ -> k c)) -state'' :: s -> C (State' s) a -> (s, a) +state'' :: s -> E (State' s) (s -> (s, a)) a -> (s, a) state'' = state' (,) -state' :: (s -> a -> b) -> s -> C (State' s) a -> b -state' z s = go z s . runC +state' :: (s -> a -> b) -> s -> E (State' s) (s -> b) a -> b +state' z s m = runE dict (flip z) m s where - go z s m = runE dict (flip z) m s dict = State' - { get' = \ k s -> go z s (k s) - , put' = \ s k _ -> go z s (k ()) } + { get' = \ k s -> state' z s (k s) + , put' = \ s k _ -> state' z s (k ()) } modify :: (s -> s) -> E (State' s) r () modify f = put'' . f =<< get'' From 310ae9f6ba663a1ee05e8a23afc48c5b410e86da Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 18 Apr 2021 13:01:54 -0400 Subject: [PATCH 0133/1324] Revert "Define a C monad wrapping E and quantifying over r." This reverts commit 271b6f96d37535bcb61f6e6dd2bb419e37eee27a. --- src/Facet/Eval.hs | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 8c65d9956..d8c8243d2 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -157,17 +157,6 @@ quoteV d = \case VDict os -> XDict <$> traverse (traverse (quoteV d)) os -newtype C sig a = C { runC :: forall r . E sig r a } - deriving (Functor) - -instance Applicative (C sig) where - pure a = C (pure a) - (<*>) = ap - -instance Monad (C sig) where - C m >>= f = C (m >>= runC . f) - - newtype E sig r a = E (forall i . sig (E sig r) i r -> (a -> r) -> r) deriving (Functor) From 400742108476d95b159e203327c4c6f1bbfcff33 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 18 Apr 2021 13:03:18 -0400 Subject: [PATCH 0134/1324] Allow operations to specify the eventual result type at each action. --- src/Facet/Eval.hs | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index d8c8243d2..c0285d9ea 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -157,7 +157,7 @@ quoteV d = \case VDict os -> XDict <$> traverse (traverse (quoteV d)) os -newtype E sig r a = E (forall i . sig (E sig r) i r -> (a -> r) -> r) +newtype E sig r a = E (forall i . sig (E sig) i r -> (a -> r) -> r) deriving (Functor) instance Applicative (E sig r) where @@ -167,21 +167,19 @@ instance Applicative (E sig r) where instance Monad (E sig r) where E run >>= f = E $ \ d k -> run d (runE d k . f) -runE :: sig (E sig r) i r -> (a -> r) -> E sig r a -> r +runE :: sig (E sig) i r -> (a -> r) -> E sig r a -> r runE d k (E run) = run d k -newtype Empty m a b = Empty { empty :: forall e . (e -> m a) -> b } - deriving (Functor) +newtype Empty m a b = Empty { empty :: forall e . (e -> m b a) -> b } toMaybe :: E Empty (Maybe a) a -> Maybe a toMaybe = runE Empty{ empty = const Nothing } Just data Reader' r m a b = Reader' - { ask' :: (r -> m a) -> b - , local' :: forall x . (r -> r) -> m x -> (x -> m a) -> b } - deriving (Functor) + { ask' :: (r -> m b a) -> b + , local' :: forall x . (r -> r) -> m b x -> (x -> m b a) -> b } ask'' :: E (Reader' r) b r ask'' = send' ask' @@ -196,11 +194,10 @@ reader' r m = runE dict const m r data State' s m a b = State' - { get' :: (s -> m a) -> b - , put' :: s -> (() -> m a) -> b } - deriving (Functor) + { get' :: (s -> m b a) -> b + , put' :: s -> (() -> m b a) -> b } -send' :: (forall i . sig (E sig b) i b -> (c -> E sig b i) -> b) -> E sig b c +send' :: (forall i . sig (E sig) i b -> (c -> E sig b i) -> b) -> E sig b c send' hdl = E $ \ d k -> hdl d (\ c -> E (\ _ _ -> k c)) state'' :: s -> E (State' s) (s -> (s, a)) a -> (s, a) From 760aeaead8259197e12c06ad3aeb05a3242a640e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 20 Apr 2021 08:12:00 -0400 Subject: [PATCH 0135/1324] =?UTF-8?q?Don=E2=80=99t=20run=20reader=20in=20C?= =?UTF-8?q?PS.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Eval.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index c0285d9ea..fe553cdee 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -179,17 +179,17 @@ toMaybe = runE Empty{ empty = const Nothing } Just data Reader' r m a b = Reader' { ask' :: (r -> m b a) -> b - , local' :: forall x . (r -> r) -> m b x -> (x -> m b a) -> b } + , local' :: forall x . (r -> r) -> m x x -> (x -> m b a) -> b } ask'' :: E (Reader' r) b r ask'' = send' ask' -reader' :: r -> E (Reader' r) (r -> a) a -> a -reader' r m = runE dict const m r +reader' :: r -> E (Reader' r) a a -> a +reader' r = runE dict id where dict = Reader' - { ask' = \ k r -> reader' r (k r) - -- , local' = \ f m k r -> reader' r (k (reader' (f r) m)) + { ask' = \ k -> reader' r (k r) + , local' = \ f m k -> reader' r (k (reader' (f r) m)) } From 9c83a74a1b214aac164969a2a6c1377984f68ca2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 20 Apr 2021 08:14:02 -0400 Subject: [PATCH 0136/1324] Define a smart constructor for local. --- src/Facet/Eval.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index fe553cdee..9a7a91796 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -25,6 +25,7 @@ module Facet.Eval , get'' , put'' , ask'' +, local'' , reader' ) where @@ -184,6 +185,9 @@ data Reader' r m a b = Reader' ask'' :: E (Reader' r) b r ask'' = send' ask' +local'' :: (r -> r) -> E (Reader' r) a a -> E (Reader' r) a a +local'' f m = send' (\ Reader'{ local' } -> local' f m) + reader' :: r -> E (Reader' r) a a -> a reader' r = runE dict id where From 6f9a362364ef1cbf855a195f3be4a382c4f3845b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 20 Apr 2021 08:38:52 -0400 Subject: [PATCH 0137/1324] Reformat some syntax specs. --- docs/elaboration.md | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/docs/elaboration.md b/docs/elaboration.md index b872e0799..f3d6b2397 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -8,13 +8,17 @@ Elaboration takes a syntactically valid surface program (resp. declaratio, defin The syntax is mostly unsurprising, featuring such diverse elements as contexts: ``` -Γ ::= ◊ | Γ, x : τ | Γ, X : κ +Γ ::= ◊ + | Γ, x : τ + | Γ, X : κ ``` Types: ``` -τ ::= {X : κ} -> τ | X | τ -> τ +τ ::= {X : κ} -> τ + | X + | τ -> τ ``` From 1da19413f521550183e097acb934f966ae5dd43f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 20 Apr 2021 08:47:44 -0400 Subject: [PATCH 0138/1324] :memo: the syntax. --- docs/elaboration.md | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/docs/elaboration.md b/docs/elaboration.md index f3d6b2397..fe0d96889 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -8,17 +8,17 @@ Elaboration takes a syntactically valid surface program (resp. declaratio, defin The syntax is mostly unsurprising, featuring such diverse elements as contexts: ``` -Γ ::= ◊ - | Γ, x : τ - | Γ, X : κ +Γ ::= ◊ (empty contexts) + | Γ, x : τ (term variable assumption) + | Γ, X : κ (type variable assumption) ``` Types: ``` -τ ::= {X : κ} -> τ - | X - | τ -> τ +τ ::= {X : κ} -> τ (universal quantification) + | X (type variable) + | τ -> τ (function type) ``` From 534ae0dfa50d51594c3b413636137bf149cb0c29 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 20 Apr 2021 08:52:21 -0400 Subject: [PATCH 0139/1324] Add computation types to the spec. --- docs/elaboration.md | 1 + 1 file changed, 1 insertion(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index fe0d96889..cb9c54c34 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -19,6 +19,7 @@ Types: τ ::= {X : κ} -> τ (universal quantification) | X (type variable) | τ -> τ (function type) + | [ι̅] τ (computation type) ``` From d810e9c1e938d0b813cfb1cb3d40d9b6e4be9cad Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 20 Apr 2021 08:56:04 -0400 Subject: [PATCH 0140/1324] :memo: kinds. --- docs/elaboration.md | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index cb9c54c34..31f5114b3 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -13,6 +13,14 @@ The syntax is mostly unsurprising, featuring such diverse elements as contexts: | Γ, X : κ (type variable assumption) ``` +Kinds: + +``` +κ ::= Type (the kind of types) + | Interface (the kind of interfaces) + | κ -> κ (type constructor kind) +``` + Types: ``` From 4844d1100942231bf892daed0f397ed2244cb23f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 20 Apr 2021 10:46:10 -0400 Subject: [PATCH 0141/1324] :memo: expressions. --- docs/elaboration.md | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index 31f5114b3..73d7c7408 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -30,6 +30,15 @@ Types: | [ι̅] τ (computation type) ``` +Expressions: + +``` +e ::= "…" (string) + | x (term variable) + | { ρ̅ -> e } (lambda) + | e e (application) +``` + ## Judgements From a5e2c309084692debba40c020a2a0418bb4d8c86 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 20 Apr 2021 14:09:17 -0400 Subject: [PATCH 0142/1324] :memo: patterns. --- docs/elaboration.md | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index 73d7c7408..da35665e3 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -39,6 +39,16 @@ e ::= "…" (string) | e e (application) ``` +Patterns: + +``` +ρ ::= _ (wildcard) + | x (variable) + | (c ρ̅) (constructor) + | [e ρ̅ ; k̅] (effect operation) + | [x] (catch-all) +``` + ## Judgements From 178ca5c225553d1ae75416355f65bf6a6ea0e662 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 23 Apr 2021 08:33:16 -0400 Subject: [PATCH 0143/1324] Run eval in Reader once more. --- src/Facet/Eval.hs | 44 ++++++++++++++++++++++---------------------- src/Facet/REPL.hs | 2 +- 2 files changed, 23 insertions(+), 23 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 9a7a91796..68c13fe2f 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -49,19 +49,19 @@ import Facet.Term import GHC.Stack (HasCallStack) import Prelude hiding (zipWith) -eval :: (HasCallStack, Has (Reader Graph :+: Reader Module) sig m, MonadFail m) => Env (Value (Eval m)) -> Expr -> Eval m (Value (Eval m)) -eval env = \case - XVar (Global n) -> global n >>= eval env - XVar (Free n) -> var env n - XLam cs -> lam env cs - XApp f a -> app env (eval env f) a - XCon n fs -> con n (eval env <$> fs) +eval :: (HasCallStack, Has (Reader Graph :+: Reader Module) sig m, MonadFail m) => Expr -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) +eval = \case + XVar (Global n) -> global n >>= eval + XVar (Free n) -> var n + XLam cs -> lam cs + XApp f a -> app (eval f) a + XCon n fs -> con n (eval <$> fs) XString s -> string s - XDict os -> VDict <$> traverse (traverse (eval env)) os - XLet p v b -> eval env v >>= \ v' -> eval (env |> fromMaybe (error "eval: non-exhaustive pattern in let") (matchV id p v')) b - XComp p b -> lam env [(PDict p, b)] -- FIXME: this won’t roundtrip correctly + XDict os -> VDict <$> traverse (traverse eval) os + XLet p v b -> eval v >>= \ v' -> local (|> fromMaybe (error "eval: non-exhaustive pattern in let") (matchV id p v')) (eval b) + XComp p b -> lam [(PDict p, b)] -- FIXME: this won’t roundtrip correctly -global :: Has (Reader Graph :+: Reader Module) sig m => RName -> Eval m Expr +global :: Has (Reader Graph :+: Reader Module) sig m => RName -> ReaderC (Env (Value (Eval m))) (Eval m) Expr global n = do mod <- lift ask graph <- lift ask @@ -69,23 +69,23 @@ global n = do [_ :=: DTerm (Just v) _] -> pure v -- FIXME: store values in the module graph _ -> error "throw a real error here" -var :: (HasCallStack, Applicative m) => Env (Value m) -> LName Index -> m (Value m) -var env n = pure (index env n) +var :: (HasCallStack, Algebra sig m) => LName Index -> ReaderC (Env (Value m)) m (Value m) +var n = asks (`index` n) -lam :: Env (Value (Eval m)) -> [(Pattern Name, Expr)] -> Eval m (Value (Eval m)) -lam env cs = pure $ VLam env cs +lam :: Algebra sig m => [(Pattern Name, Expr)] -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) +lam cs = asks (`VLam` cs) -app :: (HasCallStack, Has (Reader Graph :+: Reader Module) sig m, MonadFail m) => Env (Value (Eval m)) -> Eval m (Value (Eval m)) -> Expr -> Eval m (Value (Eval m)) -app envCallSite f a = f >>= \case - VLam env cs -> k a where - k = foldl' (\ vs (p, b) -> eval envCallSite >=> fromMaybe (vs a) . matchV (\ vs -> eval (env |> vs) b) p) (const (fail "non-exhaustive patterns in lambda")) cs - VCont k -> k =<< eval envCallSite a +app :: (HasCallStack, Has (Reader Graph :+: Reader Module) sig m, MonadFail m) => ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) -> Expr -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) +app f a = ask >>= \ envCallSite -> f >>= \case + VLam env cs -> lift (k a) where + k = foldl' (\ vs (p, b) -> runReader envCallSite . eval >=> fromMaybe (vs a) . matchV (\ vs -> runReader (env |> vs) (eval b)) p) (const (fail "non-exhaustive patterns in lambda")) cs + VCont k -> lift (k =<< runReader envCallSite (eval a)) _ -> fail "expected lambda/continuation" -string :: Text -> Eval m (Value (Eval m)) +string :: Text -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) string = pure . VString -con :: RName -> [Eval m (Value (Eval m))] -> Eval m (Value (Eval m)) +con :: RName -> [ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m))] -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) con n fs = VCon n <$> sequenceA fs diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index dbdd542cf..608f22ffa 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -204,7 +204,7 @@ showEval e = Action $ do outputDocLn (getPrint (ann (printExpr opts mempty e'' ::: printType opts mempty _T))) runEvalMain :: (Has (Error (Notice.Notice (Doc Style)) :+: Output :+: Reader Graph :+: Reader Module :+: State Options) sig m, MonadFail m) => Expr -> m Expr -runEvalMain e = runEval (E.quoteV 0 =<< eval mempty e) pure +runEvalMain e = runEval (E.quoteV 0 =<< runReader mempty (eval e)) pure -- where -- hdl = [(write, Handler handle)] -- write = fromList ["Effect", "Console"] :.: U "write" From 941b62663e294c12fd0a99582eac7199bcedfe91 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 23 Apr 2021 08:39:20 -0400 Subject: [PATCH 0144/1324] Add computations to Value. --- src/Facet/Eval.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 68c13fe2f..bb1789d7a 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -127,6 +127,7 @@ data Value m -- | Computation; continuations, used in effect handlers. | VCont (Value m -> m (Value m)) | VDict [RName :=: Value m] + | VComp [RName :=: Name] Expr unit :: Value m unit = VCon (NE.FromList ["Data", "Unit"] :.: U "unit") [] @@ -156,6 +157,7 @@ quoteV d = \case VCon n fs -> XCon n <$> traverse (quoteV d) fs VString s -> pure $ XString s VDict os -> XDict <$> traverse (traverse (quoteV d)) os + VComp p b -> pure $ XComp p b newtype E sig r a = E (forall i . sig (E sig) i r -> (a -> r) -> r) From d3129f34b60933cb8ecd809d0c653f7aba052e32 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 23 Apr 2021 08:40:49 -0400 Subject: [PATCH 0145/1324] Define a combinator for computations. --- src/Facet/Eval.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index bb1789d7a..0ee37cfc8 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -59,7 +59,7 @@ eval = \case XString s -> string s XDict os -> VDict <$> traverse (traverse eval) os XLet p v b -> eval v >>= \ v' -> local (|> fromMaybe (error "eval: non-exhaustive pattern in let") (matchV id p v')) (eval b) - XComp p b -> lam [(PDict p, b)] -- FIXME: this won’t roundtrip correctly + XComp p b -> comp p b global :: Has (Reader Graph :+: Reader Module) sig m => RName -> ReaderC (Env (Value (Eval m))) (Eval m) Expr global n = do @@ -88,6 +88,9 @@ string = pure . VString con :: RName -> [ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m))] -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) con n fs = VCon n <$> sequenceA fs +comp :: [RName :=: Name] -> Expr -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) +comp p b = pure $ VComp p b + -- Machinery From 8ddb4228ad90331a158b2d272d78fd902c2db31f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 23 Apr 2021 08:47:02 -0400 Subject: [PATCH 0146/1324] Define computations in Norm. --- src/Facet/Norm.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Facet/Norm.hs b/src/Facet/Norm.hs index 9c9bfb727..dd00fa02e 100644 --- a/src/Facet/Norm.hs +++ b/src/Facet/Norm.hs @@ -25,6 +25,7 @@ data Norm | NLam [(Pattern Name, Pattern (Name :=: Norm) -> Norm)] | NNe (Var (LName Level)) (Snoc Norm) | NDict [RName :=: Norm] + | NComp [RName :=: Name] (Pattern (Name :=: Norm) -> Norm) instance Eq Norm where (==) = (==) `on` quote 0 @@ -37,9 +38,12 @@ quote :: Level -> Norm -> Expr quote d = \case NString s -> XString s NCon n sp -> XCon n (quote d <$> sp) - NLam cs -> XLam (map (\ (p, b) -> let (d', p') = mapAccumL (\ d n -> (succ d, n :=: NNe (Free (LName d n)) Nil)) d p in (p, quote d' (b p'))) cs) + NLam cs -> XLam (map (uncurry clause) cs) NNe v sp -> foldl' (\ h -> XApp h . quote d) (XVar (fmap (levelToIndex d) <$> v)) sp NDict os -> XDict (map (fmap (quote d)) os) + NComp p b -> XComp p (snd (clause (PDict p) b)) + where + clause p b = let (d', p') = mapAccumL (\ d n -> (succ d, n :=: NNe (Free (LName d n)) Nil)) d p in (p, quote d' (b p')) norm :: Env Norm -> Expr -> Norm norm env = \case @@ -50,7 +54,7 @@ norm env = \case XLam cs -> NLam (map (\ (p, b) -> (p, \ p' -> norm (env |> p') b)) cs) XDict os -> NDict (map (fmap (norm env)) os) XLet p v b -> norm (env |> fromMaybe (error "norm: non-exhaustive pattern in let") (match (norm env v) p)) b - XComp p b -> NLam [(PDict p, \ p' -> norm (env |> p') b)] -- FIXME: this won’t roundtrip correctly + XComp p b -> NComp p (\ p' -> norm (env |> p') b) napp :: Norm -> Norm -> Norm From 792a5c0485695a4e4b1f46604e8f6a4f5c5c3045 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 25 Apr 2021 07:22:57 -0400 Subject: [PATCH 0147/1324] Add notes on handlers. --- docs/handlers.md | 65 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 65 insertions(+) create mode 100644 docs/handlers.md diff --git a/docs/handlers.md b/docs/handlers.md new file mode 100644 index 000000000..b5a41e788 --- /dev/null +++ b/docs/handlers.md @@ -0,0 +1,65 @@ +# Handlers + +Handlers have the general form: + + handle : C̅ -> [E̅] A -> B + +Typically, `A` will be parametric, and `B` can be viewed as a function of `A` and the context type(s) `C̅`. We will call `A` the incremental return type—that is, the return type of the action—and `B` the eventual return type—the return type of the handler itself. + + +Handlers are defined by providing a list of clauses for the constructors in `E̅` and a list of clauses for non-effect values at type `A`. The former define a dictionary for `E̅`, and the latter define a continuation with which to run the body. Ignoring for the moment any context arguments of type `C̅`, that gives us: + + { [o̅ x̅ ; k̅] -> b̅ + , a̅ -> b̅ } + +where + + o̅ : X̅ -> X′ + x̅ : X̅ + k̅ : X′ -> [E̅] A + a̅ : A + b̅ : B + +Note that since `k̅` returns in `[E̅] A`, clauses which use the continuation must call the handler recursively on the result. The sole exception is that if `B` is `[E̅] A`, they can technically call the continuation without calling the handler recursively. Note however that this would be _extremely_ strange as it would amount to handling only the first operation within an effect and allowing the remainder to be handled by the calling context. + +For example, we have the following types for the operations of `State S`, `Reader R`, and `Empty`: + +```facet +# State S +get : [State S] S +put : S -> [State S] Unit + +# Reader R +ask : [Reader R] R +local : {X : Type} -> (R -> R) -> [Reader R] X -> [Reader R] X + +# Empty +empty : {X : Type} -> [Empty] X +``` + +Note that all of these return computation types. + +Translating them into CPS yields: + +```facet +# State S +get : (S -> [State S] A) -> B +put : S -> (Unit -> [State S] A) -> B + +# Reader R +ask : (R -> [Reader R] A) -> B +local : {X : Type} -> (R -> R) -> [Reader R] X -> (X -> [Reader R] A) -> B + +# Empty +empty : {X : Type} -> [Empty] X +``` + + +Scoped operations like `local` and `catch` themselves contain `E̅`-actions. + + +Handlers must be able to: + +1. return a value of type `B` directly, without calling the continuation `k`. This implies that the type of handlers must not be universally quantified with respect to its eventual return type. + +2. return a value of type `X′` by calling the continuation `k`, thus producing a result of type `A` with effects in `E̅`, which it must therefore handle by calling itself recursively. From e65df504098385662bfdb122579717f035633af5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 25 Apr 2021 07:30:11 -0400 Subject: [PATCH 0148/1324] Explicitly quantify over the signature. --- docs/elaboration.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/elaboration.md b/docs/elaboration.md index da35665e3..b7411ee01 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -339,7 +339,7 @@ Eliminating free computations using the dictionary bound in the context: ~~> ```facet - modify : {S : Type} -> (S -> [σ] -> S) -> [State S, σ] -> Unit + modify : {σ : Interface} -> {S : Type} -> (S -> [σ] -> S) -> [State S, σ] -> Unit { f [get, put, σ] -> put (f [σ] get) } ``` From 9b2b20eb02d3b143a7cbc48cc05c0289a227e4b6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 25 Apr 2021 07:38:43 -0400 Subject: [PATCH 0149/1324] Polarize types. --- docs/elaboration.md | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index b7411ee01..4b4759c32 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -30,6 +30,21 @@ Types: | [ι̅] τ (computation type) ``` +Negative types: + +``` +N ::= P -> N (function type) + | [ι̅] P (computation type) +``` + +Positive types: + +``` +P ::= {X : κ} -> P (universal quantification) + | X (type variable) + | {N} (thunk type) +``` + Expressions: ``` From 0079024ff0ee1ae4234c1bc51d299badce1c51ed Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 25 Apr 2021 07:41:17 -0400 Subject: [PATCH 0150/1324] Add type constructor application. --- docs/elaboration.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index 4b4759c32..083747369 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -28,6 +28,7 @@ Types: | X (type variable) | τ -> τ (function type) | [ι̅] τ (computation type) + | τ τ (type constructor application) ``` Negative types: @@ -42,6 +43,7 @@ Positive types: ``` P ::= {X : κ} -> P (universal quantification) | X (type variable) + | P P (type constructor application) | {N} (thunk type) ``` From 3e351559e116d262159e5ad42893bc3ddaf2b4cc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 25 Apr 2021 07:41:40 -0400 Subject: [PATCH 0151/1324] Add thunk types. --- docs/elaboration.md | 1 + 1 file changed, 1 insertion(+) diff --git a/docs/elaboration.md b/docs/elaboration.md index 083747369..c531de1aa 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -29,6 +29,7 @@ Types: | τ -> τ (function type) | [ι̅] τ (computation type) | τ τ (type constructor application) + | {τ} (thunk type) ``` Negative types: From 4f2a736a4fb5e368094bae3975185b73e38c64d1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 25 Apr 2021 07:46:03 -0400 Subject: [PATCH 0152/1324] Add thunks & explicit quantification over signatures. --- docs/elaboration.md | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/docs/elaboration.md b/docs/elaboration.md index c531de1aa..5b0cbd97c 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -395,7 +395,7 @@ Eliminating free computations using the dictionary bound in the context: 5. `bool` ```facet - bool : { A : Type } -> (e : Unit -> A) -> (t : Unit -> A) -> Bool -> A + bool : {A : Type} -> (e : {A}) -> (t : {A}) -> Bool -> A { (true) -> t! , (false) -> e! } ``` @@ -403,7 +403,7 @@ Eliminating free computations using the dictionary bound in the context: ~~> ```facet - bool : { A : Type } -> (Unit -> [σ] -> A) -> (Unit -> [σ] -> A) -> Bool -> [σ] -> A + bool : {σ : Interface} -> {A : Type} -> {[σ] -> A} -> {[σ] -> A} -> Bool -> [σ] -> A { _ t (true) -> t! , e _ (false) -> e! } ``` @@ -411,14 +411,14 @@ Eliminating free computations using the dictionary bound in the context: 6. `if` ```facet - if : { A : Type } -> (c : Bool) -> (t : Unit -> A) -> (e : Unit -> A) -> A + if : {A : Type} -> (c : Bool) -> (t : {A}) -> (e : {A}) -> A { bool e t c } ``` ~~> ```facet - if : { A : Type } -> Bool -> (Unit -> [σ] -> A) -> (Unit -> [σ] -> A) -> [σ] -> A + if : {σ : Interface} -> {A : Type} -> Bool -> {[σ] -> A} -> {[σ] -> A} -> [σ] -> A { c t e -> bool e t c } ``` From e4c2bb917e781239895c779729db1748580763be Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 25 Apr 2021 07:49:55 -0400 Subject: [PATCH 0153/1324] Correct the guard examples to use thunks. --- docs/elaboration.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/docs/elaboration.md b/docs/elaboration.md index 5b0cbd97c..beb834e28 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -382,14 +382,14 @@ Eliminating free computations using the dictionary bound in the context: ```facet guard : (c : Bool) -> [Empty] Unit - { if c id { (unit) -> empty } } + { if c { unit } { empty } } ``` ~~> ```facet guard : Bool -> [Empty] -> Unit - { c [empty] -> if c id { (unit) -> empty } } + { c [empty] -> if c { unit } { empty } } ``` 5. `bool` From 1df7193a4e52b84b099c86a6c7d5fb07db818d49 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 25 Apr 2021 07:54:00 -0400 Subject: [PATCH 0154/1324] Extract quantifiers into neutral types. --- docs/elaboration.md | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/docs/elaboration.md b/docs/elaboration.md index beb834e28..e906a7072 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -39,11 +39,17 @@ N ::= P -> N (function type) | [ι̅] P (computation type) ``` +Neutral types: + +``` +O ::= {X : κ} -> O (universal quantification) + | P (embedding of positive type) +``` + Positive types: ``` -P ::= {X : κ} -> P (universal quantification) - | X (type variable) +P ::= X (type variable) | P P (type constructor application) | {N} (thunk type) ``` From b94cf5f42b78a918ae856eb73b1f838d38f9cfb0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 25 Apr 2021 07:55:35 -0400 Subject: [PATCH 0155/1324] Allow quantifiers in arguments. --- docs/elaboration.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/elaboration.md b/docs/elaboration.md index e906a7072..f46a0d3ad 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -35,7 +35,7 @@ Types: Negative types: ``` -N ::= P -> N (function type) +N ::= O -> N (function type) | [ι̅] P (computation type) ``` From 6f6b649bd3dc215f439d0491477c4610aa94ce00 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 25 Apr 2021 12:42:14 -0400 Subject: [PATCH 0156/1324] Revert "Allow quantifiers in arguments." This reverts commit b94cf5f42b78a918ae856eb73b1f838d38f9cfb0. --- docs/elaboration.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/elaboration.md b/docs/elaboration.md index f46a0d3ad..e906a7072 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -35,7 +35,7 @@ Types: Negative types: ``` -N ::= O -> N (function type) +N ::= P -> N (function type) | [ι̅] P (computation type) ``` From fafb0ab67700156774ce3273f077155ecfa73526 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 25 Apr 2021 12:42:18 -0400 Subject: [PATCH 0157/1324] Revert "Extract quantifiers into neutral types." This reverts commit 1df7193a4e52b84b099c86a6c7d5fb07db818d49. --- docs/elaboration.md | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/docs/elaboration.md b/docs/elaboration.md index e906a7072..beb834e28 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -39,17 +39,11 @@ N ::= P -> N (function type) | [ι̅] P (computation type) ``` -Neutral types: - -``` -O ::= {X : κ} -> O (universal quantification) - | P (embedding of positive type) -``` - Positive types: ``` -P ::= X (type variable) +P ::= {X : κ} -> P (universal quantification) + | X (type variable) | P P (type constructor application) | {N} (thunk type) ``` From 0b3c8d92f4a030963f705deda29357faa9b8c1b9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 25 Apr 2021 18:26:28 -0400 Subject: [PATCH 0158/1324] Define a class abstracting the relationship between types and classifiers. --- src/Facet/Type/Norm.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index d5e217032..62f4adf98 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -8,6 +8,7 @@ module Facet.Type.Norm , unNeutral , unComp , Classifier(..) +, Classified(..) , classifierType , occursIn -- ** Elimination @@ -81,6 +82,10 @@ data Classifier = CK Kind | CT Type +class Classified t where + classify :: t -> Classifier + classified :: Has Empty sig m => Classifier -> m t + classifierType :: Classifier -> Maybe Type classifierType = \case CK _K -> empty From b23b622000a1afa0ff35fcc6b3806fbd833328ec Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 25 Apr 2021 18:26:42 -0400 Subject: [PATCH 0159/1324] Define a Classified instance for Kind. --- src/Facet/Type/Norm.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 62f4adf98..dce34f6ab 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -86,6 +86,12 @@ class Classified t where classify :: t -> Classifier classified :: Has Empty sig m => Classifier -> m t +instance Classified Kind where + classify = CK + classified = \case + CK _K -> pure _K + _ -> empty + classifierType :: Classifier -> Maybe Type classifierType = \case CK _K -> empty From bca88477e958d9268b275c8f311f3a55e4074906 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 25 Apr 2021 18:26:47 -0400 Subject: [PATCH 0160/1324] Define a Classified instance for Type. --- src/Facet/Type/Norm.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index dce34f6ab..74d6cfc15 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -92,6 +92,12 @@ instance Classified Kind where CK _K -> pure _K _ -> empty +instance Classified Type where + classify = CT + classified = \case + CT _T -> pure _T + _ -> empty + classifierType :: Classifier -> Maybe Type classifierType = \case CK _K -> empty From 37943080a9f8d1d143d8f7e3b99e19c7ef22a2db Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 25 Apr 2021 18:29:36 -0400 Subject: [PATCH 0161/1324] Use Classified to clean up assertions. --- src/Facet/Elab.hs | 6 +++--- src/Facet/Elab/Term.hs | 7 +++---- src/Facet/Elab/Type.hs | 2 +- 3 files changed, 7 insertions(+), 8 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 66b5e519c..adf870d28 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -280,11 +280,11 @@ warn reason = do -- Patterns -assertMatch :: (HasCallStack, Has (Throw Err) sig m) => (Classifier -> Maybe out) -> String -> Classifier -> Elab m out -assertMatch pat exp _T = maybe (mismatch (Exp (Left exp)) (Act _T)) pure (pat _T) +assertMatch :: (HasCallStack, Has (Throw Err) sig m, Classified t) => (t -> Maybe out) -> String -> t -> Elab m out +assertMatch pat exp _T = maybe (mismatch (Exp (Left exp)) (Act (classify _T))) pure (pat _T) assertFunction :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Maybe Name ::: (Quantity, Type), Type) -assertFunction = assertMatch (\case{ CT (TN.Arrow n q t b) -> pure (n ::: (q, t), b) ; _ -> Nothing }) "_ -> _" . CT +assertFunction = assertMatch (\case{ TN.Arrow n q t b -> pure (n ::: (q, t), b) ; _ -> Nothing }) "_ -> _" -- Unification diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 03607bf40..de6b6d85f 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -49,7 +49,6 @@ import Control.Effect.Lens (view, views, (.=)) import Control.Effect.Throw import Control.Effect.Writer (censor) import Control.Lens (at, ix) -import Control.Monad ((<=<)) import Data.Bifunctor (first) import Data.Either (partitionEithers) import Data.Foldable @@ -362,15 +361,15 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os -- Errors assertQuantifier :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Name ::: Kind, Type -> Type) -assertQuantifier = assertMatch (\case{ CT (T.ForAll n t b) -> pure (n ::: t, b) ; _ -> Nothing }) "{_} -> _" . CT +assertQuantifier = assertMatch (\case{ T.ForAll n t b -> pure (n ::: t, b) ; _ -> Nothing }) "{_} -> _" -- | Expect a tacit (non-variable-binding) function type. assertTacitFunction :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m ((Quantity, Type), Type) -assertTacitFunction = assertMatch (\case{ CT (T.Arrow Nothing q t b) -> pure ((q, t), b) ; _ -> Nothing }) "_ -> _" . CT +assertTacitFunction = assertMatch (\case{ T.Arrow Nothing q t b -> pure ((q, t), b) ; _ -> Nothing }) "_ -> _" -- | Expect a computation type with effects. assertComp :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Signature Type, Type) -assertComp = assertMatch (unComp <=< classifierType) "[_] _" . CT +assertComp = assertMatch unComp "[_] _" -- Elaboration diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index c7034aeaa..bda034998 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -121,7 +121,7 @@ synthInterface (S.Ann s _ (S.Interface (S.Ann sh _ h) sp)) = IsType $ pushSpan s -- Assertions assertTypeConstructor :: (HasCallStack, Has (Throw Err) sig m) => Kind -> Elab m (Maybe Name ::: Kind, Kind) -assertTypeConstructor = assertMatch (\case{ CK (KArrow n t b) -> pure (n ::: t, b) ; _ -> Nothing }) "_ -> _" . CK +assertTypeConstructor = assertMatch (\case{ KArrow n t b -> pure (n ::: t, b) ; _ -> Nothing }) "_ -> _" -- Judgements From 691d6d993232a7e8d7ac3f3e2308b54a7a5029a8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Apr 2021 13:10:50 -0400 Subject: [PATCH 0162/1324] Classified defines a lens. --- src/Facet/Elab.hs | 4 ++-- src/Facet/Type/Norm.hs | 14 ++++---------- 2 files changed, 6 insertions(+), 12 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index adf870d28..25bd4eeb8 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -56,7 +56,7 @@ import Control.Carrier.State.Church import Control.Carrier.Writer.Church import Control.Effect.Choose import Control.Effect.Lens (views) -import Control.Lens (Lens', lens) +import Control.Lens (Lens', lens, review) import Control.Monad (unless, (<=<)) import Data.Foldable (for_) import Facet.Context hiding (empty) @@ -281,7 +281,7 @@ warn reason = do -- Patterns assertMatch :: (HasCallStack, Has (Throw Err) sig m, Classified t) => (t -> Maybe out) -> String -> t -> Elab m out -assertMatch pat exp _T = maybe (mismatch (Exp (Left exp)) (Act (classify _T))) pure (pat _T) +assertMatch pat exp _T = maybe (mismatch (Exp (Left exp)) (Act (review classified _T))) pure (pat _T) assertFunction :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Maybe Name ::: (Quantity, Type), Type) assertFunction = assertMatch (\case{ TN.Arrow n q t b -> pure (n ::: (q, t), b) ; _ -> Nothing }) "_ -> _" diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 74d6cfc15..c35160640 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -21,6 +21,7 @@ module Facet.Type.Norm ) where import Control.Effect.Empty +import Control.Lens (Prism', prism') import Data.Foldable (foldl') import Data.Function (on, (&)) import Data.Maybe (fromMaybe) @@ -83,20 +84,13 @@ data Classifier | CT Type class Classified t where - classify :: t -> Classifier - classified :: Has Empty sig m => Classifier -> m t + classified :: Prism' Classifier t instance Classified Kind where - classify = CK - classified = \case - CK _K -> pure _K - _ -> empty + classified = prism' CK (\case{ CK _K -> pure _K ; _ -> empty }) instance Classified Type where - classify = CT - classified = \case - CT _T -> pure _T - _ -> empty + classified = prism' CT (\case{ CT _T -> pure _T ; _ -> empty }) classifierType :: Classifier -> Maybe Type classifierType = \case From dff5eb1c380aa305593a493b2781363fa65d6b46 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Apr 2021 13:11:57 -0400 Subject: [PATCH 0163/1324] :fire: classifierType. --- src/Facet/Type/Norm.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index c35160640..6a47b28c3 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -9,7 +9,6 @@ module Facet.Type.Norm , unComp , Classifier(..) , Classified(..) -, classifierType , occursIn -- ** Elimination , ($$) @@ -92,11 +91,6 @@ instance Classified Kind where instance Classified Type where classified = prism' CT (\case{ CT _T -> pure _T ; _ -> empty }) -classifierType :: Classifier -> Maybe Type -classifierType = \case - CK _K -> empty - CT _T -> pure _T - occursIn :: Meta -> Level -> Type -> Bool occursIn p = go From 0b72397f26304e87da5d20f4cbf47c87628804f4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 4 Jun 2021 13:58:05 -0400 Subject: [PATCH 0164/1324] Define a tagged datatype for type-safe wrappers. --- src/Facet/Syntax.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 6d26d6a21..f61ec5f23 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -12,6 +12,8 @@ module Facet.Syntax -- * Assertion data , Exp(..) , Act(..) + -- * Type-safe constructors +, T(..) ) where import Data.Bifoldable @@ -107,3 +109,8 @@ newtype Exp a = Exp { getExp :: a } newtype Act a = Act { getAct :: a } deriving (Functor) + + +-- Type-safe constructors + +newtype T a b = T { getT :: a } From 5f5e6f597ef9fd9a85ecf46b460370df2a9c6d26 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 4 Jun 2021 13:58:33 -0400 Subject: [PATCH 0165/1324] Define a type-safe constructor for lambdas. --- src/Facet/Term.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Term.hs b/src/Facet/Term.hs index 690b155f7..f277c5434 100644 --- a/src/Facet/Term.hs +++ b/src/Facet/Term.hs @@ -1,8 +1,10 @@ module Facet.Term ( -- * Term expressions Expr(..) +, xlam ) where +import Data.Bifunctor (bimap) import Data.Text (Text) import Facet.Name import Facet.Pattern @@ -20,3 +22,6 @@ data Expr | XLet (Pattern Name) Expr Expr | XComp [RName :=: Name] Expr -- ^ NB: the first argument is a specialization of @'Pattern' 'Name'@ to the 'PDict' constructor deriving (Eq, Ord, Show) + +xlam :: [(T (Pattern Name) a, T Expr b)] -> T Expr (a -> b) +xlam ps = T (XLam (map (bimap getT getT) ps)) From e9e4686137f83b956b4b96d5687357539a67f5ab Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 4 Jun 2021 13:58:57 -0400 Subject: [PATCH 0166/1324] Define a type-safe constructor for applications. --- src/Facet/Term.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Term.hs b/src/Facet/Term.hs index f277c5434..eb5dff965 100644 --- a/src/Facet/Term.hs +++ b/src/Facet/Term.hs @@ -2,6 +2,7 @@ module Facet.Term ( -- * Term expressions Expr(..) , xlam +, xapp ) where import Data.Bifunctor (bimap) @@ -25,3 +26,8 @@ data Expr xlam :: [(T (Pattern Name) a, T Expr b)] -> T Expr (a -> b) xlam ps = T (XLam (map (bimap getT getT) ps)) + +xapp :: T Expr (a -> b) -> T Expr a -> T Expr b +xapp (T f) (T a) = T (f `XApp` a) + +infixl 9 `xapp` From fd1970440bff56e7ccb1078aed397d0aef05d88d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 4 Jun 2021 13:59:34 -0400 Subject: [PATCH 0167/1324] Define a type-safe constructor for strings. --- src/Facet/Term.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Term.hs b/src/Facet/Term.hs index eb5dff965..5dff8f2a6 100644 --- a/src/Facet/Term.hs +++ b/src/Facet/Term.hs @@ -3,6 +3,7 @@ module Facet.Term Expr(..) , xlam , xapp +, xstring ) where import Data.Bifunctor (bimap) @@ -31,3 +32,6 @@ xapp :: T Expr (a -> b) -> T Expr a -> T Expr b xapp (T f) (T a) = T (f `XApp` a) infixl 9 `xapp` + +xstring :: Text -> T Expr Text +xstring = T . XString From 6650fc1955fa6874cf878a681994b0a47458156b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 4 Jun 2021 14:12:16 -0400 Subject: [PATCH 0168/1324] Define a type-safe constructor for constructors, along with tupling. --- src/Facet/Term.hs | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/src/Facet/Term.hs b/src/Facet/Term.hs index 5dff8f2a6..d19fe37f9 100644 --- a/src/Facet/Term.hs +++ b/src/Facet/Term.hs @@ -1,9 +1,13 @@ +{-# LANGUAGE GADTs #-} module Facet.Term ( -- * Term expressions Expr(..) , xlam , xapp +, xcon , xstring +, Tuple(..) +, foldTuple ) where import Data.Bifunctor (bimap) @@ -33,5 +37,18 @@ xapp (T f) (T a) = T (f `XApp` a) infixl 9 `xapp` +xcon :: RName -> Tuple (T Expr) ts -> T Expr ts +xcon n b = T (XCon n (foldTuple (pure . getT) b)) + xstring :: Text -> T Expr Text xstring = T . XString + + +data Tuple f ts where + None :: Tuple f () + (:<) :: f t -> Tuple f ts -> Tuple f (t, ts) + +foldTuple :: Monoid m => (forall t . f t -> m) -> Tuple f ts -> m +foldTuple alg = \case + None -> mempty + t :< ts -> alg t <> foldTuple alg ts From 386fbd8b00e2665bff9e6f75f8c28b394579bea3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 4 Jun 2021 14:13:07 -0400 Subject: [PATCH 0169/1324] Replace the Tuple GADT with a Fields class. --- src/Facet/Term.hs | 21 +++++++++------------ 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/src/Facet/Term.hs b/src/Facet/Term.hs index d19fe37f9..66252e76b 100644 --- a/src/Facet/Term.hs +++ b/src/Facet/Term.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GADTs #-} module Facet.Term ( -- * Term expressions Expr(..) @@ -6,8 +5,6 @@ module Facet.Term , xapp , xcon , xstring -, Tuple(..) -, foldTuple ) where import Data.Bifunctor (bimap) @@ -37,18 +34,18 @@ xapp (T f) (T a) = T (f `XApp` a) infixl 9 `xapp` -xcon :: RName -> Tuple (T Expr) ts -> T Expr ts -xcon n b = T (XCon n (foldTuple (pure . getT) b)) +xcon :: Fields (T Expr) fs => RName -> fs -> T Expr fs +xcon n b = T (XCon n (foldFields (pure . getT) b)) xstring :: Text -> T Expr Text xstring = T . XString -data Tuple f ts where - None :: Tuple f () - (:<) :: f t -> Tuple f ts -> Tuple f (t, ts) +class Fields f fs where + foldFields :: Monoid m => (forall t . f t -> m) -> fs -> m -foldTuple :: Monoid m => (forall t . f t -> m) -> Tuple f ts -> m -foldTuple alg = \case - None -> mempty - t :< ts -> alg t <> foldTuple alg ts +instance Fields f () where + foldFields _ _ = mempty + +instance Fields f fs => Fields f (f t, fs) where + foldFields alg = mappend . alg . fst <*> foldFields alg . snd From c68377d114940c8255a00e39c30f8fe59ab93586 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 4 Jun 2021 14:13:52 -0400 Subject: [PATCH 0170/1324] Export Fields. --- src/Facet/Term.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Term.hs b/src/Facet/Term.hs index 66252e76b..c012c1d3e 100644 --- a/src/Facet/Term.hs +++ b/src/Facet/Term.hs @@ -5,6 +5,7 @@ module Facet.Term , xapp , xcon , xstring +, Fields(..) ) where import Data.Bifunctor (bimap) From f78780d61826ed92882627bfa106b4842e2b5b92 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 4 Jun 2021 14:15:18 -0400 Subject: [PATCH 0171/1324] Define a type-safe constructor for variables. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is a bit of a joke tbh because it’s not even remotely type-safe since it just assumes the type. --- src/Facet/Term.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Term.hs b/src/Facet/Term.hs index c012c1d3e..ee1743238 100644 --- a/src/Facet/Term.hs +++ b/src/Facet/Term.hs @@ -1,6 +1,7 @@ module Facet.Term ( -- * Term expressions Expr(..) +, xvar , xlam , xapp , xcon @@ -27,6 +28,9 @@ data Expr | XComp [RName :=: Name] Expr -- ^ NB: the first argument is a specialization of @'Pattern' 'Name'@ to the 'PDict' constructor deriving (Eq, Ord, Show) +xvar :: Var (LName Index) -> T Expr a +xvar = T . XVar + xlam :: [(T (Pattern Name) a, T Expr b)] -> T Expr (a -> b) xlam ps = T (XLam (map (bimap getT getT) ps)) From b8145bec8bfb058fb6e04dcf9d9fd9978040f343 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 4 Jun 2021 14:15:50 -0400 Subject: [PATCH 0172/1324] Redefine xvar to take a type-annotated variable. --- src/Facet/Term.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Term.hs b/src/Facet/Term.hs index ee1743238..bfd4e501b 100644 --- a/src/Facet/Term.hs +++ b/src/Facet/Term.hs @@ -28,8 +28,8 @@ data Expr | XComp [RName :=: Name] Expr -- ^ NB: the first argument is a specialization of @'Pattern' 'Name'@ to the 'PDict' constructor deriving (Eq, Ord, Show) -xvar :: Var (LName Index) -> T Expr a -xvar = T . XVar +xvar :: T (Var (LName Index)) a -> T Expr a +xvar = T . XVar . getT xlam :: [(T (Pattern Name) a, T Expr b)] -> T Expr (a -> b) xlam ps = T (XLam (map (bimap getT getT) ps)) From 3e3e36966bd3a7da38802f8844eb4ab8f7c28bf1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 4 Jun 2021 17:03:49 -0400 Subject: [PATCH 0173/1324] Define a type-safe constructor for let bindings. --- src/Facet/Term.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Term.hs b/src/Facet/Term.hs index bfd4e501b..d0f4ec56f 100644 --- a/src/Facet/Term.hs +++ b/src/Facet/Term.hs @@ -6,6 +6,7 @@ module Facet.Term , xapp , xcon , xstring +, xlet , Fields(..) ) where @@ -45,6 +46,9 @@ xcon n b = T (XCon n (foldFields (pure . getT) b)) xstring :: Text -> T Expr Text xstring = T . XString +xlet :: T (Pattern Name) t -> T Expr t -> T Expr u -> T Expr u +xlet (T p) (T v) (T b) = T (XLet p v b) + class Fields f fs where foldFields :: Monoid m => (forall t . f t -> m) -> fs -> m From cc41ccd4c6dbff0d4439761c8838f7269995af73 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 4 Jun 2021 17:58:03 -0400 Subject: [PATCH 0174/1324] Abstract the type-safe constructors behind a class. --- src/Facet/Term.hs | 41 ++++++++++++++++++++++------------------- 1 file changed, 22 insertions(+), 19 deletions(-) diff --git a/src/Facet/Term.hs b/src/Facet/Term.hs index d0f4ec56f..ffa72177f 100644 --- a/src/Facet/Term.hs +++ b/src/Facet/Term.hs @@ -1,12 +1,7 @@ module Facet.Term ( -- * Term expressions Expr(..) -, xvar -, xlam -, xapp -, xcon -, xstring -, xlet +, ExprI(..) , Fields(..) ) where @@ -29,25 +24,33 @@ data Expr | XComp [RName :=: Name] Expr -- ^ NB: the first argument is a specialization of @'Pattern' 'Name'@ to the 'PDict' constructor deriving (Eq, Ord, Show) -xvar :: T (Var (LName Index)) a -> T Expr a -xvar = T . XVar . getT +class ExprI expr where + xvar :: T (Var (LName Index)) a -> expr a -xlam :: [(T (Pattern Name) a, T Expr b)] -> T Expr (a -> b) -xlam ps = T (XLam (map (bimap getT getT) ps)) + xlam :: [(T (Pattern Name) a, expr b)] -> expr (a -> b) -xapp :: T Expr (a -> b) -> T Expr a -> T Expr b -xapp (T f) (T a) = T (f `XApp` a) + xapp :: expr (a -> b) -> expr a -> expr b -infixl 9 `xapp` + infixl 9 `xapp` -xcon :: Fields (T Expr) fs => RName -> fs -> T Expr fs -xcon n b = T (XCon n (foldFields (pure . getT) b)) + xcon :: Fields expr fs => RName -> fs -> expr fs -xstring :: Text -> T Expr Text -xstring = T . XString + xstring :: Text -> expr Text -xlet :: T (Pattern Name) t -> T Expr t -> T Expr u -> T Expr u -xlet (T p) (T v) (T b) = T (XLet p v b) + xlet :: T (Pattern Name) t -> expr t -> expr u -> expr u + +instance ExprI (T Expr) where + xvar = T . XVar . getT + + xlam ps = T (XLam (map (bimap getT getT) ps)) + + xapp (T f) (T a) = T (f `XApp` a) + + xcon n b = T (XCon n (foldFields (pure . getT) b)) + + xstring = T . XString + + xlet (T p) (T v) (T b) = T (XLet p v b) class Fields f fs where From 99a88ef8ca46c53aba35e0bf0f9707c491d8721c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 4 Jun 2021 18:01:03 -0400 Subject: [PATCH 0175/1324] Rename ExprI to TExpr. --- src/Facet/Term.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Term.hs b/src/Facet/Term.hs index ffa72177f..cbb0543fe 100644 --- a/src/Facet/Term.hs +++ b/src/Facet/Term.hs @@ -1,7 +1,7 @@ module Facet.Term ( -- * Term expressions Expr(..) -, ExprI(..) +, TExpr(..) , Fields(..) ) where @@ -24,7 +24,7 @@ data Expr | XComp [RName :=: Name] Expr -- ^ NB: the first argument is a specialization of @'Pattern' 'Name'@ to the 'PDict' constructor deriving (Eq, Ord, Show) -class ExprI expr where +class TExpr expr where xvar :: T (Var (LName Index)) a -> expr a xlam :: [(T (Pattern Name) a, expr b)] -> expr (a -> b) @@ -39,7 +39,7 @@ class ExprI expr where xlet :: T (Pattern Name) t -> expr t -> expr u -> expr u -instance ExprI (T Expr) where +instance TExpr (T Expr) where xvar = T . XVar . getT xlam ps = T (XLam (map (bimap getT getT) ps)) From d8ae53f0ec749bcabe451c70218d913260b3106f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 4 Jun 2021 18:01:45 -0400 Subject: [PATCH 0176/1324] Define a Type module. --- facet.cabal | 1 + src/Facet/Type.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Type.hs diff --git a/facet.cabal b/facet.cabal index 577cd4afd..65ececd48 100644 --- a/facet.cabal +++ b/facet.cabal @@ -120,6 +120,7 @@ library Facet.Syntax Facet.Term Facet.Timing + Facet.Type Facet.Type.Expr Facet.Type.Norm Facet.Unify diff --git a/src/Facet/Type.hs b/src/Facet/Type.hs new file mode 100644 index 000000000..1ced4e0ce --- /dev/null +++ b/src/Facet/Type.hs @@ -0,0 +1,2 @@ +module Facet.Type +() where From 44fb908be1dbcddf489ef1192020f78552789850 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 5 Jun 2021 13:17:57 -0400 Subject: [PATCH 0177/1324] Generalize the kind of T. --- src/Facet/Syntax.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index f61ec5f23..783fcc090 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} module Facet.Syntax ( (:::)(..) , tm @@ -20,6 +22,7 @@ import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable import Data.Functor.Classes +import Data.Kind (Type) import Facet.Name import Facet.Snoc @@ -113,4 +116,6 @@ newtype Act a = Act { getAct :: a } -- Type-safe constructors +type T :: Type -> forall k . k -> Type + newtype T a b = T { getT :: a } From 334b6435920a23368356f62ed83323aadf423de6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 5 Jun 2021 14:04:54 -0400 Subject: [PATCH 0178/1324] Define a type-safe API for constructing types. --- src/Facet/Type.hs | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/src/Facet/Type.hs b/src/Facet/Type.hs index 1ced4e0ce..bdf6b2151 100644 --- a/src/Facet/Type.hs +++ b/src/Facet/Type.hs @@ -1,2 +1,22 @@ +{-# LANGUAGE PolyKinds #-} module Facet.Type -() where +( TType(..) +) where + +import Data.Kind (Type) +import Data.Text (Text) +import Data.Void (Void) +import Facet.Interface (Interface, Signature) +import Facet.Kind (Kind) +import Facet.Name (Name) +import Facet.Syntax (T) +import Facet.Usage (Quantity) + +type Not a = a -> Void + +class TType (ty :: forall k . k -> Type) where + string :: ty Text + forAll :: Name -> T Kind a -> (ty a -> ty b) -> ty (a -> b) + arrow :: Maybe Name -> Quantity -> ty a -> ty b -> ty (a -> b) + comp :: Signature (ty (Interface Void)) -> ty a -> ty (Interface Void -> Not (Not a)) + app :: ty (f :: j -> k) -> ty (a :: j) -> ty k From 42ccd18ae5b2003dc64554d96cc84ff733dd5ca7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 5 Jun 2021 14:05:04 -0400 Subject: [PATCH 0179/1324] Define a TType instance for Type.Expr. --- src/Facet/Type/Expr.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Facet/Type/Expr.hs b/src/Facet/Type/Expr.hs index 61d70fe51..3151cc902 100644 --- a/src/Facet/Type/Expr.hs +++ b/src/Facet/Type/Expr.hs @@ -6,6 +6,7 @@ import Facet.Interface import Facet.Kind import Facet.Name import Facet.Syntax +import Facet.Type import Facet.Usage data Type @@ -16,3 +17,11 @@ data Type | Comp (Signature Type) Type | App Type Type deriving (Eq, Ord, Show) + +-- FIXME: this should be Level -> Type +instance TType (T Type) where + string = T String + forAll n (T k) b = T (ForAll n k (getT (b (T (Var (Free (Right (LName (Index 0) n)))))))) + arrow n q (T a) (T b) = T (Arrow n q a b) + comp sig (T b) = T (Comp (mapSignature getT sig) b) + app (T f) (T a) = T (App f a) From 6b87b68c9a52cb25fe13dbe97c7030bb19b40793 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 5 Jun 2021 14:05:12 -0400 Subject: [PATCH 0180/1324] Define a TType instance for Type.Norm. --- src/Facet/Type/Norm.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 6a47b28c3..68f9fb898 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -32,6 +32,7 @@ import Facet.Pattern import Facet.Snoc import Facet.Subst import Facet.Syntax +import Facet.Type import qualified Facet.Type.Expr as TX import Facet.Usage hiding (singleton) import GHC.Stack @@ -52,6 +53,13 @@ instance Eq Type where instance Ord Type where compare = compare `on` quote 0 +instance TType (T Type) where + string = T String + forAll n (T k) b = T (ForAll n k (getT . b . T)) + arrow n q (T a) (T b) = T (Arrow n q a b) + comp sig (T b) = T (Comp (mapSignature getT sig) b) + app (T a) (T b) = T (a $$ b) + global :: RName -> Type global = var . Global From 3a6cbff306c05a435f38df48424e30bf9aef94af Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 5 Jun 2021 14:19:49 -0400 Subject: [PATCH 0181/1324] Construct correct indices using the type-safe API. --- src/Facet/Type/Expr.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Facet/Type/Expr.hs b/src/Facet/Type/Expr.hs index 3151cc902..507da0b00 100644 --- a/src/Facet/Type/Expr.hs +++ b/src/Facet/Type/Expr.hs @@ -19,9 +19,9 @@ data Type deriving (Eq, Ord, Show) -- FIXME: this should be Level -> Type -instance TType (T Type) where - string = T String - forAll n (T k) b = T (ForAll n k (getT (b (T (Var (Free (Right (LName (Index 0) n)))))))) - arrow n q (T a) (T b) = T (Arrow n q a b) - comp sig (T b) = T (Comp (mapSignature getT sig) b) - app (T f) (T a) = T (App f a) +instance TType (T (Level -> Type)) where + string = T (const String) + forAll n (T k) b = T (\ d -> ForAll n k (getT (b (T (\ d' -> Var (Free (Right (LName (levelToIndex d d') n)))))) d)) + arrow n q (T a) (T b) = T (\ d -> Arrow n q (a d) (b d)) + comp sig (T b) = T (\ d -> Comp (mapSignature (\ (T i) -> i d) sig) (b d)) + app (T f) (T a) = T (\ d -> App (f d) (a d)) From 924d355d276f2456478487ec469f23c2216a915f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 5 Jun 2021 14:20:03 -0400 Subject: [PATCH 0182/1324] Define a convenience to traverse a signature. --- src/Facet/Interface.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Interface.hs b/src/Facet/Interface.hs index 3beeee297..aea559fe5 100644 --- a/src/Facet/Interface.hs +++ b/src/Facet/Interface.hs @@ -5,6 +5,7 @@ module Facet.Interface , singleton , interfaces , mapSignature +, traverseSignature ) where import qualified Data.Set as Set @@ -28,3 +29,6 @@ interfaces = Set.toList . getSignature mapSignature :: Ord b => (a -> b) -> Signature a -> Signature b mapSignature f = Signature . Set.map (fmap f) . getSignature + +traverseSignature :: (Ord b, Applicative f) => (a -> f b) -> Signature a -> f (Signature b) +traverseSignature f (Signature m) = Signature . Set.fromList <$> traverse (traverse f) (Set.toList m) From 0b1c904bb746b1da193c5d07cdcbd47b50efcead Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 5 Jun 2021 17:01:50 -0400 Subject: [PATCH 0183/1324] Represent computation types with an abstract type Comp. --- src/Facet/Type.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Type.hs b/src/Facet/Type.hs index bdf6b2151..35d4196e3 100644 --- a/src/Facet/Type.hs +++ b/src/Facet/Type.hs @@ -12,11 +12,11 @@ import Facet.Name (Name) import Facet.Syntax (T) import Facet.Usage (Quantity) -type Not a = a -> Void +data Comp a class TType (ty :: forall k . k -> Type) where string :: ty Text forAll :: Name -> T Kind a -> (ty a -> ty b) -> ty (a -> b) arrow :: Maybe Name -> Quantity -> ty a -> ty b -> ty (a -> b) - comp :: Signature (ty (Interface Void)) -> ty a -> ty (Interface Void -> Not (Not a)) + comp :: Signature (ty (Interface Void)) -> ty a -> ty (Comp a) app :: ty (f :: j -> k) -> ty (a :: j) -> ty k From 471305df0304ab27b46c25b7d7fac106dc882160 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 5 Jun 2021 17:01:57 -0400 Subject: [PATCH 0184/1324] Export Comp. --- src/Facet/Type.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Type.hs b/src/Facet/Type.hs index 35d4196e3..f48e82acd 100644 --- a/src/Facet/Type.hs +++ b/src/Facet/Type.hs @@ -1,6 +1,7 @@ {-# LANGUAGE PolyKinds #-} module Facet.Type ( TType(..) +, Comp ) where import Data.Kind (Type) From 110bfb6ede1dddb841274231ca225ccec54537e2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 7 Jun 2021 13:16:18 -0400 Subject: [PATCH 0185/1324] Try bumping the ghc version. --- .github/workflows/ci.yml | 2 +- facet.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 8032068f9..ec3a046d8 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -14,7 +14,7 @@ jobs: runs-on: ubuntu-latest strategy: matrix: - ghc: ["8.10.3"] + ghc: ["8.10.4"] cabal: ["3.2.0.0"] steps: diff --git a/facet.cabal b/facet.cabal index 65ececd48..d65f88450 100644 --- a/facet.cabal +++ b/facet.cabal @@ -14,7 +14,7 @@ copyright: 2020 Rob Rix category: Language tested-with: - GHC == 8.10.3 + GHC == 8.10.4 common common default-language: Haskell2010 From fe8186dfd043c089052f6f00ba13e448d67b1adb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 07:13:37 -0400 Subject: [PATCH 0186/1324] Define a polarized module. --- facet.cabal | 1 + src/Facet/Polarized.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Polarized.hs diff --git a/facet.cabal b/facet.cabal index d65f88450..702d7df40 100644 --- a/facet.cabal +++ b/facet.cabal @@ -103,6 +103,7 @@ library Facet.Parser Facet.Parser.Table Facet.Pattern + Facet.Polarized Facet.Pretty Facet.Print Facet.REPL diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs new file mode 100644 index 000000000..8c72b0e21 --- /dev/null +++ b/src/Facet/Polarized.hs @@ -0,0 +1,2 @@ +module Facet.Polarized +() where From 20c21ef94e89f80f6c23865213a245e5bb029e40 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 07:14:09 -0400 Subject: [PATCH 0187/1324] Define negative and positive types. --- src/Facet/Polarized.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 8c72b0e21..ac6282cf5 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -1,2 +1,7 @@ module Facet.Polarized -() where +( NType +, PType +) where + +data NType +data PType From e0dbdf11a79455ac29b944fa37ab87853a73e278 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 07:14:39 -0400 Subject: [PATCH 0188/1324] Define shifts. --- src/Facet/Polarized.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index ac6282cf5..1cc2005ba 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -1,7 +1,10 @@ module Facet.Polarized -( NType -, PType +( NType(..) +, PType(..) ) where -data NType -data PType +newtype NType + = Up PType + +newtype PType + = Down NType From 84e1208f1d1d0614ccfb35bfaa0127cd98b82756 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 07:18:43 -0400 Subject: [PATCH 0189/1324] Define function types. --- src/Facet/Polarized.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 1cc2005ba..376a08598 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -3,8 +3,11 @@ module Facet.Polarized , PType(..) ) where -newtype NType +data NType = Up PType + | PType :-> NType + +infixr 2 :-> newtype PType = Down NType From 1428cc9c5db9f347455866ca02b939eca2d2e481 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 07:20:21 -0400 Subject: [PATCH 0190/1324] Define kinds. --- src/Facet/Polarized.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 376a08598..eee9faed3 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -1,8 +1,12 @@ module Facet.Polarized -( NType(..) +( Kind(..) +, NType(..) , PType(..) ) where +data Kind + = Type + data NType = Up PType | PType :-> NType From da345e6fc8e9788853b781d64c83dbd5b6a9e38f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 08:36:54 -0400 Subject: [PATCH 0191/1324] Define kind arrows. --- src/Facet/Polarized.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index eee9faed3..45880e71a 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -6,6 +6,9 @@ module Facet.Polarized data Kind = Type + | Kind :=> Kind + +infixr 2 :=> data NType = Up PType From 558080465b09914a434f75afa3df0c377abe3c4d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 08:39:43 -0400 Subject: [PATCH 0192/1324] Define universal quantification. --- src/Facet/Polarized.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 45880e71a..58ab19c84 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -13,6 +13,7 @@ infixr 2 :=> data NType = Up PType | PType :-> NType + | ForAll Kind (Either NType PType -> NType) infixr 2 :-> From 48598d5c2039fef6e303a5b7187ab77196e6751b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 08:40:34 -0400 Subject: [PATCH 0193/1324] Distinguish between negative and positive types at the kind level. --- src/Facet/Polarized.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 58ab19c84..0be852cf3 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -5,7 +5,8 @@ module Facet.Polarized ) where data Kind - = Type + = NType + | PType | Kind :=> Kind infixr 2 :=> From 14d4923caeba657acca8abe46a13a1d85584fe7a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 08:41:04 -0400 Subject: [PATCH 0194/1324] Define Kind using GADT syntax. --- src/Facet/Polarized.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 0be852cf3..186e8e105 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -1,13 +1,14 @@ +{-# LANGUAGE GADTs #-} module Facet.Polarized ( Kind(..) , NType(..) , PType(..) ) where -data Kind - = NType - | PType - | Kind :=> Kind +data Kind where + NType :: Kind + PType :: Kind + (:=>) :: Kind -> Kind -> Kind infixr 2 :=> From dc944bc3ae17d3e97eb07a3f00857f9c99075239 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 08:44:42 -0400 Subject: [PATCH 0195/1324] Index kinds by the types inhabiting them. --- src/Facet/Polarized.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 186e8e105..fd2f9dd55 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -5,17 +5,17 @@ module Facet.Polarized , PType(..) ) where -data Kind where - NType :: Kind - PType :: Kind - (:=>) :: Kind -> Kind -> Kind +data Kind t where + NType :: Kind NType + PType :: Kind PType + (:=>) :: Kind t1 -> Kind t2 -> Kind (t1 -> t2) infixr 2 :=> data NType = Up PType | PType :-> NType - | ForAll Kind (Either NType PType -> NType) + | forall t . ForAll (Kind t) (t -> NType) infixr 2 :-> From 9aadc937f43aa93e8cc92a05d1a5ea3b0f4ca69f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 09:11:26 -0400 Subject: [PATCH 0196/1324] Add cofunctions. --- src/Facet/Polarized.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index fd2f9dd55..ccd2c9032 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -19,5 +19,6 @@ data NType infixr 2 :-> -newtype PType +data PType = Down NType + | NType :>- PType From b06df871c114810bf9ccf8bf29b45d96062b7e05 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 09:23:38 -0400 Subject: [PATCH 0197/1324] Fixity & precedence. --- src/Facet/Polarized.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index ccd2c9032..9ca7711ba 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -22,3 +22,5 @@ infixr 2 :-> data PType = Down NType | NType :>- PType + +infixl 2 :>- From 0dbdffd5ecf805e9337bf7713083dfd6ae386cfe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 09:24:11 -0400 Subject: [PATCH 0198/1324] Strict products. --- src/Facet/Polarized.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 9ca7711ba..4cb4d4b30 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -21,6 +21,8 @@ infixr 2 :-> data PType = Down NType + | PType :>< PType | NType :>- PType +infixr 7 :>< infixl 2 :>- From b50b9eb5d51626cbbd27844af529ec9d14b28ad2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 09:41:47 -0400 Subject: [PATCH 0199/1324] Add variables. --- src/Facet/Polarized.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 4cb4d4b30..c7eedb94f 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -14,6 +14,7 @@ infixr 2 :=> data NType = Up PType + | NVar String | PType :-> NType | forall t . ForAll (Kind t) (t -> NType) @@ -21,6 +22,7 @@ infixr 2 :-> data PType = Down NType + | PVar String | PType :>< PType | NType :>- PType From 04ad9d5d1b5ea093d57580fd70d037323d641a3f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 09:48:04 -0400 Subject: [PATCH 0200/1324] Add values. --- src/Facet/Polarized.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index c7eedb94f..e59058975 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -3,6 +3,8 @@ module Facet.Polarized ( Kind(..) , NType(..) , PType(..) +, NVal(..) +, PVal(..) ) where data Kind t where @@ -15,6 +17,7 @@ infixr 2 :=> data NType = Up PType | NVar String + | Bot | PType :-> NType | forall t . ForAll (Kind t) (t -> NType) @@ -23,8 +26,16 @@ infixr 2 :-> data PType = Down NType | PVar String + | One | PType :>< PType | NType :>- PType infixr 7 :>< infixl 2 :>- + + +data NVal t where + Lam :: (PVal a -> NVal b) -> NVal (a -> b) + +data PVal t where + Unit :: PVal () From 7fcb51e7807240bc6c749cd1fe83d6961103be5f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 09:48:50 -0400 Subject: [PATCH 0201/1324] Add pairs. --- src/Facet/Polarized.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index e59058975..5c261de05 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -39,3 +39,4 @@ data NVal t where data PVal t where Unit :: PVal () + Pair :: PVal a -> PVal b -> PVal (a, b) From 9788e143c0a1feffbcf12a74914b69b72f432804 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 10:38:43 -0400 Subject: [PATCH 0202/1324] Define an elaborator. --- src/Facet/Polarized.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 5c261de05..510669724 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -5,6 +5,7 @@ module Facet.Polarized , PType(..) , NVal(..) , PVal(..) +, Elab(..) ) where data Kind t where @@ -40,3 +41,6 @@ data NVal t where data PVal t where Unit :: PVal () Pair :: PVal a -> PVal b -> PVal (a, b) + + +newtype Elab a = Elab { elab :: Maybe a } From 90b27fb1c200a4d8e7d69adce5baacb58ad826bf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 10:39:23 -0400 Subject: [PATCH 0203/1324] Add contexts. --- src/Facet/Polarized.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 510669724..055eb07fc 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -43,4 +43,4 @@ data PVal t where Pair :: PVal a -> PVal b -> PVal (a, b) -newtype Elab a = Elab { elab :: Maybe a } +newtype Elab a = Elab { elab :: [PType] -> [NType] -> Maybe a } From 0962c6264566879fe90a8a871eb1cc856b496581 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 10:39:55 -0400 Subject: [PATCH 0204/1324] Index the contexts by name. --- src/Facet/Polarized.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 055eb07fc..a2a744025 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -43,4 +43,4 @@ data PVal t where Pair :: PVal a -> PVal b -> PVal (a, b) -newtype Elab a = Elab { elab :: [PType] -> [NType] -> Maybe a } +newtype Elab a = Elab { elab :: [(String, PType)] -> [(String, NType)] -> Maybe a } From 15d80a8553d1c4c82d9d658f2e6f473052e49253 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 10:42:05 -0400 Subject: [PATCH 0205/1324] Derive some instances. --- src/Facet/Polarized.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index a2a744025..f47e8a673 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -8,6 +8,7 @@ module Facet.Polarized , Elab(..) ) where +import Control.Carrier.Reader data Kind t where NType :: Kind NType PType :: Kind PType @@ -44,3 +45,5 @@ data PVal t where newtype Elab a = Elab { elab :: [(String, PType)] -> [(String, NType)] -> Maybe a } + deriving (Functor) + deriving (Applicative) via ReaderC [(String, PType)] (ReaderC [(String, NType)] Maybe) From 99885157071a8f6d3f3dfa2bb266945b2dc9b9be Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 10:48:23 -0400 Subject: [PATCH 0206/1324] =?UTF-8?q?Don=E2=80=99t=20type=20index=20the=20?= =?UTF-8?q?terms.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Polarized.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index f47e8a673..cd8ae34df 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -36,12 +36,14 @@ infixr 7 :>< infixl 2 :>- -data NVal t where - Lam :: (PVal a -> NVal b) -> NVal (a -> b) - -data PVal t where - Unit :: PVal () - Pair :: PVal a -> PVal b -> PVal (a, b) +data NVal + = Lam (PVal -> NVal) + | Ret PVal + +data PVal + = Unit + | Pair PVal PVal + | Thunk NVal newtype Elab a = Elab { elab :: [(String, PType)] -> [(String, NType)] -> Maybe a } From 54c156eac8ccc865ba417d7452f747d3c4f5db1b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 10:53:30 -0400 Subject: [PATCH 0207/1324] Define a first-order representation of types. --- src/Facet/Polarized.hs | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index cd8ae34df..3dc3c9a65 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -3,6 +3,8 @@ module Facet.Polarized ( Kind(..) , NType(..) , PType(..) +, XNType(..) +, XPType(..) , NVal(..) , PVal(..) , Elab(..) @@ -36,6 +38,27 @@ infixr 7 :>< infixl 2 :>- +data XNType + = XUp XPType + | XNVar String + | XBot + | XPType :->: XNType + deriving (Eq, Ord, Show) + +infixr 2 :->: + +data XPType + = XDown XNType + | XPVar String + | XOne + | XPType :><: XPType + | XNType :>-: XPType + deriving (Eq, Ord, Show) + +infixr 7 :><: +infixl 2 :>-: + + data NVal = Lam (PVal -> NVal) | Ret PVal From 3cd0ce6c6dbda56d7715e880ba8a68b27b2ba76e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 10:56:04 -0400 Subject: [PATCH 0208/1324] =?UTF-8?q?Don=E2=80=99t=20split=20up=20the=20re?= =?UTF-8?q?presentations.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Polarized.hs | 73 +++++++++++++++++++----------------------- 1 file changed, 33 insertions(+), 40 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 3dc3c9a65..3d1935d38 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -1,74 +1,67 @@ {-# LANGUAGE GADTs #-} module Facet.Polarized ( Kind(..) -, NType(..) -, PType(..) -, XNType(..) -, XPType(..) -, NVal(..) -, PVal(..) +, Type(..) +, XType(..) +, Val(..) , Elab(..) ) where import Control.Carrier.Reader data Kind t where - NType :: Kind NType - PType :: Kind PType + Type :: Kind Type (:=>) :: Kind t1 -> Kind t2 -> Kind (t1 -> t2) infixr 2 :=> -data NType - = Up PType +data Type + -- negative + = Up Type | NVar String | Bot - | PType :-> NType - | forall t . ForAll (Kind t) (t -> NType) - -infixr 2 :-> - -data PType - = Down NType + | Type :-> Type + | forall t . ForAll (Kind t) (t -> Type) + -- positive + | Down Type | PVar String | One - | PType :>< PType - | NType :>- PType + | Type :>< Type + | Type :>- Type +infixr 2 :-> infixr 7 :>< infixl 2 :>- -data XNType - = XUp XPType +data XType + -- negative + = XUp XType | XNVar String | XBot - | XPType :->: XNType - deriving (Eq, Ord, Show) - -infixr 2 :->: - -data XPType - = XDown XNType + | XType :->: XType + -- positive + | XDown XType | XPVar String | XOne - | XPType :><: XPType - | XNType :>-: XPType + | XType :><: XType + | XType :>-: XType deriving (Eq, Ord, Show) +infixr 2 :->: infixr 7 :><: infixl 2 :>-: -data NVal - = Lam (PVal -> NVal) - | Ret PVal - -data PVal - = Unit - | Pair PVal PVal - | Thunk NVal +data Val + -- negative + = Lam (Val -> Val) + | Ret Val + -- positive + | Unit + | Pair Val Val + | Thunk Val -newtype Elab a = Elab { elab :: [(String, PType)] -> [(String, NType)] -> Maybe a } +newtype Elab a = Elab { elab :: [(String, Type)] -> [(String, Type)] -> Maybe a } deriving (Functor) - deriving (Applicative) via ReaderC [(String, PType)] (ReaderC [(String, NType)] Maybe) + deriving (Applicative) via ReaderC [(String, Type)] (ReaderC [(String, Type)] Maybe) From 4c357a290e1bbd0256b6d88204693033284373da Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 10:56:21 -0400 Subject: [PATCH 0209/1324] =?UTF-8?q?Don=E2=80=99t=20split=20the=20context?= =?UTF-8?q?.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Polarized.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 3d1935d38..9dd7ce01b 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -62,6 +62,6 @@ data Val | Thunk Val -newtype Elab a = Elab { elab :: [(String, Type)] -> [(String, Type)] -> Maybe a } +newtype Elab a = Elab { elab :: [(String, Type)] -> Maybe a } deriving (Functor) - deriving (Applicative) via ReaderC [(String, Type)] (ReaderC [(String, Type)] Maybe) + deriving (Applicative) via ReaderC [(String, Type)] Maybe From 9617472380810a7fd8218cb3f8cf4ce19bcfc547 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 12:31:00 -0400 Subject: [PATCH 0210/1324] Quote Types back to XTypes. --- src/Facet/Polarized.hs | 41 ++++++++++++++++++++++++++++------------- 1 file changed, 28 insertions(+), 13 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 9dd7ce01b..eb79585b9 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -1,29 +1,31 @@ -{-# LANGUAGE GADTs #-} module Facet.Polarized ( Kind(..) , Type(..) , XType(..) +, quoteType , Val(..) , Elab(..) ) where import Control.Carrier.Reader -data Kind t where - Type :: Kind Type - (:=>) :: Kind t1 -> Kind t2 -> Kind (t1 -> t2) +import Facet.Name + +data Kind + = Type + | Kind :=> Kind + deriving (Eq, Ord, Show) infixr 2 :=> data Type + = Var Kind Level -- negative - = Up Type - | NVar String + | Up Type | Bot | Type :-> Type - | forall t . ForAll (Kind t) (t -> Type) + | ForAll Kind (Type -> Type) -- positive | Down Type - | PVar String | One | Type :>< Type | Type :>- Type @@ -34,14 +36,14 @@ infixl 2 :>- data XType + = XVar Kind Index -- negative - = XUp XType - | XNVar String + | XUp XType | XBot | XType :->: XType + | XForAll Kind XType -- positive | XDown XType - | XPVar String | XOne | XType :><: XType | XType :>-: XType @@ -51,6 +53,19 @@ infixr 2 :->: infixr 7 :><: infixl 2 :>-: +quoteType :: Level -> Type -> XType +quoteType d = \case + Var k d' -> XVar k (levelToIndex d d') + Up t -> XUp (quoteType d t) + Bot -> XBot + a :-> b -> quoteType d a :->: quoteType d b + ForAll k b -> XForAll k (quoteType (succ d) (b (Var k d))) + Down t -> XDown (quoteType d t) + One -> XOne + a :>< b -> quoteType d a :><: quoteType d b + b :>- a -> quoteType d b :>-: quoteType d a + + data Val -- negative @@ -62,6 +77,6 @@ data Val | Thunk Val -newtype Elab a = Elab { elab :: [(String, Type)] -> Maybe a } +newtype Elab a = Elab { elab :: [Type] -> Maybe a } deriving (Functor) - deriving (Applicative) via ReaderC [(String, Type)] Maybe + deriving (Applicative) via ReaderC [Type] Maybe From 429ebc65761a69244e30a071a2984bd2fe7d0cfa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 12:38:59 -0400 Subject: [PATCH 0211/1324] Eval XTypes to Types. --- src/Facet/Polarized.hs | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index eb79585b9..b8babe51b 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -2,6 +2,7 @@ module Facet.Polarized ( Kind(..) , Type(..) , XType(..) +, evalType , quoteType , Val(..) , Elab(..) @@ -9,6 +10,7 @@ module Facet.Polarized import Control.Carrier.Reader import Facet.Name +import Facet.Snoc data Kind = Type @@ -53,6 +55,19 @@ infixr 2 :->: infixr 7 :><: infixl 2 :>-: + +evalType :: Snoc Type -> XType -> Type +evalType env = \case + XVar _ i -> env ! getIndex i + XUp t -> Up (evalType env t) + XBot -> Bot + a :->: b -> evalType env a :-> evalType env b + XForAll k b -> ForAll k (\ _A -> evalType (env :> _A) b) + XDown t -> Down (evalType env t) + XOne -> One + a :><: b -> evalType env a :>< evalType env b + b :>-: a -> evalType env b :>- evalType env a + quoteType :: Level -> Type -> XType quoteType d = \case Var k d' -> XVar k (levelToIndex d d') From 52832ee0ff0c00d6de025796537fd22fb979c379 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 12:40:14 -0400 Subject: [PATCH 0212/1324] Align. --- src/Facet/Context.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index 535ae7037..b13918d95 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -47,10 +47,10 @@ Context es' ! Index i' = withFrozenCallStack $ go es' i' lookupIndex :: E.Has E.Empty sig m => Name -> Context -> m (LName Index, Quantity, Classifier) lookupIndex n = go (Index 0) . elems where - go _ S.Nil = E.empty + go _ S.Nil = E.empty go i (cs S.:> (q, p)) | Just (n' ::: t) <- find ((== n) . tm) p = pure (LName i n', q, t) - | otherwise = go (succ i) cs + | otherwise = go (succ i) cs toEnv :: Context -> Env.Env Type From 53c6e3c32f75a947e3b2e25ecc9772f664dada0d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 13:17:17 -0400 Subject: [PATCH 0213/1324] Rename type vars. --- src/Facet/Polarized.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index b8babe51b..38c94afd1 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -20,7 +20,7 @@ data Kind infixr 2 :=> data Type - = Var Kind Level + = TVar Kind Level -- negative | Up Type | Bot @@ -38,7 +38,7 @@ infixl 2 :>- data XType - = XVar Kind Index + = XTVar Kind Index -- negative | XUp XType | XBot @@ -58,7 +58,7 @@ infixl 2 :>-: evalType :: Snoc Type -> XType -> Type evalType env = \case - XVar _ i -> env ! getIndex i + XTVar _ i -> env ! getIndex i XUp t -> Up (evalType env t) XBot -> Bot a :->: b -> evalType env a :-> evalType env b @@ -70,11 +70,11 @@ evalType env = \case quoteType :: Level -> Type -> XType quoteType d = \case - Var k d' -> XVar k (levelToIndex d d') + TVar k d' -> XTVar k (levelToIndex d d') Up t -> XUp (quoteType d t) Bot -> XBot a :-> b -> quoteType d a :->: quoteType d b - ForAll k b -> XForAll k (quoteType (succ d) (b (Var k d))) + ForAll k b -> XForAll k (quoteType (succ d) (b (TVar k d))) Down t -> XDown (quoteType d t) One -> XOne a :>< b -> quoteType d a :><: quoteType d b From 7784c8689874b12a67fe08a015ce4790b165792b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 21:05:38 -0400 Subject: [PATCH 0214/1324] Define covals and surface expressions. --- src/Facet/Polarized.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 38c94afd1..f2ececb57 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -4,7 +4,9 @@ module Facet.Polarized , XType(..) , evalType , quoteType +, Expr(..) , Val(..) +, Coval(..) , Elab(..) ) where @@ -81,6 +83,9 @@ quoteType d = \case b :>- a -> quoteType d b :>-: quoteType d a +data Expr + = XVar String + | XLam String Expr data Val -- negative @@ -91,7 +96,11 @@ data Val | Pair Val Val | Thunk Val +data Coval + = App Val + | Fst + | Snd -newtype Elab a = Elab { elab :: [Type] -> Maybe a } +newtype Elab a = Elab { elab :: [(String, Type)] -> Maybe a } deriving (Functor) - deriving (Applicative) via ReaderC [Type] Maybe + deriving (Applicative) via ReaderC [(String, Type)] Maybe From dd9b24ca62f7c4ae5e03362810af4937a9526658 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 21:13:09 -0400 Subject: [PATCH 0215/1324] Application. --- src/Facet/Polarized.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index f2ececb57..228ea2782 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -86,6 +86,7 @@ quoteType d = \case data Expr = XVar String | XLam String Expr + | XApp Expr Expr data Val -- negative From 602cbb964f8efaf1cdd8eae2ab8e9ceebbc0344b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 21:15:47 -0400 Subject: [PATCH 0216/1324] Add neutral values. --- src/Facet/Polarized.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 228ea2782..b9f2e082d 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -89,8 +89,9 @@ data Expr | XApp Expr Expr data Val + = Ne Level (Snoc Coval) -- negative - = Lam (Val -> Val) + | Lam (Val -> Val) | Ret Val -- positive | Unit From ed65d1708dfb437eeb283314d214728a4f0a3206 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 21:25:57 -0400 Subject: [PATCH 0217/1324] Define a core syntax. --- src/Facet/Polarized.hs | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index b9f2e082d..c8ba48b91 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -5,6 +5,7 @@ module Facet.Polarized , evalType , quoteType , Expr(..) +, Core(..) , Val(..) , Coval(..) , Elab(..) @@ -88,11 +89,21 @@ data Expr | XLam String Expr | XApp Expr Expr +data Core + = CVar Index + | CLam Core + | CUnit + | CPair Core Core + | CThunk Core + | CApp Core Core + | CFst Core + | CSnd Core + | CForce Core + data Val = Ne Level (Snoc Coval) -- negative | Lam (Val -> Val) - | Ret Val -- positive | Unit | Pair Val Val @@ -102,6 +113,7 @@ data Coval = App Val | Fst | Snd + | Force newtype Elab a = Elab { elab :: [(String, Type)] -> Maybe a } deriving (Functor) From e21dbbe9724e5225f07c2156198cb27ff2ca9059 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Aug 2021 21:33:25 -0400 Subject: [PATCH 0218/1324] Divide Core into Term and Coterm. --- src/Facet/Polarized.hs | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index c8ba48b91..2fa33e425 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -5,7 +5,8 @@ module Facet.Polarized , evalType , quoteType , Expr(..) -, Core(..) +, Term(..) +, Coterm(..) , Val(..) , Coval(..) , Elab(..) @@ -89,16 +90,18 @@ data Expr | XLam String Expr | XApp Expr Expr -data Core +data Term = CVar Index - | CLam Core + | CLam Term | CUnit - | CPair Core Core - | CThunk Core - | CApp Core Core - | CFst Core - | CSnd Core - | CForce Core + | CPair Term Term + | CThunk Term + +data Coterm + = CApp Term Term + | CFst Term + | CSnd Term + | CForce Term data Val = Ne Level (Snoc Coval) From 5cbfa1cab747732bb169845eb2ab044f8d996c9f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 06:54:13 -0400 Subject: [PATCH 0219/1324] Evaluate terms and coterms. --- src/Facet/Polarized.hs | 25 +++++++++++++++++++++---- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 2fa33e425..2a706fa7a 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -6,7 +6,9 @@ module Facet.Polarized , quoteType , Expr(..) , Term(..) +, evalTerm , Coterm(..) +, evalCoterm , Val(..) , Coval(..) , Elab(..) @@ -97,11 +99,26 @@ data Term | CPair Term Term | CThunk Term +evalTerm :: Snoc Val -> Term -> Val +evalTerm env = \case + CVar i -> env ! getIndex i + CLam b -> Lam (\ a -> evalTerm (env :> a) b) + CUnit -> Unit + CPair a b -> Pair (evalTerm env a) (evalTerm env b) + CThunk b -> Thunk (evalTerm env b) + data Coterm - = CApp Term Term - | CFst Term - | CSnd Term - | CForce Term + = CApp Term + | CFst + | CSnd + | CForce + +evalCoterm :: Snoc Val -> Coterm -> Coval +evalCoterm env = \case + CApp a -> App (evalTerm env a) + CFst -> Fst + CSnd -> Snd + CForce -> Force data Val = Ne Level (Snoc Coval) From 84a361aabc99a0cbe9a963c783d0a43a03bf67ce Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 06:58:17 -0400 Subject: [PATCH 0220/1324] Define a smart constructor for variable Vals. --- src/Facet/Polarized.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 2a706fa7a..aa29199c6 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -10,6 +10,7 @@ module Facet.Polarized , Coterm(..) , evalCoterm , Val(..) +, vvar , Coval(..) , Elab(..) ) where @@ -129,6 +130,9 @@ data Val | Pair Val Val | Thunk Val +vvar :: Level -> Val +vvar l = Ne l Nil + data Coval = App Val | Fst From d9a84867ff53f598c09de59a9fbbdfbec2d9f6b1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:06:21 -0400 Subject: [PATCH 0221/1324] Eliminate values. --- src/Facet/Polarized.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index aa29199c6..16f629514 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -11,6 +11,7 @@ module Facet.Polarized , evalCoterm , Val(..) , vvar +, velim , Coval(..) , Elab(..) ) where @@ -133,6 +134,15 @@ data Val vvar :: Level -> Val vvar l = Ne l Nil +velim :: Val -> Coval -> Val +velim = curry $ \case + (Ne v sp, c) -> Ne v (sp :> c) + (Lam f, App a) -> f a + (Pair a _, Fst) -> a + (Pair _ b, Snd) -> b + (Thunk v, Force) -> v + (_, _) -> error "cannot elim" + data Coval = App Val | Fst From d3ab01145d05bac04b9f6a0e73080ac18119b582 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:07:00 -0400 Subject: [PATCH 0222/1324] Eliminate terms. --- src/Facet/Polarized.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 16f629514..0a21e9866 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -100,6 +100,7 @@ data Term | CUnit | CPair Term Term | CThunk Term + | CElim Term Coterm evalTerm :: Snoc Val -> Term -> Val evalTerm env = \case @@ -108,6 +109,7 @@ evalTerm env = \case CUnit -> Unit CPair a b -> Pair (evalTerm env a) (evalTerm env b) CThunk b -> Thunk (evalTerm env b) + CElim t e -> velim (evalTerm env t) (evalCoterm env e) data Coterm = CApp Term From b4568969c146f43229c31d363514bcd96e7ac83d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:11:30 -0400 Subject: [PATCH 0223/1324] Quote (co)values. --- src/Facet/Polarized.hs | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 0a21e9866..bdd53a7e3 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -12,11 +12,14 @@ module Facet.Polarized , Val(..) , vvar , velim +, quoteVal , Coval(..) +, quoteCoval , Elab(..) ) where import Control.Carrier.Reader +import Data.Foldable (foldl') import Facet.Name import Facet.Snoc @@ -145,12 +148,30 @@ velim = curry $ \case (Thunk v, Force) -> v (_, _) -> error "cannot elim" + +quoteVal :: Level -> Val -> Term +quoteVal d = \case + Ne l sp -> foldl' (\ t c -> CElim t (quoteCoval d c)) (CVar (levelToIndex d l)) sp + Lam f -> CLam (quoteVal (succ d) (f (vvar d))) + Unit -> CUnit + Pair a b -> CPair (quoteVal d a) (quoteVal d b) + Thunk b -> CThunk (quoteVal d b) + + data Coval = App Val | Fst | Snd | Force +quoteCoval :: Level -> Coval -> Coterm +quoteCoval d = \case + App a -> CApp (quoteVal d a) + Fst -> CFst + Snd -> CSnd + Force -> CForce + + newtype Elab a = Elab { elab :: [(String, Type)] -> Maybe a } deriving (Functor) deriving (Applicative) via ReaderC [(String, Type)] Maybe From 8bbfe7e7f7b75093022ddb939738144195a24e27 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:14:59 -0400 Subject: [PATCH 0224/1324] Quote (co)values via a Quote class. --- src/Facet/Polarized.hs | 38 +++++++++++++++++++++----------------- 1 file changed, 21 insertions(+), 17 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index bdd53a7e3..da3992694 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FunctionalDependencies #-} module Facet.Polarized ( Kind(..) , Type(..) @@ -12,10 +13,9 @@ module Facet.Polarized , Val(..) , vvar , velim -, quoteVal , Coval(..) -, quoteCoval , Elab(..) +, Quote(..) ) where import Control.Carrier.Reader @@ -136,6 +136,15 @@ data Val | Pair Val Val | Thunk Val +instance Quote Val Term where + quote d = \case + Ne l sp -> foldl' (\ t c -> CElim t (quote d c)) (CVar (levelToIndex d l)) sp + Lam f -> CLam (quote (succ d) (f (vvar d))) + Unit -> CUnit + Pair a b -> CPair (quote d a) (quote d b) + Thunk b -> CThunk (quote d b) + + vvar :: Level -> Val vvar l = Ne l Nil @@ -149,29 +158,24 @@ velim = curry $ \case (_, _) -> error "cannot elim" -quoteVal :: Level -> Val -> Term -quoteVal d = \case - Ne l sp -> foldl' (\ t c -> CElim t (quoteCoval d c)) (CVar (levelToIndex d l)) sp - Lam f -> CLam (quoteVal (succ d) (f (vvar d))) - Unit -> CUnit - Pair a b -> CPair (quoteVal d a) (quoteVal d b) - Thunk b -> CThunk (quoteVal d b) - - data Coval = App Val | Fst | Snd | Force -quoteCoval :: Level -> Coval -> Coterm -quoteCoval d = \case - App a -> CApp (quoteVal d a) - Fst -> CFst - Snd -> CSnd - Force -> CForce +instance Quote Coval Coterm where + quote d = \case + App a -> CApp (quote d a) + Fst -> CFst + Snd -> CSnd + Force -> CForce newtype Elab a = Elab { elab :: [(String, Type)] -> Maybe a } deriving (Functor) deriving (Applicative) via ReaderC [(String, Type)] Maybe + + +class Quote v t | v -> t where + quote :: Level -> v -> t From 4d77816d211839a8d7db58eaeb688d47e437e79a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:17:12 -0400 Subject: [PATCH 0225/1324] Quote types via Quote. --- src/Facet/Polarized.hs | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index da3992694..a8ea1fe84 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -4,7 +4,6 @@ module Facet.Polarized , Type(..) , XType(..) , evalType -, quoteType , Expr(..) , Term(..) , evalTerm @@ -47,6 +46,18 @@ infixr 2 :-> infixr 7 :>< infixl 2 :>- +instance Quote Type XType where + quote d = \case + TVar k d' -> XTVar k (levelToIndex d d') + Up t -> XUp (quote d t) + Bot -> XBot + a :-> b -> quote d a :->: quote d b + ForAll k b -> XForAll k (quote (succ d) (b (TVar k d))) + Down t -> XDown (quote d t) + One -> XOne + a :>< b -> quote d a :><: quote d b + b :>- a -> quote d b :>-: quote d a + data XType = XTVar Kind Index @@ -79,18 +90,6 @@ evalType env = \case a :><: b -> evalType env a :>< evalType env b b :>-: a -> evalType env b :>- evalType env a -quoteType :: Level -> Type -> XType -quoteType d = \case - TVar k d' -> XTVar k (levelToIndex d d') - Up t -> XUp (quoteType d t) - Bot -> XBot - a :-> b -> quoteType d a :->: quoteType d b - ForAll k b -> XForAll k (quoteType (succ d) (b (TVar k d))) - Down t -> XDown (quoteType d t) - One -> XOne - a :>< b -> quoteType d a :><: quoteType d b - b :>- a -> quoteType d b :>-: quoteType d a - data Expr = XVar String From 21884bea07d26967059fa1750d3ededfb9432289 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:20:20 -0400 Subject: [PATCH 0226/1324] Evaluate (co)terms via an Eval class. --- src/Facet/Polarized.hs | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index a8ea1fe84..d027ef1ed 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -6,15 +6,14 @@ module Facet.Polarized , evalType , Expr(..) , Term(..) -, evalTerm , Coterm(..) -, evalCoterm , Val(..) , vvar , velim , Coval(..) , Elab(..) , Quote(..) +, Eval(..) ) where import Control.Carrier.Reader @@ -104,14 +103,14 @@ data Term | CThunk Term | CElim Term Coterm -evalTerm :: Snoc Val -> Term -> Val -evalTerm env = \case - CVar i -> env ! getIndex i - CLam b -> Lam (\ a -> evalTerm (env :> a) b) - CUnit -> Unit - CPair a b -> Pair (evalTerm env a) (evalTerm env b) - CThunk b -> Thunk (evalTerm env b) - CElim t e -> velim (evalTerm env t) (evalCoterm env e) +instance Eval Term Val Val where + eval env = \case + CVar i -> env ! getIndex i + CLam b -> Lam (\ a -> eval (env :> a) b) + CUnit -> Unit + CPair a b -> Pair (eval env a) (eval env b) + CThunk b -> Thunk (eval env b) + CElim t e -> velim (eval env t) (eval env e) data Coterm = CApp Term @@ -119,12 +118,12 @@ data Coterm | CSnd | CForce -evalCoterm :: Snoc Val -> Coterm -> Coval -evalCoterm env = \case - CApp a -> App (evalTerm env a) - CFst -> Fst - CSnd -> Snd - CForce -> Force +instance Eval Coterm Val Coval where + eval env = \case + CApp a -> App (eval env a) + CFst -> Fst + CSnd -> Snd + CForce -> Force data Val = Ne Level (Snoc Coval) @@ -178,3 +177,6 @@ newtype Elab a = Elab { elab :: [(String, Type)] -> Maybe a } class Quote v t | v -> t where quote :: Level -> v -> t + +class Eval t e v | t -> e v where + eval :: Snoc e -> t -> v From a71d93ef7127bc00e8311716cf55d5c4a6079b54 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:21:03 -0400 Subject: [PATCH 0227/1324] Evaluate types via Eval. --- src/Facet/Polarized.hs | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index d027ef1ed..3fc35a44e 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -3,7 +3,6 @@ module Facet.Polarized ( Kind(..) , Type(..) , XType(..) -, evalType , Expr(..) , Term(..) , Coterm(..) @@ -76,18 +75,17 @@ infixr 2 :->: infixr 7 :><: infixl 2 :>-: - -evalType :: Snoc Type -> XType -> Type -evalType env = \case - XTVar _ i -> env ! getIndex i - XUp t -> Up (evalType env t) - XBot -> Bot - a :->: b -> evalType env a :-> evalType env b - XForAll k b -> ForAll k (\ _A -> evalType (env :> _A) b) - XDown t -> Down (evalType env t) - XOne -> One - a :><: b -> evalType env a :>< evalType env b - b :>-: a -> evalType env b :>- evalType env a +instance Eval XType Type Type where + eval env = \case + XTVar _ i -> env ! getIndex i + XUp t -> Up (eval env t) + XBot -> Bot + a :->: b -> eval env a :-> eval env b + XForAll k b -> ForAll k (\ _A -> eval (env :> _A) b) + XDown t -> Down (eval env t) + XOne -> One + a :><: b -> eval env a :>< eval env b + b :>-: a -> eval env b :>- eval env a data Expr From a8d7f620df9e19a3da3b43d136a425e8dba2ea08 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:23:04 -0400 Subject: [PATCH 0228/1324] Parameterize Coval by the type it holds. --- src/Facet/Polarized.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 3fc35a44e..564675424 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -9,7 +9,7 @@ module Facet.Polarized , Val(..) , vvar , velim -, Coval(..) +, Co(..) , Elab(..) , Quote(..) , Eval(..) @@ -116,7 +116,7 @@ data Coterm | CSnd | CForce -instance Eval Coterm Val Coval where +instance Eval Coterm Val (Co Val) where eval env = \case CApp a -> App (eval env a) CFst -> Fst @@ -124,7 +124,7 @@ instance Eval Coterm Val Coval where CForce -> Force data Val - = Ne Level (Snoc Coval) + = Ne Level (Snoc (Co Val)) -- negative | Lam (Val -> Val) -- positive @@ -144,7 +144,7 @@ instance Quote Val Term where vvar :: Level -> Val vvar l = Ne l Nil -velim :: Val -> Coval -> Val +velim :: Val -> Co Val -> Val velim = curry $ \case (Ne v sp, c) -> Ne v (sp :> c) (Lam f, App a) -> f a @@ -154,13 +154,13 @@ velim = curry $ \case (_, _) -> error "cannot elim" -data Coval - = App Val +data Co t + = App t | Fst | Snd | Force -instance Quote Coval Coterm where +instance Quote (Co Val) Coterm where quote d = \case App a -> CApp (quote d a) Fst -> CFst From 72167dffcafa021776b5c0b3890ecb592d8db9a0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:23:30 -0400 Subject: [PATCH 0229/1324] Derive a bunch of instances for Co. --- src/Facet/Polarized.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 564675424..928120c62 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -159,6 +159,7 @@ data Co t | Fst | Snd | Force + deriving (Eq, Foldable, Functor, Ord, Show, Traversable) instance Quote (Co Val) Coterm where quote d = \case From 86f698d2b447e6e150e7c8d2d847d9bc597b133c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:24:42 -0400 Subject: [PATCH 0230/1324] Replace Coterm with Co Term. --- src/Facet/Polarized.hs | 29 +++++++++++------------------ 1 file changed, 11 insertions(+), 18 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 928120c62..4c50f8b1e 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -5,7 +5,6 @@ module Facet.Polarized , XType(..) , Expr(..) , Term(..) -, Coterm(..) , Val(..) , vvar , velim @@ -99,7 +98,7 @@ data Term | CUnit | CPair Term Term | CThunk Term - | CElim Term Coterm + | CElim Term (Co Term) instance Eval Term Val Val where eval env = \case @@ -110,18 +109,12 @@ instance Eval Term Val Val where CThunk b -> Thunk (eval env b) CElim t e -> velim (eval env t) (eval env e) -data Coterm - = CApp Term - | CFst - | CSnd - | CForce - -instance Eval Coterm Val (Co Val) where +instance Eval (Co Term) Val (Co Val) where eval env = \case - CApp a -> App (eval env a) - CFst -> Fst - CSnd -> Snd - CForce -> Force + App a -> App (eval env a) + Fst -> Fst + Snd -> Snd + Force -> Force data Val = Ne Level (Snoc (Co Val)) @@ -161,12 +154,12 @@ data Co t | Force deriving (Eq, Foldable, Functor, Ord, Show, Traversable) -instance Quote (Co Val) Coterm where +instance Quote (Co Val) (Co Term) where quote d = \case - App a -> CApp (quote d a) - Fst -> CFst - Snd -> CSnd - Force -> CForce + App a -> App (quote d a) + Fst -> Fst + Snd -> Snd + Force -> Force newtype Elab a = Elab { elab :: [(String, Type)] -> Maybe a } From dfa680a4b24e49a4ff01401ad633cbee8fc01321 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:25:11 -0400 Subject: [PATCH 0231/1324] Generalize quotation of Co. --- src/Facet/Polarized.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 4c50f8b1e..759de0253 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} module Facet.Polarized ( Kind(..) , Type(..) @@ -154,7 +155,7 @@ data Co t | Force deriving (Eq, Foldable, Functor, Ord, Show, Traversable) -instance Quote (Co Val) (Co Term) where +instance Quote v t => Quote (Co v) (Co t) where quote d = \case App a -> App (quote d a) Fst -> Fst From 0b2c3dcce890ae2440d424043770eb92881a0c8e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:25:59 -0400 Subject: [PATCH 0232/1324] Generalize evaluation of Co. --- src/Facet/Polarized.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 759de0253..dcc31792e 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -110,7 +110,7 @@ instance Eval Term Val Val where CThunk b -> Thunk (eval env b) CElim t e -> velim (eval env t) (eval env e) -instance Eval (Co Term) Val (Co Val) where +instance Eval t e v => Eval (Co t) e (Co v) where eval env = \case App a -> App (eval env a) Fst -> Fst From 6b9e0b7efdfb0eb6a16bbdfa92c91c2e300b745f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:27:10 -0400 Subject: [PATCH 0233/1324] Define a module for Quote. --- facet.cabal | 1 + src/Facet/Quote.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Quote.hs diff --git a/facet.cabal b/facet.cabal index 702d7df40..4ab8b9787 100644 --- a/facet.cabal +++ b/facet.cabal @@ -106,6 +106,7 @@ library Facet.Polarized Facet.Pretty Facet.Print + Facet.Quote Facet.REPL Facet.REPL.Parser Facet.Run diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs new file mode 100644 index 000000000..56b81ae3f --- /dev/null +++ b/src/Facet/Quote.hs @@ -0,0 +1,2 @@ +module Facet.Quote +() where From f35156ee29c65894fdb2de4c6e1821afa89e50cc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:27:43 -0400 Subject: [PATCH 0234/1324] Define Quote. --- src/Facet/Quote.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index 56b81ae3f..e5097dc0c 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -1,2 +1,12 @@ +{-# LANGUAGE FunctionalDependencies #-} module Facet.Quote -() where +( -- * Quotation + Quote(..) +) where + +import Facet.Name (Level) + +-- Quotation + +class Quote v t | v -> t where + quote :: Level -> v -> t From a91196c450ffe400be105ab47468cd9862507cb9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:28:01 -0400 Subject: [PATCH 0235/1324] Use the extracted definition of Quote. --- src/Facet/Polarized.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index dcc31792e..a05737aac 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -18,6 +18,7 @@ module Facet.Polarized import Control.Carrier.Reader import Data.Foldable (foldl') import Facet.Name +import Facet.Quote import Facet.Snoc data Kind @@ -168,8 +169,5 @@ newtype Elab a = Elab { elab :: [(String, Type)] -> Maybe a } deriving (Applicative) via ReaderC [(String, Type)] Maybe -class Quote v t | v -> t where - quote :: Level -> v -> t - class Eval t e v | t -> e v where eval :: Snoc e -> t -> v From f56979dfa5ea4f8c813703cf2681a30c8b5367f9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:30:25 -0400 Subject: [PATCH 0236/1324] Define a helper for quoting binders. --- src/Facet/Quote.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index e5097dc0c..429ddfa71 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -2,6 +2,7 @@ module Facet.Quote ( -- * Quotation Quote(..) +, quoteBinder ) where import Facet.Name (Level) @@ -10,3 +11,7 @@ import Facet.Name (Level) class Quote v t | v -> t where quote :: Level -> v -> t + + +quoteBinder :: Quote v t => (Level -> v) -> Level -> (v -> v) -> t +quoteBinder var d f = quote (succ d) (f (var d)) From 7b03afad952636f487a9e4c2bfe4b34c6ebb9149 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:31:01 -0400 Subject: [PATCH 0237/1324] Quote binders with quoteBinder. --- src/Facet/Polarized.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index a05737aac..4cdee4f03 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -51,7 +51,7 @@ instance Quote Type XType where Up t -> XUp (quote d t) Bot -> XBot a :-> b -> quote d a :->: quote d b - ForAll k b -> XForAll k (quote (succ d) (b (TVar k d))) + ForAll k b -> XForAll k (quoteBinder (TVar k) d b) Down t -> XDown (quote d t) One -> XOne a :>< b -> quote d a :><: quote d b @@ -130,7 +130,7 @@ data Val instance Quote Val Term where quote d = \case Ne l sp -> foldl' (\ t c -> CElim t (quote d c)) (CVar (levelToIndex d l)) sp - Lam f -> CLam (quote (succ d) (f (vvar d))) + Lam f -> CLam (quoteBinder vvar d f) Unit -> CUnit Pair a b -> CPair (quote d a) (quote d b) Thunk b -> CThunk (quote d b) From 6fc780d6124c66101f093afecd6bdf811a184eae Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:32:12 -0400 Subject: [PATCH 0238/1324] Quote Norm using Quote. --- src/Facet/Norm.hs | 23 +++++++++++------------ src/Facet/Print.hs | 3 ++- 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Facet/Norm.hs b/src/Facet/Norm.hs index dd00fa02e..250b75b23 100644 --- a/src/Facet/Norm.hs +++ b/src/Facet/Norm.hs @@ -1,6 +1,5 @@ module Facet.Norm ( Norm(..) -, quote , norm ) where @@ -14,6 +13,7 @@ import Data.Traversable (mapAccumL) import Facet.Env import Facet.Name import Facet.Pattern +import Facet.Quote import Facet.Semialign (zipWithM) import Facet.Snoc import Facet.Syntax @@ -33,17 +33,16 @@ instance Eq Norm where instance Ord Norm where compare = compare `on` quote 0 - -quote :: Level -> Norm -> Expr -quote d = \case - NString s -> XString s - NCon n sp -> XCon n (quote d <$> sp) - NLam cs -> XLam (map (uncurry clause) cs) - NNe v sp -> foldl' (\ h -> XApp h . quote d) (XVar (fmap (levelToIndex d) <$> v)) sp - NDict os -> XDict (map (fmap (quote d)) os) - NComp p b -> XComp p (snd (clause (PDict p) b)) - where - clause p b = let (d', p') = mapAccumL (\ d n -> (succ d, n :=: NNe (Free (LName d n)) Nil)) d p in (p, quote d' (b p')) +instance Quote Norm Expr where + quote d = \case + NString s -> XString s + NCon n sp -> XCon n (quote d <$> sp) + NLam cs -> XLam (map (uncurry clause) cs) + NNe v sp -> foldl' (\ h -> XApp h . quote d) (XVar (fmap (levelToIndex d) <$> v)) sp + NDict os -> XDict (map (fmap (quote d)) os) + NComp p b -> XComp p (snd (clause (PDict p) b)) + where + clause p b = let (d', p') = mapAccumL (\ d n -> (succ d, n :=: NNe (Free (LName d n)) Nil)) d p in (p, quote d' (b p')) norm :: Env Norm -> Expr -> Norm norm env = \case diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index cfe4a2438..96738b85f 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -43,6 +43,7 @@ import Facet.Name as Name import qualified Facet.Norm as N import Facet.Pattern import Facet.Pretty (lower, upper) +import Facet.Quote import Facet.Semiring (one, zero) import Facet.Snoc import Facet.Style @@ -199,7 +200,7 @@ printInterfaceWith :: (Options -> Env Print -> a -> Print) -> Options -> Env Pri printInterfaceWith with opts@Options{ rname } env (Interface h sp) = rname h $$* fmap (with opts env) sp printNorm :: Options -> Env Print -> N.Norm -> Print -printNorm opts env = printExpr opts env . N.quote (level env) +printNorm opts env = printExpr opts env . quote (level env) printExpr :: Options -> Env Print -> C.Expr -> Print printExpr opts@Options{ rname } = go From 390d6c22fa62da98b70f7dedc4c14695b2e67548 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:35:23 -0400 Subject: [PATCH 0239/1324] Quote Type using Quote. --- src/Facet/Elab.hs | 3 ++- src/Facet/Print.hs | 2 +- src/Facet/Type/Norm.hs | 20 ++++++++++---------- src/Facet/Unify.hs | 1 + test/Facet/Core/Type/Test.hs | 3 ++- 5 files changed, 16 insertions(+), 13 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 25bd4eeb8..bf244313a 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -70,6 +70,7 @@ import Facet.Lens import Facet.Module import Facet.Name hiding (L, R) import Facet.Pattern +import Facet.Quote import Facet.Semiring import Facet.Snoc import Facet.Snoc.NonEmpty (toSnoc) @@ -335,7 +336,7 @@ elabTerm :: Has (Reader Graph :+: Reader Module :+: Reader Source) sig m => Elab elabTerm = elabWith one (const pure) elabSynthTerm :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (Expr ::: Type) -> m (Expr ::: Type) -elabSynthTerm = elabWith one (\ subst (e ::: _T) -> pure (e ::: TN.eval subst Env.empty (TN.quote 0 _T))) +elabSynthTerm = elabWith one (\ subst (e ::: _T) -> pure (e ::: TN.eval subst Env.empty (quote 0 _T))) elabSynthType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (TX.Type ::: Kind) -> m (Type ::: Kind) elabSynthType = elabWith zero (\ subst (_T ::: _K) -> pure (TN.eval subst Env.empty _T ::: _K)) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 96738b85f..0b967273a 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -168,7 +168,7 @@ printKind env = \case d = level env printType :: Options -> Env Print -> TN.Type -> Print -printType opts env = printTExpr opts env . TN.quote (level env) +printType opts env = printTExpr opts env . quote (level env) printInterface :: Options -> Env Print -> Interface TN.Type -> Print printInterface = printInterfaceWith printType diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 68f9fb898..065b53003 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -13,8 +13,7 @@ module Facet.Type.Norm -- ** Elimination , ($$) , ($$*) - -- * Quotation -, quote + -- * Evaluation , eval , apply ) where @@ -29,6 +28,7 @@ import Facet.Interface import Facet.Kind import Facet.Name import Facet.Pattern +import Facet.Quote import Facet.Snoc import Facet.Subst import Facet.Syntax @@ -53,6 +53,14 @@ instance Eq Type where instance Ord Type where compare = compare `on` quote 0 +instance Quote Type TX.Type where + quote d = \case + String -> TX.String + ForAll n t b -> TX.ForAll n t (quote (succ d) (b (free (LName d n)))) + Arrow n q a b -> TX.Arrow n q (quote d a) (quote d b) + Comp s t -> TX.Comp (mapSignature (quote d) s) (quote d t) + Ne n sp -> foldl' (&) (TX.Var (fmap (fmap (levelToIndex d)) <$> n)) (flip TX.App . quote d <$> sp) + instance TType (T Type) where string = T String forAll n (T k) b = T (ForAll n k (getT . b . T)) @@ -125,14 +133,6 @@ infixl 9 $$, $$* -- Quotation -quote :: Level -> Type -> TX.Type -quote d = \case - String -> TX.String - ForAll n t b -> TX.ForAll n t (quote (succ d) (b (free (LName d n)))) - Arrow n q a b -> TX.Arrow n q (quote d a) (quote d b) - Comp s t -> TX.Comp (mapSignature (quote d) s) (quote d t) - Ne n sp -> foldl' (&) (TX.Var (fmap (fmap (levelToIndex d)) <$> n)) (flip TX.App . quote d <$> sp) - eval :: HasCallStack => Subst Type -> Env Type -> TX.Type -> Type eval subst = go where go env = \case diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index b52eb8700..f6ebc51e8 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -23,6 +23,7 @@ import Facet.Interface import Facet.Kind import Facet.Name import Facet.Pattern +import Facet.Quote import Facet.Semialign import Facet.Semiring import Facet.Snoc diff --git a/test/Facet/Core/Type/Test.hs b/test/Facet/Core/Type/Test.hs index 37a87bf61..b0e0191fb 100644 --- a/test/Facet/Core/Type/Test.hs +++ b/test/Facet/Core/Type/Test.hs @@ -7,10 +7,11 @@ module Facet.Core.Type.Test import Facet.Env import Facet.Kind import Facet.Name +import Facet.Quote import Facet.Semiring import Facet.Syntax import Facet.Type.Expr -import Facet.Type.Norm (eval, quote) +import Facet.Type.Norm (eval) import Hedgehog hiding (Var, eval) tests :: IO Bool From 752bcd5b24d2f6c032a841486d56351310d5c951 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:37:39 -0400 Subject: [PATCH 0240/1324] Quote Value in Quote. --- src/Facet/Eval.hs | 23 +++++++++++------------ src/Facet/REPL.hs | 3 ++- 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 0ee37cfc8..2b74e6ce3 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -11,7 +11,6 @@ module Facet.Eval , Value(..) , unit -- * Quotation -, quoteV , E(..) , runE , state' @@ -42,6 +41,7 @@ import Facet.Graph import Facet.Module import Facet.Name hiding (Op) import Facet.Pattern +import Facet.Quote import Facet.Semialign (zipWithM) import Facet.Snoc.NonEmpty as NE hiding ((|>)) import Facet.Syntax @@ -132,6 +132,16 @@ data Value m | VDict [RName :=: Value m] | VComp [RName :=: Name] Expr +instance Monad m => Quote (Value m) (m Expr) where + quote d = \case + VLam _ cs -> pure $ XLam cs + VCont k -> quote (succ d) =<< k (VVar (Free (LName d __))) + VVar v -> pure (XVar (fmap (levelToIndex d) <$> v)) + VCon n fs -> XCon n <$> traverse (quote d) fs + VString s -> pure $ XString s + VDict os -> XDict <$> traverse (traverse (quote d)) os + VComp p b -> pure $ XComp p b + unit :: Value m unit = VCon (NE.FromList ["Data", "Unit"] :.: U "unit") [] @@ -152,17 +162,6 @@ matchV k p s = case p of -- Quotation -quoteV :: Monad m => Level -> Value m -> m Expr -quoteV d = \case - VLam _ cs -> pure $ XLam cs - VCont k -> quoteV (succ d) =<< k (VVar (Free (LName d __))) - VVar v -> pure (XVar (fmap (levelToIndex d) <$> v)) - VCon n fs -> XCon n <$> traverse (quoteV d) fs - VString s -> pure $ XString s - VDict os -> XDict <$> traverse (traverse (quoteV d)) os - VComp p b -> pure $ XComp p b - - newtype E sig r a = E (forall i . sig (E sig) i r -> (a -> r) -> r) deriving (Functor) diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index 608f22ffa..761a54b7f 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -45,6 +45,7 @@ import Facet.Notice.Parser import Facet.Parser as Parser import Facet.Pretty import Facet.Print as Print hiding (meta) +import Facet.Quote import Facet.REPL.Parser import Facet.Snoc import Facet.Source (Source(..), sourceFromString) @@ -204,7 +205,7 @@ showEval e = Action $ do outputDocLn (getPrint (ann (printExpr opts mempty e'' ::: printType opts mempty _T))) runEvalMain :: (Has (Error (Notice.Notice (Doc Style)) :+: Output :+: Reader Graph :+: Reader Module :+: State Options) sig m, MonadFail m) => Expr -> m Expr -runEvalMain e = runEval (E.quoteV 0 =<< runReader mempty (eval e)) pure +runEvalMain e = runEval (quote 0 =<< runReader mempty (eval e)) pure -- where -- hdl = [(write, Handler handle)] -- write = fromList ["Effect", "Console"] :.: U "write" From ef571ec346bfe532aeb1344c56813255c49648e5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:39:35 -0400 Subject: [PATCH 0241/1324] Define a newtype for deriving instances via quotation. --- src/Facet/Quote.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index 429ddfa71..331f41626 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -3,6 +3,8 @@ module Facet.Quote ( -- * Quotation Quote(..) , quoteBinder + -- * Deriving +, Quoting(..) ) where import Facet.Name (Level) @@ -15,3 +17,8 @@ class Quote v t | v -> t where quoteBinder :: Quote v t => (Level -> v) -> Level -> (v -> v) -> t quoteBinder var d f = quote (succ d) (f (var d)) + + +-- Deriving + +newtype Quoting t v = Quoting { getQuoting :: v } From 541e9be18d06ea224f6a061e3f71e113abda8520 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:40:28 -0400 Subject: [PATCH 0242/1324] Define an Eq instance for Quoting. --- src/Facet/Quote.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index 331f41626..f12e27014 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -22,3 +22,6 @@ quoteBinder var d f = quote (succ d) (f (var d)) -- Deriving newtype Quoting t v = Quoting { getQuoting :: v } + +instance (Quote v t, Eq t) => Eq (Quoting t v) where + Quoting a == Quoting b = quote 0 a == quote 0 b From 7fbee80ab59055e8a3ed3296560e8036d1e1ba28 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:40:49 -0400 Subject: [PATCH 0243/1324] Define an Ord instance for Quoting. --- src/Facet/Quote.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index f12e27014..a9053ae87 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -25,3 +25,6 @@ newtype Quoting t v = Quoting { getQuoting :: v } instance (Quote v t, Eq t) => Eq (Quoting t v) where Quoting a == Quoting b = quote 0 a == quote 0 b + +instance (Quote v t, Ord t) => Ord (Quoting t v) where + Quoting a `compare` Quoting b = quote 0 a `compare` quote 0 b From 104d7ab1f380086bf6ba1b54b55f93c0fe647d15 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:41:37 -0400 Subject: [PATCH 0244/1324] Define a Show instance for Quoting. --- src/Facet/Quote.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index a9053ae87..dcc5afa3c 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -28,3 +28,6 @@ instance (Quote v t, Eq t) => Eq (Quoting t v) where instance (Quote v t, Ord t) => Ord (Quoting t v) where Quoting a `compare` Quoting b = quote 0 a `compare` quote 0 b + +instance (Quote v t, Show t) => Show (Quoting t v) where + showsPrec p = showsPrec p . quote 0 . getQuoting From b1600f64ebb662f712950ec4e9f76aebee0b7db7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:43:38 -0400 Subject: [PATCH 0245/1324] Derive instances for Type via Quoting. --- src/Facet/Polarized.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 4cdee4f03..a3b407ee5 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -40,6 +40,7 @@ data Type | One | Type :>< Type | Type :>- Type + deriving (Eq, Ord, Show) via Quoting XType Type infixr 2 :-> infixr 7 :>< From db56db280f2d391ef1e40644e06080627131db39 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:44:36 -0400 Subject: [PATCH 0246/1324] Derive instances for Val via Quoting. --- src/Facet/Polarized.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index a3b407ee5..d6a198dfb 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -102,6 +102,7 @@ data Term | CPair Term Term | CThunk Term | CElim Term (Co Term) + deriving (Eq, Ord, Show) instance Eval Term Val Val where eval env = \case @@ -127,6 +128,7 @@ data Val | Unit | Pair Val Val | Thunk Val + deriving (Eq, Ord, Show) via Quoting Term Val instance Quote Val Term where quote d = \case From 6b8de755a0069cb471aeeafe0ad2f40a608ddde7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:47:34 -0400 Subject: [PATCH 0247/1324] Derive more instances via Quoting. --- src/Facet/Norm.hs | 8 +------- src/Facet/Type/Norm.hs | 9 ++------- 2 files changed, 3 insertions(+), 14 deletions(-) diff --git a/src/Facet/Norm.hs b/src/Facet/Norm.hs index 250b75b23..a81384c76 100644 --- a/src/Facet/Norm.hs +++ b/src/Facet/Norm.hs @@ -5,7 +5,6 @@ module Facet.Norm import Control.Monad (guard) import Data.Foldable (foldl') -import Data.Function (on) import Data.Maybe (fromMaybe) import Data.Monoid import Data.Text (Text) @@ -26,12 +25,7 @@ data Norm | NNe (Var (LName Level)) (Snoc Norm) | NDict [RName :=: Norm] | NComp [RName :=: Name] (Pattern (Name :=: Norm) -> Norm) - -instance Eq Norm where - (==) = (==) `on` quote 0 - -instance Ord Norm where - compare = compare `on` quote 0 + deriving (Eq, Ord, Show) via Quoting Expr Norm instance Quote Norm Expr where quote d = \case diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 065b53003..b471299c8 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -21,7 +21,7 @@ module Facet.Type.Norm import Control.Effect.Empty import Control.Lens (Prism', prism') import Data.Foldable (foldl') -import Data.Function (on, (&)) +import Data.Function ((&)) import Data.Maybe (fromMaybe) import Facet.Env hiding (empty) import Facet.Interface @@ -46,12 +46,7 @@ data Type | Arrow (Maybe Name) Quantity Type Type | Ne (Var (Either Meta (LName Level))) (Snoc Type) | Comp (Signature Type) Type - -instance Eq Type where - (==) = (==) `on` quote 0 - -instance Ord Type where - compare = compare `on` quote 0 + deriving (Eq, Ord, Show) via Quoting TX.Type Type instance Quote Type TX.Type where quote d = \case From 84a853b1b6d46cb83e7de5fc2ab0938891791ad9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:52:33 -0400 Subject: [PATCH 0248/1324] Define a Printable class. --- src/Facet/Print.hs | 8 ++++++++ src/Facet/REPL.hs | 2 +- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 0b967273a..157963c28 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -29,6 +29,8 @@ module Facet.Print , intro , tintro , meta + -- * Printable +, Printable(..) ) where import Data.Foldable (foldl', toList) @@ -270,3 +272,9 @@ name f n d = setPrec Var . annotate (Name d) $ pretty '_' <> f d else pretty n + + +-- Printable + +class Printable t where + print :: Options -> Env Print -> t -> Print diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index 761a54b7f..602fc2b4c 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -64,7 +64,7 @@ import Text.Parser.Token hiding (brackets, comma) repl :: [FilePath] -> IO ExitCode repl searchPaths - = handle @IOError (\ e -> ExitFailure 1 <$ print e) + = handle @IOError (\ e -> ExitFailure 1 <$ Prelude.print e) . fmap (const ExitSuccess) . runReadlineWithHistory . evalState (defaultREPLState & target_.searchPaths_ .~ Set.fromList searchPaths) From f8fe215e6532f3bdb10388fb268a921f0cae00ea Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:53:53 -0400 Subject: [PATCH 0249/1324] Define a Printable instance for Classifier. --- src/Facet/Print.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 157963c28..f15ff47f1 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -278,3 +278,8 @@ name f n d = setPrec Var . annotate (Name d) $ class Printable t where print :: Options -> Env Print -> t -> Print + +instance Printable TN.Classifier where + print opts env = \case + TN.CK k -> printKind env k + TN.CT t -> printType opts env t From efccee72ec1c9ca266de6df2819b4f77a0793085 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:56:40 -0400 Subject: [PATCH 0250/1324] :fire: printSubject. --- src/Facet/Notice/Elab.hs | 16 ++++++++-------- src/Facet/Print.hs | 6 ------ 2 files changed, 8 insertions(+), 14 deletions(-) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 4a161c565..34ca759d2 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -23,7 +23,7 @@ import Facet.Subst (metas) import Facet.Syntax import Facet.Type.Norm (Classifier(..), apply, free, metavar) import GHC.Stack -import Prelude hiding (unlines) +import Prelude hiding (print, unlines) import Silkscreen -- Elaboration @@ -70,18 +70,18 @@ printErrReason opts ctx = group . \case One -> pretty "1" Many -> pretty "arbitrarily many" Unify r (Exp exp) (Act act) -> reason r - <> hardline <> pretty "expected:" <> print exp' - <> hardline <> pretty " actual:" <> print act' + <> hardline <> pretty "expected:" <> align exp' + <> hardline <> pretty " actual:" <> align act' where reason = \case Mismatch -> pretty "mismatch" - Occurs v t -> reflow "infinite type:" <+> getPrint (printType opts ctx (metavar v)) <+> reflow "occurs in" <+> getPrint (printSubject opts ctx t) - exp' = either reflow (getPrint . printSubject opts ctx) exp - act' = getPrint (printSubject opts ctx act) + Occurs v t -> reflow "infinite type:" <+> getPrint (printType opts ctx (metavar v)) <+> reflow "occurs in" <+> getPrint (print opts ctx t) + exp' = either reflow (getPrint . print opts ctx) exp + act' = getPrint (print opts ctx act) -- line things up nicely for e.g. wrapped function types - print = nest 2 . (flatAlt (line <> stimes (3 :: Int) space) mempty <>) + align = nest 2 . (flatAlt (line <> stimes (3 :: Int) space) mempty <>) Hole n _T -> - let _T' = getPrint (printSubject opts ctx _T) + let _T' = getPrint (print opts ctx _T) in fillSep [ reflow "found hole", pretty n, colon, _T' ] Invariant s -> reflow s MissingInterface i -> reflow "could not find required interface" <+> getPrint (printInterface opts ctx i) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index f15ff47f1..d9970f7f7 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -16,7 +16,6 @@ module Facet.Print , printInstantiation , suppressInstantiation -- * Core printers -, printSubject , printKind , printType , printInterface @@ -155,11 +154,6 @@ suppressInstantiation = const -- Core printers -printSubject :: Options -> Env Print -> TN.Classifier -> Print -printSubject opts env = \case - TN.CK k -> printKind env k - TN.CT t -> printType opts env t - printKind :: Env Print -> Kind -> Print printKind env = \case KType -> annotate Type $ pretty "Type" From f975f0e436948ebf679e527676100c6467a9efa5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 07:59:48 -0400 Subject: [PATCH 0251/1324] Define a Printable instance for Kind. --- src/Facet/Notice/Elab.hs | 8 ++++---- src/Facet/Print.hs | 24 ++++++++++++------------ src/Facet/REPL.hs | 2 +- 3 files changed, 17 insertions(+), 17 deletions(-) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 34ca759d2..bda3b4fff 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -41,14 +41,14 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) (_, _, printCtx, ctx) = foldl' combine (0, Env.empty, Env.empty, Nil) (elems context) subst' = map (\ (m :=: v) -> getPrint (Print.meta m <+> pretty '=' <+> maybe (pretty '?') (printType opts printCtx) v)) (metas subst) sig' = getPrint . printInterface opts printCtx . fmap (apply subst (toEnv context)) <$> (interfaces =<< sig) - combine (d, env, print, ctx) (m, p) = + combine (d, env, prints, ctx) (m, p) = let roundtrip = apply subst env binding (n ::: _T) = ann (intro n d ::: mult m (case _T of - CK _K -> printKind print _K - CT _T -> printType opts print (roundtrip _T))) + CK _K -> print opts prints _K + CT _T -> printType opts prints (roundtrip _T))) in ( succ d , env Env.|> ((\ (n ::: _T) -> n :=: free (LName d n)) <$> p) - , print Env.|> ((\ (n ::: _) -> n :=: intro n d) <$> p) + , prints Env.|> ((\ (n ::: _) -> n :=: intro n d) <$> p) , ctx :> getPrint (printPattern opts (binding <$> p)) ) mult m = if | m == zero -> (pretty "0" <+>) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index d9970f7f7..031fcbf42 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -16,7 +16,6 @@ module Facet.Print , printInstantiation , suppressInstantiation -- * Core printers -, printKind , printType , printInterface , printTExpr @@ -52,6 +51,7 @@ import Facet.Syntax import qualified Facet.Term as C import qualified Facet.Type.Expr as TX import qualified Facet.Type.Norm as TN +import Prelude hiding (print) import qualified Prettyprinter as PP import Silkscreen as P import Silkscreen.Printer.Prec hiding (Level) @@ -154,15 +154,6 @@ suppressInstantiation = const -- Core printers -printKind :: Env Print -> Kind -> Print -printKind env = \case - KType -> annotate Type $ pretty "Type" - KInterface -> annotate Type $ pretty "Interface" - KArrow Nothing a b -> printKind env a --> printKind env b - KArrow (Just n) a b -> parens (ann (intro n d ::: printKind env a)) --> printKind env b - where - d = level env - printType :: Options -> Env Print -> TN.Type -> Print printType opts env = printTExpr opts env . quote (level env) @@ -177,7 +168,7 @@ printTExpr opts@Options{ rname } = go TX.Var (Global n) -> qvar n TX.Var (Free (Right n)) -> fromMaybe (lname (indexToLevel d <$> n)) $ Env.lookup env n TX.Var (Free (Left m)) -> meta m - TX.ForAll n t b -> braces (ann (intro n d ::: printKind env t)) --> go (env |> PVar (n :=: intro n d)) b + TX.ForAll n t b -> braces (ann (intro n d ::: print opts env t)) --> go (env |> PVar (n :=: intro n d)) b TX.Arrow Nothing q a b -> mult q (go env a) --> go env b TX.Arrow (Just n) q a b -> parens (ann (intro n d ::: mult q (go env a))) --> go env b TX.Comp s t -> if s == mempty then go env t else sig s <+> go env t @@ -275,5 +266,14 @@ class Printable t where instance Printable TN.Classifier where print opts env = \case - TN.CK k -> printKind env k + TN.CK k -> print opts env k TN.CT t -> printType opts env t + +instance Printable Kind where + print opts env = \case + KType -> annotate Type $ pretty "Type" + KInterface -> annotate Type $ pretty "Interface" + KArrow Nothing a b -> print opts env a --> print opts env b + KArrow (Just n) a b -> parens (ann (intro n d ::: print opts env a)) --> print opts env b + where + d = level env diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index 602fc2b4c..bd8db5688 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -219,7 +219,7 @@ showKind :: S.Ann S.Type -> Action showKind _T = Action $ do _T ::: _K <- runElab $ Elab.elabSynthType (Elab.isType (Elab.synthType _T)) opts <- get - outputDocLn (getPrint (ann (printType opts mempty _T ::: printKind mempty _K))) + outputDocLn (getPrint (ann (printType opts mempty _T ::: Print.print opts mempty _K))) helpDoc :: Doc Style From 6044e3219118cc6ccbe44bb136071d4b51b26e54 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 08:01:45 -0400 Subject: [PATCH 0252/1324] Define a Printable1 class. --- src/Facet/Print.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 031fcbf42..a030101ba 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -29,6 +29,7 @@ module Facet.Print , meta -- * Printable , Printable(..) +, Printable1(..) ) where import Data.Foldable (foldl', toList) @@ -277,3 +278,7 @@ instance Printable Kind where KArrow (Just n) a b -> parens (ann (intro n d ::: print opts env a)) --> print opts env b where d = level env + + +class Printable1 f where + printWith :: (Options -> Env Print -> a -> Print) -> Options -> Env Print -> f a -> Print From 44161acfd472d94099747e8cd0325030e40e87ce Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 08:03:40 -0400 Subject: [PATCH 0253/1324] Define a Printable1 instance for Interface. --- src/Facet/Print.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index a030101ba..e697971ae 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -159,7 +159,7 @@ printType :: Options -> Env Print -> TN.Type -> Print printType opts env = printTExpr opts env . quote (level env) printInterface :: Options -> Env Print -> Interface TN.Type -> Print -printInterface = printInterfaceWith printType +printInterface = printWith printType printTExpr :: Options -> Env Print -> TX.Type -> Print printTExpr opts@Options{ rname } = go @@ -178,15 +178,12 @@ printTExpr opts@Options{ rname } = go where d = level env sig s = brackets (commaSep (map (interface env) (interfaces s))) - interface = printInterfaceWith printTExpr opts + interface = printWith printTExpr opts mult q = if | q == zero -> (pretty '0' <+>) | q == one -> (pretty '1' <+>) | otherwise -> id -printInterfaceWith :: (Options -> Env Print -> a -> Print) -> Options -> Env Print -> Interface a -> Print -printInterfaceWith with opts@Options{ rname } env (Interface h sp) = rname h $$* fmap (with opts env) sp - printNorm :: Options -> Env Print -> N.Norm -> Print printNorm opts env = printExpr opts env . quote (level env) @@ -282,3 +279,6 @@ instance Printable Kind where class Printable1 f where printWith :: (Options -> Env Print -> a -> Print) -> Options -> Env Print -> f a -> Print + +instance Printable1 Interface where + printWith with opts@Options{ rname } env (Interface h sp) = rname h $$* fmap (with opts env) sp From 35e9e88fec99f628fb42c585a9e7510439559ac7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 08:05:27 -0400 Subject: [PATCH 0254/1324] Lift Printable through Printable1. --- src/Facet/Print.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index e697971ae..8b443abab 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -30,6 +30,7 @@ module Facet.Print -- * Printable , Printable(..) , Printable1(..) +, print1 ) where import Data.Foldable (foldl', toList) @@ -282,3 +283,7 @@ class Printable1 f where instance Printable1 Interface where printWith with opts@Options{ rname } env (Interface h sp) = rname h $$* fmap (with opts env) sp + + +print1 :: (Printable1 f, Printable a) => Options -> Env Print -> f a -> Print +print1 = printWith print From 09b14edf0610661a349fd8ac3d3e4fab0ac58254 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 08:06:12 -0400 Subject: [PATCH 0255/1324] Define a Printable instance for Interface. --- src/Facet/Print.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 8b443abab..db3d3dd2c 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -277,6 +277,9 @@ instance Printable Kind where where d = level env +instance Printable a => Printable (Interface a) where + print = print1 + class Printable1 f where printWith :: (Options -> Env Print -> a -> Print) -> Options -> Env Print -> f a -> Print From b45fa1216aec410bd0c26beca86baa8adb86282f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 08:08:19 -0400 Subject: [PATCH 0256/1324] Print type expressions. --- src/Facet/Print.hs | 49 +++++++++++++++++++++++----------------------- 1 file changed, 24 insertions(+), 25 deletions(-) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index db3d3dd2c..7b3be1539 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -18,7 +18,6 @@ module Facet.Print -- * Core printers , printType , printInterface -, printTExpr , printNorm , printExpr , printPattern @@ -157,34 +156,11 @@ suppressInstantiation = const -- Core printers printType :: Options -> Env Print -> TN.Type -> Print -printType opts env = printTExpr opts env . quote (level env) +printType opts env = print opts env . quote (level env) printInterface :: Options -> Env Print -> Interface TN.Type -> Print printInterface = printWith printType -printTExpr :: Options -> Env Print -> TX.Type -> Print -printTExpr opts@Options{ rname } = go - where - qvar = group . setPrec Var . rname - go env = \case - TX.Var (Global n) -> qvar n - TX.Var (Free (Right n)) -> fromMaybe (lname (indexToLevel d <$> n)) $ Env.lookup env n - TX.Var (Free (Left m)) -> meta m - TX.ForAll n t b -> braces (ann (intro n d ::: print opts env t)) --> go (env |> PVar (n :=: intro n d)) b - TX.Arrow Nothing q a b -> mult q (go env a) --> go env b - TX.Arrow (Just n) q a b -> parens (ann (intro n d ::: mult q (go env a))) --> go env b - TX.Comp s t -> if s == mempty then go env t else sig s <+> go env t - TX.App f a -> group (go env f) $$ group (go env a) - TX.String -> annotate Type $ pretty "String" - where - d = level env - sig s = brackets (commaSep (map (interface env) (interfaces s))) - interface = printWith printTExpr opts - mult q = if - | q == zero -> (pretty '0' <+>) - | q == one -> (pretty '1' <+>) - | otherwise -> id - printNorm :: Options -> Env Print -> N.Norm -> Print printNorm opts env = printExpr opts env . quote (level env) @@ -280,6 +256,29 @@ instance Printable Kind where instance Printable a => Printable (Interface a) where print = print1 +instance Printable TX.Type where + print opts@Options{ rname } = go + where + qvar = group . setPrec Var . rname + go env = \case + TX.Var (Global n) -> qvar n + TX.Var (Free (Right n)) -> fromMaybe (lname (indexToLevel d <$> n)) $ Env.lookup env n + TX.Var (Free (Left m)) -> meta m + TX.ForAll n t b -> braces (ann (intro n d ::: print opts env t)) --> go (env |> PVar (n :=: intro n d)) b + TX.Arrow Nothing q a b -> mult q (go env a) --> go env b + TX.Arrow (Just n) q a b -> parens (ann (intro n d ::: mult q (go env a))) --> go env b + TX.Comp s t -> if s == mempty then go env t else sig s <+> go env t + TX.App f a -> group (go env f) $$ group (go env a) + TX.String -> annotate Type $ pretty "String" + where + d = level env + sig s = brackets (commaSep (map (interface env) (interfaces s))) + interface = printWith print opts + mult q = if + | q == zero -> (pretty '0' <+>) + | q == one -> (pretty '1' <+>) + | otherwise -> id + class Printable1 f where printWith :: (Options -> Env Print -> a -> Print) -> Options -> Env Print -> f a -> Print From f8674af1d75c101a536e77f0431b3787bb358e4f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 08:10:15 -0400 Subject: [PATCH 0257/1324] Define a Printable instance for Quoting. --- src/Facet/Print.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 7b3be1539..ee91272f6 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -239,6 +239,9 @@ name f n d = setPrec Var . annotate (Name d) $ class Printable t where print :: Options -> Env Print -> t -> Print +instance (Quote v t, Printable t) => Printable (Quoting t v) where + print opts env = print opts env . quote (level env) . getQuoting + instance Printable TN.Classifier where print opts env = \case TN.CK k -> print opts env k From 66ba14bb99e1b0477882ffa4bee204cd480039b8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 08:11:21 -0400 Subject: [PATCH 0258/1324] Derive a Printable instance for types. --- src/Facet/Print.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index ee91272f6..d29808ee9 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -282,6 +282,8 @@ instance Printable TX.Type where | q == one -> (pretty '1' <+>) | otherwise -> id +deriving via (Quoting TX.Type TN.Type) instance Printable TN.Type + class Printable1 f where printWith :: (Options -> Env Print -> a -> Print) -> Options -> Env Print -> f a -> Print From 7cfe3e18f44a781389c3692ef196129b03a558b9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 08:12:55 -0400 Subject: [PATCH 0259/1324] :fire: printType/printInterface. --- src/Facet/Notice/Elab.hs | 10 +++++----- src/Facet/Print.hs | 16 ++++------------ src/Facet/REPL.hs | 6 +++--- 3 files changed, 12 insertions(+), 20 deletions(-) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index bda3b4fff..275a82d8f 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -39,13 +39,13 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) ] where (_, _, printCtx, ctx) = foldl' combine (0, Env.empty, Env.empty, Nil) (elems context) - subst' = map (\ (m :=: v) -> getPrint (Print.meta m <+> pretty '=' <+> maybe (pretty '?') (printType opts printCtx) v)) (metas subst) - sig' = getPrint . printInterface opts printCtx . fmap (apply subst (toEnv context)) <$> (interfaces =<< sig) + subst' = map (\ (m :=: v) -> getPrint (Print.meta m <+> pretty '=' <+> maybe (pretty '?') (print opts printCtx) v)) (metas subst) + sig' = getPrint . print opts printCtx . fmap (apply subst (toEnv context)) <$> (interfaces =<< sig) combine (d, env, prints, ctx) (m, p) = let roundtrip = apply subst env binding (n ::: _T) = ann (intro n d ::: mult m (case _T of CK _K -> print opts prints _K - CT _T -> printType opts prints (roundtrip _T))) + CT _T -> print opts prints (roundtrip _T))) in ( succ d , env Env.|> ((\ (n ::: _T) -> n :=: free (LName d n)) <$> p) , prints Env.|> ((\ (n ::: _) -> n :=: intro n d) <$> p) @@ -75,7 +75,7 @@ printErrReason opts ctx = group . \case where reason = \case Mismatch -> pretty "mismatch" - Occurs v t -> reflow "infinite type:" <+> getPrint (printType opts ctx (metavar v)) <+> reflow "occurs in" <+> getPrint (print opts ctx t) + Occurs v t -> reflow "infinite type:" <+> getPrint (print opts ctx (metavar v)) <+> reflow "occurs in" <+> getPrint (print opts ctx t) exp' = either reflow (getPrint . print opts ctx) exp act' = getPrint (print opts ctx act) -- line things up nicely for e.g. wrapped function types @@ -84,7 +84,7 @@ printErrReason opts ctx = group . \case let _T' = getPrint (print opts ctx _T) in fillSep [ reflow "found hole", pretty n, colon, _T' ] Invariant s -> reflow s - MissingInterface i -> reflow "could not find required interface" <+> getPrint (printInterface opts ctx i) + MissingInterface i -> reflow "could not find required interface" <+> getPrint (print opts ctx i) rethrowElabWarnings :: L.WriteC (Notice (Doc Style)) Warn m a -> m a diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index d29808ee9..280f5ed2f 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -16,8 +16,6 @@ module Facet.Print , printInstantiation , suppressInstantiation -- * Core printers -, printType -, printInterface , printNorm , printExpr , printPattern @@ -155,12 +153,6 @@ suppressInstantiation = const -- Core printers -printType :: Options -> Env Print -> TN.Type -> Print -printType opts env = print opts env . quote (level env) - -printInterface :: Options -> Env Print -> Interface TN.Type -> Print -printInterface = printWith printType - printNorm :: Options -> Env Print -> N.Norm -> Print printNorm opts env = printExpr opts env . quote (level env) @@ -202,10 +194,10 @@ printModule (C.Module mname is _ ds) = module_ where def (n :=: d) = ann (qvar (Nil:.n) ::: d) defBody = \case - C.DTerm Nothing _T -> printType opts empty _T - C.DTerm (Just b) _T -> defn (printType opts empty _T :=: printExpr opts empty b) + C.DTerm Nothing _T -> print opts empty _T + C.DTerm (Just b) _T -> defn (print opts empty _T :=: printExpr opts empty b) C.DData cs _K -> annotate Keyword (pretty "data") <+> scope defBody cs - C.DInterface os _K -> annotate Keyword (pretty "interface") <+> scope (printType opts empty) os + C.DInterface os _K -> annotate Keyword (pretty "interface") <+> scope (print opts empty) os C.DModule ds _K -> block (concatWith (surround hardline) (map ((hardline <>) . def . fmap defBody) (C.scopeToList ds))) scope with = block . group . concatWith (surround (hardline <> comma <> space)) . map (group . def . fmap with) . C.scopeToList import' n = pretty "import" <+> braces (setPrec Var (prettyMName n)) @@ -245,7 +237,7 @@ instance (Quote v t, Printable t) => Printable (Quoting t v) where instance Printable TN.Classifier where print opts env = \case TN.CK k -> print opts env k - TN.CT t -> printType opts env t + TN.CT t -> print opts env t instance Printable Kind where print opts env = \case diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index bd8db5688..04150548c 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -196,13 +196,13 @@ showType, showEval :: S.Ann S.Expr -> Action showType e = Action $ do e ::: _T <- runElab $ Elab.elabSynthTerm (Elab.synth (Elab.synthExpr e)) opts <- get - outputDocLn (getPrint (ann (printExpr opts mempty e ::: printType opts mempty _T))) + outputDocLn (getPrint (ann (printExpr opts mempty e ::: Print.print opts mempty _T))) showEval e = Action $ do e' ::: _T <- runElab $ Elab.elabSynthTerm $ locally Elab.sig_ (I.singleton (I.Interface (["Effect", "Console"]:.:U "Output") Nil) :) $ Elab.synth (Elab.synthExpr e) e'' <- runElab $ runEvalMain e' opts <- get - outputDocLn (getPrint (ann (printExpr opts mempty e'' ::: printType opts mempty _T))) + outputDocLn (getPrint (ann (printExpr opts mempty e'' ::: Print.print opts mempty _T))) runEvalMain :: (Has (Error (Notice.Notice (Doc Style)) :+: Output :+: Reader Graph :+: Reader Module :+: State Options) sig m, MonadFail m) => Expr -> m Expr runEvalMain e = runEval (quote 0 =<< runReader mempty (eval e)) pure @@ -219,7 +219,7 @@ showKind :: S.Ann S.Type -> Action showKind _T = Action $ do _T ::: _K <- runElab $ Elab.elabSynthType (Elab.isType (Elab.synthType _T)) opts <- get - outputDocLn (getPrint (ann (printType opts mempty _T ::: Print.print opts mempty _K))) + outputDocLn (getPrint (ann (Print.print opts mempty _T ::: Print.print opts mempty _K))) helpDoc :: Doc Style From 0098a0e69cf148a410bde5d3811544c16bc4bcf4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 08:17:04 -0400 Subject: [PATCH 0260/1324] Define a Printable instance for expressions. --- src/Facet/Print.hs | 46 +++++++++++++++++++++++----------------------- src/Facet/REPL.hs | 4 ++-- 2 files changed, 25 insertions(+), 25 deletions(-) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 280f5ed2f..73ab03146 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -17,7 +17,6 @@ module Facet.Print , suppressInstantiation -- * Core printers , printNorm -, printExpr , printPattern , printModule -- * Misc @@ -154,27 +153,7 @@ suppressInstantiation = const -- Core printers printNorm :: Options -> Env Print -> N.Norm -> Print -printNorm opts env = printExpr opts env . quote (level env) - -printExpr :: Options -> Env Print -> C.Expr -> Print -printExpr opts@Options{ rname } = go - where - go env = \case - C.XVar (Global n) -> qvar n - C.XVar (Free n) -> fromMaybe (lname (indexToLevel d <$> n)) $ Env.lookup env n - C.XLam cs -> comp (commaSep (map (clause env) cs)) - C.XApp f a -> go env f $$ go env a - C.XCon n p -> qvar n $$* (group . go env <$> p) - C.XString s -> annotate Lit $ pretty (show s) - C.XDict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> rname n <+> equals <+> group (go env v)) os) <> flatAlt space line) - C.XLet p v b -> let p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) in pretty "let" <+> braces (printPattern opts (def <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p') b - C.XComp p b -> comp (clause env (PDict p, b)) - where - d = level env - qvar = group . setPrec Var . rname - clause env (p, b) = printPattern opts (def <$> p') <+> arrow <+> go (env |> p') b - where - p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) +printNorm opts env = print opts env . quote (level env) printPattern :: Options -> Pattern Print -> Print printPattern Options{ rname } = go @@ -195,7 +174,7 @@ printModule (C.Module mname is _ ds) = module_ def (n :=: d) = ann (qvar (Nil:.n) ::: d) defBody = \case C.DTerm Nothing _T -> print opts empty _T - C.DTerm (Just b) _T -> defn (print opts empty _T :=: printExpr opts empty b) + C.DTerm (Just b) _T -> defn (print opts empty _T :=: print opts empty b) C.DData cs _K -> annotate Keyword (pretty "data") <+> scope defBody cs C.DInterface os _K -> annotate Keyword (pretty "interface") <+> scope (print opts empty) os C.DModule ds _K -> block (concatWith (surround hardline) (map ((hardline <>) . def . fmap defBody) (C.scopeToList ds))) @@ -277,6 +256,27 @@ instance Printable TX.Type where deriving via (Quoting TX.Type TN.Type) instance Printable TN.Type +instance Printable C.Expr where + print opts@Options{ rname } = go + where + go env = \case + C.XVar (Global n) -> qvar n + C.XVar (Free n) -> fromMaybe (lname (indexToLevel d <$> n)) $ Env.lookup env n + C.XLam cs -> comp (commaSep (map (clause env) cs)) + C.XApp f a -> go env f $$ go env a + C.XCon n p -> qvar n $$* (group . go env <$> p) + C.XString s -> annotate Lit $ pretty (show s) + C.XDict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> rname n <+> equals <+> group (go env v)) os) <> flatAlt space line) + C.XLet p v b -> let p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) in pretty "let" <+> braces (printPattern opts (def <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p') b + C.XComp p b -> comp (clause env (PDict p, b)) + where + d = level env + qvar = group . setPrec Var . rname + clause env (p, b) = printPattern opts (def <$> p') <+> arrow <+> go (env |> p') b + where + p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) + + class Printable1 f where printWith :: (Options -> Env Print -> a -> Print) -> Options -> Env Print -> f a -> Print diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index 04150548c..8fc082593 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -196,13 +196,13 @@ showType, showEval :: S.Ann S.Expr -> Action showType e = Action $ do e ::: _T <- runElab $ Elab.elabSynthTerm (Elab.synth (Elab.synthExpr e)) opts <- get - outputDocLn (getPrint (ann (printExpr opts mempty e ::: Print.print opts mempty _T))) + outputDocLn (getPrint (ann (Print.print opts mempty e ::: Print.print opts mempty _T))) showEval e = Action $ do e' ::: _T <- runElab $ Elab.elabSynthTerm $ locally Elab.sig_ (I.singleton (I.Interface (["Effect", "Console"]:.:U "Output") Nil) :) $ Elab.synth (Elab.synthExpr e) e'' <- runElab $ runEvalMain e' opts <- get - outputDocLn (getPrint (ann (printExpr opts mempty e'' ::: Print.print opts mempty _T))) + outputDocLn (getPrint (ann (Print.print opts mempty e'' ::: Print.print opts mempty _T))) runEvalMain :: (Has (Error (Notice.Notice (Doc Style)) :+: Output :+: Reader Graph :+: Reader Module :+: State Options) sig m, MonadFail m) => Expr -> m Expr runEvalMain e = runEval (quote 0 =<< runReader mempty (eval e)) pure From 2de36a891c44989289cc1128b79571000c675c8e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 08:19:51 -0400 Subject: [PATCH 0261/1324] Derive a Printable instance for Norm. --- src/Facet/Print.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 73ab03146..29827d5ff 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -16,7 +16,6 @@ module Facet.Print , printInstantiation , suppressInstantiation -- * Core printers -, printNorm , printPattern , printModule -- * Misc @@ -152,9 +151,6 @@ suppressInstantiation = const -- Core printers -printNorm :: Options -> Env Print -> N.Norm -> Print -printNorm opts env = print opts env . quote (level env) - printPattern :: Options -> Pattern Print -> Print printPattern Options{ rname } = go where @@ -276,6 +272,8 @@ instance Printable C.Expr where where p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) +deriving via (Quoting C.Expr N.Norm) instance Printable N.Norm + class Printable1 f where printWith :: (Options -> Env Print -> a -> Print) -> Options -> Env Print -> f a -> Print From db032800b567a31c021c54994c8dd301e5a72fb3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 08:21:52 -0400 Subject: [PATCH 0262/1324] Define a Printable1 instance for Pattern. --- src/Facet/Print.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 29827d5ff..c1aa6ec79 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -281,6 +281,15 @@ class Printable1 f where instance Printable1 Interface where printWith with opts@Options{ rname } env (Interface h sp) = rname h $$* fmap (with opts env) sp +instance Printable1 Pattern where + printWith with opts@Options{ rname } env = go + where + go = \case + PWildcard -> pretty '_' + PVar n -> with opts env n + PCon n ps -> parens (annotate Con (rname n) $$* map go (toList ps)) + PDict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> rname n <+> equals <+> group (with opts env v)) os) <> flatAlt space line) + print1 :: (Printable1 f, Printable a) => Options -> Env Print -> f a -> Print print1 = printWith print From bbdffb32c67bf48b58ce0f978b751a6b11e5757a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 08:22:54 -0400 Subject: [PATCH 0263/1324] Define a Printable instance for Print. --- src/Facet/Print.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index c1aa6ec79..543783cd9 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -206,6 +206,9 @@ name f n d = setPrec Var . annotate (Name d) $ class Printable t where print :: Options -> Env Print -> t -> Print +instance Printable Print where + print _ _ = id + instance (Quote v t, Printable t) => Printable (Quoting t v) where print opts env = print opts env . quote (level env) . getQuoting From 3d42e75aaa56c5b80355f8b7af0f392300e97fbf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 08:25:20 -0400 Subject: [PATCH 0264/1324] Define a Printable instance for Pattern. --- src/Facet/Print.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 543783cd9..0192c2e7d 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -277,6 +277,9 @@ instance Printable C.Expr where deriving via (Quoting C.Expr N.Norm) instance Printable N.Norm +instance Printable a => Printable (Pattern a) where + print = print1 + class Printable1 f where printWith :: (Options -> Env Print -> a -> Print) -> Options -> Env Print -> f a -> Print From 7aba6784c4bcb7a314cf18905ce1208ff6768968 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 08:25:29 -0400 Subject: [PATCH 0265/1324] :fire: printPattern. --- src/Facet/Notice/Elab.hs | 2 +- src/Facet/Print.hs | 14 ++------------ 2 files changed, 3 insertions(+), 13 deletions(-) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 275a82d8f..cb888f7d0 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -49,7 +49,7 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) in ( succ d , env Env.|> ((\ (n ::: _T) -> n :=: free (LName d n)) <$> p) , prints Env.|> ((\ (n ::: _) -> n :=: intro n d) <$> p) - , ctx :> getPrint (printPattern opts (binding <$> p)) ) + , ctx :> getPrint (print opts prints (binding <$> p)) ) mult m = if | m == zero -> (pretty "0" <+>) | m == one -> (pretty "1" <+>) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 0192c2e7d..482e7637e 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -16,7 +16,6 @@ module Facet.Print , printInstantiation , suppressInstantiation -- * Core printers -, printPattern , printModule -- * Misc , intro @@ -151,15 +150,6 @@ suppressInstantiation = const -- Core printers -printPattern :: Options -> Pattern Print -> Print -printPattern Options{ rname } = go - where - go = \case - PWildcard -> pretty '_' - PVar n -> n - PCon n ps -> parens (annotate Con (rname n) $$* map go (toList ps)) - PDict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> rname n <+> equals <+> group v) os) <> flatAlt space line) - printModule :: C.Module -> Print printModule (C.Module mname is _ ds) = module_ mname @@ -266,12 +256,12 @@ instance Printable C.Expr where C.XCon n p -> qvar n $$* (group . go env <$> p) C.XString s -> annotate Lit $ pretty (show s) C.XDict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> rname n <+> equals <+> group (go env v)) os) <> flatAlt space line) - C.XLet p v b -> let p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) in pretty "let" <+> braces (printPattern opts (def <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p') b + C.XLet p v b -> let p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) in pretty "let" <+> braces (print opts env (def <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p') b C.XComp p b -> comp (clause env (PDict p, b)) where d = level env qvar = group . setPrec Var . rname - clause env (p, b) = printPattern opts (def <$> p') <+> arrow <+> go (env |> p') b + clause env (p, b) = print opts env (def <$> p') <+> arrow <+> go (env |> p') b where p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) From af596a78a0d8281b4b5424d417e3320135ffd4cd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 08:28:31 -0400 Subject: [PATCH 0266/1324] Define a Printable instance for Module. --- src/Facet/Print.hs | 44 ++++++++++++++++++++------------------------ 1 file changed, 20 insertions(+), 24 deletions(-) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 482e7637e..5e8ebafe2 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -15,8 +15,6 @@ module Facet.Print , unqualified , printInstantiation , suppressInstantiation - -- * Core printers -, printModule -- * Misc , intro , tintro @@ -148,28 +146,6 @@ printInstantiation = ($$) suppressInstantiation = const --- Core printers - -printModule :: C.Module -> Print -printModule (C.Module mname is _ ds) = module_ - mname - (qvar (fromList [U (T.pack "Kernel")]:.U (T.pack "Module"))) - (map (\ (C.Import n) -> import' n) is) - (map (def . fmap defBody) (C.scopeToList ds)) - where - def (n :=: d) = ann (qvar (Nil:.n) ::: d) - defBody = \case - C.DTerm Nothing _T -> print opts empty _T - C.DTerm (Just b) _T -> defn (print opts empty _T :=: print opts empty b) - C.DData cs _K -> annotate Keyword (pretty "data") <+> scope defBody cs - C.DInterface os _K -> annotate Keyword (pretty "interface") <+> scope (print opts empty) os - C.DModule ds _K -> block (concatWith (surround hardline) (map ((hardline <>) . def . fmap defBody) (C.scopeToList ds))) - scope with = block . group . concatWith (surround (hardline <> comma <> space)) . map (group . def . fmap with) . C.scopeToList - import' n = pretty "import" <+> braces (setPrec Var (prettyMName n)) - module_ n t is ds = ann (setPrec Var (prettyMName n) ::: t) concatWith (surround hardline) (is ++ map (hardline <>) ds) - defn (a :=: b) = group a <> hardline <> group b - opts = quietOptions - intro, tintro :: Name -> Level -> Print intro n = name lower n . getLevel tintro n = name upper n . getLevel @@ -271,6 +247,26 @@ instance Printable a => Printable (Pattern a) where print = print1 +instance Printable C.Module where + print opts env (C.Module mname is _ ds) = module_ + mname + (qvar (fromList [U (T.pack "Kernel")]:.U (T.pack "Module"))) + (map (\ (C.Import n) -> import' n) is) + (map (def . fmap defBody) (C.scopeToList ds)) + where + def (n :=: d) = ann (qvar (Nil:.n) ::: d) + defBody = \case + C.DTerm Nothing _T -> print opts env _T + C.DTerm (Just b) _T -> defn (print opts env _T :=: print opts env b) + C.DData cs _K -> annotate Keyword (pretty "data") <+> scope defBody cs + C.DInterface os _K -> annotate Keyword (pretty "interface") <+> scope (print opts env) os + C.DModule ds _K -> block (concatWith (surround hardline) (map ((hardline <>) . def . fmap defBody) (C.scopeToList ds))) + scope with = block . group . concatWith (surround (hardline <> comma <> space)) . map (group . def . fmap with) . C.scopeToList + import' n = pretty "import" <+> braces (setPrec Var (prettyMName n)) + module_ n t is ds = ann (setPrec Var (prettyMName n) ::: t) concatWith (surround hardline) (is ++ map (hardline <>) ds) + defn (a :=: b) = group a <> hardline <> group b + + class Printable1 f where printWith :: (Options -> Env Print -> a -> Print) -> Options -> Env Print -> f a -> Print From 2c5424ff551c6a57fe64005bdc123c9dadf0d126 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 19:17:17 -0400 Subject: [PATCH 0267/1324] This is no longer used. --- script/ghci-flags-dependencies | 10 ---------- 1 file changed, 10 deletions(-) delete mode 100755 script/ghci-flags-dependencies diff --git a/script/ghci-flags-dependencies b/script/ghci-flags-dependencies deleted file mode 100755 index 1a5f25070..000000000 --- a/script/ghci-flags-dependencies +++ /dev/null @@ -1,10 +0,0 @@ -#!/bin/bash -# Computes the paths to files causing changes to the ghci flags. You probably won’t be running this yourself, but rather ghcide will via configuration in hie.yaml. - -set -e - -cd $(dirname "$0")/.. - -echo "cabal.project" - -echo "facet.cabal" From 349f9f45843cf1285ab568f2a0ad60c3562c2c22 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 19:26:12 -0400 Subject: [PATCH 0268/1324] Define a module for a synth functor. --- facet.cabal | 1 + src/Facet/Functor/Synth.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Functor/Synth.hs diff --git a/facet.cabal b/facet.cabal index 4ab8b9787..e0fba0b09 100644 --- a/facet.cabal +++ b/facet.cabal @@ -89,6 +89,7 @@ library Facet.Eval Facet.Flag Facet.Format + Facet.Functor.Synth Facet.Graph Facet.Interface Facet.Kind diff --git a/src/Facet/Functor/Synth.hs b/src/Facet/Functor/Synth.hs new file mode 100644 index 000000000..002368110 --- /dev/null +++ b/src/Facet/Functor/Synth.hs @@ -0,0 +1,2 @@ +module Facet.Functor.Synth +() where From dff7f62287f038f8bc8b8344710981349a8bcf8e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 19:27:05 -0400 Subject: [PATCH 0269/1324] Define a synthesis judgement functor. --- src/Facet/Functor/Synth.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/Facet/Functor/Synth.hs b/src/Facet/Functor/Synth.hs index 002368110..1d414745a 100644 --- a/src/Facet/Functor/Synth.hs +++ b/src/Facet/Functor/Synth.hs @@ -1,2 +1,12 @@ module Facet.Functor.Synth -() where +( -- * Synth judgement + Synth(..) +) where + +import Facet.Type.Norm + +-- Synth judgement + +data Synth a = a :==> Type + +infixr 2 :==> From f547d41d5a8d275d6bf40988eae5abf9e5c50134 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 19:27:23 -0400 Subject: [PATCH 0270/1324] Derive some instances. --- src/Facet/Functor/Synth.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Functor/Synth.hs b/src/Facet/Functor/Synth.hs index 1d414745a..2399371d2 100644 --- a/src/Facet/Functor/Synth.hs +++ b/src/Facet/Functor/Synth.hs @@ -8,5 +8,6 @@ import Facet.Type.Norm -- Synth judgement data Synth a = a :==> Type + deriving (Foldable, Functor, Traversable) infixr 2 :==> From 9f0edcaefa50937c0e12296b45c91878feb9eaa1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 19:28:22 -0400 Subject: [PATCH 0271/1324] Define a module for a checking judgement functor. --- facet.cabal | 1 + src/Facet/Functor/Check.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Functor/Check.hs diff --git a/facet.cabal b/facet.cabal index e0fba0b09..494671f2f 100644 --- a/facet.cabal +++ b/facet.cabal @@ -89,6 +89,7 @@ library Facet.Eval Facet.Flag Facet.Format + Facet.Functor.Check Facet.Functor.Synth Facet.Graph Facet.Interface diff --git a/src/Facet/Functor/Check.hs b/src/Facet/Functor/Check.hs new file mode 100644 index 000000000..0620de0ba --- /dev/null +++ b/src/Facet/Functor/Check.hs @@ -0,0 +1,2 @@ +module Facet.Functor.Check +() where From 8a2cd56aa92f4d909b0c3d4f955b538ef2a7ac62 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 19:29:22 -0400 Subject: [PATCH 0272/1324] Define a checking judgement functor. --- src/Facet/Functor/Check.hs | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/src/Facet/Functor/Check.hs b/src/Facet/Functor/Check.hs index 0620de0ba..08d8a6688 100644 --- a/src/Facet/Functor/Check.hs +++ b/src/Facet/Functor/Check.hs @@ -1,2 +1,16 @@ module Facet.Functor.Check -() where +( -- * Check judgement + Check(..) +, (<==:) +) where + +import Facet.Type.Norm + +-- Check judgement + +newtype Check a = Check (Type -> a) + +(<==:) :: Check a -> Type -> a +Check f <==: _T = f _T + +infixl 2 <==: From 1dae68fd3b24ec1e52d2d943fcafdf32e87e826c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 19:29:35 -0400 Subject: [PATCH 0273/1324] Derive some instances. --- src/Facet/Functor/Check.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Functor/Check.hs b/src/Facet/Functor/Check.hs index 08d8a6688..4d3a6c7ca 100644 --- a/src/Facet/Functor/Check.hs +++ b/src/Facet/Functor/Check.hs @@ -9,6 +9,7 @@ import Facet.Type.Norm -- Check judgement newtype Check a = Check (Type -> a) + deriving (Applicative, Functor, Monad) (<==:) :: Check a -> Type -> a Check f <==: _T = f _T From 4f2b4f74957b2fad4bdd167ac8501f34499cd24c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 19:34:44 -0400 Subject: [PATCH 0274/1324] Use the synth functor for synthesis stuff. --- src/Facet/Elab.hs | 5 +++-- src/Facet/Elab/Term.hs | 25 +++++++++++++------------ src/Facet/REPL.hs | 5 +++-- 3 files changed, 19 insertions(+), 16 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index bf244313a..da8daa4b4 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -63,6 +63,7 @@ import Facet.Context hiding (empty) import qualified Facet.Context as Context (empty) import Facet.Effect.Write import qualified Facet.Env as Env +import Facet.Functor.Synth import Facet.Graph as Graph import Facet.Interface import Facet.Kind @@ -335,8 +336,8 @@ elabType = elabWith zero (\ subst t -> pure (TN.eval subst Env.empty t)) elabTerm :: Has (Reader Graph :+: Reader Module :+: Reader Source) sig m => Elab m Expr -> m Expr elabTerm = elabWith one (const pure) -elabSynthTerm :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (Expr ::: Type) -> m (Expr ::: Type) -elabSynthTerm = elabWith one (\ subst (e ::: _T) -> pure (e ::: TN.eval subst Env.empty (quote 0 _T))) +elabSynthTerm :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (Synth Expr) -> m (Synth Expr) +elabSynthTerm = elabWith one (\ subst (e :==> _T) -> pure (e :==> TN.eval subst Env.empty (quote 0 _T))) elabSynthType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (TX.Type ::: Kind) -> m (Type ::: Kind) elabSynthType = elabWith zero (\ subst (_T ::: _K) -> pure (TN.eval subst Env.empty _T ::: _K)) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index de6b6d85f..fbf2efab9 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -62,6 +62,7 @@ import Facet.Context (toEnv) import Facet.Effect.Write import Facet.Elab import Facet.Elab.Type +import qualified Facet.Functor.Synth as S import Facet.Graph import Facet.Interface import Facet.Kind @@ -87,28 +88,28 @@ import GHC.Stack switch :: (HasCallStack, Has (Throw Err) sig m) => Synth m a -> Check m a switch (Synth m) = Check $ \ _Exp -> m >>= \case - a ::: T.Comp req _Act -> require req >> unify (Exp _Exp) (Act _Act) $> a - a ::: _Act -> unify (Exp _Exp) (Act _Act) $> a + a S.:==> T.Comp req _Act -> require req >> unify (Exp _Exp) (Act _Act) $> a + a S.:==> _Act -> unify (Exp _Exp) (Act _Act) $> a as :: (HasCallStack, Has (Throw Err) sig m) => Check m Expr ::: IsType m Type -> Synth m Expr as (m ::: _T) = Synth $ do _T' <- checkIsType (_T ::: KType) a <- check (m ::: _T') - pure $ a ::: _T' + pure $ a S.:==> _T' -- Term combinators -- FIXME: we’re instantiating when inspecting types in the REPL. global :: Algebra sig m => RName ::: Type -> Synth m Expr -global (q ::: _T) = Synth $ instantiate const (XVar (Global q) ::: _T) +global (q ::: _T) = Synth $ (\ (v ::: _T) -> v S.:==> _T) <$> instantiate const (XVar (Global q) ::: _T) -- FIXME: do we need to instantiate here to deal with rank-n applications? -- FIXME: effect ops not in the sig are reported as not in scope -- FIXME: effect ops in the sig are available whether or not they’re in scope var :: (HasCallStack, Has (Throw Err) sig m) => QName -> Synth m Expr var n = Synth $ views context_ (lookupInContext n) >>= \case - [(n', q, CT _T)] -> use n' q $> (XVar (Free n') ::: _T) + [(n', q, CT _T)] -> use n' q $> (XVar (Free n') S.:==> _T) _ -> resolveQ n >>= \case n :=: DTerm _ _T -> synth $ global (n ::: _T) _ :=: _ -> freeVariable n @@ -134,19 +135,19 @@ lam1 p b = lam [(p, b)] app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Synth m a) -> (HasCallStack => Check m b) -> Synth m c app mk operator operand = Synth $ do - f' ::: _F <- synth operator + f' S.:==> _F <- synth operator (_ ::: (q, _A), _B) <- assertFunction _F a' <- censor @Usage (q ><<) $ check (operand ::: _A) - pure $ mk f' a' ::: _B + pure $ mk f' a' S.:==> _B string :: Text -> Synth m Expr -string s = Synth $ pure $ XString s ::: T.String +string s = Synth $ pure $ XString s S.:==> T.String let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Synth m Expr -> Check m Expr -> Check m Expr let' p a b = Check $ \ _B -> do - a' ::: _A <- synth a + a' S.:==> _A <- synth a (p', b') <- bind (p ::: (Many, _A)) (check (b ::: _B)) pure $ XLet p' a' b' @@ -419,12 +420,12 @@ mapCheck :: (Elab m a -> Elab m b) -> Check m a -> Check m b mapCheck f m = Check $ \ _T -> f (runCheck m _T) -newtype Synth m a = Synth { synth :: Elab m (a ::: Type) } +newtype Synth m a = Synth { synth :: Elab m (S.Synth a) } instance Functor (Synth m) where - fmap f (Synth m) = Synth (first f <$> m) + fmap f (Synth m) = Synth (fmap f <$> m) -mapSynth :: (Elab m (a ::: Type) -> Elab m (b ::: Type)) -> Synth m a -> Synth m b +mapSynth :: (Elab m (S.Synth a) -> Elab m (S.Synth b)) -> Synth m a -> Synth m b mapSynth f = Synth . f . synth diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index 8fc082593..3a6e78f44 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -34,6 +34,7 @@ import qualified Facet.Elab as Elab import qualified Facet.Elab.Term as Elab import qualified Facet.Elab.Type as Elab import Facet.Eval as E +import Facet.Functor.Synth import Facet.Graph import Facet.Interface as I import Facet.Lens @@ -194,12 +195,12 @@ removeTarget targets = Action $ target_.targets_ %= (Set.\\ Set.fromList targets showType, showEval :: S.Ann S.Expr -> Action showType e = Action $ do - e ::: _T <- runElab $ Elab.elabSynthTerm (Elab.synth (Elab.synthExpr e)) + e :==> _T <- runElab $ Elab.elabSynthTerm (Elab.synth (Elab.synthExpr e)) opts <- get outputDocLn (getPrint (ann (Print.print opts mempty e ::: Print.print opts mempty _T))) showEval e = Action $ do - e' ::: _T <- runElab $ Elab.elabSynthTerm $ locally Elab.sig_ (I.singleton (I.Interface (["Effect", "Console"]:.:U "Output") Nil) :) $ Elab.synth (Elab.synthExpr e) + e' :==> _T <- runElab $ Elab.elabSynthTerm $ locally Elab.sig_ (I.singleton (I.Interface (["Effect", "Console"]:.:U "Output") Nil) :) $ Elab.synth (Elab.synthExpr e) e'' <- runElab $ runEvalMain e' opts <- get outputDocLn (getPrint (ann (Print.print opts mempty e'' ::: Print.print opts mempty _T))) From 9df514edb66fb51314e5a877da6bbce45af975b9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 19:36:34 -0400 Subject: [PATCH 0275/1324] Use the check functor for checking rules. --- src/Facet/Elab/Term.hs | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index fbf2efab9..573a87a0c 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -62,6 +62,7 @@ import Facet.Context (toEnv) import Facet.Effect.Write import Facet.Elab import Facet.Elab.Type +import qualified Facet.Functor.Check as C import qualified Facet.Functor.Synth as S import Facet.Graph import Facet.Interface @@ -87,7 +88,7 @@ import GHC.Stack -- General combinators switch :: (HasCallStack, Has (Throw Err) sig m) => Synth m a -> Check m a -switch (Synth m) = Check $ \ _Exp -> m >>= \case +switch (Synth m) = Check $ C.Check $ \ _Exp -> m >>= \case a S.:==> T.Comp req _Act -> require req >> unify (Exp _Exp) (Act _Act) $> a a S.:==> _Act -> unify (Exp _Exp) (Act _Act) $> a @@ -116,17 +117,17 @@ var n = Synth $ views context_ (lookupInContext n) >>= \case hole :: (HasCallStack, Has (Throw Err) sig m) => Name -> Check m a -hole n = Check $ \ _T -> withFrozenCallStack $ err $ Hole n (CT _T) +hole n = Check $ C.Check $ \ _T -> withFrozenCallStack $ err $ Hole n (CT _T) tlam :: (HasCallStack, Has (Throw Err) sig m) => Check m Expr -> Check m Expr -tlam b = Check $ \ _T -> do +tlam b = Check $ C.Check $ \ _T -> do (n ::: _A, _B) <- assertQuantifier _T d <- depth (zero, PVar (n ::: CK _A)) |- check (b ::: _B (T.free (LName d n))) lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern (Name ::: Classifier)), Check m Expr)] -> Check m Expr -lam cs = Check $ \ _T -> do +lam cs = Check $ C.Check $ \ _T -> do (_A, _B) <- assertTacitFunction _T XLam <$> traverse (\ (p, b) -> bind (p ::: _A) (check (b ::: _B))) cs @@ -146,14 +147,14 @@ string s = Synth $ pure $ XString s S.:==> T.String let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Synth m Expr -> Check m Expr -> Check m Expr -let' p a b = Check $ \ _B -> do +let' p a b = Check $ C.Check $ \ _B -> do a' S.:==> _A <- synth a (p', b') <- bind (p ::: (Many, _A)) (check (b ::: _B)) pure $ XLet p' a' b' comp :: Has (Throw Err) sig m => Check m Expr -> Check m Expr -comp b = Check $ \ _T -> do +comp b = Check $ C.Check $ \ _T -> do (sig, _B) <- assertComp _T StaticContext{ graph, module' } <- ask let interfacePattern :: Has (Throw Err) sig m => Interface Type -> Elab m (RName :=: (Name ::: Classifier)) @@ -256,7 +257,7 @@ abstractType body = go abstractTerm :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => (Snoc TX.Type -> Snoc Expr -> Expr) -> Check m Expr abstractTerm body = go Nil Nil where - go ts fs = Check $ \case + go ts fs = Check $ C.Check $ \case T.ForAll n _T _B -> do d <- depth check (tlam (go (ts :> LName d n) fs) ::: T.ForAll n _T _B) @@ -311,7 +312,7 @@ elabTermDef elabTermDef _T expr@(S.Ann s _ _) = do elabTerm $ pushSpan s $ check (go (checkExpr expr) ::: _T) where - go k = Check $ \ _T -> case _T of + go k = Check $ C.Check $ \ _T -> case _T of T.ForAll{} -> check (tlam (go k) ::: _T) T.Arrow (Just n) q _A _B -> check (lam [(varP n, go k)] ::: T.Arrow Nothing q _A _B) -- FIXME: this doesn’t do what we want for tacit definitions, i.e. where _T is itself a telescope. @@ -410,14 +411,14 @@ findMaybeM p = getAp . fmap getFirst . foldMap (Ap . fmap First . p) check :: Algebra sig m => (Check m a ::: Type) -> Elab m a check (m ::: _T) = case _T of - T.Comp sig _T -> provide sig $ runCheck m _T - _T -> runCheck m _T + T.Comp sig _T -> provide sig $ runCheck m C.<==: _T + _T -> runCheck m C.<==: _T -newtype Check m a = Check { runCheck :: Type -> Elab m a } +newtype Check m a = Check { runCheck :: C.Check (Elab m a) } deriving (Applicative, Functor) via ReaderC Type (Elab m) mapCheck :: (Elab m a -> Elab m b) -> Check m a -> Check m b -mapCheck f m = Check $ \ _T -> f (runCheck m _T) +mapCheck f m = Check $ C.Check $ \ _T -> f (runCheck m C.<==: _T) newtype Synth m a = Synth { synth :: Elab m (S.Synth a) } From a431d620886cd24db752e04bbdb780498a93448c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 19:39:04 -0400 Subject: [PATCH 0276/1324] Replace the Check judgement with the functor. --- src/Facet/Elab/Term.hs | 59 ++++++++++++++++++++---------------------- 1 file changed, 28 insertions(+), 31 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 573a87a0c..aa56ddf33 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -62,7 +62,7 @@ import Facet.Context (toEnv) import Facet.Effect.Write import Facet.Elab import Facet.Elab.Type -import qualified Facet.Functor.Check as C +import Facet.Functor.Check import qualified Facet.Functor.Synth as S import Facet.Graph import Facet.Interface @@ -87,12 +87,12 @@ import GHC.Stack -- General combinators -switch :: (HasCallStack, Has (Throw Err) sig m) => Synth m a -> Check m a -switch (Synth m) = Check $ C.Check $ \ _Exp -> m >>= \case +switch :: (HasCallStack, Has (Throw Err) sig m) => Synth m a -> Check (Elab m a) +switch (Synth m) = Check $ \ _Exp -> m >>= \case a S.:==> T.Comp req _Act -> require req >> unify (Exp _Exp) (Act _Act) $> a a S.:==> _Act -> unify (Exp _Exp) (Act _Act) $> a -as :: (HasCallStack, Has (Throw Err) sig m) => Check m Expr ::: IsType m Type -> Synth m Expr +as :: (HasCallStack, Has (Throw Err) sig m) => Check (Elab m Expr) ::: IsType m Type -> Synth m Expr as (m ::: _T) = Synth $ do _T' <- checkIsType (_T ::: KType) a <- check (m ::: _T') @@ -116,25 +116,25 @@ var n = Synth $ views context_ (lookupInContext n) >>= \case _ :=: _ -> freeVariable n -hole :: (HasCallStack, Has (Throw Err) sig m) => Name -> Check m a -hole n = Check $ C.Check $ \ _T -> withFrozenCallStack $ err $ Hole n (CT _T) +hole :: (HasCallStack, Has (Throw Err) sig m) => Name -> Check (Elab m a) +hole n = Check $ \ _T -> withFrozenCallStack $ err $ Hole n (CT _T) -tlam :: (HasCallStack, Has (Throw Err) sig m) => Check m Expr -> Check m Expr -tlam b = Check $ C.Check $ \ _T -> do +tlam :: (HasCallStack, Has (Throw Err) sig m) => Check (Elab m Expr) -> Check (Elab m Expr) +tlam b = Check $ \ _T -> do (n ::: _A, _B) <- assertQuantifier _T d <- depth (zero, PVar (n ::: CK _A)) |- check (b ::: _B (T.free (LName d n))) -lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern (Name ::: Classifier)), Check m Expr)] -> Check m Expr -lam cs = Check $ C.Check $ \ _T -> do +lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern (Name ::: Classifier)), Check (Elab m Expr))] -> Check (Elab m Expr) +lam cs = Check $ \ _T -> do (_A, _B) <- assertTacitFunction _T XLam <$> traverse (\ (p, b) -> bind (p ::: _A) (check (b ::: _B))) cs -lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Check m Expr -> Check m Expr +lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Check (Elab m Expr) -> Check (Elab m Expr) lam1 p b = lam [(p, b)] -app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Synth m a) -> (HasCallStack => Check m b) -> Synth m c +app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Synth m a) -> (HasCallStack => Check (Elab m b)) -> Synth m c app mk operator operand = Synth $ do f' S.:==> _F <- synth operator (_ ::: (q, _A), _B) <- assertFunction _F @@ -146,15 +146,15 @@ string :: Text -> Synth m Expr string s = Synth $ pure $ XString s S.:==> T.String -let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Synth m Expr -> Check m Expr -> Check m Expr -let' p a b = Check $ C.Check $ \ _B -> do +let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Synth m Expr -> Check (Elab m Expr) -> Check (Elab m Expr) +let' p a b = Check $ \ _B -> do a' S.:==> _A <- synth a (p', b') <- bind (p ::: (Many, _A)) (check (b ::: _B)) pure $ XLet p' a' b' -comp :: Has (Throw Err) sig m => Check m Expr -> Check m Expr -comp b = Check $ C.Check $ \ _T -> do +comp :: Has (Throw Err) sig m => Check (Elab m Expr) -> Check (Elab m Expr) +comp b = Check $ \ _T -> do (sig, _B) <- assertComp _T StaticContext{ graph, module' } <- ask let interfacePattern :: Has (Throw Err) sig m => Interface Type -> Elab m (RName :=: (Name ::: Classifier)) @@ -217,7 +217,7 @@ synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanS $ \ca synthAs t _T = as (checkExpr t ::: mapIsType (>>= (\ (_T ::: _K) -> (::: _K) <$> evalTExpr _T)) (synthType _T)) -checkExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Check m Expr +checkExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Check (Elab m Expr) checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in flip withSpanC expr $ \case S.Hole n -> hole n S.Lam cs -> checkLam cs @@ -226,10 +226,10 @@ checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in flip withS S.As{} -> switch (synthExpr expr) S.String{} -> switch (synthExpr expr) -checkLam :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => [S.Clause] -> Check m Expr +checkLam :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => [S.Clause] -> Check (Elab m Expr) checkLam cs = lam (snd vs) where - vs :: Has (Throw Err :+: Write Warn) sig m => ([QName :=: Check m Expr], [(Bind m (Pattern (Name ::: Classifier)), Check m Expr)]) + vs :: Has (Throw Err :+: Write Warn) sig m => ([QName :=: Check (Elab m Expr)], [(Bind m (Pattern (Name ::: Classifier)), Check (Elab m Expr))]) vs = partitionEithers (map (\ (S.Clause (S.Ann _ _ p) b) -> case p of S.PVal p -> Right (bindPattern p, checkExpr b) S.PEff (S.Ann s _ (S.POp n fs k)) -> Left $ n :=: mapCheck (pushSpan s) (foldr (lam1 . bindPattern) (checkExpr b) (fromList fs:>k))) cs) @@ -254,10 +254,10 @@ abstractType body = go KArrow (Just n) a b -> TX.ForAll n a <$> ((zero, PVar (n ::: CK a)) |- go b) _ -> body -abstractTerm :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => (Snoc TX.Type -> Snoc Expr -> Expr) -> Check m Expr +abstractTerm :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => (Snoc TX.Type -> Snoc Expr -> Expr) -> Check (Elab m Expr) abstractTerm body = go Nil Nil where - go ts fs = Check $ C.Check $ \case + go ts fs = Check $ \case T.ForAll n _T _B -> do d <- depth check (tlam (go (ts :> LName d n) fs) ::: T.ForAll n _T _B) @@ -312,7 +312,7 @@ elabTermDef elabTermDef _T expr@(S.Ann s _ _) = do elabTerm $ pushSpan s $ check (go (checkExpr expr) ::: _T) where - go k = Check $ C.Check $ \ _T -> case _T of + go k = Check $ \ _T -> case _T of T.ForAll{} -> check (tlam (go k) ::: _T) T.Arrow (Just n) q _A _B -> check (lam [(varP n, go k)] ::: T.Arrow Nothing q _A _B) -- FIXME: this doesn’t do what we want for tacit definitions, i.e. where _T is itself a telescope. @@ -384,7 +384,7 @@ runModule m = do withSpanB :: Algebra sig m => (a -> Bind m b) -> S.Ann a -> Bind m b withSpanB k (S.Ann s _ a) = mapBind (pushSpan s) (k a) -withSpanC :: Algebra sig m => (a -> Check m b) -> S.Ann a -> Check m b +withSpanC :: Algebra sig m => (a -> Check (Elab m b)) -> S.Ann a -> Check (Elab m b) withSpanC k (S.Ann s _ a) = mapCheck (pushSpan s) (k a) withSpanS :: Algebra sig m => (a -> Synth m b) -> S.Ann a -> Synth m b @@ -409,16 +409,13 @@ findMaybeM p = getAp . fmap getFirst . foldMap (Ap . fmap First . p) -- Judgements -check :: Algebra sig m => (Check m a ::: Type) -> Elab m a +check :: Algebra sig m => (Check (Elab m a) ::: Type) -> Elab m a check (m ::: _T) = case _T of - T.Comp sig _T -> provide sig $ runCheck m C.<==: _T - _T -> runCheck m C.<==: _T + T.Comp sig _T -> provide sig $ m <==: _T + _T -> m <==: _T -newtype Check m a = Check { runCheck :: C.Check (Elab m a) } - deriving (Applicative, Functor) via ReaderC Type (Elab m) - -mapCheck :: (Elab m a -> Elab m b) -> Check m a -> Check m b -mapCheck f m = Check $ C.Check $ \ _T -> f (runCheck m C.<==: _T) +mapCheck :: (Elab m a -> Elab m b) -> Check (Elab m a) -> Check (Elab m b) +mapCheck f m = Check $ \ _T -> f (m <==: _T) newtype Synth m a = Synth { synth :: Elab m (S.Synth a) } From a916d239e51e844aa3308b772e9e7eb881267f10 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 19:43:39 -0400 Subject: [PATCH 0277/1324] :fire: Synth. --- src/Facet/Elab/Term.hs | 66 ++++++++++++++++++------------------------ src/Facet/REPL.hs | 4 +-- 2 files changed, 30 insertions(+), 40 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index aa56ddf33..7d253f593 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -36,7 +36,6 @@ module Facet.Elab.Term , Check(..) , mapCheck , Synth(..) -, mapSynth , bind , Bind(..) , mapBind @@ -63,7 +62,7 @@ import Facet.Effect.Write import Facet.Elab import Facet.Elab.Type import Facet.Functor.Check -import qualified Facet.Functor.Synth as S +import Facet.Functor.Synth import Facet.Graph import Facet.Interface import Facet.Kind @@ -87,32 +86,32 @@ import GHC.Stack -- General combinators -switch :: (HasCallStack, Has (Throw Err) sig m) => Synth m a -> Check (Elab m a) -switch (Synth m) = Check $ \ _Exp -> m >>= \case - a S.:==> T.Comp req _Act -> require req >> unify (Exp _Exp) (Act _Act) $> a - a S.:==> _Act -> unify (Exp _Exp) (Act _Act) $> a +switch :: (HasCallStack, Has (Throw Err) sig m) => Elab m (Synth a) -> Check (Elab m a) +switch m = Check $ \ _Exp -> m >>= \case + a :==> T.Comp req _Act -> require req >> unify (Exp _Exp) (Act _Act) $> a + a :==> _Act -> unify (Exp _Exp) (Act _Act) $> a -as :: (HasCallStack, Has (Throw Err) sig m) => Check (Elab m Expr) ::: IsType m Type -> Synth m Expr -as (m ::: _T) = Synth $ do +as :: (HasCallStack, Has (Throw Err) sig m) => Check (Elab m Expr) ::: IsType m Type -> Elab m (Synth Expr) +as (m ::: _T) = do _T' <- checkIsType (_T ::: KType) a <- check (m ::: _T') - pure $ a S.:==> _T' + pure $ a :==> _T' -- Term combinators -- FIXME: we’re instantiating when inspecting types in the REPL. -global :: Algebra sig m => RName ::: Type -> Synth m Expr -global (q ::: _T) = Synth $ (\ (v ::: _T) -> v S.:==> _T) <$> instantiate const (XVar (Global q) ::: _T) +global :: Algebra sig m => RName ::: Type -> Elab m (Synth Expr) +global (q ::: _T) = (\ (v ::: _T) -> v :==> _T) <$> instantiate const (XVar (Global q) ::: _T) -- FIXME: do we need to instantiate here to deal with rank-n applications? -- FIXME: effect ops not in the sig are reported as not in scope -- FIXME: effect ops in the sig are available whether or not they’re in scope -var :: (HasCallStack, Has (Throw Err) sig m) => QName -> Synth m Expr -var n = Synth $ views context_ (lookupInContext n) >>= \case - [(n', q, CT _T)] -> use n' q $> (XVar (Free n') S.:==> _T) +var :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (Synth Expr) +var n = views context_ (lookupInContext n) >>= \case + [(n', q, CT _T)] -> use n' q $> (XVar (Free n') :==> _T) _ -> resolveQ n >>= \case - n :=: DTerm _ _T -> synth $ global (n ::: _T) + n :=: DTerm _ _T -> global (n ::: _T) _ :=: _ -> freeVariable n @@ -134,21 +133,21 @@ lam cs = Check $ \ _T -> do lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Check (Elab m Expr) -> Check (Elab m Expr) lam1 p b = lam [(p, b)] -app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Synth m a) -> (HasCallStack => Check (Elab m b)) -> Synth m c -app mk operator operand = Synth $ do - f' S.:==> _F <- synth operator +app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Elab m (Synth a)) -> (HasCallStack => Check (Elab m b)) -> Elab m (Synth c) +app mk operator operand = do + f' :==> _F <- operator (_ ::: (q, _A), _B) <- assertFunction _F a' <- censor @Usage (q ><<) $ check (operand ::: _A) - pure $ mk f' a' S.:==> _B + pure $ mk f' a' :==> _B -string :: Text -> Synth m Expr -string s = Synth $ pure $ XString s S.:==> T.String +string :: Text -> Elab m (Synth Expr) +string s = pure $ XString s :==> T.String -let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Synth m Expr -> Check (Elab m Expr) -> Check (Elab m Expr) +let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Elab m (Synth Expr) -> Check (Elab m Expr) -> Check (Elab m Expr) let' p a b = Check $ \ _B -> do - a' S.:==> _A <- synth a + a' :==> _A <- a (p', b') <- bind (p ::: (Many, _A)) (check (b ::: _B)) pure $ XLet p' a' b' @@ -201,7 +200,7 @@ allP n = Bind $ \ _A k -> do -- Expression elaboration -synthExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Synth m Expr +synthExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Elab m (Synth Expr) synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanS $ \case S.Var n -> var n S.App f a -> synthApp f a @@ -210,10 +209,10 @@ synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanS $ \ca S.Hole{} -> nope S.Lam{} -> nope where - nope = Synth couldNotSynthesize - synthApp :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Expr -> Synth m Expr + nope = couldNotSynthesize + synthApp :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Expr -> Elab m (Synth Expr) synthApp f a = app XApp (synthExpr f) (checkExpr a) - synthAs :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Type -> Synth m Expr + synthAs :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Type -> Elab m (Synth Expr) synthAs t _T = as (checkExpr t ::: mapIsType (>>= (\ (_T ::: _K) -> (::: _K) <$> evalTExpr _T)) (synthType _T)) @@ -387,8 +386,8 @@ withSpanB k (S.Ann s _ a) = mapBind (pushSpan s) (k a) withSpanC :: Algebra sig m => (a -> Check (Elab m b)) -> S.Ann a -> Check (Elab m b) withSpanC k (S.Ann s _ a) = mapCheck (pushSpan s) (k a) -withSpanS :: Algebra sig m => (a -> Synth m b) -> S.Ann a -> Synth m b -withSpanS k (S.Ann s _ a) = mapSynth (pushSpan s) (k a) +withSpanS :: Algebra sig m => (a -> Elab m (Synth b)) -> S.Ann a -> Elab m (Synth b) +withSpanS k (S.Ann s _ a) = pushSpan s (k a) provide :: Has (Reader ElabContext :+: State (Subst Type)) sig m => Signature Type -> m a -> m a provide sig m = do @@ -418,15 +417,6 @@ mapCheck :: (Elab m a -> Elab m b) -> Check (Elab m a) -> Check (Elab m b) mapCheck f m = Check $ \ _T -> f (m <==: _T) -newtype Synth m a = Synth { synth :: Elab m (S.Synth a) } - -instance Functor (Synth m) where - fmap f (Synth m) = Synth (fmap f <$> m) - -mapSynth :: (Elab m (S.Synth a) -> Elab m (S.Synth b)) -> Synth m a -> Synth m b -mapSynth f = Synth . f . synth - - bind :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) ::: (Quantity, Type) -> Elab m b -> Elab m (Pattern Name, b) bind (p ::: (q, _T)) m = runBind p _T (\ p' -> (tm <$> p',) <$> ((q, p') |- m)) diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index 3a6e78f44..29294db2e 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -195,12 +195,12 @@ removeTarget targets = Action $ target_.targets_ %= (Set.\\ Set.fromList targets showType, showEval :: S.Ann S.Expr -> Action showType e = Action $ do - e :==> _T <- runElab $ Elab.elabSynthTerm (Elab.synth (Elab.synthExpr e)) + e :==> _T <- runElab $ Elab.elabSynthTerm (Elab.synthExpr e) opts <- get outputDocLn (getPrint (ann (Print.print opts mempty e ::: Print.print opts mempty _T))) showEval e = Action $ do - e' :==> _T <- runElab $ Elab.elabSynthTerm $ locally Elab.sig_ (I.singleton (I.Interface (["Effect", "Console"]:.:U "Output") Nil) :) $ Elab.synth (Elab.synthExpr e) + e' :==> _T <- runElab $ Elab.elabSynthTerm $ locally Elab.sig_ (I.singleton (I.Interface (["Effect", "Console"]:.:U "Output") Nil) :) $ Elab.synthExpr e e'' <- runElab $ runEvalMain e' opts <- get outputDocLn (getPrint (ann (Print.print opts mempty e'' ::: Print.print opts mempty _T))) From 49998f312c004cdb15ebb356c0783be167519f8c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 19:46:56 -0400 Subject: [PATCH 0278/1324] :fire: mapBind & mapCheck. --- src/Facet/Elab/Term.hs | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 7d253f593..e83737165 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -34,11 +34,9 @@ module Facet.Elab.Term -- * Judgements , check , Check(..) -, mapCheck , Synth(..) , bind , Bind(..) -, mapBind ) where import Control.Algebra @@ -231,7 +229,7 @@ checkLam cs = lam (snd vs) vs :: Has (Throw Err :+: Write Warn) sig m => ([QName :=: Check (Elab m Expr)], [(Bind m (Pattern (Name ::: Classifier)), Check (Elab m Expr))]) vs = partitionEithers (map (\ (S.Clause (S.Ann _ _ p) b) -> case p of S.PVal p -> Right (bindPattern p, checkExpr b) - S.PEff (S.Ann s _ (S.POp n fs k)) -> Left $ n :=: mapCheck (pushSpan s) (foldr (lam1 . bindPattern) (checkExpr b) (fromList fs:>k))) cs) + S.PEff (S.Ann s _ (S.POp n fs k)) -> Left $ n :=: Check (\ _T -> pushSpan s (foldr (lam1 . bindPattern) (checkExpr b) (fromList fs:>k) <==: _T))) cs) -- FIXME: check for unique variable names @@ -381,10 +379,10 @@ runModule m = do runReader mod m withSpanB :: Algebra sig m => (a -> Bind m b) -> S.Ann a -> Bind m b -withSpanB k (S.Ann s _ a) = mapBind (pushSpan s) (k a) +withSpanB k (S.Ann s _ a) = Bind (\ _A k' -> pushSpan s (runBind (k a) _A k')) withSpanC :: Algebra sig m => (a -> Check (Elab m b)) -> S.Ann a -> Check (Elab m b) -withSpanC k (S.Ann s _ a) = mapCheck (pushSpan s) (k a) +withSpanC k (S.Ann s _ a) = Check (\ _T -> pushSpan s (k a <==: _T)) withSpanS :: Algebra sig m => (a -> Elab m (Synth b)) -> S.Ann a -> Elab m (Synth b) withSpanS k (S.Ann s _ a) = pushSpan s (k a) @@ -413,15 +411,9 @@ check (m ::: _T) = case _T of T.Comp sig _T -> provide sig $ m <==: _T _T -> m <==: _T -mapCheck :: (Elab m a -> Elab m b) -> Check (Elab m a) -> Check (Elab m b) -mapCheck f m = Check $ \ _T -> f (m <==: _T) - bind :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) ::: (Quantity, Type) -> Elab m b -> Elab m (Pattern Name, b) bind (p ::: (q, _T)) m = runBind p _T (\ p' -> (tm <$> p',) <$> ((q, p') |- m)) newtype Bind m a = Bind { runBind :: forall x . Type -> (a -> Elab m x) -> Elab m x } deriving (Functor) - -mapBind :: (forall x . Elab m x -> Elab m x) -> Bind m a -> Bind m a -mapBind f m = Bind $ \ _A k -> runBind m _A (f . k) From 0c3d12f8af90dbe749e88f26433bfbd866c7f997 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 19:50:32 -0400 Subject: [PATCH 0279/1324] Generalize withSpanS to withSpan. --- src/Facet/Elab/Term.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index e83737165..b30a218db 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -199,7 +199,7 @@ allP n = Bind $ \ _A k -> do -- Expression elaboration synthExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Elab m (Synth Expr) -synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanS $ \case +synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \case S.Var n -> var n S.App f a -> synthApp f a S.As t _T -> synthAs t _T @@ -384,8 +384,8 @@ withSpanB k (S.Ann s _ a) = Bind (\ _A k' -> pushSpan s (runBind (k a) _A k')) withSpanC :: Algebra sig m => (a -> Check (Elab m b)) -> S.Ann a -> Check (Elab m b) withSpanC k (S.Ann s _ a) = Check (\ _T -> pushSpan s (k a <==: _T)) -withSpanS :: Algebra sig m => (a -> Elab m (Synth b)) -> S.Ann a -> Elab m (Synth b) -withSpanS k (S.Ann s _ a) = pushSpan s (k a) +withSpan :: Has (Reader ElabContext) sig m => (a -> m b) -> S.Ann a -> m b +withSpan k (S.Ann s _ a) = pushSpan s (k a) provide :: Has (Reader ElabContext :+: State (Subst Type)) sig m => Signature Type -> m a -> m a provide sig m = do From e064b675fcbcab55c8c6b6cec3144eaca837ab3e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 21:27:07 -0400 Subject: [PATCH 0280/1324] =?UTF-8?q?Don=E2=80=99t=20re-export=20Check/Syn?= =?UTF-8?q?th.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Elab/Term.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index b30a218db..c8990fc9e 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -33,8 +33,6 @@ module Facet.Elab.Term , require -- * Judgements , check -, Check(..) -, Synth(..) , bind , Bind(..) ) where From c2c498a8b37b1f26dd7e5fd35a3b22ff191b1f5d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 21:27:46 -0400 Subject: [PATCH 0281/1324] Parameterize Synth by the type of types. --- src/Facet/Elab.hs | 2 +- src/Facet/Elab/Term.hs | 20 ++++++++++---------- src/Facet/Functor/Synth.hs | 6 ++---- 3 files changed, 13 insertions(+), 15 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index da8daa4b4..5b274b61b 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -336,7 +336,7 @@ elabType = elabWith zero (\ subst t -> pure (TN.eval subst Env.empty t)) elabTerm :: Has (Reader Graph :+: Reader Module :+: Reader Source) sig m => Elab m Expr -> m Expr elabTerm = elabWith one (const pure) -elabSynthTerm :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (Synth Expr) -> m (Synth Expr) +elabSynthTerm :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (Expr :==> Type) -> m (Expr :==> Type) elabSynthTerm = elabWith one (\ subst (e :==> _T) -> pure (e :==> TN.eval subst Env.empty (quote 0 _T))) elabSynthType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (TX.Type ::: Kind) -> m (Type ::: Kind) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index c8990fc9e..30f1580c9 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -82,12 +82,12 @@ import GHC.Stack -- General combinators -switch :: (HasCallStack, Has (Throw Err) sig m) => Elab m (Synth a) -> Check (Elab m a) +switch :: (HasCallStack, Has (Throw Err) sig m) => Elab m (a :==> Type) -> Check (Elab m a) switch m = Check $ \ _Exp -> m >>= \case a :==> T.Comp req _Act -> require req >> unify (Exp _Exp) (Act _Act) $> a a :==> _Act -> unify (Exp _Exp) (Act _Act) $> a -as :: (HasCallStack, Has (Throw Err) sig m) => Check (Elab m Expr) ::: IsType m Type -> Elab m (Synth Expr) +as :: (HasCallStack, Has (Throw Err) sig m) => Check (Elab m Expr) ::: IsType m Type -> Elab m (Expr :==> Type) as (m ::: _T) = do _T' <- checkIsType (_T ::: KType) a <- check (m ::: _T') @@ -97,13 +97,13 @@ as (m ::: _T) = do -- Term combinators -- FIXME: we’re instantiating when inspecting types in the REPL. -global :: Algebra sig m => RName ::: Type -> Elab m (Synth Expr) +global :: Algebra sig m => RName ::: Type -> Elab m (Expr :==> Type) global (q ::: _T) = (\ (v ::: _T) -> v :==> _T) <$> instantiate const (XVar (Global q) ::: _T) -- FIXME: do we need to instantiate here to deal with rank-n applications? -- FIXME: effect ops not in the sig are reported as not in scope -- FIXME: effect ops in the sig are available whether or not they’re in scope -var :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (Synth Expr) +var :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (Expr :==> Type) var n = views context_ (lookupInContext n) >>= \case [(n', q, CT _T)] -> use n' q $> (XVar (Free n') :==> _T) _ -> resolveQ n >>= \case @@ -129,7 +129,7 @@ lam cs = Check $ \ _T -> do lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Check (Elab m Expr) -> Check (Elab m Expr) lam1 p b = lam [(p, b)] -app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Elab m (Synth a)) -> (HasCallStack => Check (Elab m b)) -> Elab m (Synth c) +app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Elab m (a :==> Type)) -> (HasCallStack => Check (Elab m b)) -> Elab m (c :==> Type) app mk operator operand = do f' :==> _F <- operator (_ ::: (q, _A), _B) <- assertFunction _F @@ -137,11 +137,11 @@ app mk operator operand = do pure $ mk f' a' :==> _B -string :: Text -> Elab m (Synth Expr) +string :: Text -> Elab m (Expr :==> Type) string s = pure $ XString s :==> T.String -let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Elab m (Synth Expr) -> Check (Elab m Expr) -> Check (Elab m Expr) +let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Elab m (Expr :==> Type) -> Check (Elab m Expr) -> Check (Elab m Expr) let' p a b = Check $ \ _B -> do a' :==> _A <- a (p', b') <- bind (p ::: (Many, _A)) (check (b ::: _B)) @@ -196,7 +196,7 @@ allP n = Bind $ \ _A k -> do -- Expression elaboration -synthExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Elab m (Synth Expr) +synthExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Elab m (Expr :==> Type) synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \case S.Var n -> var n S.App f a -> synthApp f a @@ -206,9 +206,9 @@ synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \cas S.Lam{} -> nope where nope = couldNotSynthesize - synthApp :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Expr -> Elab m (Synth Expr) + synthApp :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Expr -> Elab m (Expr :==> Type) synthApp f a = app XApp (synthExpr f) (checkExpr a) - synthAs :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Type -> Elab m (Synth Expr) + synthAs :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Type -> Elab m (Expr :==> Type) synthAs t _T = as (checkExpr t ::: mapIsType (>>= (\ (_T ::: _K) -> (::: _K) <$> evalTExpr _T)) (synthType _T)) diff --git a/src/Facet/Functor/Synth.hs b/src/Facet/Functor/Synth.hs index 2399371d2..ec7fd7dda 100644 --- a/src/Facet/Functor/Synth.hs +++ b/src/Facet/Functor/Synth.hs @@ -1,13 +1,11 @@ module Facet.Functor.Synth ( -- * Synth judgement - Synth(..) + (:==>)(..) ) where -import Facet.Type.Norm - -- Synth judgement -data Synth a = a :==> Type +data a :==> b = a :==> b deriving (Foldable, Functor, Traversable) infixr 2 :==> From 90dd7a50da09972539c89cf11d3341a94df5609e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 21:28:38 -0400 Subject: [PATCH 0282/1324] Define a Bifunctor instance for :==>. --- src/Facet/Functor/Synth.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Functor/Synth.hs b/src/Facet/Functor/Synth.hs index ec7fd7dda..fd8acd79d 100644 --- a/src/Facet/Functor/Synth.hs +++ b/src/Facet/Functor/Synth.hs @@ -3,9 +3,14 @@ module Facet.Functor.Synth (:==>)(..) ) where +import Data.Bifunctor + -- Synth judgement data a :==> b = a :==> b deriving (Foldable, Functor, Traversable) infixr 2 :==> + +instance Bifunctor (:==>) where + bimap f g (a :==> _T) = f a :==> g _T From 1f63c042a6f0491414a3d312dac4e66e13288048 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 21:29:02 -0400 Subject: [PATCH 0283/1324] Define a Bifoldable instance for :==>. --- src/Facet/Functor/Synth.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Functor/Synth.hs b/src/Facet/Functor/Synth.hs index fd8acd79d..23b64a0f2 100644 --- a/src/Facet/Functor/Synth.hs +++ b/src/Facet/Functor/Synth.hs @@ -3,6 +3,7 @@ module Facet.Functor.Synth (:==>)(..) ) where +import Data.Bifoldable import Data.Bifunctor -- Synth judgement @@ -14,3 +15,6 @@ infixr 2 :==> instance Bifunctor (:==>) where bimap f g (a :==> _T) = f a :==> g _T + +instance Bifoldable (:==>) where + bifoldMap f g (a :==> _T) = f a <> g _T From b0132fd4b28351caa7f66f5c2cc2e45c030f78dc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 21:29:42 -0400 Subject: [PATCH 0284/1324] Define a Bitraversable instance for :==>. --- src/Facet/Functor/Synth.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Functor/Synth.hs b/src/Facet/Functor/Synth.hs index 23b64a0f2..539808320 100644 --- a/src/Facet/Functor/Synth.hs +++ b/src/Facet/Functor/Synth.hs @@ -5,6 +5,7 @@ module Facet.Functor.Synth import Data.Bifoldable import Data.Bifunctor +import Data.Bitraversable -- Synth judgement @@ -18,3 +19,6 @@ instance Bifunctor (:==>) where instance Bifoldable (:==>) where bifoldMap f g (a :==> _T) = f a <> g _T + +instance Bitraversable (:==>) where + bitraverse f g (a :==> _T) = (:==>) <$> f a <*> g _T From f4267870f300cafe2e8ee51a74aacb837e203228 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 21:30:09 -0400 Subject: [PATCH 0285/1324] Define bifoldMap & bimap via bitraverse. --- src/Facet/Functor/Synth.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Functor/Synth.hs b/src/Facet/Functor/Synth.hs index 539808320..dfc42315a 100644 --- a/src/Facet/Functor/Synth.hs +++ b/src/Facet/Functor/Synth.hs @@ -15,10 +15,10 @@ data a :==> b = a :==> b infixr 2 :==> instance Bifunctor (:==>) where - bimap f g (a :==> _T) = f a :==> g _T + bimap = bimapDefault instance Bifoldable (:==>) where - bifoldMap f g (a :==> _T) = f a <> g _T + bifoldMap = bifoldMapDefault instance Bitraversable (:==>) where bitraverse f g (a :==> _T) = (:==>) <$> f a <*> g _T From d17f2180b4be20854413a961910c89e0c92a4e5f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 21:32:44 -0400 Subject: [PATCH 0286/1324] Use :==> in IsType. --- src/Facet/Elab.hs | 4 ++-- src/Facet/Elab/Term.hs | 2 +- src/Facet/Elab/Type.hs | 35 ++++++++++++++++++----------------- src/Facet/REPL.hs | 2 +- 4 files changed, 22 insertions(+), 21 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 5b274b61b..445ddd051 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -339,5 +339,5 @@ elabTerm = elabWith one (const pure) elabSynthTerm :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (Expr :==> Type) -> m (Expr :==> Type) elabSynthTerm = elabWith one (\ subst (e :==> _T) -> pure (e :==> TN.eval subst Env.empty (quote 0 _T))) -elabSynthType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (TX.Type ::: Kind) -> m (Type ::: Kind) -elabSynthType = elabWith zero (\ subst (_T ::: _K) -> pure (TN.eval subst Env.empty _T ::: _K)) +elabSynthType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (TX.Type :==> Kind) -> m (Type :==> Kind) +elabSynthType = elabWith zero (\ subst (_T :==> _K) -> pure (TN.eval subst Env.empty _T :==> _K)) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 30f1580c9..7d16f32c8 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -209,7 +209,7 @@ synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \cas synthApp :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Expr -> Elab m (Expr :==> Type) synthApp f a = app XApp (synthExpr f) (checkExpr a) synthAs :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Type -> Elab m (Expr :==> Type) - synthAs t _T = as (checkExpr t ::: mapIsType (>>= (\ (_T ::: _K) -> (::: _K) <$> evalTExpr _T)) (synthType _T)) + synthAs t _T = as (checkExpr t ::: mapIsType (>>= (\ (_T :==> _K) -> (:==> _K) <$> evalTExpr _T)) (synthType _T)) checkExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Check (Elab m Expr) diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index bda034998..ecfd7eb6f 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -23,6 +23,7 @@ import Data.Bifunctor (first) import Data.Foldable (foldl') import Data.Functor (($>)) import Facet.Elab +import Facet.Functor.Synth import Facet.Interface import Facet.Kind import Facet.Module @@ -38,48 +39,48 @@ import GHC.Stack tvar :: (HasCallStack, Has (Throw Err) sig m) => QName -> IsType m TX.Type tvar n = IsType $ views context_ (lookupInContext n) >>= \case - [(n', q, CK _K)] -> use n' q $> (TX.Var (Free (Right n')) ::: _K) + [(n', q, CK _K)] -> use n' q $> (TX.Var (Free (Right n')) :==> _K) _ -> resolveQ n >>= \case - q :=: DData _ _K -> pure $ TX.Var (Global q) ::: _K - q :=: DInterface _ _K -> pure $ TX.Var (Global q) ::: _K + q :=: DData _ _K -> pure $ TX.Var (Global q) :==> _K + q :=: DInterface _ _K -> pure $ TX.Var (Global q) :==> _K _ -> freeVariable n ivar :: (HasCallStack, Has (Throw Err) sig m) => QName -> IsType m RName ivar n = IsType $ resolveQ n >>= \case - q :=: DInterface _ _K -> pure $ q ::: _K + q :=: DInterface _ _K -> pure $ q :==> _K _ -> freeVariable n _Type :: IsType m Kind -_Type = IsType $ pure $ KType ::: KType +_Type = IsType $ pure $ KType :==> KType _Interface :: IsType m Kind -_Interface = IsType $ pure $ KInterface ::: KType +_Interface = IsType $ pure $ KInterface :==> KType _String :: IsType m TX.Type -_String = IsType $ pure $ TX.String ::: KType +_String = IsType $ pure $ TX.String :==> KType forAll :: (HasCallStack, Has (Throw Err) sig m) => Name ::: IsType m Kind -> IsType m TX.Type -> IsType m TX.Type forAll (n ::: t) b = IsType $ do t' <- checkIsType (t ::: KType) b' <- (zero, PVar (n ::: CK t')) |- checkIsType (b ::: KType) - pure $ TX.ForAll n t' b' ::: KType + pure $ TX.ForAll n t' b' :==> KType arrow :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> IsType m a -> IsType m b -> IsType m c arrow mk a b = IsType $ do a' <- checkIsType (a ::: KType) b' <- checkIsType (b ::: KType) - pure $ mk a' b' ::: KType + pure $ mk a' b' :==> KType app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> IsType m a -> IsType m b -> IsType m c app mk f a = IsType $ do - f' ::: _F <- isType f + f' :==> _F <- isType f (_ ::: _A, _B) <- assertTypeConstructor _F -- FIXME: assert that the usage is zero a' <- checkIsType (a ::: _A) - pure $ mk f' a' ::: _B + pure $ mk f' a' :==> _B comp :: (HasCallStack, Has (Throw Err) sig m) => [IsType m (Interface TX.Type)] -> IsType m TX.Type -> IsType m TX.Type @@ -87,7 +88,7 @@ comp s t = IsType $ do s' <- traverse (checkIsType . (::: KInterface)) s -- FIXME: polarize types and check that this is a value type being returned t' <- checkIsType (t ::: KType) - pure $ TX.Comp (fromInterfaces s') t' ::: KType + pure $ TX.Comp (fromInterfaces s') t' :==> KType synthKind :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Kind -> IsType m Kind @@ -113,9 +114,9 @@ synthType (S.Ann s _ e) = mapIsType (pushSpan s) $ case e of synthInterface :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Interface -> IsType m (Interface TX.Type) synthInterface (S.Ann s _ (S.Interface (S.Ann sh _ h) sp)) = IsType $ pushSpan s $ do -- FIXME: check that the application actually result in an Interface - h' ::: _ <- pushSpan sh (isType (ivar h)) + h' :==> _ <- pushSpan sh (isType (ivar h)) sp' <- foldl' (liftA2 (:>)) (pure Nil) (checkIsType . (::: KType) . synthType <$> sp) - pure $ Interface h' sp' ::: KInterface + pure $ Interface h' sp' :==> KInterface -- Assertions @@ -128,13 +129,13 @@ assertTypeConstructor = assertMatch (\case{ KArrow n t b -> pure (n ::: t, b) ; checkIsType :: (HasCallStack, Has (Throw Err) sig m) => IsType m a ::: Kind -> Elab m a checkIsType (m ::: _K) = do - a ::: _KA <- isType m + a :==> _KA <- isType m a <$ unless (_KA == _K) (couldNotUnify (Exp (CK _K)) (Act (CK _KA))) -newtype IsType m a = IsType { isType :: Elab m (a ::: Kind) } +newtype IsType m a = IsType { isType :: Elab m (a :==> Kind) } instance Functor (IsType m) where fmap f (IsType m) = IsType (first f <$> m) -mapIsType :: (Elab m (a ::: Kind) -> Elab m (b ::: Kind)) -> IsType m a -> IsType m b +mapIsType :: (Elab m (a :==> Kind) -> Elab m (b :==> Kind)) -> IsType m a -> IsType m b mapIsType f = IsType . f . isType diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index 29294db2e..31d4a64c7 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -218,7 +218,7 @@ runEvalMain e = runEval (quote 0 =<< runReader mempty (eval e)) pure showKind :: S.Ann S.Type -> Action showKind _T = Action $ do - _T ::: _K <- runElab $ Elab.elabSynthType (Elab.isType (Elab.synthType _T)) + _T :==> _K <- runElab $ Elab.elabSynthType (Elab.isType (Elab.synthType _T)) opts <- get outputDocLn (getPrint (ann (Print.print opts mempty _T ::: Print.print opts mempty _K))) From 35e484f7d40459320cae307a91eae1cc94f7b8f9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 21:40:57 -0400 Subject: [PATCH 0287/1324] Use Synth in the IsType judgement. --- src/Facet/Elab/Term.hs | 4 +-- src/Facet/Elab/Type.hs | 67 ++++++++++++++++++------------------------ src/Facet/REPL.hs | 2 +- 3 files changed, 31 insertions(+), 42 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 7d16f32c8..c38b3ba8c 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -87,7 +87,7 @@ switch m = Check $ \ _Exp -> m >>= \case a :==> T.Comp req _Act -> require req >> unify (Exp _Exp) (Act _Act) $> a a :==> _Act -> unify (Exp _Exp) (Act _Act) $> a -as :: (HasCallStack, Has (Throw Err) sig m) => Check (Elab m Expr) ::: IsType m Type -> Elab m (Expr :==> Type) +as :: (HasCallStack, Has (Throw Err) sig m) => Check (Elab m Expr) ::: Elab m (Type :==> Kind) -> Elab m (Expr :==> Type) as (m ::: _T) = do _T' <- checkIsType (_T ::: KType) a <- check (m ::: _T') @@ -209,7 +209,7 @@ synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \cas synthApp :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Expr -> Elab m (Expr :==> Type) synthApp f a = app XApp (synthExpr f) (checkExpr a) synthAs :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Type -> Elab m (Expr :==> Type) - synthAs t _T = as (checkExpr t ::: mapIsType (>>= (\ (_T :==> _K) -> (:==> _K) <$> evalTExpr _T)) (synthType _T)) + synthAs t _T = as (checkExpr t ::: do { _T :==> _K <- synthType _T ; (:==> _K) <$> evalTExpr _T }) checkExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Check (Elab m Expr) diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index ecfd7eb6f..f7cbcc8f3 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -10,8 +10,6 @@ module Facet.Elab.Type , synthType -- * Judgements , checkIsType -, IsType(..) -, mapIsType ) where import Control.Algebra @@ -19,7 +17,6 @@ import Control.Applicative (liftA2) import Control.Effect.Lens (views) import Control.Effect.Throw import Control.Monad (unless) -import Data.Bifunctor (first) import Data.Foldable (foldl') import Data.Functor (($>)) import Facet.Elab @@ -37,69 +34,69 @@ import qualified Facet.Type.Expr as TX import Facet.Type.Norm import GHC.Stack -tvar :: (HasCallStack, Has (Throw Err) sig m) => QName -> IsType m TX.Type -tvar n = IsType $ views context_ (lookupInContext n) >>= \case +tvar :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (TX.Type :==> Kind) +tvar n = views context_ (lookupInContext n) >>= \case [(n', q, CK _K)] -> use n' q $> (TX.Var (Free (Right n')) :==> _K) _ -> resolveQ n >>= \case q :=: DData _ _K -> pure $ TX.Var (Global q) :==> _K q :=: DInterface _ _K -> pure $ TX.Var (Global q) :==> _K _ -> freeVariable n -ivar :: (HasCallStack, Has (Throw Err) sig m) => QName -> IsType m RName -ivar n = IsType $ resolveQ n >>= \case +ivar :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (RName :==> Kind) +ivar n = resolveQ n >>= \case q :=: DInterface _ _K -> pure $ q :==> _K _ -> freeVariable n -_Type :: IsType m Kind -_Type = IsType $ pure $ KType :==> KType +_Type :: Elab m (Kind :==> Kind) +_Type = pure $ KType :==> KType -_Interface :: IsType m Kind -_Interface = IsType $ pure $ KInterface :==> KType +_Interface :: Elab m (Kind :==> Kind) +_Interface = pure $ KInterface :==> KType -_String :: IsType m TX.Type -_String = IsType $ pure $ TX.String :==> KType +_String :: Elab m (TX.Type :==> Kind) +_String = pure $ TX.String :==> KType -forAll :: (HasCallStack, Has (Throw Err) sig m) => Name ::: IsType m Kind -> IsType m TX.Type -> IsType m TX.Type -forAll (n ::: t) b = IsType $ do +forAll :: (HasCallStack, Has (Throw Err) sig m) => Name ::: Elab m (Kind :==> Kind) -> Elab m (TX.Type :==> Kind) -> Elab m (TX.Type :==> Kind) +forAll (n ::: t) b = do t' <- checkIsType (t ::: KType) b' <- (zero, PVar (n ::: CK t')) |- checkIsType (b ::: KType) pure $ TX.ForAll n t' b' :==> KType -arrow :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> IsType m a -> IsType m b -> IsType m c -arrow mk a b = IsType $ do +arrow :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> Elab m (a :==> Kind) -> Elab m (b :==> Kind) -> Elab m (c :==> Kind) +arrow mk a b = do a' <- checkIsType (a ::: KType) b' <- checkIsType (b ::: KType) pure $ mk a' b' :==> KType -app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> IsType m a -> IsType m b -> IsType m c -app mk f a = IsType $ do - f' :==> _F <- isType f +app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> Elab m (a :==> Kind) -> Elab m (b :==> Kind) -> Elab m (c :==> Kind) +app mk f a = do + f' :==> _F <- f (_ ::: _A, _B) <- assertTypeConstructor _F -- FIXME: assert that the usage is zero a' <- checkIsType (a ::: _A) pure $ mk f' a' :==> _B -comp :: (HasCallStack, Has (Throw Err) sig m) => [IsType m (Interface TX.Type)] -> IsType m TX.Type -> IsType m TX.Type -comp s t = IsType $ do +comp :: (HasCallStack, Has (Throw Err) sig m) => [Elab m (Interface TX.Type :==> Kind)] -> Elab m (TX.Type :==> Kind) -> Elab m (TX.Type :==> Kind) +comp s t = do s' <- traverse (checkIsType . (::: KInterface)) s -- FIXME: polarize types and check that this is a value type being returned t' <- checkIsType (t ::: KType) pure $ TX.Comp (fromInterfaces s') t' :==> KType -synthKind :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Kind -> IsType m Kind -synthKind (S.Ann s _ e) = mapIsType (pushSpan s) $ case e of +synthKind :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Kind -> Elab m (Kind :==> Kind) +synthKind (S.Ann s _ e) = pushSpan s $ case e of S.KArrow n a b -> arrow (KArrow n) (synthKind a) (synthKind b) S.KType -> _Type S.KInterface -> _Interface -synthType :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Type -> IsType m TX.Type -synthType (S.Ann s _ e) = mapIsType (pushSpan s) $ case e of +synthType :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Type -> Elab m (TX.Type :==> Kind) +synthType (S.Ann s _ e) = pushSpan s $ case e of S.TVar n -> tvar n S.TString -> _String S.TForAll n t b -> forAll (n ::: synthKind t) (synthType b) @@ -111,10 +108,10 @@ synthType (S.Ann s _ e) = mapIsType (pushSpan s) $ case e of S.Zero -> zero S.One -> one -synthInterface :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Interface -> IsType m (Interface TX.Type) -synthInterface (S.Ann s _ (S.Interface (S.Ann sh _ h) sp)) = IsType $ pushSpan s $ do +synthInterface :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Interface -> Elab m (Interface TX.Type :==> Kind) +synthInterface (S.Ann s _ (S.Interface (S.Ann sh _ h) sp)) = pushSpan s $ do -- FIXME: check that the application actually result in an Interface - h' :==> _ <- pushSpan sh (isType (ivar h)) + h' :==> _ <- pushSpan sh (ivar h) sp' <- foldl' (liftA2 (:>)) (pure Nil) (checkIsType . (::: KType) . synthType <$> sp) pure $ Interface h' sp' :==> KInterface @@ -127,15 +124,7 @@ assertTypeConstructor = assertMatch (\case{ KArrow n t b -> pure (n ::: t, b) ; -- Judgements -checkIsType :: (HasCallStack, Has (Throw Err) sig m) => IsType m a ::: Kind -> Elab m a +checkIsType :: (HasCallStack, Has (Throw Err) sig m) => Elab m (a :==> Kind) ::: Kind -> Elab m a checkIsType (m ::: _K) = do - a :==> _KA <- isType m + a :==> _KA <- m a <$ unless (_KA == _K) (couldNotUnify (Exp (CK _K)) (Act (CK _KA))) - -newtype IsType m a = IsType { isType :: Elab m (a :==> Kind) } - -instance Functor (IsType m) where - fmap f (IsType m) = IsType (first f <$> m) - -mapIsType :: (Elab m (a :==> Kind) -> Elab m (b :==> Kind)) -> IsType m a -> IsType m b -mapIsType f = IsType . f . isType diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index 31d4a64c7..a0a04d849 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -218,7 +218,7 @@ runEvalMain e = runEval (quote 0 =<< runReader mempty (eval e)) pure showKind :: S.Ann S.Type -> Action showKind _T = Action $ do - _T :==> _K <- runElab $ Elab.elabSynthType (Elab.isType (Elab.synthType _T)) + _T :==> _K <- runElab $ Elab.elabSynthType (Elab.synthType _T) opts <- get outputDocLn (getPrint (ann (Print.print opts mempty _T ::: Print.print opts mempty _K))) From f3357d08ffdceb996a0c03ded68eca7bd3487bb8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 22:25:49 -0400 Subject: [PATCH 0288/1324] Generalize Check over the type of types. --- src/Facet/Elab/Term.hs | 30 +++++++++++++++--------------- src/Facet/Functor/Check.hs | 8 +++----- 2 files changed, 18 insertions(+), 20 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index c38b3ba8c..dd75c29d3 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -82,12 +82,12 @@ import GHC.Stack -- General combinators -switch :: (HasCallStack, Has (Throw Err) sig m) => Elab m (a :==> Type) -> Check (Elab m a) +switch :: (HasCallStack, Has (Throw Err) sig m) => Elab m (a :==> Type) -> Type <==: Elab m a switch m = Check $ \ _Exp -> m >>= \case a :==> T.Comp req _Act -> require req >> unify (Exp _Exp) (Act _Act) $> a a :==> _Act -> unify (Exp _Exp) (Act _Act) $> a -as :: (HasCallStack, Has (Throw Err) sig m) => Check (Elab m Expr) ::: Elab m (Type :==> Kind) -> Elab m (Expr :==> Type) +as :: (HasCallStack, Has (Throw Err) sig m) => (Type <==: Elab m Expr) ::: Elab m (Type :==> Kind) -> Elab m (Expr :==> Type) as (m ::: _T) = do _T' <- checkIsType (_T ::: KType) a <- check (m ::: _T') @@ -111,25 +111,25 @@ var n = views context_ (lookupInContext n) >>= \case _ :=: _ -> freeVariable n -hole :: (HasCallStack, Has (Throw Err) sig m) => Name -> Check (Elab m a) +hole :: (HasCallStack, Has (Throw Err) sig m) => Name -> Type <==: Elab m a hole n = Check $ \ _T -> withFrozenCallStack $ err $ Hole n (CT _T) -tlam :: (HasCallStack, Has (Throw Err) sig m) => Check (Elab m Expr) -> Check (Elab m Expr) +tlam :: (HasCallStack, Has (Throw Err) sig m) => Type <==: Elab m Expr -> Type <==: Elab m Expr tlam b = Check $ \ _T -> do (n ::: _A, _B) <- assertQuantifier _T d <- depth (zero, PVar (n ::: CK _A)) |- check (b ::: _B (T.free (LName d n))) -lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern (Name ::: Classifier)), Check (Elab m Expr))] -> Check (Elab m Expr) +lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern (Name ::: Classifier)), Type <==: Elab m Expr)] -> Type <==: Elab m Expr lam cs = Check $ \ _T -> do (_A, _B) <- assertTacitFunction _T XLam <$> traverse (\ (p, b) -> bind (p ::: _A) (check (b ::: _B))) cs -lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Check (Elab m Expr) -> Check (Elab m Expr) +lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Type <==: Elab m Expr -> Type <==: Elab m Expr lam1 p b = lam [(p, b)] -app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Elab m (a :==> Type)) -> (HasCallStack => Check (Elab m b)) -> Elab m (c :==> Type) +app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Elab m (a :==> Type)) -> (HasCallStack => Type <==: Elab m b) -> Elab m (c :==> Type) app mk operator operand = do f' :==> _F <- operator (_ ::: (q, _A), _B) <- assertFunction _F @@ -141,14 +141,14 @@ string :: Text -> Elab m (Expr :==> Type) string s = pure $ XString s :==> T.String -let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Elab m (Expr :==> Type) -> Check (Elab m Expr) -> Check (Elab m Expr) +let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Elab m (Expr :==> Type) -> Type <==: Elab m Expr -> Type <==: Elab m Expr let' p a b = Check $ \ _B -> do a' :==> _A <- a (p', b') <- bind (p ::: (Many, _A)) (check (b ::: _B)) pure $ XLet p' a' b' -comp :: Has (Throw Err) sig m => Check (Elab m Expr) -> Check (Elab m Expr) +comp :: Has (Throw Err) sig m => Type <==: Elab m Expr -> Type <==: Elab m Expr comp b = Check $ \ _T -> do (sig, _B) <- assertComp _T StaticContext{ graph, module' } <- ask @@ -212,7 +212,7 @@ synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \cas synthAs t _T = as (checkExpr t ::: do { _T :==> _K <- synthType _T ; (:==> _K) <$> evalTExpr _T }) -checkExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Check (Elab m Expr) +checkExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Type <==: Elab m Expr checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in flip withSpanC expr $ \case S.Hole n -> hole n S.Lam cs -> checkLam cs @@ -221,10 +221,10 @@ checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in flip withS S.As{} -> switch (synthExpr expr) S.String{} -> switch (synthExpr expr) -checkLam :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => [S.Clause] -> Check (Elab m Expr) +checkLam :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => [S.Clause] -> Type <==: Elab m Expr checkLam cs = lam (snd vs) where - vs :: Has (Throw Err :+: Write Warn) sig m => ([QName :=: Check (Elab m Expr)], [(Bind m (Pattern (Name ::: Classifier)), Check (Elab m Expr))]) + vs :: Has (Throw Err :+: Write Warn) sig m => ([QName :=: (Type <==: Elab m Expr)], [(Bind m (Pattern (Name ::: Classifier)), Type <==: Elab m Expr)]) vs = partitionEithers (map (\ (S.Clause (S.Ann _ _ p) b) -> case p of S.PVal p -> Right (bindPattern p, checkExpr b) S.PEff (S.Ann s _ (S.POp n fs k)) -> Left $ n :=: Check (\ _T -> pushSpan s (foldr (lam1 . bindPattern) (checkExpr b) (fromList fs:>k) <==: _T))) cs) @@ -249,7 +249,7 @@ abstractType body = go KArrow (Just n) a b -> TX.ForAll n a <$> ((zero, PVar (n ::: CK a)) |- go b) _ -> body -abstractTerm :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => (Snoc TX.Type -> Snoc Expr -> Expr) -> Check (Elab m Expr) +abstractTerm :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => (Snoc TX.Type -> Snoc Expr -> Expr) -> Type <==: Elab m Expr abstractTerm body = go Nil Nil where go ts fs = Check $ \case @@ -379,7 +379,7 @@ runModule m = do withSpanB :: Algebra sig m => (a -> Bind m b) -> S.Ann a -> Bind m b withSpanB k (S.Ann s _ a) = Bind (\ _A k' -> pushSpan s (runBind (k a) _A k')) -withSpanC :: Algebra sig m => (a -> Check (Elab m b)) -> S.Ann a -> Check (Elab m b) +withSpanC :: Algebra sig m => (a -> Type <==: Elab m b) -> S.Ann a -> Type <==: Elab m b withSpanC k (S.Ann s _ a) = Check (\ _T -> pushSpan s (k a <==: _T)) withSpan :: Has (Reader ElabContext) sig m => (a -> m b) -> S.Ann a -> m b @@ -404,7 +404,7 @@ findMaybeM p = getAp . fmap getFirst . foldMap (Ap . fmap First . p) -- Judgements -check :: Algebra sig m => (Check (Elab m a) ::: Type) -> Elab m a +check :: Algebra sig m => ((Type <==: Elab m a) ::: Type) -> Elab m a check (m ::: _T) = case _T of T.Comp sig _T -> provide sig $ m <==: _T _T -> m <==: _T diff --git a/src/Facet/Functor/Check.hs b/src/Facet/Functor/Check.hs index 4d3a6c7ca..eaf15df30 100644 --- a/src/Facet/Functor/Check.hs +++ b/src/Facet/Functor/Check.hs @@ -1,17 +1,15 @@ module Facet.Functor.Check ( -- * Check judgement - Check(..) + type (<==:)(..) , (<==:) ) where -import Facet.Type.Norm - -- Check judgement -newtype Check a = Check (Type -> a) +newtype b <==: a = Check (b -> a) deriving (Applicative, Functor, Monad) -(<==:) :: Check a -> Type -> a +(<==:) :: b <==: a -> b -> a Check f <==: _T = f _T infixl 2 <==: From 3aa7b4d2beff5fbe44730a15dd575da4c863a210 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Aug 2021 22:26:57 -0400 Subject: [PATCH 0289/1324] Derive a Profunctor instance for <==:. --- src/Facet/Functor/Check.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Facet/Functor/Check.hs b/src/Facet/Functor/Check.hs index eaf15df30..64085978e 100644 --- a/src/Facet/Functor/Check.hs +++ b/src/Facet/Functor/Check.hs @@ -4,12 +4,14 @@ module Facet.Functor.Check , (<==:) ) where +import Data.Profunctor + -- Check judgement newtype b <==: a = Check (b -> a) - deriving (Applicative, Functor, Monad) + deriving (Applicative, Functor, Monad, Profunctor) + +infixl 2 <==: (<==:) :: b <==: a -> b -> a Check f <==: _T = f _T - -infixl 2 <==: From 729ec02b3e6e4e405830cd777a38a6dec81f14fe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Aug 2021 08:12:06 -0400 Subject: [PATCH 0290/1324] Add a source-repository-package for fresnel. --- cabal.project | 5 +++++ cabal.project.ci | 5 +++++ 2 files changed, 10 insertions(+) diff --git a/cabal.project b/cabal.project index 7ef286b0d..29d35e4f9 100644 --- a/cabal.project +++ b/cabal.project @@ -1,2 +1,7 @@ packages: . tests: True + +source-repository-package + type: git + location: https://github.com/robrix/fresnel.git + tag: 77da2c71502f3943e741b9a96d0e330d8292a444 diff --git a/cabal.project.ci b/cabal.project.ci index dd5c5c333..5adf94920 100644 --- a/cabal.project.ci +++ b/cabal.project.ci @@ -3,3 +3,8 @@ tests: True package facet ghc-options: -Werror + +source-repository-package + type: git + location: https://github.com/robrix/fresnel.git + tag: 77da2c71502f3943e741b9a96d0e330d8292a444 From 29c7f2c2cda58a4df7cca681ae119f90f29f3421 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Aug 2021 08:15:19 -0400 Subject: [PATCH 0291/1324] Depend on fresnel. --- facet.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/facet.cabal b/facet.cabal index 494671f2f..97cd73280 100644 --- a/facet.cabal +++ b/facet.cabal @@ -143,6 +143,7 @@ library , directory , exceptions ^>= 0.10 , filepath + , fresnel , fused-effects , fused-effects-lens , haskeline ^>= 0.8.1 From 72c834e09f935b6b80feb5a2d70a67d9547586ad Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Aug 2021 14:39:59 -0400 Subject: [PATCH 0292/1324] Replace lens with fresnel. --- facet.cabal | 1 - src/Facet/Carrier/Error/Lens.hs | 11 ++-- src/Facet/Carrier/Parser/Church.hs | 4 +- src/Facet/Carrier/State/Lens.hs | 17 ++++-- src/Facet/Driver.hs | 4 +- src/Facet/Elab.hs | 6 +- src/Facet/Elab/Term.hs | 4 +- src/Facet/Elab/Type.hs | 2 +- src/Facet/Graph.hs | 12 ++-- src/Facet/Lens.hs | 92 ++++++++++++++++++++++++++---- src/Facet/Module.hs | 3 +- src/Facet/Notice.hs | 2 +- src/Facet/REPL.hs | 5 +- src/Facet/Run.hs | 4 +- src/Facet/Source.hs | 2 +- src/Facet/Span.hs | 3 +- src/Facet/Surface.hs | 2 +- src/Facet/Type/Norm.hs | 2 +- 18 files changed, 129 insertions(+), 47 deletions(-) diff --git a/facet.cabal b/facet.cabal index 97cd73280..6b2236208 100644 --- a/facet.cabal +++ b/facet.cabal @@ -147,7 +147,6 @@ library , fused-effects , fused-effects-lens , haskeline ^>= 0.8.1 - , lens , optparse-applicative , parsers , prettyprinter diff --git a/src/Facet/Carrier/Error/Lens.hs b/src/Facet/Carrier/Error/Lens.hs index 56efa7660..14201fad6 100644 --- a/src/Facet/Carrier/Error/Lens.hs +++ b/src/Facet/Carrier/Error/Lens.hs @@ -11,17 +11,20 @@ module Facet.Carrier.Error.Lens import Control.Algebra import Control.Carrier.Reader import Control.Effect.Error -import Control.Lens (APrism', withPrism) import Control.Monad.IO.Class +import Fresnel.Prism (Prism', withPrism) -runError :: APrism' e f -> ErrorC e f m a -> m a -runError prism (ErrorC m) = runReader prism m +runError :: Prism' e f -> ErrorC e f m a -> m a +runError prism (ErrorC m) = runReader (APrism' prism) m newtype ErrorC e f m a = ErrorC (ReaderC (APrism' e f) m a) deriving (Applicative, Functor, Monad, MonadFail, MonadIO) instance Has (Error e) sig m => Algebra (Error f :+: sig) (ErrorC e f m) where - alg hdl sig ctx = ErrorC $ ReaderC $ \ prism -> case sig of + alg hdl sig ctx = ErrorC $ ReaderC $ \ (APrism' prism) -> case sig of L (L (Throw e)) -> throwError (withPrism prism (\ review _ -> review e)) L (R (Catch m h)) -> runError prism (hdl (m <$ ctx)) `catchError` \ e -> withPrism prism (\ _ preview -> either throwError (runError prism . hdl . (<$ ctx) . h) (preview e)) R other -> alg (runError prism . hdl) other ctx + + +newtype APrism' s a = APrism' (Prism' s a) diff --git a/src/Facet/Carrier/Parser/Church.hs b/src/Facet/Carrier/Parser/Church.hs index 655a4e0d4..629f63f09 100644 --- a/src/Facet/Carrier/Parser/Church.hs +++ b/src/Facet/Carrier/Parser/Church.hs @@ -26,13 +26,13 @@ import Control.Algebra import Control.Effect.Cut import Control.Effect.NonDet import Control.Effect.Throw -import Control.Lens (Lens', lens, (%~), (&), (.~)) import Control.Monad (ap) import Control.Monad.Fail as Fail import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Trans.Class import Data.Coerce (coerce) +import Data.Function ((&)) import Data.Functor.Compose import Data.Functor.Identity import Data.List.NonEmpty (NonEmpty(..)) @@ -40,6 +40,8 @@ import Data.Set (Set, singleton) import Facet.Effect.Parser import Facet.Source as Source import Facet.Span as Span +import Fresnel.Lens (Lens', lens) +import Fresnel.Setter ((%~), (.~)) import Text.Parser.Char (CharParsing(..)) import Text.Parser.Combinators import Text.Parser.Token (TokenParsing) diff --git a/src/Facet/Carrier/State/Lens.hs b/src/Facet/Carrier/State/Lens.hs index 28d2fc993..66ff15524 100644 --- a/src/Facet/Carrier/State/Lens.hs +++ b/src/Facet/Carrier/State/Lens.hs @@ -11,19 +11,24 @@ module Facet.Carrier.State.Lens import Control.Algebra import Control.Carrier.Reader import Control.Effect.State -import Control.Lens (ALens', storing, (^#)) import Control.Monad.IO.Class +import Fresnel.Getter ((^.)) +import Fresnel.Lens (Lens') +import Fresnel.Setter (set) -runState :: ALens' s t -> StateC s t m a -> m a -runState lens (StateC m) = runReader lens m +runState :: Lens' s t -> StateC s t m a -> m a +runState lens (StateC m) = runReader (ALens' lens) m {-# INLINE runState #-} newtype StateC s t m a = StateC (ReaderC (ALens' s t) m a) deriving (Applicative, Functor, Monad, MonadFail, MonadIO) instance Has (State s) sig m => Algebra (State t :+: sig) (StateC s t m) where - alg hdl sig ctx = StateC $ ReaderC $ \ lens -> case sig of - L Get -> (<$ ctx) <$> gets (^# lens) - L (Put s) -> (<$ ctx) <$> modify (storing lens s) + alg hdl sig ctx = StateC $ ReaderC $ \ (ALens' lens) -> case sig of + L Get -> (<$ ctx) <$> gets (^. lens) + L (Put s) -> (<$ ctx) <$> modify (set lens s) R other -> alg (runState lens . hdl) other ctx {-# INLINABLE alg #-} + + +newtype ALens' s a = ALens' (Lens' s a) diff --git a/src/Facet/Driver.hs b/src/Facet/Driver.hs index 97abe0229..c60ba91e8 100644 --- a/src/Facet/Driver.hs +++ b/src/Facet/Driver.hs @@ -23,9 +23,7 @@ module Facet.Driver import Control.Algebra import Control.Carrier.Reader import Control.Effect.Error -import Control.Effect.Lens (use, uses, (.=)) import Control.Effect.State -import Control.Lens (Lens, Lens', at, lens, (^.)) import Control.Monad.IO.Class import Data.Foldable (toList) import Data.Maybe (catMaybes) @@ -52,6 +50,8 @@ import Facet.Source import Facet.Style import qualified Facet.Surface as Import (Import(..)) import qualified Facet.Surface as S +import Fresnel.Getter ((^.)) +import Fresnel.Lens (Lens, Lens', lens) import Silkscreen import System.Directory (findFile) import qualified System.FilePath as FP diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 445ddd051..f123907a6 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -55,8 +55,6 @@ import Control.Carrier.Reader import Control.Carrier.State.Church import Control.Carrier.Writer.Church import Control.Effect.Choose -import Control.Effect.Lens (views) -import Control.Lens (Lens', lens, review) import Control.Monad (unless, (<=<)) import Data.Foldable (for_) import Facet.Context hiding (empty) @@ -67,7 +65,7 @@ import Facet.Functor.Synth import Facet.Graph as Graph import Facet.Interface import Facet.Kind -import Facet.Lens +import Facet.Lens hiding (Index, use) import Facet.Module import Facet.Name hiding (L, R) import Facet.Pattern @@ -84,6 +82,8 @@ import qualified Facet.Type.Expr as TX import Facet.Type.Norm as TN import Facet.Usage as Usage import Facet.Vars as Vars +import Fresnel.Lens (Lens', lens) +import Fresnel.Review (review) import GHC.Stack import Prelude hiding (span, zipWith) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index dd75c29d3..72f4b3bfd 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -40,10 +40,8 @@ module Facet.Elab.Term import Control.Algebra import Control.Carrier.Reader import Control.Carrier.State.Church -import Control.Effect.Lens (view, views, (.=)) import Control.Effect.Throw import Control.Effect.Writer (censor) -import Control.Lens (at, ix) import Data.Bifunctor (first) import Data.Either (partitionEithers) import Data.Foldable @@ -62,7 +60,7 @@ import Facet.Functor.Synth import Facet.Graph import Facet.Interface import Facet.Kind -import Facet.Lens (locally) +import Facet.Lens (At(..), Ixed(..), locally, view, views, (.=)) import Facet.Module as Module import Facet.Name import Facet.Pattern diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index f7cbcc8f3..6ab92fcde 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -14,7 +14,6 @@ module Facet.Elab.Type import Control.Algebra import Control.Applicative (liftA2) -import Control.Effect.Lens (views) import Control.Effect.Throw import Control.Monad (unless) import Data.Foldable (foldl') @@ -23,6 +22,7 @@ import Facet.Elab import Facet.Functor.Synth import Facet.Interface import Facet.Kind +import Facet.Lens (views) import Facet.Module import Facet.Name import Facet.Pattern diff --git a/src/Facet/Graph.hs b/src/Facet/Graph.hs index afe7d968c..e09179d5e 100644 --- a/src/Facet/Graph.hs +++ b/src/Facet/Graph.hs @@ -20,26 +20,28 @@ import Control.Carrier.Writer.Church import Control.Effect.Choose import Control.Effect.Empty import Control.Effect.Throw -import Control.Lens as Lens (At(..), Index, IxValue, Ixed(..), iso) import Control.Monad (unless, when, (<=<)) import Control.Monad.Trans.Class import Data.Foldable (for_) import qualified Data.Map as Map import Data.Monoid (Endo(..)) import qualified Data.Set as Set +import Facet.Lens import Facet.Module import Facet.Name import Facet.Snoc import Facet.Snoc.NonEmpty (fromSnoc, toSnoc) import Facet.Syntax +import Fresnel.Iso newtype Graph = Graph { getGraph :: Map.Map MName (Maybe FilePath, Maybe Module) } - deriving (Semigroup, Monoid) + deriving (Monoid, Semigroup) -type instance Lens.Index Graph = MName -type instance IxValue Graph = (Maybe FilePath, Maybe Module) +instance Ixed Graph where + type Index Graph = MName + type IxValue Graph = (Maybe FilePath, Maybe Module) + ix = ixAt -instance Ixed Graph instance At Graph where at i = iso getGraph Graph .at i diff --git a/src/Facet/Lens.hs b/src/Facet/Lens.hs index 0fe8db117..86c3d6205 100644 --- a/src/Facet/Lens.hs +++ b/src/Facet/Lens.hs @@ -1,32 +1,102 @@ +{-# LANGUAGE TypeFamilies #-} module Facet.Lens ( zoom +, (<~) , (~>) , (<~>) , locally +, use +, uses +, view +, views +, (%=) +, (.=) +, modifying +, assign +, At(..) +, Ixed(..) +, ixAt ) where -import Control.Carrier.State.Church -import Control.Effect.Lens (use, (<~)) -import Control.Effect.Reader -import Control.Lens (ASetter, Getting, Lens', over) +import Control.Carrier.State.Church +import Control.Effect.Reader +import qualified Data.Map as Map +import Data.Profunctor.Traversing (wander) +import qualified Fresnel.Getter as Getter +import qualified Fresnel.Lens as Lens +import qualified Fresnel.Setter as Setter +import qualified Fresnel.Traversal as Traversal -zoom :: Has (State s) sig m => Lens' s a -> StateC a m () -> m () +zoom :: Has (State s) sig m => Lens.Lens' s a -> StateC a m () -> m () zoom lens action = lens <~> (`execState` action) infixr 2 `zoom` +(<~) :: Has (State s) sig m => Setter.Setter s s a b -> m b -> m () +o <~ m = m >>= assign o + -- | Compose a getter onto the input of a Kleisli arrow and run it on the 'State'. -(~>) :: Has (State s) sig m => Getting a s a -> (a -> m b) -> m b +(~>) :: Has (State s) sig m => Getter.Getter s a -> (a -> m b) -> m b lens ~> act = use lens >>= act -infixr 2 ~> +infixr 2 <~, ~>, <~> -- | Compose a lens onto either side of a Kleisli arrow and run it on the 'State'. -(<~>) :: Has (State s) sig m => Lens' s a -> (a -> m a) -> m () +(<~>) :: Has (State s) sig m => Lens.Lens' s a -> (a -> m a) -> m () lens <~> act = lens <~ lens ~> act -infixr 2 <~> + +locally :: Has (Reader s) sig m => Setter.Setter s s a b -> (a -> b) -> m r -> m r +locally o = local . Setter.over o + + +use :: Has (State s) sig m => Getter.Getter s a -> m a +use o = gets (Getter.view o) + +uses :: Has (State s) sig m => Getter.Getter s a -> (a -> b) -> m b +uses o f = f <$> use o + +view :: Has (Reader s) sig m => Getter.Getter s a -> m a +view o = asks (Getter.view o) + +views :: Has (Reader s) sig m => Getter.Getter s a -> (a -> b) -> m b +views o f = f <$> view o + +(%=) :: Has (State s) sig m => Setter.Setter s s a b -> (a -> b) -> m () +(%=) = modifying + +infix 4 %=, .= + +(.=) :: Has (State s) sig m => Setter.Setter s s a b -> b -> m () +(.=) = assign + +modifying :: Has (State s) sig m => Setter.Setter s s a b -> (a -> b) -> m () +modifying o = modify . Setter.over o + +assign :: Has (State s) sig m => Setter.Setter s s a b -> b -> m () +assign o = modify . Setter.set o + + +class Ixed a where + type Index a + type IxValue a + + ix :: Index a -> Traversal.Traversal' a (IxValue a) + +instance Ord k => Ixed (Map.Map k v) where + type Index (Map.Map k v) = k + type IxValue (Map.Map k v) = v + ix k = wander $ \ f m -> case Map.lookup k m of + Just v -> fmap (\ v' -> Map.insert k v' m) (f v) + Nothing -> pure m + + +class Ixed a => At a where + at :: Index a -> Lens.Lens' a (Maybe (IxValue a)) + +instance Ord k => At (Map.Map k v) where + at k = Lens.lens (Map.lookup k) (\ m v -> maybe (Map.delete k m) (\ v -> Map.insert k v m) v) -locally :: Has (Reader s) sig m => ASetter s s a b -> (a -> b) -> m r -> m r -locally l f = local (over l f) +ixAt :: At a => Index a -> Traversal.Traversal' a (IxValue a) +ixAt i = at i . wander traverse diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 12fe76725..5c9c682cd 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -23,7 +23,6 @@ module Facet.Module import Control.Algebra import Control.Effect.Choose import Control.Effect.Empty -import Control.Lens (Lens, Lens', coerced, lens) import Control.Monad ((<=<)) import Data.Bifunctor (Bifunctor(bimap), first) import Data.Coerce @@ -33,6 +32,8 @@ import Facet.Name import Facet.Syntax import Facet.Term import Facet.Type.Norm +import Fresnel.Iso (coerced) +import Fresnel.Lens (Lens, Lens', lens) -- Modules diff --git a/src/Facet/Notice.hs b/src/Facet/Notice.hs index feb2e56f4..699165ec5 100644 --- a/src/Facet/Notice.hs +++ b/src/Facet/Notice.hs @@ -8,8 +8,8 @@ module Facet.Notice , context_ ) where -import Control.Lens (Lens', lens) import Facet.Source (Source(..)) +import Fresnel.Lens (Lens', lens) -- Notices diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index a0a04d849..e3c4ba642 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -12,14 +12,13 @@ import Control.Carrier.Error.Church import Control.Carrier.Fail.Either import Control.Carrier.Reader import Control.Carrier.State.Church -import Control.Effect.Lens (use, uses, (%=)) import Control.Exception (handle) -import Control.Lens (Lens', lens, (&), (.~)) import Control.Monad (unless, (<=<)) import Control.Monad.IO.Class import Data.Char import Data.Colour.RGBSpace.HSL (hsl) import Data.Foldable (toList) +import Data.Function ((&)) import qualified Data.Map as Map import Data.Semigroup (stimes) import qualified Data.Set as Set @@ -54,6 +53,8 @@ import Facet.Style as Style import qualified Facet.Surface as S import Facet.Syntax import Facet.Term (Expr) +import Fresnel.Lens (Lens', lens) +import Fresnel.Setter ((.~)) import Prelude hiding (span, unlines) import Silkscreen as S hiding (Ann, line) import System.Console.ANSI diff --git a/src/Facet/Run.hs b/src/Facet/Run.hs index 409cbf187..6d2772457 100644 --- a/src/Facet/Run.hs +++ b/src/Facet/Run.hs @@ -4,8 +4,6 @@ module Facet.Run import Control.Carrier.Error.Church import Control.Carrier.State.Church -import Control.Effect.Lens (use) -import Control.Lens (at, (^.)) import Control.Monad ((<=<)) import Data.Foldable (for_) import qualified Data.Set as Set @@ -14,9 +12,11 @@ import Facet.Carrier.Time.System import Facet.Carrier.Write.General import Facet.Driver import Facet.Graph +import Facet.Lens import Facet.Print (quietOptions) import Facet.Source as Source import Facet.Style +import Fresnel.Getter ((^.)) import System.Exit runFile :: [FilePath] -> FilePath -> IO ExitCode diff --git a/src/Facet/Source.hs b/src/Facet/Source.hs index 74401e8d4..bfa334fc0 100644 --- a/src/Facet/Source.hs +++ b/src/Facet/Source.hs @@ -14,10 +14,10 @@ module Facet.Source ) where import Control.Exception (assert) -import Control.Lens (Lens', lens) import qualified Data.List.NonEmpty as NE import Data.Monoid (Endo(..)) import qualified Facet.Span as Span +import Fresnel.Lens (Lens', lens) import Prelude hiding (lines, span) import qualified Prettyprinter as P diff --git a/src/Facet/Span.hs b/src/Facet/Span.hs index 904dc5e12..f2c0e4874 100644 --- a/src/Facet/Span.hs +++ b/src/Facet/Span.hs @@ -8,8 +8,9 @@ module Facet.Span , HasSpan(..) ) where -import Control.Lens (Lens', iso, lens) import Data.Functor.Classes (showsBinaryWith) +import Fresnel.Iso (iso) +import Fresnel.Lens (Lens', lens) -- Positions diff --git a/src/Facet/Surface.hs b/src/Facet/Surface.hs index d3d8d28b8..dd36df0d7 100644 --- a/src/Facet/Surface.hs +++ b/src/Facet/Surface.hs @@ -27,13 +27,13 @@ module Facet.Surface , Comment(..) ) where -import Control.Lens (Lens, Lens', lens) import Data.Function (on) import Data.Text (Text) import Facet.Name import Facet.Snoc import Facet.Span import Facet.Syntax +import Fresnel.Lens (Lens, Lens', lens) -- Types diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index b471299c8..3180380a6 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -19,7 +19,6 @@ module Facet.Type.Norm ) where import Control.Effect.Empty -import Control.Lens (Prism', prism') import Data.Foldable (foldl') import Data.Function ((&)) import Data.Maybe (fromMaybe) @@ -35,6 +34,7 @@ import Facet.Syntax import Facet.Type import qualified Facet.Type.Expr as TX import Facet.Usage hiding (singleton) +import Fresnel.Prism (Prism', prism') import GHC.Stack import Prelude hiding (lookup) From a87783337b731c838a04bad73f41ad1e1b96aafa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Aug 2021 14:41:28 -0400 Subject: [PATCH 0293/1324] :fire: a redundant dependency. --- facet.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/facet.cabal b/facet.cabal index 6b2236208..a3869d255 100644 --- a/facet.cabal +++ b/facet.cabal @@ -145,7 +145,6 @@ library , filepath , fresnel , fused-effects - , fused-effects-lens , haskeline ^>= 0.8.1 , optparse-applicative , parsers From b9065dc671f36ef5f01b9df615676c0754c15e2d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Aug 2021 17:42:54 -0400 Subject: [PATCH 0294/1324] Rename Val to V. --- src/Facet/Polarized.hs | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index d6a198dfb..65a9f44d4 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -6,7 +6,7 @@ module Facet.Polarized , XType(..) , Expr(..) , Term(..) -, Val(..) +, V(..) , vvar , velim , Co(..) @@ -104,7 +104,7 @@ data Term | CElim Term (Co Term) deriving (Eq, Ord, Show) -instance Eval Term Val Val where +instance Eval Term V V where eval env = \case CVar i -> env ! getIndex i CLam b -> Lam (\ a -> eval (env :> a) b) @@ -120,17 +120,17 @@ instance Eval t e v => Eval (Co t) e (Co v) where Snd -> Snd Force -> Force -data Val - = Ne Level (Snoc (Co Val)) +data V + = Ne Level (Snoc (Co V)) -- negative - | Lam (Val -> Val) + | Lam (V -> V) -- positive | Unit - | Pair Val Val - | Thunk Val - deriving (Eq, Ord, Show) via Quoting Term Val + | Pair V V + | Thunk V + deriving (Eq, Ord, Show) via Quoting Term V -instance Quote Val Term where +instance Quote V Term where quote d = \case Ne l sp -> foldl' (\ t c -> CElim t (quote d c)) (CVar (levelToIndex d l)) sp Lam f -> CLam (quoteBinder vvar d f) @@ -139,10 +139,10 @@ instance Quote Val Term where Thunk b -> CThunk (quote d b) -vvar :: Level -> Val +vvar :: Level -> V vvar l = Ne l Nil -velim :: Val -> Co Val -> Val +velim :: V -> Co V -> V velim = curry $ \case (Ne v sp, c) -> Ne v (sp :> c) (Lam f, App a) -> f a From f2854403c112b63c32488ec2f3d004b931a7c941 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Aug 2021 17:43:03 -0400 Subject: [PATCH 0295/1324] Rename Co to K. --- src/Facet/Polarized.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 65a9f44d4..4e12772e9 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -9,7 +9,7 @@ module Facet.Polarized , V(..) , vvar , velim -, Co(..) +, K(..) , Elab(..) , Quote(..) , Eval(..) @@ -101,7 +101,7 @@ data Term | CUnit | CPair Term Term | CThunk Term - | CElim Term (Co Term) + | CElim Term (K Term) deriving (Eq, Ord, Show) instance Eval Term V V where @@ -113,7 +113,7 @@ instance Eval Term V V where CThunk b -> Thunk (eval env b) CElim t e -> velim (eval env t) (eval env e) -instance Eval t e v => Eval (Co t) e (Co v) where +instance Eval t e v => Eval (K t) e (K v) where eval env = \case App a -> App (eval env a) Fst -> Fst @@ -121,7 +121,7 @@ instance Eval t e v => Eval (Co t) e (Co v) where Force -> Force data V - = Ne Level (Snoc (Co V)) + = Ne Level (Snoc (K V)) -- negative | Lam (V -> V) -- positive @@ -142,7 +142,7 @@ instance Quote V Term where vvar :: Level -> V vvar l = Ne l Nil -velim :: V -> Co V -> V +velim :: V -> K V -> V velim = curry $ \case (Ne v sp, c) -> Ne v (sp :> c) (Lam f, App a) -> f a @@ -152,14 +152,14 @@ velim = curry $ \case (_, _) -> error "cannot elim" -data Co t +data K t = App t | Fst | Snd | Force deriving (Eq, Foldable, Functor, Ord, Show, Traversable) -instance Quote v t => Quote (Co v) (Co t) where +instance Quote v t => Quote (K v) (K t) where quote d = \case App a -> App (quote d a) Fst -> Fst From 2936fee1a20464b3ac3d539472b5d8cc025aeec5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Aug 2021 17:44:46 -0400 Subject: [PATCH 0296/1324] :fire: most of v, K, and Term. --- src/Facet/Polarized.hs | 32 +++----------------------------- 1 file changed, 3 insertions(+), 29 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 4e12772e9..3755eba62 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -98,9 +98,6 @@ data Expr data Term = CVar Index | CLam Term - | CUnit - | CPair Term Term - | CThunk Term | CElim Term (K Term) deriving (Eq, Ord, Show) @@ -108,35 +105,22 @@ instance Eval Term V V where eval env = \case CVar i -> env ! getIndex i CLam b -> Lam (\ a -> eval (env :> a) b) - CUnit -> Unit - CPair a b -> Pair (eval env a) (eval env b) - CThunk b -> Thunk (eval env b) CElim t e -> velim (eval env t) (eval env e) instance Eval t e v => Eval (K t) e (K v) where eval env = \case App a -> App (eval env a) - Fst -> Fst - Snd -> Snd - Force -> Force data V = Ne Level (Snoc (K V)) -- negative | Lam (V -> V) - -- positive - | Unit - | Pair V V - | Thunk V deriving (Eq, Ord, Show) via Quoting Term V instance Quote V Term where quote d = \case - Ne l sp -> foldl' (\ t c -> CElim t (quote d c)) (CVar (levelToIndex d l)) sp - Lam f -> CLam (quoteBinder vvar d f) - Unit -> CUnit - Pair a b -> CPair (quote d a) (quote d b) - Thunk b -> CThunk (quote d b) + Ne l sp -> foldl' (\ t c -> CElim t (quote d c)) (CVar (levelToIndex d l)) sp + Lam f -> CLam (quoteBinder vvar d f) vvar :: Level -> V @@ -146,25 +130,15 @@ velim :: V -> K V -> V velim = curry $ \case (Ne v sp, c) -> Ne v (sp :> c) (Lam f, App a) -> f a - (Pair a _, Fst) -> a - (Pair _ b, Snd) -> b - (Thunk v, Force) -> v - (_, _) -> error "cannot elim" -data K t +newtype K t = App t - | Fst - | Snd - | Force deriving (Eq, Foldable, Functor, Ord, Show, Traversable) instance Quote v t => Quote (K v) (K t) where quote d = \case App a -> App (quote d a) - Fst -> Fst - Snd -> Snd - Force -> Force newtype Elab a = Elab { elab :: [(String, Type)] -> Maybe a } From b418a20eb62dd2bd38036233e77ea9cb18737927 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Aug 2021 18:16:23 -0400 Subject: [PATCH 0297/1324] Generalize quoteBinder. --- src/Facet/Quote.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index dcc5afa3c..748a4e10f 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -15,7 +15,7 @@ class Quote v t | v -> t where quote :: Level -> v -> t -quoteBinder :: Quote v t => (Level -> v) -> Level -> (v -> v) -> t +quoteBinder :: Quote v t => (Level -> u) -> Level -> (u -> v) -> t quoteBinder var d f = quote (succ d) (f (var d)) From 6106735110e7157150e6279af271007d9c8bb203 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Aug 2021 18:21:26 -0400 Subject: [PATCH 0298/1324] Add type lambdas. Note that this adds some pretty significant complexity. --- src/Facet/Polarized.hs | 35 +++++++++++++++++++++++------------ 1 file changed, 23 insertions(+), 12 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 3755eba62..74e212f82 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -97,6 +97,8 @@ data Expr data Term = CVar Index + | CType Type + | CTLam Kind Term | CLam Term | CElim Term (K Term) deriving (Eq, Ord, Show) @@ -104,23 +106,28 @@ data Term instance Eval Term V V where eval env = \case CVar i -> env ! getIndex i + CType _T -> VType _T + CTLam k b -> TLam k (\ _T -> eval (env :> VType _T) b) CLam b -> Lam (\ a -> eval (env :> a) b) CElim t e -> velim (eval env t) (eval env e) -instance Eval t e v => Eval (K t) e (K v) where - eval env = \case - App a -> App (eval env a) +instance Eval m e v => Eval (K m) e (K v) where + eval = fmap . eval data V = Ne Level (Snoc (K V)) + | VType Type -- negative + | TLam Kind (Type -> V) | Lam (V -> V) deriving (Eq, Ord, Show) via Quoting Term V instance Quote V Term where quote d = \case - Ne l sp -> foldl' (\ t c -> CElim t (quote d c)) (CVar (levelToIndex d l)) sp - Lam f -> CLam (quoteBinder vvar d f) + Ne l sp -> foldl' (\ t c -> CElim t (quote d c)) (CVar (levelToIndex d l)) sp + VType _T -> CType _T + TLam k f -> CTLam k (quoteBinder (TVar k) d f) + Lam f -> CLam (quoteBinder vvar d f) vvar :: Level -> V @@ -128,17 +135,21 @@ vvar l = Ne l Nil velim :: V -> K V -> V velim = curry $ \case - (Ne v sp, c) -> Ne v (sp :> c) - (Lam f, App a) -> f a + (Ne v sp, k) -> Ne v (sp :> k) + (VType _T, k) -> error $ "cannot eliminate VType " <> show _T <> " with " <> show k + (Lam f, App a) -> f a + (Lam{}, k) -> error $ "cannot eliminate Lam with " <> show k + (TLam _ f, Inst t) -> f t + (TLam{}, k) -> error $ "cannot eliminate TLam with " <> show k -newtype K t - = App t +data K v + = App v + | Inst Type deriving (Eq, Foldable, Functor, Ord, Show, Traversable) -instance Quote v t => Quote (K v) (K t) where - quote d = \case - App a -> App (quote d a) +instance Quote v m => Quote (K v) (K m) where + quote = fmap . quote newtype Elab a = Elab { elab :: [(String, Type)] -> Maybe a } From e11793dce68ae68f857104375418a58ef605afed Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Aug 2021 18:23:50 -0400 Subject: [PATCH 0299/1324] Define a command type. --- src/Facet/Polarized.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 74e212f82..6c8178130 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -10,8 +10,8 @@ module Facet.Polarized , vvar , velim , K(..) +, C(..) , Elab(..) -, Quote(..) , Eval(..) ) where @@ -152,6 +152,10 @@ instance Quote v m => Quote (K v) (K m) where quote = fmap . quote +data C + = V :|: K V + + newtype Elab a = Elab { elab :: [(String, Type)] -> Maybe a } deriving (Functor) deriving (Applicative) via ReaderC [(String, Type)] Maybe From 42dccdaf510d53d5ac721ae956acad613b32030e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Aug 2021 20:59:16 -0400 Subject: [PATCH 0300/1324] Represent both term and type variables in the context. --- src/Facet/Polarized.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 6c8178130..221ecc3ab 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -17,6 +17,7 @@ module Facet.Polarized import Control.Carrier.Reader import Data.Foldable (foldl') +import Data.Maybe import Facet.Name import Facet.Quote import Facet.Snoc @@ -103,12 +104,12 @@ data Term | CElim Term (K Term) deriving (Eq, Ord, Show) -instance Eval Term V V where +instance Eval Term (Either Type V) V where eval env = \case - CVar i -> env ! getIndex i + CVar i -> fromJust (either (const Nothing) Just (env ! getIndex i)) CType _T -> VType _T - CTLam k b -> TLam k (\ _T -> eval (env :> VType _T) b) - CLam b -> Lam (\ a -> eval (env :> a) b) + CTLam k b -> TLam k (\ _T -> eval (env :> Left _T) b) + CLam b -> Lam (\ a -> eval (env :> Right a) b) CElim t e -> velim (eval env t) (eval env e) instance Eval m e v => Eval (K m) e (K v) where From 72e043ee135b5d884212495b89adc2af784c5973 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Aug 2021 20:59:56 -0400 Subject: [PATCH 0301/1324] :fire: VType/CType. --- src/Facet/Polarized.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 221ecc3ab..ace9e5902 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -98,7 +98,6 @@ data Expr data Term = CVar Index - | CType Type | CTLam Kind Term | CLam Term | CElim Term (K Term) @@ -107,7 +106,6 @@ data Term instance Eval Term (Either Type V) V where eval env = \case CVar i -> fromJust (either (const Nothing) Just (env ! getIndex i)) - CType _T -> VType _T CTLam k b -> TLam k (\ _T -> eval (env :> Left _T) b) CLam b -> Lam (\ a -> eval (env :> Right a) b) CElim t e -> velim (eval env t) (eval env e) @@ -117,7 +115,6 @@ instance Eval m e v => Eval (K m) e (K v) where data V = Ne Level (Snoc (K V)) - | VType Type -- negative | TLam Kind (Type -> V) | Lam (V -> V) @@ -126,7 +123,6 @@ data V instance Quote V Term where quote d = \case Ne l sp -> foldl' (\ t c -> CElim t (quote d c)) (CVar (levelToIndex d l)) sp - VType _T -> CType _T TLam k f -> CTLam k (quoteBinder (TVar k) d f) Lam f -> CLam (quoteBinder vvar d f) @@ -137,7 +133,6 @@ vvar l = Ne l Nil velim :: V -> K V -> V velim = curry $ \case (Ne v sp, k) -> Ne v (sp :> k) - (VType _T, k) -> error $ "cannot eliminate VType " <> show _T <> " with " <> show k (Lam f, App a) -> f a (Lam{}, k) -> error $ "cannot eliminate Lam with " <> show k (TLam _ f, Inst t) -> f t From c7fa6fedbf5d2ecbbf9ca9f42a0fbf946bb29310 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Aug 2021 21:01:20 -0400 Subject: [PATCH 0302/1324] Define a binding type. --- src/Facet/Polarized.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index ace9e5902..ad9e8ab9e 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -6,6 +6,7 @@ module Facet.Polarized , XType(..) , Expr(..) , Term(..) +, Binding(..) , V(..) , vvar , velim @@ -103,6 +104,10 @@ data Term | CElim Term (K Term) deriving (Eq, Ord, Show) +data Binding + = Tm V + | Ty Type + instance Eval Term (Either Type V) V where eval env = \case CVar i -> fromJust (either (const Nothing) Just (env ! getIndex i)) From 34829060454b06935884b48052789f886d93da88 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Aug 2021 21:01:53 -0400 Subject: [PATCH 0303/1324] Rename the constructors. --- src/Facet/Polarized.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index ad9e8ab9e..ade5da622 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -105,8 +105,8 @@ data Term deriving (Eq, Ord, Show) data Binding - = Tm V - | Ty Type + = V V + | T Type instance Eval Term (Either Type V) V where eval env = \case From 6ee345e53498bc29341e94b3cbb7f83136044487 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Aug 2021 21:02:49 -0400 Subject: [PATCH 0304/1324] Define a partial eliminator for Binding. --- src/Facet/Polarized.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index ade5da622..49867147b 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -7,6 +7,7 @@ module Facet.Polarized , Expr(..) , Term(..) , Binding(..) +, fromV , V(..) , vvar , velim @@ -108,6 +109,11 @@ data Binding = V V | T Type +fromV :: Binding -> V +fromV = \case + V v -> v + T _ -> error "fromV: type binding" + instance Eval Term (Either Type V) V where eval env = \case CVar i -> fromJust (either (const Nothing) Just (env ! getIndex i)) From 723e87a1ea9b39046a54a7df80ba8c6cb8b0f229 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Aug 2021 21:08:16 -0400 Subject: [PATCH 0305/1324] Use Binding in the Eval instance for Term/V. --- src/Facet/Polarized.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 49867147b..9dd842baf 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -19,7 +19,6 @@ module Facet.Polarized import Control.Carrier.Reader import Data.Foldable (foldl') -import Data.Maybe import Facet.Name import Facet.Quote import Facet.Snoc @@ -114,11 +113,11 @@ fromV = \case V v -> v T _ -> error "fromV: type binding" -instance Eval Term (Either Type V) V where +instance Eval Term Binding V where eval env = \case - CVar i -> fromJust (either (const Nothing) Just (env ! getIndex i)) - CTLam k b -> TLam k (\ _T -> eval (env :> Left _T) b) - CLam b -> Lam (\ a -> eval (env :> Right a) b) + CVar i -> fromV (env ! getIndex i) + CTLam k b -> TLam k (\ _T -> eval (env :> T _T) b) + CLam b -> Lam (\ a -> eval (env :> V a) b) CElim t e -> velim (eval env t) (eval env e) instance Eval m e v => Eval (K m) e (K v) where From 9fe077c6242a42f166b2a5687420e9305edf7a2b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Aug 2021 21:10:51 -0400 Subject: [PATCH 0306/1324] Infix. --- src/Facet/Polarized.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 9dd842baf..f2f0432e4 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -118,7 +118,7 @@ instance Eval Term Binding V where CVar i -> fromV (env ! getIndex i) CTLam k b -> TLam k (\ _T -> eval (env :> T _T) b) CLam b -> Lam (\ a -> eval (env :> V a) b) - CElim t e -> velim (eval env t) (eval env e) + CElim t e -> eval env t `velim` eval env e instance Eval m e v => Eval (K m) e (K v) where eval = fmap . eval From 12e75663470b2bf8b2c9729470ed53e1e31959a0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Aug 2021 21:12:16 -0400 Subject: [PATCH 0307/1324] Parameterize C by the type of values. --- src/Facet/Polarized.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index f2f0432e4..05844925c 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -158,8 +158,9 @@ instance Quote v m => Quote (K v) (K m) where quote = fmap . quote -data C - = V :|: K V +data C v + = v :|: K v + deriving (Eq, Foldable, Functor, Ord, Show, Traversable) newtype Elab a = Elab { elab :: [(String, Type)] -> Maybe a } From 19090081ec20287c1402377f61f4e38ecda71a8f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 08:00:59 -0400 Subject: [PATCH 0308/1324] Define a Quote instance for C. --- src/Facet/Polarized.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 05844925c..347df0766 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -162,6 +162,9 @@ data C v = v :|: K v deriving (Eq, Foldable, Functor, Ord, Show, Traversable) +instance Quote v t => Quote (C v) (C t) where + quote = fmap . quote + newtype Elab a = Elab { elab :: [(String, Type)] -> Maybe a } deriving (Functor) From d2cdd5c5d5ace569aa2de9514f4d400d833e1164 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 08:01:06 -0400 Subject: [PATCH 0309/1324] Define an Eval instance for C. --- src/Facet/Polarized.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 347df0766..632afd38d 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -165,6 +165,9 @@ data C v instance Quote v t => Quote (C v) (C t) where quote = fmap . quote +instance Eval m e v => Eval (C m) e (C v) where + eval = fmap . eval + newtype Elab a = Elab { elab :: [(String, Type)] -> Maybe a } deriving (Functor) From e8ed4a1e4c8489bf91a36e3fd6b36a7e9c2ebc1b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 08:09:42 -0400 Subject: [PATCH 0310/1324] Give Quote a parameter for the type of levels. This is intended to enable separate environments for e.g. types/terms or for continuations. --- src/Facet/Eval.hs | 2 +- src/Facet/Norm.hs | 4 ++-- src/Facet/Polarized.hs | 12 ++++++------ src/Facet/Print.hs | 6 +++--- src/Facet/Quote.hs | 16 +++++++--------- src/Facet/Type/Norm.hs | 4 ++-- 6 files changed, 21 insertions(+), 23 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 2b74e6ce3..35065cd94 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -132,7 +132,7 @@ data Value m | VDict [RName :=: Value m] | VComp [RName :=: Name] Expr -instance Monad m => Quote (Value m) (m Expr) where +instance Monad m => Quote (Value m) Level (m Expr) where quote d = \case VLam _ cs -> pure $ XLam cs VCont k -> quote (succ d) =<< k (VVar (Free (LName d __))) diff --git a/src/Facet/Norm.hs b/src/Facet/Norm.hs index a81384c76..ecb3f062e 100644 --- a/src/Facet/Norm.hs +++ b/src/Facet/Norm.hs @@ -25,9 +25,9 @@ data Norm | NNe (Var (LName Level)) (Snoc Norm) | NDict [RName :=: Norm] | NComp [RName :=: Name] (Pattern (Name :=: Norm) -> Norm) - deriving (Eq, Ord, Show) via Quoting Expr Norm + deriving (Eq, Ord, Show) via Quoting Level Expr Norm -instance Quote Norm Expr where +instance Quote Norm Level Expr where quote d = \case NString s -> XString s NCon n sp -> XCon n (quote d <$> sp) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 632afd38d..b5db54940 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -42,13 +42,13 @@ data Type | One | Type :>< Type | Type :>- Type - deriving (Eq, Ord, Show) via Quoting XType Type + deriving (Eq, Ord, Show) via Quoting Level XType Type infixr 2 :-> infixr 7 :>< infixl 2 :>- -instance Quote Type XType where +instance Quote Type Level XType where quote d = \case TVar k d' -> XTVar k (levelToIndex d d') Up t -> XUp (quote d t) @@ -128,9 +128,9 @@ data V -- negative | TLam Kind (Type -> V) | Lam (V -> V) - deriving (Eq, Ord, Show) via Quoting Term V + deriving (Eq, Ord, Show) via Quoting Level Term V -instance Quote V Term where +instance Quote V Level Term where quote d = \case Ne l sp -> foldl' (\ t c -> CElim t (quote d c)) (CVar (levelToIndex d l)) sp TLam k f -> CTLam k (quoteBinder (TVar k) d f) @@ -154,7 +154,7 @@ data K v | Inst Type deriving (Eq, Foldable, Functor, Ord, Show, Traversable) -instance Quote v m => Quote (K v) (K m) where +instance Quote v l m => Quote (K v) l (K m) where quote = fmap . quote @@ -162,7 +162,7 @@ data C v = v :|: K v deriving (Eq, Foldable, Functor, Ord, Show, Traversable) -instance Quote v t => Quote (C v) (C t) where +instance Quote v l t => Quote (C v) l (C t) where quote = fmap . quote instance Eval m e v => Eval (C m) e (C v) where diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 5e8ebafe2..21e398693 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -175,7 +175,7 @@ class Printable t where instance Printable Print where print _ _ = id -instance (Quote v t, Printable t) => Printable (Quoting t v) where +instance (Quote v Level t, Printable t) => Printable (Quoting Level t v) where print opts env = print opts env . quote (level env) . getQuoting instance Printable TN.Classifier where @@ -218,7 +218,7 @@ instance Printable TX.Type where | q == one -> (pretty '1' <+>) | otherwise -> id -deriving via (Quoting TX.Type TN.Type) instance Printable TN.Type +deriving via (Quoting Level TX.Type TN.Type) instance Printable TN.Type instance Printable C.Expr where @@ -241,7 +241,7 @@ instance Printable C.Expr where where p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) -deriving via (Quoting C.Expr N.Norm) instance Printable N.Norm +deriving via (Quoting Level C.Expr N.Norm) instance Printable N.Norm instance Printable a => Printable (Pattern a) where print = print1 diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index 748a4e10f..d37ca221f 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -7,27 +7,25 @@ module Facet.Quote , Quoting(..) ) where -import Facet.Name (Level) - -- Quotation -class Quote v t | v -> t where - quote :: Level -> v -> t +class Quote v l t | v -> l t where + quote :: l -> v -> t -quoteBinder :: Quote v t => (Level -> u) -> Level -> (u -> v) -> t +quoteBinder :: (Quote v l t, Enum l) => (l -> u) -> l -> (u -> v) -> t quoteBinder var d f = quote (succ d) (f (var d)) -- Deriving -newtype Quoting t v = Quoting { getQuoting :: v } +newtype Quoting l t v = Quoting { getQuoting :: v } -instance (Quote v t, Eq t) => Eq (Quoting t v) where +instance (Quote v l t, Num l, Eq t) => Eq (Quoting l t v) where Quoting a == Quoting b = quote 0 a == quote 0 b -instance (Quote v t, Ord t) => Ord (Quoting t v) where +instance (Quote v l t, Num l, Ord t) => Ord (Quoting l t v) where Quoting a `compare` Quoting b = quote 0 a `compare` quote 0 b -instance (Quote v t, Show t) => Show (Quoting t v) where +instance (Quote v l t, Num l, Show t) => Show (Quoting l t v) where showsPrec p = showsPrec p . quote 0 . getQuoting diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 3180380a6..60ea7eb36 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -46,9 +46,9 @@ data Type | Arrow (Maybe Name) Quantity Type Type | Ne (Var (Either Meta (LName Level))) (Snoc Type) | Comp (Signature Type) Type - deriving (Eq, Ord, Show) via Quoting TX.Type Type + deriving (Eq, Ord, Show) via Quoting Level TX.Type Type -instance Quote Type TX.Type where +instance Quote Type Level TX.Type where quote d = \case String -> TX.String ForAll n t b -> TX.ForAll n t (quote (succ d) (b (free (LName d n)))) From 50014bb54b5502e9863f408e77945cf0b3347c15 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 09:40:53 -0400 Subject: [PATCH 0311/1324] Revert "Give Quote a parameter for the type of levels." This reverts commit e8ed4a1e4c8489bf91a36e3fd6b36a7e9c2ebc1b. --- src/Facet/Eval.hs | 2 +- src/Facet/Norm.hs | 4 ++-- src/Facet/Polarized.hs | 12 ++++++------ src/Facet/Print.hs | 6 +++--- src/Facet/Quote.hs | 16 +++++++++------- src/Facet/Type/Norm.hs | 4 ++-- 6 files changed, 23 insertions(+), 21 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 35065cd94..2b74e6ce3 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -132,7 +132,7 @@ data Value m | VDict [RName :=: Value m] | VComp [RName :=: Name] Expr -instance Monad m => Quote (Value m) Level (m Expr) where +instance Monad m => Quote (Value m) (m Expr) where quote d = \case VLam _ cs -> pure $ XLam cs VCont k -> quote (succ d) =<< k (VVar (Free (LName d __))) diff --git a/src/Facet/Norm.hs b/src/Facet/Norm.hs index ecb3f062e..a81384c76 100644 --- a/src/Facet/Norm.hs +++ b/src/Facet/Norm.hs @@ -25,9 +25,9 @@ data Norm | NNe (Var (LName Level)) (Snoc Norm) | NDict [RName :=: Norm] | NComp [RName :=: Name] (Pattern (Name :=: Norm) -> Norm) - deriving (Eq, Ord, Show) via Quoting Level Expr Norm + deriving (Eq, Ord, Show) via Quoting Expr Norm -instance Quote Norm Level Expr where +instance Quote Norm Expr where quote d = \case NString s -> XString s NCon n sp -> XCon n (quote d <$> sp) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index b5db54940..632afd38d 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -42,13 +42,13 @@ data Type | One | Type :>< Type | Type :>- Type - deriving (Eq, Ord, Show) via Quoting Level XType Type + deriving (Eq, Ord, Show) via Quoting XType Type infixr 2 :-> infixr 7 :>< infixl 2 :>- -instance Quote Type Level XType where +instance Quote Type XType where quote d = \case TVar k d' -> XTVar k (levelToIndex d d') Up t -> XUp (quote d t) @@ -128,9 +128,9 @@ data V -- negative | TLam Kind (Type -> V) | Lam (V -> V) - deriving (Eq, Ord, Show) via Quoting Level Term V + deriving (Eq, Ord, Show) via Quoting Term V -instance Quote V Level Term where +instance Quote V Term where quote d = \case Ne l sp -> foldl' (\ t c -> CElim t (quote d c)) (CVar (levelToIndex d l)) sp TLam k f -> CTLam k (quoteBinder (TVar k) d f) @@ -154,7 +154,7 @@ data K v | Inst Type deriving (Eq, Foldable, Functor, Ord, Show, Traversable) -instance Quote v l m => Quote (K v) l (K m) where +instance Quote v m => Quote (K v) (K m) where quote = fmap . quote @@ -162,7 +162,7 @@ data C v = v :|: K v deriving (Eq, Foldable, Functor, Ord, Show, Traversable) -instance Quote v l t => Quote (C v) l (C t) where +instance Quote v t => Quote (C v) (C t) where quote = fmap . quote instance Eval m e v => Eval (C m) e (C v) where diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 21e398693..5e8ebafe2 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -175,7 +175,7 @@ class Printable t where instance Printable Print where print _ _ = id -instance (Quote v Level t, Printable t) => Printable (Quoting Level t v) where +instance (Quote v t, Printable t) => Printable (Quoting t v) where print opts env = print opts env . quote (level env) . getQuoting instance Printable TN.Classifier where @@ -218,7 +218,7 @@ instance Printable TX.Type where | q == one -> (pretty '1' <+>) | otherwise -> id -deriving via (Quoting Level TX.Type TN.Type) instance Printable TN.Type +deriving via (Quoting TX.Type TN.Type) instance Printable TN.Type instance Printable C.Expr where @@ -241,7 +241,7 @@ instance Printable C.Expr where where p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) -deriving via (Quoting Level C.Expr N.Norm) instance Printable N.Norm +deriving via (Quoting C.Expr N.Norm) instance Printable N.Norm instance Printable a => Printable (Pattern a) where print = print1 diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index d37ca221f..748a4e10f 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -7,25 +7,27 @@ module Facet.Quote , Quoting(..) ) where +import Facet.Name (Level) + -- Quotation -class Quote v l t | v -> l t where - quote :: l -> v -> t +class Quote v t | v -> t where + quote :: Level -> v -> t -quoteBinder :: (Quote v l t, Enum l) => (l -> u) -> l -> (u -> v) -> t +quoteBinder :: Quote v t => (Level -> u) -> Level -> (u -> v) -> t quoteBinder var d f = quote (succ d) (f (var d)) -- Deriving -newtype Quoting l t v = Quoting { getQuoting :: v } +newtype Quoting t v = Quoting { getQuoting :: v } -instance (Quote v l t, Num l, Eq t) => Eq (Quoting l t v) where +instance (Quote v t, Eq t) => Eq (Quoting t v) where Quoting a == Quoting b = quote 0 a == quote 0 b -instance (Quote v l t, Num l, Ord t) => Ord (Quoting l t v) where +instance (Quote v t, Ord t) => Ord (Quoting t v) where Quoting a `compare` Quoting b = quote 0 a `compare` quote 0 b -instance (Quote v l t, Num l, Show t) => Show (Quoting l t v) where +instance (Quote v t, Show t) => Show (Quoting t v) where showsPrec p = showsPrec p . quote 0 . getQuoting diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 60ea7eb36..3180380a6 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -46,9 +46,9 @@ data Type | Arrow (Maybe Name) Quantity Type Type | Ne (Var (Either Meta (LName Level))) (Snoc Type) | Comp (Signature Type) Type - deriving (Eq, Ord, Show) via Quoting Level TX.Type Type + deriving (Eq, Ord, Show) via Quoting TX.Type Type -instance Quote Type Level TX.Type where +instance Quote Type TX.Type where quote d = \case String -> TX.String ForAll n t b -> TX.ForAll n t (quote (succ d) (b (free (LName d n)))) From 16841e2685c78fc382d354b85c88c9f29a7d3f06 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 09:45:36 -0400 Subject: [PATCH 0312/1324] Lift Quote to * -> *. --- src/Facet/Quote.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index 748a4e10f..95a38a879 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -3,6 +3,7 @@ module Facet.Quote ( -- * Quotation Quote(..) , quoteBinder +, Quote1(..) -- * Deriving , Quoting(..) ) where @@ -19,6 +20,10 @@ quoteBinder :: Quote v t => (Level -> u) -> Level -> (u -> v) -> t quoteBinder var d f = quote (succ d) (f (var d)) +class Quote1 v t | v -> t where + liftQuoteWith :: (Level -> u -> s) -> Level -> v u -> t s + + -- Deriving newtype Quoting t v = Quoting { getQuoting :: v } From 0a1f01c787d4b7b73c8a764a3e0b94d3640fc116 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 09:46:17 -0400 Subject: [PATCH 0313/1324] Lift Quote through Quote1. --- src/Facet/Quote.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index 95a38a879..f82a610b0 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -4,6 +4,7 @@ module Facet.Quote Quote(..) , quoteBinder , Quote1(..) +, quote1 -- * Deriving , Quoting(..) ) where @@ -23,6 +24,9 @@ quoteBinder var d f = quote (succ d) (f (var d)) class Quote1 v t | v -> t where liftQuoteWith :: (Level -> u -> s) -> Level -> v u -> t s +quote1 :: (Quote u s, Quote1 v t) => Level -> v u -> t s +quote1 = liftQuoteWith quote + -- Deriving From 942cd1ba535a084f85492d154db7b216eefb4a8f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 09:47:38 -0400 Subject: [PATCH 0314/1324] Define a Quote1 instance for C. --- src/Facet/Polarized.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 632afd38d..aa42ba6c8 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -162,6 +162,9 @@ data C v = v :|: K v deriving (Eq, Foldable, Functor, Ord, Show, Traversable) +instance Quote1 C C where + liftQuoteWith = fmap fmap + instance Quote v t => Quote (C v) (C t) where quote = fmap . quote From 4bb36995e3ff41935d5833903834496c07cf05c5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 09:48:21 -0400 Subject: [PATCH 0315/1324] Define a Quote1 instance for K. --- src/Facet/Polarized.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index aa42ba6c8..141041fc5 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -154,6 +154,9 @@ data K v | Inst Type deriving (Eq, Foldable, Functor, Ord, Show, Traversable) +instance Quote1 K K where + liftQuoteWith = fmap fmap + instance Quote v m => Quote (K v) (K m) where quote = fmap . quote From ddcda1214d8fde19d195d0d0fdde6547d5d1c263 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 09:49:04 -0400 Subject: [PATCH 0316/1324] Define Quote instances via Quote1 instances. --- src/Facet/Polarized.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 141041fc5..fd856fde9 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -158,7 +158,7 @@ instance Quote1 K K where liftQuoteWith = fmap fmap instance Quote v m => Quote (K v) (K m) where - quote = fmap . quote + quote = quote1 data C v @@ -169,7 +169,7 @@ instance Quote1 C C where liftQuoteWith = fmap fmap instance Quote v t => Quote (C v) (C t) where - quote = fmap . quote + quote = quote1 instance Eval m e v => Eval (C m) e (C v) where eval = fmap . eval From 1dad3273924eff113b6cf8137ddccd1d1e06e7c1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 09:50:46 -0400 Subject: [PATCH 0317/1324] Define a generalization of quoteBinder to * -> *. --- src/Facet/Quote.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index f82a610b0..95bc9ea77 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -5,6 +5,7 @@ module Facet.Quote , quoteBinder , Quote1(..) , quote1 +, quoteBinderWith -- * Deriving , Quoting(..) ) where @@ -27,6 +28,9 @@ class Quote1 v t | v -> t where quote1 :: (Quote u s, Quote1 v t) => Level -> v u -> t s quote1 = liftQuoteWith quote +quoteBinderWith :: Quote1 v t => (Level -> u -> s) -> (Level -> r) -> Level -> (r -> v u) -> t s +quoteBinderWith with var d f = liftQuoteWith with (succ d) (f (var d)) + -- Deriving From 71844fe411409fccbc8c420594d7cef137b20ca1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 09:51:32 -0400 Subject: [PATCH 0318/1324] Rename quoteBinderWith to liftQuoteBinderWith. --- src/Facet/Quote.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index 95bc9ea77..e8f4cb0cd 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -5,7 +5,7 @@ module Facet.Quote , quoteBinder , Quote1(..) , quote1 -, quoteBinderWith +, liftQuoteBinderWith -- * Deriving , Quoting(..) ) where @@ -28,8 +28,8 @@ class Quote1 v t | v -> t where quote1 :: (Quote u s, Quote1 v t) => Level -> v u -> t s quote1 = liftQuoteWith quote -quoteBinderWith :: Quote1 v t => (Level -> u -> s) -> (Level -> r) -> Level -> (r -> v u) -> t s -quoteBinderWith with var d f = liftQuoteWith with (succ d) (f (var d)) +liftQuoteBinderWith :: Quote1 v t => (Level -> u -> s) -> (Level -> r) -> Level -> (r -> v u) -> t s +liftQuoteBinderWith with var d f = liftQuoteWith with (succ d) (f (var d)) -- Deriving From 7aa9f42c9e5bf6d664724a9ae59be9e66d251919 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 09:52:05 -0400 Subject: [PATCH 0319/1324] Spacing. --- src/Facet/Quote.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index e8f4cb0cd..0018bfeeb 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -17,7 +17,6 @@ import Facet.Name (Level) class Quote v t | v -> t where quote :: Level -> v -> t - quoteBinder :: Quote v t => (Level -> u) -> Level -> (u -> v) -> t quoteBinder var d f = quote (succ d) (f (var d)) From 6347821edeb28f3344a9fd5a597f845f27286c88 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 09:52:52 -0400 Subject: [PATCH 0320/1324] Generalize quoteBinder to non-Quote instances. --- src/Facet/Quote.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index 0018bfeeb..b4831ee10 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -3,6 +3,7 @@ module Facet.Quote ( -- * Quotation Quote(..) , quoteBinder +, quoteBinderWith , Quote1(..) , quote1 , liftQuoteBinderWith @@ -20,6 +21,9 @@ class Quote v t | v -> t where quoteBinder :: Quote v t => (Level -> u) -> Level -> (u -> v) -> t quoteBinder var d f = quote (succ d) (f (var d)) +quoteBinderWith :: (Level -> v -> t) -> (Level -> u) -> Level -> (u -> v) -> t +quoteBinderWith quote var d f = quote (succ d) (f (var d)) + class Quote1 v t | v -> t where liftQuoteWith :: (Level -> u -> s) -> Level -> v u -> t s From eecd16c0538d367b94fd4177b018423f4de526f1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 09:53:49 -0400 Subject: [PATCH 0321/1324] Define quoteBinder in terms of quoteBinderWith. --- src/Facet/Quote.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index b4831ee10..deb9f2059 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -19,7 +19,7 @@ class Quote v t | v -> t where quote :: Level -> v -> t quoteBinder :: Quote v t => (Level -> u) -> Level -> (u -> v) -> t -quoteBinder var d f = quote (succ d) (f (var d)) +quoteBinder = quoteBinderWith quote quoteBinderWith :: (Level -> v -> t) -> (Level -> u) -> Level -> (u -> v) -> t quoteBinderWith quote var d f = quote (succ d) (f (var d)) From e95168fb286a4b8957675cb8014f0c99e6ad4502 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 09:53:59 -0400 Subject: [PATCH 0322/1324] Define liftQuoteBinderWith in terms of quoteBinderWith. --- src/Facet/Quote.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index deb9f2059..923e8ff60 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -32,7 +32,7 @@ quote1 :: (Quote u s, Quote1 v t) => Level -> v u -> t s quote1 = liftQuoteWith quote liftQuoteBinderWith :: Quote1 v t => (Level -> u -> s) -> (Level -> r) -> Level -> (r -> v u) -> t s -liftQuoteBinderWith with var d f = liftQuoteWith with (succ d) (f (var d)) +liftQuoteBinderWith = quoteBinderWith . liftQuoteWith -- Deriving From fbd3385e23acfb2b0af868a6c5e988df6560ced5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 09:57:50 -0400 Subject: [PATCH 0323/1324] Lift Eval to * -> *. --- src/Facet/Polarized.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index fd856fde9..5247341e6 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -15,6 +15,7 @@ module Facet.Polarized , C(..) , Elab(..) , Eval(..) +, Eval1(..) ) where import Control.Carrier.Reader @@ -182,3 +183,6 @@ newtype Elab a = Elab { elab :: [(String, Type)] -> Maybe a } class Eval t e v | t -> e v where eval :: Snoc e -> t -> v + +class Eval1 t e v | t -> e v where + liftEvalWith :: (Snoc e -> s -> u) -> Snoc e -> t s -> v u From 4e0845c8baef40a46e8ef06332cd2d743696a5bd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 09:57:59 -0400 Subject: [PATCH 0324/1324] Lift Eval through Eval1. --- src/Facet/Polarized.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 5247341e6..30e3c03a2 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -16,6 +16,7 @@ module Facet.Polarized , Elab(..) , Eval(..) , Eval1(..) +, eval1 ) where import Control.Carrier.Reader @@ -186,3 +187,6 @@ class Eval t e v | t -> e v where class Eval1 t e v | t -> e v where liftEvalWith :: (Snoc e -> s -> u) -> Snoc e -> t s -> v u + +eval1 :: (Eval s e u, Eval1 t e v) => Snoc e -> t s -> v u +eval1 = liftEvalWith eval From 6f6c324f5846ba1fc7f841598a350dbb3214a14e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 09:59:21 -0400 Subject: [PATCH 0325/1324] =?UTF-8?q?Eval1=20doesn=E2=80=99t=20constrain?= =?UTF-8?q?=20the=20environment.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Polarized.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 30e3c03a2..47e81dde6 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -185,8 +185,8 @@ newtype Elab a = Elab { elab :: [(String, Type)] -> Maybe a } class Eval t e v | t -> e v where eval :: Snoc e -> t -> v -class Eval1 t e v | t -> e v where +class Eval1 t v | t -> v where liftEvalWith :: (Snoc e -> s -> u) -> Snoc e -> t s -> v u -eval1 :: (Eval s e u, Eval1 t e v) => Snoc e -> t s -> v u +eval1 :: (Eval s e u, Eval1 t v) => Snoc e -> t s -> v u eval1 = liftEvalWith eval From 4c3dd90d708115ee9258055d63012e44d28a10e2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 09:59:30 -0400 Subject: [PATCH 0326/1324] Define an Eval1 instance for C. --- src/Facet/Polarized.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 47e81dde6..dd3a27702 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -173,6 +173,9 @@ instance Quote1 C C where instance Quote v t => Quote (C v) (C t) where quote = quote1 +instance Eval1 C C where + liftEvalWith = fmap fmap + instance Eval m e v => Eval (C m) e (C v) where eval = fmap . eval From 8dfe1d4faad37bebfbce5bac022b0dcd34252c65 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 10:00:01 -0400 Subject: [PATCH 0327/1324] Define an Eval1 instance for K. --- src/Facet/Polarized.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index dd3a27702..40710ffaa 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -162,6 +162,9 @@ instance Quote1 K K where instance Quote v m => Quote (K v) (K m) where quote = quote1 +instance Eval1 K K where + liftEvalWith = fmap fmap + data C v = v :|: K v From d92828ffc8b9646e1d449db085c7c8b55267dd07 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 10:02:12 -0400 Subject: [PATCH 0328/1324] Define Eval instances in terms of Eval1 instances. --- src/Facet/Polarized.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 40710ffaa..5b9a952f7 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -123,7 +123,7 @@ instance Eval Term Binding V where CElim t e -> eval env t `velim` eval env e instance Eval m e v => Eval (K m) e (K v) where - eval = fmap . eval + eval = eval1 data V = Ne Level (Snoc (K V)) @@ -180,7 +180,7 @@ instance Eval1 C C where liftEvalWith = fmap fmap instance Eval m e v => Eval (C m) e (C v) where - eval = fmap . eval + eval = eval1 newtype Elab a = Elab { elab :: [(String, Type)] -> Maybe a } From b799899055fb10a3041a04a1d26af10cd9a56973 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 10:02:46 -0400 Subject: [PATCH 0329/1324] Move the Eval instance for K down. --- src/Facet/Polarized.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 5b9a952f7..fe034edd5 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -122,9 +122,6 @@ instance Eval Term Binding V where CLam b -> Lam (\ a -> eval (env :> V a) b) CElim t e -> eval env t `velim` eval env e -instance Eval m e v => Eval (K m) e (K v) where - eval = eval1 - data V = Ne Level (Snoc (K V)) -- negative @@ -165,6 +162,9 @@ instance Quote v m => Quote (K v) (K m) where instance Eval1 K K where liftEvalWith = fmap fmap +instance Eval m e v => Eval (K m) e (K v) where + eval = eval1 + data C v = v :|: K v From 189a88e8df79a7d14096a783e38f9e2140869878 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 11:50:05 -0400 Subject: [PATCH 0330/1324] =?UTF-8?q?Define=20=C2=B5-abstractions.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Polarized.hs | 79 ++++++++++++++++++++++++++++-------------- 1 file changed, 53 insertions(+), 26 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index fe034edd5..21683ce74 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -6,6 +6,7 @@ module Facet.Polarized , XType(..) , Expr(..) , Term(..) +, evalTerm , Binding(..) , fromV , V(..) @@ -20,7 +21,9 @@ module Facet.Polarized ) where import Control.Carrier.Reader +import Data.Bifunctor import Data.Foldable (foldl') +import Data.Function (on) import Facet.Name import Facet.Quote import Facet.Snoc @@ -103,9 +106,18 @@ data Term = CVar Index | CTLam Kind Term | CLam Term - | CElim Term (K Term) + | CMu (C Index Term) + | CElim Term (K Index Term) deriving (Eq, Ord, Show) +evalTerm :: Snoc Binding -> Snoc (K Level V) -> Term -> V +evalTerm env kenv = \case + CVar i -> fromV (env ! getIndex i) + CTLam k b -> TLam k (\ _T -> evalTerm (env :> T _T) kenv b) + CLam b -> Lam (\ a -> evalTerm (env :> V a) kenv b) + CMu c -> Mu (\ k -> bimap (indexToLevel (Level (length kenv))) (evalTerm env (kenv :> k)) c) + CElim t e -> evalTerm env kenv t `velim` bimap (indexToLevel (Level (length kenv))) (evalTerm env kenv) e + data Binding = V V | T Type @@ -115,71 +127,86 @@ fromV = \case V v -> v T _ -> error "fromV: type binding" -instance Eval Term Binding V where - eval env = \case - CVar i -> fromV (env ! getIndex i) - CTLam k b -> TLam k (\ _T -> eval (env :> T _T) b) - CLam b -> Lam (\ a -> eval (env :> V a) b) - CElim t e -> eval env t `velim` eval env e data V - = Ne Level (Snoc (K V)) + = Ne Level (Snoc (K Level V)) -- negative | TLam Kind (Type -> V) | Lam (V -> V) - deriving (Eq, Ord, Show) via Quoting Term V + | Mu (K Level V -> C Level V) -instance Quote V Term where - quote d = \case - Ne l sp -> foldl' (\ t c -> CElim t (quote d c)) (CVar (levelToIndex d l)) sp - TLam k f -> CTLam k (quoteBinder (TVar k) d f) - Lam f -> CLam (quoteBinder vvar d f) +instance Eq V where + (==) = (==) `on` quoteV 0 0 + +instance Ord V where + compare = compare `on` quoteV 0 0 + +instance Show V where + showsPrec p = showsPrec p . quoteV 0 0 + +quoteV :: Level -> Level -> V -> Term +quoteV lv lk = \case + Ne l sp -> foldl' (\ t c -> CElim t (bimap (levelToIndex lk) (quoteV lk lv) c)) (CVar (levelToIndex lv l)) sp + TLam k f -> CTLam k (quoteBinderWith (`quoteV` lk) (TVar k) lv f) + Lam f -> CLam (quoteBinderWith (`quoteV` lk) vvar lv f) + Mu f -> CMu (bimap (levelToIndex lk) (quoteV lv (succ lk)) (f (Ret lk))) vvar :: Level -> V vvar l = Ne l Nil -velim :: V -> K V -> V +velim :: V -> K Level V -> V velim = curry $ \case (Ne v sp, k) -> Ne v (sp :> k) (Lam f, App a) -> f a (Lam{}, k) -> error $ "cannot eliminate Lam with " <> show k (TLam _ f, Inst t) -> f t (TLam{}, k) -> error $ "cannot eliminate TLam with " <> show k + (Mu{}, k) -> error $ "cannot eliminate Mu with " <> show k -data K v +data K i v = App v | Inst Type + | Ret i deriving (Eq, Foldable, Functor, Ord, Show, Traversable) -instance Quote1 K K where +instance Bifunctor K where + bimap f g = \case + App c -> App (g c) + Inst ty -> Inst ty + Ret i -> Ret (f i) + +instance Quote1 (K Level) (K Level) where liftQuoteWith = fmap fmap -instance Quote v m => Quote (K v) (K m) where +instance Quote v m => Quote (K Level v) (K Level m) where quote = quote1 -instance Eval1 K K where +instance Eval1 (K Index) (K Index) where liftEvalWith = fmap fmap -instance Eval m e v => Eval (K m) e (K v) where +instance Eval m e v => Eval (K Index m) e (K Index v) where eval = eval1 -data C v - = v :|: K v +data C i v + = v :|: K i v deriving (Eq, Foldable, Functor, Ord, Show, Traversable) -instance Quote1 C C where +instance Bifunctor C where + bimap f g (v :|: k) = g v :|: bimap f g k + +instance Quote1 (C Level) (C Level) where liftQuoteWith = fmap fmap -instance Quote v t => Quote (C v) (C t) where +instance Quote v t => Quote (C Level v) (C Level t) where quote = quote1 -instance Eval1 C C where +instance Eval1 (C Index) (C Index) where liftEvalWith = fmap fmap -instance Eval m e v => Eval (C m) e (C v) where +instance Eval m e v => Eval (C Index m) e (C Index v) where eval = eval1 From 5f76f159ca495a7f55583d7dc76baec0c7d34a38 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 18:03:53 -0400 Subject: [PATCH 0331/1324] =?UTF-8?q?Evaluate=20=C2=B5-abstractions=20dire?= =?UTF-8?q?ctly.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Polarized.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 21683ce74..e4aba97ed 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -112,11 +112,11 @@ data Term evalTerm :: Snoc Binding -> Snoc (K Level V) -> Term -> V evalTerm env kenv = \case - CVar i -> fromV (env ! getIndex i) - CTLam k b -> TLam k (\ _T -> evalTerm (env :> T _T) kenv b) - CLam b -> Lam (\ a -> evalTerm (env :> V a) kenv b) - CMu c -> Mu (\ k -> bimap (indexToLevel (Level (length kenv))) (evalTerm env (kenv :> k)) c) - CElim t e -> evalTerm env kenv t `velim` bimap (indexToLevel (Level (length kenv))) (evalTerm env kenv) e + CVar i -> fromV (env ! getIndex i) + CTLam k b -> TLam k (\ _T -> evalTerm (env :> T _T) kenv b) + CLam b -> Lam (\ a -> evalTerm (env :> V a) kenv b) + CMu (v :|: k) -> evalTerm env kenv v `velim` bimap (indexToLevel (Level (length kenv))) (evalTerm env kenv) k + CElim t e -> evalTerm env kenv t `velim` bimap (indexToLevel (Level (length kenv))) (evalTerm env kenv) e data Binding = V V From e45569cc5dbf6f2d21754301886ab0b8aa91b19f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 18:05:26 -0400 Subject: [PATCH 0332/1324] Bind a return continuation. --- src/Facet/Polarized.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index e4aba97ed..db5d6506a 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -115,7 +115,7 @@ evalTerm env kenv = \case CVar i -> fromV (env ! getIndex i) CTLam k b -> TLam k (\ _T -> evalTerm (env :> T _T) kenv b) CLam b -> Lam (\ a -> evalTerm (env :> V a) kenv b) - CMu (v :|: k) -> evalTerm env kenv v `velim` bimap (indexToLevel (Level (length kenv))) (evalTerm env kenv) k + CMu (v :|: k) -> evalTerm env kenv v `velim` bimap (indexToLevel (Level (length kenv))) (evalTerm env (kenv :> Ret (Level (length kenv)))) k CElim t e -> evalTerm env kenv t `velim` bimap (indexToLevel (Level (length kenv))) (evalTerm env kenv) e data Binding From 42f33da6db15da51ee0bbf89b6b1f036b6e4c737 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 20:12:51 -0400 Subject: [PATCH 0333/1324] Mu subsumes Elim. --- src/Facet/Polarized.hs | 88 ++++++++++++++---------------------------- 1 file changed, 30 insertions(+), 58 deletions(-) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index db5d6506a..9e13c4363 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -13,7 +13,6 @@ module Facet.Polarized , vvar , velim , K(..) -, C(..) , Elab(..) , Eval(..) , Eval1(..) @@ -21,7 +20,6 @@ module Facet.Polarized ) where import Control.Carrier.Reader -import Data.Bifunctor import Data.Foldable (foldl') import Data.Function (on) import Facet.Name @@ -106,17 +104,29 @@ data Term = CVar Index | CTLam Kind Term | CLam Term - | CMu (C Index Term) - | CElim Term (K Index Term) + | CMu Term Coterm deriving (Eq, Ord, Show) -evalTerm :: Snoc Binding -> Snoc (K Level V) -> Term -> V +data Coterm + = CApp Term Coterm + | CInst Type Coterm + | CRet Index + deriving (Eq, Ord, Show) + +evalTerm :: Snoc Binding -> Snoc K -> Term -> V evalTerm env kenv = \case - CVar i -> fromV (env ! getIndex i) - CTLam k b -> TLam k (\ _T -> evalTerm (env :> T _T) kenv b) - CLam b -> Lam (\ a -> evalTerm (env :> V a) kenv b) - CMu (v :|: k) -> evalTerm env kenv v `velim` bimap (indexToLevel (Level (length kenv))) (evalTerm env (kenv :> Ret (Level (length kenv)))) k - CElim t e -> evalTerm env kenv t `velim` bimap (indexToLevel (Level (length kenv))) (evalTerm env kenv) e + CVar i -> fromV (env ! getIndex i) + CTLam k b -> TLam k (\ _T -> evalTerm (env :> T _T) kenv b) + CLam b -> Lam (\ a -> evalTerm (env :> V a) kenv b) + CMu v k -> foldl' velim (evalTerm env kenv v) (evalCoterm env (kenv :> Ret (Level (length kenv))) k) + +evalCoterm :: Snoc Binding -> Snoc K -> Coterm -> [K] +evalCoterm env kenv = go + where + go = \case + CApp a k -> App (evalTerm env kenv a) : go k + CInst t k -> Inst t : go k + CRet i -> [Ret (indexToLevel (Level (length kenv)) i)] data Binding = V V @@ -129,11 +139,10 @@ fromV = \case data V - = Ne Level (Snoc (K Level V)) + = Ne Level (Snoc K) -- negative | TLam Kind (Type -> V) | Lam (V -> V) - | Mu (K Level V -> C Level V) instance Eq V where (==) = (==) `on` quoteV 0 0 @@ -146,68 +155,31 @@ instance Show V where quoteV :: Level -> Level -> V -> Term quoteV lv lk = \case - Ne l sp -> foldl' (\ t c -> CElim t (bimap (levelToIndex lk) (quoteV lk lv) c)) (CVar (levelToIndex lv l)) sp + Ne l sp -> CMu (CVar (levelToIndex lv l)) (foldr (\case + App v -> CApp (quoteV lv lk v) + Inst t -> CInst t + Ret i -> const (CRet (levelToIndex lk i))) (CRet (Index 0)) sp) TLam k f -> CTLam k (quoteBinderWith (`quoteV` lk) (TVar k) lv f) Lam f -> CLam (quoteBinderWith (`quoteV` lk) vvar lv f) - Mu f -> CMu (bimap (levelToIndex lk) (quoteV lv (succ lk)) (f (Ret lk))) vvar :: Level -> V vvar l = Ne l Nil -velim :: V -> K Level V -> V +velim :: V -> K -> V velim = curry $ \case (Ne v sp, k) -> Ne v (sp :> k) (Lam f, App a) -> f a (Lam{}, k) -> error $ "cannot eliminate Lam with " <> show k (TLam _ f, Inst t) -> f t (TLam{}, k) -> error $ "cannot eliminate TLam with " <> show k - (Mu{}, k) -> error $ "cannot eliminate Mu with " <> show k -data K i v - = App v +data K + = App V | Inst Type - | Ret i - deriving (Eq, Foldable, Functor, Ord, Show, Traversable) - -instance Bifunctor K where - bimap f g = \case - App c -> App (g c) - Inst ty -> Inst ty - Ret i -> Ret (f i) - -instance Quote1 (K Level) (K Level) where - liftQuoteWith = fmap fmap - -instance Quote v m => Quote (K Level v) (K Level m) where - quote = quote1 - -instance Eval1 (K Index) (K Index) where - liftEvalWith = fmap fmap - -instance Eval m e v => Eval (K Index m) e (K Index v) where - eval = eval1 - - -data C i v - = v :|: K i v - deriving (Eq, Foldable, Functor, Ord, Show, Traversable) - -instance Bifunctor C where - bimap f g (v :|: k) = g v :|: bimap f g k - -instance Quote1 (C Level) (C Level) where - liftQuoteWith = fmap fmap - -instance Quote v t => Quote (C Level v) (C Level t) where - quote = quote1 - -instance Eval1 (C Index) (C Index) where - liftEvalWith = fmap fmap - -instance Eval m e v => Eval (C Index m) e (C Index v) where - eval = eval1 + | Ret Level + deriving (Eq, Ord, Show) newtype Elab a = Elab { elab :: [(String, Type)] -> Maybe a } From c74bf892a8e5db0b0ea2885ed380bacebc1da157 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 20:32:16 -0400 Subject: [PATCH 0334/1324] Define a Quoter newtype. --- src/Facet/Quote.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index 923e8ff60..4309e1434 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -9,6 +9,8 @@ module Facet.Quote , liftQuoteBinderWith -- * Deriving , Quoting(..) + -- * Quoters +, Quoter(..) ) where import Facet.Name (Level) @@ -47,3 +49,8 @@ instance (Quote v t, Ord t) => Ord (Quoting t v) where instance (Quote v t, Show t) => Show (Quoting t v) where showsPrec p = showsPrec p . quote 0 . getQuoting + + +-- Quoters + +newtype Quoter a = Quoter { runQuoter :: Level -> a } From 11c8451dc939609ee5c346d6a580b07f66fba962 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 22:33:49 -0400 Subject: [PATCH 0335/1324] Rename the term modules. --- facet.cabal | 4 ++-- src/Facet/Elab.hs | 2 +- src/Facet/Elab/Term.hs | 2 +- src/Facet/Eval.hs | 2 +- src/Facet/Module.hs | 2 +- src/Facet/Print.hs | 4 ++-- src/Facet/REPL.hs | 2 +- src/Facet/{Term.hs => Term/Expr.hs} | 2 +- src/Facet/{ => Term}/Norm.hs | 4 ++-- 9 files changed, 12 insertions(+), 12 deletions(-) rename src/Facet/{Term.hs => Term/Expr.hs} (98%) rename src/Facet/{ => Term}/Norm.hs (98%) diff --git a/facet.cabal b/facet.cabal index a3869d255..6d24fc6fa 100644 --- a/facet.cabal +++ b/facet.cabal @@ -98,7 +98,6 @@ library Facet.Lexer Facet.Module Facet.Name - Facet.Norm Facet.Notice Facet.Notice.Elab Facet.Notice.Parser @@ -122,7 +121,8 @@ library Facet.Subst Facet.Surface Facet.Syntax - Facet.Term + Facet.Term.Expr + Facet.Term.Norm Facet.Timing Facet.Type Facet.Type.Expr diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index f123907a6..164ca8778 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -77,7 +77,7 @@ import Facet.Source (Source, slice) import Facet.Span (Span(..)) import Facet.Subst import Facet.Syntax -import Facet.Term as E +import Facet.Term.Expr as E import qualified Facet.Type.Expr as TX import Facet.Type.Norm as TN import Facet.Usage as Usage diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 72f4b3bfd..521283d75 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -71,7 +71,7 @@ import Facet.Source (Source) import Facet.Subst import qualified Facet.Surface as S import Facet.Syntax -import Facet.Term as E +import Facet.Term.Expr as E import qualified Facet.Type.Expr as TX import Facet.Type.Norm as T hiding (global) import Facet.Unify diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 2b74e6ce3..479e6c304 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -45,7 +45,7 @@ import Facet.Quote import Facet.Semialign (zipWithM) import Facet.Snoc.NonEmpty as NE hiding ((|>)) import Facet.Syntax -import Facet.Term +import Facet.Term.Expr import GHC.Stack (HasCallStack) import Prelude hiding (zipWith) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 5c9c682cd..a0a66cd56 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -30,7 +30,7 @@ import qualified Data.Map as Map import Facet.Kind import Facet.Name import Facet.Syntax -import Facet.Term +import Facet.Term.Expr import Facet.Type.Norm import Fresnel.Iso (coerced) import Fresnel.Lens (Lens, Lens', lens) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 5e8ebafe2..ad375e2f7 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -34,7 +34,6 @@ import Facet.Interface import Facet.Kind import qualified Facet.Module as C import Facet.Name as Name -import qualified Facet.Norm as N import Facet.Pattern import Facet.Pretty (lower, upper) import Facet.Quote @@ -42,7 +41,8 @@ import Facet.Semiring (one, zero) import Facet.Snoc import Facet.Style import Facet.Syntax -import qualified Facet.Term as C +import qualified Facet.Term.Expr as C +import qualified Facet.Term.Norm as N import qualified Facet.Type.Expr as TX import qualified Facet.Type.Norm as TN import Prelude hiding (print) diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index e3c4ba642..10e4eef87 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -52,7 +52,7 @@ import Facet.Source (Source(..), sourceFromString) import Facet.Style as Style import qualified Facet.Surface as S import Facet.Syntax -import Facet.Term (Expr) +import Facet.Term.Expr (Expr) import Fresnel.Lens (Lens', lens) import Fresnel.Setter ((.~)) import Prelude hiding (span, unlines) diff --git a/src/Facet/Term.hs b/src/Facet/Term/Expr.hs similarity index 98% rename from src/Facet/Term.hs rename to src/Facet/Term/Expr.hs index cbb0543fe..6a7c9d511 100644 --- a/src/Facet/Term.hs +++ b/src/Facet/Term/Expr.hs @@ -1,4 +1,4 @@ -module Facet.Term +module Facet.Term.Expr ( -- * Term expressions Expr(..) , TExpr(..) diff --git a/src/Facet/Norm.hs b/src/Facet/Term/Norm.hs similarity index 98% rename from src/Facet/Norm.hs rename to src/Facet/Term/Norm.hs index a81384c76..3981b4525 100644 --- a/src/Facet/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -1,4 +1,4 @@ -module Facet.Norm +module Facet.Term.Norm ( Norm(..) , norm ) where @@ -16,7 +16,7 @@ import Facet.Quote import Facet.Semialign (zipWithM) import Facet.Snoc import Facet.Syntax -import Facet.Term +import Facet.Term.Expr data Norm = NString Text From edd781e27ecf18ed960693d9af97127662a7969c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 22:34:24 -0400 Subject: [PATCH 0336/1324] Define a module for a term class. --- facet.cabal | 1 + src/Facet/Term/Class.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Term/Class.hs diff --git a/facet.cabal b/facet.cabal index 6d24fc6fa..6715af5b9 100644 --- a/facet.cabal +++ b/facet.cabal @@ -121,6 +121,7 @@ library Facet.Subst Facet.Surface Facet.Syntax + Facet.Term.Class Facet.Term.Expr Facet.Term.Norm Facet.Timing diff --git a/src/Facet/Term/Class.hs b/src/Facet/Term/Class.hs new file mode 100644 index 000000000..02c72af69 --- /dev/null +++ b/src/Facet/Term/Class.hs @@ -0,0 +1,2 @@ +module Facet.Term.Class +() where From 164a3fd86b21e9ce082168698ae61da86dae12f4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 22:36:31 -0400 Subject: [PATCH 0337/1324] :fire: the X prefix from Term.Expr. --- src/Facet/Elab/Term.hs | 18 +++++++++--------- src/Facet/Eval.hs | 30 +++++++++++++++--------------- src/Facet/Print.hs | 18 +++++++++--------- src/Facet/Term/Expr.hs | 28 ++++++++++++++-------------- src/Facet/Term/Norm.hs | 28 ++++++++++++++-------------- 5 files changed, 61 insertions(+), 61 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 521283d75..51c96b70b 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -96,14 +96,14 @@ as (m ::: _T) = do -- FIXME: we’re instantiating when inspecting types in the REPL. global :: Algebra sig m => RName ::: Type -> Elab m (Expr :==> Type) -global (q ::: _T) = (\ (v ::: _T) -> v :==> _T) <$> instantiate const (XVar (Global q) ::: _T) +global (q ::: _T) = (\ (v ::: _T) -> v :==> _T) <$> instantiate const (Var (Global q) ::: _T) -- FIXME: do we need to instantiate here to deal with rank-n applications? -- FIXME: effect ops not in the sig are reported as not in scope -- FIXME: effect ops in the sig are available whether or not they’re in scope var :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (Expr :==> Type) var n = views context_ (lookupInContext n) >>= \case - [(n', q, CT _T)] -> use n' q $> (XVar (Free n') :==> _T) + [(n', q, CT _T)] -> use n' q $> (Var (Free n') :==> _T) _ -> resolveQ n >>= \case n :=: DTerm _ _T -> global (n ::: _T) _ :=: _ -> freeVariable n @@ -122,7 +122,7 @@ tlam b = Check $ \ _T -> do lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern (Name ::: Classifier)), Type <==: Elab m Expr)] -> Type <==: Elab m Expr lam cs = Check $ \ _T -> do (_A, _B) <- assertTacitFunction _T - XLam <$> traverse (\ (p, b) -> bind (p ::: _A) (check (b ::: _B))) cs + Lam <$> traverse (\ (p, b) -> bind (p ::: _A) (check (b ::: _B))) cs lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Type <==: Elab m Expr -> Type <==: Elab m Expr lam1 p b = lam [(p, b)] @@ -136,14 +136,14 @@ app mk operator operand = do string :: Text -> Elab m (Expr :==> Type) -string s = pure $ XString s :==> T.String +string s = pure $ E.String s :==> T.String let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Elab m (Expr :==> Type) -> Type <==: Elab m Expr -> Type <==: Elab m Expr let' p a b = Check $ \ _B -> do a' :==> _A <- a (p', b') <- bind (p ::: (Many, _A)) (check (b ::: _B)) - pure $ XLet p' a' b' + pure $ Let p' a' b' comp :: Has (Throw Err) sig m => Type <==: Elab m Expr -> Type <==: Elab m Expr @@ -155,7 +155,7 @@ comp b = Check $ \ _T -> do p' <- traverse interfacePattern (interfaces sig) -- FIXME: can we apply quantities to dictionaries? what would they mean? b' <- (Many, PDict p') |- check (b ::: _B) - pure $ XComp (map (fmap tm) p') b' + pure $ E.Comp (map (fmap tm) p') b' -- Pattern combinators @@ -205,7 +205,7 @@ synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \cas where nope = couldNotSynthesize synthApp :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Expr -> Elab m (Expr :==> Type) - synthApp f a = app XApp (synthExpr f) (checkExpr a) + synthApp f a = app App (synthExpr f) (checkExpr a) synthAs :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Type -> Elab m (Expr :==> Type) synthAs t _T = as (checkExpr t ::: do { _T :==> _K <- synthType _T ; (:==> _K) <$> evalTExpr _T }) @@ -256,7 +256,7 @@ abstractTerm body = go Nil Nil check (tlam (go (ts :> LName d n) fs) ::: T.ForAll n _T _B) T.Arrow n q _A _B -> do d <- depth - check (lam [(patternForArgType _A (fromMaybe __ n), go ts (fs :> \ d' -> XVar (Free (LName (levelToIndex d' d) (fromMaybe __ n)))))] ::: T.Arrow n q _A _B) + check (lam [(patternForArgType _A (fromMaybe __ n), go ts (fs :> \ d' -> Var (Free (LName (levelToIndex d' d) (fromMaybe __ n)))))] ::: T.Arrow n q _A _B) _T -> do d <- depth pure $ body (TX.Var . Free . Right . fmap (levelToIndex d) <$> ts) (fs <*> pure d) @@ -279,7 +279,7 @@ elabDataDef (dname ::: _K) constructors = do mname <- view name_ cs <- for constructors $ \ (S.Ann _ _ (n ::: t)) -> do c_T <- elabType $ abstractType (checkIsType (synthType t ::: KType)) _K - con' <- elabTerm $ check (abstractTerm (const (XCon (mname :.: n) . toList)) ::: c_T) + con' <- elabTerm $ check (abstractTerm (const (Con (mname :.: n) . toList)) ::: c_T) pure $ n :=: DTerm (Just con') c_T pure $ (dname :=: DData (scopeFromList cs) _K) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 479e6c304..d3a7df375 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -51,15 +51,15 @@ import Prelude hiding (zipWith) eval :: (HasCallStack, Has (Reader Graph :+: Reader Module) sig m, MonadFail m) => Expr -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) eval = \case - XVar (Global n) -> global n >>= eval - XVar (Free n) -> var n - XLam cs -> lam cs - XApp f a -> app (eval f) a - XCon n fs -> con n (eval <$> fs) - XString s -> string s - XDict os -> VDict <$> traverse (traverse eval) os - XLet p v b -> eval v >>= \ v' -> local (|> fromMaybe (error "eval: non-exhaustive pattern in let") (matchV id p v')) (eval b) - XComp p b -> comp p b + Var (Global n) -> global n >>= eval + Var (Free n) -> var n + Lam cs -> lam cs + App f a -> app (eval f) a + Con n fs -> con n (eval <$> fs) + String s -> string s + Dict os -> VDict <$> traverse (traverse eval) os + Let p v b -> eval v >>= \ v' -> local (|> fromMaybe (error "eval: non-exhaustive pattern in let") (matchV id p v')) (eval b) + Comp p b -> comp p b global :: Has (Reader Graph :+: Reader Module) sig m => RName -> ReaderC (Env (Value (Eval m))) (Eval m) Expr global n = do @@ -134,13 +134,13 @@ data Value m instance Monad m => Quote (Value m) (m Expr) where quote d = \case - VLam _ cs -> pure $ XLam cs + VLam _ cs -> pure $ Lam cs VCont k -> quote (succ d) =<< k (VVar (Free (LName d __))) - VVar v -> pure (XVar (fmap (levelToIndex d) <$> v)) - VCon n fs -> XCon n <$> traverse (quote d) fs - VString s -> pure $ XString s - VDict os -> XDict <$> traverse (traverse (quote d)) os - VComp p b -> pure $ XComp p b + VVar v -> pure (Var (fmap (levelToIndex d) <$> v)) + VCon n fs -> Con n <$> traverse (quote d) fs + VString s -> pure $ String s + VDict os -> Dict <$> traverse (traverse (quote d)) os + VComp p b -> pure $ Comp p b unit :: Value m unit = VCon (NE.FromList ["Data", "Unit"] :.: U "unit") [] diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index ad375e2f7..7b79e6e63 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -225,15 +225,15 @@ instance Printable C.Expr where print opts@Options{ rname } = go where go env = \case - C.XVar (Global n) -> qvar n - C.XVar (Free n) -> fromMaybe (lname (indexToLevel d <$> n)) $ Env.lookup env n - C.XLam cs -> comp (commaSep (map (clause env) cs)) - C.XApp f a -> go env f $$ go env a - C.XCon n p -> qvar n $$* (group . go env <$> p) - C.XString s -> annotate Lit $ pretty (show s) - C.XDict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> rname n <+> equals <+> group (go env v)) os) <> flatAlt space line) - C.XLet p v b -> let p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) in pretty "let" <+> braces (print opts env (def <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p') b - C.XComp p b -> comp (clause env (PDict p, b)) + C.Var (Global n) -> qvar n + C.Var (Free n) -> fromMaybe (lname (indexToLevel d <$> n)) $ Env.lookup env n + C.Lam cs -> comp (commaSep (map (clause env) cs)) + C.App f a -> go env f $$ go env a + C.Con n p -> qvar n $$* (group . go env <$> p) + C.String s -> annotate Lit $ pretty (show s) + C.Dict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> rname n <+> equals <+> group (go env v)) os) <> flatAlt space line) + C.Let p v b -> let p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) in pretty "let" <+> braces (print opts env (def <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p') b + C.Comp p b -> comp (clause env (PDict p, b)) where d = level env qvar = group . setPrec Var . rname diff --git a/src/Facet/Term/Expr.hs b/src/Facet/Term/Expr.hs index 6a7c9d511..1c1c7462e 100644 --- a/src/Facet/Term/Expr.hs +++ b/src/Facet/Term/Expr.hs @@ -14,14 +14,14 @@ import Facet.Syntax -- Term expressions data Expr - = XVar (Var (LName Index)) - | XLam [(Pattern Name, Expr)] - | XApp Expr Expr - | XCon RName [Expr] - | XString Text - | XDict [RName :=: Expr] - | XLet (Pattern Name) Expr Expr - | XComp [RName :=: Name] Expr -- ^ NB: the first argument is a specialization of @'Pattern' 'Name'@ to the 'PDict' constructor + = Var (Var (LName Index)) + | Lam [(Pattern Name, Expr)] + | App Expr Expr + | Con RName [Expr] + | String Text + | Dict [RName :=: Expr] + | Let (Pattern Name) Expr Expr + | Comp [RName :=: Name] Expr -- ^ NB: the first argument is a specialization of @'Pattern' 'Name'@ to the 'PDict' constructor deriving (Eq, Ord, Show) class TExpr expr where @@ -40,17 +40,17 @@ class TExpr expr where xlet :: T (Pattern Name) t -> expr t -> expr u -> expr u instance TExpr (T Expr) where - xvar = T . XVar . getT + xvar = T . Var . getT - xlam ps = T (XLam (map (bimap getT getT) ps)) + xlam ps = T (Lam (map (bimap getT getT) ps)) - xapp (T f) (T a) = T (f `XApp` a) + xapp (T f) (T a) = T (f `App` a) - xcon n b = T (XCon n (foldFields (pure . getT) b)) + xcon n b = T (Con n (foldFields (pure . getT) b)) - xstring = T . XString + xstring = T . String - xlet (T p) (T v) (T b) = T (XLet p v b) + xlet (T p) (T v) (T b) = T (Let p v b) class Fields f fs where diff --git a/src/Facet/Term/Norm.hs b/src/Facet/Term/Norm.hs index 3981b4525..45ed9a222 100644 --- a/src/Facet/Term/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -29,25 +29,25 @@ data Norm instance Quote Norm Expr where quote d = \case - NString s -> XString s - NCon n sp -> XCon n (quote d <$> sp) - NLam cs -> XLam (map (uncurry clause) cs) - NNe v sp -> foldl' (\ h -> XApp h . quote d) (XVar (fmap (levelToIndex d) <$> v)) sp - NDict os -> XDict (map (fmap (quote d)) os) - NComp p b -> XComp p (snd (clause (PDict p) b)) + NString s -> String s + NCon n sp -> Con n (quote d <$> sp) + NLam cs -> Lam (map (uncurry clause) cs) + NNe v sp -> foldl' (\ h -> App h . quote d) (Var (fmap (levelToIndex d) <$> v)) sp + NDict os -> Dict (map (fmap (quote d)) os) + NComp p b -> Comp p (snd (clause (PDict p) b)) where clause p b = let (d', p') = mapAccumL (\ d n -> (succ d, n :=: NNe (Free (LName d n)) Nil)) d p in (p, quote d' (b p')) norm :: Env Norm -> Expr -> Norm norm env = \case - XString s -> NString s - XVar v -> NNe (fmap (indexToLevel (level env)) <$> v) Nil - XCon n sp -> NCon n (norm env <$> sp) - XApp f a -> norm env f `napp` norm env a - XLam cs -> NLam (map (\ (p, b) -> (p, \ p' -> norm (env |> p') b)) cs) - XDict os -> NDict (map (fmap (norm env)) os) - XLet p v b -> norm (env |> fromMaybe (error "norm: non-exhaustive pattern in let") (match (norm env v) p)) b - XComp p b -> NComp p (\ p' -> norm (env |> p') b) + String s -> NString s + Var v -> NNe (fmap (indexToLevel (level env)) <$> v) Nil + Con n sp -> NCon n (norm env <$> sp) + App f a -> norm env f `napp` norm env a + Lam cs -> NLam (map (\ (p, b) -> (p, \ p' -> norm (env |> p') b)) cs) + Dict os -> NDict (map (fmap (norm env)) os) + Let p v b -> norm (env |> fromMaybe (error "norm: non-exhaustive pattern in let") (match (norm env v) p)) b + Comp p b -> NComp p (\ p' -> norm (env |> p') b) napp :: Norm -> Norm -> Norm From 9b5e7d9d6d8967970aa195134feec5b8be53ec0e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 22:37:59 -0400 Subject: [PATCH 0338/1324] Qualify the Expr constructors. --- src/Facet/Term/Norm.hs | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Facet/Term/Norm.hs b/src/Facet/Term/Norm.hs index 45ed9a222..211f07841 100644 --- a/src/Facet/Term/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -16,7 +16,7 @@ import Facet.Quote import Facet.Semialign (zipWithM) import Facet.Snoc import Facet.Syntax -import Facet.Term.Expr +import Facet.Term.Expr as X data Norm = NString Text @@ -29,25 +29,25 @@ data Norm instance Quote Norm Expr where quote d = \case - NString s -> String s - NCon n sp -> Con n (quote d <$> sp) - NLam cs -> Lam (map (uncurry clause) cs) - NNe v sp -> foldl' (\ h -> App h . quote d) (Var (fmap (levelToIndex d) <$> v)) sp - NDict os -> Dict (map (fmap (quote d)) os) - NComp p b -> Comp p (snd (clause (PDict p) b)) + NString s -> X.String s + NCon n sp -> X.Con n (quote d <$> sp) + NLam cs -> X.Lam (map (uncurry clause) cs) + NNe v sp -> foldl' (\ h -> X.App h . quote d) (X.Var (fmap (levelToIndex d) <$> v)) sp + NDict os -> X.Dict (map (fmap (quote d)) os) + NComp p b -> X.Comp p (snd (clause (PDict p) b)) where clause p b = let (d', p') = mapAccumL (\ d n -> (succ d, n :=: NNe (Free (LName d n)) Nil)) d p in (p, quote d' (b p')) norm :: Env Norm -> Expr -> Norm norm env = \case - String s -> NString s - Var v -> NNe (fmap (indexToLevel (level env)) <$> v) Nil - Con n sp -> NCon n (norm env <$> sp) - App f a -> norm env f `napp` norm env a - Lam cs -> NLam (map (\ (p, b) -> (p, \ p' -> norm (env |> p') b)) cs) - Dict os -> NDict (map (fmap (norm env)) os) - Let p v b -> norm (env |> fromMaybe (error "norm: non-exhaustive pattern in let") (match (norm env v) p)) b - Comp p b -> NComp p (\ p' -> norm (env |> p') b) + X.String s -> NString s + X.Var v -> NNe (fmap (indexToLevel (level env)) <$> v) Nil + X.Con n sp -> NCon n (norm env <$> sp) + X.App f a -> norm env f `napp` norm env a + X.Lam cs -> NLam (map (\ (p, b) -> (p, \ p' -> norm (env |> p') b)) cs) + X.Dict os -> NDict (map (fmap (norm env)) os) + X.Let p v b -> norm (env |> fromMaybe (error "norm: non-exhaustive pattern in let") (match (norm env v) p)) b + X.Comp p b -> NComp p (\ p' -> norm (env |> p') b) napp :: Norm -> Norm -> Norm From 4c4ded7cf6ec1b8b172b1440aae18c3dafca4bd7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 22:40:47 -0400 Subject: [PATCH 0339/1324] Strip the prefix from the Norm constructors. --- src/Facet/Term/Norm.hs | 81 +++++++++++++++++++++--------------------- 1 file changed, 41 insertions(+), 40 deletions(-) diff --git a/src/Facet/Term/Norm.hs b/src/Facet/Term/Norm.hs index 211f07841..2c3a2963f 100644 --- a/src/Facet/Term/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -3,71 +3,72 @@ module Facet.Term.Norm , norm ) where -import Control.Monad (guard) -import Data.Foldable (foldl') -import Data.Maybe (fromMaybe) -import Data.Monoid -import Data.Text (Text) -import Data.Traversable (mapAccumL) -import Facet.Env -import Facet.Name -import Facet.Pattern -import Facet.Quote -import Facet.Semialign (zipWithM) -import Facet.Snoc -import Facet.Syntax -import Facet.Term.Expr as X +import Control.Monad (guard) +import Data.Foldable (foldl') +import Data.Maybe (fromMaybe) +import Data.Monoid +import Data.Text (Text) +import Data.Traversable (mapAccumL) +import Facet.Env +import Facet.Name +import Facet.Pattern +import Facet.Quote +import Facet.Semialign (zipWithM) +import Facet.Snoc +import Facet.Syntax +import Facet.Term.Expr (Expr) +import qualified Facet.Term.Expr as X data Norm - = NString Text - | NCon RName [Norm] - | NLam [(Pattern Name, Pattern (Name :=: Norm) -> Norm)] - | NNe (Var (LName Level)) (Snoc Norm) - | NDict [RName :=: Norm] - | NComp [RName :=: Name] (Pattern (Name :=: Norm) -> Norm) + = String Text + | Con RName [Norm] + | Lam [(Pattern Name, Pattern (Name :=: Norm) -> Norm)] + | Ne (Var (LName Level)) (Snoc Norm) + | Dict [RName :=: Norm] + | Comp [RName :=: Name] (Pattern (Name :=: Norm) -> Norm) deriving (Eq, Ord, Show) via Quoting Expr Norm instance Quote Norm Expr where quote d = \case - NString s -> X.String s - NCon n sp -> X.Con n (quote d <$> sp) - NLam cs -> X.Lam (map (uncurry clause) cs) - NNe v sp -> foldl' (\ h -> X.App h . quote d) (X.Var (fmap (levelToIndex d) <$> v)) sp - NDict os -> X.Dict (map (fmap (quote d)) os) - NComp p b -> X.Comp p (snd (clause (PDict p) b)) + String s -> X.String s + Con n sp -> X.Con n (quote d <$> sp) + Lam cs -> X.Lam (map (uncurry clause) cs) + Ne v sp -> foldl' (\ h -> X.App h . quote d) (X.Var (fmap (levelToIndex d) <$> v)) sp + Dict os -> X.Dict (map (fmap (quote d)) os) + Comp p b -> X.Comp p (snd (clause (PDict p) b)) where - clause p b = let (d', p') = mapAccumL (\ d n -> (succ d, n :=: NNe (Free (LName d n)) Nil)) d p in (p, quote d' (b p')) + clause p b = let (d', p') = mapAccumL (\ d n -> (succ d, n :=: Ne (Free (LName d n)) Nil)) d p in (p, quote d' (b p')) norm :: Env Norm -> Expr -> Norm norm env = \case - X.String s -> NString s - X.Var v -> NNe (fmap (indexToLevel (level env)) <$> v) Nil - X.Con n sp -> NCon n (norm env <$> sp) + X.String s -> String s + X.Var v -> Ne (fmap (indexToLevel (level env)) <$> v) Nil + X.Con n sp -> Con n (norm env <$> sp) X.App f a -> norm env f `napp` norm env a - X.Lam cs -> NLam (map (\ (p, b) -> (p, \ p' -> norm (env |> p') b)) cs) - X.Dict os -> NDict (map (fmap (norm env)) os) + X.Lam cs -> Lam (map (\ (p, b) -> (p, \ p' -> norm (env |> p') b)) cs) + X.Dict os -> Dict (map (fmap (norm env)) os) X.Let p v b -> norm (env |> fromMaybe (error "norm: non-exhaustive pattern in let") (match (norm env v) p)) b - X.Comp p b -> NComp p (\ p' -> norm (env |> p') b) + X.Comp p b -> Comp p (\ p' -> norm (env |> p') b) napp :: Norm -> Norm -> Norm napp f a = case f of - NLam cs -> case getFirst (foldMap (\ (p, b) -> First (b <$> match a p)) cs) of + Lam cs -> case getFirst (foldMap (\ (p, b) -> First (b <$> match a p)) cs) of Just a' -> a' Nothing -> error "napp: non-exhaustive patterns in lambda" - NNe h sp -> NNe h (sp :> a) - _ -> error "napp: ill-formed application" + Ne h sp -> Ne h (sp :> a) + _ -> error "napp: ill-formed application" match :: Norm -> Pattern Name -> Maybe (Pattern (Name :=: Norm)) match s = \case PWildcard -> Just PWildcard PVar n -> Just (PVar (n :=: s)) PCon n ps -> case s of - NCon n' fs -> PCon n' <$ guard (n == n') <*> zipWithM match fs ps - _ -> Nothing + Con n' fs -> PCon n' <$ guard (n == n') <*> zipWithM match fs ps + _ -> Nothing PDict ps -> case s of - NDict os -> PDict <$> zipWithM (\ (n1 :=: o) (n2 :=: p) -> (n1 :=: (p :=: o)) <$ guard (n1 == n2)) os ps - _ -> Nothing + Dict os -> PDict <$> zipWithM (\ (n1 :=: o) (n2 :=: p) -> (n1 :=: (p :=: o)) <$ guard (n1 == n2)) os ps + _ -> Nothing -- ninst :: Norm -> T.Type -> Norm -- ninst f t = case f of From 6a8800fed49b3743203ab3001f971a0cb9ed52a8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 22:44:05 -0400 Subject: [PATCH 0340/1324] Rename Norm to Term. --- src/Facet/Print.hs | 2 +- src/Facet/Term/Norm.hs | 26 +++++++++++++------------- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 7b79e6e63..8af20d33e 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -241,7 +241,7 @@ instance Printable C.Expr where where p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) -deriving via (Quoting C.Expr N.Norm) instance Printable N.Norm +deriving via (Quoting C.Expr N.Term) instance Printable N.Term instance Printable a => Printable (Pattern a) where print = print1 diff --git a/src/Facet/Term/Norm.hs b/src/Facet/Term/Norm.hs index 2c3a2963f..379eb8ff8 100644 --- a/src/Facet/Term/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -1,5 +1,5 @@ module Facet.Term.Norm -( Norm(..) +( Term(..) , norm ) where @@ -19,16 +19,16 @@ import Facet.Syntax import Facet.Term.Expr (Expr) import qualified Facet.Term.Expr as X -data Norm +data Term = String Text - | Con RName [Norm] - | Lam [(Pattern Name, Pattern (Name :=: Norm) -> Norm)] - | Ne (Var (LName Level)) (Snoc Norm) - | Dict [RName :=: Norm] - | Comp [RName :=: Name] (Pattern (Name :=: Norm) -> Norm) - deriving (Eq, Ord, Show) via Quoting Expr Norm + | Con RName [Term] + | Lam [(Pattern Name, Pattern (Name :=: Term) -> Term)] + | Ne (Var (LName Level)) (Snoc Term) + | Dict [RName :=: Term] + | Comp [RName :=: Name] (Pattern (Name :=: Term) -> Term) + deriving (Eq, Ord, Show) via Quoting Expr Term -instance Quote Norm Expr where +instance Quote Term Expr where quote d = \case String s -> X.String s Con n sp -> X.Con n (quote d <$> sp) @@ -39,7 +39,7 @@ instance Quote Norm Expr where where clause p b = let (d', p') = mapAccumL (\ d n -> (succ d, n :=: Ne (Free (LName d n)) Nil)) d p in (p, quote d' (b p')) -norm :: Env Norm -> Expr -> Norm +norm :: Env Term -> Expr -> Term norm env = \case X.String s -> String s X.Var v -> Ne (fmap (indexToLevel (level env)) <$> v) Nil @@ -51,7 +51,7 @@ norm env = \case X.Comp p b -> Comp p (\ p' -> norm (env |> p') b) -napp :: Norm -> Norm -> Norm +napp :: Term -> Term -> Term napp f a = case f of Lam cs -> case getFirst (foldMap (\ (p, b) -> First (b <$> match a p)) cs) of Just a' -> a' @@ -59,7 +59,7 @@ napp f a = case f of Ne h sp -> Ne h (sp :> a) _ -> error "napp: ill-formed application" -match :: Norm -> Pattern Name -> Maybe (Pattern (Name :=: Norm)) +match :: Term -> Pattern Name -> Maybe (Pattern (Name :=: Term)) match s = \case PWildcard -> Just PWildcard PVar n -> Just (PVar (n :=: s)) @@ -70,7 +70,7 @@ match s = \case Dict os -> PDict <$> zipWithM (\ (n1 :=: o) (n2 :=: p) -> (n1 :=: (p :=: o)) <$ guard (n1 == n2)) os ps _ -> Nothing --- ninst :: Norm -> T.Type -> Norm +-- ninst :: Term -> T.Type -> Term -- ninst f t = case f of -- NTLam _ b -> b t -- NNe h sp -> NNe h (sp :> EInst t) From 12e13ef290f1aa405d9e25efc99e3e2467e190df Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Aug 2021 22:47:20 -0400 Subject: [PATCH 0341/1324] Rename Term.Expr to Term. --- src/Facet/Elab.hs | 6 +++--- src/Facet/Elab/Term.hs | 34 +++++++++++++++++----------------- src/Facet/Eval.hs | 16 ++++++++-------- src/Facet/Module.hs | 6 +++--- src/Facet/Print.hs | 4 ++-- src/Facet/REPL.hs | 4 ++-- src/Facet/Term/Expr.hs | 18 +++++++++--------- src/Facet/Term/Norm.hs | 7 +++---- 8 files changed, 47 insertions(+), 48 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 164ca8778..49f7914fe 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -120,7 +120,7 @@ resolveWith lookup n = asks (\ StaticContext{ module', graph } -> lookupWith loo [v] -> pure v ds -> ambiguousName n (map (\ (q :=: _) -> q) ds) -resolveC :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (RName :=: Maybe Expr ::: Type) +resolveC :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (RName :=: Maybe Term ::: Type) resolveC = resolveWith lookupC resolveQ :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (RName :=: Def) @@ -333,10 +333,10 @@ elabKind = elabWith zero (const pure) elabType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m TX.Type -> m Type elabType = elabWith zero (\ subst t -> pure (TN.eval subst Env.empty t)) -elabTerm :: Has (Reader Graph :+: Reader Module :+: Reader Source) sig m => Elab m Expr -> m Expr +elabTerm :: Has (Reader Graph :+: Reader Module :+: Reader Source) sig m => Elab m Term -> m Term elabTerm = elabWith one (const pure) -elabSynthTerm :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (Expr :==> Type) -> m (Expr :==> Type) +elabSynthTerm :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (Term :==> Type) -> m (Term :==> Type) elabSynthTerm = elabWith one (\ subst (e :==> _T) -> pure (e :==> TN.eval subst Env.empty (quote 0 _T))) elabSynthType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (TX.Type :==> Kind) -> m (Type :==> Kind) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 51c96b70b..d9f5d0c1d 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -85,7 +85,7 @@ switch m = Check $ \ _Exp -> m >>= \case a :==> T.Comp req _Act -> require req >> unify (Exp _Exp) (Act _Act) $> a a :==> _Act -> unify (Exp _Exp) (Act _Act) $> a -as :: (HasCallStack, Has (Throw Err) sig m) => (Type <==: Elab m Expr) ::: Elab m (Type :==> Kind) -> Elab m (Expr :==> Type) +as :: (HasCallStack, Has (Throw Err) sig m) => (Type <==: Elab m Term) ::: Elab m (Type :==> Kind) -> Elab m (Term :==> Type) as (m ::: _T) = do _T' <- checkIsType (_T ::: KType) a <- check (m ::: _T') @@ -95,13 +95,13 @@ as (m ::: _T) = do -- Term combinators -- FIXME: we’re instantiating when inspecting types in the REPL. -global :: Algebra sig m => RName ::: Type -> Elab m (Expr :==> Type) +global :: Algebra sig m => RName ::: Type -> Elab m (Term :==> Type) global (q ::: _T) = (\ (v ::: _T) -> v :==> _T) <$> instantiate const (Var (Global q) ::: _T) -- FIXME: do we need to instantiate here to deal with rank-n applications? -- FIXME: effect ops not in the sig are reported as not in scope -- FIXME: effect ops in the sig are available whether or not they’re in scope -var :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (Expr :==> Type) +var :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (Term :==> Type) var n = views context_ (lookupInContext n) >>= \case [(n', q, CT _T)] -> use n' q $> (Var (Free n') :==> _T) _ -> resolveQ n >>= \case @@ -113,18 +113,18 @@ hole :: (HasCallStack, Has (Throw Err) sig m) => Name -> Type <==: Elab m a hole n = Check $ \ _T -> withFrozenCallStack $ err $ Hole n (CT _T) -tlam :: (HasCallStack, Has (Throw Err) sig m) => Type <==: Elab m Expr -> Type <==: Elab m Expr +tlam :: (HasCallStack, Has (Throw Err) sig m) => Type <==: Elab m Term -> Type <==: Elab m Term tlam b = Check $ \ _T -> do (n ::: _A, _B) <- assertQuantifier _T d <- depth (zero, PVar (n ::: CK _A)) |- check (b ::: _B (T.free (LName d n))) -lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern (Name ::: Classifier)), Type <==: Elab m Expr)] -> Type <==: Elab m Expr +lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern (Name ::: Classifier)), Type <==: Elab m Term)] -> Type <==: Elab m Term lam cs = Check $ \ _T -> do (_A, _B) <- assertTacitFunction _T Lam <$> traverse (\ (p, b) -> bind (p ::: _A) (check (b ::: _B))) cs -lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Type <==: Elab m Expr -> Type <==: Elab m Expr +lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Type <==: Elab m Term -> Type <==: Elab m Term lam1 p b = lam [(p, b)] app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Elab m (a :==> Type)) -> (HasCallStack => Type <==: Elab m b) -> Elab m (c :==> Type) @@ -135,18 +135,18 @@ app mk operator operand = do pure $ mk f' a' :==> _B -string :: Text -> Elab m (Expr :==> Type) +string :: Text -> Elab m (Term :==> Type) string s = pure $ E.String s :==> T.String -let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Elab m (Expr :==> Type) -> Type <==: Elab m Expr -> Type <==: Elab m Expr +let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Elab m (Term :==> Type) -> Type <==: Elab m Term -> Type <==: Elab m Term let' p a b = Check $ \ _B -> do a' :==> _A <- a (p', b') <- bind (p ::: (Many, _A)) (check (b ::: _B)) pure $ Let p' a' b' -comp :: Has (Throw Err) sig m => Type <==: Elab m Expr -> Type <==: Elab m Expr +comp :: Has (Throw Err) sig m => Type <==: Elab m Term -> Type <==: Elab m Term comp b = Check $ \ _T -> do (sig, _B) <- assertComp _T StaticContext{ graph, module' } <- ask @@ -194,7 +194,7 @@ allP n = Bind $ \ _A k -> do -- Expression elaboration -synthExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Elab m (Expr :==> Type) +synthExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Elab m (Term :==> Type) synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \case S.Var n -> var n S.App f a -> synthApp f a @@ -204,13 +204,13 @@ synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \cas S.Lam{} -> nope where nope = couldNotSynthesize - synthApp :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Expr -> Elab m (Expr :==> Type) + synthApp :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Expr -> Elab m (Term :==> Type) synthApp f a = app App (synthExpr f) (checkExpr a) - synthAs :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Type -> Elab m (Expr :==> Type) + synthAs :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Type -> Elab m (Term :==> Type) synthAs t _T = as (checkExpr t ::: do { _T :==> _K <- synthType _T ; (:==> _K) <$> evalTExpr _T }) -checkExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Type <==: Elab m Expr +checkExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Type <==: Elab m Term checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in flip withSpanC expr $ \case S.Hole n -> hole n S.Lam cs -> checkLam cs @@ -219,10 +219,10 @@ checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in flip withS S.As{} -> switch (synthExpr expr) S.String{} -> switch (synthExpr expr) -checkLam :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => [S.Clause] -> Type <==: Elab m Expr +checkLam :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => [S.Clause] -> Type <==: Elab m Term checkLam cs = lam (snd vs) where - vs :: Has (Throw Err :+: Write Warn) sig m => ([QName :=: (Type <==: Elab m Expr)], [(Bind m (Pattern (Name ::: Classifier)), Type <==: Elab m Expr)]) + vs :: Has (Throw Err :+: Write Warn) sig m => ([QName :=: (Type <==: Elab m Term)], [(Bind m (Pattern (Name ::: Classifier)), Type <==: Elab m Term)]) vs = partitionEithers (map (\ (S.Clause (S.Ann _ _ p) b) -> case p of S.PVal p -> Right (bindPattern p, checkExpr b) S.PEff (S.Ann s _ (S.POp n fs k)) -> Left $ n :=: Check (\ _T -> pushSpan s (foldr (lam1 . bindPattern) (checkExpr b) (fromList fs:>k) <==: _T))) cs) @@ -247,7 +247,7 @@ abstractType body = go KArrow (Just n) a b -> TX.ForAll n a <$> ((zero, PVar (n ::: CK a)) |- go b) _ -> body -abstractTerm :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => (Snoc TX.Type -> Snoc Expr -> Expr) -> Type <==: Elab m Expr +abstractTerm :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => (Snoc TX.Type -> Snoc Term -> Term) -> Type <==: Elab m Term abstractTerm body = go Nil Nil where go ts fs = Check $ \case @@ -301,7 +301,7 @@ elabTermDef :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source :+: Throw Err :+: Write Warn) sig m) => Type -> S.Ann S.Expr - -> m Expr + -> m Term elabTermDef _T expr@(S.Ann s _ _) = do elabTerm $ pushSpan s $ check (go (checkExpr expr) ::: _T) where diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index d3a7df375..cad82ec3b 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -49,7 +49,7 @@ import Facet.Term.Expr import GHC.Stack (HasCallStack) import Prelude hiding (zipWith) -eval :: (HasCallStack, Has (Reader Graph :+: Reader Module) sig m, MonadFail m) => Expr -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) +eval :: (HasCallStack, Has (Reader Graph :+: Reader Module) sig m, MonadFail m) => Term -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) eval = \case Var (Global n) -> global n >>= eval Var (Free n) -> var n @@ -61,7 +61,7 @@ eval = \case Let p v b -> eval v >>= \ v' -> local (|> fromMaybe (error "eval: non-exhaustive pattern in let") (matchV id p v')) (eval b) Comp p b -> comp p b -global :: Has (Reader Graph :+: Reader Module) sig m => RName -> ReaderC (Env (Value (Eval m))) (Eval m) Expr +global :: Has (Reader Graph :+: Reader Module) sig m => RName -> ReaderC (Env (Value (Eval m))) (Eval m) Term global n = do mod <- lift ask graph <- lift ask @@ -72,10 +72,10 @@ global n = do var :: (HasCallStack, Algebra sig m) => LName Index -> ReaderC (Env (Value m)) m (Value m) var n = asks (`index` n) -lam :: Algebra sig m => [(Pattern Name, Expr)] -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) +lam :: Algebra sig m => [(Pattern Name, Term)] -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) lam cs = asks (`VLam` cs) -app :: (HasCallStack, Has (Reader Graph :+: Reader Module) sig m, MonadFail m) => ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) -> Expr -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) +app :: (HasCallStack, Has (Reader Graph :+: Reader Module) sig m, MonadFail m) => ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) -> Term -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) app f a = ask >>= \ envCallSite -> f >>= \case VLam env cs -> lift (k a) where k = foldl' (\ vs (p, b) -> runReader envCallSite . eval >=> fromMaybe (vs a) . matchV (\ vs -> runReader (env |> vs) (eval b)) p) (const (fail "non-exhaustive patterns in lambda")) cs @@ -88,7 +88,7 @@ string = pure . VString con :: RName -> [ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m))] -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) con n fs = VCon n <$> sequenceA fs -comp :: [RName :=: Name] -> Expr -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) +comp :: [RName :=: Name] -> Term -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) comp p b = pure $ VComp p b @@ -126,13 +126,13 @@ data Value m -- | Value; strings. | VString Text -- | Computation; lambdas. - | VLam (Env (Value m)) [(Pattern Name, Expr)] + | VLam (Env (Value m)) [(Pattern Name, Term)] -- | Computation; continuations, used in effect handlers. | VCont (Value m -> m (Value m)) | VDict [RName :=: Value m] - | VComp [RName :=: Name] Expr + | VComp [RName :=: Name] Term -instance Monad m => Quote (Value m) (m Expr) where +instance Monad m => Quote (Value m) (m Term) where quote d = \case VLam _ cs -> pure $ Lam cs VCont k -> quote (succ d) =<< k (VVar (Free (LName d __))) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index a0a66cd56..28865a670 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -71,7 +71,7 @@ foldMapC f = getChoosing #. foldMap (Choosing #. f) {-# INLINE (#.) #-} -lookupC :: Has (Choose :+: Empty) sig m => Name -> Module -> m (RName :=: Maybe Expr ::: Type) +lookupC :: Has (Choose :+: Empty) sig m => Name -> Module -> m (RName :=: Maybe Term ::: Type) lookupC n Module{ name, scope } = foldMapC matchDef (decls scope) where matchDef = matchTerm <=< lookupScope n . tm <=< unDData @@ -107,12 +107,12 @@ newtype Import = Import { name :: MName } data Def - = DTerm (Maybe Expr) Type + = DTerm (Maybe Term) Type | DData (Scope Def) Kind | DInterface (Scope Type) Kind | DModule (Scope Def) Kind -unDTerm :: Has Empty sig m => Def -> m (Maybe Expr ::: Type) +unDTerm :: Has Empty sig m => Def -> m (Maybe Term ::: Type) unDTerm = \case DTerm expr _T -> pure $ expr ::: _T _ -> empty diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 8af20d33e..63f33d447 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -221,7 +221,7 @@ instance Printable TX.Type where deriving via (Quoting TX.Type TN.Type) instance Printable TN.Type -instance Printable C.Expr where +instance Printable C.Term where print opts@Options{ rname } = go where go env = \case @@ -241,7 +241,7 @@ instance Printable C.Expr where where p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) -deriving via (Quoting C.Expr N.Term) instance Printable N.Term +deriving via (Quoting C.Term N.Term) instance Printable N.Term instance Printable a => Printable (Pattern a) where print = print1 diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index 10e4eef87..5372920b9 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -52,7 +52,7 @@ import Facet.Source (Source(..), sourceFromString) import Facet.Style as Style import qualified Facet.Surface as S import Facet.Syntax -import Facet.Term.Expr (Expr) +import Facet.Term.Expr (Term) import Fresnel.Lens (Lens', lens) import Fresnel.Setter ((.~)) import Prelude hiding (span, unlines) @@ -206,7 +206,7 @@ showEval e = Action $ do opts <- get outputDocLn (getPrint (ann (Print.print opts mempty e'' ::: Print.print opts mempty _T))) -runEvalMain :: (Has (Error (Notice.Notice (Doc Style)) :+: Output :+: Reader Graph :+: Reader Module :+: State Options) sig m, MonadFail m) => Expr -> m Expr +runEvalMain :: (Has (Error (Notice.Notice (Doc Style)) :+: Output :+: Reader Graph :+: Reader Module :+: State Options) sig m, MonadFail m) => Term -> m Term runEvalMain e = runEval (quote 0 =<< runReader mempty (eval e)) pure -- where -- hdl = [(write, Handler handle)] diff --git a/src/Facet/Term/Expr.hs b/src/Facet/Term/Expr.hs index 1c1c7462e..e1a176027 100644 --- a/src/Facet/Term/Expr.hs +++ b/src/Facet/Term/Expr.hs @@ -1,6 +1,6 @@ module Facet.Term.Expr ( -- * Term expressions - Expr(..) + Term(..) , TExpr(..) , Fields(..) ) where @@ -13,15 +13,15 @@ import Facet.Syntax -- Term expressions -data Expr +data Term = Var (Var (LName Index)) - | Lam [(Pattern Name, Expr)] - | App Expr Expr - | Con RName [Expr] + | Lam [(Pattern Name, Term)] + | App Term Term + | Con RName [Term] | String Text - | Dict [RName :=: Expr] - | Let (Pattern Name) Expr Expr - | Comp [RName :=: Name] Expr -- ^ NB: the first argument is a specialization of @'Pattern' 'Name'@ to the 'PDict' constructor + | Dict [RName :=: Term] + | Let (Pattern Name) Term Term + | Comp [RName :=: Name] Term -- ^ NB: the first argument is a specialization of @'Pattern' 'Name'@ to the 'PDict' constructor deriving (Eq, Ord, Show) class TExpr expr where @@ -39,7 +39,7 @@ class TExpr expr where xlet :: T (Pattern Name) t -> expr t -> expr u -> expr u -instance TExpr (T Expr) where +instance TExpr (T Term) where xvar = T . Var . getT xlam ps = T (Lam (map (bimap getT getT) ps)) diff --git a/src/Facet/Term/Norm.hs b/src/Facet/Term/Norm.hs index 379eb8ff8..239f7c878 100644 --- a/src/Facet/Term/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -16,7 +16,6 @@ import Facet.Quote import Facet.Semialign (zipWithM) import Facet.Snoc import Facet.Syntax -import Facet.Term.Expr (Expr) import qualified Facet.Term.Expr as X data Term @@ -26,9 +25,9 @@ data Term | Ne (Var (LName Level)) (Snoc Term) | Dict [RName :=: Term] | Comp [RName :=: Name] (Pattern (Name :=: Term) -> Term) - deriving (Eq, Ord, Show) via Quoting Expr Term + deriving (Eq, Ord, Show) via Quoting X.Term Term -instance Quote Term Expr where +instance Quote Term X.Term where quote d = \case String s -> X.String s Con n sp -> X.Con n (quote d <$> sp) @@ -39,7 +38,7 @@ instance Quote Term Expr where where clause p b = let (d', p') = mapAccumL (\ d n -> (succ d, n :=: Ne (Free (LName d n)) Nil)) d p in (p, quote d' (b p')) -norm :: Env Term -> Expr -> Term +norm :: Env Term -> X.Term -> Term norm env = \case X.String s -> String s X.Var v -> Ne (fmap (indexToLevel (level env)) <$> v) Nil From 4be0d431fd38a17a6223f7ba64048850f6665bf8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 07:23:32 -0400 Subject: [PATCH 0342/1324] Define a Term class. --- src/Facet/Term/Class.hs | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/src/Facet/Term/Class.hs b/src/Facet/Term/Class.hs index 02c72af69..dc98dfd98 100644 --- a/src/Facet/Term/Class.hs +++ b/src/Facet/Term/Class.hs @@ -1,2 +1,17 @@ module Facet.Term.Class -() where +( Term(..) +) where + +import Data.Text (Text) +import Facet.Name +import Facet.Pattern +import Facet.Syntax + +class Term r where + string :: Text -> r + con :: RName -> [r] -> r + lam :: [(Pattern Name, Pattern (Name :=: r) -> r)] -> r + var :: Var (LName Level) -> r + app :: r -> r -> r + dict :: [RName :=: r] -> r + comp :: [RName :=: Name] -> (Pattern (Name :=: r) -> r) -> r From 94a717fd273593464c0b12c88d0683d72dca067e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 07:23:42 -0400 Subject: [PATCH 0343/1324] Define a Term instance for Norm. --- src/Facet/Term/Norm.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/Facet/Term/Norm.hs b/src/Facet/Term/Norm.hs index 239f7c878..a9261cf7a 100644 --- a/src/Facet/Term/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -16,6 +16,7 @@ import Facet.Quote import Facet.Semialign (zipWithM) import Facet.Snoc import Facet.Syntax +import qualified Facet.Term.Class as C import qualified Facet.Term.Expr as X data Term @@ -27,6 +28,15 @@ data Term | Comp [RName :=: Name] (Pattern (Name :=: Term) -> Term) deriving (Eq, Ord, Show) via Quoting X.Term Term +instance C.Term Term where + string = String + con = Con + lam = Lam + var = (`Ne` Nil) + app = napp + dict = Dict + comp = Comp + instance Quote Term X.Term where quote d = \case String s -> X.String s From 4c26a235806d9e5dc32074915c6d9e518a3954a7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 07:28:35 -0400 Subject: [PATCH 0344/1324] Derive some instances for Quoter. --- src/Facet/Quote.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index 4309e1434..e8b8bd74d 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -54,3 +54,4 @@ instance (Quote v t, Show t) => Show (Quoting t v) where -- Quoters newtype Quoter a = Quoter { runQuoter :: Level -> a } + deriving (Applicative, Functor, Monad) From 19f667716ceb2187b9aad4c655186a3d6be84e92 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 07:32:42 -0400 Subject: [PATCH 0345/1324] Convert LNames between Index and Level contents. --- src/Facet/Name.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 7f1e36354..90e7af909 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -13,6 +13,8 @@ module Facet.Name , (.:.) , toQ , LName(..) +, lnameToIndex +, lnameToLevel , Name(..) , Assoc(..) , Op(..) @@ -106,6 +108,12 @@ toQ (m :.: n) = toSnoc m :. n data LName v = LName v Name deriving (Eq, Foldable, Functor, Ord, Show, Traversable) +lnameToIndex :: Level -> LName Level -> LName Index +lnameToIndex = fmap . levelToIndex + +lnameToLevel :: Level -> LName Index -> LName Level +lnameToLevel = fmap . indexToLevel + -- | Declaration names; a choice of expression, constructor, term, or operator names. data Name From 9f19421b784bb9e5964cdc71bbd5862522f5c060 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 07:39:03 -0400 Subject: [PATCH 0346/1324] Define a class modelling translations between de Bruijn levels and indices. --- src/Facet/Name.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 90e7af909..439b259ae 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE OverloadedStrings #-} module Facet.Name ( Index(..) , Level(..) , levelToIndex , indexToLevel +, DeBruijn(..) , Meta(..) , __ , MName @@ -56,6 +58,11 @@ indexToLevel :: Level -> Index -> Level indexToLevel (Level d) (Index index) = Level $ d - index - 1 +class DeBruijn lv ix | lv -> ix, ix -> lv where + toIndexed :: lv -> ix + toLeveled :: ix -> lv + + newtype Meta = Meta { getMeta :: Int } deriving (Eq, Ord, Show) From 9e8b12465a52dad458840c4d2e2ca455f5949f1b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 07:39:45 -0400 Subject: [PATCH 0347/1324] De Bruijn translations take the current Level. --- src/Facet/Name.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 439b259ae..af52170a4 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -59,8 +59,8 @@ indexToLevel (Level d) (Index index) = Level $ d - index - 1 class DeBruijn lv ix | lv -> ix, ix -> lv where - toIndexed :: lv -> ix - toLeveled :: ix -> lv + toIndexed :: Level -> lv -> ix + toLeveled :: Level -> ix -> lv newtype Meta = Meta { getMeta :: Int } From 599b16b8e14afd198ef503e00f88c64b7464984c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 07:40:26 -0400 Subject: [PATCH 0348/1324] Define a DeBruijn instance for Level/Index. --- src/Facet/Name.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index af52170a4..526970378 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -62,6 +62,10 @@ class DeBruijn lv ix | lv -> ix, ix -> lv where toIndexed :: Level -> lv -> ix toLeveled :: Level -> ix -> lv +instance DeBruijn Level Index where + toIndexed = levelToIndex + toLeveled = indexToLevel + newtype Meta = Meta { getMeta :: Int } deriving (Eq, Ord, Show) From 047d8c488acd3a05911e4dc86dbd5819d36747ae Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 07:41:27 -0400 Subject: [PATCH 0349/1324] Define a DeBruijn instance for LName. --- src/Facet/Name.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 526970378..ed77d744c 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} module Facet.Name ( Index(..) , Level(..) @@ -119,6 +120,10 @@ toQ (m :.: n) = toSnoc m :. n data LName v = LName v Name deriving (Eq, Foldable, Functor, Ord, Show, Traversable) +instance DeBruijn lv ix => DeBruijn (LName lv) (LName ix) where + toIndexed = fmap . toIndexed + toLeveled = fmap . toLeveled + lnameToIndex :: Level -> LName Level -> LName Index lnameToIndex = fmap . levelToIndex From f9e1b7c8ca20ff07374103b0c6d7fa4d9814ad37 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 07:41:50 -0400 Subject: [PATCH 0350/1324] Define a DeBruijn instance for Var. --- src/Facet/Syntax.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 783fcc090..a43fe3f57 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -1,5 +1,6 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} module Facet.Syntax ( (:::)(..) , tm @@ -87,6 +88,10 @@ data Var a | Free a deriving (Eq, Foldable, Functor, Ord, Show, Traversable) +instance DeBruijn lv ix => DeBruijn (Var lv) (Var ix) where + toIndexed = fmap . toIndexed + toLeveled = fmap . toLeveled + -- Decomposition From 04227c6c5e369056cf610a90987591cd86b18eee Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 07:42:27 -0400 Subject: [PATCH 0351/1324] :fire: lnameToIndex/Level. --- src/Facet/Name.hs | 8 -------- 1 file changed, 8 deletions(-) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index ed77d744c..6a5dbbc2b 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -16,8 +16,6 @@ module Facet.Name , (.:.) , toQ , LName(..) -, lnameToIndex -, lnameToLevel , Name(..) , Assoc(..) , Op(..) @@ -124,12 +122,6 @@ instance DeBruijn lv ix => DeBruijn (LName lv) (LName ix) where toIndexed = fmap . toIndexed toLeveled = fmap . toLeveled -lnameToIndex :: Level -> LName Level -> LName Index -lnameToIndex = fmap . levelToIndex - -lnameToLevel :: Level -> LName Index -> LName Level -lnameToLevel = fmap . indexToLevel - -- | Declaration names; a choice of expression, constructor, term, or operator names. data Name From 2348c83fa9ce9d03dcf6baab52b2761537695f2b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 07:45:20 -0400 Subject: [PATCH 0352/1324] Define a DeBruijn instance for Either. --- src/Facet/Name.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 6a5dbbc2b..20ae250cf 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -65,6 +65,10 @@ instance DeBruijn Level Index where toIndexed = levelToIndex toLeveled = indexToLevel +instance DeBruijn lv ix => DeBruijn (Either e lv) (Either e ix) where + toIndexed = fmap . toIndexed + toLeveled = fmap . toLeveled + newtype Meta = Meta { getMeta :: Int } deriving (Eq, Ord, Show) From ee7b70b8757f356519516af107f492a3d310f004 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 07:50:25 -0400 Subject: [PATCH 0353/1324] Replace indexToLevel and levelToIndex with DeBruijn. --- src/Facet/Elab.hs | 2 +- src/Facet/Elab/Term.hs | 4 ++-- src/Facet/Eval.hs | 2 +- src/Facet/Name.hs | 12 ++---------- src/Facet/Polarized.hs | 8 ++++---- src/Facet/Print.hs | 4 ++-- src/Facet/Term/Norm.hs | 4 ++-- src/Facet/Type/Expr.hs | 2 +- src/Facet/Type/Norm.hs | 2 +- 9 files changed, 16 insertions(+), 24 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 49f7914fe..7890c907e 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -174,7 +174,7 @@ depth = views context_ level use :: Has (Reader ElabContext :+: Writer Usage) sig m => LName Index -> Quantity -> m () use n q = do d <- depth - tell (Usage.singleton (indexToLevel d <$> n) q) + tell (Usage.singleton (toLeveled d n) q) -- Errors diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index d9f5d0c1d..b0c65d9cf 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -256,10 +256,10 @@ abstractTerm body = go Nil Nil check (tlam (go (ts :> LName d n) fs) ::: T.ForAll n _T _B) T.Arrow n q _A _B -> do d <- depth - check (lam [(patternForArgType _A (fromMaybe __ n), go ts (fs :> \ d' -> Var (Free (LName (levelToIndex d' d) (fromMaybe __ n)))))] ::: T.Arrow n q _A _B) + check (lam [(patternForArgType _A (fromMaybe __ n), go ts (fs :> \ d' -> Var (Free (LName (toIndexed d' d) (fromMaybe __ n)))))] ::: T.Arrow n q _A _B) _T -> do d <- depth - pure $ body (TX.Var . Free . Right . fmap (levelToIndex d) <$> ts) (fs <*> pure d) + pure $ body (TX.Var . Free . Right . toIndexed d <$> ts) (fs <*> pure d) patternForArgType :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Type -> Name -> Bind m (Pattern (Name ::: Classifier)) patternForArgType = \case diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index cad82ec3b..6bcf23b1e 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -136,7 +136,7 @@ instance Monad m => Quote (Value m) (m Term) where quote d = \case VLam _ cs -> pure $ Lam cs VCont k -> quote (succ d) =<< k (VVar (Free (LName d __))) - VVar v -> pure (Var (fmap (levelToIndex d) <$> v)) + VVar v -> pure (Var (toIndexed d v)) VCon n fs -> Con n <$> traverse (quote d) fs VString s -> pure $ String s VDict os -> Dict <$> traverse (traverse (quote d)) os diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 20ae250cf..6a0e6e63b 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -4,8 +4,6 @@ module Facet.Name ( Index(..) , Level(..) -, levelToIndex -, indexToLevel , DeBruijn(..) , Meta(..) , __ @@ -50,20 +48,14 @@ newtype Level = Level { getLevel :: Int } instance Show Level where showsPrec p = showsUnaryWith showsPrec "Level" p . getLevel -levelToIndex :: Level -> Level -> Index -levelToIndex (Level d) (Level level) = Index $ d - level - 1 - -indexToLevel :: Level -> Index -> Level -indexToLevel (Level d) (Index index) = Level $ d - index - 1 - class DeBruijn lv ix | lv -> ix, ix -> lv where toIndexed :: Level -> lv -> ix toLeveled :: Level -> ix -> lv instance DeBruijn Level Index where - toIndexed = levelToIndex - toLeveled = indexToLevel + toIndexed (Level d) (Level level) = Index $ d - level - 1 + toLeveled (Level d) (Index index) = Level $ d - index - 1 instance DeBruijn lv ix => DeBruijn (Either e lv) (Either e ix) where toIndexed = fmap . toIndexed diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 9e13c4363..c721810e6 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -53,7 +53,7 @@ infixl 2 :>- instance Quote Type XType where quote d = \case - TVar k d' -> XTVar k (levelToIndex d d') + TVar k d' -> XTVar k (toIndexed d d') Up t -> XUp (quote d t) Bot -> XBot a :-> b -> quote d a :->: quote d b @@ -126,7 +126,7 @@ evalCoterm env kenv = go go = \case CApp a k -> App (evalTerm env kenv a) : go k CInst t k -> Inst t : go k - CRet i -> [Ret (indexToLevel (Level (length kenv)) i)] + CRet i -> [Ret (toLeveled (Level (length kenv)) i)] data Binding = V V @@ -155,10 +155,10 @@ instance Show V where quoteV :: Level -> Level -> V -> Term quoteV lv lk = \case - Ne l sp -> CMu (CVar (levelToIndex lv l)) (foldr (\case + Ne l sp -> CMu (CVar (toIndexed lv l)) (foldr (\case App v -> CApp (quoteV lv lk v) Inst t -> CInst t - Ret i -> const (CRet (levelToIndex lk i))) (CRet (Index 0)) sp) + Ret i -> const (CRet (toIndexed lk i))) (CRet (Index 0)) sp) TLam k f -> CTLam k (quoteBinderWith (`quoteV` lk) (TVar k) lv f) Lam f -> CLam (quoteBinderWith (`quoteV` lk) vvar lv f) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 63f33d447..a73902b74 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -201,7 +201,7 @@ instance Printable TX.Type where qvar = group . setPrec Var . rname go env = \case TX.Var (Global n) -> qvar n - TX.Var (Free (Right n)) -> fromMaybe (lname (indexToLevel d <$> n)) $ Env.lookup env n + TX.Var (Free (Right n)) -> fromMaybe (lname (toLeveled d n)) $ Env.lookup env n TX.Var (Free (Left m)) -> meta m TX.ForAll n t b -> braces (ann (intro n d ::: print opts env t)) --> go (env |> PVar (n :=: intro n d)) b TX.Arrow Nothing q a b -> mult q (go env a) --> go env b @@ -226,7 +226,7 @@ instance Printable C.Term where where go env = \case C.Var (Global n) -> qvar n - C.Var (Free n) -> fromMaybe (lname (indexToLevel d <$> n)) $ Env.lookup env n + C.Var (Free n) -> fromMaybe (lname (toLeveled d n)) $ Env.lookup env n C.Lam cs -> comp (commaSep (map (clause env) cs)) C.App f a -> go env f $$ go env a C.Con n p -> qvar n $$* (group . go env <$> p) diff --git a/src/Facet/Term/Norm.hs b/src/Facet/Term/Norm.hs index a9261cf7a..43efd99fa 100644 --- a/src/Facet/Term/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -42,7 +42,7 @@ instance Quote Term X.Term where String s -> X.String s Con n sp -> X.Con n (quote d <$> sp) Lam cs -> X.Lam (map (uncurry clause) cs) - Ne v sp -> foldl' (\ h -> X.App h . quote d) (X.Var (fmap (levelToIndex d) <$> v)) sp + Ne v sp -> foldl' (\ h -> X.App h . quote d) (X.Var (toIndexed d v)) sp Dict os -> X.Dict (map (fmap (quote d)) os) Comp p b -> X.Comp p (snd (clause (PDict p) b)) where @@ -51,7 +51,7 @@ instance Quote Term X.Term where norm :: Env Term -> X.Term -> Term norm env = \case X.String s -> String s - X.Var v -> Ne (fmap (indexToLevel (level env)) <$> v) Nil + X.Var v -> Ne (toLeveled (level env) v) Nil X.Con n sp -> Con n (norm env <$> sp) X.App f a -> norm env f `napp` norm env a X.Lam cs -> Lam (map (\ (p, b) -> (p, \ p' -> norm (env |> p') b)) cs) diff --git a/src/Facet/Type/Expr.hs b/src/Facet/Type/Expr.hs index 507da0b00..5ca57e7e4 100644 --- a/src/Facet/Type/Expr.hs +++ b/src/Facet/Type/Expr.hs @@ -21,7 +21,7 @@ data Type -- FIXME: this should be Level -> Type instance TType (T (Level -> Type)) where string = T (const String) - forAll n (T k) b = T (\ d -> ForAll n k (getT (b (T (\ d' -> Var (Free (Right (LName (levelToIndex d d') n)))))) d)) + forAll n (T k) b = T (\ d -> ForAll n k (getT (b (T (\ d' -> Var (Free (Right (LName (toIndexed d d') n)))))) d)) arrow n q (T a) (T b) = T (\ d -> Arrow n q (a d) (b d)) comp sig (T b) = T (\ d -> Comp (mapSignature (\ (T i) -> i d) sig) (b d)) app (T f) (T a) = T (\ d -> App (f d) (a d)) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 3180380a6..37d440d8c 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -54,7 +54,7 @@ instance Quote Type TX.Type where ForAll n t b -> TX.ForAll n t (quote (succ d) (b (free (LName d n)))) Arrow n q a b -> TX.Arrow n q (quote d a) (quote d b) Comp s t -> TX.Comp (mapSignature (quote d) s) (quote d t) - Ne n sp -> foldl' (&) (TX.Var (fmap (fmap (levelToIndex d)) <$> n)) (flip TX.App . quote d <$> sp) + Ne n sp -> foldl' (&) (TX.Var (toIndexed d n)) (flip TX.App . quote d <$> sp) instance TType (T Type) where string = T String From 32424b010fcf905e50a2fd756fa1f05f6500d2cb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 08:31:35 -0400 Subject: [PATCH 0354/1324] Define a Term instance for Quoter Term. --- src/Facet/Term/Expr.hs | 26 +++++++++++++++++++++----- 1 file changed, 21 insertions(+), 5 deletions(-) diff --git a/src/Facet/Term/Expr.hs b/src/Facet/Term/Expr.hs index e1a176027..b1d4b01fc 100644 --- a/src/Facet/Term/Expr.hs +++ b/src/Facet/Term/Expr.hs @@ -5,11 +5,15 @@ module Facet.Term.Expr , Fields(..) ) where -import Data.Bifunctor (bimap) -import Data.Text (Text) -import Facet.Name -import Facet.Pattern -import Facet.Syntax +import Control.Applicative (liftA2) +import Data.Bifunctor (bimap) +import Data.Text (Text) +import Data.Traversable (mapAccumL) +import Facet.Name +import Facet.Pattern +import Facet.Quote +import Facet.Syntax +import qualified Facet.Term.Class as C -- Term expressions @@ -24,6 +28,18 @@ data Term | Comp [RName :=: Name] Term -- ^ NB: the first argument is a specialization of @'Pattern' 'Name'@ to the 'PDict' constructor deriving (Eq, Ord, Show) +instance C.Term (Quoter Term) where + string = pure . String + con n fs = Con n <$> sequenceA fs + lam b = Lam <$> traverse (sequenceA . uncurry clause) b + var v = Quoter (\ d -> Var (toIndexed d v)) + app = liftA2 App + dict fs = Dict <$> traverse sequenceA fs + comp p b = Comp p <$> snd (clause (PDict p) b) + +clause :: Traversable t => t Name -> (t (Name :=: Quoter Term) -> Quoter Term) -> (t Name, Quoter Term) +clause p b = (p, Quoter (\ d -> let (_, p') = mapAccumL (\ d n -> (succ d, n :=: Free (LName d n))) d p in runQuoter (b (fmap C.var <$> p')) d)) + class TExpr expr where xvar :: T (Var (LName Index)) a -> expr a From ccc7a0fb965e4a821c7130a4a7f10a99d8083083 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 08:32:05 -0400 Subject: [PATCH 0355/1324] Define a module for a Type class. --- facet.cabal | 1 + src/Facet/Type/Class.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Type/Class.hs diff --git a/facet.cabal b/facet.cabal index 6715af5b9..c1838d55d 100644 --- a/facet.cabal +++ b/facet.cabal @@ -126,6 +126,7 @@ library Facet.Term.Norm Facet.Timing Facet.Type + Facet.Type.Class Facet.Type.Expr Facet.Type.Norm Facet.Unify diff --git a/src/Facet/Type/Class.hs b/src/Facet/Type/Class.hs new file mode 100644 index 000000000..73f07ad79 --- /dev/null +++ b/src/Facet/Type/Class.hs @@ -0,0 +1,2 @@ +module Facet.Type.Class +() where From 150f56c3a7b29da30373426e4f8d1b8dc5101681 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 08:35:15 -0400 Subject: [PATCH 0356/1324] Rename app to $$. --- src/Facet/Term/Class.hs | 3 ++- src/Facet/Term/Expr.hs | 2 +- src/Facet/Term/Norm.hs | 2 +- 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Facet/Term/Class.hs b/src/Facet/Term/Class.hs index dc98dfd98..3c7a6502f 100644 --- a/src/Facet/Term/Class.hs +++ b/src/Facet/Term/Class.hs @@ -12,6 +12,7 @@ class Term r where con :: RName -> [r] -> r lam :: [(Pattern Name, Pattern (Name :=: r) -> r)] -> r var :: Var (LName Level) -> r - app :: r -> r -> r + ($$) :: r -> r -> r + infixl 9 $$ dict :: [RName :=: r] -> r comp :: [RName :=: Name] -> (Pattern (Name :=: r) -> r) -> r diff --git a/src/Facet/Term/Expr.hs b/src/Facet/Term/Expr.hs index b1d4b01fc..c1b12e797 100644 --- a/src/Facet/Term/Expr.hs +++ b/src/Facet/Term/Expr.hs @@ -33,7 +33,7 @@ instance C.Term (Quoter Term) where con n fs = Con n <$> sequenceA fs lam b = Lam <$> traverse (sequenceA . uncurry clause) b var v = Quoter (\ d -> Var (toIndexed d v)) - app = liftA2 App + ($$) = liftA2 App dict fs = Dict <$> traverse sequenceA fs comp p b = Comp p <$> snd (clause (PDict p) b) diff --git a/src/Facet/Term/Norm.hs b/src/Facet/Term/Norm.hs index 43efd99fa..aaf20e6ae 100644 --- a/src/Facet/Term/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -33,7 +33,7 @@ instance C.Term Term where con = Con lam = Lam var = (`Ne` Nil) - app = napp + ($$) = napp dict = Dict comp = Comp From 22ae11ec5b9ebe60cc68996b3d1fa1ca2470f825 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 08:36:03 -0400 Subject: [PATCH 0357/1324] Define a final tagless encoding of a Type interface. --- src/Facet/Type/Class.hs | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/src/Facet/Type/Class.hs b/src/Facet/Type/Class.hs index 73f07ad79..862a838fc 100644 --- a/src/Facet/Type/Class.hs +++ b/src/Facet/Type/Class.hs @@ -1,2 +1,21 @@ module Facet.Type.Class -() where +( -- * Types + Type(..) +) where + +import Facet.Interface (Signature) +import Facet.Kind (Kind) +import Facet.Name (LName, Level, Meta, Name) +import Facet.Syntax (Var) +import Facet.Usage (Quantity) + +-- Types + +class Type r where + string :: r + forAll :: Name -> Kind -> (r -> r) -> r + arrow :: Maybe Name -> Quantity -> r -> r -> r + var :: Var (Either Meta (LName Level)) -> r + ($$) :: r -> r -> r + infixl 9 $$ + comp :: Signature r -> r -> r From e0aab1c03a57e5e9b3ecddbb9bf232e3e95381e4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 08:36:45 -0400 Subject: [PATCH 0358/1324] Rename comp to |-. --- src/Facet/Type/Class.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Facet/Type/Class.hs b/src/Facet/Type/Class.hs index 862a838fc..6dddd6bca 100644 --- a/src/Facet/Type/Class.hs +++ b/src/Facet/Type/Class.hs @@ -18,4 +18,5 @@ class Type r where var :: Var (Either Meta (LName Level)) -> r ($$) :: r -> r -> r infixl 9 $$ - comp :: Signature r -> r -> r + (|-) :: Signature r -> r -> r + infixr 9 |- From 55aa322d372ba649bfab70d2f11b4ac2d760ea4d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 08:40:16 -0400 Subject: [PATCH 0359/1324] Define a Class.Type instance for Norm.Type. --- src/Facet/Type/Norm.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 37d440d8c..5a66d60c1 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -32,6 +32,7 @@ import Facet.Snoc import Facet.Subst import Facet.Syntax import Facet.Type +import qualified Facet.Type.Class as C import qualified Facet.Type.Expr as TX import Facet.Usage hiding (singleton) import Fresnel.Prism (Prism', prism') @@ -48,6 +49,14 @@ data Type | Comp (Signature Type) Type deriving (Eq, Ord, Show) via Quoting TX.Type Type +instance C.Type Type where + string = String + forAll = ForAll + arrow = Arrow + var = Facet.Type.Norm.var + ($$) = (Facet.Type.Norm.$$) + (|-) = Comp + instance Quote Type TX.Type where quote d = \case String -> TX.String From 046780ee360f827def44d04b50ca019a8fce577f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 08:54:57 -0400 Subject: [PATCH 0360/1324] TODOs. --- TODO.md | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/TODO.md b/TODO.md index 90339a3ad..c5b0486e4 100644 --- a/TODO.md +++ b/TODO.md @@ -148,11 +148,15 @@ _Caveat lector: there are no guarantees of correctness or completeness on the co ### Elaborator -- Emit warnings. +- ✅ Emit warnings. - Continue after errors on a declaration-by-declaration basis. -- Add entire composite patterns to contexts. One entry for the whole pattern at type A, with sub-entries for each sub-pattern at decomposed types. +- ✅ Add entire composite patterns to contexts. One entry for the whole pattern at type A, with sub-entries for each sub-pattern at decomposed types. + +- `Level`/`Level` pairs could be represented as `Ratio`s. + +- Distinguish between the `Level` a variable was bound and the `Level` of the place it’s being inserted at the type level using `newtype`s. ### Pretty-printer From a496a75db8eefaee0050f726afd3c4968cb37656 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 08:56:24 -0400 Subject: [PATCH 0361/1324] Quote binders. Maybe. --- src/Facet/Quote.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index e8b8bd74d..643590486 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -11,6 +11,7 @@ module Facet.Quote , Quoting(..) -- * Quoters , Quoter(..) +, binder ) where import Facet.Name (Level) @@ -55,3 +56,6 @@ instance (Quote v t, Show t) => Show (Quoting t v) where newtype Quoter a = Quoter { runQuoter :: Level -> a } deriving (Applicative, Functor, Monad) + +binder :: (Level -> Level -> a) -> (Quoter a -> Quoter b) -> Quoter b +binder with f = Quoter (\ d -> runQuoter (f (Quoter (with d))) (d + 1)) From 5200d9ec398a05dbca2228dcdfbc48e6d4e9aa89 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 09:01:45 -0400 Subject: [PATCH 0362/1324] Define sequencing of signatures. --- src/Facet/Interface.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Interface.hs b/src/Facet/Interface.hs index aea559fe5..c78af6d84 100644 --- a/src/Facet/Interface.hs +++ b/src/Facet/Interface.hs @@ -6,6 +6,7 @@ module Facet.Interface , interfaces , mapSignature , traverseSignature +, sequenceSignature ) where import qualified Data.Set as Set @@ -32,3 +33,6 @@ mapSignature f = Signature . Set.map (fmap f) . getSignature traverseSignature :: (Ord b, Applicative f) => (a -> f b) -> Signature a -> f (Signature b) traverseSignature f (Signature m) = Signature . Set.fromList <$> traverse (traverse f) (Set.toList m) + +sequenceSignature :: (Ord a, Applicative f) => Signature (f a) -> f (Signature a) +sequenceSignature = traverseSignature id From cbe75300f1e4ecb3bc2a3c3601caa80fc5008997 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 09:04:27 -0400 Subject: [PATCH 0363/1324] Define a Class.Type instance for Quoter Expr.Type. --- src/Facet/Type/Expr.hs | 29 ++++++++++++++++++++++------- 1 file changed, 22 insertions(+), 7 deletions(-) diff --git a/src/Facet/Type/Expr.hs b/src/Facet/Type/Expr.hs index 5ca57e7e4..71186b945 100644 --- a/src/Facet/Type/Expr.hs +++ b/src/Facet/Type/Expr.hs @@ -2,12 +2,15 @@ module Facet.Type.Expr ( Type(..) ) where -import Facet.Interface -import Facet.Kind -import Facet.Name -import Facet.Syntax -import Facet.Type -import Facet.Usage +import Control.Applicative (liftA2) +import Facet.Interface +import Facet.Kind +import Facet.Name +import Facet.Quote +import Facet.Syntax +import Facet.Type +import qualified Facet.Type.Class as C +import Facet.Usage data Type = String @@ -18,10 +21,22 @@ data Type | App Type Type deriving (Eq, Ord, Show) +instance C.Type (Quoter Type) where + string = pure String + forAll n k b = ForAll n k <$> binder (\ d d' -> lvar n (toIndexed d' d)) b + arrow n q = liftA2 (Arrow n q) + var v = Quoter (\ d -> Var (toIndexed d v)) + ($$) = liftA2 App + sig |- t = Comp <$> sequenceSignature sig <*> t + -- FIXME: this should be Level -> Type instance TType (T (Level -> Type)) where string = T (const String) - forAll n (T k) b = T (\ d -> ForAll n k (getT (b (T (\ d' -> Var (Free (Right (LName (toIndexed d d') n)))))) d)) + forAll n (T k) b = T (\ d -> ForAll n k (getT (b (T (lvar n . toIndexed d))) d)) arrow n q (T a) (T b) = T (\ d -> Arrow n q (a d) (b d)) comp sig (T b) = T (\ d -> Comp (mapSignature (\ (T i) -> i d) sig) (b d)) app (T f) (T a) = T (\ d -> App (f d) (a d)) + + +lvar :: Name -> Index -> Type +lvar n i = Var (Free (Right (LName i n))) From 37759bbd5a6144ba89fcabe3088ffdc1a4ee044c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 09:06:53 -0400 Subject: [PATCH 0364/1324] Define a newtype representing a point at which syntax is used. --- src/Facet/Name.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 6a0e6e63b..d5cb32971 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -5,6 +5,7 @@ module Facet.Name ( Index(..) , Level(..) , DeBruijn(..) +, Used(..) , Meta(..) , __ , MName @@ -62,6 +63,13 @@ instance DeBruijn lv ix => DeBruijn (Either e lv) (Either e ix) where toLeveled = fmap . toLeveled +newtype Used = Used { getUsed :: Int } + deriving (Enum, Eq, Num, Ord) + +instance Show Used where + showsPrec p = showsUnaryWith showsPrec "Used" p . getUsed + + newtype Meta = Meta { getMeta :: Int } deriving (Eq, Ord, Show) From 428842371c7b21a8fbc6eae40d8680aef9a5d41b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 09:10:00 -0400 Subject: [PATCH 0365/1324] Flip runQuoter. --- src/Facet/Quote.hs | 8 ++++++-- src/Facet/Term/Expr.hs | 2 +- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index 643590486..a0674fd04 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -11,6 +11,7 @@ module Facet.Quote , Quoting(..) -- * Quoters , Quoter(..) +, runQuoter , binder ) where @@ -54,8 +55,11 @@ instance (Quote v t, Show t) => Show (Quoting t v) where -- Quoters -newtype Quoter a = Quoter { runQuoter :: Level -> a } +newtype Quoter a = Quoter (Level -> a) deriving (Applicative, Functor, Monad) +runQuoter :: Level -> Quoter a -> a +runQuoter d (Quoter f) = f d + binder :: (Level -> Level -> a) -> (Quoter a -> Quoter b) -> Quoter b -binder with f = Quoter (\ d -> runQuoter (f (Quoter (with d))) (d + 1)) +binder with f = Quoter (\ d -> runQuoter (d + 1) (f (Quoter (with d)))) diff --git a/src/Facet/Term/Expr.hs b/src/Facet/Term/Expr.hs index c1b12e797..fd82ce261 100644 --- a/src/Facet/Term/Expr.hs +++ b/src/Facet/Term/Expr.hs @@ -38,7 +38,7 @@ instance C.Term (Quoter Term) where comp p b = Comp p <$> snd (clause (PDict p) b) clause :: Traversable t => t Name -> (t (Name :=: Quoter Term) -> Quoter Term) -> (t Name, Quoter Term) -clause p b = (p, Quoter (\ d -> let (_, p') = mapAccumL (\ d n -> (succ d, n :=: Free (LName d n))) d p in runQuoter (b (fmap C.var <$> p')) d)) +clause p b = (p, Quoter (\ d -> let (_, p') = mapAccumL (\ d n -> (succ d, n :=: Free (LName d n))) d p in runQuoter d (b (fmap C.var <$> p')))) class TExpr expr where xvar :: T (Var (LName Index)) a -> expr a From bd59e81f2d751f8dca326f346708e86e375e9784 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 09:11:35 -0400 Subject: [PATCH 0366/1324] :fire: the typed type interface. --- src/Facet/Type.hs | 23 ----------------------- src/Facet/Type/Expr.hs | 9 --------- src/Facet/Type/Norm.hs | 8 -------- 3 files changed, 40 deletions(-) delete mode 100644 src/Facet/Type.hs diff --git a/src/Facet/Type.hs b/src/Facet/Type.hs deleted file mode 100644 index f48e82acd..000000000 --- a/src/Facet/Type.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -module Facet.Type -( TType(..) -, Comp -) where - -import Data.Kind (Type) -import Data.Text (Text) -import Data.Void (Void) -import Facet.Interface (Interface, Signature) -import Facet.Kind (Kind) -import Facet.Name (Name) -import Facet.Syntax (T) -import Facet.Usage (Quantity) - -data Comp a - -class TType (ty :: forall k . k -> Type) where - string :: ty Text - forAll :: Name -> T Kind a -> (ty a -> ty b) -> ty (a -> b) - arrow :: Maybe Name -> Quantity -> ty a -> ty b -> ty (a -> b) - comp :: Signature (ty (Interface Void)) -> ty a -> ty (Comp a) - app :: ty (f :: j -> k) -> ty (a :: j) -> ty k diff --git a/src/Facet/Type/Expr.hs b/src/Facet/Type/Expr.hs index 71186b945..d4dd538e7 100644 --- a/src/Facet/Type/Expr.hs +++ b/src/Facet/Type/Expr.hs @@ -8,7 +8,6 @@ import Facet.Kind import Facet.Name import Facet.Quote import Facet.Syntax -import Facet.Type import qualified Facet.Type.Class as C import Facet.Usage @@ -29,14 +28,6 @@ instance C.Type (Quoter Type) where ($$) = liftA2 App sig |- t = Comp <$> sequenceSignature sig <*> t --- FIXME: this should be Level -> Type -instance TType (T (Level -> Type)) where - string = T (const String) - forAll n (T k) b = T (\ d -> ForAll n k (getT (b (T (lvar n . toIndexed d))) d)) - arrow n q (T a) (T b) = T (\ d -> Arrow n q (a d) (b d)) - comp sig (T b) = T (\ d -> Comp (mapSignature (\ (T i) -> i d) sig) (b d)) - app (T f) (T a) = T (\ d -> App (f d) (a d)) - lvar :: Name -> Index -> Type lvar n i = Var (Free (Right (LName i n))) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 5a66d60c1..015301cb3 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -31,7 +31,6 @@ import Facet.Quote import Facet.Snoc import Facet.Subst import Facet.Syntax -import Facet.Type import qualified Facet.Type.Class as C import qualified Facet.Type.Expr as TX import Facet.Usage hiding (singleton) @@ -65,13 +64,6 @@ instance Quote Type TX.Type where Comp s t -> TX.Comp (mapSignature (quote d) s) (quote d t) Ne n sp -> foldl' (&) (TX.Var (toIndexed d n)) (flip TX.App . quote d <$> sp) -instance TType (T Type) where - string = T String - forAll n (T k) b = T (ForAll n k (getT . b . T)) - arrow n q (T a) (T b) = T (Arrow n q a b) - comp sig (T b) = T (Comp (mapSignature getT sig) b) - app (T a) (T b) = T (a $$ b) - global :: RName -> Type global = var . Global From 1a2232bf3439c83de0153a793c6dc5f39b284fef Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 09:12:04 -0400 Subject: [PATCH 0367/1324] :fire: the typed term interface. --- src/Facet/Term/Expr.hs | 41 ----------------------------------------- 1 file changed, 41 deletions(-) diff --git a/src/Facet/Term/Expr.hs b/src/Facet/Term/Expr.hs index fd82ce261..da491e6fb 100644 --- a/src/Facet/Term/Expr.hs +++ b/src/Facet/Term/Expr.hs @@ -1,12 +1,9 @@ module Facet.Term.Expr ( -- * Term expressions Term(..) -, TExpr(..) -, Fields(..) ) where import Control.Applicative (liftA2) -import Data.Bifunctor (bimap) import Data.Text (Text) import Data.Traversable (mapAccumL) import Facet.Name @@ -39,41 +36,3 @@ instance C.Term (Quoter Term) where clause :: Traversable t => t Name -> (t (Name :=: Quoter Term) -> Quoter Term) -> (t Name, Quoter Term) clause p b = (p, Quoter (\ d -> let (_, p') = mapAccumL (\ d n -> (succ d, n :=: Free (LName d n))) d p in runQuoter d (b (fmap C.var <$> p')))) - -class TExpr expr where - xvar :: T (Var (LName Index)) a -> expr a - - xlam :: [(T (Pattern Name) a, expr b)] -> expr (a -> b) - - xapp :: expr (a -> b) -> expr a -> expr b - - infixl 9 `xapp` - - xcon :: Fields expr fs => RName -> fs -> expr fs - - xstring :: Text -> expr Text - - xlet :: T (Pattern Name) t -> expr t -> expr u -> expr u - -instance TExpr (T Term) where - xvar = T . Var . getT - - xlam ps = T (Lam (map (bimap getT getT) ps)) - - xapp (T f) (T a) = T (f `App` a) - - xcon n b = T (Con n (foldFields (pure . getT) b)) - - xstring = T . String - - xlet (T p) (T v) (T b) = T (Let p v b) - - -class Fields f fs where - foldFields :: Monoid m => (forall t . f t -> m) -> fs -> m - -instance Fields f () where - foldFields _ _ = mempty - -instance Fields f fs => Fields f (f t, fs) where - foldFields alg = mappend . alg . fst <*> foldFields alg . snd From b5003c6325bc4bc7ea42fad9c78e3ff304964311 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 11:09:19 -0400 Subject: [PATCH 0368/1324] :fire: Facet.Type. --- facet.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/facet.cabal b/facet.cabal index c1838d55d..cccd473ce 100644 --- a/facet.cabal +++ b/facet.cabal @@ -125,7 +125,6 @@ library Facet.Term.Expr Facet.Term.Norm Facet.Timing - Facet.Type Facet.Type.Class Facet.Type.Expr Facet.Type.Norm From 0fb56439d24b34e4de76b61113a5526a86e03872 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 11:09:33 -0400 Subject: [PATCH 0369/1324] Add a module for a composition functor. --- facet.cabal | 1 + src/Facet/Functor/Compose.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Functor/Compose.hs diff --git a/facet.cabal b/facet.cabal index cccd473ce..739405218 100644 --- a/facet.cabal +++ b/facet.cabal @@ -90,6 +90,7 @@ library Facet.Flag Facet.Format Facet.Functor.Check + Facet.Functor.Compose Facet.Functor.Synth Facet.Graph Facet.Interface diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs new file mode 100644 index 000000000..dded29d4c --- /dev/null +++ b/src/Facet/Functor/Compose.hs @@ -0,0 +1,2 @@ +module Facet.Functor.Compose +() where From 5032b4228a8db9c171e9fc78ec4686b5bbdcc9eb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 11:10:39 -0400 Subject: [PATCH 0370/1324] Define a composition functor. --- src/Facet/Functor/Compose.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index dded29d4c..2e156e9e3 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -1,2 +1,9 @@ module Facet.Functor.Compose -() where +( -- * Composition functor + type (.)(..) +) where + +-- Composition functor + +newtype (i . j) a = C { runC :: i (j a) } + deriving (Functor) From 2e6b3dfc201da838297a62687063edc0d888c808 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 11:10:55 -0400 Subject: [PATCH 0371/1324] Define an Applicative instance for .. --- src/Facet/Functor/Compose.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index 2e156e9e3..c77d230fb 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -7,3 +7,7 @@ module Facet.Functor.Compose newtype (i . j) a = C { runC :: i (j a) } deriving (Functor) + +instance (Applicative i, Applicative j) => Applicative (i . j) where + pure = C . pure . pure + C f <*> C a = C ((<*>) <$> f <*> a) From 40d732498235190e44c90608d9f6af2bd1f8a1ba Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 11:11:33 -0400 Subject: [PATCH 0372/1324] Introduce . via the inner functor. --- src/Facet/Functor/Compose.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index c77d230fb..ee34fa024 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -1,6 +1,8 @@ module Facet.Functor.Compose ( -- * Composition functor type (.)(..) + -- * Introduction +, liftCInner ) where -- Composition functor @@ -11,3 +13,7 @@ newtype (i . j) a = C { runC :: i (j a) } instance (Applicative i, Applicative j) => Applicative (i . j) where pure = C . pure . pure C f <*> C a = C ((<*>) <$> f <*> a) + + +liftCInner :: Applicative i => j a -> (i . j) a +liftCInner = C . pure From 6a5f66ff2b3e4221f3e023e11e1b811aeeae0fef Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 11:12:03 -0400 Subject: [PATCH 0373/1324] Introduce . via the outer functor. --- src/Facet/Functor/Compose.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index ee34fa024..d5b1e111d 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -3,6 +3,7 @@ module Facet.Functor.Compose type (.)(..) -- * Introduction , liftCInner +, liftCOuter ) where -- Composition functor @@ -17,3 +18,6 @@ instance (Applicative i, Applicative j) => Applicative (i . j) where liftCInner :: Applicative i => j a -> (i . j) a liftCInner = C . pure + +liftCOuter :: (Functor i, Applicative j) => i a -> (i . j) a +liftCOuter = C . fmap pure From 5a6c29cf94f581a8ab1fc9527f8e0cf065f6125b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 11:13:12 -0400 Subject: [PATCH 0374/1324] Define a type synonym for natural transformations. --- src/Facet/Syntax.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index a43fe3f57..ede003583 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -17,6 +17,8 @@ module Facet.Syntax , Act(..) -- * Type-safe constructors , T(..) + -- * Natural transformations +, type (~>) ) where import Data.Bifoldable @@ -124,3 +126,8 @@ newtype Act a = Act { getAct :: a } type T :: Type -> forall k . k -> Type newtype T a b = T { getT :: a } + + +-- Natural transformations + +type i ~> j = forall x . i x -> j x From 992e04ee20cdc5df29d6f8b8853e6774dde20ea0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 11:14:58 -0400 Subject: [PATCH 0375/1324] Define an Applicative constructor for lambdas. --- src/Facet/Term/Class.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Term/Class.hs b/src/Facet/Term/Class.hs index 3c7a6502f..78bd16d87 100644 --- a/src/Facet/Term/Class.hs +++ b/src/Facet/Term/Class.hs @@ -1,8 +1,10 @@ module Facet.Term.Class ( Term(..) +, lamA ) where import Data.Text (Text) +import Facet.Functor.Compose import Facet.Name import Facet.Pattern import Facet.Syntax @@ -16,3 +18,7 @@ class Term r where infixl 9 $$ dict :: [RName :=: r] -> r comp :: [RName :=: Name] -> (Pattern (Name :=: r) -> r) -> r + + +lamA :: (Applicative m, Applicative i, Term r) => (forall j . Applicative j => (i ~> j) -> [(Pattern Name, j (Pattern (Name :=: r)) -> m (j r))]) -> m (i r) +lamA b = fmap lam . traverse (traverse runC) <$> traverse (traverse ($ liftCInner id)) (b liftCOuter) From b39bdd175a4ed02779193025ad434ce743da501d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 11:19:12 -0400 Subject: [PATCH 0376/1324] Define an Applicative constructor for foralls. --- src/Facet/Type/Class.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Facet/Type/Class.hs b/src/Facet/Type/Class.hs index 6dddd6bca..1a98539c2 100644 --- a/src/Facet/Type/Class.hs +++ b/src/Facet/Type/Class.hs @@ -1,12 +1,14 @@ module Facet.Type.Class ( -- * Types Type(..) +, forAllA ) where +import Facet.Functor.Compose import Facet.Interface (Signature) import Facet.Kind (Kind) import Facet.Name (LName, Level, Meta, Name) -import Facet.Syntax (Var) +import Facet.Syntax (Var, type (~>)) import Facet.Usage (Quantity) -- Types @@ -20,3 +22,6 @@ class Type r where infixl 9 $$ (|-) :: Signature r -> r -> r infixr 9 |- + +forAllA :: (Applicative m, Applicative i, Type r) => Name -> Kind -> (forall j . Applicative j => (i ~> j) -> j r -> m (j r)) -> m (i r) +forAllA n k b = fmap (forAll n k) . runC <$> b liftCOuter (liftCInner id) From f5ae903f300d05950c72fc4c6629634a13bf40ac Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 12:13:20 -0400 Subject: [PATCH 0377/1324] Use Used to indicate where terms are inserted. --- src/Facet/Context.hs | 6 +++--- src/Facet/Elab.hs | 6 +++--- src/Facet/Elab/Term.hs | 6 +++--- src/Facet/Env.hs | 4 ++-- src/Facet/Eval.hs | 2 +- src/Facet/Name.hs | 10 +++++----- src/Facet/Polarized.hs | 10 +++++----- src/Facet/Print.hs | 12 +++++------- src/Facet/Quote.hs | 22 +++++++++++----------- src/Facet/Term/Expr.hs | 2 +- src/Facet/Term/Norm.hs | 2 +- src/Facet/Type/Expr.hs | 2 +- src/Facet/Type/Norm.hs | 2 +- src/Facet/Unify.hs | 4 ++-- 14 files changed, 44 insertions(+), 46 deletions(-) diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index b13918d95..7f0bf17be 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -33,8 +33,8 @@ Context as |> a = Context (as S.:> a) infixl 5 |> -level :: Context -> Level -level (Context es) = Level (length es) +level :: Context -> Used +level (Context es) = Used (Level (length es)) (!) :: HasCallStack => Context -> Index -> (Quantity, Pattern (Name ::: Classifier)) Context es' ! Index i' = withFrozenCallStack $ go es' i' @@ -54,4 +54,4 @@ lookupIndex n = go (Index 0) . elems toEnv :: Context -> Env.Env Type -toEnv c = Env.Env (S.fromList (zipWith (\ (_, p) d -> (\ b -> tm b :=: free (LName d (tm b))) <$> p) (toList (elems c)) [0..pred (level c)])) +toEnv c = Env.Env (S.fromList (zipWith (\ (_, p) d -> (\ b -> tm b :=: free (LName (getUsed d) (tm b))) <$> p) (toList (elems c)) [0..pred (level c)])) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 7890c907e..6039adf3c 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -147,10 +147,10 @@ lookupInSig (m :. n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':.:_) _) (q, p) |- b = do sigma <- asks scale d <- depth - (u, a) <- censor (`Usage.withoutVars` Vars.singleton d) $ listen $ locally context_ (|> (q, p)) b + (u, a) <- censor (`Usage.withoutVars` Vars.singleton (getUsed d)) $ listen $ locally context_ (|> (q, p)) b for_ p $ \ (n ::: _T) -> do let exp = sigma >< q - act = Usage.lookup (LName d n) u + act = Usage.lookup (LName (getUsed d) n) u unless (act `sat` exp) $ resourceMismatch n exp act pure a @@ -168,7 +168,7 @@ sat a b evalTExpr :: Has (Reader ElabContext :+: State (Subst Type)) sig m => TX.Type -> m Type evalTExpr texpr = TN.eval <$> get <*> views context_ toEnv <*> pure texpr -depth :: Has (Reader ElabContext) sig m => m Level +depth :: Has (Reader ElabContext) sig m => m Used depth = views context_ level use :: Has (Reader ElabContext :+: Writer Usage) sig m => LName Index -> Quantity -> m () diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index b0c65d9cf..d46ef58ca 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -117,7 +117,7 @@ tlam :: (HasCallStack, Has (Throw Err) sig m) => Type <==: Elab m Term -> Type < tlam b = Check $ \ _T -> do (n ::: _A, _B) <- assertQuantifier _T d <- depth - (zero, PVar (n ::: CK _A)) |- check (b ::: _B (T.free (LName d n))) + (zero, PVar (n ::: CK _A)) |- check (b ::: _B (T.free (LName (getUsed d) n))) lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern (Name ::: Classifier)), Type <==: Elab m Term)] -> Type <==: Elab m Term lam cs = Check $ \ _T -> do @@ -253,10 +253,10 @@ abstractTerm body = go Nil Nil go ts fs = Check $ \case T.ForAll n _T _B -> do d <- depth - check (tlam (go (ts :> LName d n) fs) ::: T.ForAll n _T _B) + check (tlam (go (ts :> LName (getUsed d) n) fs) ::: T.ForAll n _T _B) T.Arrow n q _A _B -> do d <- depth - check (lam [(patternForArgType _A (fromMaybe __ n), go ts (fs :> \ d' -> Var (Free (LName (toIndexed d' d) (fromMaybe __ n)))))] ::: T.Arrow n q _A _B) + check (lam [(patternForArgType _A (fromMaybe __ n), go ts (fs :> \ d' -> Var (Free (LName (toIndexed d' (getUsed d)) (fromMaybe __ n)))))] ::: T.Arrow n q _A _B) _T -> do d <- depth pure $ body (TX.Var . Free . Right . toIndexed d <$> ts) (fs <*> pure d) diff --git a/src/Facet/Env.hs b/src/Facet/Env.hs index 3d91fdaf7..1420f600a 100644 --- a/src/Facet/Env.hs +++ b/src/Facet/Env.hs @@ -36,5 +36,5 @@ lookup (Env vs) (LName i n) = find (\ (n' :=: v) -> v <$ guard (n == n')) (vs ! index :: HasCallStack => Env v -> LName Index -> v index env n = fromMaybe (error ("Env.index: name (" <> show n <> ") not found")) (lookup env n) -level :: Env v -> Level -level = Level . length . bindings +level :: Env v -> Used +level = Used . Level . length . bindings diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 6bcf23b1e..a94e2f10b 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -135,7 +135,7 @@ data Value m instance Monad m => Quote (Value m) (m Term) where quote d = \case VLam _ cs -> pure $ Lam cs - VCont k -> quote (succ d) =<< k (VVar (Free (LName d __))) + VCont k -> quote (succ d) =<< k (VVar (Free (LName (getUsed d) __))) VVar v -> pure (Var (toIndexed d v)) VCon n fs -> Con n <$> traverse (quote d) fs VString s -> pure $ String s diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index d5cb32971..c2dbce978 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -51,19 +51,19 @@ instance Show Level where class DeBruijn lv ix | lv -> ix, ix -> lv where - toIndexed :: Level -> lv -> ix - toLeveled :: Level -> ix -> lv + toIndexed :: Used -> lv -> ix + toLeveled :: Used -> ix -> lv instance DeBruijn Level Index where - toIndexed (Level d) (Level level) = Index $ d - level - 1 - toLeveled (Level d) (Index index) = Level $ d - index - 1 + toIndexed (Used (Level d)) (Level level) = Index $ d - level - 1 + toLeveled (Used (Level d)) (Index index) = Level $ d - index - 1 instance DeBruijn lv ix => DeBruijn (Either e lv) (Either e ix) where toIndexed = fmap . toIndexed toLeveled = fmap . toLeveled -newtype Used = Used { getUsed :: Int } +newtype Used = Used { getUsed :: Level } deriving (Enum, Eq, Num, Ord) instance Show Used where diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index c721810e6..972941bb1 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -57,7 +57,7 @@ instance Quote Type XType where Up t -> XUp (quote d t) Bot -> XBot a :-> b -> quote d a :->: quote d b - ForAll k b -> XForAll k (quoteBinder (TVar k) d b) + ForAll k b -> XForAll k (quoteBinder (TVar k . getUsed) d b) Down t -> XDown (quote d t) One -> XOne a :>< b -> quote d a :><: quote d b @@ -126,7 +126,7 @@ evalCoterm env kenv = go go = \case CApp a k -> App (evalTerm env kenv a) : go k CInst t k -> Inst t : go k - CRet i -> [Ret (toLeveled (Level (length kenv)) i)] + CRet i -> [Ret (toLeveled (Used (Level (length kenv))) i)] data Binding = V V @@ -153,14 +153,14 @@ instance Ord V where instance Show V where showsPrec p = showsPrec p . quoteV 0 0 -quoteV :: Level -> Level -> V -> Term +quoteV :: Used -> Used -> V -> Term quoteV lv lk = \case Ne l sp -> CMu (CVar (toIndexed lv l)) (foldr (\case App v -> CApp (quoteV lv lk v) Inst t -> CInst t Ret i -> const (CRet (toIndexed lk i))) (CRet (Index 0)) sp) - TLam k f -> CTLam k (quoteBinderWith (`quoteV` lk) (TVar k) lv f) - Lam f -> CLam (quoteBinderWith (`quoteV` lk) vvar lv f) + TLam k f -> CTLam k (quoteBinderWith (`quoteV` lk) (TVar k . getUsed) lv f) + Lam f -> CLam (quoteBinderWith (`quoteV` lk) (vvar . getUsed) lv f) vvar :: Level -> V diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index a73902b74..84366c3c0 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -188,9 +188,7 @@ instance Printable Kind where KType -> annotate Type $ pretty "Type" KInterface -> annotate Type $ pretty "Interface" KArrow Nothing a b -> print opts env a --> print opts env b - KArrow (Just n) a b -> parens (ann (intro n d ::: print opts env a)) --> print opts env b - where - d = level env + KArrow (Just n) a b -> parens (ann (intro n (getUsed (level env)) ::: print opts env a)) --> print opts env b instance Printable a => Printable (Interface a) where print = print1 @@ -203,9 +201,9 @@ instance Printable TX.Type where TX.Var (Global n) -> qvar n TX.Var (Free (Right n)) -> fromMaybe (lname (toLeveled d n)) $ Env.lookup env n TX.Var (Free (Left m)) -> meta m - TX.ForAll n t b -> braces (ann (intro n d ::: print opts env t)) --> go (env |> PVar (n :=: intro n d)) b + TX.ForAll n t b -> braces (ann (intro n (getUsed d) ::: print opts env t)) --> go (env |> PVar (n :=: intro n (getUsed d))) b TX.Arrow Nothing q a b -> mult q (go env a) --> go env b - TX.Arrow (Just n) q a b -> parens (ann (intro n d ::: mult q (go env a))) --> go env b + TX.Arrow (Just n) q a b -> parens (ann (intro n (getUsed d) ::: mult q (go env a))) --> go env b TX.Comp s t -> if s == mempty then go env t else sig s <+> go env t TX.App f a -> group (go env f) $$ group (go env a) TX.String -> annotate Type $ pretty "String" @@ -232,14 +230,14 @@ instance Printable C.Term where C.Con n p -> qvar n $$* (group . go env <$> p) C.String s -> annotate Lit $ pretty (show s) C.Dict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> rname n <+> equals <+> group (go env v)) os) <> flatAlt space line) - C.Let p v b -> let p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) in pretty "let" <+> braces (print opts env (def <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p') b + C.Let p v b -> let p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (getUsed (level env)) p) in pretty "let" <+> braces (print opts env (def <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p') b C.Comp p b -> comp (clause env (PDict p, b)) where d = level env qvar = group . setPrec Var . rname clause env (p, b) = print opts env (def <$> p') <+> arrow <+> go (env |> p') b where - p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) + p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (getUsed (level env)) p) deriving via (Quoting C.Term N.Term) instance Printable N.Term diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index a0674fd04..2d5415f17 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -15,27 +15,27 @@ module Facet.Quote , binder ) where -import Facet.Name (Level) +import Facet.Name (Level, Used(..)) -- Quotation class Quote v t | v -> t where - quote :: Level -> v -> t + quote :: Used -> v -> t -quoteBinder :: Quote v t => (Level -> u) -> Level -> (u -> v) -> t +quoteBinder :: Quote v t => (Used -> u) -> Used -> (u -> v) -> t quoteBinder = quoteBinderWith quote -quoteBinderWith :: (Level -> v -> t) -> (Level -> u) -> Level -> (u -> v) -> t +quoteBinderWith :: (Used -> v -> t) -> (Used -> u) -> Used -> (u -> v) -> t quoteBinderWith quote var d f = quote (succ d) (f (var d)) class Quote1 v t | v -> t where - liftQuoteWith :: (Level -> u -> s) -> Level -> v u -> t s + liftQuoteWith :: (Used -> u -> s) -> Used -> v u -> t s -quote1 :: (Quote u s, Quote1 v t) => Level -> v u -> t s +quote1 :: (Quote u s, Quote1 v t) => Used -> v u -> t s quote1 = liftQuoteWith quote -liftQuoteBinderWith :: Quote1 v t => (Level -> u -> s) -> (Level -> r) -> Level -> (r -> v u) -> t s +liftQuoteBinderWith :: Quote1 v t => (Used -> u -> s) -> (Used -> r) -> Used -> (r -> v u) -> t s liftQuoteBinderWith = quoteBinderWith . liftQuoteWith @@ -55,11 +55,11 @@ instance (Quote v t, Show t) => Show (Quoting t v) where -- Quoters -newtype Quoter a = Quoter (Level -> a) +newtype Quoter a = Quoter (Used -> a) deriving (Applicative, Functor, Monad) -runQuoter :: Level -> Quoter a -> a +runQuoter :: Used -> Quoter a -> a runQuoter d (Quoter f) = f d -binder :: (Level -> Level -> a) -> (Quoter a -> Quoter b) -> Quoter b -binder with f = Quoter (\ d -> runQuoter (d + 1) (f (Quoter (with d)))) +binder :: (Used -> Level -> a) -> (Quoter a -> Quoter b) -> Quoter b +binder with f = Quoter (\ d -> runQuoter (d + 1) (f (Quoter (`with` getUsed d)))) diff --git a/src/Facet/Term/Expr.hs b/src/Facet/Term/Expr.hs index da491e6fb..cbc576a3e 100644 --- a/src/Facet/Term/Expr.hs +++ b/src/Facet/Term/Expr.hs @@ -35,4 +35,4 @@ instance C.Term (Quoter Term) where comp p b = Comp p <$> snd (clause (PDict p) b) clause :: Traversable t => t Name -> (t (Name :=: Quoter Term) -> Quoter Term) -> (t Name, Quoter Term) -clause p b = (p, Quoter (\ d -> let (_, p') = mapAccumL (\ d n -> (succ d, n :=: Free (LName d n))) d p in runQuoter d (b (fmap C.var <$> p')))) +clause p b = (p, Quoter (\ d -> let (_, p') = mapAccumL (\ d n -> (succ d, n :=: Free (LName (getUsed d) n))) d p in runQuoter d (b (fmap C.var <$> p')))) diff --git a/src/Facet/Term/Norm.hs b/src/Facet/Term/Norm.hs index aaf20e6ae..6585509f7 100644 --- a/src/Facet/Term/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -46,7 +46,7 @@ instance Quote Term X.Term where Dict os -> X.Dict (map (fmap (quote d)) os) Comp p b -> X.Comp p (snd (clause (PDict p) b)) where - clause p b = let (d', p') = mapAccumL (\ d n -> (succ d, n :=: Ne (Free (LName d n)) Nil)) d p in (p, quote d' (b p')) + clause p b = let (d', p') = mapAccumL (\ d n -> (succ d, n :=: Ne (Free (LName (getUsed d) n)) Nil)) d p in (p, quote d' (b p')) norm :: Env Term -> X.Term -> Term norm env = \case diff --git a/src/Facet/Type/Expr.hs b/src/Facet/Type/Expr.hs index d4dd538e7..dd0922eab 100644 --- a/src/Facet/Type/Expr.hs +++ b/src/Facet/Type/Expr.hs @@ -22,7 +22,7 @@ data Type instance C.Type (Quoter Type) where string = pure String - forAll n k b = ForAll n k <$> binder (\ d d' -> lvar n (toIndexed d' d)) b + forAll n k b = ForAll n k <$> binder (\ d d' -> lvar n (toIndexed d d')) b arrow n q = liftA2 (Arrow n q) var v = Quoter (\ d -> Var (toIndexed d v)) ($$) = liftA2 App diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 015301cb3..404a918ac 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -59,7 +59,7 @@ instance C.Type Type where instance Quote Type TX.Type where quote d = \case String -> TX.String - ForAll n t b -> TX.ForAll n t (quote (succ d) (b (free (LName d n)))) + ForAll n t b -> TX.ForAll n t (quote (succ d) (b (free (LName (getUsed d) n)))) Arrow n q a b -> TX.Arrow n q (quote d a) (quote d b) Comp s t -> TX.Comp (mapSignature (quote d) s) (quote d t) Ne n sp -> foldl' (&) (TX.Var (toIndexed d n)) (flip TX.App . quote d <$> sp) diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index f6ebc51e8..c790f3ad8 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -60,7 +60,7 @@ unifyType = curry $ \case (TN.Ne (Free (Left v1)) Nil, TN.Ne (Free (Left v2)) Nil) -> flexFlex v1 v2 (TN.Ne (Free (Left v1)) Nil, t2) -> solve v1 t2 (t1, TN.Ne (Free (Left v2)) Nil) -> solve v2 t1 - (TN.ForAll _ t1 b1, TN.ForAll n t2 b2) -> depth >>= \ d -> evalTExpr =<< mkForAll d n <$> unifyKind t1 t2 <*> ((zero, PVar (n ::: CK t2)) |- unifyType (b1 (free (LName d n))) (b2 (free (LName d n)))) + (TN.ForAll _ t1 b1, TN.ForAll n t2 b2) -> depth >>= \ d -> evalTExpr =<< mkForAll d n <$> unifyKind t1 t2 <*> ((zero, PVar (n ::: CK t2)) |- unifyType (b1 (free (LName (getUsed d) n))) (b2 (free (LName (getUsed d) n)))) (TN.ForAll{}, _) -> mismatch (TN.Arrow _ _ a1 b1, TN.Arrow n q a2 b2) -> TN.Arrow n q <$> unifyType a1 a2 <*> unifyType b1 b2 (TN.Arrow{}, _) -> mismatch @@ -95,7 +95,7 @@ flexFlex v1 v2 solve :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Type -> m Type solve v t = do d <- depth - if occursIn v d t then + if occursIn v (getUsed d) t then occurs v t else gets (lookupMeta v) >>= \case From 454d04ef3efad2a89f5bf994c92ab87e479ee9db Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 14:45:10 -0400 Subject: [PATCH 0378/1324] Rename Facet.Surface to Facet.Surface.Expr. --- facet.cabal | 2 +- src/Facet/Driver.hs | 4 ++-- src/Facet/Elab/Term.hs | 2 +- src/Facet/Elab/Type.hs | 2 +- src/Facet/Parser.hs | 2 +- src/Facet/REPL.hs | 2 +- src/Facet/{Surface.hs => Surface/Expr.hs} | 2 +- 7 files changed, 8 insertions(+), 8 deletions(-) rename src/Facet/{Surface.hs => Surface/Expr.hs} (99%) diff --git a/facet.cabal b/facet.cabal index 739405218..874e9aeb7 100644 --- a/facet.cabal +++ b/facet.cabal @@ -120,7 +120,7 @@ library Facet.Span Facet.Style Facet.Subst - Facet.Surface + Facet.Surface.Expr Facet.Syntax Facet.Term.Class Facet.Term.Expr diff --git a/src/Facet/Driver.hs b/src/Facet/Driver.hs index c60ba91e8..17bb33557 100644 --- a/src/Facet/Driver.hs +++ b/src/Facet/Driver.hs @@ -48,8 +48,8 @@ import Facet.Print (Options) import Facet.Snoc import Facet.Source import Facet.Style -import qualified Facet.Surface as Import (Import(..)) -import qualified Facet.Surface as S +import qualified Facet.Surface.Expr as Import (Import(..)) +import qualified Facet.Surface.Expr as S import Fresnel.Getter ((^.)) import Fresnel.Lens (Lens, Lens', lens) import Silkscreen diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index d46ef58ca..4785b3bc7 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -69,7 +69,7 @@ import Facet.Snoc import Facet.Snoc.NonEmpty as NE import Facet.Source (Source) import Facet.Subst -import qualified Facet.Surface as S +import qualified Facet.Surface.Expr as S import Facet.Syntax import Facet.Term.Expr as E import qualified Facet.Type.Expr as TX diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 6ab92fcde..d62ef2366 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -28,7 +28,7 @@ import Facet.Name import Facet.Pattern import Facet.Semiring (Few(..), one, zero) import Facet.Snoc -import qualified Facet.Surface as S +import qualified Facet.Surface.Expr as S import Facet.Syntax import qualified Facet.Type.Expr as TX import Facet.Type.Norm diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index f404832de..35ce88497 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -36,7 +36,7 @@ import qualified Facet.Name as N import Facet.Parser.Table as Op import Facet.Snoc import Facet.Span -import qualified Facet.Surface as S +import qualified Facet.Surface.Expr as S import Facet.Syntax import Prelude hiding (lines, null, product, span) import Text.Parser.Char diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index 5372920b9..d281c5f9c 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -50,7 +50,7 @@ import Facet.REPL.Parser import Facet.Snoc import Facet.Source (Source(..), sourceFromString) import Facet.Style as Style -import qualified Facet.Surface as S +import qualified Facet.Surface.Expr as S import Facet.Syntax import Facet.Term.Expr (Term) import Fresnel.Lens (Lens', lens) diff --git a/src/Facet/Surface.hs b/src/Facet/Surface/Expr.hs similarity index 99% rename from src/Facet/Surface.hs rename to src/Facet/Surface/Expr.hs index dd36df0d7..8961b72cd 100644 --- a/src/Facet/Surface.hs +++ b/src/Facet/Surface/Expr.hs @@ -1,5 +1,5 @@ {-# LANGUAGE UndecidableInstances #-} -module Facet.Surface +module Facet.Surface.Expr ( -- * Types Kind(..) , Type(..) From a2b64222c68ae8586a825d272860e7ac940a648a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 14:45:43 -0400 Subject: [PATCH 0379/1324] Define a module for a surface syntax class. --- facet.cabal | 1 + src/Facet/Surface/Class.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Surface/Class.hs diff --git a/facet.cabal b/facet.cabal index 874e9aeb7..d51b2501f 100644 --- a/facet.cabal +++ b/facet.cabal @@ -120,6 +120,7 @@ library Facet.Span Facet.Style Facet.Subst + Facet.Surface.Class Facet.Surface.Expr Facet.Syntax Facet.Term.Class diff --git a/src/Facet/Surface/Class.hs b/src/Facet/Surface/Class.hs new file mode 100644 index 000000000..c5485850e --- /dev/null +++ b/src/Facet/Surface/Class.hs @@ -0,0 +1,2 @@ +module Facet.Surface.Class +() where From 48dd5f2dbce9374246762fc9e67d84247a3af486 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 15:51:59 -0400 Subject: [PATCH 0380/1324] Add a module for surface type expressions. --- facet.cabal | 1 + src/Facet/Surface/Type/Expr.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Surface/Type/Expr.hs diff --git a/facet.cabal b/facet.cabal index d51b2501f..7162814bd 100644 --- a/facet.cabal +++ b/facet.cabal @@ -122,6 +122,7 @@ library Facet.Subst Facet.Surface.Class Facet.Surface.Expr + Facet.Surface.Type.Expr Facet.Syntax Facet.Term.Class Facet.Term.Expr diff --git a/src/Facet/Surface/Type/Expr.hs b/src/Facet/Surface/Type/Expr.hs new file mode 100644 index 000000000..e12cbef5c --- /dev/null +++ b/src/Facet/Surface/Type/Expr.hs @@ -0,0 +1,2 @@ +module Facet.Surface.Type.Expr +() where From 1e0889bebe8e610d1771cb3ce73549c1adf31803 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 15:58:16 -0400 Subject: [PATCH 0381/1324] Rename the comments field of Ann to context. --- src/Facet/Surface/Expr.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Facet/Surface/Expr.hs b/src/Facet/Surface/Expr.hs index 8961b72cd..a4b088eed 100644 --- a/src/Facet/Surface/Expr.hs +++ b/src/Facet/Surface/Expr.hs @@ -20,7 +20,7 @@ module Facet.Surface.Expr -- * Annotations , Ann(..) , ann_ -, comments_ +, context_ , out_ , annUnary , annBinary @@ -121,9 +121,9 @@ newtype Import = Import { name :: MName } -- Annotations data Ann a = Ann - { ann :: Span - , comments :: Snoc (Span, Comment) - , out :: a + { ann :: Span + , context :: Snoc (Span, Comment) + , out :: a } deriving (Foldable, Functor, Traversable) @@ -142,8 +142,8 @@ instance HasSpan (Ann a) where ann_ :: Lens' (Ann a) Span ann_ = lens ann (\ a ann -> a{ ann }) -comments_ :: Lens' (Ann a) (Snoc (Span, Comment)) -comments_ = lens comments (\ a comments -> a{ comments }) +context_ :: Lens' (Ann a) (Snoc (Span, Comment)) +context_ = lens context (\ a context -> a{ context }) out_ :: Lens (Ann a) (Ann b) a b out_ = lens out (\ a out -> a{ out }) From 79be304a2cf34de2d0b0d71d4b62813ba6c7b8e7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 16:05:19 -0400 Subject: [PATCH 0382/1324] Parameterize Ann by the type of comments. --- src/Facet/Elab/Term.hs | 24 ++++++------- src/Facet/Elab/Type.hs | 6 ++-- src/Facet/Parser.hs | 74 +++++++++++++++++++-------------------- src/Facet/REPL.hs | 4 +-- src/Facet/Surface/Expr.hs | 58 +++++++++++++++--------------- 5 files changed, 83 insertions(+), 83 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 4785b3bc7..170876576 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -194,7 +194,7 @@ allP n = Bind $ \ _A k -> do -- Expression elaboration -synthExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Elab m (Term :==> Type) +synthExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Comment S.Expr -> Elab m (Term :==> Type) synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \case S.Var n -> var n S.App f a -> synthApp f a @@ -204,13 +204,13 @@ synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \cas S.Lam{} -> nope where nope = couldNotSynthesize - synthApp :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Expr -> Elab m (Term :==> Type) + synthApp :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Comment S.Expr -> S.Ann S.Comment S.Expr -> Elab m (Term :==> Type) synthApp f a = app App (synthExpr f) (checkExpr a) - synthAs :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Type -> Elab m (Term :==> Type) + synthAs :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Comment S.Expr -> S.Ann S.Comment S.Type -> Elab m (Term :==> Type) synthAs t _T = as (checkExpr t ::: do { _T :==> _K <- synthType _T ; (:==> _K) <$> evalTExpr _T }) -checkExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Type <==: Elab m Term +checkExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Comment S.Expr -> Type <==: Elab m Term checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in flip withSpanC expr $ \case S.Hole n -> hole n S.Lam cs -> checkLam cs @@ -229,7 +229,7 @@ checkLam cs = lam (snd vs) -- FIXME: check for unique variable names -bindPattern :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.ValPattern -> Bind m (Pattern (Name ::: Classifier)) +bindPattern :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Comment S.ValPattern -> Bind m (Pattern (Name ::: Classifier)) bindPattern = go where go = withSpanB $ \case S.PWildcard -> wildcardP @@ -272,7 +272,7 @@ patternForArgType = \case elabDataDef :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source :+: Throw Err :+: Write Warn) sig m) => Name ::: Kind - -> [S.Ann (Name ::: S.Ann S.Type)] + -> [S.Ann S.Comment (Name ::: S.Ann S.Comment S.Type)] -> m [Name :=: Def] -- FIXME: check that all constructors return the datatype. elabDataDef (dname ::: _K) constructors = do @@ -288,7 +288,7 @@ elabDataDef (dname ::: _K) constructors = do elabInterfaceDef :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source :+: Throw Err :+: Write Warn) sig m) => Name ::: Kind - -> [S.Ann (Name ::: S.Ann S.Type)] + -> [S.Ann S.Comment (Name ::: S.Ann S.Comment S.Type)] -> m [Name :=: Def] elabInterfaceDef (dname ::: _T) constructors = do cs <- for constructors $ \ (S.Ann _ _ (n ::: t)) -> do @@ -300,7 +300,7 @@ elabInterfaceDef (dname ::: _T) constructors = do elabTermDef :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source :+: Throw Err :+: Write Warn) sig m) => Type - -> S.Ann S.Expr + -> S.Ann S.Comment S.Expr -> m Term elabTermDef _T expr@(S.Ann s _ _) = do elabTerm $ pushSpan s $ check (go (checkExpr expr) ::: _T) @@ -318,7 +318,7 @@ elabTermDef _T expr@(S.Ann s _ _) = do elabModule :: (HasCallStack, Has (Reader Graph :+: Reader Source :+: Throw Err :+: Write Warn) sig m) - => S.Ann S.Module + => S.Ann S.Comment S.Module -> m Module elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os mempty) $ do let (importedNames, imports) = mapAccumL (\ names (S.Ann _ _ S.Import{ name }) -> (Set.insert name names, Import name)) Set.empty is @@ -374,13 +374,13 @@ runModule m = do mod <- get runReader mod m -withSpanB :: Algebra sig m => (a -> Bind m b) -> S.Ann a -> Bind m b +withSpanB :: Algebra sig m => (a -> Bind m b) -> S.Ann S.Comment a -> Bind m b withSpanB k (S.Ann s _ a) = Bind (\ _A k' -> pushSpan s (runBind (k a) _A k')) -withSpanC :: Algebra sig m => (a -> Type <==: Elab m b) -> S.Ann a -> Type <==: Elab m b +withSpanC :: Algebra sig m => (a -> Type <==: Elab m b) -> S.Ann S.Comment a -> Type <==: Elab m b withSpanC k (S.Ann s _ a) = Check (\ _T -> pushSpan s (k a <==: _T)) -withSpan :: Has (Reader ElabContext) sig m => (a -> m b) -> S.Ann a -> m b +withSpan :: Has (Reader ElabContext) sig m => (a -> m b) -> S.Ann S.Comment a -> m b withSpan k (S.Ann s _ a) = pushSpan s (k a) provide :: Has (Reader ElabContext :+: State (Subst Type)) sig m => Signature Type -> m a -> m a diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index d62ef2366..64a448729 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -88,14 +88,14 @@ comp s t = do pure $ TX.Comp (fromInterfaces s') t' :==> KType -synthKind :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Kind -> Elab m (Kind :==> Kind) +synthKind :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Comment S.Kind -> Elab m (Kind :==> Kind) synthKind (S.Ann s _ e) = pushSpan s $ case e of S.KArrow n a b -> arrow (KArrow n) (synthKind a) (synthKind b) S.KType -> _Type S.KInterface -> _Interface -synthType :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Type -> Elab m (TX.Type :==> Kind) +synthType :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Comment S.Type -> Elab m (TX.Type :==> Kind) synthType (S.Ann s _ e) = pushSpan s $ case e of S.TVar n -> tvar n S.TString -> _String @@ -108,7 +108,7 @@ synthType (S.Ann s _ e) = pushSpan s $ case e of S.Zero -> zero S.One -> one -synthInterface :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Interface -> Elab m (Interface TX.Type :==> Kind) +synthInterface :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Comment S.Interface -> Elab m (Interface TX.Type :==> Kind) synthInterface (S.Ann s _ (S.Interface (S.Ann sh _ h) sp)) = pushSpan s $ do -- FIXME: check that the application actually result in an Interface h' :==> _ <- pushSpan sh (ivar h) diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index 35ce88497..4f89d2751 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -56,7 +56,7 @@ whole :: TokenParsing p => p a -> p a whole p = whiteSpace *> p <* eof -makeOperator :: (N.MName, N.Op, N.Assoc) -> Operator (S.Ann S.Expr) +makeOperator :: (N.MName, N.Op, N.Assoc) -> Operator (S.Ann S.Comment S.Expr) makeOperator (name, op, assoc) = (op, assoc, nary (N.toQ (name N.:.: N.O op))) where nary name es = foldl' (S.annBinary S.App) (S.Ann (S.ann (head es)) Nil (S.Var name)) es @@ -64,23 +64,23 @@ makeOperator (name, op, assoc) = (op, assoc, nary (N.toQ (name N.:.: N.O op))) -- Modules -module' :: (Has Parser sig p, Has (State [Operator (S.Ann S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Module) +module' :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Module) module' = anned $ do (name, imports) <- moduleHeader decls <- C.runReader name (runReaderC (many decl)) - ops <- get @[Operator (S.Ann S.Expr)] + ops <- get @[Operator (S.Ann S.Comment S.Expr)] pure $ S.Module name imports (map (\ (op, assoc, _) -> (op, assoc)) ops) decls -moduleHeader :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (N.MName, [S.Ann S.Import]) +moduleHeader :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (N.MName, [S.Ann S.Comment S.Import]) moduleHeader = (,) <$ reserve dnameStyle "module" <*> mname <* colon <* symbol "Module" <*> many import' -- Declarations -import' :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Import) +import' :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Import) import' = anned $ S.Import <$ reserve dnameStyle "import" <*> mname -decl :: (Has Parser sig p, Has (Reader N.MName) sig p, Has (State [Operator (S.Ann S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann (N.Name, S.Ann S.Def)) +decl :: (Has Parser sig p, Has (Reader N.MName) sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name, S.Ann S.Comment S.Def)) decl = choice [ termDecl , dataDecl @@ -90,7 +90,7 @@ decl = choice -- FIXME: operators aren’t available until after their declarations have been parsed. -- FIXME: parse operator declarations in datatypes. -- FIXME: parse operator declarations in interfaces. -termDecl :: (Has Parser sig p, Has (Reader N.MName) sig p, Has (State [Operator (S.Ann S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann (N.Name, S.Ann S.Def)) +termDecl :: (Has Parser sig p, Has (Reader N.MName) sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name, S.Ann S.Comment S.Def)) termDecl = anned $ do name <- dename case name of @@ -109,18 +109,18 @@ termDecl = anned $ do decl <- anned $ colon *> typeSig ename <**> (S.TermDef <$> body) pure (name, decl) -body :: (Has Parser sig p, Has (State [Operator (S.Ann S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Expr) +body :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) -- NB: We parse sepBy1 and the empty case separately so that it doesn’t succeed at matching 0 clauses and then expect a closing brace when it sees a nullary computation body = fmap (either S.out id) <$> anned (braces (Right . S.Lam <$> sepBy1 clause comma <|> Left <$> expr <|> pure (Right (S.Lam [])))) -dataDecl :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann (N.Name, S.Ann S.Def)) +dataDecl :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name, S.Ann S.Comment S.Def)) dataDecl = anned $ (,) <$ reserve dnameStyle "data" <*> tname <* colon <*> anned (kindSig tname <**> (S.DataDef <$> braces (commaSep con))) -interfaceDecl :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann (N.Name, S.Ann S.Def)) +interfaceDecl :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name, S.Ann S.Comment S.Def)) interfaceDecl = anned $ (,) <$ reserve dnameStyle "interface" <*> tname <* colon <*> anned (kindSig tname <**> (S.InterfaceDef <$> braces (commaSep con))) -con :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann (N.Name ::: S.Ann S.Type)) +con :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name ::: S.Ann S.Comment S.Type)) con = anned ((:::) <$> dename <* colon <*> rec) where rec = choice [ forAll rec, type' ] @@ -129,30 +129,30 @@ con = anned ((:::) <$> dename <* colon <*> rec) kindSig :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p N.Name -- ^ a parser for names occurring in explicit (parenthesized) bindings - -> p (S.Ann S.Kind) + -> p (S.Ann S.Comment S.Kind) kindSig name = choice [ kindArrow name (kindSig name), kind ] typeSig :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p N.Name -- ^ a parser for names occurring in explicit (parenthesized) bindings - -> p (S.Ann S.Type) + -> p (S.Ann S.Comment S.Type) typeSig name = choice [ forAll (typeSig name), bindArrow name (typeSig name), type' ] -- Types -kind :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Kind) +kind :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Kind) kind = choice [ token (anned (S.KType <$ string "Type")) , token (anned (S.KInterface <$ string "Interface")) ] -kindArrow :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p N.Name -> p (S.Ann S.Kind) -> p (S.Ann S.Kind) +kindArrow :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p N.Name -> p (S.Ann S.Comment S.Kind) -> p (S.Ann S.Comment S.Kind) kindArrow name k = anned (try (S.KArrow . Just <$ lparen <*> (name <|> N.__ <$ wildcard) <* colon) <*> kind <* rparen <* arrow <*> k) -- FIXME: kind ascriptions -monotypeTable :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => Table p (S.Ann S.Type) +monotypeTable :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => Table p (S.Ann S.Comment S.Type) monotypeTable = [ [ functionType ] , [ retType ] @@ -165,40 +165,40 @@ monotypeTable = ] -type' :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Type) +type' :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) type' = monotype -forAll :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Type) -> p (S.Ann S.Type) +forAll :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) forAll k = make <$> anned (try (((,,) <$ lbrace <*> commaSep1 ((,) <$> position <*> tname) <* colon) <*> kind <* rbrace <* arrow) <*> k) where make (S.Ann s cs (ns, t, b)) = S.Ann s cs (S.out (foldr (\ (p, n) b -> S.Ann (Span p (end s)) Nil (S.TForAll n t b)) b ns)) -bindArrow :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p N.Name -> p (S.Ann S.Type) -> p (S.Ann S.Type) +bindArrow :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p N.Name -> p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) bindArrow name k = anned (try (S.TArrow . Just <$ lparen <*> (name <|> N.__ <$ wildcard) <* colon) <*> optional mul <*> type' <* rparen <* arrow <*> k) -functionType :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Type) -> p (S.Ann S.Type) -> p (S.Ann S.Type) +functionType :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) functionType self next = anned (try (S.TArrow Nothing <$> optional mul <*> next <* arrow) <*> self) <|> next mul :: TokenParsing p => p S.Mul mul = choice [ S.Zero <$ token (char '0'), S.One <$ token (char '1') ] -retType :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Type) -> p (S.Ann S.Type) -> p (S.Ann S.Type) +retType :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) retType _ next = mk <$> anned ((,) <$> optional signature <*> next) where mk (S.Ann s c (sig, _T)) = maybe id (\ sig -> S.Ann s c . S.TComp sig) sig _T -- FIXME: support type operators -monotype :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Type) +monotype :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) monotype = build monotypeTable $ parens type' -tvar :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Type) +tvar :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) tvar = anned (S.TVar <$> qname tname) -signature :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p [S.Ann S.Interface] +signature :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p [S.Ann S.Comment S.Interface] signature = brackets (commaSep delta) "signature" where delta = anned $ S.Interface <$> head <*> (fromList <$> many type') @@ -209,7 +209,7 @@ signature = brackets (commaSep delta) "signature" -- Expressions -exprTable :: (Has Parser sig p, Has (State [Operator (S.Ann S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => Table p (S.Ann S.Expr) +exprTable :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => Table p (S.Ann S.Comment S.Expr) exprTable = -- FIXME: parse this as a unary operator or something -- FIXME: better yet, generalize operators to allow different syntactic types on either side (following the associativity) @@ -218,23 +218,23 @@ exprTable = , [ atom thunk, atom hole, atom evar, atom (token (anned (runUnspaced (S.String <$> stringLiteral)))) ] ] -expr :: (Has Parser sig p, Has (State [Operator (S.Ann S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Expr) +expr :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) expr = do ops <- get let rec = build (map parseOperator ops:exprTable) $ parens rec rec -ascription :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Expr) -> p (S.Ann S.Expr) -> p (S.Ann S.Expr) +ascription :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) -> p (S.Ann S.Comment S.Expr) -> p (S.Ann S.Comment S.Expr) ascription _self next = anned (S.As <$> try (next <* colon) <*> type') <|> next -thunk :: (Has Parser sig p, Has (State [Operator (S.Ann S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Expr) +thunk :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) -- NB: We parse sepBy1 and the empty case separately so that it doesn’t succeed at matching 0 clauses and then expect a closing brace when it sees a nullary computation thunk = anned (braces (S.Lam <$> sepBy1 clause comma <|> {-S.Thunk <$> expr <|>-} pure (S.Lam []))) -clause :: (Has Parser sig p, Has (State [Operator (S.Ann S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p S.Clause +clause :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p S.Clause clause = S.Clause <$> try (compPattern <* arrow) <*> expr "clause" -evar :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Expr) +evar :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) evar = choice [ token (anned (runUnspaced (S.Var <$> try ((N.:.) . fromList <$> many (comp <* dot) <*> ename)))) -- FIXME: would be better to commit once we see a placeholder, but try doesn’t really let us express that @@ -243,7 +243,7 @@ evar = choice where comp = ident tnameStyle -hole :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Expr) +hole :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) hole = token (anned (runUnspaced (S.Hole <$> ident hnameStyle))) where hnameStyle = IdentifierStyle "hole name" (char '?') nameChar reserved Identifier ReservedIdentifier @@ -254,14 +254,14 @@ hole = token (anned (runUnspaced (S.Hole <$> ident hnameStyle))) wildcard :: (Monad p, TokenParsing p) => p () wildcard = reserve enameStyle "_" -valuePattern :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.ValPattern) +valuePattern :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.ValPattern) valuePattern = choice [ token (anned (runUnspaced (S.PVar <$> ename "variable"))) , anned (S.PWildcard <$ wildcard) , try (parens (anned (S.PCon <$> qname ename <*> many valuePattern))) ] "pattern" -compPattern :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Pattern) +compPattern :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Pattern) compPattern = choice [ anned (S.PVal <$> valuePattern) , anned (S.PEff <$> try (brackets (anned (S.POp <$> qname ename <*> many valuePattern <* symbolic ';' <*> valuePattern)))) @@ -351,7 +351,7 @@ rbrace :: TokenParsing p => p Char rbrace = symbolic '}' -anned :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p) => p a -> p (S.Ann a) +anned :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p) => p a -> p (S.Ann S.Comment a) anned p = mk <$> censor @(Snoc (Span, S.Comment)) (const Nil) (listen @(Snoc (Span, S.Comment)) ((,,) <$> position <*> p <*> position)) where mk (cs, (s, a, e)) = S.Ann (Span s e) cs a @@ -359,11 +359,11 @@ anned p = mk <$> censor @(Snoc (Span, S.Comment)) (const Nil) (listen @(Snoc (Sp -- Parsing carriers -runFacet :: Functor m => [Operator (S.Ann S.Expr)] -> Facet m a -> m a +runFacet :: Functor m => [Operator (S.Ann S.Comment S.Expr)] -> Facet m a -> m a runFacet ops (Facet m) = snd <$> C.runWriter (runWriterC (C.evalState ops (runStateC m))) -newtype Facet m a = Facet (StateC [Operator (S.Ann S.Expr)] (WriterC (Snoc (Span, S.Comment)) m) a) - deriving (Algebra (State [Operator (S.Ann S.Expr)] :+: Writer (Snoc (Span, S.Comment)) :+: sig), Alternative, Applicative, Functor, Monad, MonadFail, MonadFix) +newtype Facet m a = Facet (StateC [Operator (S.Ann S.Comment S.Expr)] (WriterC (Snoc (Span, S.Comment)) m) a) + deriving (Algebra (State [Operator (S.Ann S.Comment S.Expr)] :+: Writer (Snoc (Span, S.Comment)) :+: sig), Alternative, Applicative, Functor, Monad, MonadFail, MonadFix) instance (Monad p, Parsing p) => Parsing (Facet p) where try (Facet m) = Facet $ try m diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index d281c5f9c..5132b0537 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -193,7 +193,7 @@ addTarget targets = Action $ do removeTarget targets = Action $ target_.targets_ %= (Set.\\ Set.fromList targets) -showType, showEval :: S.Ann S.Expr -> Action +showType, showEval :: S.Ann S.Comment S.Expr -> Action showType e = Action $ do e :==> _T <- runElab $ Elab.elabSynthTerm (Elab.synthExpr e) @@ -217,7 +217,7 @@ runEvalMain e = runEval (quote 0 =<< runReader mempty (eval e)) pure -- handle _ _ = unhandled -- unhandled = throwError $ Notice.Notice (Just Notice.Error) [] (fillSep @(Doc Style) [reflow "unhandled effect operator"]) [] -showKind :: S.Ann S.Type -> Action +showKind :: S.Ann S.Comment S.Type -> Action showKind _T = Action $ do _T :==> _K <- runElab $ Elab.elabSynthType (Elab.synthType _T) opts <- get diff --git a/src/Facet/Surface/Expr.hs b/src/Facet/Surface/Expr.hs index a4b088eed..75a2de7a7 100644 --- a/src/Facet/Surface/Expr.hs +++ b/src/Facet/Surface/Expr.hs @@ -40,16 +40,16 @@ import Fresnel.Lens (Lens, Lens', lens) data Kind = KType | KInterface - | KArrow (Maybe Name) (Ann Kind) (Ann Kind) + | KArrow (Maybe Name) (Ann Comment Kind) (Ann Comment Kind) deriving (Eq, Show) data Type = TVar QName | TString - | TForAll Name (Ann Kind) (Ann Type) - | TArrow (Maybe Name) (Maybe Mul) (Ann Type) (Ann Type) - | TComp [Ann Interface] (Ann Type) - | TApp (Ann Type) (Ann Type) + | TForAll Name (Ann Comment Kind) (Ann Comment Type) + | TArrow (Maybe Name) (Maybe Mul) (Ann Comment Type) (Ann Comment Type) + | TComp [Ann Comment Interface] (Ann Comment Type) + | TApp (Ann Comment Type) (Ann Comment Type) deriving (Eq, Show) data Mul = Zero | One @@ -62,43 +62,43 @@ data Expr = Var QName | Hole Name | Lam [Clause] - | App (Ann Expr) (Ann Expr) - | As (Ann Expr) (Ann Type) + | App (Ann Comment Expr) (Ann Comment Expr) + | As (Ann Comment Expr) (Ann Comment Type) | String Text deriving (Eq, Show) -data Interface = Interface (Ann QName) (Snoc (Ann Type)) +data Interface = Interface (Ann Comment QName) (Snoc (Ann Comment Type)) deriving (Eq, Show) -data Clause = Clause (Ann Pattern) (Ann Expr) +data Clause = Clause (Ann Comment Pattern) (Ann Comment Expr) deriving (Eq, Show) -- Patterns data Pattern - = PVal (Ann ValPattern) - | PEff (Ann EffPattern) + = PVal (Ann Comment ValPattern) + | PEff (Ann Comment EffPattern) deriving (Eq, Show) data ValPattern = PWildcard | PVar Name - | PCon QName [Ann ValPattern] + | PCon QName [Ann Comment ValPattern] deriving (Eq, Show) -data EffPattern = POp QName [Ann ValPattern] (Ann ValPattern) +data EffPattern = POp QName [Ann Comment ValPattern] (Ann Comment ValPattern) deriving (Eq, Show) -- Declarations data Def - = DataDef [Ann (Name ::: Ann Type)] (Ann Kind) - | InterfaceDef [Ann (Name ::: Ann Type)] (Ann Kind) - | TermDef (Ann Expr) (Ann Type) + = DataDef [Ann Comment (Name ::: Ann Comment Type)] (Ann Comment Kind) + | InterfaceDef [Ann Comment (Name ::: Ann Comment Type)] (Ann Comment Kind) + | TermDef (Ann Comment Expr) (Ann Comment Type) deriving (Eq, Show) @@ -106,10 +106,10 @@ data Def data Module = Module { name :: MName - , imports :: [Ann Import] + , imports :: [Ann Comment Import] -- FIXME: store source references for operators’ definitions, for error reporting , operators :: [(Op, Assoc)] - , defs :: [Ann (Name, Ann Def)] + , defs :: [Ann Comment (Name, Ann Comment Def)] } deriving (Eq, Show) @@ -120,39 +120,39 @@ newtype Import = Import { name :: MName } -- Annotations -data Ann a = Ann +data Ann c a = Ann { ann :: Span - , context :: Snoc (Span, Comment) + , context :: Snoc (Span, c) , out :: a } deriving (Foldable, Functor, Traversable) -instance Eq a => Eq (Ann a) where +instance Eq a => Eq (Ann c a) where (==) = (==) `on` out -instance Ord a => Ord (Ann a) where +instance Ord a => Ord (Ann c a) where compare = compare `on` out -instance Show a => Show (Ann a) where +instance Show a => Show (Ann c a) where showsPrec p = showsPrec p . out -instance HasSpan (Ann a) where +instance HasSpan (Ann c a) where span_ = ann_ -ann_ :: Lens' (Ann a) Span +ann_ :: Lens' (Ann c a) Span ann_ = lens ann (\ a ann -> a{ ann }) -context_ :: Lens' (Ann a) (Snoc (Span, Comment)) +context_ :: Lens (Ann c a) (Ann d a) (Snoc (Span, c)) (Snoc (Span, d)) context_ = lens context (\ a context -> a{ context }) -out_ :: Lens (Ann a) (Ann b) a b +out_ :: Lens (Ann c a) (Ann c b) a b out_ = lens out (\ a out -> a{ out }) -annUnary :: (Ann a -> a) -> Ann a -> Ann a +annUnary :: (Ann c a -> a) -> Ann c a -> Ann c a annUnary f a = Ann (ann a) Nil (f a) -annBinary :: (Ann a -> Ann b -> a) -> Ann a -> Ann b -> Ann a +annBinary :: (Ann c a -> Ann c b -> a) -> Ann c a -> Ann c b -> Ann c a annBinary f a b = Ann (ann a <> ann b) Nil (f a b) From 066600a85af42e63b599406a3ff8ce681ed2459b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 16:12:24 -0400 Subject: [PATCH 0383/1324] Move Ann into the Syntax module. --- src/Facet/Driver.hs | 2 +- src/Facet/Elab.hs | 2 +- src/Facet/Elab/Term.hs | 2 +- src/Facet/Elab/Type.hs | 2 +- src/Facet/Notice/Elab.hs | 2 +- src/Facet/Parser.hs | 2 +- src/Facet/Print.hs | 2 +- src/Facet/REPL.hs | 2 +- src/Facet/Surface/Expr.hs | 45 ------------------------------------ src/Facet/Syntax.hs | 48 +++++++++++++++++++++++++++++++++++++++ 10 files changed, 56 insertions(+), 53 deletions(-) diff --git a/src/Facet/Driver.hs b/src/Facet/Driver.hs index 17bb33557..ea997b453 100644 --- a/src/Facet/Driver.hs +++ b/src/Facet/Driver.hs @@ -49,7 +49,7 @@ import Facet.Snoc import Facet.Source import Facet.Style import qualified Facet.Surface.Expr as Import (Import(..)) -import qualified Facet.Surface.Expr as S +import Facet.Syntax as S import Fresnel.Getter ((^.)) import Fresnel.Lens (Lens, Lens', lens) import Silkscreen diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 6039adf3c..942d3aba6 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -76,7 +76,7 @@ import Facet.Snoc.NonEmpty (toSnoc) import Facet.Source (Source, slice) import Facet.Span (Span(..)) import Facet.Subst -import Facet.Syntax +import Facet.Syntax hiding (context_) import Facet.Term.Expr as E import qualified Facet.Type.Expr as TX import Facet.Type.Norm as TN diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 170876576..3200d3cd2 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -70,7 +70,7 @@ import Facet.Snoc.NonEmpty as NE import Facet.Source (Source) import Facet.Subst import qualified Facet.Surface.Expr as S -import Facet.Syntax +import Facet.Syntax as S hiding (context_) import Facet.Term.Expr as E import qualified Facet.Type.Expr as TX import Facet.Type.Norm as T hiding (global) diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 64a448729..6a563aad9 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -29,7 +29,7 @@ import Facet.Pattern import Facet.Semiring (Few(..), one, zero) import Facet.Snoc import qualified Facet.Surface.Expr as S -import Facet.Syntax +import Facet.Syntax as S hiding (context_) import qualified Facet.Type.Expr as TX import Facet.Type.Norm import GHC.Stack diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index cb888f7d0..8e58c8c1c 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -20,7 +20,7 @@ import Facet.Semiring (Few(..), one, zero) import Facet.Snoc import Facet.Style import Facet.Subst (metas) -import Facet.Syntax +import Facet.Syntax hiding (ann) import Facet.Type.Norm (Classifier(..), apply, free, metavar) import GHC.Stack import Prelude hiding (print, unlines) diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index 4f89d2751..391b8cd32 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -37,7 +37,7 @@ import Facet.Parser.Table as Op import Facet.Snoc import Facet.Span import qualified Facet.Surface.Expr as S -import Facet.Syntax +import Facet.Syntax as S import Prelude hiding (lines, null, product, span) import Text.Parser.Char import Text.Parser.Combinators diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 84366c3c0..9736f4219 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -40,7 +40,7 @@ import Facet.Quote import Facet.Semiring (one, zero) import Facet.Snoc import Facet.Style -import Facet.Syntax +import Facet.Syntax hiding (Ann(..)) import qualified Facet.Term.Expr as C import qualified Facet.Term.Norm as N import qualified Facet.Type.Expr as TX diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index 5132b0537..76b1a5ca4 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -51,7 +51,7 @@ import Facet.Snoc import Facet.Source (Source(..), sourceFromString) import Facet.Style as Style import qualified Facet.Surface.Expr as S -import Facet.Syntax +import Facet.Syntax as S hiding (ann) import Facet.Term.Expr (Term) import Fresnel.Lens (Lens', lens) import Fresnel.Setter ((.~)) diff --git a/src/Facet/Surface/Expr.hs b/src/Facet/Surface/Expr.hs index 75a2de7a7..5e6ddb0e8 100644 --- a/src/Facet/Surface/Expr.hs +++ b/src/Facet/Surface/Expr.hs @@ -18,22 +18,13 @@ module Facet.Surface.Expr , Module(..) , Import(..) -- * Annotations -, Ann(..) -, ann_ -, context_ -, out_ -, annUnary -, annBinary , Comment(..) ) where -import Data.Function (on) import Data.Text (Text) import Facet.Name import Facet.Snoc -import Facet.Span import Facet.Syntax -import Fresnel.Lens (Lens, Lens', lens) -- Types @@ -120,41 +111,5 @@ newtype Import = Import { name :: MName } -- Annotations -data Ann c a = Ann - { ann :: Span - , context :: Snoc (Span, c) - , out :: a - } - deriving (Foldable, Functor, Traversable) - -instance Eq a => Eq (Ann c a) where - (==) = (==) `on` out - -instance Ord a => Ord (Ann c a) where - compare = compare `on` out - -instance Show a => Show (Ann c a) where - showsPrec p = showsPrec p . out - -instance HasSpan (Ann c a) where - span_ = ann_ - -ann_ :: Lens' (Ann c a) Span -ann_ = lens ann (\ a ann -> a{ ann }) - -context_ :: Lens (Ann c a) (Ann d a) (Snoc (Span, c)) (Snoc (Span, d)) -context_ = lens context (\ a context -> a{ context }) - -out_ :: Lens (Ann c a) (Ann c b) a b -out_ = lens out (\ a out -> a{ out }) - - -annUnary :: (Ann c a -> a) -> Ann c a -> Ann c a -annUnary f a = Ann (ann a) Nil (f a) - -annBinary :: (Ann c a -> Ann c b -> a) -> Ann c a -> Ann c b -> Ann c a -annBinary f a b = Ann (ann a <> ann b) Nil (f a b) - - newtype Comment = Comment { getComment :: Text } deriving (Eq, Show) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index ede003583..9e9d49db3 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -19,15 +19,25 @@ module Facet.Syntax , T(..) -- * Natural transformations , type (~>) + -- * Annotations +, Ann(..) +, ann_ +, context_ +, out_ +, annUnary +, annBinary ) where import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable +import Data.Function (on) import Data.Functor.Classes import Data.Kind (Type) import Facet.Name import Facet.Snoc +import Facet.Span +import Fresnel.Lens (Lens, Lens', lens) data a ::: b = a ::: b deriving (Eq, Foldable, Functor, Ord, Show, Traversable) @@ -131,3 +141,41 @@ newtype T a b = T { getT :: a } -- Natural transformations type i ~> j = forall x . i x -> j x + + +-- Annotations + +data Ann c a = Ann + { ann :: Span + , context :: Snoc (Span, c) + , out :: a + } + deriving (Foldable, Functor, Traversable) + +instance Eq a => Eq (Ann c a) where + (==) = (==) `on` out + +instance Ord a => Ord (Ann c a) where + compare = compare `on` out + +instance Show a => Show (Ann c a) where + showsPrec p = showsPrec p . out + +instance HasSpan (Ann c a) where + span_ = ann_ + +ann_ :: Lens' (Ann c a) Span +ann_ = lens ann (\ a ann -> a{ ann }) + +context_ :: Lens (Ann c a) (Ann d a) (Snoc (Span, c)) (Snoc (Span, d)) +context_ = lens context (\ a context -> a{ context }) + +out_ :: Lens (Ann c a) (Ann c b) a b +out_ = lens out (\ a out -> a{ out }) + + +annUnary :: (Ann c a -> a) -> Ann c a -> Ann c a +annUnary f a = Ann (ann a) Nil (f a) + +annBinary :: (Ann c a -> Ann c b -> a) -> Ann c a -> Ann c b -> Ann c a +annBinary f a b = Ann (ann a <> ann b) Nil (f a b) From 207ff11ef4cd5d4c2d23561004286c98e3055b71 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 16:16:28 -0400 Subject: [PATCH 0384/1324] Move Comment into the syntax module. --- src/Facet/Surface/Expr.hs | 8 -------- src/Facet/Syntax.hs | 6 ++++++ 2 files changed, 6 insertions(+), 8 deletions(-) diff --git a/src/Facet/Surface/Expr.hs b/src/Facet/Surface/Expr.hs index 5e6ddb0e8..ffadbad7d 100644 --- a/src/Facet/Surface/Expr.hs +++ b/src/Facet/Surface/Expr.hs @@ -17,8 +17,6 @@ module Facet.Surface.Expr -- * Modules , Module(..) , Import(..) - -- * Annotations -, Comment(..) ) where import Data.Text (Text) @@ -107,9 +105,3 @@ data Module = Module newtype Import = Import { name :: MName } deriving (Eq, Show) - - --- Annotations - -newtype Comment = Comment { getComment :: Text } - deriving (Eq, Show) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 9e9d49db3..996c9ca3b 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -26,6 +26,7 @@ module Facet.Syntax , out_ , annUnary , annBinary +, Comment(..) ) where import Data.Bifoldable @@ -34,6 +35,7 @@ import Data.Bitraversable import Data.Function (on) import Data.Functor.Classes import Data.Kind (Type) +import Data.Text (Text) import Facet.Name import Facet.Snoc import Facet.Span @@ -179,3 +181,7 @@ annUnary f a = Ann (ann a) Nil (f a) annBinary :: (Ann c a -> Ann c b -> a) -> Ann c a -> Ann c b -> Ann c a annBinary f a b = Ann (ann a <> ann b) Nil (f a b) + + +newtype Comment = Comment { getComment :: Text } + deriving (Eq, Show) From a56e5f4c64c219bb738ef9afe2edd76356ad1453 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 18:41:13 -0400 Subject: [PATCH 0385/1324] Move the types into Facet.Surface.Type.Expr. --- src/Facet/Surface/Expr.hs | 27 +------------------------- src/Facet/Surface/Type/Expr.hs | 35 +++++++++++++++++++++++++++++++++- 2 files changed, 35 insertions(+), 27 deletions(-) diff --git a/src/Facet/Surface/Expr.hs b/src/Facet/Surface/Expr.hs index ffadbad7d..ed6bd2491 100644 --- a/src/Facet/Surface/Expr.hs +++ b/src/Facet/Surface/Expr.hs @@ -21,30 +21,9 @@ module Facet.Surface.Expr import Data.Text (Text) import Facet.Name -import Facet.Snoc +import Facet.Surface.Type.Expr import Facet.Syntax --- Types - -data Kind - = KType - | KInterface - | KArrow (Maybe Name) (Ann Comment Kind) (Ann Comment Kind) - deriving (Eq, Show) - -data Type - = TVar QName - | TString - | TForAll Name (Ann Comment Kind) (Ann Comment Type) - | TArrow (Maybe Name) (Maybe Mul) (Ann Comment Type) (Ann Comment Type) - | TComp [Ann Comment Interface] (Ann Comment Type) - | TApp (Ann Comment Type) (Ann Comment Type) - deriving (Eq, Show) - -data Mul = Zero | One - deriving (Bounded, Enum, Eq, Ord, Show) - - -- Expressions data Expr @@ -57,10 +36,6 @@ data Expr deriving (Eq, Show) -data Interface = Interface (Ann Comment QName) (Snoc (Ann Comment Type)) - deriving (Eq, Show) - - data Clause = Clause (Ann Comment Pattern) (Ann Comment Expr) deriving (Eq, Show) diff --git a/src/Facet/Surface/Type/Expr.hs b/src/Facet/Surface/Type/Expr.hs index e12cbef5c..cc97cd473 100644 --- a/src/Facet/Surface/Type/Expr.hs +++ b/src/Facet/Surface/Type/Expr.hs @@ -1,2 +1,35 @@ module Facet.Surface.Type.Expr -() where +( Kind(..) +, Type(..) +, Interface(..) +, Mul(..) +) where + +import Facet.Name +import Facet.Snoc +import Facet.Syntax + +-- Types + +data Kind + = KType + | KInterface + | KArrow (Maybe Name) (Ann Comment Kind) (Ann Comment Kind) + deriving (Eq, Show) + +data Type + = TVar QName + | TString + | TForAll Name (Ann Comment Kind) (Ann Comment Type) + | TArrow (Maybe Name) (Maybe Mul) (Ann Comment Type) (Ann Comment Type) + | TComp [Ann Comment Interface] (Ann Comment Type) + | TApp (Ann Comment Type) (Ann Comment Type) + deriving (Eq, Show) + + +data Interface = Interface (Ann Comment QName) (Snoc (Ann Comment Type)) + deriving (Eq, Show) + + +data Mul = Zero | One + deriving (Bounded, Enum, Eq, Ord, Show) From a1e65f2beac59cc926b0537d4c69e71972527628 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 18:42:11 -0400 Subject: [PATCH 0386/1324] =?UTF-8?q?Don=E2=80=99t=20re-export=20the=20typ?= =?UTF-8?q?es.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Elab/Term.hs | 1 + src/Facet/Elab/Type.hs | 2 +- src/Facet/Parser.hs | 1 + src/Facet/REPL.hs | 1 + src/Facet/Surface/Expr.hs | 9 ++------- 5 files changed, 6 insertions(+), 8 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 3200d3cd2..7b667f00e 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -70,6 +70,7 @@ import Facet.Snoc.NonEmpty as NE import Facet.Source (Source) import Facet.Subst import qualified Facet.Surface.Expr as S +import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) import Facet.Term.Expr as E import qualified Facet.Type.Expr as TX diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 6a563aad9..27bb68938 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -28,7 +28,7 @@ import Facet.Name import Facet.Pattern import Facet.Semiring (Few(..), one, zero) import Facet.Snoc -import qualified Facet.Surface.Expr as S +import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) import qualified Facet.Type.Expr as TX import Facet.Type.Norm diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index 391b8cd32..8d9d760ff 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -37,6 +37,7 @@ import Facet.Parser.Table as Op import Facet.Snoc import Facet.Span import qualified Facet.Surface.Expr as S +import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S import Prelude hiding (lines, null, product, span) import Text.Parser.Char diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index 76b1a5ca4..e0e74e35e 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -51,6 +51,7 @@ import Facet.Snoc import Facet.Source (Source(..), sourceFromString) import Facet.Style as Style import qualified Facet.Surface.Expr as S +import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (ann) import Facet.Term.Expr (Term) import Fresnel.Lens (Lens', lens) diff --git a/src/Facet/Surface/Expr.hs b/src/Facet/Surface/Expr.hs index ed6bd2491..8906dd685 100644 --- a/src/Facet/Surface/Expr.hs +++ b/src/Facet/Surface/Expr.hs @@ -1,12 +1,7 @@ {-# LANGUAGE UndecidableInstances #-} module Facet.Surface.Expr -( -- * Types - Kind(..) -, Type(..) -, Mul(..) - -- * Expressions -, Expr(..) -, Interface(..) +( -- * Expressions + Expr(..) , Clause(..) -- * Patterns , Pattern(..) From e6b047e22dfe88b7a6d60ecb1e137710ab66db44 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 18:43:15 -0400 Subject: [PATCH 0387/1324] Define a module for surface term expressions. --- facet.cabal | 1 + src/Facet/Surface/Term/Expr.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Surface/Term/Expr.hs diff --git a/facet.cabal b/facet.cabal index 7162814bd..5c60d91b3 100644 --- a/facet.cabal +++ b/facet.cabal @@ -122,6 +122,7 @@ library Facet.Subst Facet.Surface.Class Facet.Surface.Expr + Facet.Surface.Term.Expr Facet.Surface.Type.Expr Facet.Syntax Facet.Term.Class diff --git a/src/Facet/Surface/Term/Expr.hs b/src/Facet/Surface/Term/Expr.hs new file mode 100644 index 000000000..eaaddda82 --- /dev/null +++ b/src/Facet/Surface/Term/Expr.hs @@ -0,0 +1,2 @@ +module Facet.Surface.Term.Expr +() where From 81269b3a43bfa727022de4bc0e6ff082f9196d46 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 18:45:13 -0400 Subject: [PATCH 0388/1324] Move Expr &c. into Facet.Surface.Term.Expr. --- src/Facet/Elab/Term.hs | 1 + src/Facet/Parser.hs | 1 + src/Facet/REPL.hs | 2 +- src/Facet/Surface/Expr.hs | 46 +++------------------------------- src/Facet/Surface/Term/Expr.hs | 46 +++++++++++++++++++++++++++++++++- 5 files changed, 51 insertions(+), 45 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 7b667f00e..7d24f2756 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -70,6 +70,7 @@ import Facet.Snoc.NonEmpty as NE import Facet.Source (Source) import Facet.Subst import qualified Facet.Surface.Expr as S +import qualified Facet.Surface.Term.Expr as S import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) import Facet.Term.Expr as E diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index 8d9d760ff..0788e39a7 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -37,6 +37,7 @@ import Facet.Parser.Table as Op import Facet.Snoc import Facet.Span import qualified Facet.Surface.Expr as S +import qualified Facet.Surface.Term.Expr as S import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S import Prelude hiding (lines, null, product, span) diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index e0e74e35e..35b99ad87 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -50,7 +50,7 @@ import Facet.REPL.Parser import Facet.Snoc import Facet.Source (Source(..), sourceFromString) import Facet.Style as Style -import qualified Facet.Surface.Expr as S +import qualified Facet.Surface.Term.Expr as S import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (ann) import Facet.Term.Expr (Term) diff --git a/src/Facet/Surface/Expr.hs b/src/Facet/Surface/Expr.hs index 8906dd685..98a5c8da5 100644 --- a/src/Facet/Surface/Expr.hs +++ b/src/Facet/Surface/Expr.hs @@ -1,57 +1,17 @@ {-# LANGUAGE UndecidableInstances #-} module Facet.Surface.Expr -( -- * Expressions - Expr(..) -, Clause(..) - -- * Patterns -, Pattern(..) -, ValPattern(..) -, EffPattern(..) - -- * Definitions -, Def(..) +( -- * Definitions + Def(..) -- * Modules , Module(..) , Import(..) ) where -import Data.Text (Text) import Facet.Name +import Facet.Surface.Term.Expr import Facet.Surface.Type.Expr import Facet.Syntax --- Expressions - -data Expr - = Var QName - | Hole Name - | Lam [Clause] - | App (Ann Comment Expr) (Ann Comment Expr) - | As (Ann Comment Expr) (Ann Comment Type) - | String Text - deriving (Eq, Show) - - -data Clause = Clause (Ann Comment Pattern) (Ann Comment Expr) - deriving (Eq, Show) - - --- Patterns - -data Pattern - = PVal (Ann Comment ValPattern) - | PEff (Ann Comment EffPattern) - deriving (Eq, Show) - -data ValPattern - = PWildcard - | PVar Name - | PCon QName [Ann Comment ValPattern] - deriving (Eq, Show) - -data EffPattern = POp QName [Ann Comment ValPattern] (Ann Comment ValPattern) - deriving (Eq, Show) - - -- Declarations data Def diff --git a/src/Facet/Surface/Term/Expr.hs b/src/Facet/Surface/Term/Expr.hs index eaaddda82..ac524dbe8 100644 --- a/src/Facet/Surface/Term/Expr.hs +++ b/src/Facet/Surface/Term/Expr.hs @@ -1,2 +1,46 @@ module Facet.Surface.Term.Expr -() where +( -- * Expressions + Expr(..) +, Clause(..) + -- * Patterns +, Pattern(..) +, ValPattern(..) +, EffPattern(..) +) where + +import Data.Text (Text) +import Facet.Name +import Facet.Surface.Type.Expr +import Facet.Syntax + +-- Expressions + +data Expr + = Var QName + | Hole Name + | Lam [Clause] + | App (Ann Comment Expr) (Ann Comment Expr) + | As (Ann Comment Expr) (Ann Comment Type) + | String Text + deriving (Eq, Show) + + +data Clause = Clause (Ann Comment Pattern) (Ann Comment Expr) + deriving (Eq, Show) + + +-- Patterns + +data Pattern + = PVal (Ann Comment ValPattern) + | PEff (Ann Comment EffPattern) + deriving (Eq, Show) + +data ValPattern + = PWildcard + | PVar Name + | PCon QName [Ann Comment ValPattern] + deriving (Eq, Show) + +data EffPattern = POp QName [Ann Comment ValPattern] (Ann Comment ValPattern) + deriving (Eq, Show) From 3a81bebd44d41e82142c9f5fcc7d8707a02909d5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 18:46:26 -0400 Subject: [PATCH 0389/1324] Rename Facet.Surface.Expr to Facet.Surface.Module. --- facet.cabal | 2 +- src/Facet/Driver.hs | 2 +- src/Facet/Elab/Term.hs | 2 +- src/Facet/Parser.hs | 2 +- src/Facet/Surface/{Expr.hs => Module.hs} | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) rename src/Facet/Surface/{Expr.hs => Module.hs} (96%) diff --git a/facet.cabal b/facet.cabal index 5c60d91b3..32504bb09 100644 --- a/facet.cabal +++ b/facet.cabal @@ -121,7 +121,7 @@ library Facet.Style Facet.Subst Facet.Surface.Class - Facet.Surface.Expr + Facet.Surface.Module Facet.Surface.Term.Expr Facet.Surface.Type.Expr Facet.Syntax diff --git a/src/Facet/Driver.hs b/src/Facet/Driver.hs index ea997b453..a26fc1eef 100644 --- a/src/Facet/Driver.hs +++ b/src/Facet/Driver.hs @@ -48,7 +48,7 @@ import Facet.Print (Options) import Facet.Snoc import Facet.Source import Facet.Style -import qualified Facet.Surface.Expr as Import (Import(..)) +import qualified Facet.Surface.Module as Import (Import(..)) import Facet.Syntax as S import Fresnel.Getter ((^.)) import Fresnel.Lens (Lens, Lens', lens) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 7d24f2756..11dd529d2 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -69,7 +69,7 @@ import Facet.Snoc import Facet.Snoc.NonEmpty as NE import Facet.Source (Source) import Facet.Subst -import qualified Facet.Surface.Expr as S +import qualified Facet.Surface.Module as S import qualified Facet.Surface.Term.Expr as S import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index 0788e39a7..e4cf4e289 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -36,7 +36,7 @@ import qualified Facet.Name as N import Facet.Parser.Table as Op import Facet.Snoc import Facet.Span -import qualified Facet.Surface.Expr as S +import qualified Facet.Surface.Module as S import qualified Facet.Surface.Term.Expr as S import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S diff --git a/src/Facet/Surface/Expr.hs b/src/Facet/Surface/Module.hs similarity index 96% rename from src/Facet/Surface/Expr.hs rename to src/Facet/Surface/Module.hs index 98a5c8da5..e20e3d4f0 100644 --- a/src/Facet/Surface/Expr.hs +++ b/src/Facet/Surface/Module.hs @@ -1,5 +1,5 @@ {-# LANGUAGE UndecidableInstances #-} -module Facet.Surface.Expr +module Facet.Surface.Module ( -- * Definitions Def(..) -- * Modules From f95710f784b13e276b59d38845b8702260fdcce8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 18:47:27 -0400 Subject: [PATCH 0390/1324] Rename Facet.Surface.Class to Facet.Surface.Type.Class. --- facet.cabal | 2 +- src/Facet/Surface/Class.hs | 2 -- src/Facet/Surface/Type/Class.hs | 2 ++ 3 files changed, 3 insertions(+), 3 deletions(-) delete mode 100644 src/Facet/Surface/Class.hs create mode 100644 src/Facet/Surface/Type/Class.hs diff --git a/facet.cabal b/facet.cabal index 32504bb09..c2fb7bd3e 100644 --- a/facet.cabal +++ b/facet.cabal @@ -120,9 +120,9 @@ library Facet.Span Facet.Style Facet.Subst - Facet.Surface.Class Facet.Surface.Module Facet.Surface.Term.Expr + Facet.Surface.Type.Class Facet.Surface.Type.Expr Facet.Syntax Facet.Term.Class diff --git a/src/Facet/Surface/Class.hs b/src/Facet/Surface/Class.hs deleted file mode 100644 index c5485850e..000000000 --- a/src/Facet/Surface/Class.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Facet.Surface.Class -() where diff --git a/src/Facet/Surface/Type/Class.hs b/src/Facet/Surface/Type/Class.hs new file mode 100644 index 000000000..d16a4db20 --- /dev/null +++ b/src/Facet/Surface/Type/Class.hs @@ -0,0 +1,2 @@ +module Facet.Surface.Type.Class +() where From 1cbc96643b06ab39f3821f7e5a0f8c3a2f21e434 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 18:51:36 -0400 Subject: [PATCH 0391/1324] Give Surface.Interface a parameter for the type of types. --- src/Facet/Elab/Type.hs | 2 +- src/Facet/Parser.hs | 2 +- src/Facet/Surface/Type/Expr.hs | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 27bb68938..c9171851d 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -108,7 +108,7 @@ synthType (S.Ann s _ e) = pushSpan s $ case e of S.Zero -> zero S.One -> one -synthInterface :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Comment S.Interface -> Elab m (Interface TX.Type :==> Kind) +synthInterface :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Comment (S.Interface (S.Ann S.Comment S.Type)) -> Elab m (Interface TX.Type :==> Kind) synthInterface (S.Ann s _ (S.Interface (S.Ann sh _ h) sp)) = pushSpan s $ do -- FIXME: check that the application actually result in an Interface h' :==> _ <- pushSpan sh (ivar h) diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index e4cf4e289..e097c7b4c 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -200,7 +200,7 @@ tvar :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenPar tvar = anned (S.TVar <$> qname tname) -signature :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p [S.Ann S.Comment S.Interface] +signature :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p [S.Ann S.Comment (S.Interface (S.Ann S.Comment S.Type))] signature = brackets (commaSep delta) "signature" where delta = anned $ S.Interface <$> head <*> (fromList <$> many type') diff --git a/src/Facet/Surface/Type/Expr.hs b/src/Facet/Surface/Type/Expr.hs index cc97cd473..328ad235c 100644 --- a/src/Facet/Surface/Type/Expr.hs +++ b/src/Facet/Surface/Type/Expr.hs @@ -22,12 +22,12 @@ data Type | TString | TForAll Name (Ann Comment Kind) (Ann Comment Type) | TArrow (Maybe Name) (Maybe Mul) (Ann Comment Type) (Ann Comment Type) - | TComp [Ann Comment Interface] (Ann Comment Type) + | TComp [Ann Comment (Interface (Ann Comment Type))] (Ann Comment Type) | TApp (Ann Comment Type) (Ann Comment Type) deriving (Eq, Show) -data Interface = Interface (Ann Comment QName) (Snoc (Ann Comment Type)) +data Interface a = Interface (Ann Comment QName) (Snoc a) deriving (Eq, Show) From 5201434d99f508a84d0a147e86398ae4d1ae972c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 18:55:18 -0400 Subject: [PATCH 0392/1324] =?UTF-8?q?Don=E2=80=99t=20add=20an=20extra=20sp?= =?UTF-8?q?an=20around=20an=20interface=E2=80=99s=20QName.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Elab/Type.hs | 4 ++-- src/Facet/Parser.hs | 2 +- src/Facet/Surface/Type/Expr.hs | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index c9171851d..9b0426315 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -109,9 +109,9 @@ synthType (S.Ann s _ e) = pushSpan s $ case e of S.One -> one synthInterface :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Comment (S.Interface (S.Ann S.Comment S.Type)) -> Elab m (Interface TX.Type :==> Kind) -synthInterface (S.Ann s _ (S.Interface (S.Ann sh _ h) sp)) = pushSpan s $ do +synthInterface (S.Ann s _ (S.Interface h sp)) = pushSpan s $ do -- FIXME: check that the application actually result in an Interface - h' :==> _ <- pushSpan sh (ivar h) + h' :==> _ <- ivar h sp' <- foldl' (liftA2 (:>)) (pure Nil) (checkIsType . (::: KType) . synthType <$> sp) pure $ Interface h' sp' :==> KInterface diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index e097c7b4c..141176916 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -204,7 +204,7 @@ signature :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, Tok signature = brackets (commaSep delta) "signature" where delta = anned $ S.Interface <$> head <*> (fromList <$> many type') - head = fmap mkHead <$> token (anned (runUnspaced (sepByNonEmpty comp dot))) + head = mkHead <$> token (runUnspaced (sepByNonEmpty comp dot)) mkHead cs = fromList (NE.init cs) N.:. NE.last cs comp = ident tnameStyle diff --git a/src/Facet/Surface/Type/Expr.hs b/src/Facet/Surface/Type/Expr.hs index 328ad235c..07915cb05 100644 --- a/src/Facet/Surface/Type/Expr.hs +++ b/src/Facet/Surface/Type/Expr.hs @@ -27,7 +27,7 @@ data Type deriving (Eq, Show) -data Interface a = Interface (Ann Comment QName) (Snoc a) +data Interface a = Interface QName (Snoc a) deriving (Eq, Show) From 806378eac07a875199fb51a4062cccabe40961c7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 18:57:06 -0400 Subject: [PATCH 0393/1324] Define a class abstracting surface types using HOAS. --- src/Facet/Surface/Type/Class.hs | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/src/Facet/Surface/Type/Class.hs b/src/Facet/Surface/Type/Class.hs index d16a4db20..0c3dbabd8 100644 --- a/src/Facet/Surface/Type/Class.hs +++ b/src/Facet/Surface/Type/Class.hs @@ -1,2 +1,17 @@ module Facet.Surface.Type.Class -() where +( Type(..) +) where + +import Facet.Name +import Facet.Surface.Type.Expr (Interface, Kind, Mul) + +-- FIXME: interface for annotating types/terms +class Type r where + var :: QName -> r + string :: r + -- FIXME: how do we annotate the kind? + forAll :: Name -> Kind -> (r -> r) -> r + arrow :: Maybe Name -> Maybe Mul -> r -> r -> r + -- FIXME: how do we annotate the interface? + comp :: [Interface r] -> r -> r + tapp :: r -> r -> r From 7fa578a175fcf84090cd50387ea522c571f686ea Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 18:59:45 -0400 Subject: [PATCH 0394/1324] Abstract kinds. --- src/Facet/Surface/Type/Class.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/Facet/Surface/Type/Class.hs b/src/Facet/Surface/Type/Class.hs index 0c3dbabd8..4e8d99575 100644 --- a/src/Facet/Surface/Type/Class.hs +++ b/src/Facet/Surface/Type/Class.hs @@ -1,16 +1,21 @@ module Facet.Surface.Type.Class -( Type(..) +( Kind(..) +, Type(..) ) where import Facet.Name -import Facet.Surface.Type.Expr (Interface, Kind, Mul) +import Facet.Surface.Type.Expr (Interface, Mul) + +class Kind r where + ktype :: r + kinterface :: r + karrow :: Maybe Name -> r -> r -> r -- FIXME: interface for annotating types/terms class Type r where var :: QName -> r string :: r - -- FIXME: how do we annotate the kind? - forAll :: Name -> Kind -> (r -> r) -> r + forAll :: Name -> r -> (r -> r) -> r arrow :: Maybe Name -> Maybe Mul -> r -> r -> r -- FIXME: how do we annotate the interface? comp :: [Interface r] -> r -> r From 8d1c527b7699ffe5cd7b274fdae62edb68219aed Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 19:00:50 -0400 Subject: [PATCH 0395/1324] Define a class abstracting interfaces. --- src/Facet/Surface/Type/Class.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Facet/Surface/Type/Class.hs b/src/Facet/Surface/Type/Class.hs index 4e8d99575..68e880d15 100644 --- a/src/Facet/Surface/Type/Class.hs +++ b/src/Facet/Surface/Type/Class.hs @@ -1,10 +1,12 @@ module Facet.Surface.Type.Class ( Kind(..) , Type(..) +, Interface(..) ) where import Facet.Name -import Facet.Surface.Type.Expr (Interface, Mul) +import Facet.Snoc +import Facet.Surface.Type.Expr (Mul) class Kind r where ktype :: r @@ -17,6 +19,8 @@ class Type r where string :: r forAll :: Name -> r -> (r -> r) -> r arrow :: Maybe Name -> Maybe Mul -> r -> r -> r - -- FIXME: how do we annotate the interface? - comp :: [Interface r] -> r -> r + comp :: [r] -> r -> r tapp :: r -> r -> r + +class Interface r where + interface :: QName -> Snoc r -> r From 761adb3af76183b95de621339bad2ea7b29d8aed Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 19:20:17 -0400 Subject: [PATCH 0396/1324] Add parameters for recursive positions. --- src/Facet/Surface/Type/Class.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Facet/Surface/Type/Class.hs b/src/Facet/Surface/Type/Class.hs index 68e880d15..e54bec13c 100644 --- a/src/Facet/Surface/Type/Class.hs +++ b/src/Facet/Surface/Type/Class.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FunctionalDependencies #-} module Facet.Surface.Type.Class ( Kind(..) , Type(..) @@ -8,19 +9,18 @@ import Facet.Name import Facet.Snoc import Facet.Surface.Type.Expr (Mul) -class Kind r where +class Kind f r | r -> f where ktype :: r kinterface :: r - karrow :: Maybe Name -> r -> r -> r + karrow :: Maybe Name -> f r -> f r -> r --- FIXME: interface for annotating types/terms -class Type r where +class Type f r | r -> f where var :: QName -> r string :: r - forAll :: Name -> r -> (r -> r) -> r - arrow :: Maybe Name -> Maybe Mul -> r -> r -> r - comp :: [r] -> r -> r - tapp :: r -> r -> r + forAll :: Name -> f r -> (f r -> f r) -> r + arrow :: Maybe Name -> Maybe Mul -> f r -> f r -> r + comp :: [f r] -> f r -> r + tapp :: f r -> f r -> r -class Interface r where - interface :: QName -> Snoc r -> r +class Interface f r | r -> f where + interface :: QName -> Snoc (f r) -> r From 9290eeb28a07a1de6cffcef8873ddff2853c69ef Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 21:14:11 -0400 Subject: [PATCH 0397/1324] Revert "Add parameters for recursive positions." This reverts commit 761adb3af76183b95de621339bad2ea7b29d8aed. --- src/Facet/Surface/Type/Class.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Facet/Surface/Type/Class.hs b/src/Facet/Surface/Type/Class.hs index e54bec13c..68e880d15 100644 --- a/src/Facet/Surface/Type/Class.hs +++ b/src/Facet/Surface/Type/Class.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FunctionalDependencies #-} module Facet.Surface.Type.Class ( Kind(..) , Type(..) @@ -9,18 +8,19 @@ import Facet.Name import Facet.Snoc import Facet.Surface.Type.Expr (Mul) -class Kind f r | r -> f where +class Kind r where ktype :: r kinterface :: r - karrow :: Maybe Name -> f r -> f r -> r + karrow :: Maybe Name -> r -> r -> r -class Type f r | r -> f where +-- FIXME: interface for annotating types/terms +class Type r where var :: QName -> r string :: r - forAll :: Name -> f r -> (f r -> f r) -> r - arrow :: Maybe Name -> Maybe Mul -> f r -> f r -> r - comp :: [f r] -> f r -> r - tapp :: f r -> f r -> r + forAll :: Name -> r -> (r -> r) -> r + arrow :: Maybe Name -> Maybe Mul -> r -> r -> r + comp :: [r] -> r -> r + tapp :: r -> r -> r -class Interface f r | r -> f where - interface :: QName -> Snoc (f r) -> r +class Interface r where + interface :: QName -> Snoc r -> r From dc3f1cc66c49fe02714a1934a350b817b4ca9616 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 21:24:28 -0400 Subject: [PATCH 0398/1324] Simplify kind arrows. --- src/Facet/Parser.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index 141176916..60094d4bb 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -117,10 +117,10 @@ body = fmap (either S.out id) <$> anned (braces (Right . S.Lam <$> sepBy1 clause dataDecl :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name, S.Ann S.Comment S.Def)) -dataDecl = anned $ (,) <$ reserve dnameStyle "data" <*> tname <* colon <*> anned (kindSig tname <**> (S.DataDef <$> braces (commaSep con))) +dataDecl = anned $ (,) <$ reserve dnameStyle "data" <*> tname <* colon <*> anned (kindSig <**> (S.DataDef <$> braces (commaSep con))) interfaceDecl :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name, S.Ann S.Comment S.Def)) -interfaceDecl = anned $ (,) <$ reserve dnameStyle "interface" <*> tname <* colon <*> anned (kindSig tname <**> (S.InterfaceDef <$> braces (commaSep con))) +interfaceDecl = anned $ (,) <$ reserve dnameStyle "interface" <*> tname <* colon <*> anned (kindSig <**> (S.InterfaceDef <$> braces (commaSep con))) con :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name ::: S.Ann S.Comment S.Type)) con = anned ((:::) <$> dename <* colon <*> rec) @@ -130,9 +130,8 @@ con = anned ((:::) <$> dename <* colon <*> rec) kindSig :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) - => p N.Name -- ^ a parser for names occurring in explicit (parenthesized) bindings - -> p (S.Ann S.Comment S.Kind) -kindSig name = choice [ kindArrow name (kindSig name), kind ] + => p (S.Ann S.Comment S.Kind) +kindSig = choice [ kindArrow kindSig, kind ] typeSig :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) @@ -149,8 +148,8 @@ kind = choice , token (anned (S.KInterface <$ string "Interface")) ] -kindArrow :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p N.Name -> p (S.Ann S.Comment S.Kind) -> p (S.Ann S.Comment S.Kind) -kindArrow name k = anned (try (S.KArrow . Just <$ lparen <*> (name <|> N.__ <$ wildcard) <* colon) <*> kind <* rparen <* arrow <*> k) +kindArrow :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Kind) -> p (S.Ann S.Comment S.Kind) +kindArrow k = anned (try (S.KArrow . Just <$ lparen <*> (tname <|> N.__ <$ wildcard) <* colon) <*> kind <* rparen <* arrow <*> k) -- FIXME: kind ascriptions From 7ce298343cecc6343d2242281213b6d0fa0386e3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 21:26:26 -0400 Subject: [PATCH 0399/1324] Factor out the type of accrued comments. --- src/Facet/Parser.hs | 72 +++++++++++++++++++++++---------------------- 1 file changed, 37 insertions(+), 35 deletions(-) diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index 60094d4bb..e84a9b68e 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -66,23 +66,23 @@ makeOperator (name, op, assoc) = (op, assoc, nary (N.toQ (name N.:.: N.O op))) -- Modules -module' :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Module) +module' :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Module) module' = anned $ do (name, imports) <- moduleHeader decls <- C.runReader name (runReaderC (many decl)) ops <- get @[Operator (S.Ann S.Comment S.Expr)] pure $ S.Module name imports (map (\ (op, assoc, _) -> (op, assoc)) ops) decls -moduleHeader :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (N.MName, [S.Ann S.Comment S.Import]) +moduleHeader :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (N.MName, [S.Ann S.Comment S.Import]) moduleHeader = (,) <$ reserve dnameStyle "module" <*> mname <* colon <* symbol "Module" <*> many import' -- Declarations -import' :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Import) +import' :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Import) import' = anned $ S.Import <$ reserve dnameStyle "import" <*> mname -decl :: (Has Parser sig p, Has (Reader N.MName) sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name, S.Ann S.Comment S.Def)) +decl :: (Has Parser sig p, Has (Reader N.MName) sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name, S.Ann S.Comment S.Def)) decl = choice [ termDecl , dataDecl @@ -92,7 +92,7 @@ decl = choice -- FIXME: operators aren’t available until after their declarations have been parsed. -- FIXME: parse operator declarations in datatypes. -- FIXME: parse operator declarations in interfaces. -termDecl :: (Has Parser sig p, Has (Reader N.MName) sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name, S.Ann S.Comment S.Def)) +termDecl :: (Has Parser sig p, Has (Reader N.MName) sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name, S.Ann S.Comment S.Def)) termDecl = anned $ do name <- dename case name of @@ -111,30 +111,30 @@ termDecl = anned $ do decl <- anned $ colon *> typeSig ename <**> (S.TermDef <$> body) pure (name, decl) -body :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) +body :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) -- NB: We parse sepBy1 and the empty case separately so that it doesn’t succeed at matching 0 clauses and then expect a closing brace when it sees a nullary computation body = fmap (either S.out id) <$> anned (braces (Right . S.Lam <$> sepBy1 clause comma <|> Left <$> expr <|> pure (Right (S.Lam [])))) -dataDecl :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name, S.Ann S.Comment S.Def)) +dataDecl :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name, S.Ann S.Comment S.Def)) dataDecl = anned $ (,) <$ reserve dnameStyle "data" <*> tname <* colon <*> anned (kindSig <**> (S.DataDef <$> braces (commaSep con))) -interfaceDecl :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name, S.Ann S.Comment S.Def)) +interfaceDecl :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name, S.Ann S.Comment S.Def)) interfaceDecl = anned $ (,) <$ reserve dnameStyle "interface" <*> tname <* colon <*> anned (kindSig <**> (S.InterfaceDef <$> braces (commaSep con))) -con :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name ::: S.Ann S.Comment S.Type)) +con :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name ::: S.Ann S.Comment S.Type)) con = anned ((:::) <$> dename <* colon <*> rec) where rec = choice [ forAll rec, type' ] kindSig - :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) + :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Kind) kindSig = choice [ kindArrow kindSig, kind ] typeSig - :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) + :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p N.Name -- ^ a parser for names occurring in explicit (parenthesized) bindings -> p (S.Ann S.Comment S.Type) typeSig name = choice [ forAll (typeSig name), bindArrow name (typeSig name), type' ] @@ -142,18 +142,18 @@ typeSig name = choice [ forAll (typeSig name), bindArrow name (typeSig name), ty -- Types -kind :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Kind) +kind :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Kind) kind = choice [ token (anned (S.KType <$ string "Type")) , token (anned (S.KInterface <$ string "Interface")) ] -kindArrow :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Kind) -> p (S.Ann S.Comment S.Kind) +kindArrow :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Kind) -> p (S.Ann S.Comment S.Kind) kindArrow k = anned (try (S.KArrow . Just <$ lparen <*> (tname <|> N.__ <$ wildcard) <* colon) <*> kind <* rparen <* arrow <*> k) -- FIXME: kind ascriptions -monotypeTable :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => Table p (S.Ann S.Comment S.Type) +monotypeTable :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => Table p (S.Ann S.Comment S.Type) monotypeTable = [ [ functionType ] , [ retType ] @@ -166,40 +166,40 @@ monotypeTable = ] -type' :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) +type' :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) type' = monotype -forAll :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) +forAll :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) forAll k = make <$> anned (try (((,,) <$ lbrace <*> commaSep1 ((,) <$> position <*> tname) <* colon) <*> kind <* rbrace <* arrow) <*> k) where make (S.Ann s cs (ns, t, b)) = S.Ann s cs (S.out (foldr (\ (p, n) b -> S.Ann (Span p (end s)) Nil (S.TForAll n t b)) b ns)) -bindArrow :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p N.Name -> p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) +bindArrow :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p N.Name -> p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) bindArrow name k = anned (try (S.TArrow . Just <$ lparen <*> (name <|> N.__ <$ wildcard) <* colon) <*> optional mul <*> type' <* rparen <* arrow <*> k) -functionType :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) +functionType :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) functionType self next = anned (try (S.TArrow Nothing <$> optional mul <*> next <* arrow) <*> self) <|> next mul :: TokenParsing p => p S.Mul mul = choice [ S.Zero <$ token (char '0'), S.One <$ token (char '1') ] -retType :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) +retType :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) retType _ next = mk <$> anned ((,) <$> optional signature <*> next) where mk (S.Ann s c (sig, _T)) = maybe id (\ sig -> S.Ann s c . S.TComp sig) sig _T -- FIXME: support type operators -monotype :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) +monotype :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) monotype = build monotypeTable $ parens type' -tvar :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) +tvar :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) tvar = anned (S.TVar <$> qname tname) -signature :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p [S.Ann S.Comment (S.Interface (S.Ann S.Comment S.Type))] +signature :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p [S.Ann S.Comment (S.Interface (S.Ann S.Comment S.Type))] signature = brackets (commaSep delta) "signature" where delta = anned $ S.Interface <$> head <*> (fromList <$> many type') @@ -210,7 +210,7 @@ signature = brackets (commaSep delta) "signature" -- Expressions -exprTable :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => Table p (S.Ann S.Comment S.Expr) +exprTable :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => Table p (S.Ann S.Comment S.Expr) exprTable = -- FIXME: parse this as a unary operator or something -- FIXME: better yet, generalize operators to allow different syntactic types on either side (following the associativity) @@ -219,23 +219,23 @@ exprTable = , [ atom thunk, atom hole, atom evar, atom (token (anned (runUnspaced (S.String <$> stringLiteral)))) ] ] -expr :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) +expr :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) expr = do ops <- get let rec = build (map parseOperator ops:exprTable) $ parens rec rec -ascription :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) -> p (S.Ann S.Comment S.Expr) -> p (S.Ann S.Comment S.Expr) +ascription :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) -> p (S.Ann S.Comment S.Expr) -> p (S.Ann S.Comment S.Expr) ascription _self next = anned (S.As <$> try (next <* colon) <*> type') <|> next -thunk :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) +thunk :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) -- NB: We parse sepBy1 and the empty case separately so that it doesn’t succeed at matching 0 clauses and then expect a closing brace when it sees a nullary computation thunk = anned (braces (S.Lam <$> sepBy1 clause comma <|> {-S.Thunk <$> expr <|>-} pure (S.Lam []))) -clause :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p S.Clause +clause :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p S.Clause clause = S.Clause <$> try (compPattern <* arrow) <*> expr "clause" -evar :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) +evar :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) evar = choice [ token (anned (runUnspaced (S.Var <$> try ((N.:.) . fromList <$> many (comp <* dot) <*> ename)))) -- FIXME: would be better to commit once we see a placeholder, but try doesn’t really let us express that @@ -244,7 +244,7 @@ evar = choice where comp = ident tnameStyle -hole :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) +hole :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) hole = token (anned (runUnspaced (S.Hole <$> ident hnameStyle))) where hnameStyle = IdentifierStyle "hole name" (char '?') nameChar reserved Identifier ReservedIdentifier @@ -255,14 +255,14 @@ hole = token (anned (runUnspaced (S.Hole <$> ident hnameStyle))) wildcard :: (Monad p, TokenParsing p) => p () wildcard = reserve enameStyle "_" -valuePattern :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.ValPattern) +valuePattern :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.ValPattern) valuePattern = choice [ token (anned (runUnspaced (S.PVar <$> ename "variable"))) , anned (S.PWildcard <$ wildcard) , try (parens (anned (S.PCon <$> qname ename <*> many valuePattern))) ] "pattern" -compPattern :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p, TokenParsing p) => p (S.Ann S.Comment S.Pattern) +compPattern :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Pattern) compPattern = choice [ anned (S.PVal <$> valuePattern) , anned (S.PEff <$> try (brackets (anned (S.POp <$> qname ename <*> many valuePattern <* symbolic ';' <*> valuePattern)))) @@ -352,8 +352,8 @@ rbrace :: TokenParsing p => p Char rbrace = symbolic '}' -anned :: (Has Parser sig p, Has (Writer (Snoc (Span, S.Comment))) sig p) => p a -> p (S.Ann S.Comment a) -anned p = mk <$> censor @(Snoc (Span, S.Comment)) (const Nil) (listen @(Snoc (Span, S.Comment)) ((,,) <$> position <*> p <*> position)) +anned :: (Has Parser sig p, Has (Writer Comments) sig p) => p a -> p (S.Ann S.Comment a) +anned p = mk <$> censor @Comments (const Nil) (listen @Comments ((,,) <$> position <*> p <*> position)) where mk (cs, (s, a, e)) = S.Ann (Span s e) cs a @@ -363,8 +363,10 @@ anned p = mk <$> censor @(Snoc (Span, S.Comment)) (const Nil) (listen @(Snoc (Sp runFacet :: Functor m => [Operator (S.Ann S.Comment S.Expr)] -> Facet m a -> m a runFacet ops (Facet m) = snd <$> C.runWriter (runWriterC (C.evalState ops (runStateC m))) -newtype Facet m a = Facet (StateC [Operator (S.Ann S.Comment S.Expr)] (WriterC (Snoc (Span, S.Comment)) m) a) - deriving (Algebra (State [Operator (S.Ann S.Comment S.Expr)] :+: Writer (Snoc (Span, S.Comment)) :+: sig), Alternative, Applicative, Functor, Monad, MonadFail, MonadFix) +type Comments = Snoc (Span, S.Comment) + +newtype Facet m a = Facet (StateC [Operator (S.Ann S.Comment S.Expr)] (WriterC Comments m) a) + deriving (Algebra (State [Operator (S.Ann S.Comment S.Expr)] :+: Writer Comments :+: sig), Alternative, Applicative, Functor, Monad, MonadFail, MonadFix) instance (Monad p, Parsing p) => Parsing (Facet p) where try (Facet m) = Facet $ try m From e608b4c0b809c7d9ede82ced2b56fde01c75fc37 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 21:41:31 -0400 Subject: [PATCH 0400/1324] Use a single definition of Kind. --- src/Facet/Elab/Term.hs | 6 ++---- src/Facet/Elab/Type.hs | 25 ++++--------------------- src/Facet/Parser.hs | 13 +++++++------ src/Facet/Surface/Module.hs | 5 +++-- src/Facet/Surface/Type/Expr.hs | 12 +++--------- 5 files changed, 19 insertions(+), 42 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 11dd529d2..318a2232c 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -332,14 +332,12 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os -- elaborate all the types first es <- for ds $ \ (S.Ann _ _ (dname, S.Ann _ _ def)) -> case def of - S.DataDef cs tele -> Nothing <$ do - _K <- runModule $ elabKind $ checkIsType (synthKind tele ::: KType) + S.DataDef cs _K -> Nothing <$ do scope_.decls_.at dname .= Just (DData mempty _K) decls <- runModule $ elabDataDef (dname ::: _K) cs for_ decls $ \ (dname :=: decl) -> scope_.decls_.at dname .= Just decl - S.InterfaceDef os tele -> Nothing <$ do - _K <- runModule $ elabKind $ checkIsType (synthKind tele ::: KType) + S.InterfaceDef os _K -> Nothing <$ do scope_.decls_.at dname .= Just (DInterface mempty _K) decls <- runModule $ elabInterfaceDef (dname ::: _K) os for_ decls $ \ (dname :=: decl) -> scope_.decls_.at dname .= Just decl diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 9b0426315..83f8a838c 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -2,11 +2,8 @@ module Facet.Elab.Type ( -- * Types tvar -, _Type -, _Interface , _String , forAll -, synthKind , synthType -- * Judgements , checkIsType @@ -48,21 +45,14 @@ ivar n = resolveQ n >>= \case _ -> freeVariable n -_Type :: Elab m (Kind :==> Kind) -_Type = pure $ KType :==> KType - -_Interface :: Elab m (Kind :==> Kind) -_Interface = pure $ KInterface :==> KType - _String :: Elab m (TX.Type :==> Kind) _String = pure $ TX.String :==> KType -forAll :: (HasCallStack, Has (Throw Err) sig m) => Name ::: Elab m (Kind :==> Kind) -> Elab m (TX.Type :==> Kind) -> Elab m (TX.Type :==> Kind) +forAll :: (HasCallStack, Has (Throw Err) sig m) => Name ::: Kind -> Elab m (TX.Type :==> Kind) -> Elab m (TX.Type :==> Kind) forAll (n ::: t) b = do - t' <- checkIsType (t ::: KType) - b' <- (zero, PVar (n ::: CK t')) |- checkIsType (b ::: KType) - pure $ TX.ForAll n t' b' :==> KType + b' <- (zero, PVar (n ::: CK t)) |- checkIsType (b ::: KType) + pure $ TX.ForAll n t b' :==> KType arrow :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> Elab m (a :==> Kind) -> Elab m (b :==> Kind) -> Elab m (c :==> Kind) arrow mk a b = do @@ -88,18 +78,11 @@ comp s t = do pure $ TX.Comp (fromInterfaces s') t' :==> KType -synthKind :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Comment S.Kind -> Elab m (Kind :==> Kind) -synthKind (S.Ann s _ e) = pushSpan s $ case e of - S.KArrow n a b -> arrow (KArrow n) (synthKind a) (synthKind b) - S.KType -> _Type - S.KInterface -> _Interface - - synthType :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Comment S.Type -> Elab m (TX.Type :==> Kind) synthType (S.Ann s _ e) = pushSpan s $ case e of S.TVar n -> tvar n S.TString -> _String - S.TForAll n t b -> forAll (n ::: synthKind t) (synthType b) + S.TForAll n t b -> forAll (n ::: t) (synthType b) S.TArrow n q a b -> arrow (TX.Arrow n (maybe Many interpretMul q)) (synthType a) (synthType b) S.TComp s t -> comp (map synthInterface s) (synthType t) S.TApp f a -> app TX.App (synthType f) (synthType a) diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index e84a9b68e..f97566c17 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -32,6 +32,7 @@ import qualified Data.HashSet as HashSet import qualified Data.List.NonEmpty as NE import Data.Text (pack) import Facet.Effect.Parser +import Facet.Kind import qualified Facet.Name as N import Facet.Parser.Table as Op import Facet.Snoc @@ -130,7 +131,7 @@ con = anned ((:::) <$> dename <* colon <*> rec) kindSig :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) - => p (S.Ann S.Comment S.Kind) + => p Kind kindSig = choice [ kindArrow kindSig, kind ] typeSig @@ -142,14 +143,14 @@ typeSig name = choice [ forAll (typeSig name), bindArrow name (typeSig name), ty -- Types -kind :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Kind) +kind :: (Has Parser sig p, TokenParsing p) => p Kind kind = choice - [ token (anned (S.KType <$ string "Type")) - , token (anned (S.KInterface <$ string "Interface")) + [ token (KType <$ string "Type") + , token (KInterface <$ string "Interface") ] -kindArrow :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Kind) -> p (S.Ann S.Comment S.Kind) -kindArrow k = anned (try (S.KArrow . Just <$ lparen <*> (tname <|> N.__ <$ wildcard) <* colon) <*> kind <* rparen <* arrow <*> k) +kindArrow :: (Has Parser sig p, TokenParsing p) => p Kind -> p Kind +kindArrow k = try (KArrow . Just <$ lparen <*> (tname <|> N.__ <$ wildcard) <* colon) <*> kind <* rparen <* arrow <*> k -- FIXME: kind ascriptions diff --git a/src/Facet/Surface/Module.hs b/src/Facet/Surface/Module.hs index e20e3d4f0..5ab4183f7 100644 --- a/src/Facet/Surface/Module.hs +++ b/src/Facet/Surface/Module.hs @@ -7,6 +7,7 @@ module Facet.Surface.Module , Import(..) ) where +import Facet.Kind import Facet.Name import Facet.Surface.Term.Expr import Facet.Surface.Type.Expr @@ -15,8 +16,8 @@ import Facet.Syntax -- Declarations data Def - = DataDef [Ann Comment (Name ::: Ann Comment Type)] (Ann Comment Kind) - | InterfaceDef [Ann Comment (Name ::: Ann Comment Type)] (Ann Comment Kind) + = DataDef [Ann Comment (Name ::: Ann Comment Type)] Kind + | InterfaceDef [Ann Comment (Name ::: Ann Comment Type)] Kind | TermDef (Ann Comment Expr) (Ann Comment Type) deriving (Eq, Show) diff --git a/src/Facet/Surface/Type/Expr.hs b/src/Facet/Surface/Type/Expr.hs index 07915cb05..2a1cadecc 100644 --- a/src/Facet/Surface/Type/Expr.hs +++ b/src/Facet/Surface/Type/Expr.hs @@ -1,26 +1,20 @@ module Facet.Surface.Type.Expr -( Kind(..) -, Type(..) +( Type(..) , Interface(..) , Mul(..) ) where +import Facet.Kind import Facet.Name import Facet.Snoc import Facet.Syntax -- Types -data Kind - = KType - | KInterface - | KArrow (Maybe Name) (Ann Comment Kind) (Ann Comment Kind) - deriving (Eq, Show) - data Type = TVar QName | TString - | TForAll Name (Ann Comment Kind) (Ann Comment Type) + | TForAll Name Kind (Ann Comment Type) | TArrow (Maybe Name) (Maybe Mul) (Ann Comment Type) (Ann Comment Type) | TComp [Ann Comment (Interface (Ann Comment Type))] (Ann Comment Type) | TApp (Ann Comment Type) (Ann Comment Type) From 374dad6d5c6af143147a700b5024a081efb2c377 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 21:42:03 -0400 Subject: [PATCH 0401/1324] =?UTF-8?q?Don=E2=80=99t=20abstract=20Kind.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Surface/Type/Class.hs | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/src/Facet/Surface/Type/Class.hs b/src/Facet/Surface/Type/Class.hs index 68e880d15..dcc879da7 100644 --- a/src/Facet/Surface/Type/Class.hs +++ b/src/Facet/Surface/Type/Class.hs @@ -1,23 +1,18 @@ module Facet.Surface.Type.Class -( Kind(..) -, Type(..) +( Type(..) , Interface(..) ) where +import Facet.Kind import Facet.Name import Facet.Snoc import Facet.Surface.Type.Expr (Mul) -class Kind r where - ktype :: r - kinterface :: r - karrow :: Maybe Name -> r -> r -> r - -- FIXME: interface for annotating types/terms class Type r where var :: QName -> r string :: r - forAll :: Name -> r -> (r -> r) -> r + forAll :: Name -> Kind -> (r -> r) -> r arrow :: Maybe Name -> Maybe Mul -> r -> r -> r comp :: [r] -> r -> r tapp :: r -> r -> r From 902d3423c95477f4961b56b3ee0673fa412c4582 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 26 Aug 2021 21:56:29 -0400 Subject: [PATCH 0402/1324] Define an Applicative lifting of forAll. --- src/Facet/Surface/Type/Class.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Surface/Type/Class.hs b/src/Facet/Surface/Type/Class.hs index dcc879da7..d84659eec 100644 --- a/src/Facet/Surface/Type/Class.hs +++ b/src/Facet/Surface/Type/Class.hs @@ -1,12 +1,15 @@ module Facet.Surface.Type.Class ( Type(..) +, forAllA , Interface(..) ) where +import Facet.Functor.Compose import Facet.Kind import Facet.Name import Facet.Snoc import Facet.Surface.Type.Expr (Mul) +import Facet.Syntax (type (~>)) -- FIXME: interface for annotating types/terms class Type r where @@ -17,5 +20,8 @@ class Type r where comp :: [r] -> r -> r tapp :: r -> r -> r +forAllA :: (Applicative m, Applicative i, Type r) => Name -> Kind -> (forall j . Applicative j => (i ~> j) -> j r -> m (j r)) -> m (i r) +forAllA n k b = fmap (forAll n k) . runC <$> b liftCOuter (liftCInner id) + class Interface r where interface :: QName -> Snoc r -> r From 012232734c81b3e40c968327227297e2e3b12068 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 27 Aug 2021 09:29:04 -0400 Subject: [PATCH 0403/1324] Take the name and kind in the effectful context. --- src/Facet/Surface/Type/Class.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Surface/Type/Class.hs b/src/Facet/Surface/Type/Class.hs index d84659eec..d6d5c940f 100644 --- a/src/Facet/Surface/Type/Class.hs +++ b/src/Facet/Surface/Type/Class.hs @@ -20,8 +20,8 @@ class Type r where comp :: [r] -> r -> r tapp :: r -> r -> r -forAllA :: (Applicative m, Applicative i, Type r) => Name -> Kind -> (forall j . Applicative j => (i ~> j) -> j r -> m (j r)) -> m (i r) -forAllA n k b = fmap (forAll n k) . runC <$> b liftCOuter (liftCInner id) +forAllA :: (Applicative m, Applicative i, Type r) => m Name -> m Kind -> (forall j . Applicative j => (i ~> j) -> j r -> m (j r)) -> m (i r) +forAllA n k b = fmap fmap . forAll <$> n <*> k <*> (runC <$> b liftCOuter (liftCInner id)) class Interface r where interface :: QName -> Snoc r -> r From cb5d8970188030d5eb10dd73e110844dc4563a12 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 27 Aug 2021 09:31:52 -0400 Subject: [PATCH 0404/1324] Map over the inner functor of a composition. --- src/Facet/Functor/Compose.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index d5b1e111d..fa9c815c8 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -3,9 +3,12 @@ module Facet.Functor.Compose type (.)(..) -- * Introduction , liftCInner +, mapCInner , liftCOuter ) where +import Facet.Syntax (type (~>)) + -- Composition functor newtype (i . j) a = C { runC :: i (j a) } @@ -19,5 +22,8 @@ instance (Applicative i, Applicative j) => Applicative (i . j) where liftCInner :: Applicative i => j a -> (i . j) a liftCInner = C . pure +mapCInner :: Functor i => (j ~> j') -> ((i . j) ~> (i . j')) +mapCInner f = C . fmap f . runC + liftCOuter :: (Functor i, Applicative j) => i a -> (i . j) a liftCOuter = C . fmap pure From 21b7b1e87d5f03d473c737743b8abe5cd5705505 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 27 Aug 2021 09:32:38 -0400 Subject: [PATCH 0405/1324] Map over the outer functor of a composition. --- src/Facet/Functor/Compose.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index fa9c815c8..89affbb34 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -5,6 +5,7 @@ module Facet.Functor.Compose , liftCInner , mapCInner , liftCOuter +, mapCOuter ) where import Facet.Syntax (type (~>)) @@ -27,3 +28,6 @@ mapCInner f = C . fmap f . runC liftCOuter :: (Functor i, Applicative j) => i a -> (i . j) a liftCOuter = C . fmap pure + +mapCOuter :: (i ~> i') -> ((i . j) ~> (i' . j)) +mapCOuter f = C . f . runC From 4aed9b7e33e42ac6f475acd30a4df4883e9ed444 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 27 Aug 2021 09:35:54 -0400 Subject: [PATCH 0406/1324] Generalize mapCinner. --- src/Facet/Functor/Compose.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index 89affbb34..7c4f6c08c 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -23,7 +23,7 @@ instance (Applicative i, Applicative j) => Applicative (i . j) where liftCInner :: Applicative i => j a -> (i . j) a liftCInner = C . pure -mapCInner :: Functor i => (j ~> j') -> ((i . j) ~> (i . j')) +mapCInner :: Functor i => (j a -> j' b) -> ((i . j) a -> (i . j') b) mapCInner f = C . fmap f . runC liftCOuter :: (Functor i, Applicative j) => i a -> (i . j) a From f2b7682ed2adb2ee6023706ee9835912ead99e07 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 27 Aug 2021 09:36:30 -0400 Subject: [PATCH 0407/1324] Generalize mapCOuter. --- src/Facet/Functor/Compose.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index 7c4f6c08c..dc48cda2a 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -8,8 +8,6 @@ module Facet.Functor.Compose , mapCOuter ) where -import Facet.Syntax (type (~>)) - -- Composition functor newtype (i . j) a = C { runC :: i (j a) } @@ -29,5 +27,5 @@ mapCInner f = C . fmap f . runC liftCOuter :: (Functor i, Applicative j) => i a -> (i . j) a liftCOuter = C . fmap pure -mapCOuter :: (i ~> i') -> ((i . j) ~> (i' . j)) +mapCOuter :: (i (j a) -> i' (j' b)) -> ((i . j) a -> (i' . j') b) mapCOuter f = C . f . runC From 61c263f3a74ed4e0eaa6d0a04386bcf81cccf8b5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 27 Aug 2021 09:37:13 -0400 Subject: [PATCH 0408/1324] Compose the effect context with the environment. --- src/Facet/Surface/Type/Class.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Surface/Type/Class.hs b/src/Facet/Surface/Type/Class.hs index d6d5c940f..a13307b39 100644 --- a/src/Facet/Surface/Type/Class.hs +++ b/src/Facet/Surface/Type/Class.hs @@ -20,8 +20,8 @@ class Type r where comp :: [r] -> r -> r tapp :: r -> r -> r -forAllA :: (Applicative m, Applicative i, Type r) => m Name -> m Kind -> (forall j . Applicative j => (i ~> j) -> j r -> m (j r)) -> m (i r) -forAllA n k b = fmap fmap . forAll <$> n <*> k <*> (runC <$> b liftCOuter (liftCInner id)) +forAllA :: (Applicative m, Applicative i, Type r) => (m . i) Name -> (m . i) Kind -> (forall j . Applicative j => (i ~> j) -> j r -> (m . j) r) -> (m . i) r +forAllA n k b = forAll <$> n <*> k <*> mapCInner runC (b liftCOuter (liftCInner id)) class Interface r where interface :: QName -> Snoc r -> r From a89791d002418c611e5e5b3800564fb428277f94 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 27 Aug 2021 09:40:28 -0400 Subject: [PATCH 0409/1324] Define an Alternative instance for compositions. --- src/Facet/Functor/Compose.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index dc48cda2a..6a087fdb8 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -8,6 +8,8 @@ module Facet.Functor.Compose , mapCOuter ) where +import Control.Applicative (Alternative(..)) + -- Composition functor newtype (i . j) a = C { runC :: i (j a) } @@ -17,6 +19,10 @@ instance (Applicative i, Applicative j) => Applicative (i . j) where pure = C . pure . pure C f <*> C a = C ((<*>) <$> f <*> a) +instance (Alternative i, Applicative j) => Alternative (i . j) where + empty = liftCOuter empty + C l <|> C r = C (l <|> r) + liftCInner :: Applicative i => j a -> (i . j) a liftCInner = C . pure From 344e2f872fed8b6ead120283e289614fd6cff1e9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 27 Aug 2021 09:58:27 -0400 Subject: [PATCH 0410/1324] Revert "Compose the effect context with the environment." This reverts commit 61c263f3a74ed4e0eaa6d0a04386bcf81cccf8b5. --- src/Facet/Surface/Type/Class.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Surface/Type/Class.hs b/src/Facet/Surface/Type/Class.hs index a13307b39..d6d5c940f 100644 --- a/src/Facet/Surface/Type/Class.hs +++ b/src/Facet/Surface/Type/Class.hs @@ -20,8 +20,8 @@ class Type r where comp :: [r] -> r -> r tapp :: r -> r -> r -forAllA :: (Applicative m, Applicative i, Type r) => (m . i) Name -> (m . i) Kind -> (forall j . Applicative j => (i ~> j) -> j r -> (m . j) r) -> (m . i) r -forAllA n k b = forAll <$> n <*> k <*> mapCInner runC (b liftCOuter (liftCInner id)) +forAllA :: (Applicative m, Applicative i, Type r) => m Name -> m Kind -> (forall j . Applicative j => (i ~> j) -> j r -> m (j r)) -> m (i r) +forAllA n k b = fmap fmap . forAll <$> n <*> k <*> (runC <$> b liftCOuter (liftCInner id)) class Interface r where interface :: QName -> Snoc r -> r From e671c8eec339954a0904aab42384bdefc44502eb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 27 Aug 2021 16:25:37 -0400 Subject: [PATCH 0411/1324] Define a Semigroup instance for NonEmpty. --- src/Facet/Snoc/NonEmpty.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Snoc/NonEmpty.hs b/src/Facet/Snoc/NonEmpty.hs index 415ccf45b..a4a401ebb 100644 --- a/src/Facet/Snoc/NonEmpty.hs +++ b/src/Facet/Snoc/NonEmpty.hs @@ -18,6 +18,9 @@ data NonEmpty a = Snoc a :|> a infixl 5 :|> +instance Semigroup (NonEmpty a) where + as <> (bs :|> b) = toSnoc as <> bs :|> b + (|>) :: NonEmpty a -> a -> NonEmpty a i :|> l |> l' = i :> l :|> l' From a4a60abdd1c7cf74e18ba4baaa0f1d6dfc653f34 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 27 Aug 2021 16:31:02 -0400 Subject: [PATCH 0412/1324] Define an Applicative instance for NonEmpty. --- src/Facet/Snoc/NonEmpty.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Snoc/NonEmpty.hs b/src/Facet/Snoc/NonEmpty.hs index a4a401ebb..e81eef0af 100644 --- a/src/Facet/Snoc/NonEmpty.hs +++ b/src/Facet/Snoc/NonEmpty.hs @@ -21,6 +21,10 @@ infixl 5 :|> instance Semigroup (NonEmpty a) where as <> (bs :|> b) = toSnoc as <> bs :|> b +instance Applicative NonEmpty where + pure = (Nil :|>) + fs <*> as = fromSnoc (toSnoc fs <*> toSnoc as) + (|>) :: NonEmpty a -> a -> NonEmpty a i :|> l |> l' = i :> l :|> l' From 4918514be8e98fa37fccc39e1eab8f7320b0e03b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 00:01:59 -0400 Subject: [PATCH 0413/1324] Define a prism for data definitions. --- src/Facet/Module.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 28865a670..cb802b5e0 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -34,6 +34,7 @@ import Facet.Term.Expr import Facet.Type.Norm import Fresnel.Iso (coerced) import Fresnel.Lens (Lens, Lens', lens) +import Fresnel.Prism -- Modules @@ -126,3 +127,8 @@ unDInterface :: Has Empty sig m => Def -> m (Scope Type ::: Kind) unDInterface = \case DInterface cs _K -> pure $ cs ::: _K _ -> empty + +_DData :: Prism' Def (Scope Def ::: Kind) +_DData = prism' (\ (cs ::: _K) -> DData cs _K) (\case + DData cs _K -> Just (cs ::: _K) + _ -> Nothing) From 1d30e85dbe9dc51fabd42a6c7a4d2bee06694781 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 00:02:10 -0400 Subject: [PATCH 0414/1324] Define a prism for interface definitions. --- src/Facet/Module.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index cb802b5e0..71054c42a 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -132,3 +132,8 @@ _DData :: Prism' Def (Scope Def ::: Kind) _DData = prism' (\ (cs ::: _K) -> DData cs _K) (\case DData cs _K -> Just (cs ::: _K) _ -> Nothing) + +_DInterface :: Prism' Def (Scope Type ::: Kind) +_DInterface = prism' (\ (cs ::: _K) -> DInterface cs _K) (\case + DInterface os _K -> Just (os ::: _K) + _ -> Nothing) From d7f9d45cb75499c2900b9fbe78074e9b15586836 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 00:02:54 -0400 Subject: [PATCH 0415/1324] Define a prism for module definitions. --- src/Facet/Module.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 71054c42a..4516b71b1 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -137,3 +137,8 @@ _DInterface :: Prism' Def (Scope Type ::: Kind) _DInterface = prism' (\ (cs ::: _K) -> DInterface cs _K) (\case DInterface os _K -> Just (os ::: _K) _ -> Nothing) + +_DModule :: Prism' Def (Scope Def ::: Kind) +_DModule = prism' (\ (ds ::: _K) -> DModule ds _K) (\case + DModule ds _K -> Just (ds ::: _K) + _ -> Nothing) From 915d1c2ab406fefce90b88eef7c2340567b947bc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 00:03:10 -0400 Subject: [PATCH 0416/1324] Export the prisms. --- src/Facet/Module.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 4516b71b1..419a58a50 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -18,6 +18,9 @@ module Facet.Module , unDTerm , unDData , unDInterface +, _DData +, _DInterface +, _DModule ) where import Control.Algebra From 6bacb2b0c1f57481cb48afa052c6ef57637339be Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 00:25:22 -0400 Subject: [PATCH 0417/1324] Define previewing. --- src/Facet/Lens.hs | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/src/Facet/Lens.hs b/src/Facet/Lens.hs index 86c3d6205..12bdd366d 100644 --- a/src/Facet/Lens.hs +++ b/src/Facet/Lens.hs @@ -13,17 +13,23 @@ module Facet.Lens , (.=) , modifying , assign +, preview +, previews +, ForgetF(..) , At(..) , Ixed(..) , ixAt ) where +import Control.Applicative (Alternative(..)) import Control.Carrier.State.Church import Control.Effect.Reader import qualified Data.Map as Map +import Data.Profunctor (Choice(..), Profunctor(..)) import Data.Profunctor.Traversing (wander) import qualified Fresnel.Getter as Getter import qualified Fresnel.Lens as Lens +import Fresnel.Optic import qualified Fresnel.Setter as Setter import qualified Fresnel.Traversal as Traversal @@ -77,6 +83,24 @@ assign :: Has (State s) sig m => Setter.Setter s s a b -> b -> m () assign o = modify . Setter.set o +preview :: Optic' (ForgetF Maybe a) s a -> s -> Maybe a +preview o = previews o id + +previews :: Optic' (ForgetF Maybe r) s a -> (a -> r) -> (s -> Maybe r) +previews o f = runForgetF (o (ForgetF (Just . f))) + + +newtype ForgetF f r a b = ForgetF { runForgetF :: a -> f r } + deriving (Functor) + +instance Profunctor (ForgetF f r) where + dimap f _ = ForgetF . lmap f . runForgetF + +instance Alternative f => Choice (ForgetF f r) where + left' (ForgetF r) = ForgetF (either r (const empty)) + right' (ForgetF r) = ForgetF (either (const empty) r) + + class Ixed a where type Index a type IxValue a From 28cb1c55f04017cfa64e97e0d00319ad525c7a86 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 00:26:00 -0400 Subject: [PATCH 0418/1324] Abbreviate the projections with the prisms. --- src/Facet/Module.hs | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 419a58a50..cd557b4f2 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -31,6 +31,7 @@ import Data.Bifunctor (Bifunctor(bimap), first) import Data.Coerce import qualified Data.Map as Map import Facet.Kind +import Facet.Lens import Facet.Name import Facet.Syntax import Facet.Term.Expr @@ -122,14 +123,10 @@ unDTerm = \case _ -> empty unDData :: Has Empty sig m => Def -> m (Scope Def ::: Kind) -unDData = \case - DData cs _K -> pure $ cs ::: _K - _ -> empty +unDData = maybe empty pure . preview _DData unDInterface :: Has Empty sig m => Def -> m (Scope Type ::: Kind) -unDInterface = \case - DInterface cs _K -> pure $ cs ::: _K - _ -> empty +unDInterface = maybe empty pure . preview _DInterface _DData :: Prism' Def (Scope Def ::: Kind) _DData = prism' (\ (cs ::: _K) -> DData cs _K) (\case From 1ce3f5b9cf1253de10450eccbafc568634711227 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 00:27:07 -0400 Subject: [PATCH 0419/1324] Define a prism for DTerm. --- src/Facet/Module.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index cd557b4f2..d35b27f22 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -128,6 +128,11 @@ unDData = maybe empty pure . preview _DData unDInterface :: Has Empty sig m => Def -> m (Scope Type ::: Kind) unDInterface = maybe empty pure . preview _DInterface +_DTerm :: Prism' Def (Maybe Term ::: Type) +_DTerm = prism' (\ (t ::: _T) -> DTerm t _T) (\case + DTerm t _T -> Just (t ::: _T) + _ -> Nothing) + _DData :: Prism' Def (Scope Def ::: Kind) _DData = prism' (\ (cs ::: _K) -> DData cs _K) (\case DData cs _K -> Just (cs ::: _K) From 5248a5a653508e3455064b2a609a0642f6a273cd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 00:27:23 -0400 Subject: [PATCH 0420/1324] Abbreviate unDTerm with _DTerm. --- src/Facet/Module.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index d35b27f22..12ab26a61 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -118,9 +118,7 @@ data Def | DModule (Scope Def) Kind unDTerm :: Has Empty sig m => Def -> m (Maybe Term ::: Type) -unDTerm = \case - DTerm expr _T -> pure $ expr ::: _T - _ -> empty +unDTerm = maybe empty pure . preview _DTerm unDData :: Has Empty sig m => Def -> m (Scope Def ::: Kind) unDData = maybe empty pure . preview _DData From c8829f3fb1f5f4bd7ca0d12839091e212f222c31 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 01:49:36 -0400 Subject: [PATCH 0421/1324] Split a submodule type out of Def. --- src/Facet/Elab.hs | 2 +- src/Facet/Elab/Term.hs | 31 ++++++++++++--------------- src/Facet/Elab/Type.hs | 7 +++--- src/Facet/Module.hs | 48 +++++++++++++++++++++++++++++++----------- src/Facet/Print.hs | 7 +++--- 5 files changed, 58 insertions(+), 37 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 942d3aba6..1d4f007e8 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -140,7 +140,7 @@ lookupInSig (m :. n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':.:_) _) _ :=: d <- lookupScope n defs pure $ m':.:n :=: d) . interfaces where - interfaceScope (_ :=: d) = case d of { DInterface defs _K -> pure defs ; _ -> empty } + interfaceScope (_ :=: d) = case d of { DSubmodule (SInterface defs) _K -> pure defs ; _ -> empty } (|-) :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Writer Usage) sig m) => (Quantity, Pattern (Name ::: Classifier)) -> m a -> m a diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 318a2232c..e75063333 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -273,30 +273,26 @@ patternForArgType = \case elabDataDef :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source :+: Throw Err :+: Write Warn) sig m) - => Name ::: Kind + => Kind -> [S.Ann S.Comment (Name ::: S.Ann S.Comment S.Type)] -> m [Name :=: Def] -- FIXME: check that all constructors return the datatype. -elabDataDef (dname ::: _K) constructors = do +elabDataDef _K constructors = do mname <- view name_ - cs <- for constructors $ \ (S.Ann _ _ (n ::: t)) -> do + for constructors $ \ (S.Ann _ _ (n ::: t)) -> do c_T <- elabType $ abstractType (checkIsType (synthType t ::: KType)) _K con' <- elabTerm $ check (abstractTerm (const (Con (mname :.: n) . toList)) ::: c_T) pure $ n :=: DTerm (Just con') c_T - pure - $ (dname :=: DData (scopeFromList cs) _K) - : cs elabInterfaceDef :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source :+: Throw Err :+: Write Warn) sig m) - => Name ::: Kind + => Kind -> [S.Ann S.Comment (Name ::: S.Ann S.Comment S.Type)] - -> m [Name :=: Def] -elabInterfaceDef (dname ::: _T) constructors = do - cs <- for constructors $ \ (S.Ann _ _ (n ::: t)) -> do + -> m [Name :=: Type] +elabInterfaceDef _T constructors = do + for constructors $ \ (S.Ann _ _ (n ::: t)) -> do _T' <- elabType $ abstractType (checkIsType (synthType t ::: KType)) _T pure $ n :=: _T' - pure [ dname :=: DInterface (scopeFromList cs) _T ] -- FIXME: add a parameter for the effect signature. elabTermDef @@ -333,14 +329,15 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os -- elaborate all the types first es <- for ds $ \ (S.Ann _ _ (dname, S.Ann _ _ def)) -> case def of S.DataDef cs _K -> Nothing <$ do - scope_.decls_.at dname .= Just (DData mempty _K) - decls <- runModule $ elabDataDef (dname ::: _K) cs - for_ decls $ \ (dname :=: decl) -> scope_.decls_.at dname .= Just decl + scope_.decls_.at dname .= Just (DSubmodule (SData mempty) _K) + constructors <- runModule $ elabDataDef _K cs + scope_.decls_.at dname .= Just (DSubmodule (SData (scopeFromList constructors)) _K) + for_ constructors $ \ (dname :=: decl) -> scope_.decls_.at dname .= Just decl S.InterfaceDef os _K -> Nothing <$ do - scope_.decls_.at dname .= Just (DInterface mempty _K) - decls <- runModule $ elabInterfaceDef (dname ::: _K) os - for_ decls $ \ (dname :=: decl) -> scope_.decls_.at dname .= Just decl + scope_.decls_.at dname .= Just (DSubmodule (SInterface mempty) _K) + operations <- runModule $ elabInterfaceDef _K os + scope_.decls_.at dname .= Just (DSubmodule (SInterface (scopeFromList operations)) _K) S.TermDef t tele -> do _T <- runModule $ elabType $ checkIsType (synthType tele ::: KType) diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 83f8a838c..6c581bf5c 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -35,14 +35,13 @@ tvar :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (TX.Type :==> K tvar n = views context_ (lookupInContext n) >>= \case [(n', q, CK _K)] -> use n' q $> (TX.Var (Free (Right n')) :==> _K) _ -> resolveQ n >>= \case - q :=: DData _ _K -> pure $ TX.Var (Global q) :==> _K - q :=: DInterface _ _K -> pure $ TX.Var (Global q) :==> _K + q :=: DSubmodule _ _K -> pure $ TX.Var (Global q) :==> _K _ -> freeVariable n ivar :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (RName :==> Kind) ivar n = resolveQ n >>= \case - q :=: DInterface _ _K -> pure $ q :==> _K - _ -> freeVariable n + q :=: DSubmodule (SInterface _) _K -> pure $ q :==> _K + _ -> freeVariable n _String :: Elab m (TX.Type :==> Kind) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 12ab26a61..aeae6e681 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -14,6 +14,7 @@ module Facet.Module , scopeToList , lookupScope , Import(..) +, Submodule(..) , Def(..) , unDTerm , unDData @@ -28,6 +29,7 @@ import Control.Effect.Choose import Control.Effect.Empty import Control.Monad ((<=<)) import Data.Bifunctor (Bifunctor(bimap), first) +import Data.Bitraversable import Data.Coerce import qualified Data.Map as Map import Facet.Kind @@ -39,6 +41,7 @@ import Facet.Type.Norm import Fresnel.Iso (coerced) import Fresnel.Lens (Lens, Lens', lens) import Fresnel.Prism +import Fresnel.Review (review) -- Modules @@ -111,11 +114,30 @@ lookupScope n (Scope ds) = maybe empty (pure . (n :=:)) (Map.lookup n ds) newtype Import = Import { name :: MName } +data Submodule + = SData (Scope Def) + | SInterface (Scope Type) + | SModule (Scope Def) + +_SData :: Prism' Submodule (Scope Def) +_SData = prism' SData (\case + SData cs -> Just cs + _ -> Nothing) + +_SInterface :: Prism' Submodule (Scope Type) +_SInterface = prism' SInterface (\case + SInterface os -> Just os + _ -> Nothing) + +_SModule :: Prism' Submodule (Scope Def) +_SModule = prism' SModule (\case + SModule ds -> Just ds + _ -> Nothing) + + data Def = DTerm (Maybe Term) Type - | DData (Scope Def) Kind - | DInterface (Scope Type) Kind - | DModule (Scope Def) Kind + | DSubmodule Submodule Kind unDTerm :: Has Empty sig m => Def -> m (Maybe Term ::: Type) unDTerm = maybe empty pure . preview _DTerm @@ -131,17 +153,19 @@ _DTerm = prism' (\ (t ::: _T) -> DTerm t _T) (\case DTerm t _T -> Just (t ::: _T) _ -> Nothing) +_DSubmodule :: Prism' Def (Submodule ::: Kind) +_DSubmodule = prism' (\ (s ::: _K) -> DSubmodule s _K) (\case + DSubmodule s _K -> Just (s ::: _K) + _ -> Nothing) + _DData :: Prism' Def (Scope Def ::: Kind) -_DData = prism' (\ (cs ::: _K) -> DData cs _K) (\case - DData cs _K -> Just (cs ::: _K) - _ -> Nothing) +_DData = onFst _DSubmodule _SData _DInterface :: Prism' Def (Scope Type ::: Kind) -_DInterface = prism' (\ (cs ::: _K) -> DInterface cs _K) (\case - DInterface os _K -> Just (os ::: _K) - _ -> Nothing) +_DInterface = onFst _DSubmodule _SInterface _DModule :: Prism' Def (Scope Def ::: Kind) -_DModule = prism' (\ (ds ::: _K) -> DModule ds _K) (\case - DModule ds _K -> Just (ds ::: _K) - _ -> Nothing) +_DModule = onFst _DSubmodule _SModule + +onFst :: Bitraversable f => Prism' s (f a c) -> Prism' a b -> Prism' s (f b c) +onFst p q = prism' (review p . first (review q)) (bitraverse (preview q) pure <=< preview p) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 9736f4219..021dafda8 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -256,9 +256,10 @@ instance Printable C.Module where defBody = \case C.DTerm Nothing _T -> print opts env _T C.DTerm (Just b) _T -> defn (print opts env _T :=: print opts env b) - C.DData cs _K -> annotate Keyword (pretty "data") <+> scope defBody cs - C.DInterface os _K -> annotate Keyword (pretty "interface") <+> scope (print opts env) os - C.DModule ds _K -> block (concatWith (surround hardline) (map ((hardline <>) . def . fmap defBody) (C.scopeToList ds))) + C.DSubmodule s _K -> case s of + C.SData cs -> annotate Keyword (pretty "data") <+> scope defBody cs + C.SInterface os -> annotate Keyword (pretty "interface") <+> scope (print opts env) os + C.SModule ds -> block (concatWith (surround hardline) (map ((hardline <>) . def . fmap defBody) (C.scopeToList ds))) scope with = block . group . concatWith (surround (hardline <> comma <> space)) . map (group . def . fmap with) . C.scopeToList import' n = pretty "import" <+> braces (setPrec Var (prettyMName n)) module_ n t is ds = ann (setPrec Var (prettyMName n) ::: t) concatWith (surround hardline) (is ++ map (hardline <>) ds) From d9ac035aa663edf01c713e09461a71bce8d81012 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 01:53:42 -0400 Subject: [PATCH 0422/1324] Export the submodule prisms. --- src/Facet/Module.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index aeae6e681..02f6cd3f1 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -15,6 +15,9 @@ module Facet.Module , lookupScope , Import(..) , Submodule(..) +, _SData +, _SInterface +, _SModule , Def(..) , unDTerm , unDData From 1ef442948d8ee85e0590e624998960b183b6e10d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 01:54:47 -0400 Subject: [PATCH 0423/1324] Export the submodule prism. --- src/Facet/Module.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 02f6cd3f1..165a05876 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -22,6 +22,7 @@ module Facet.Module , unDTerm , unDData , unDInterface +, _DSubmodule , _DData , _DInterface , _DModule From 7d6c1404b4295959cbad0ed276a2eb002841503d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 02:10:11 -0400 Subject: [PATCH 0424/1324] Define an infix flipped preview. --- src/Facet/Lens.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Lens.hs b/src/Facet/Lens.hs index 12bdd366d..1b861dd0c 100644 --- a/src/Facet/Lens.hs +++ b/src/Facet/Lens.hs @@ -13,6 +13,7 @@ module Facet.Lens , (.=) , modifying , assign +, (^?) , preview , previews , ForgetF(..) @@ -83,6 +84,11 @@ assign :: Has (State s) sig m => Setter.Setter s s a b -> b -> m () assign o = modify . Setter.set o +(^?) :: s -> Optic' (ForgetF Maybe a) s a -> Maybe a +(^?) = flip preview + +infixl 8 ^? + preview :: Optic' (ForgetF Maybe a) s a -> s -> Maybe a preview o = previews o id From 626056b76569b31692d713eaa4befc3089ee3d93 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 08:09:54 -0400 Subject: [PATCH 0425/1324] Spacing. --- src/Facet/Elab/Term.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index e75063333..e7cc1035a 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -246,8 +246,8 @@ abstractType :: (HasCallStack, Has (Throw Err) sig m) => Elab m TX.Type -> Kind abstractType body = go where go = \case - KArrow (Just n) a b -> TX.ForAll n a <$> ((zero, PVar (n ::: CK a)) |- go b) - _ -> body + KArrow (Just n) a b -> TX.ForAll n a <$> ((zero, PVar (n ::: CK a)) |- go b) + _ -> body abstractTerm :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => (Snoc TX.Type -> Snoc Term -> Term) -> Type <==: Elab m Term abstractTerm body = go Nil Nil From 6b961f0b8a91a419b58fc8d8259b56977290b353 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 08:17:06 -0400 Subject: [PATCH 0426/1324] Represent the top-level elaborators using <==:. --- src/Facet/Elab/Term.hs | 31 ++++++++++++++----------------- 1 file changed, 14 insertions(+), 17 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index e7cc1035a..cd1f47950 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -273,11 +273,10 @@ patternForArgType = \case elabDataDef :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source :+: Throw Err :+: Write Warn) sig m) - => Kind - -> [S.Ann S.Comment (Name ::: S.Ann S.Comment S.Type)] - -> m [Name :=: Def] + => [S.Ann S.Comment (Name ::: S.Ann S.Comment S.Type)] + -> Kind <==: m [Name :=: Def] -- FIXME: check that all constructors return the datatype. -elabDataDef _K constructors = do +elabDataDef constructors = Check $ \ _K -> do mname <- view name_ for constructors $ \ (S.Ann _ _ (n ::: t)) -> do c_T <- elabType $ abstractType (checkIsType (synthType t ::: KType)) _K @@ -286,21 +285,19 @@ elabDataDef _K constructors = do elabInterfaceDef :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source :+: Throw Err :+: Write Warn) sig m) - => Kind - -> [S.Ann S.Comment (Name ::: S.Ann S.Comment S.Type)] - -> m [Name :=: Type] -elabInterfaceDef _T constructors = do + => [S.Ann S.Comment (Name ::: S.Ann S.Comment S.Type)] + -> Kind <==: m [Name :=: Type] +elabInterfaceDef constructors = Check $ \ _K -> do for constructors $ \ (S.Ann _ _ (n ::: t)) -> do - _T' <- elabType $ abstractType (checkIsType (synthType t ::: KType)) _T - pure $ n :=: _T' + _K' <- elabType $ abstractType (checkIsType (synthType t ::: KType)) _K + pure $ n :=: _K' -- FIXME: add a parameter for the effect signature. elabTermDef :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source :+: Throw Err :+: Write Warn) sig m) - => Type - -> S.Ann S.Comment S.Expr - -> m Term -elabTermDef _T expr@(S.Ann s _ _) = do + => S.Ann S.Comment S.Expr + -> Type <==: m Term +elabTermDef expr@(S.Ann s _ _) = Check $ \ _T -> do elabTerm $ pushSpan s $ check (go (checkExpr expr) ::: _T) where go k = Check $ \ _T -> case _T of @@ -330,13 +327,13 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os es <- for ds $ \ (S.Ann _ _ (dname, S.Ann _ _ def)) -> case def of S.DataDef cs _K -> Nothing <$ do scope_.decls_.at dname .= Just (DSubmodule (SData mempty) _K) - constructors <- runModule $ elabDataDef _K cs + constructors <- runModule $ elabDataDef cs <==: _K scope_.decls_.at dname .= Just (DSubmodule (SData (scopeFromList constructors)) _K) for_ constructors $ \ (dname :=: decl) -> scope_.decls_.at dname .= Just decl S.InterfaceDef os _K -> Nothing <$ do scope_.decls_.at dname .= Just (DSubmodule (SInterface mempty) _K) - operations <- runModule $ elabInterfaceDef _K os + operations <- runModule $ elabInterfaceDef os <==: _K scope_.decls_.at dname .= Just (DSubmodule (SInterface (scopeFromList operations)) _K) S.TermDef t tele -> do @@ -346,7 +343,7 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os -- then elaborate the terms for_ (catMaybes es) $ \ (dname, t ::: _T) -> do - t' <- runModule $ elabTermDef _T t + t' <- runModule $ elabTermDef t <==: _T scope_.decls_.ix dname .= DTerm (Just t') _T From cdfd9ea335d6ce9fcff8d4c42c66c142c5426612 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 08:22:01 -0400 Subject: [PATCH 0427/1324] Run checkIsType in <==:. --- src/Facet/Elab/Term.hs | 8 ++++---- src/Facet/Elab/Type.hs | 19 ++++++++++--------- 2 files changed, 14 insertions(+), 13 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index cd1f47950..507910282 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -89,7 +89,7 @@ switch m = Check $ \ _Exp -> m >>= \case as :: (HasCallStack, Has (Throw Err) sig m) => (Type <==: Elab m Term) ::: Elab m (Type :==> Kind) -> Elab m (Term :==> Type) as (m ::: _T) = do - _T' <- checkIsType (_T ::: KType) + _T' <- checkIsType _T <==: KType a <- check (m ::: _T') pure $ a :==> _T' @@ -279,7 +279,7 @@ elabDataDef elabDataDef constructors = Check $ \ _K -> do mname <- view name_ for constructors $ \ (S.Ann _ _ (n ::: t)) -> do - c_T <- elabType $ abstractType (checkIsType (synthType t ::: KType)) _K + c_T <- elabType $ abstractType (checkIsType (synthType t) <==: KType) _K con' <- elabTerm $ check (abstractTerm (const (Con (mname :.: n) . toList)) ::: c_T) pure $ n :=: DTerm (Just con') c_T @@ -289,7 +289,7 @@ elabInterfaceDef -> Kind <==: m [Name :=: Type] elabInterfaceDef constructors = Check $ \ _K -> do for constructors $ \ (S.Ann _ _ (n ::: t)) -> do - _K' <- elabType $ abstractType (checkIsType (synthType t ::: KType)) _K + _K' <- elabType $ abstractType (checkIsType (synthType t) <==: KType) _K pure $ n :=: _K' -- FIXME: add a parameter for the effect signature. @@ -337,7 +337,7 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os scope_.decls_.at dname .= Just (DSubmodule (SInterface (scopeFromList operations)) _K) S.TermDef t tele -> do - _T <- runModule $ elabType $ checkIsType (synthType tele ::: KType) + _T <- runModule $ elabType $ checkIsType (synthType tele) <==: KType scope_.decls_.at dname .= Just (DTerm Nothing _T) pure (Just (dname, t ::: _T)) diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 6c581bf5c..78076ff24 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -16,6 +16,7 @@ import Control.Monad (unless) import Data.Foldable (foldl') import Data.Functor (($>)) import Facet.Elab +import Facet.Functor.Check import Facet.Functor.Synth import Facet.Interface import Facet.Kind @@ -50,13 +51,13 @@ _String = pure $ TX.String :==> KType forAll :: (HasCallStack, Has (Throw Err) sig m) => Name ::: Kind -> Elab m (TX.Type :==> Kind) -> Elab m (TX.Type :==> Kind) forAll (n ::: t) b = do - b' <- (zero, PVar (n ::: CK t)) |- checkIsType (b ::: KType) + b' <- (zero, PVar (n ::: CK t)) |- checkIsType b <==: KType pure $ TX.ForAll n t b' :==> KType arrow :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> Elab m (a :==> Kind) -> Elab m (b :==> Kind) -> Elab m (c :==> Kind) arrow mk a b = do - a' <- checkIsType (a ::: KType) - b' <- checkIsType (b ::: KType) + a' <- checkIsType a <==: KType + b' <- checkIsType b <==: KType pure $ mk a' b' :==> KType @@ -65,15 +66,15 @@ app mk f a = do f' :==> _F <- f (_ ::: _A, _B) <- assertTypeConstructor _F -- FIXME: assert that the usage is zero - a' <- checkIsType (a ::: _A) + a' <- checkIsType a <==: _A pure $ mk f' a' :==> _B comp :: (HasCallStack, Has (Throw Err) sig m) => [Elab m (Interface TX.Type :==> Kind)] -> Elab m (TX.Type :==> Kind) -> Elab m (TX.Type :==> Kind) comp s t = do - s' <- traverse (checkIsType . (::: KInterface)) s + s' <- traverse ((<==: KInterface) . checkIsType) s -- FIXME: polarize types and check that this is a value type being returned - t' <- checkIsType (t ::: KType) + t' <- checkIsType t <==: KType pure $ TX.Comp (fromInterfaces s') t' :==> KType @@ -94,7 +95,7 @@ synthInterface :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Comment (S.In synthInterface (S.Ann s _ (S.Interface h sp)) = pushSpan s $ do -- FIXME: check that the application actually result in an Interface h' :==> _ <- ivar h - sp' <- foldl' (liftA2 (:>)) (pure Nil) (checkIsType . (::: KType) . synthType <$> sp) + sp' <- foldl' (liftA2 (:>)) (pure Nil) ((<==: KType) . checkIsType . synthType <$> sp) pure $ Interface h' sp' :==> KInterface @@ -106,7 +107,7 @@ assertTypeConstructor = assertMatch (\case{ KArrow n t b -> pure (n ::: t, b) ; -- Judgements -checkIsType :: (HasCallStack, Has (Throw Err) sig m) => Elab m (a :==> Kind) ::: Kind -> Elab m a -checkIsType (m ::: _K) = do +checkIsType :: (HasCallStack, Has (Throw Err) sig m) => Elab m (a :==> Kind) -> Kind <==: Elab m a +checkIsType m = Check $ \ _K -> do a :==> _KA <- m a <$ unless (_KA == _K) (couldNotUnify (Exp (CK _K)) (Act (CK _KA))) From ecaadaa8df6ec10bf55a8ffdd2cf8978b61b7404 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 08:24:08 -0400 Subject: [PATCH 0428/1324] Rename checkIsType to switch. --- src/Facet/Elab/Term.hs | 11 ++++++----- src/Facet/Elab/Type.hs | 20 ++++++++++---------- 2 files changed, 16 insertions(+), 15 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 507910282..e2027c5a6 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -54,7 +54,8 @@ import Data.Traversable (for, mapAccumL) import Facet.Context (toEnv) import Facet.Effect.Write import Facet.Elab -import Facet.Elab.Type +import Facet.Elab.Type hiding (switch) +import qualified Facet.Elab.Type as Type import Facet.Functor.Check import Facet.Functor.Synth import Facet.Graph @@ -89,7 +90,7 @@ switch m = Check $ \ _Exp -> m >>= \case as :: (HasCallStack, Has (Throw Err) sig m) => (Type <==: Elab m Term) ::: Elab m (Type :==> Kind) -> Elab m (Term :==> Type) as (m ::: _T) = do - _T' <- checkIsType _T <==: KType + _T' <- Type.switch _T <==: KType a <- check (m ::: _T') pure $ a :==> _T' @@ -279,7 +280,7 @@ elabDataDef elabDataDef constructors = Check $ \ _K -> do mname <- view name_ for constructors $ \ (S.Ann _ _ (n ::: t)) -> do - c_T <- elabType $ abstractType (checkIsType (synthType t) <==: KType) _K + c_T <- elabType $ abstractType (Type.switch (synthType t) <==: KType) _K con' <- elabTerm $ check (abstractTerm (const (Con (mname :.: n) . toList)) ::: c_T) pure $ n :=: DTerm (Just con') c_T @@ -289,7 +290,7 @@ elabInterfaceDef -> Kind <==: m [Name :=: Type] elabInterfaceDef constructors = Check $ \ _K -> do for constructors $ \ (S.Ann _ _ (n ::: t)) -> do - _K' <- elabType $ abstractType (checkIsType (synthType t) <==: KType) _K + _K' <- elabType $ abstractType (Type.switch (synthType t) <==: KType) _K pure $ n :=: _K' -- FIXME: add a parameter for the effect signature. @@ -337,7 +338,7 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os scope_.decls_.at dname .= Just (DSubmodule (SInterface (scopeFromList operations)) _K) S.TermDef t tele -> do - _T <- runModule $ elabType $ checkIsType (synthType tele) <==: KType + _T <- runModule $ elabType $ Type.switch (synthType tele) <==: KType scope_.decls_.at dname .= Just (DTerm Nothing _T) pure (Just (dname, t ::: _T)) diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 78076ff24..d9e93f4d6 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -6,7 +6,7 @@ module Facet.Elab.Type , forAll , synthType -- * Judgements -, checkIsType +, switch ) where import Control.Algebra @@ -51,13 +51,13 @@ _String = pure $ TX.String :==> KType forAll :: (HasCallStack, Has (Throw Err) sig m) => Name ::: Kind -> Elab m (TX.Type :==> Kind) -> Elab m (TX.Type :==> Kind) forAll (n ::: t) b = do - b' <- (zero, PVar (n ::: CK t)) |- checkIsType b <==: KType + b' <- (zero, PVar (n ::: CK t)) |- switch b <==: KType pure $ TX.ForAll n t b' :==> KType arrow :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> Elab m (a :==> Kind) -> Elab m (b :==> Kind) -> Elab m (c :==> Kind) arrow mk a b = do - a' <- checkIsType a <==: KType - b' <- checkIsType b <==: KType + a' <- switch a <==: KType + b' <- switch b <==: KType pure $ mk a' b' :==> KType @@ -66,15 +66,15 @@ app mk f a = do f' :==> _F <- f (_ ::: _A, _B) <- assertTypeConstructor _F -- FIXME: assert that the usage is zero - a' <- checkIsType a <==: _A + a' <- switch a <==: _A pure $ mk f' a' :==> _B comp :: (HasCallStack, Has (Throw Err) sig m) => [Elab m (Interface TX.Type :==> Kind)] -> Elab m (TX.Type :==> Kind) -> Elab m (TX.Type :==> Kind) comp s t = do - s' <- traverse ((<==: KInterface) . checkIsType) s + s' <- traverse ((<==: KInterface) . switch) s -- FIXME: polarize types and check that this is a value type being returned - t' <- checkIsType t <==: KType + t' <- switch t <==: KType pure $ TX.Comp (fromInterfaces s') t' :==> KType @@ -95,7 +95,7 @@ synthInterface :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Comment (S.In synthInterface (S.Ann s _ (S.Interface h sp)) = pushSpan s $ do -- FIXME: check that the application actually result in an Interface h' :==> _ <- ivar h - sp' <- foldl' (liftA2 (:>)) (pure Nil) ((<==: KType) . checkIsType . synthType <$> sp) + sp' <- foldl' (liftA2 (:>)) (pure Nil) ((<==: KType) . switch . synthType <$> sp) pure $ Interface h' sp' :==> KInterface @@ -107,7 +107,7 @@ assertTypeConstructor = assertMatch (\case{ KArrow n t b -> pure (n ::: t, b) ; -- Judgements -checkIsType :: (HasCallStack, Has (Throw Err) sig m) => Elab m (a :==> Kind) -> Kind <==: Elab m a -checkIsType m = Check $ \ _K -> do +switch :: (HasCallStack, Has (Throw Err) sig m) => Elab m (a :==> Kind) -> Kind <==: Elab m a +switch m = Check $ \ _K -> do a :==> _KA <- m a <$ unless (_KA == _K) (couldNotUnify (Exp (CK _K)) (Act (CK _KA))) From 8d8d8bf470a1b0d09153fe4fd24d3929db54915a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 08:27:36 -0400 Subject: [PATCH 0429/1324] Eliminate an indirection. --- src/Facet/Elab/Term.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index e2027c5a6..90fd8c41c 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -340,10 +340,10 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os S.TermDef t tele -> do _T <- runModule $ elabType $ Type.switch (synthType tele) <==: KType scope_.decls_.at dname .= Just (DTerm Nothing _T) - pure (Just (dname, t ::: _T)) + pure (Just (dname, t, _T)) -- then elaborate the terms - for_ (catMaybes es) $ \ (dname, t ::: _T) -> do + for_ (catMaybes es) $ \ (dname, t, _T) -> do t' <- runModule $ elabTermDef t <==: _T scope_.decls_.ix dname .= DTerm (Just t') _T From 7feebfb8b404f5a11b8a930f62c070d3aeca4bf9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 08:50:42 -0400 Subject: [PATCH 0430/1324] Simplify scope elaboration. --- src/Facet/Elab/Term.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 90fd8c41c..466f992f8 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -79,6 +79,7 @@ import qualified Facet.Type.Expr as TX import Facet.Type.Norm as T hiding (global) import Facet.Unify import Facet.Usage hiding (restrict) +import Fresnel.Prism (_Just) import GHC.Stack -- General combinators @@ -327,15 +328,15 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os -- elaborate all the types first es <- for ds $ \ (S.Ann _ _ (dname, S.Ann _ _ def)) -> case def of S.DataDef cs _K -> Nothing <$ do - scope_.decls_.at dname .= Just (DSubmodule (SData mempty) _K) + scope_.decls_.at dname._Just._DData .= (mempty ::: _K) constructors <- runModule $ elabDataDef cs <==: _K - scope_.decls_.at dname .= Just (DSubmodule (SData (scopeFromList constructors)) _K) + scope_.decls_.ix dname._DData .= (scopeFromList constructors ::: _K) for_ constructors $ \ (dname :=: decl) -> scope_.decls_.at dname .= Just decl S.InterfaceDef os _K -> Nothing <$ do - scope_.decls_.at dname .= Just (DSubmodule (SInterface mempty) _K) + scope_.decls_.at dname._Just._DInterface .= (mempty ::: _K) operations <- runModule $ elabInterfaceDef os <==: _K - scope_.decls_.at dname .= Just (DSubmodule (SInterface (scopeFromList operations)) _K) + scope_.decls_.ix dname._DInterface .= (scopeFromList operations ::: _K) S.TermDef t tele -> do _T <- runModule $ elabType $ Type.switch (synthType tele) <==: KType From b9e73a253cffa1a9b6c9b0d0c35a42dfad71a4f3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 09:50:50 -0400 Subject: [PATCH 0431/1324] Define a lens over the first parameter to :::. --- src/Facet/Syntax.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 996c9ca3b..f02b1f8e9 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -4,6 +4,7 @@ module Facet.Syntax ( (:::)(..) , tm +, _tm , ty , (:=:)(..) , nm, def @@ -70,6 +71,9 @@ instance Ord2 (:::) where tm :: a ::: b -> a tm (a ::: _) = a +_tm :: Lens (s ::: t) (s' ::: t) s s' +_tm = lens tm (\ (_ ::: t) s' -> s' ::: t) + ty :: a ::: b -> b ty (_ ::: b) = b From 0979a907cda2532bdba7437de298dc268d5e6ffa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 09:51:31 -0400 Subject: [PATCH 0432/1324] Define a lens over the second parameter to :::. --- src/Facet/Syntax.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index f02b1f8e9..046ad14d8 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -6,6 +6,7 @@ module Facet.Syntax , tm , _tm , ty +, _ty , (:=:)(..) , nm, def -- * Variables @@ -77,6 +78,9 @@ _tm = lens tm (\ (_ ::: t) s' -> s' ::: t) ty :: a ::: b -> b ty (_ ::: b) = b +_ty :: Lens (s ::: t) (s ::: t') t t' +_ty = lens ty (\ (s ::: _) t' -> s ::: t') + data a :=: b = a :=: b deriving (Eq, Foldable, Functor, Ord, Show, Traversable) From 04d03e91324238a28147c0bd4cc6727a4d1c14bd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 10:19:41 -0400 Subject: [PATCH 0433/1324] Define an Ixed instance for IntMap. --- src/Facet/Lens.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Facet/Lens.hs b/src/Facet/Lens.hs index 1b861dd0c..932f23c94 100644 --- a/src/Facet/Lens.hs +++ b/src/Facet/Lens.hs @@ -25,6 +25,7 @@ module Facet.Lens import Control.Applicative (Alternative(..)) import Control.Carrier.State.Church import Control.Effect.Reader +import qualified Data.IntMap as IntMap import qualified Data.Map as Map import Data.Profunctor (Choice(..), Profunctor(..)) import Data.Profunctor.Traversing (wander) @@ -120,6 +121,13 @@ instance Ord k => Ixed (Map.Map k v) where Just v -> fmap (\ v' -> Map.insert k v' m) (f v) Nothing -> pure m +instance Ixed (IntMap.IntMap v) where + type Index (IntMap.IntMap v) = IntMap.Key + type IxValue (IntMap.IntMap v) = v + ix k = wander $ \ f m -> case IntMap.lookup k m of + Just v -> fmap (\ v' -> IntMap.insert k v' m) (f v) + Nothing -> pure m + class Ixed a => At a where at :: Index a -> Lens.Lens' a (Maybe (IxValue a)) From 3ab59a33fa3f531d1cea2bdaea21944b1f5aea4c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 10:20:05 -0400 Subject: [PATCH 0434/1324] Define an At instance for IntMap. --- src/Facet/Lens.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Lens.hs b/src/Facet/Lens.hs index 932f23c94..3dd9bfddd 100644 --- a/src/Facet/Lens.hs +++ b/src/Facet/Lens.hs @@ -135,6 +135,9 @@ class Ixed a => At a where instance Ord k => At (Map.Map k v) where at k = Lens.lens (Map.lookup k) (\ m v -> maybe (Map.delete k m) (\ v -> Map.insert k v m) v) +instance At (IntMap.IntMap v) where + at k = Lens.lens (IntMap.lookup k) (\ m v -> maybe (IntMap.delete k m) (\ v -> IntMap.insert k v m) v) + ixAt :: At a => Index a -> Traversal.Traversal' a (IxValue a) ixAt i = at i . wander traverse From 0ea424b72fb8775700320c8b977aed105607e281 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 10:20:41 -0400 Subject: [PATCH 0435/1324] Simplify the definition of ixAt. --- src/Facet/Lens.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Lens.hs b/src/Facet/Lens.hs index 3dd9bfddd..0ab233856 100644 --- a/src/Facet/Lens.hs +++ b/src/Facet/Lens.hs @@ -28,7 +28,7 @@ import Control.Effect.Reader import qualified Data.IntMap as IntMap import qualified Data.Map as Map import Data.Profunctor (Choice(..), Profunctor(..)) -import Data.Profunctor.Traversing (wander) +import Data.Profunctor.Traversing (traverse', wander) import qualified Fresnel.Getter as Getter import qualified Fresnel.Lens as Lens import Fresnel.Optic @@ -140,4 +140,4 @@ instance At (IntMap.IntMap v) where ixAt :: At a => Index a -> Traversal.Traversal' a (IxValue a) -ixAt i = at i . wander traverse +ixAt i = at i . traverse' From a46d2418e3695cc29ae2a05a5828e5d7c27aeefe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 10:29:57 -0400 Subject: [PATCH 0436/1324] Correct the initialization of scopes. --- src/Facet/Elab/Term.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 466f992f8..ce334b528 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -79,7 +79,6 @@ import qualified Facet.Type.Expr as TX import Facet.Type.Norm as T hiding (global) import Facet.Unify import Facet.Usage hiding (restrict) -import Fresnel.Prism (_Just) import GHC.Stack -- General combinators @@ -317,7 +316,7 @@ elabModule :: (HasCallStack, Has (Reader Graph :+: Reader Source :+: Throw Err :+: Write Warn) sig m) => S.Ann S.Comment S.Module -> m Module -elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os mempty) $ do +elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os (Scope mempty)) $ do let (importedNames, imports) = mapAccumL (\ names (S.Ann _ _ S.Import{ name }) -> (Set.insert name names, Import name)) Set.empty is imports_ .= imports @@ -328,15 +327,15 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os -- elaborate all the types first es <- for ds $ \ (S.Ann _ _ (dname, S.Ann _ _ def)) -> case def of S.DataDef cs _K -> Nothing <$ do - scope_.decls_.at dname._Just._DData .= (mempty ::: _K) + scope_.decls_.at dname .= Just (DSubmodule (SData mempty) _K) constructors <- runModule $ elabDataDef cs <==: _K - scope_.decls_.ix dname._DData .= (scopeFromList constructors ::: _K) + scope_.decls_.ix dname._DSubmodule._tm._SData .= scopeFromList constructors for_ constructors $ \ (dname :=: decl) -> scope_.decls_.at dname .= Just decl S.InterfaceDef os _K -> Nothing <$ do - scope_.decls_.at dname._Just._DInterface .= (mempty ::: _K) + scope_.decls_.at dname .= Just (DSubmodule (SInterface mempty) _K) operations <- runModule $ elabInterfaceDef os <==: _K - scope_.decls_.ix dname._DInterface .= (scopeFromList operations ::: _K) + scope_.decls_.ix dname._DSubmodule._tm._SInterface .= scopeFromList operations S.TermDef t tele -> do _T <- runModule $ elabType $ Type.switch (synthType tele) <==: KType From a5eb629ac34a16c0921b3de7f9b185b425322729 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 10:56:25 -0400 Subject: [PATCH 0437/1324] Elaborate datatypes & interfaces via a letrec operation. --- src/Facet/Elab/Term.hs | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index ce334b528..57569b3d5 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -61,7 +61,7 @@ import Facet.Functor.Synth import Facet.Graph import Facet.Interface import Facet.Kind -import Facet.Lens (At(..), Ixed(..), locally, view, views, (.=)) +import Facet.Lens as Lens (At(..), Ixed(..), locally, view, views, (.=), (<~)) import Facet.Module as Module import Facet.Name import Facet.Pattern @@ -79,6 +79,8 @@ import qualified Facet.Type.Expr as TX import Facet.Type.Norm as T hiding (global) import Facet.Unify import Facet.Usage hiding (restrict) +import Fresnel.Setter (Setter') +import Fresnel.Traversal (Traversal') import GHC.Stack -- General combinators @@ -325,17 +327,12 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os -- FIXME: check for redundant naming -- elaborate all the types first - es <- for ds $ \ (S.Ann _ _ (dname, S.Ann _ _ def)) -> case def of - S.DataDef cs _K -> Nothing <$ do - scope_.decls_.at dname .= Just (DSubmodule (SData mempty) _K) - constructors <- runModule $ elabDataDef cs <==: _K - scope_.decls_.ix dname._DSubmodule._tm._SData .= scopeFromList constructors - for_ constructors $ \ (dname :=: decl) -> scope_.decls_.at dname .= Just decl - - S.InterfaceDef os _K -> Nothing <$ do - scope_.decls_.at dname .= Just (DSubmodule (SInterface mempty) _K) - operations <- runModule $ elabInterfaceDef os <==: _K - scope_.decls_.ix dname._DSubmodule._tm._SInterface .= scopeFromList operations + es <- for ds $ \ (S.Ann _ _ (dname, S.Ann _ _ def)) -> let build = letrec (scope_.decls_) dname in case def of + S.DataDef cs _K -> Nothing <$ build (_DSubmodule._tm._SData) (DSubmodule (SData mempty) _K) (do + cs <- runModule $ elabDataDef cs <==: _K + scopeFromList cs <$ for_ cs (\ (dname :=: decl) -> scope_.decls_.at dname .= Just decl)) + + S.InterfaceDef os _K -> Nothing <$ build (_DSubmodule._tm._SInterface) (DSubmodule (SInterface mempty) _K) (scopeFromList <$> runModule (elabInterfaceDef os <==: _K)) S.TermDef t tele -> do _T <- runModule $ elabType $ Type.switch (synthType tele) <==: KType @@ -347,6 +344,11 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os t' <- runModule $ elabTermDef t <==: _T scope_.decls_.ix dname .= DTerm (Just t') _T +letrec :: (Has (State s) sig m, At a) => Setter' s a -> Lens.Index a -> Traversal' (Lens.IxValue a) b -> Lens.IxValue a -> m b -> m () +letrec getter key projection initial final = do + getter.at key .= Just initial + getter.ix key.projection <~ final + -- Errors From 77ad1c3e4815d746c7468973f1ea9be8fdb34894 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 11:04:41 -0400 Subject: [PATCH 0438/1324] Move most of the traversal into build. --- src/Facet/Elab/Term.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 57569b3d5..5456ef561 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -79,6 +79,8 @@ import qualified Facet.Type.Expr as TX import Facet.Type.Norm as T hiding (global) import Facet.Unify import Facet.Usage hiding (restrict) +import Fresnel.Prism (Prism') +import Fresnel.Review (review) import Fresnel.Setter (Setter') import Fresnel.Traversal (Traversal') import GHC.Stack @@ -327,12 +329,12 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os -- FIXME: check for redundant naming -- elaborate all the types first - es <- for ds $ \ (S.Ann _ _ (dname, S.Ann _ _ def)) -> let build = letrec (scope_.decls_) dname in case def of - S.DataDef cs _K -> Nothing <$ build (_DSubmodule._tm._SData) (DSubmodule (SData mempty) _K) (do - cs <- runModule $ elabDataDef cs <==: _K + es <- for ds $ \ (S.Ann _ _ (dname, S.Ann _ _ def)) -> let { build :: (Has (State Module) sig m, Monoid a) => Prism' Submodule a -> Kind -> m a -> m () ; build p _K = letrec (scope_.decls_) dname (_DSubmodule._tm.p) (DSubmodule (review p mempty) _K) } in case def of + S.DataDef cs _K -> Nothing <$ build _SData _K (do + cs <- runModule (elabDataDef cs <==: _K) scopeFromList cs <$ for_ cs (\ (dname :=: decl) -> scope_.decls_.at dname .= Just decl)) - S.InterfaceDef os _K -> Nothing <$ build (_DSubmodule._tm._SInterface) (DSubmodule (SInterface mempty) _K) (scopeFromList <$> runModule (elabInterfaceDef os <==: _K)) + S.InterfaceDef os _K -> Nothing <$ build _SInterface _K (scopeFromList <$> runModule (elabInterfaceDef os <==: _K)) S.TermDef t tele -> do _T <- runModule $ elabType $ Type.switch (synthType tele) <==: KType From 2a55c08e389ef0169a1bb0f66f9ae528289cf258 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 11:10:09 -0400 Subject: [PATCH 0439/1324] Run the elaboration within build. --- src/Facet/Elab/Term.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 5456ef561..18d87b057 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -329,12 +329,11 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os -- FIXME: check for redundant naming -- elaborate all the types first - es <- for ds $ \ (S.Ann _ _ (dname, S.Ann _ _ def)) -> let { build :: (Has (State Module) sig m, Monoid a) => Prism' Submodule a -> Kind -> m a -> m () ; build p _K = letrec (scope_.decls_) dname (_DSubmodule._tm.p) (DSubmodule (review p mempty) _K) } in case def of - S.DataDef cs _K -> Nothing <$ build _SData _K (do - cs <- runModule (elabDataDef cs <==: _K) + es <- for ds $ \ (S.Ann _ _ (dname, S.Ann _ _ def)) -> let { build :: (Has (State Module) sig m, Monoid a) => Prism' Submodule a -> Kind -> Kind <==: ReaderC Module m b -> (b -> m a) -> m () ; build p _K elab ret = letrec (scope_.decls_) dname (_DSubmodule._tm.p) (DSubmodule (review p mempty) _K) (runModule (elab <==: _K) >>= ret) } in case def of + S.DataDef cs _K -> Nothing <$ build _SData _K (elabDataDef cs) (\ cs -> do scopeFromList cs <$ for_ cs (\ (dname :=: decl) -> scope_.decls_.at dname .= Just decl)) - S.InterfaceDef os _K -> Nothing <$ build _SInterface _K (scopeFromList <$> runModule (elabInterfaceDef os <==: _K)) + S.InterfaceDef os _K -> Nothing <$ build _SInterface _K (elabInterfaceDef os) (pure . scopeFromList) S.TermDef t tele -> do _T <- runModule $ elabType $ Type.switch (synthType tele) <==: KType From d7392ee3f2209c9f828c50a029280c359a97db35 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 11:11:26 -0400 Subject: [PATCH 0440/1324] Pull build out of the loop. --- src/Facet/Elab/Term.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 18d87b057..3faf27b52 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -328,12 +328,15 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os -- FIXME: maybe figure out the graph for mutual recursion? -- FIXME: check for redundant naming + let build :: (Has (State Module) sig m, Monoid a) => Name -> Prism' Submodule a -> Kind -> Kind <==: ReaderC Module m b -> (b -> m a) -> m () + build dname p _K elab ret = letrec (scope_.decls_) dname (_DSubmodule._tm.p) (DSubmodule (review p mempty) _K) (runModule (elab <==: _K) >>= ret) + -- elaborate all the types first - es <- for ds $ \ (S.Ann _ _ (dname, S.Ann _ _ def)) -> let { build :: (Has (State Module) sig m, Monoid a) => Prism' Submodule a -> Kind -> Kind <==: ReaderC Module m b -> (b -> m a) -> m () ; build p _K elab ret = letrec (scope_.decls_) dname (_DSubmodule._tm.p) (DSubmodule (review p mempty) _K) (runModule (elab <==: _K) >>= ret) } in case def of - S.DataDef cs _K -> Nothing <$ build _SData _K (elabDataDef cs) (\ cs -> do + es <- for ds $ \ (S.Ann _ _ (dname, S.Ann _ _ def)) -> case def of + S.DataDef cs _K -> Nothing <$ build dname _SData _K (elabDataDef cs) (\ cs -> do scopeFromList cs <$ for_ cs (\ (dname :=: decl) -> scope_.decls_.at dname .= Just decl)) - S.InterfaceDef os _K -> Nothing <$ build _SInterface _K (elabInterfaceDef os) (pure . scopeFromList) + S.InterfaceDef os _K -> Nothing <$ build dname _SInterface _K (elabInterfaceDef os) (pure . scopeFromList) S.TermDef t tele -> do _T <- runModule $ elabType $ Type.switch (synthType tele) <==: KType From 1a4d47abfb2ab4d8d1ff3c8473effa3c66fdaa33 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 11:11:44 -0400 Subject: [PATCH 0441/1324] Rename build to elabScope. --- src/Facet/Elab/Term.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 3faf27b52..866523896 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -328,15 +328,15 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os -- FIXME: maybe figure out the graph for mutual recursion? -- FIXME: check for redundant naming - let build :: (Has (State Module) sig m, Monoid a) => Name -> Prism' Submodule a -> Kind -> Kind <==: ReaderC Module m b -> (b -> m a) -> m () - build dname p _K elab ret = letrec (scope_.decls_) dname (_DSubmodule._tm.p) (DSubmodule (review p mempty) _K) (runModule (elab <==: _K) >>= ret) + let elabScope :: (Has (State Module) sig m, Monoid a) => Name -> Prism' Submodule a -> Kind -> Kind <==: ReaderC Module m b -> (b -> m a) -> m () + elabScope dname p _K elab ret = letrec (scope_.decls_) dname (_DSubmodule._tm.p) (DSubmodule (review p mempty) _K) (runModule (elab <==: _K) >>= ret) -- elaborate all the types first es <- for ds $ \ (S.Ann _ _ (dname, S.Ann _ _ def)) -> case def of - S.DataDef cs _K -> Nothing <$ build dname _SData _K (elabDataDef cs) (\ cs -> do + S.DataDef cs _K -> Nothing <$ elabScope dname _SData _K (elabDataDef cs) (\ cs -> do scopeFromList cs <$ for_ cs (\ (dname :=: decl) -> scope_.decls_.at dname .= Just decl)) - S.InterfaceDef os _K -> Nothing <$ build dname _SInterface _K (elabInterfaceDef os) (pure . scopeFromList) + S.InterfaceDef os _K -> Nothing <$ elabScope dname _SInterface _K (elabInterfaceDef os) (pure . scopeFromList) S.TermDef t tele -> do _T <- runModule $ elabType $ Type.switch (synthType tele) <==: KType From 41e362844d98e3879ce207f3e31356094f303885 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 11:52:16 -0400 Subject: [PATCH 0442/1324] Flip withSpanC. --- src/Facet/Elab/Term.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 866523896..4b8783b19 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -218,7 +218,7 @@ synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \cas checkExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Comment S.Expr -> Type <==: Elab m Term -checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in flip withSpanC expr $ \case +checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC expr $ \case S.Hole n -> hole n S.Lam cs -> checkLam cs S.Var{} -> switch (synthExpr expr) @@ -378,8 +378,8 @@ runModule m = do withSpanB :: Algebra sig m => (a -> Bind m b) -> S.Ann S.Comment a -> Bind m b withSpanB k (S.Ann s _ a) = Bind (\ _A k' -> pushSpan s (runBind (k a) _A k')) -withSpanC :: Algebra sig m => (a -> Type <==: Elab m b) -> S.Ann S.Comment a -> Type <==: Elab m b -withSpanC k (S.Ann s _ a) = Check (\ _T -> pushSpan s (k a <==: _T)) +withSpanC :: Algebra sig m => S.Ann S.Comment a -> (a -> Type <==: Elab m b) -> Type <==: Elab m b +withSpanC (S.Ann s _ a) k = Check (\ _T -> pushSpan s (k a <==: _T)) withSpan :: Has (Reader ElabContext) sig m => (a -> m b) -> S.Ann S.Comment a -> m b withSpan k (S.Ann s _ a) = pushSpan s (k a) From 3f29f1f32e0969696d9746089563a955fdd2b248 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 11:52:44 -0400 Subject: [PATCH 0443/1324] Simplify bindPattern. --- src/Facet/Elab/Term.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 4b8783b19..79d9f6795 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -237,11 +237,10 @@ checkLam cs = lam (snd vs) -- FIXME: check for unique variable names bindPattern :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Comment S.ValPattern -> Bind m (Pattern (Name ::: Classifier)) -bindPattern = go where - go = withSpanB $ \case - S.PWildcard -> wildcardP - S.PVar n -> varP n - S.PCon n ps -> conP n (map go ps) +bindPattern = withSpanB $ \case + S.PWildcard -> wildcardP + S.PVar n -> varP n + S.PCon n ps -> conP n (map bindPattern ps) -- | Elaborate a type abstracted over another type’s parameters. From b4e09cc70c3aa2824deef47b638d95cbda5ffa74 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 15:26:27 -0400 Subject: [PATCH 0444/1324] Define a projection of the proof term of Synth judgements. --- src/Facet/Functor/Synth.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Facet/Functor/Synth.hs b/src/Facet/Functor/Synth.hs index dfc42315a..92f6408a3 100644 --- a/src/Facet/Functor/Synth.hs +++ b/src/Facet/Functor/Synth.hs @@ -1,6 +1,8 @@ module Facet.Functor.Synth ( -- * Synth judgement (:==>)(..) + -- * Elimination +, proof ) where import Data.Bifoldable @@ -22,3 +24,9 @@ instance Bifoldable (:==>) where instance Bitraversable (:==>) where bitraverse f g (a :==> _T) = (:==>) <$> f a <*> g _T + + +-- Elimination + +proof :: a :==> b -> a +proof (a :==> _) = a From 97f4636b8d9ec3b079796406695bda61dd33e7b5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 15:27:07 -0400 Subject: [PATCH 0445/1324] Define a projection of the proposition of Synth judgements. --- src/Facet/Functor/Synth.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Functor/Synth.hs b/src/Facet/Functor/Synth.hs index 92f6408a3..175e9280e 100644 --- a/src/Facet/Functor/Synth.hs +++ b/src/Facet/Functor/Synth.hs @@ -3,6 +3,7 @@ module Facet.Functor.Synth (:==>)(..) -- * Elimination , proof +, prop ) where import Data.Bifoldable @@ -30,3 +31,6 @@ instance Bitraversable (:==>) where proof :: a :==> b -> a proof (a :==> _) = a + +prop :: a :==> b -> b +prop (_ :==> b) = b From 00570f7993250502a1348311f7956929850aa0c0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 28 Aug 2021 15:36:42 -0400 Subject: [PATCH 0446/1324] Bind variables in the synth judgement. --- src/Facet/Context.hs | 15 ++++++++------- src/Facet/Elab.hs | 4 ++-- src/Facet/Elab/Term.hs | 38 +++++++++++++++++++------------------- src/Facet/Elab/Type.hs | 2 +- src/Facet/Notice/Elab.hs | 7 ++++--- src/Facet/Unify.hs | 3 ++- 6 files changed, 36 insertions(+), 33 deletions(-) diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index 7f0bf17be..db7125ace 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -13,6 +13,7 @@ module Facet.Context import qualified Control.Effect.Empty as E import Data.Foldable (find, toList) import qualified Facet.Env as Env +import Facet.Functor.Synth import Facet.Name import Facet.Pattern import qualified Facet.Snoc as S @@ -22,13 +23,13 @@ import Facet.Usage import GHC.Stack import Prelude hiding (lookup) -newtype Context = Context { elems :: S.Snoc (Quantity, Pattern (Name ::: Classifier)) } +newtype Context = Context { elems :: S.Snoc (Quantity, Pattern (Name :==> Classifier)) } empty :: Context empty = Context S.Nil -(|>) :: Context -> (Quantity, Pattern (Name ::: Classifier)) -> Context +(|>) :: Context -> (Quantity, Pattern (Name :==> Classifier)) -> Context Context as |> a = Context (as S.:> a) infixl 5 |> @@ -36,7 +37,7 @@ infixl 5 |> level :: Context -> Used level (Context es) = Used (Level (length es)) -(!) :: HasCallStack => Context -> Index -> (Quantity, Pattern (Name ::: Classifier)) +(!) :: HasCallStack => Context -> Index -> (Quantity, Pattern (Name :==> Classifier)) Context es' ! Index i' = withFrozenCallStack $ go es' i' where go (es S.:> e) i @@ -47,11 +48,11 @@ Context es' ! Index i' = withFrozenCallStack $ go es' i' lookupIndex :: E.Has E.Empty sig m => Name -> Context -> m (LName Index, Quantity, Classifier) lookupIndex n = go (Index 0) . elems where - go _ S.Nil = E.empty + go _ S.Nil = E.empty go i (cs S.:> (q, p)) - | Just (n' ::: t) <- find ((== n) . tm) p = pure (LName i n', q, t) - | otherwise = go (succ i) cs + | Just (n' :==> t) <- find ((== n) . proof) p = pure (LName i n', q, t) + | otherwise = go (succ i) cs toEnv :: Context -> Env.Env Type -toEnv c = Env.Env (S.fromList (zipWith (\ (_, p) d -> (\ b -> tm b :=: free (LName (getUsed d) (tm b))) <$> p) (toList (elems c)) [0..pred (level c)])) +toEnv c = Env.Env (S.fromList (zipWith (\ (_, p) d -> (\ b -> proof b :=: free (LName (getUsed d) (proof b))) <$> p) (toList (elems c)) [0..pred (level c)])) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 1d4f007e8..a46724e4a 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -143,12 +143,12 @@ lookupInSig (m :. n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':.:_) _) interfaceScope (_ :=: d) = case d of { DSubmodule (SInterface defs) _K -> pure defs ; _ -> empty } -(|-) :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Writer Usage) sig m) => (Quantity, Pattern (Name ::: Classifier)) -> m a -> m a +(|-) :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Writer Usage) sig m) => (Quantity, Pattern (Name :==> Classifier)) -> m a -> m a (q, p) |- b = do sigma <- asks scale d <- depth (u, a) <- censor (`Usage.withoutVars` Vars.singleton (getUsed d)) $ listen $ locally context_ (|> (q, p)) b - for_ p $ \ (n ::: _T) -> do + for_ p $ \ (n :==> _T) -> do let exp = sigma >< q act = Usage.lookup (LName (getUsed d) n) u unless (act `sat` exp) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 79d9f6795..f572d64fd 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -124,14 +124,14 @@ tlam :: (HasCallStack, Has (Throw Err) sig m) => Type <==: Elab m Term -> Type < tlam b = Check $ \ _T -> do (n ::: _A, _B) <- assertQuantifier _T d <- depth - (zero, PVar (n ::: CK _A)) |- check (b ::: _B (T.free (LName (getUsed d) n))) + (zero, PVar (n :==> CK _A)) |- check (b ::: _B (T.free (LName (getUsed d) n))) -lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern (Name ::: Classifier)), Type <==: Elab m Term)] -> Type <==: Elab m Term +lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern (Name :==> Classifier)), Type <==: Elab m Term)] -> Type <==: Elab m Term lam cs = Check $ \ _T -> do (_A, _B) <- assertTacitFunction _T Lam <$> traverse (\ (p, b) -> bind (p ::: _A) (check (b ::: _B))) cs -lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Type <==: Elab m Term -> Type <==: Elab m Term +lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Classifier)) -> Type <==: Elab m Term -> Type <==: Elab m Term lam1 p b = lam [(p, b)] app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Elab m (a :==> Type)) -> (HasCallStack => Type <==: Elab m b) -> Elab m (c :==> Type) @@ -146,7 +146,7 @@ string :: Text -> Elab m (Term :==> Type) string s = pure $ E.String s :==> T.String -let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) -> Elab m (Term :==> Type) -> Type <==: Elab m Term -> Type <==: Elab m Term +let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Classifier)) -> Elab m (Term :==> Type) -> Type <==: Elab m Term -> Type <==: Elab m Term let' p a b = Check $ \ _B -> do a' :==> _A <- a (p', b') <- bind (p ::: (Many, _A)) (check (b ::: _B)) @@ -157,27 +157,27 @@ comp :: Has (Throw Err) sig m => Type <==: Elab m Term -> Type <==: Elab m Term comp b = Check $ \ _T -> do (sig, _B) <- assertComp _T StaticContext{ graph, module' } <- ask - let interfacePattern :: Has (Throw Err) sig m => Interface Type -> Elab m (RName :=: (Name ::: Classifier)) - interfacePattern (Interface n _) = maybe (freeVariable (toQ n)) (\ (n' :=: _T) -> pure ((n .:. n') :=: (n' ::: CT _T))) (listToMaybe (scopeToList . tm =<< unDInterface . def =<< lookupQ graph module' (toQ n))) + let interfacePattern :: Has (Throw Err) sig m => Interface Type -> Elab m (RName :=: (Name :==> Classifier)) + interfacePattern (Interface n _) = maybe (freeVariable (toQ n)) (\ (n' :=: _T) -> pure ((n .:. n') :=: (n' :==> CT _T))) (listToMaybe (scopeToList . tm =<< unDInterface . def =<< lookupQ graph module' (toQ n))) p' <- traverse interfacePattern (interfaces sig) -- FIXME: can we apply quantities to dictionaries? what would they mean? b' <- (Many, PDict p') |- check (b ::: _B) - pure $ E.Comp (map (fmap tm) p') b' + pure $ E.Comp (map (fmap proof) p') b' -- Pattern combinators -wildcardP :: Bind m (Pattern (Name ::: Classifier)) +wildcardP :: Bind m (Pattern (Name :==> Classifier)) wildcardP = Bind $ \ _T k -> k PWildcard -varP :: Name -> Bind m (Pattern (Name ::: Classifier)) -varP n = Bind $ \ _A k -> k (PVar (n ::: CT (wrap _A))) +varP :: Name -> Bind m (Pattern (Name :==> Classifier)) +varP n = Bind $ \ _A k -> k (PVar (n :==> CT (wrap _A))) where wrap = \case T.Comp sig _A -> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (T.Comp sig _A) _T -> _T -conP :: (HasCallStack, Has (Throw Err) sig m) => QName -> [Bind m (Pattern (Name ::: Classifier))] -> Bind m (Pattern (Name ::: Classifier)) +conP :: (HasCallStack, Has (Throw Err) sig m) => QName -> [Bind m (Pattern (Name :==> Classifier))] -> Bind m (Pattern (Name :==> Classifier)) conP n fs = Bind $ \ _A k -> do n' :=: _ ::: _T <- resolveC n _T' <- maybe (pure _T) (foldl' (\ _T _A -> ($ _A) . snd <$> (_T >>= assertQuantifier)) (pure _T) . snd) (unNeutral _A) @@ -193,10 +193,10 @@ fieldsP = foldr cons nil nil = Bind $ \ _T k -> k ([], _T) -allP :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Name -> Bind m (Pattern (Name ::: Classifier)) +allP :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Name -> Bind m (Pattern (Name :==> Classifier)) allP n = Bind $ \ _A k -> do (sig, _T) <- assertComp _A - k (PVar (n ::: CT (T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (T.Comp sig _T)))) + k (PVar (n :==> CT (T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (T.Comp sig _T)))) -- Expression elaboration @@ -229,14 +229,14 @@ checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC checkLam :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => [S.Clause] -> Type <==: Elab m Term checkLam cs = lam (snd vs) where - vs :: Has (Throw Err :+: Write Warn) sig m => ([QName :=: (Type <==: Elab m Term)], [(Bind m (Pattern (Name ::: Classifier)), Type <==: Elab m Term)]) + vs :: Has (Throw Err :+: Write Warn) sig m => ([QName :=: (Type <==: Elab m Term)], [(Bind m (Pattern (Name :==> Classifier)), Type <==: Elab m Term)]) vs = partitionEithers (map (\ (S.Clause (S.Ann _ _ p) b) -> case p of S.PVal p -> Right (bindPattern p, checkExpr b) S.PEff (S.Ann s _ (S.POp n fs k)) -> Left $ n :=: Check (\ _T -> pushSpan s (foldr (lam1 . bindPattern) (checkExpr b) (fromList fs:>k) <==: _T))) cs) -- FIXME: check for unique variable names -bindPattern :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Comment S.ValPattern -> Bind m (Pattern (Name ::: Classifier)) +bindPattern :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Comment S.ValPattern -> Bind m (Pattern (Name :==> Classifier)) bindPattern = withSpanB $ \case S.PWildcard -> wildcardP S.PVar n -> varP n @@ -250,7 +250,7 @@ abstractType :: (HasCallStack, Has (Throw Err) sig m) => Elab m TX.Type -> Kind abstractType body = go where go = \case - KArrow (Just n) a b -> TX.ForAll n a <$> ((zero, PVar (n ::: CK a)) |- go b) + KArrow (Just n) a b -> TX.ForAll n a <$> ((zero, PVar (n :==> CK a)) |- go b) _ -> body abstractTerm :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => (Snoc TX.Type -> Snoc Term -> Term) -> Type <==: Elab m Term @@ -267,7 +267,7 @@ abstractTerm body = go Nil Nil d <- depth pure $ body (TX.Var . Free . Right . toIndexed d <$> ts) (fs <*> pure d) -patternForArgType :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Type -> Name -> Bind m (Pattern (Name ::: Classifier)) +patternForArgType :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Type -> Name -> Bind m (Pattern (Name :==> Classifier)) patternForArgType = \case T.Comp{} -> allP _ -> varP @@ -408,8 +408,8 @@ check (m ::: _T) = case _T of _T -> m <==: _T -bind :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name ::: Classifier)) ::: (Quantity, Type) -> Elab m b -> Elab m (Pattern Name, b) -bind (p ::: (q, _T)) m = runBind p _T (\ p' -> (tm <$> p',) <$> ((q, p') |- m)) +bind :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Classifier)) ::: (Quantity, Type) -> Elab m b -> Elab m (Pattern Name, b) +bind (p ::: (q, _T)) m = runBind p _T (\ p' -> (proof <$> p',) <$> ((q, p') |- m)) newtype Bind m a = Bind { runBind :: forall x . Type -> (a -> Elab m x) -> Elab m x } deriving (Functor) diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index d9e93f4d6..3ad14052e 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -51,7 +51,7 @@ _String = pure $ TX.String :==> KType forAll :: (HasCallStack, Has (Throw Err) sig m) => Name ::: Kind -> Elab m (TX.Type :==> Kind) -> Elab m (TX.Type :==> Kind) forAll (n ::: t) b = do - b' <- (zero, PVar (n ::: CK t)) |- switch b <==: KType + b' <- (zero, PVar (n :==> CK t)) |- switch b <==: KType pure $ TX.ForAll n t b' :==> KType arrow :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> Elab m (a :==> Kind) -> Elab m (b :==> Kind) -> Elab m (c :==> Kind) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 8e58c8c1c..ff98c13f5 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -11,6 +11,7 @@ import qualified Facet.Carrier.Write.Inject as L import Facet.Context import Facet.Elab as Elab import qualified Facet.Env as Env +import Facet.Functor.Synth import Facet.Interface (interfaces) import Facet.Name (LName(..)) import Facet.Notice as Notice hiding (level) @@ -43,12 +44,12 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) sig' = getPrint . print opts printCtx . fmap (apply subst (toEnv context)) <$> (interfaces =<< sig) combine (d, env, prints, ctx) (m, p) = let roundtrip = apply subst env - binding (n ::: _T) = ann (intro n d ::: mult m (case _T of + binding (n :==> _T) = ann (intro n d ::: mult m (case _T of CK _K -> print opts prints _K CT _T -> print opts prints (roundtrip _T))) in ( succ d - , env Env.|> ((\ (n ::: _T) -> n :=: free (LName d n)) <$> p) - , prints Env.|> ((\ (n ::: _) -> n :=: intro n d) <$> p) + , env Env.|> ((\ (n :==> _T) -> n :=: free (LName d n)) <$> p) + , prints Env.|> ((\ (n :==> _) -> n :=: intro n d) <$> p) , ctx :> getPrint (print opts prints (binding <$> p)) ) mult m = if | m == zero -> (pretty "0" <+>) diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index c790f3ad8..d2e53eec8 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -19,6 +19,7 @@ import Control.Effect.Writer import Control.Monad (unless) import Facet.Carrier.Throw.Inject import Facet.Elab +import Facet.Functor.Synth import Facet.Interface import Facet.Kind import Facet.Name @@ -60,7 +61,7 @@ unifyType = curry $ \case (TN.Ne (Free (Left v1)) Nil, TN.Ne (Free (Left v2)) Nil) -> flexFlex v1 v2 (TN.Ne (Free (Left v1)) Nil, t2) -> solve v1 t2 (t1, TN.Ne (Free (Left v2)) Nil) -> solve v2 t1 - (TN.ForAll _ t1 b1, TN.ForAll n t2 b2) -> depth >>= \ d -> evalTExpr =<< mkForAll d n <$> unifyKind t1 t2 <*> ((zero, PVar (n ::: CK t2)) |- unifyType (b1 (free (LName (getUsed d) n))) (b2 (free (LName (getUsed d) n)))) + (TN.ForAll _ t1 b1, TN.ForAll n t2 b2) -> depth >>= \ d -> evalTExpr =<< mkForAll d n <$> unifyKind t1 t2 <*> ((zero, PVar (n :==> CK t2)) |- unifyType (b1 (free (LName (getUsed d) n))) (b2 (free (LName (getUsed d) n)))) (TN.ForAll{}, _) -> mismatch (TN.Arrow _ _ a1 b1, TN.Arrow n q a2 b2) -> TN.Arrow n q <$> unifyType a1 a2 <*> unifyType b1 b2 (TN.Arrow{}, _) -> mismatch From 75706008c5c71233e144d055de54ce4244496db9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 29 Aug 2021 00:32:43 -0400 Subject: [PATCH 0447/1324] Specialize Ann to Comment. --- src/Facet/Elab/Term.hs | 24 ++++++------ src/Facet/Elab/Type.hs | 4 +- src/Facet/Parser.hs | 68 +++++++++++++++++----------------- src/Facet/REPL.hs | 4 +- src/Facet/Surface/Module.hs | 10 ++--- src/Facet/Surface/Term/Expr.hs | 14 +++---- src/Facet/Surface/Type/Expr.hs | 8 ++-- src/Facet/Syntax.hs | 22 +++++------ 8 files changed, 77 insertions(+), 77 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index f572d64fd..4caf8acf7 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -201,7 +201,7 @@ allP n = Bind $ \ _A k -> do -- Expression elaboration -synthExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Comment S.Expr -> Elab m (Term :==> Type) +synthExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Elab m (Term :==> Type) synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \case S.Var n -> var n S.App f a -> synthApp f a @@ -211,13 +211,13 @@ synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \cas S.Lam{} -> nope where nope = couldNotSynthesize - synthApp :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Comment S.Expr -> S.Ann S.Comment S.Expr -> Elab m (Term :==> Type) + synthApp :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Expr -> Elab m (Term :==> Type) synthApp f a = app App (synthExpr f) (checkExpr a) - synthAs :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Comment S.Expr -> S.Ann S.Comment S.Type -> Elab m (Term :==> Type) + synthAs :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Type -> Elab m (Term :==> Type) synthAs t _T = as (checkExpr t ::: do { _T :==> _K <- synthType _T ; (:==> _K) <$> evalTExpr _T }) -checkExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Comment S.Expr -> Type <==: Elab m Term +checkExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Type <==: Elab m Term checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC expr $ \case S.Hole n -> hole n S.Lam cs -> checkLam cs @@ -236,7 +236,7 @@ checkLam cs = lam (snd vs) -- FIXME: check for unique variable names -bindPattern :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Comment S.ValPattern -> Bind m (Pattern (Name :==> Classifier)) +bindPattern :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.ValPattern -> Bind m (Pattern (Name :==> Classifier)) bindPattern = withSpanB $ \case S.PWildcard -> wildcardP S.PVar n -> varP n @@ -277,7 +277,7 @@ patternForArgType = \case elabDataDef :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source :+: Throw Err :+: Write Warn) sig m) - => [S.Ann S.Comment (Name ::: S.Ann S.Comment S.Type)] + => [S.Ann (Name ::: S.Ann S.Type)] -> Kind <==: m [Name :=: Def] -- FIXME: check that all constructors return the datatype. elabDataDef constructors = Check $ \ _K -> do @@ -289,7 +289,7 @@ elabDataDef constructors = Check $ \ _K -> do elabInterfaceDef :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source :+: Throw Err :+: Write Warn) sig m) - => [S.Ann S.Comment (Name ::: S.Ann S.Comment S.Type)] + => [S.Ann (Name ::: S.Ann S.Type)] -> Kind <==: m [Name :=: Type] elabInterfaceDef constructors = Check $ \ _K -> do for constructors $ \ (S.Ann _ _ (n ::: t)) -> do @@ -299,7 +299,7 @@ elabInterfaceDef constructors = Check $ \ _K -> do -- FIXME: add a parameter for the effect signature. elabTermDef :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source :+: Throw Err :+: Write Warn) sig m) - => S.Ann S.Comment S.Expr + => S.Ann S.Expr -> Type <==: m Term elabTermDef expr@(S.Ann s _ _) = Check $ \ _T -> do elabTerm $ pushSpan s $ check (go (checkExpr expr) ::: _T) @@ -317,7 +317,7 @@ elabTermDef expr@(S.Ann s _ _) = Check $ \ _T -> do elabModule :: (HasCallStack, Has (Reader Graph :+: Reader Source :+: Throw Err :+: Write Warn) sig m) - => S.Ann S.Comment S.Module + => S.Ann S.Module -> m Module elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os (Scope mempty)) $ do let (importedNames, imports) = mapAccumL (\ names (S.Ann _ _ S.Import{ name }) -> (Set.insert name names, Import name)) Set.empty is @@ -374,13 +374,13 @@ runModule m = do mod <- get runReader mod m -withSpanB :: Algebra sig m => (a -> Bind m b) -> S.Ann S.Comment a -> Bind m b +withSpanB :: Algebra sig m => (a -> Bind m b) -> S.Ann a -> Bind m b withSpanB k (S.Ann s _ a) = Bind (\ _A k' -> pushSpan s (runBind (k a) _A k')) -withSpanC :: Algebra sig m => S.Ann S.Comment a -> (a -> Type <==: Elab m b) -> Type <==: Elab m b +withSpanC :: Algebra sig m => S.Ann a -> (a -> Type <==: Elab m b) -> Type <==: Elab m b withSpanC (S.Ann s _ a) k = Check (\ _T -> pushSpan s (k a <==: _T)) -withSpan :: Has (Reader ElabContext) sig m => (a -> m b) -> S.Ann S.Comment a -> m b +withSpan :: Has (Reader ElabContext) sig m => (a -> m b) -> S.Ann a -> m b withSpan k (S.Ann s _ a) = pushSpan s (k a) provide :: Has (Reader ElabContext :+: State (Subst Type)) sig m => Signature Type -> m a -> m a diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 3ad14052e..2bf9aba4c 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -78,7 +78,7 @@ comp s t = do pure $ TX.Comp (fromInterfaces s') t' :==> KType -synthType :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Comment S.Type -> Elab m (TX.Type :==> Kind) +synthType :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Type -> Elab m (TX.Type :==> Kind) synthType (S.Ann s _ e) = pushSpan s $ case e of S.TVar n -> tvar n S.TString -> _String @@ -91,7 +91,7 @@ synthType (S.Ann s _ e) = pushSpan s $ case e of S.Zero -> zero S.One -> one -synthInterface :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Comment (S.Interface (S.Ann S.Comment S.Type)) -> Elab m (Interface TX.Type :==> Kind) +synthInterface :: (HasCallStack, Has (Throw Err) sig m) => S.Ann (S.Interface (S.Ann S.Type)) -> Elab m (Interface TX.Type :==> Kind) synthInterface (S.Ann s _ (S.Interface h sp)) = pushSpan s $ do -- FIXME: check that the application actually result in an Interface h' :==> _ <- ivar h diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index f97566c17..bd5bdadf7 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -59,7 +59,7 @@ whole :: TokenParsing p => p a -> p a whole p = whiteSpace *> p <* eof -makeOperator :: (N.MName, N.Op, N.Assoc) -> Operator (S.Ann S.Comment S.Expr) +makeOperator :: (N.MName, N.Op, N.Assoc) -> Operator (S.Ann S.Expr) makeOperator (name, op, assoc) = (op, assoc, nary (N.toQ (name N.:.: N.O op))) where nary name es = foldl' (S.annBinary S.App) (S.Ann (S.ann (head es)) Nil (S.Var name)) es @@ -67,23 +67,23 @@ makeOperator (name, op, assoc) = (op, assoc, nary (N.toQ (name N.:.: N.O op))) -- Modules -module' :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Module) +module' :: (Has Parser sig p, Has (State [Operator (S.Ann S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Module) module' = anned $ do (name, imports) <- moduleHeader decls <- C.runReader name (runReaderC (many decl)) - ops <- get @[Operator (S.Ann S.Comment S.Expr)] + ops <- get @[Operator (S.Ann S.Expr)] pure $ S.Module name imports (map (\ (op, assoc, _) -> (op, assoc)) ops) decls -moduleHeader :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (N.MName, [S.Ann S.Comment S.Import]) +moduleHeader :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (N.MName, [S.Ann S.Import]) moduleHeader = (,) <$ reserve dnameStyle "module" <*> mname <* colon <* symbol "Module" <*> many import' -- Declarations -import' :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Import) +import' :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Import) import' = anned $ S.Import <$ reserve dnameStyle "import" <*> mname -decl :: (Has Parser sig p, Has (Reader N.MName) sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name, S.Ann S.Comment S.Def)) +decl :: (Has Parser sig p, Has (Reader N.MName) sig p, Has (State [Operator (S.Ann S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann (N.Name, S.Ann S.Def)) decl = choice [ termDecl , dataDecl @@ -93,7 +93,7 @@ decl = choice -- FIXME: operators aren’t available until after their declarations have been parsed. -- FIXME: parse operator declarations in datatypes. -- FIXME: parse operator declarations in interfaces. -termDecl :: (Has Parser sig p, Has (Reader N.MName) sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name, S.Ann S.Comment S.Def)) +termDecl :: (Has Parser sig p, Has (Reader N.MName) sig p, Has (State [Operator (S.Ann S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann (N.Name, S.Ann S.Def)) termDecl = anned $ do name <- dename case name of @@ -112,18 +112,18 @@ termDecl = anned $ do decl <- anned $ colon *> typeSig ename <**> (S.TermDef <$> body) pure (name, decl) -body :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) +body :: (Has Parser sig p, Has (State [Operator (S.Ann S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Expr) -- NB: We parse sepBy1 and the empty case separately so that it doesn’t succeed at matching 0 clauses and then expect a closing brace when it sees a nullary computation body = fmap (either S.out id) <$> anned (braces (Right . S.Lam <$> sepBy1 clause comma <|> Left <$> expr <|> pure (Right (S.Lam [])))) -dataDecl :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name, S.Ann S.Comment S.Def)) +dataDecl :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann (N.Name, S.Ann S.Def)) dataDecl = anned $ (,) <$ reserve dnameStyle "data" <*> tname <* colon <*> anned (kindSig <**> (S.DataDef <$> braces (commaSep con))) -interfaceDecl :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name, S.Ann S.Comment S.Def)) +interfaceDecl :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann (N.Name, S.Ann S.Def)) interfaceDecl = anned $ (,) <$ reserve dnameStyle "interface" <*> tname <* colon <*> anned (kindSig <**> (S.InterfaceDef <$> braces (commaSep con))) -con :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment (N.Name ::: S.Ann S.Comment S.Type)) +con :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann (N.Name ::: S.Ann S.Type)) con = anned ((:::) <$> dename <* colon <*> rec) where rec = choice [ forAll rec, type' ] @@ -137,7 +137,7 @@ kindSig = choice [ kindArrow kindSig, kind ] typeSig :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p N.Name -- ^ a parser for names occurring in explicit (parenthesized) bindings - -> p (S.Ann S.Comment S.Type) + -> p (S.Ann S.Type) typeSig name = choice [ forAll (typeSig name), bindArrow name (typeSig name), type' ] @@ -154,7 +154,7 @@ kindArrow k = try (KArrow . Just <$ lparen <*> (tname <|> N.__ <$ wildcard) <* c -- FIXME: kind ascriptions -monotypeTable :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => Table p (S.Ann S.Comment S.Type) +monotypeTable :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => Table p (S.Ann S.Type) monotypeTable = [ [ functionType ] , [ retType ] @@ -167,40 +167,40 @@ monotypeTable = ] -type' :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) +type' :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Type) type' = monotype -forAll :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) +forAll :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Type) -> p (S.Ann S.Type) forAll k = make <$> anned (try (((,,) <$ lbrace <*> commaSep1 ((,) <$> position <*> tname) <* colon) <*> kind <* rbrace <* arrow) <*> k) where make (S.Ann s cs (ns, t, b)) = S.Ann s cs (S.out (foldr (\ (p, n) b -> S.Ann (Span p (end s)) Nil (S.TForAll n t b)) b ns)) -bindArrow :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p N.Name -> p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) +bindArrow :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p N.Name -> p (S.Ann S.Type) -> p (S.Ann S.Type) bindArrow name k = anned (try (S.TArrow . Just <$ lparen <*> (name <|> N.__ <$ wildcard) <* colon) <*> optional mul <*> type' <* rparen <* arrow <*> k) -functionType :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) +functionType :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Type) -> p (S.Ann S.Type) -> p (S.Ann S.Type) functionType self next = anned (try (S.TArrow Nothing <$> optional mul <*> next <* arrow) <*> self) <|> next mul :: TokenParsing p => p S.Mul mul = choice [ S.Zero <$ token (char '0'), S.One <$ token (char '1') ] -retType :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) -> p (S.Ann S.Comment S.Type) +retType :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Type) -> p (S.Ann S.Type) -> p (S.Ann S.Type) retType _ next = mk <$> anned ((,) <$> optional signature <*> next) where mk (S.Ann s c (sig, _T)) = maybe id (\ sig -> S.Ann s c . S.TComp sig) sig _T -- FIXME: support type operators -monotype :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) +monotype :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Type) monotype = build monotypeTable $ parens type' -tvar :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Type) +tvar :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Type) tvar = anned (S.TVar <$> qname tname) -signature :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p [S.Ann S.Comment (S.Interface (S.Ann S.Comment S.Type))] +signature :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p [S.Ann (S.Interface (S.Ann S.Type))] signature = brackets (commaSep delta) "signature" where delta = anned $ S.Interface <$> head <*> (fromList <$> many type') @@ -211,7 +211,7 @@ signature = brackets (commaSep delta) "signature" -- Expressions -exprTable :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => Table p (S.Ann S.Comment S.Expr) +exprTable :: (Has Parser sig p, Has (State [Operator (S.Ann S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => Table p (S.Ann S.Expr) exprTable = -- FIXME: parse this as a unary operator or something -- FIXME: better yet, generalize operators to allow different syntactic types on either side (following the associativity) @@ -220,23 +220,23 @@ exprTable = , [ atom thunk, atom hole, atom evar, atom (token (anned (runUnspaced (S.String <$> stringLiteral)))) ] ] -expr :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) +expr :: (Has Parser sig p, Has (State [Operator (S.Ann S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Expr) expr = do ops <- get let rec = build (map parseOperator ops:exprTable) $ parens rec rec -ascription :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) -> p (S.Ann S.Comment S.Expr) -> p (S.Ann S.Comment S.Expr) +ascription :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Expr) -> p (S.Ann S.Expr) -> p (S.Ann S.Expr) ascription _self next = anned (S.As <$> try (next <* colon) <*> type') <|> next -thunk :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) +thunk :: (Has Parser sig p, Has (State [Operator (S.Ann S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Expr) -- NB: We parse sepBy1 and the empty case separately so that it doesn’t succeed at matching 0 clauses and then expect a closing brace when it sees a nullary computation thunk = anned (braces (S.Lam <$> sepBy1 clause comma <|> {-S.Thunk <$> expr <|>-} pure (S.Lam []))) -clause :: (Has Parser sig p, Has (State [Operator (S.Ann S.Comment S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p S.Clause +clause :: (Has Parser sig p, Has (State [Operator (S.Ann S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p S.Clause clause = S.Clause <$> try (compPattern <* arrow) <*> expr "clause" -evar :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) +evar :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Expr) evar = choice [ token (anned (runUnspaced (S.Var <$> try ((N.:.) . fromList <$> many (comp <* dot) <*> ename)))) -- FIXME: would be better to commit once we see a placeholder, but try doesn’t really let us express that @@ -245,7 +245,7 @@ evar = choice where comp = ident tnameStyle -hole :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Expr) +hole :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Expr) hole = token (anned (runUnspaced (S.Hole <$> ident hnameStyle))) where hnameStyle = IdentifierStyle "hole name" (char '?') nameChar reserved Identifier ReservedIdentifier @@ -256,14 +256,14 @@ hole = token (anned (runUnspaced (S.Hole <$> ident hnameStyle))) wildcard :: (Monad p, TokenParsing p) => p () wildcard = reserve enameStyle "_" -valuePattern :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.ValPattern) +valuePattern :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.ValPattern) valuePattern = choice [ token (anned (runUnspaced (S.PVar <$> ename "variable"))) , anned (S.PWildcard <$ wildcard) , try (parens (anned (S.PCon <$> qname ename <*> many valuePattern))) ] "pattern" -compPattern :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Comment S.Pattern) +compPattern :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Pattern) compPattern = choice [ anned (S.PVal <$> valuePattern) , anned (S.PEff <$> try (brackets (anned (S.POp <$> qname ename <*> many valuePattern <* symbolic ';' <*> valuePattern)))) @@ -353,7 +353,7 @@ rbrace :: TokenParsing p => p Char rbrace = symbolic '}' -anned :: (Has Parser sig p, Has (Writer Comments) sig p) => p a -> p (S.Ann S.Comment a) +anned :: (Has Parser sig p, Has (Writer Comments) sig p) => p a -> p (S.Ann a) anned p = mk <$> censor @Comments (const Nil) (listen @Comments ((,,) <$> position <*> p <*> position)) where mk (cs, (s, a, e)) = S.Ann (Span s e) cs a @@ -361,13 +361,13 @@ anned p = mk <$> censor @Comments (const Nil) (listen @Comments ((,,) <$> positi -- Parsing carriers -runFacet :: Functor m => [Operator (S.Ann S.Comment S.Expr)] -> Facet m a -> m a +runFacet :: Functor m => [Operator (S.Ann S.Expr)] -> Facet m a -> m a runFacet ops (Facet m) = snd <$> C.runWriter (runWriterC (C.evalState ops (runStateC m))) type Comments = Snoc (Span, S.Comment) -newtype Facet m a = Facet (StateC [Operator (S.Ann S.Comment S.Expr)] (WriterC Comments m) a) - deriving (Algebra (State [Operator (S.Ann S.Comment S.Expr)] :+: Writer Comments :+: sig), Alternative, Applicative, Functor, Monad, MonadFail, MonadFix) +newtype Facet m a = Facet (StateC [Operator (S.Ann S.Expr)] (WriterC Comments m) a) + deriving (Algebra (State [Operator (S.Ann S.Expr)] :+: Writer Comments :+: sig), Alternative, Applicative, Functor, Monad, MonadFail, MonadFix) instance (Monad p, Parsing p) => Parsing (Facet p) where try (Facet m) = Facet $ try m diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index 35b99ad87..b8d9adfad 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -194,7 +194,7 @@ addTarget targets = Action $ do removeTarget targets = Action $ target_.targets_ %= (Set.\\ Set.fromList targets) -showType, showEval :: S.Ann S.Comment S.Expr -> Action +showType, showEval :: S.Ann S.Expr -> Action showType e = Action $ do e :==> _T <- runElab $ Elab.elabSynthTerm (Elab.synthExpr e) @@ -218,7 +218,7 @@ runEvalMain e = runEval (quote 0 =<< runReader mempty (eval e)) pure -- handle _ _ = unhandled -- unhandled = throwError $ Notice.Notice (Just Notice.Error) [] (fillSep @(Doc Style) [reflow "unhandled effect operator"]) [] -showKind :: S.Ann S.Comment S.Type -> Action +showKind :: S.Ann S.Type -> Action showKind _T = Action $ do _T :==> _K <- runElab $ Elab.elabSynthType (Elab.synthType _T) opts <- get diff --git a/src/Facet/Surface/Module.hs b/src/Facet/Surface/Module.hs index 5ab4183f7..ca9785494 100644 --- a/src/Facet/Surface/Module.hs +++ b/src/Facet/Surface/Module.hs @@ -16,9 +16,9 @@ import Facet.Syntax -- Declarations data Def - = DataDef [Ann Comment (Name ::: Ann Comment Type)] Kind - | InterfaceDef [Ann Comment (Name ::: Ann Comment Type)] Kind - | TermDef (Ann Comment Expr) (Ann Comment Type) + = DataDef [Ann (Name ::: Ann Type)] Kind + | InterfaceDef [Ann (Name ::: Ann Type)] Kind + | TermDef (Ann Expr) (Ann Type) deriving (Eq, Show) @@ -26,10 +26,10 @@ data Def data Module = Module { name :: MName - , imports :: [Ann Comment Import] + , imports :: [Ann Import] -- FIXME: store source references for operators’ definitions, for error reporting , operators :: [(Op, Assoc)] - , defs :: [Ann Comment (Name, Ann Comment Def)] + , defs :: [Ann (Name, Ann Def)] } deriving (Eq, Show) diff --git a/src/Facet/Surface/Term/Expr.hs b/src/Facet/Surface/Term/Expr.hs index ac524dbe8..868c7907f 100644 --- a/src/Facet/Surface/Term/Expr.hs +++ b/src/Facet/Surface/Term/Expr.hs @@ -19,28 +19,28 @@ data Expr = Var QName | Hole Name | Lam [Clause] - | App (Ann Comment Expr) (Ann Comment Expr) - | As (Ann Comment Expr) (Ann Comment Type) + | App (Ann Expr) (Ann Expr) + | As (Ann Expr) (Ann Type) | String Text deriving (Eq, Show) -data Clause = Clause (Ann Comment Pattern) (Ann Comment Expr) +data Clause = Clause (Ann Pattern) (Ann Expr) deriving (Eq, Show) -- Patterns data Pattern - = PVal (Ann Comment ValPattern) - | PEff (Ann Comment EffPattern) + = PVal (Ann ValPattern) + | PEff (Ann EffPattern) deriving (Eq, Show) data ValPattern = PWildcard | PVar Name - | PCon QName [Ann Comment ValPattern] + | PCon QName [Ann ValPattern] deriving (Eq, Show) -data EffPattern = POp QName [Ann Comment ValPattern] (Ann Comment ValPattern) +data EffPattern = POp QName [Ann ValPattern] (Ann ValPattern) deriving (Eq, Show) diff --git a/src/Facet/Surface/Type/Expr.hs b/src/Facet/Surface/Type/Expr.hs index 2a1cadecc..c07a20c0d 100644 --- a/src/Facet/Surface/Type/Expr.hs +++ b/src/Facet/Surface/Type/Expr.hs @@ -14,10 +14,10 @@ import Facet.Syntax data Type = TVar QName | TString - | TForAll Name Kind (Ann Comment Type) - | TArrow (Maybe Name) (Maybe Mul) (Ann Comment Type) (Ann Comment Type) - | TComp [Ann Comment (Interface (Ann Comment Type))] (Ann Comment Type) - | TApp (Ann Comment Type) (Ann Comment Type) + | TForAll Name Kind (Ann Type) + | TArrow (Maybe Name) (Maybe Mul) (Ann Type) (Ann Type) + | TComp [Ann (Interface (Ann Type))] (Ann Type) + | TApp (Ann Type) (Ann Type) deriving (Eq, Show) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 046ad14d8..89b43a0dd 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -155,39 +155,39 @@ type i ~> j = forall x . i x -> j x -- Annotations -data Ann c a = Ann +data Ann a = Ann { ann :: Span - , context :: Snoc (Span, c) + , context :: Snoc (Span, Comment) , out :: a } deriving (Foldable, Functor, Traversable) -instance Eq a => Eq (Ann c a) where +instance Eq a => Eq (Ann a) where (==) = (==) `on` out -instance Ord a => Ord (Ann c a) where +instance Ord a => Ord (Ann a) where compare = compare `on` out -instance Show a => Show (Ann c a) where +instance Show a => Show (Ann a) where showsPrec p = showsPrec p . out -instance HasSpan (Ann c a) where +instance HasSpan (Ann a) where span_ = ann_ -ann_ :: Lens' (Ann c a) Span +ann_ :: Lens' (Ann a) Span ann_ = lens ann (\ a ann -> a{ ann }) -context_ :: Lens (Ann c a) (Ann d a) (Snoc (Span, c)) (Snoc (Span, d)) +context_ :: Lens (Ann a) (Ann a) (Snoc (Span, Comment)) (Snoc (Span, Comment)) context_ = lens context (\ a context -> a{ context }) -out_ :: Lens (Ann c a) (Ann c b) a b +out_ :: Lens (Ann a) (Ann b) a b out_ = lens out (\ a out -> a{ out }) -annUnary :: (Ann c a -> a) -> Ann c a -> Ann c a +annUnary :: (Ann a -> a) -> Ann a -> Ann a annUnary f a = Ann (ann a) Nil (f a) -annBinary :: (Ann c a -> Ann c b -> a) -> Ann c a -> Ann c b -> Ann c a +annBinary :: (Ann a -> Ann b -> a) -> Ann a -> Ann b -> Ann a annBinary f a b = Ann (ann a <> ann b) Nil (f a b) From abf3a87994069970667f4569ab9aa1487eaaef43 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 2 Oct 2021 20:38:18 -0400 Subject: [PATCH 0448/1324] Bump fresnel. --- cabal.project | 3 +- cabal.project.ci | 3 +- src/Facet/Driver.hs | 1 + src/Facet/Elab.hs | 2 +- src/Facet/Elab/Term.hs | 6 ++-- src/Facet/Graph.hs | 3 +- src/Facet/Lens.hs | 72 ------------------------------------------ src/Facet/Module.hs | 2 +- src/Facet/Run.hs | 1 + 9 files changed, 14 insertions(+), 79 deletions(-) diff --git a/cabal.project b/cabal.project index 29d35e4f9..df6f3b3f6 100644 --- a/cabal.project +++ b/cabal.project @@ -4,4 +4,5 @@ tests: True source-repository-package type: git location: https://github.com/robrix/fresnel.git - tag: 77da2c71502f3943e741b9a96d0e330d8292a444 + tag: dbb1c34c93c72e9207d0d8a01226efa2ff2e08d9 + subdir: fresnel diff --git a/cabal.project.ci b/cabal.project.ci index 5adf94920..2aee5e62c 100644 --- a/cabal.project.ci +++ b/cabal.project.ci @@ -7,4 +7,5 @@ package facet source-repository-package type: git location: https://github.com/robrix/fresnel.git - tag: 77da2c71502f3943e741b9a96d0e330d8292a444 + tag: dbb1c34c93c72e9207d0d8a01226efa2ff2e08d9 + subdir: fresnel diff --git a/src/Facet/Driver.hs b/src/Facet/Driver.hs index a26fc1eef..2af2e07a3 100644 --- a/src/Facet/Driver.hs +++ b/src/Facet/Driver.hs @@ -50,6 +50,7 @@ import Facet.Source import Facet.Style import qualified Facet.Surface.Module as Import (Import(..)) import Facet.Syntax as S +import Fresnel.At (at) import Fresnel.Getter ((^.)) import Fresnel.Lens (Lens, Lens', lens) import Silkscreen diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index a46724e4a..d44a09133 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -65,7 +65,7 @@ import Facet.Functor.Synth import Facet.Graph as Graph import Facet.Interface import Facet.Kind -import Facet.Lens hiding (Index, use) +import Facet.Lens hiding (use) import Facet.Module import Facet.Name hiding (L, R) import Facet.Pattern diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 4caf8acf7..9d6d2e2a7 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -61,7 +61,7 @@ import Facet.Functor.Synth import Facet.Graph import Facet.Interface import Facet.Kind -import Facet.Lens as Lens (At(..), Ixed(..), locally, view, views, (.=), (<~)) +import Facet.Lens as Lens (locally, view, views, (.=), (<~)) import Facet.Module as Module import Facet.Name import Facet.Pattern @@ -79,6 +79,8 @@ import qualified Facet.Type.Expr as TX import Facet.Type.Norm as T hiding (global) import Facet.Unify import Facet.Usage hiding (restrict) +import Fresnel.At as At +import Fresnel.Ixed import Fresnel.Prism (Prism') import Fresnel.Review (review) import Fresnel.Setter (Setter') @@ -347,7 +349,7 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os t' <- runModule $ elabTermDef t <==: _T scope_.decls_.ix dname .= DTerm (Just t') _T -letrec :: (Has (State s) sig m, At a) => Setter' s a -> Lens.Index a -> Traversal' (Lens.IxValue a) b -> Lens.IxValue a -> m b -> m () +letrec :: (Has (State s) sig m, At a) => Setter' s a -> At.Index a -> Traversal' (IxValue a) b -> IxValue a -> m b -> m () letrec getter key projection initial final = do getter.at key .= Just initial getter.ix key.projection <~ final diff --git a/src/Facet/Graph.hs b/src/Facet/Graph.hs index e09179d5e..a24bb2dd3 100644 --- a/src/Facet/Graph.hs +++ b/src/Facet/Graph.hs @@ -26,13 +26,14 @@ import Data.Foldable (for_) import qualified Data.Map as Map import Data.Monoid (Endo(..)) import qualified Data.Set as Set -import Facet.Lens import Facet.Module import Facet.Name import Facet.Snoc import Facet.Snoc.NonEmpty (fromSnoc, toSnoc) import Facet.Syntax +import Fresnel.At import Fresnel.Iso +import Fresnel.Ixed newtype Graph = Graph { getGraph :: Map.Map MName (Maybe FilePath, Maybe Module) } deriving (Monoid, Semigroup) diff --git a/src/Facet/Lens.hs b/src/Facet/Lens.hs index 0ab233856..c06032bf3 100644 --- a/src/Facet/Lens.hs +++ b/src/Facet/Lens.hs @@ -13,27 +13,13 @@ module Facet.Lens , (.=) , modifying , assign -, (^?) -, preview -, previews -, ForgetF(..) -, At(..) -, Ixed(..) -, ixAt ) where -import Control.Applicative (Alternative(..)) import Control.Carrier.State.Church import Control.Effect.Reader -import qualified Data.IntMap as IntMap -import qualified Data.Map as Map -import Data.Profunctor (Choice(..), Profunctor(..)) -import Data.Profunctor.Traversing (traverse', wander) import qualified Fresnel.Getter as Getter import qualified Fresnel.Lens as Lens -import Fresnel.Optic import qualified Fresnel.Setter as Setter -import qualified Fresnel.Traversal as Traversal zoom :: Has (State s) sig m => Lens.Lens' s a -> StateC a m () -> m () zoom lens action = lens <~> (`execState` action) @@ -83,61 +69,3 @@ modifying o = modify . Setter.over o assign :: Has (State s) sig m => Setter.Setter s s a b -> b -> m () assign o = modify . Setter.set o - - -(^?) :: s -> Optic' (ForgetF Maybe a) s a -> Maybe a -(^?) = flip preview - -infixl 8 ^? - -preview :: Optic' (ForgetF Maybe a) s a -> s -> Maybe a -preview o = previews o id - -previews :: Optic' (ForgetF Maybe r) s a -> (a -> r) -> (s -> Maybe r) -previews o f = runForgetF (o (ForgetF (Just . f))) - - -newtype ForgetF f r a b = ForgetF { runForgetF :: a -> f r } - deriving (Functor) - -instance Profunctor (ForgetF f r) where - dimap f _ = ForgetF . lmap f . runForgetF - -instance Alternative f => Choice (ForgetF f r) where - left' (ForgetF r) = ForgetF (either r (const empty)) - right' (ForgetF r) = ForgetF (either (const empty) r) - - -class Ixed a where - type Index a - type IxValue a - - ix :: Index a -> Traversal.Traversal' a (IxValue a) - -instance Ord k => Ixed (Map.Map k v) where - type Index (Map.Map k v) = k - type IxValue (Map.Map k v) = v - ix k = wander $ \ f m -> case Map.lookup k m of - Just v -> fmap (\ v' -> Map.insert k v' m) (f v) - Nothing -> pure m - -instance Ixed (IntMap.IntMap v) where - type Index (IntMap.IntMap v) = IntMap.Key - type IxValue (IntMap.IntMap v) = v - ix k = wander $ \ f m -> case IntMap.lookup k m of - Just v -> fmap (\ v' -> IntMap.insert k v' m) (f v) - Nothing -> pure m - - -class Ixed a => At a where - at :: Index a -> Lens.Lens' a (Maybe (IxValue a)) - -instance Ord k => At (Map.Map k v) where - at k = Lens.lens (Map.lookup k) (\ m v -> maybe (Map.delete k m) (\ v -> Map.insert k v m) v) - -instance At (IntMap.IntMap v) where - at k = Lens.lens (IntMap.lookup k) (\ m v -> maybe (IntMap.delete k m) (\ v -> IntMap.insert k v m) v) - - -ixAt :: At a => Index a -> Traversal.Traversal' a (IxValue a) -ixAt i = at i . traverse' diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 165a05876..b8fd75c9b 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -37,11 +37,11 @@ import Data.Bitraversable import Data.Coerce import qualified Data.Map as Map import Facet.Kind -import Facet.Lens import Facet.Name import Facet.Syntax import Facet.Term.Expr import Facet.Type.Norm +import Fresnel.Fold (preview) import Fresnel.Iso (coerced) import Fresnel.Lens (Lens, Lens', lens) import Fresnel.Prism diff --git a/src/Facet/Run.hs b/src/Facet/Run.hs index 6d2772457..8adcbd392 100644 --- a/src/Facet/Run.hs +++ b/src/Facet/Run.hs @@ -16,6 +16,7 @@ import Facet.Lens import Facet.Print (quietOptions) import Facet.Source as Source import Facet.Style +import Fresnel.At import Fresnel.Getter ((^.)) import System.Exit From 690f6749c5682e64a3c83d3bd4e1c2a191eae80a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 5 Oct 2021 08:47:54 -0400 Subject: [PATCH 0449/1324] assertMatch takes a Prism. --- src/Facet/Elab.hs | 10 ++++++---- src/Facet/Elab/Term.hs | 22 +++++++++++----------- src/Facet/Elab/Type.hs | 10 +++++----- src/Facet/Kind.hs | 13 +++++++++++++ src/Facet/Type/Norm.hs | 21 +++++++++++++++++++++ 5 files changed, 56 insertions(+), 20 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index d44a09133..e2bb45317 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -82,7 +82,9 @@ import qualified Facet.Type.Expr as TX import Facet.Type.Norm as TN import Facet.Usage as Usage import Facet.Vars as Vars +import Fresnel.Fold ((^?)) import Fresnel.Lens (Lens', lens) +import Fresnel.Prism (Prism') import Fresnel.Review (review) import GHC.Stack import Prelude hiding (span, zipWith) @@ -282,11 +284,11 @@ warn reason = do -- Patterns -assertMatch :: (HasCallStack, Has (Throw Err) sig m, Classified t) => (t -> Maybe out) -> String -> t -> Elab m out -assertMatch pat exp _T = maybe (mismatch (Exp (Left exp)) (Act (review classified _T))) pure (pat _T) +assertMatch :: (HasCallStack, Has (Throw Err) sig m, Classified s) => Prism' s a -> String -> s -> Elab m a +assertMatch pat exp _T = maybe (mismatch (Exp (Left exp)) (Act (review classified _T))) pure (_T ^? pat) -assertFunction :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Maybe Name ::: (Quantity, Type), Type) -assertFunction = assertMatch (\case{ TN.Arrow n q t b -> pure (n ::: (q, t), b) ; _ -> Nothing }) "_ -> _" +assertFunction :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Maybe Name, Quantity, Type, Type) +assertFunction = assertMatch _Arrow "_ -> _" -- Unification diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 9d6d2e2a7..8ec47c89f 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -124,14 +124,14 @@ hole n = Check $ \ _T -> withFrozenCallStack $ err $ Hole n (CT _T) tlam :: (HasCallStack, Has (Throw Err) sig m) => Type <==: Elab m Term -> Type <==: Elab m Term tlam b = Check $ \ _T -> do - (n ::: _A, _B) <- assertQuantifier _T + (n, _A, _B) <- assertQuantifier _T d <- depth (zero, PVar (n :==> CK _A)) |- check (b ::: _B (T.free (LName (getUsed d) n))) lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern (Name :==> Classifier)), Type <==: Elab m Term)] -> Type <==: Elab m Term lam cs = Check $ \ _T -> do - (_A, _B) <- assertTacitFunction _T - Lam <$> traverse (\ (p, b) -> bind (p ::: _A) (check (b ::: _B))) cs + (_, q, _A, _B) <- assertTacitFunction _T + Lam <$> traverse (\ (p, b) -> bind (p ::: (q, _A)) (check (b ::: _B))) cs lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Classifier)) -> Type <==: Elab m Term -> Type <==: Elab m Term lam1 p b = lam [(p, b)] @@ -139,7 +139,7 @@ lam1 p b = lam [(p, b)] app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Elab m (a :==> Type)) -> (HasCallStack => Type <==: Elab m b) -> Elab m (c :==> Type) app mk operator operand = do f' :==> _F <- operator - (_ ::: (q, _A), _B) <- assertFunction _F + (_, q, _A, _B) <- assertFunction _F a' <- censor @Usage (q ><<) $ check (operand ::: _A) pure $ mk f' a' :==> _B @@ -182,7 +182,7 @@ varP n = Bind $ \ _A k -> k (PVar (n :==> CT (wrap _A))) conP :: (HasCallStack, Has (Throw Err) sig m) => QName -> [Bind m (Pattern (Name :==> Classifier))] -> Bind m (Pattern (Name :==> Classifier)) conP n fs = Bind $ \ _A k -> do n' :=: _ ::: _T <- resolveC n - _T' <- maybe (pure _T) (foldl' (\ _T _A -> ($ _A) . snd <$> (_T >>= assertQuantifier)) (pure _T) . snd) (unNeutral _A) + _T' <- maybe (pure _T) (foldl' (\ _T _A -> do t <- _T ; (_, _, b) <- assertQuantifier t ; pure (b _A)) (pure _T) . snd) (unNeutral _A) fs' <- runBind (fieldsP fs) _T' (\ (fs, _T) -> fs <$ unify (Exp _A) (Act _T)) k $ PCon n' (fromList fs') @@ -190,7 +190,7 @@ fieldsP :: (HasCallStack, Has (Throw Err) sig m) => [Bind m a] -> Bind m ([a], T fieldsP = foldr cons nil where cons p ps = Bind $ \ _A k -> do - (_ ::: (_, _A'), _A'') <- assertFunction _A + (_, _, _A', _A'') <- assertFunction _A runBind p _A' $ \ p' -> runBind ps _A'' (k . first (p' :)) nil = Bind $ \ _T k -> k ([], _T) @@ -357,16 +357,16 @@ letrec getter key projection initial final = do -- Errors -assertQuantifier :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Name ::: Kind, Type -> Type) -assertQuantifier = assertMatch (\case{ T.ForAll n t b -> pure (n ::: t, b) ; _ -> Nothing }) "{_} -> _" +assertQuantifier :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Name, Kind, Type -> Type) +assertQuantifier = assertMatch _ForAll "{_} -> _" -- | Expect a tacit (non-variable-binding) function type. -assertTacitFunction :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m ((Quantity, Type), Type) -assertTacitFunction = assertMatch (\case{ T.Arrow Nothing q t b -> pure ((q, t), b) ; _ -> Nothing }) "_ -> _" +assertTacitFunction :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Maybe Name, Quantity, Type, Type) +assertTacitFunction = assertMatch _Arrow "_ -> _" -- | Expect a computation type with effects. assertComp :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Signature Type, Type) -assertComp = assertMatch unComp "[_] _" +assertComp = assertMatch _Comp "[_] _" -- Elaboration diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 2bf9aba4c..9ee721957 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -2,7 +2,7 @@ module Facet.Elab.Type ( -- * Types tvar -, _String +, Facet.Elab.Type._String , forAll , synthType -- * Judgements @@ -64,7 +64,7 @@ arrow mk a b = do app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> Elab m (a :==> Kind) -> Elab m (b :==> Kind) -> Elab m (c :==> Kind) app mk f a = do f' :==> _F <- f - (_ ::: _A, _B) <- assertTypeConstructor _F + (_, _A, _B) <- assertTypeConstructor _F -- FIXME: assert that the usage is zero a' <- switch a <==: _A pure $ mk f' a' :==> _B @@ -81,7 +81,7 @@ comp s t = do synthType :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Type -> Elab m (TX.Type :==> Kind) synthType (S.Ann s _ e) = pushSpan s $ case e of S.TVar n -> tvar n - S.TString -> _String + S.TString -> Facet.Elab.Type._String S.TForAll n t b -> forAll (n ::: t) (synthType b) S.TArrow n q a b -> arrow (TX.Arrow n (maybe Many interpretMul q)) (synthType a) (synthType b) S.TComp s t -> comp (map synthInterface s) (synthType t) @@ -101,8 +101,8 @@ synthInterface (S.Ann s _ (S.Interface h sp)) = pushSpan s $ do -- Assertions -assertTypeConstructor :: (HasCallStack, Has (Throw Err) sig m) => Kind -> Elab m (Maybe Name ::: Kind, Kind) -assertTypeConstructor = assertMatch (\case{ KArrow n t b -> pure (n ::: t, b) ; _ -> Nothing }) "_ -> _" +assertTypeConstructor :: (HasCallStack, Has (Throw Err) sig m) => Kind -> Elab m (Maybe Name, Kind, Kind) +assertTypeConstructor = assertMatch _KArrow "_ -> _" -- Judgements diff --git a/src/Facet/Kind.hs b/src/Facet/Kind.hs index dd1d2e4f5..bd74153b2 100644 --- a/src/Facet/Kind.hs +++ b/src/Facet/Kind.hs @@ -1,8 +1,12 @@ module Facet.Kind ( Kind(..) +, _KType +, _KInterface +, _KArrow ) where import Facet.Name +import Fresnel.Prism (Prism', prism') -- Kinds @@ -11,3 +15,12 @@ data Kind | KInterface | KArrow (Maybe Name) Kind Kind deriving (Eq, Ord, Show) + +_KType :: Prism' Kind () +_KType = prism' (const KType) (\case{ KType -> Just () ; _ -> Nothing }) + +_KInterface :: Prism' Kind () +_KInterface = prism' (const KInterface) (\case{ KInterface -> Just () ; _ -> Nothing }) + +_KArrow :: Prism' Kind (Maybe Name, Kind, Kind) +_KArrow = prism' (\ (n, a, b) -> KArrow n a b) (\case{ KArrow n a b -> Just (n, a, b) ; _ -> Nothing }) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 404a918ac..5888ffb7e 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -2,6 +2,11 @@ module Facet.Type.Norm ( -- * Types Type(..) +, _String +, _ForAll +, _Arrow +, _Ne +, _Comp , global , free , metavar @@ -65,6 +70,22 @@ instance Quote Type TX.Type where Ne n sp -> foldl' (&) (TX.Var (toIndexed d n)) (flip TX.App . quote d <$> sp) +_String :: Prism' Type () +_String = prism' (const String) (\case{ String -> Just () ; _ -> Nothing }) + +_ForAll :: Prism' Type (Name, Kind, Type -> Type) +_ForAll = prism' (\ (n, k, b) -> ForAll n k b) (\case{ ForAll n k b -> Just (n, k, b) ; _ -> Nothing }) + +_Arrow :: Prism' Type (Maybe Name, Quantity, Type, Type) +_Arrow = prism' (\ (n, q, a, b) -> Arrow n q a b) (\case{ Arrow n q a b -> Just (n, q, a, b) ; _ -> Nothing }) + +_Ne :: Prism' Type (Var (Either Meta (LName Level)), Snoc Type) +_Ne = prism' (uncurry Ne) (\case{ Ne c ts -> Just (c, ts) ; _ -> Nothing }) + +_Comp :: Prism' Type (Signature Type, Type) +_Comp = prism' (uncurry Comp) (\case{ Comp sig t -> Just (sig, t) ; _ -> Nothing }) + + global :: RName -> Type global = var . Global From c2f5df2df98bf102e0de9899d28f9429bf6c07e1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 5 Oct 2021 08:57:31 -0400 Subject: [PATCH 0450/1324] Simplify classified down to just a function. --- src/Facet/Elab.hs | 3 +-- src/Facet/Type/Norm.hs | 6 +++--- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index e2bb45317..c16832fd8 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -85,7 +85,6 @@ import Facet.Vars as Vars import Fresnel.Fold ((^?)) import Fresnel.Lens (Lens', lens) import Fresnel.Prism (Prism') -import Fresnel.Review (review) import GHC.Stack import Prelude hiding (span, zipWith) @@ -285,7 +284,7 @@ warn reason = do -- Patterns assertMatch :: (HasCallStack, Has (Throw Err) sig m, Classified s) => Prism' s a -> String -> s -> Elab m a -assertMatch pat exp _T = maybe (mismatch (Exp (Left exp)) (Act (review classified _T))) pure (_T ^? pat) +assertMatch pat exp _T = maybe (mismatch (Exp (Left exp)) (Act (classified _T))) pure (_T ^? pat) assertFunction :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Maybe Name, Quantity, Type, Type) assertFunction = assertMatch _Arrow "_ -> _" diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 5888ffb7e..74850773c 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -116,13 +116,13 @@ data Classifier | CT Type class Classified t where - classified :: Prism' Classifier t + classified :: t -> Classifier instance Classified Kind where - classified = prism' CK (\case{ CK _K -> pure _K ; _ -> empty }) + classified = CK instance Classified Type where - classified = prism' CT (\case{ CT _T -> pure _T ; _ -> empty }) + classified = CT occursIn :: Meta -> Level -> Type -> Bool From 42f023bbae9d50e7d5ceb643539e1ba11f4e50ed Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 5 Oct 2021 09:13:06 -0400 Subject: [PATCH 0451/1324] :fire: the tagless final encoding of types. --- src/Facet/Term/Class.hs | 24 +----------------------- src/Facet/Term/Expr.hs | 24 ++++-------------------- src/Facet/Term/Norm.hs | 10 ---------- 3 files changed, 5 insertions(+), 53 deletions(-) diff --git a/src/Facet/Term/Class.hs b/src/Facet/Term/Class.hs index 78bd16d87..02c72af69 100644 --- a/src/Facet/Term/Class.hs +++ b/src/Facet/Term/Class.hs @@ -1,24 +1,2 @@ module Facet.Term.Class -( Term(..) -, lamA -) where - -import Data.Text (Text) -import Facet.Functor.Compose -import Facet.Name -import Facet.Pattern -import Facet.Syntax - -class Term r where - string :: Text -> r - con :: RName -> [r] -> r - lam :: [(Pattern Name, Pattern (Name :=: r) -> r)] -> r - var :: Var (LName Level) -> r - ($$) :: r -> r -> r - infixl 9 $$ - dict :: [RName :=: r] -> r - comp :: [RName :=: Name] -> (Pattern (Name :=: r) -> r) -> r - - -lamA :: (Applicative m, Applicative i, Term r) => (forall j . Applicative j => (i ~> j) -> [(Pattern Name, j (Pattern (Name :=: r)) -> m (j r))]) -> m (i r) -lamA b = fmap lam . traverse (traverse runC) <$> traverse (traverse ($ liftCInner id)) (b liftCOuter) +() where diff --git a/src/Facet/Term/Expr.hs b/src/Facet/Term/Expr.hs index cbc576a3e..ee9b73fce 100644 --- a/src/Facet/Term/Expr.hs +++ b/src/Facet/Term/Expr.hs @@ -3,14 +3,10 @@ module Facet.Term.Expr Term(..) ) where -import Control.Applicative (liftA2) -import Data.Text (Text) -import Data.Traversable (mapAccumL) -import Facet.Name -import Facet.Pattern -import Facet.Quote -import Facet.Syntax -import qualified Facet.Term.Class as C +import Data.Text (Text) +import Facet.Name +import Facet.Pattern +import Facet.Syntax -- Term expressions @@ -24,15 +20,3 @@ data Term | Let (Pattern Name) Term Term | Comp [RName :=: Name] Term -- ^ NB: the first argument is a specialization of @'Pattern' 'Name'@ to the 'PDict' constructor deriving (Eq, Ord, Show) - -instance C.Term (Quoter Term) where - string = pure . String - con n fs = Con n <$> sequenceA fs - lam b = Lam <$> traverse (sequenceA . uncurry clause) b - var v = Quoter (\ d -> Var (toIndexed d v)) - ($$) = liftA2 App - dict fs = Dict <$> traverse sequenceA fs - comp p b = Comp p <$> snd (clause (PDict p) b) - -clause :: Traversable t => t Name -> (t (Name :=: Quoter Term) -> Quoter Term) -> (t Name, Quoter Term) -clause p b = (p, Quoter (\ d -> let (_, p') = mapAccumL (\ d n -> (succ d, n :=: Free (LName (getUsed d) n))) d p in runQuoter d (b (fmap C.var <$> p')))) diff --git a/src/Facet/Term/Norm.hs b/src/Facet/Term/Norm.hs index 6585509f7..d774cb4a4 100644 --- a/src/Facet/Term/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -16,7 +16,6 @@ import Facet.Quote import Facet.Semialign (zipWithM) import Facet.Snoc import Facet.Syntax -import qualified Facet.Term.Class as C import qualified Facet.Term.Expr as X data Term @@ -28,15 +27,6 @@ data Term | Comp [RName :=: Name] (Pattern (Name :=: Term) -> Term) deriving (Eq, Ord, Show) via Quoting X.Term Term -instance C.Term Term where - string = String - con = Con - lam = Lam - var = (`Ne` Nil) - ($$) = napp - dict = Dict - comp = Comp - instance Quote Term X.Term where quote d = \case String s -> X.String s From f8c65846c0301da6a6929fa681c8024d9c43fc06 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 6 Dec 2021 00:31:38 -0500 Subject: [PATCH 0452/1324] Define a module for a normal-form sequent type. --- facet.cabal | 1 + src/Facet/Sequent/Norm.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Sequent/Norm.hs diff --git a/facet.cabal b/facet.cabal index c2fb7bd3e..d7eee6f51 100644 --- a/facet.cabal +++ b/facet.cabal @@ -114,6 +114,7 @@ library Facet.Run Facet.Semialign Facet.Semiring + Facet.Sequent.Norm Facet.Snoc Facet.Snoc.NonEmpty Facet.Source diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs new file mode 100644 index 000000000..9c6abfed3 --- /dev/null +++ b/src/Facet/Sequent/Norm.hs @@ -0,0 +1,2 @@ +module Facet.Sequent.Norm +() where From e46213eee293180c8c87eeb531f068fbda7218a1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 6 Dec 2021 00:38:15 -0500 Subject: [PATCH 0453/1324] =?UTF-8?q?Define=20normal-form=E2=80=93ish=20se?= =?UTF-8?q?quent=20calculus=20types.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Sequent/Norm.hs | 38 +++++++++++++++++++++++++++++++++++++- 1 file changed, 37 insertions(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index 9c6abfed3..fde4b3389 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -1,2 +1,38 @@ module Facet.Sequent.Norm -() where +( -- * Terms + Term(..) + -- * Coterms +, Coterm(..) + -- * Commands +, Command(..) +) where + +import Data.Text (Text) +import Facet.Name +import Facet.Pattern +import Facet.Syntax hiding (Var) +import qualified Facet.Syntax as Syntax + +-- Terms + +data Term + = Var (Syntax.Var (LName Level)) + | MuR (Coterm -> Command) + | FunR [(Pattern Name, Pattern (Name :=: Term) -> Term)] + | ConR RName [Term] + | StringR Text + | DictR [RName :=: Term] + | CompR [RName :=: Name] (Pattern (Name :=: Term) -> Term) + + +-- Coterms + +data Coterm + = Covar (Syntax.Var (LName Level)) + | MuL (Term -> Command) + | FunL Term Coterm + + +-- Commands + +data Command = Term :|: Coterm From 603fd2ef3bcb035e44e7544e7fc8751c3e2d8c45 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 6 Dec 2021 00:39:11 -0500 Subject: [PATCH 0454/1324] Define a module for an abstract interface for sequents. --- facet.cabal | 1 + src/Facet/Sequent/Class.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Sequent/Class.hs diff --git a/facet.cabal b/facet.cabal index d7eee6f51..d0fc5c241 100644 --- a/facet.cabal +++ b/facet.cabal @@ -114,6 +114,7 @@ library Facet.Run Facet.Semialign Facet.Semiring + Facet.Sequent.Class Facet.Sequent.Norm Facet.Snoc Facet.Snoc.NonEmpty diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs new file mode 100644 index 000000000..306a8ebba --- /dev/null +++ b/src/Facet/Sequent/Class.hs @@ -0,0 +1,2 @@ +module Facet.Sequent.Class +() where From f71b418a9f4bab1ab7575f85c95da2bddce4f995 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 6 Dec 2021 00:43:17 -0500 Subject: [PATCH 0455/1324] Tidy up some imports. --- src/Facet/Sequent/Norm.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index fde4b3389..ac24c8690 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -7,16 +7,15 @@ module Facet.Sequent.Norm , Command(..) ) where -import Data.Text (Text) -import Facet.Name -import Facet.Pattern -import Facet.Syntax hiding (Var) -import qualified Facet.Syntax as Syntax +import Data.Text (Text) +import Facet.Name +import Facet.Pattern +import Facet.Syntax -- Terms data Term - = Var (Syntax.Var (LName Level)) + = Var (Var (LName Level)) | MuR (Coterm -> Command) | FunR [(Pattern Name, Pattern (Name :=: Term) -> Term)] | ConR RName [Term] @@ -28,7 +27,7 @@ data Term -- Coterms data Coterm - = Covar (Syntax.Var (LName Level)) + = Covar (Var (LName Level)) | MuL (Term -> Command) | FunL Term Coterm From d1de23a87332dd81f72c70352c6a6a78272584d6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 6 Dec 2021 02:13:59 -0500 Subject: [PATCH 0456/1324] Define a class for terms, coterms, and commands. --- src/Facet/Sequent/Class.hs | 29 ++++++++++++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 306a8ebba..b2c0ed11d 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -1,2 +1,29 @@ +{-# LANGUAGE FunctionalDependencies #-} module Facet.Sequent.Class -() where +( Term(..) +) where + +import Data.Text (Text) +import Facet.Name (LName, Level, Name, RName) +import Facet.Pattern (Pattern) +import Facet.Syntax (Var, (:=:)) + +class Term term coterm command | coterm -> term command, term -> coterm command, command -> term coterm where + -- Terms + var :: Var (LName Level) -> term + µR :: (coterm -> command) -> term + funR :: [(Pattern Name, Pattern (Name :=: term) -> term)] -> term + conR :: RName -> term + stringR :: Text -> term + dictR :: [RName :=: term] -> term + compR :: [RName :=: Name] -> (Pattern (Name :=: term) -> term) -> term + + -- Coterms + covar :: Var (LName Level) -> coterm + µL :: (term -> command) -> coterm + funL :: term -> coterm -> coterm + + -- Commands + (|||) :: term -> coterm -> command + + infix 1 ||| From 58e9cba7ee75fc894595d8c8658e299d997febc3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 6 Dec 2021 02:16:02 -0500 Subject: [PATCH 0457/1324] Correct the type of conR. --- src/Facet/Sequent/Class.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index b2c0ed11d..3c88082ef 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -13,7 +13,7 @@ class Term term coterm command | coterm -> term command, term -> coterm command, var :: Var (LName Level) -> term µR :: (coterm -> command) -> term funR :: [(Pattern Name, Pattern (Name :=: term) -> term)] -> term - conR :: RName -> term + conR :: RName -> [term] -> term stringR :: Text -> term dictR :: [RName :=: term] -> term compR :: [RName :=: Name] -> (Pattern (Name :=: term) -> term) -> term From ae91f298401d0ca9d679a23f2359f4aed75d7197 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 6 Dec 2021 02:17:47 -0500 Subject: [PATCH 0458/1324] Define a Class.Term instance for Norm.Term. --- src/Facet/Sequent/Norm.hs | 25 +++++++++++++++++++++---- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index ac24c8690..a99ae8416 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -7,10 +7,11 @@ module Facet.Sequent.Norm , Command(..) ) where -import Data.Text (Text) -import Facet.Name -import Facet.Pattern -import Facet.Syntax +import Data.Text (Text) +import Facet.Name +import Facet.Pattern +import qualified Facet.Sequent.Class as Class +import Facet.Syntax -- Terms @@ -35,3 +36,19 @@ data Coterm -- Commands data Command = Term :|: Coterm + + +instance Class.Term Term Coterm Command where + var = Var + µR = MuR + funR = FunR + conR = ConR + stringR = StringR + dictR = DictR + compR = CompR + + covar = Covar + µL = MuL + funL = FunL + + (|||) = (:|:) From bda3c1bd5f73d1084fd117eb856b9bbcbab58438 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 6 Dec 2021 09:56:38 -0500 Subject: [PATCH 0459/1324] :memo: Quote. --- src/Facet/Quote.hs | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index 2d5415f17..8973dbef1 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -19,8 +19,20 @@ import Facet.Name (Level, Used(..)) -- Quotation +-- | @'Quote' v t@ relates (normalized) values in @v@ to terms in @t@. +-- +-- Values are expected to have been created by evaluating terms, and as such the properties +-- +-- prop> 'quote' 0 . eval 'mempty' = 'id' +-- prop> eval 'mempty' . 'quote' 0 = 'id' +-- +-- (i.e. that @'quote'@ is both a left and right inverse of @eval@) should hold for some specific value of @eval@, modulo any effects it performs. class Quote v t | v -> t where - quote :: Used -> v -> t + -- | Quote a value back to an equivalent term. + quote + :: Used -- ^ The level from which to start quoting. If the resulting term is to be used under @n :: 'Level'@ binders, pass @'Used' n@. + -> v -- ^ The value to quote. + -> t -- ^ An equivalent term. quoteBinder :: Quote v t => (Used -> u) -> Used -> (u -> v) -> t quoteBinder = quoteBinderWith quote From 7515399d4dc41bbd7d73cec438b72c9ce60341ac Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 6 Dec 2021 11:46:41 -0500 Subject: [PATCH 0460/1324] :memo: quoteBinderWith. --- src/Facet/Quote.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index 8973dbef1..ae3dc4428 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -37,7 +37,13 @@ class Quote v t | v -> t where quoteBinder :: Quote v t => (Used -> u) -> Used -> (u -> v) -> t quoteBinder = quoteBinderWith quote -quoteBinderWith :: (Used -> v -> t) -> (Used -> u) -> Used -> (u -> v) -> t +-- | Quote binding syntax using the given a quotation function. +quoteBinderWith + :: (Used -> v -> t) -- ^ Quotation of values back to termss. + -> (Used -> u) -- ^ Variable construction. + -> Used -- ^ The level that the term will be inserted at. + -> (u -> v) -- ^ The higher-order function mapping variables to normalized values. + -> t -- ^ A term representing the position in which the variable is bound. quoteBinderWith quote var d f = quote (succ d) (f (var d)) From 2ed9057eb57975e8c56cb72c110e8daa14c499d6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 6 Dec 2021 11:53:59 -0500 Subject: [PATCH 0461/1324] =?UTF-8?q?Add=20names=20to=20=C2=B5R.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Sequent/Class.hs | 2 +- src/Facet/Sequent/Norm.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 3c88082ef..14a1f7090 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -11,7 +11,7 @@ import Facet.Syntax (Var, (:=:)) class Term term coterm command | coterm -> term command, term -> coterm command, command -> term coterm where -- Terms var :: Var (LName Level) -> term - µR :: (coterm -> command) -> term + µR :: Name -> (coterm -> command) -> term funR :: [(Pattern Name, Pattern (Name :=: term) -> term)] -> term conR :: RName -> [term] -> term stringR :: Text -> term diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index a99ae8416..15d4480a5 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -17,7 +17,7 @@ import Facet.Syntax data Term = Var (Var (LName Level)) - | MuR (Coterm -> Command) + | MuR Name (Coterm -> Command) | FunR [(Pattern Name, Pattern (Name :=: Term) -> Term)] | ConR RName [Term] | StringR Text From b0d9eb8f9d9620470c6b27cfa98cf75e0710d5c8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 6 Dec 2021 11:54:31 -0500 Subject: [PATCH 0462/1324] =?UTF-8?q?Add=20names=20to=20=C2=B5L.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Sequent/Class.hs | 2 +- src/Facet/Sequent/Norm.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 14a1f7090..545961f84 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -20,7 +20,7 @@ class Term term coterm command | coterm -> term command, term -> coterm command, -- Coterms covar :: Var (LName Level) -> coterm - µL :: (term -> command) -> coterm + µL :: Name -> (term -> command) -> coterm funL :: term -> coterm -> coterm -- Commands diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index 15d4480a5..c7e668022 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -29,7 +29,7 @@ data Term data Coterm = Covar (Var (LName Level)) - | MuL (Term -> Command) + | MuL Name (Term -> Command) | FunL Term Coterm From d2477b4c748b18ea68c9363a11478c13e622b710 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 6 Dec 2021 13:12:46 -0500 Subject: [PATCH 0463/1324] Sketch out some expression types which we can quote to. --- src/Facet/Sequent/Norm.hs | 44 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index c7e668022..abe7a552b 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -8,8 +8,10 @@ module Facet.Sequent.Norm ) where import Data.Text (Text) +import Data.Traversable (mapAccumL) import Facet.Name import Facet.Pattern +import Facet.Quote import qualified Facet.Sequent.Class as Class import Facet.Syntax @@ -52,3 +54,45 @@ instance Class.Term Term Coterm Command where funL = FunL (|||) = (:|:) + + +instance Quote Term XTerm where + quote d = \case + Var v -> XVar (toIndexed d v) + MuR n b -> XMuR n (quoteBinder (Covar . Free . (`LName` n) . getUsed) d b) + FunR ps -> XFunR (map (uncurry clause) ps) + ConR n fs -> XConR n (map (quote d) fs) + StringR t -> XStringR t + DictR ops -> XDictR (map (fmap (quote d)) ops) + CompR i b -> XCompR i (snd (clause (PDict i) b)) + where + var d n = Var (Free (LName (getUsed d) n)) + clause p b = let (d', p') = mapAccumL (\ d n -> (succ d, n :=: var d n)) d p in (p, quote d' (b p')) + +instance Quote Coterm XCoterm where + quote d = \case + Covar v -> XCovar (toIndexed d v) + MuL n b -> XMuL n (quoteBinder (Var . Free . (`LName` n) . getUsed) d b) + FunL a b -> XFunL (quote d a) (quote d b) + +instance Quote Command XCommand where + quote d (term :|: coterm) = quote d term :||: quote d coterm + + +-- Expressions + +data XTerm + = XVar (Var (LName Index)) + | XMuR Name XCommand + | XFunR [(Pattern Name, XTerm)] + | XConR RName [XTerm] + | XStringR Text + | XDictR [RName :=: XTerm] + | XCompR [RName :=: Name] XTerm + +data XCoterm + = XCovar (Var (LName Index)) + | XMuL Name XCommand + | XFunL XTerm XCoterm + +data XCommand = XTerm :||: XCoterm From c11ea38bc40c06cc614b3a2becec00acefe2d1a7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 6 Dec 2021 13:13:48 -0500 Subject: [PATCH 0464/1324] Define a module for sequent core expressions. --- facet.cabal | 1 + src/Facet/Sequent/Expr.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Sequent/Expr.hs diff --git a/facet.cabal b/facet.cabal index d0fc5c241..68cc3a4af 100644 --- a/facet.cabal +++ b/facet.cabal @@ -115,6 +115,7 @@ library Facet.Semialign Facet.Semiring Facet.Sequent.Class + Facet.Sequent.Expr Facet.Sequent.Norm Facet.Snoc Facet.Snoc.NonEmpty diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs new file mode 100644 index 000000000..f5d1a784c --- /dev/null +++ b/src/Facet/Sequent/Expr.hs @@ -0,0 +1,2 @@ +module Facet.Sequent.Expr +() where From d661eea83733b649c3cfd3f38fc12d010fc2506d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 6 Dec 2021 13:17:57 -0500 Subject: [PATCH 0465/1324] Move the expressions to their own module. --- src/Facet/Sequent/Expr.hs | 37 +++++++++++++++++++++++++++++- src/Facet/Sequent/Norm.hs | 48 ++++++++++++--------------------------- 2 files changed, 51 insertions(+), 34 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index f5d1a784c..96147c1e9 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -1,2 +1,37 @@ module Facet.Sequent.Expr -() where +( -- * Terms + Term(..) + -- * Coterms +, Coterm(..) + -- * Commands +, Command(..) +) where + +import Data.Text (Text) +import Facet.Name +import Facet.Pattern +import Facet.Syntax + +-- Terms + +data Term + = Var (Var (LName Index)) + | MuR Name Command + | FunR [(Pattern Name, Term)] + | ConR RName [Term] + | StringR Text + | DictR [RName :=: Term] + | CompR [RName :=: Name] Term + + +-- Coterms + +data Coterm + = Covar (Var (LName Index)) + | MuL Name Command + | FunL Term Coterm + + +-- Commands + +data Command = Term :|: Coterm diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index abe7a552b..11dda67f2 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -13,6 +13,7 @@ import Facet.Name import Facet.Pattern import Facet.Quote import qualified Facet.Sequent.Class as Class +import qualified Facet.Sequent.Expr as X import Facet.Syntax -- Terms @@ -56,43 +57,24 @@ instance Class.Term Term Coterm Command where (|||) = (:|:) -instance Quote Term XTerm where +instance Quote Term X.Term where quote d = \case - Var v -> XVar (toIndexed d v) - MuR n b -> XMuR n (quoteBinder (Covar . Free . (`LName` n) . getUsed) d b) - FunR ps -> XFunR (map (uncurry clause) ps) - ConR n fs -> XConR n (map (quote d) fs) - StringR t -> XStringR t - DictR ops -> XDictR (map (fmap (quote d)) ops) - CompR i b -> XCompR i (snd (clause (PDict i) b)) + Var v -> X.Var (toIndexed d v) + MuR n b -> X.MuR n (quoteBinder (Covar . Free . (`LName` n) . getUsed) d b) + FunR ps -> X.FunR (map (uncurry clause) ps) + ConR n fs -> X.ConR n (map (quote d) fs) + StringR t -> X.StringR t + DictR ops -> X.DictR (map (fmap (quote d)) ops) + CompR i b -> X.CompR i (snd (clause (PDict i) b)) where var d n = Var (Free (LName (getUsed d) n)) clause p b = let (d', p') = mapAccumL (\ d n -> (succ d, n :=: var d n)) d p in (p, quote d' (b p')) -instance Quote Coterm XCoterm where +instance Quote Coterm X.Coterm where quote d = \case - Covar v -> XCovar (toIndexed d v) - MuL n b -> XMuL n (quoteBinder (Var . Free . (`LName` n) . getUsed) d b) - FunL a b -> XFunL (quote d a) (quote d b) + Covar v -> X.Covar (toIndexed d v) + MuL n b -> X.MuL n (quoteBinder (Var . Free . (`LName` n) . getUsed) d b) + FunL a b -> X.FunL (quote d a) (quote d b) -instance Quote Command XCommand where - quote d (term :|: coterm) = quote d term :||: quote d coterm - - --- Expressions - -data XTerm - = XVar (Var (LName Index)) - | XMuR Name XCommand - | XFunR [(Pattern Name, XTerm)] - | XConR RName [XTerm] - | XStringR Text - | XDictR [RName :=: XTerm] - | XCompR [RName :=: Name] XTerm - -data XCoterm - = XCovar (Var (LName Index)) - | XMuL Name XCommand - | XFunL XTerm XCoterm - -data XCommand = XTerm :||: XCoterm +instance Quote Command X.Command where + quote d (term :|: coterm) = quote d term X.:|: quote d coterm From f8426053ad6e081322c1db468f45bea3df90b2ff Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 6 Dec 2021 13:23:24 -0500 Subject: [PATCH 0466/1324] Use a single definition of Command. --- src/Facet/Sequent/Class.hs | 20 +++++++++++++++----- src/Facet/Sequent/Expr.hs | 20 ++++++++------------ src/Facet/Sequent/Norm.hs | 12 ++++++------ 3 files changed, 29 insertions(+), 23 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 545961f84..b6c05996d 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -1,6 +1,9 @@ {-# LANGUAGE FunctionalDependencies #-} module Facet.Sequent.Class -( Term(..) +( -- * Term abstraction + Term(..) + -- * Commands +, Command(..) ) where import Data.Text (Text) @@ -8,10 +11,12 @@ import Facet.Name (LName, Level, Name, RName) import Facet.Pattern (Pattern) import Facet.Syntax (Var, (:=:)) -class Term term coterm command | coterm -> term command, term -> coterm command, command -> term coterm where +-- * Term abstraction + +class Term term coterm | coterm -> term, term -> coterm where -- Terms var :: Var (LName Level) -> term - µR :: Name -> (coterm -> command) -> term + µR :: Name -> (coterm -> Command term coterm) -> term funR :: [(Pattern Name, Pattern (Name :=: term) -> term)] -> term conR :: RName -> [term] -> term stringR :: Text -> term @@ -20,10 +25,15 @@ class Term term coterm command | coterm -> term command, term -> coterm command, -- Coterms covar :: Var (LName Level) -> coterm - µL :: Name -> (term -> command) -> coterm + µL :: Name -> (term -> Command term coterm) -> coterm funL :: term -> coterm -> coterm -- Commands - (|||) :: term -> coterm -> command + (|||) :: term -> coterm -> Command term coterm infix 1 ||| + + +-- * Commands + +data Command term coterm = term :|: coterm diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 96147c1e9..6ab95bbfd 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -4,19 +4,20 @@ module Facet.Sequent.Expr -- * Coterms , Coterm(..) -- * Commands -, Command(..) +, C.Command(..) ) where -import Data.Text (Text) -import Facet.Name -import Facet.Pattern -import Facet.Syntax +import Data.Text (Text) +import Facet.Name +import Facet.Pattern +import qualified Facet.Sequent.Class as C +import Facet.Syntax -- Terms data Term = Var (Var (LName Index)) - | MuR Name Command + | MuR Name (C.Command Term Coterm) | FunR [(Pattern Name, Term)] | ConR RName [Term] | StringR Text @@ -28,10 +29,5 @@ data Term data Coterm = Covar (Var (LName Index)) - | MuL Name Command + | MuL Name (C.Command Term Coterm) | FunL Term Coterm - - --- Commands - -data Command = Term :|: Coterm diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index 11dda67f2..8ee7a75c1 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -20,7 +20,7 @@ import Facet.Syntax data Term = Var (Var (LName Level)) - | MuR Name (Coterm -> Command) + | MuR Name (Coterm -> Class.Command Term Coterm) | FunR [(Pattern Name, Pattern (Name :=: Term) -> Term)] | ConR RName [Term] | StringR Text @@ -32,7 +32,7 @@ data Term data Coterm = Covar (Var (LName Level)) - | MuL Name (Term -> Command) + | MuL Name (Term -> Class.Command Term Coterm) | FunL Term Coterm @@ -41,7 +41,7 @@ data Coterm data Command = Term :|: Coterm -instance Class.Term Term Coterm Command where +instance Class.Term Term Coterm where var = Var µR = MuR funR = FunR @@ -54,7 +54,7 @@ instance Class.Term Term Coterm Command where µL = MuL funL = FunL - (|||) = (:|:) + (|||) = (Class.:|:) instance Quote Term X.Term where @@ -76,5 +76,5 @@ instance Quote Coterm X.Coterm where MuL n b -> X.MuL n (quoteBinder (Var . Free . (`LName` n) . getUsed) d b) FunL a b -> X.FunL (quote d a) (quote d b) -instance Quote Command X.Command where - quote d (term :|: coterm) = quote d term X.:|: quote d coterm +instance Quote (Class.Command Term Coterm) (Class.Command X.Term X.Coterm) where + quote d (term Class.:|: coterm) = quote d term Class.:|: quote d coterm From 712e0a790b8fc2a2db0accae603177b20c64b9fa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 6 Dec 2021 13:25:09 -0500 Subject: [PATCH 0467/1324] Rename Command to :|:. --- src/Facet/Sequent/Class.hs | 10 +++++----- src/Facet/Sequent/Expr.hs | 6 +++--- src/Facet/Sequent/Norm.hs | 6 +++--- 3 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index b6c05996d..4ce3767e1 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -3,7 +3,7 @@ module Facet.Sequent.Class ( -- * Term abstraction Term(..) -- * Commands -, Command(..) +, (:|:)(..) ) where import Data.Text (Text) @@ -16,7 +16,7 @@ import Facet.Syntax (Var, (:=:)) class Term term coterm | coterm -> term, term -> coterm where -- Terms var :: Var (LName Level) -> term - µR :: Name -> (coterm -> Command term coterm) -> term + µR :: Name -> (coterm -> term :|: coterm) -> term funR :: [(Pattern Name, Pattern (Name :=: term) -> term)] -> term conR :: RName -> [term] -> term stringR :: Text -> term @@ -25,15 +25,15 @@ class Term term coterm | coterm -> term, term -> coterm where -- Coterms covar :: Var (LName Level) -> coterm - µL :: Name -> (term -> Command term coterm) -> coterm + µL :: Name -> (term -> term :|: coterm) -> coterm funL :: term -> coterm -> coterm -- Commands - (|||) :: term -> coterm -> Command term coterm + (|||) :: term -> coterm -> term :|: coterm infix 1 ||| -- * Commands -data Command term coterm = term :|: coterm +data term :|: coterm = term :|: coterm diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 6ab95bbfd..43ba5d824 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -4,7 +4,7 @@ module Facet.Sequent.Expr -- * Coterms , Coterm(..) -- * Commands -, C.Command(..) +, (C.:|:)(..) ) where import Data.Text (Text) @@ -17,7 +17,7 @@ import Facet.Syntax data Term = Var (Var (LName Index)) - | MuR Name (C.Command Term Coterm) + | MuR Name (Term C.:|: Coterm) | FunR [(Pattern Name, Term)] | ConR RName [Term] | StringR Text @@ -29,5 +29,5 @@ data Term data Coterm = Covar (Var (LName Index)) - | MuL Name (C.Command Term Coterm) + | MuL Name (Term C.:|: Coterm) | FunL Term Coterm diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index 8ee7a75c1..5b96c5879 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -20,7 +20,7 @@ import Facet.Syntax data Term = Var (Var (LName Level)) - | MuR Name (Coterm -> Class.Command Term Coterm) + | MuR Name (Coterm -> Term Class.:|: Coterm) | FunR [(Pattern Name, Pattern (Name :=: Term) -> Term)] | ConR RName [Term] | StringR Text @@ -32,7 +32,7 @@ data Term data Coterm = Covar (Var (LName Level)) - | MuL Name (Term -> Class.Command Term Coterm) + | MuL Name (Term -> Term Class.:|: Coterm) | FunL Term Coterm @@ -76,5 +76,5 @@ instance Quote Coterm X.Coterm where MuL n b -> X.MuL n (quoteBinder (Var . Free . (`LName` n) . getUsed) d b) FunL a b -> X.FunL (quote d a) (quote d b) -instance Quote (Class.Command Term Coterm) (Class.Command X.Term X.Coterm) where +instance Quote (Term Class.:|: Coterm) (X.Term Class.:|: X.Coterm) where quote d (term Class.:|: coterm) = quote d term Class.:|: quote d coterm From 36e44cf865c3322d7a55a866dfe5d5c2fdae8cd3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 6 Dec 2021 13:26:48 -0500 Subject: [PATCH 0468/1324] Generalize the Quote instance for :|:. --- src/Facet/Sequent/Class.hs | 5 +++++ src/Facet/Sequent/Norm.hs | 3 --- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 4ce3767e1..0efc8e285 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} module Facet.Sequent.Class ( -- * Term abstraction Term(..) @@ -9,6 +10,7 @@ module Facet.Sequent.Class import Data.Text (Text) import Facet.Name (LName, Level, Name, RName) import Facet.Pattern (Pattern) +import Facet.Quote (Quote(..)) import Facet.Syntax (Var, (:=:)) -- * Term abstraction @@ -37,3 +39,6 @@ class Term term coterm | coterm -> term, term -> coterm where -- * Commands data term :|: coterm = term :|: coterm + +instance (Quote term1 term2, Quote coterm1 coterm2) => Quote (term1 :|: coterm1) (term2 :|: coterm2) where + quote d (term :|: coterm) = quote d term :|: quote d coterm diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index 5b96c5879..1d30a0101 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -75,6 +75,3 @@ instance Quote Coterm X.Coterm where Covar v -> X.Covar (toIndexed d v) MuL n b -> X.MuL n (quoteBinder (Var . Free . (`LName` n) . getUsed) d b) FunL a b -> X.FunL (quote d a) (quote d b) - -instance Quote (Term Class.:|: Coterm) (X.Term Class.:|: X.Coterm) where - quote d (term Class.:|: coterm) = quote d term Class.:|: quote d coterm From 88a4a912fc4ec71fe5f1b01bd11be866044e31c3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 6 Dec 2021 13:29:21 -0500 Subject: [PATCH 0469/1324] Spacing. --- src/Facet/Sequent/Class.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 0efc8e285..1bb7b263e 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -40,5 +40,5 @@ class Term term coterm | coterm -> term, term -> coterm where data term :|: coterm = term :|: coterm -instance (Quote term1 term2, Quote coterm1 coterm2) => Quote (term1 :|: coterm1) (term2 :|: coterm2) where +instance (Quote term1 term2, Quote coterm1 coterm2) => Quote (term1 :|: coterm1) (term2 :|: coterm2) where quote d (term :|: coterm) = quote d term :|: quote d coterm From 82be89cc369ad7c98600b95a7ab7e8434a2f962a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 6 Dec 2021 13:41:20 -0500 Subject: [PATCH 0470/1324] Define Bifoldable, Bifunctor, and Bitraversable instances for :|:. --- src/Facet/Sequent/Class.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 1bb7b263e..231f127d0 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -7,6 +7,9 @@ module Facet.Sequent.Class , (:|:)(..) ) where +import Data.Bifoldable +import Data.Bifunctor +import Data.Bitraversable import Data.Text (Text) import Facet.Name (LName, Level, Name, RName) import Facet.Pattern (Pattern) @@ -42,3 +45,12 @@ data term :|: coterm = term :|: coterm instance (Quote term1 term2, Quote coterm1 coterm2) => Quote (term1 :|: coterm1) (term2 :|: coterm2) where quote d (term :|: coterm) = quote d term :|: quote d coterm + +instance Bifoldable (:|:) where + bifoldMap = bifoldMapDefault + +instance Bifunctor (:|:) where + bimap = bimapDefault + +instance Bitraversable (:|:) where + bitraverse f g (a :|: b) = (:|:) <$> f a <*> g b From 24b4ce7c249f8efca6e7b6ce6c840bd176c8f107 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 6 Dec 2021 14:08:03 -0500 Subject: [PATCH 0471/1324] :memo: Quoter. --- src/Facet/Quote.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index ae3dc4428..a37a38ed2 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -73,6 +73,9 @@ instance (Quote v t, Show t) => Show (Quoting t v) where -- Quoters +-- | 'Quoter' is used to construct first-order representations of syntax directly from higher-order APIs in final tagless style. +-- +-- This typically requires that quotation keep track of the current de Bruijn level, but this data is typically not recorded in ASTs. 'Quoter' instead constructs a function parameterized by the initial level, and thus passing around the current level as quoting proceeds in exactly the same manner as the reader monad. newtype Quoter a = Quoter (Used -> a) deriving (Applicative, Functor, Monad) From 0c446c7997588ab03fd98dc19e24ba2d18ae3f1b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 6 Dec 2021 14:15:27 -0500 Subject: [PATCH 0472/1324] :memo: binder. --- src/Facet/Quote.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index a37a38ed2..9866a2cc8 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -82,5 +82,9 @@ newtype Quoter a = Quoter (Used -> a) runQuoter :: Used -> Quoter a -> a runQuoter d (Quoter f) = f d -binder :: (Used -> Level -> a) -> (Quoter a -> Quoter b) -> Quoter b +-- | Build quoted first-order syntax from a higher-order representation. +binder + :: (Used -> Level -> a) -- ^ Constructor for variables in @a@. + -> (Quoter a -> Quoter b) -- ^ The binder's scope, represented as a Haskell function mapping variables' values to complete terms. + -> Quoter b -- ^ A 'Quoter' of the first-order term. binder with f = Quoter (\ d -> runQuoter (d + 1) (f (Quoter (`with` getUsed d)))) From f99f0a776e3b7c3d149cb84d71e10ea675629c16 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 8 Dec 2021 04:31:06 -0500 Subject: [PATCH 0473/1324] Define a Term instance for first-order terms. --- src/Facet/Sequent/Expr.hs | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 43ba5d824..e42539390 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -7,9 +7,12 @@ module Facet.Sequent.Expr , (C.:|:)(..) ) where +import Data.Bitraversable (bisequenceA) import Data.Text (Text) +import Data.Traversable (mapAccumL) import Facet.Name import Facet.Pattern +import Facet.Quote import qualified Facet.Sequent.Class as C import Facet.Syntax @@ -31,3 +34,28 @@ data Coterm = Covar (Var (LName Index)) | MuL Name (Term C.:|: Coterm) | FunL Term Coterm + + +instance C.Term (Quoter Term) (Quoter Coterm) where + var v = Quoter (\ d -> Var (toIndexed d v)) + µR n b = MuR n <$> binder (\ d d' -> covar n (toIndexed d d')) (bisequenceA . b) + funR ps = FunR <$> traverse (uncurry clause) ps + conR n fs = ConR n <$> sequenceA fs + stringR = pure . StringR + dictR i = DictR <$> traverse sequenceA i + compR i b = CompR <$> traverse pure i <*> fmap snd (clause (PDict i) b) + + covar v = Quoter (\ d -> Covar (toIndexed d v)) + µL n b = MuL n <$> binder (\ d d' -> var n (toIndexed d d')) (bisequenceA . b) + funL a b = FunL <$> a <*> b + + (|||) = (C.:|:) + +var :: Name -> Index -> Term +var n i = Var (Free (LName i n)) + +covar :: Name -> Index -> Coterm +covar n i = Covar (Free (LName i n)) + +clause :: Pattern Name -> (Pattern (Name :=: Quoter Term) -> Quoter Term) -> Quoter (Pattern Name, Term) +clause p b = Quoter (\ d -> let (d', p') = mapAccumL (\ d' n -> (succ d', n :=: Quoter (\ d -> var n (toIndexed d (getUsed d'))))) d p in (p, runQuoter d' (b p'))) From b67a5a777a8c626ee2cd172e2403b78a5ebddbdf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 8 Dec 2021 04:32:28 -0500 Subject: [PATCH 0474/1324] Suggestive parens. --- src/Facet/Quote.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index 9866a2cc8..daaebe705 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -34,7 +34,7 @@ class Quote v t | v -> t where -> v -- ^ The value to quote. -> t -- ^ An equivalent term. -quoteBinder :: Quote v t => (Used -> u) -> Used -> (u -> v) -> t +quoteBinder :: Quote v t => (Used -> u) -> (Used -> (u -> v) -> t) quoteBinder = quoteBinderWith quote -- | Quote binding syntax using the given a quotation function. @@ -48,12 +48,12 @@ quoteBinderWith quote var d f = quote (succ d) (f (var d)) class Quote1 v t | v -> t where - liftQuoteWith :: (Used -> u -> s) -> Used -> v u -> t s + liftQuoteWith :: (Used -> u -> s) -> (Used -> v u -> t s) -quote1 :: (Quote u s, Quote1 v t) => Used -> v u -> t s +quote1 :: (Quote u s, Quote1 v t) => (Used -> v u -> t s) quote1 = liftQuoteWith quote -liftQuoteBinderWith :: Quote1 v t => (Used -> u -> s) -> (Used -> r) -> Used -> (r -> v u) -> t s +liftQuoteBinderWith :: Quote1 v t => (Used -> u -> s) -> (Used -> r) -> (Used -> (r -> v u) -> t s) liftQuoteBinderWith = quoteBinderWith . liftQuoteWith From 963173fa80d5549d6096064b18d1b43dc9b80274 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 8 Dec 2021 05:05:56 -0500 Subject: [PATCH 0475/1324] Abbreviate the compR case. --- src/Facet/Sequent/Expr.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index e42539390..4aa6606ec 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -43,7 +43,7 @@ instance C.Term (Quoter Term) (Quoter Coterm) where conR n fs = ConR n <$> sequenceA fs stringR = pure . StringR dictR i = DictR <$> traverse sequenceA i - compR i b = CompR <$> traverse pure i <*> fmap snd (clause (PDict i) b) + compR i b = CompR i . snd <$> clause (PDict i) b covar v = Quoter (\ d -> Covar (toIndexed d v)) µL n b = MuL n <$> binder (\ d d' -> var n (toIndexed d d')) (bisequenceA . b) From 343e13ca4afb045bd642a5e1ed7a9e2696781b32 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 8 Dec 2021 09:46:46 -0500 Subject: [PATCH 0476/1324] Quote returns in Quoter. --- src/Facet/Elab.hs | 2 +- src/Facet/Eval.hs | 16 ++++++++-------- src/Facet/Polarized.hs | 25 +++++++++++++------------ src/Facet/Print.hs | 2 +- src/Facet/Quote.hs | 34 ++++++++++++++++------------------ src/Facet/REPL.hs | 2 +- src/Facet/Sequent/Class.hs | 3 ++- src/Facet/Sequent/Expr.hs | 4 ++-- src/Facet/Sequent/Norm.hs | 29 ++++++++++++++++------------- src/Facet/Term/Norm.hs | 17 +++++++++-------- src/Facet/Type/Expr.hs | 2 +- src/Facet/Type/Norm.hs | 15 +++++++-------- src/Facet/Unify.hs | 2 +- test/Facet/Core/Type/Test.hs | 2 +- 14 files changed, 79 insertions(+), 76 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index c16832fd8..52e316468 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -338,7 +338,7 @@ elabTerm :: Has (Reader Graph :+: Reader Module :+: Reader Source) sig m => Elab elabTerm = elabWith one (const pure) elabSynthTerm :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (Term :==> Type) -> m (Term :==> Type) -elabSynthTerm = elabWith one (\ subst (e :==> _T) -> pure (e :==> TN.eval subst Env.empty (quote 0 _T))) +elabSynthTerm = elabWith one (\ subst (e :==> _T) -> pure (e :==> TN.eval subst Env.empty (runQuoter 0 (quote _T)))) elabSynthType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (TX.Type :==> Kind) -> m (Type :==> Kind) elabSynthType = elabWith zero (\ subst (_T :==> _K) -> pure (TN.eval subst Env.empty _T :==> _K)) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index a94e2f10b..06326014d 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -133,14 +133,14 @@ data Value m | VComp [RName :=: Name] Term instance Monad m => Quote (Value m) (m Term) where - quote d = \case - VLam _ cs -> pure $ Lam cs - VCont k -> quote (succ d) =<< k (VVar (Free (LName (getUsed d) __))) - VVar v -> pure (Var (toIndexed d v)) - VCon n fs -> Con n <$> traverse (quote d) fs - VString s -> pure $ String s - VDict os -> Dict <$> traverse (traverse (quote d)) os - VComp p b -> pure $ Comp p b + quote = \case + VLam _ cs -> pure . pure $ Lam cs + VCont k -> Quoter (\ d -> runQuoter (succ d) . quote =<< k (VVar (Free (LName (getUsed d) __)))) + VVar v -> Quoter (\ d -> pure (Var (toIndexed d v))) + VCon n fs -> fmap (Con n) . sequenceA <$> traverse quote fs + VString s -> pure . pure $ String s + VDict os -> fmap Dict . traverse sequenceA <$> traverse (traverse quote) os + VComp p b -> pure . pure $ Comp p b unit :: Value m unit = VCon (NE.FromList ["Data", "Unit"] :.: U "unit") [] diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 972941bb1..c6aaf8d55 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -19,6 +19,7 @@ module Facet.Polarized , eval1 ) where +import Control.Applicative (liftA2) import Control.Carrier.Reader import Data.Foldable (foldl') import Data.Function (on) @@ -52,16 +53,16 @@ infixr 7 :>< infixl 2 :>- instance Quote Type XType where - quote d = \case - TVar k d' -> XTVar k (toIndexed d d') - Up t -> XUp (quote d t) - Bot -> XBot - a :-> b -> quote d a :->: quote d b - ForAll k b -> XForAll k (quoteBinder (TVar k . getUsed) d b) - Down t -> XDown (quote d t) - One -> XOne - a :>< b -> quote d a :><: quote d b - b :>- a -> quote d b :>-: quote d a + quote = \case + TVar k d' -> Quoter (\ d -> XTVar k (toIndexed d d')) + Up t -> XUp <$> quote t + Bot -> pure XBot + a :-> b -> liftA2 (:->:) (quote a) (quote b) + ForAll k b -> XForAll k <$> quoteBinder (Quoter (TVar k . getUsed)) b + Down t -> XDown <$> quote t + One -> pure XOne + a :>< b -> liftA2 (:><:) (quote a) (quote b) + b :>- a -> liftA2 (:>-:) (quote b) (quote a) data XType @@ -159,8 +160,8 @@ quoteV lv lk = \case App v -> CApp (quoteV lv lk v) Inst t -> CInst t Ret i -> const (CRet (toIndexed lk i))) (CRet (Index 0)) sp) - TLam k f -> CTLam k (quoteBinderWith (`quoteV` lk) (TVar k . getUsed) lv f) - Lam f -> CLam (quoteBinderWith (`quoteV` lk) (vvar . getUsed) lv f) + TLam k f -> CTLam k (quoteV (succ lv) lk (f (TVar k (getUsed lv)))) + Lam f -> CLam (quoteV (succ lv) lk (f (vvar (getUsed lv)))) vvar :: Level -> V diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 021dafda8..f196fab37 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -176,7 +176,7 @@ instance Printable Print where print _ _ = id instance (Quote v t, Printable t) => Printable (Quoting t v) where - print opts env = print opts env . quote (level env) . getQuoting + print opts env = print opts env . runQuoter (level env) . quote . getQuoting instance Printable TN.Classifier where print opts env = \case diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index daaebe705..1db167013 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -30,30 +30,28 @@ import Facet.Name (Level, Used(..)) class Quote v t | v -> t where -- | Quote a value back to an equivalent term. quote - :: Used -- ^ The level from which to start quoting. If the resulting term is to be used under @n :: 'Level'@ binders, pass @'Used' n@. - -> v -- ^ The value to quote. - -> t -- ^ An equivalent term. + :: v -- ^ The value to quote. + -> Quoter t -- ^ A 'Quoter' producing an equivalent term. -quoteBinder :: Quote v t => (Used -> u) -> (Used -> (u -> v) -> t) +quoteBinder :: Quote v t => Quoter u -> ((u -> v) -> Quoter t) quoteBinder = quoteBinderWith quote -- | Quote binding syntax using the given a quotation function. quoteBinderWith - :: (Used -> v -> t) -- ^ Quotation of values back to termss. - -> (Used -> u) -- ^ Variable construction. - -> Used -- ^ The level that the term will be inserted at. - -> (u -> v) -- ^ The higher-order function mapping variables to normalized values. - -> t -- ^ A term representing the position in which the variable is bound. -quoteBinderWith quote var d f = quote (succ d) (f (var d)) + :: (v -> Quoter t) -- ^ Quotation of values back to termss. + -> Quoter u -- ^ Variable construction. + -> (u -> v) -- ^ The higher-order function mapping variables to normalized values. + -> Quoter t -- ^ A term representing the position in which the variable is bound. +quoteBinderWith quote var f = Quoter (\ d -> runQuoter (succ d) (quote (f (runQuoter d var)))) class Quote1 v t | v -> t where - liftQuoteWith :: (Used -> u -> s) -> (Used -> v u -> t s) + liftQuoteWith :: (u -> Quoter s) -> (v u -> Quoter (t s)) -quote1 :: (Quote u s, Quote1 v t) => (Used -> v u -> t s) +quote1 :: (Quote u s, Quote1 v t) => (v u -> Quoter (t s)) quote1 = liftQuoteWith quote -liftQuoteBinderWith :: Quote1 v t => (Used -> u -> s) -> (Used -> r) -> (Used -> (r -> v u) -> t s) +liftQuoteBinderWith :: Quote1 v t => (u -> Quoter s) -> Quoter r -> ((r -> v u) -> Quoter (t s)) liftQuoteBinderWith = quoteBinderWith . liftQuoteWith @@ -62,13 +60,13 @@ liftQuoteBinderWith = quoteBinderWith . liftQuoteWith newtype Quoting t v = Quoting { getQuoting :: v } instance (Quote v t, Eq t) => Eq (Quoting t v) where - Quoting a == Quoting b = quote 0 a == quote 0 b + Quoting a == Quoting b = runQuoter 0 (quote a) == runQuoter 0 (quote b) instance (Quote v t, Ord t) => Ord (Quoting t v) where - Quoting a `compare` Quoting b = quote 0 a `compare` quote 0 b + Quoting a `compare` Quoting b = runQuoter 0 (quote a) `compare` runQuoter 0 (quote b) instance (Quote v t, Show t) => Show (Quoting t v) where - showsPrec p = showsPrec p . quote 0 . getQuoting + showsPrec p = showsPrec p . runQuoter 0 . quote . getQuoting -- Quoters @@ -84,7 +82,7 @@ runQuoter d (Quoter f) = f d -- | Build quoted first-order syntax from a higher-order representation. binder - :: (Used -> Level -> a) -- ^ Constructor for variables in @a@. + :: (Level -> Quoter a) -- ^ Constructor for variables in @a@. -> (Quoter a -> Quoter b) -- ^ The binder's scope, represented as a Haskell function mapping variables' values to complete terms. -> Quoter b -- ^ A 'Quoter' of the first-order term. -binder with f = Quoter (\ d -> runQuoter (d + 1) (f (Quoter (`with` getUsed d)))) +binder with f = Quoter (\ d -> runQuoter (d + 1) (f (with (getUsed d)))) diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index b8d9adfad..52efd64b3 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -208,7 +208,7 @@ showEval e = Action $ do outputDocLn (getPrint (ann (Print.print opts mempty e'' ::: Print.print opts mempty _T))) runEvalMain :: (Has (Error (Notice.Notice (Doc Style)) :+: Output :+: Reader Graph :+: Reader Module :+: State Options) sig m, MonadFail m) => Term -> m Term -runEvalMain e = runEval (quote 0 =<< runReader mempty (eval e)) pure +runEvalMain e = runEval (runQuoter 0 . quote =<< runReader mempty (eval e)) pure -- where -- hdl = [(write, Handler handle)] -- write = fromList ["Effect", "Console"] :.: U "write" diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 231f127d0..b286f5b04 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -7,6 +7,7 @@ module Facet.Sequent.Class , (:|:)(..) ) where +import Control.Applicative (liftA2) import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable @@ -44,7 +45,7 @@ class Term term coterm | coterm -> term, term -> coterm where data term :|: coterm = term :|: coterm instance (Quote term1 term2, Quote coterm1 coterm2) => Quote (term1 :|: coterm1) (term2 :|: coterm2) where - quote d (term :|: coterm) = quote d term :|: quote d coterm + quote (term :|: coterm) = liftA2 (:|:) (quote term) (quote coterm) instance Bifoldable (:|:) where bifoldMap = bifoldMapDefault diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 4aa6606ec..16261a01d 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -38,7 +38,7 @@ data Coterm instance C.Term (Quoter Term) (Quoter Coterm) where var v = Quoter (\ d -> Var (toIndexed d v)) - µR n b = MuR n <$> binder (\ d d' -> covar n (toIndexed d d')) (bisequenceA . b) + µR n b = MuR n <$> binder (\ d' -> Quoter (\ d -> covar n (toIndexed d d'))) (bisequenceA . b) funR ps = FunR <$> traverse (uncurry clause) ps conR n fs = ConR n <$> sequenceA fs stringR = pure . StringR @@ -46,7 +46,7 @@ instance C.Term (Quoter Term) (Quoter Coterm) where compR i b = CompR i . snd <$> clause (PDict i) b covar v = Quoter (\ d -> Covar (toIndexed d v)) - µL n b = MuL n <$> binder (\ d d' -> var n (toIndexed d d')) (bisequenceA . b) + µL n b = MuL n <$> binder (\ d' -> Quoter (\ d -> var n (toIndexed d d'))) (bisequenceA . b) funL a b = FunL <$> a <*> b (|||) = (C.:|:) diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index 1d30a0101..a0ebab20a 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -7,6 +7,7 @@ module Facet.Sequent.Norm , Command(..) ) where +import Control.Applicative (liftA2) import Data.Text (Text) import Data.Traversable (mapAccumL) import Facet.Name @@ -58,20 +59,22 @@ instance Class.Term Term Coterm where instance Quote Term X.Term where - quote d = \case - Var v -> X.Var (toIndexed d v) - MuR n b -> X.MuR n (quoteBinder (Covar . Free . (`LName` n) . getUsed) d b) - FunR ps -> X.FunR (map (uncurry clause) ps) - ConR n fs -> X.ConR n (map (quote d) fs) - StringR t -> X.StringR t - DictR ops -> X.DictR (map (fmap (quote d)) ops) - CompR i b -> X.CompR i (snd (clause (PDict i) b)) + quote = \case + Var v -> Quoter (\ d -> X.Var (toIndexed d v)) + MuR n b -> X.MuR n <$> quoteBinder (Quoter (\ d -> Covar (Free (LName (getUsed d) n)))) b + FunR ps -> X.FunR <$> traverse (uncurry clause) ps + ConR n fs -> X.ConR n <$> traverse quote fs + StringR t -> pure (X.StringR t) + DictR ops -> X.DictR <$> traverse (traverse quote) ops + CompR i b -> X.CompR i . snd <$> clause (PDict i) b where var d n = Var (Free (LName (getUsed d) n)) - clause p b = let (d', p') = mapAccumL (\ d n -> (succ d, n :=: var d n)) d p in (p, quote d' (b p')) + clause :: Pattern Name -> (Pattern (Name :=: Term) -> Term) -> Quoter (Pattern Name, X.Term) + clause p b = Quoter (\ d -> let (_, p') = mapAccumL (\ d' n -> (succ d', n :=: var d' n)) d p in (p, runQuoter d (quote (b p')))) + instance Quote Coterm X.Coterm where - quote d = \case - Covar v -> X.Covar (toIndexed d v) - MuL n b -> X.MuL n (quoteBinder (Var . Free . (`LName` n) . getUsed) d b) - FunL a b -> X.FunL (quote d a) (quote d b) + quote = \case + Covar v -> Quoter (\ d -> X.Covar (toIndexed d v)) + MuL n b -> X.MuL n <$> quoteBinder (Quoter (\ d -> Var (Free (LName (getUsed d) n)))) b + FunL a b -> liftA2 X.FunL (quote a) (quote b) diff --git a/src/Facet/Term/Norm.hs b/src/Facet/Term/Norm.hs index d774cb4a4..ff5fb2051 100644 --- a/src/Facet/Term/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -28,15 +28,16 @@ data Term deriving (Eq, Ord, Show) via Quoting X.Term Term instance Quote Term X.Term where - quote d = \case - String s -> X.String s - Con n sp -> X.Con n (quote d <$> sp) - Lam cs -> X.Lam (map (uncurry clause) cs) - Ne v sp -> foldl' (\ h -> X.App h . quote d) (X.Var (toIndexed d v)) sp - Dict os -> X.Dict (map (fmap (quote d)) os) - Comp p b -> X.Comp p (snd (clause (PDict p) b)) + quote = \case + String s -> pure (X.String s) + Con n sp -> X.Con n <$> traverse quote sp + Lam cs -> X.Lam <$> traverse (uncurry clause) cs + Ne v sp -> foldl' (\ h t -> X.App <$> h <*> quote t) (Quoter (\ d -> X.Var (toIndexed d v))) sp + Dict os -> X.Dict <$> traverse (traverse quote) os + Comp p b -> X.Comp p . snd <$> clause (PDict p) b where - clause p b = let (d', p') = mapAccumL (\ d n -> (succ d, n :=: Ne (Free (LName (getUsed d) n)) Nil)) d p in (p, quote d' (b p')) + clause :: Traversable t => t Name -> (t (Name :=: Term) -> Term) -> Quoter (t Name, X.Term) + clause p b = Quoter (\ d -> let (d', p') = mapAccumL (\ d n -> (succ d, n :=: Ne (Free (LName (getUsed d) n)) Nil)) d p in (p, runQuoter d' (quote (b p')))) norm :: Env Term -> X.Term -> Term norm env = \case diff --git a/src/Facet/Type/Expr.hs b/src/Facet/Type/Expr.hs index dd0922eab..2f8e65e7c 100644 --- a/src/Facet/Type/Expr.hs +++ b/src/Facet/Type/Expr.hs @@ -22,7 +22,7 @@ data Type instance C.Type (Quoter Type) where string = pure String - forAll n k b = ForAll n k <$> binder (\ d d' -> lvar n (toIndexed d d')) b + forAll n k b = ForAll n k <$> binder (\ d' -> Quoter (\ d -> lvar n (toIndexed d d'))) b arrow n q = liftA2 (Arrow n q) var v = Quoter (\ d -> Var (toIndexed d v)) ($$) = liftA2 App diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 74850773c..5527aafe7 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -25,7 +25,6 @@ module Facet.Type.Norm import Control.Effect.Empty import Data.Foldable (foldl') -import Data.Function ((&)) import Data.Maybe (fromMaybe) import Facet.Env hiding (empty) import Facet.Interface @@ -62,12 +61,12 @@ instance C.Type Type where (|-) = Comp instance Quote Type TX.Type where - quote d = \case - String -> TX.String - ForAll n t b -> TX.ForAll n t (quote (succ d) (b (free (LName (getUsed d) n)))) - Arrow n q a b -> TX.Arrow n q (quote d a) (quote d b) - Comp s t -> TX.Comp (mapSignature (quote d) s) (quote d t) - Ne n sp -> foldl' (&) (TX.Var (toIndexed d n)) (flip TX.App . quote d <$> sp) + quote = \case + String -> pure TX.String + ForAll n t b -> Quoter (\ d -> TX.ForAll n t (runQuoter (succ d) (quote (b (free (LName (getUsed d) n)))))) + Arrow n q a b -> TX.Arrow n q <$> quote a <*> quote b + Comp s t -> TX.Comp <$> traverseSignature quote s <*> quote t + Ne n sp -> foldl' (\ h t -> TX.App <$> h <*> quote t) (Quoter (\ d -> TX.Var (toIndexed d n))) sp _String :: Prism' Type () @@ -163,4 +162,4 @@ eval subst = go where TX.App f a -> go env f $$ go env a apply :: HasCallStack => Subst Type -> Env Type -> Type -> Type -apply subst env = eval subst env . quote (level env) +apply subst env = eval subst env . runQuoter (level env) . quote diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index d2e53eec8..82e2fa3ad 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -70,7 +70,7 @@ unifyType = curry $ \case (TN.String, TN.String) -> pure TN.String (TN.String, _) -> mismatch where - mkForAll d n k b = TX.ForAll n k (quote (succ d) b) + mkForAll d n k b = TX.ForAll n k (runQuoter (succ d) (quote b)) unifyKind :: Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m => Kind -> Kind -> m Kind unifyKind k1 k2 = if k1 == k2 then pure k2 else mismatch diff --git a/test/Facet/Core/Type/Test.hs b/test/Facet/Core/Type/Test.hs index b0e0191fb..689470336 100644 --- a/test/Facet/Core/Type/Test.hs +++ b/test/Facet/Core/Type/Test.hs @@ -19,4 +19,4 @@ tests = checkParallel $$(discover) prop_quotation_inverse = property $ do let init = ForAll (U "A") KType (Arrow (Just (U "x")) Many (Var (Free (Right (LName 0 (U "A"))))) (Comp mempty (Var (Free (Right (LName 0 (U "A"))))))) - quote 0 (eval mempty empty init) === init + runQuoter 0 (quote (eval mempty empty init)) === init From 9ce37f46c56fc8407677d2339b27d0f99bef883a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 8 Dec 2021 10:08:44 -0500 Subject: [PATCH 0477/1324] Define elaboration of applications into sequents. --- src/Facet/Elab/Term.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 8ec47c89f..29ab48ff6 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -10,6 +10,7 @@ module Facet.Elab.Term , tlam , lam , app +, appS , string , let' , comp @@ -66,6 +67,7 @@ import Facet.Module as Module import Facet.Name import Facet.Pattern import Facet.Semiring (Few(..), zero, (><<)) +import qualified Facet.Sequent.Class as S import Facet.Snoc import Facet.Snoc.NonEmpty as NE import Facet.Source (Source) @@ -143,6 +145,13 @@ app mk operator operand = do a' <- censor @Usage (q ><<) $ check (operand ::: _A) pure $ mk f' a' :==> _B +appS :: (HasCallStack, Has (Throw Err) sig m) => S.Term t c => (HasCallStack => Elab m (t :==> Type)) -> (HasCallStack => Type <==: Elab m t) -> Elab m (t :==> Type) +appS f a = do + f' :==> _F <- f + (_, q, _A, _B) <- assertFunction _F + a' <- censor @Usage (q ><<) $ check (a ::: _A) + pure $ S.µR __ (\ k -> f' S.:|: S.funL a' k) :==> _B + string :: Text -> Elab m (Term :==> Type) string s = pure $ E.String s :==> T.String From c7f28ca2535d5f251560a86f1491ed92fc921a67 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 8 Dec 2021 10:11:18 -0500 Subject: [PATCH 0478/1324] Elaborate strings to sequents. --- src/Facet/Elab/Term.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 29ab48ff6..e24ce16b0 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -12,6 +12,7 @@ module Facet.Elab.Term , app , appS , string +, stringS , let' , comp -- * Pattern combinators @@ -156,6 +157,9 @@ appS f a = do string :: Text -> Elab m (Term :==> Type) string s = pure $ E.String s :==> T.String +stringS :: S.Term t c => Text -> Elab m (t :==> Type) +stringS s = pure $ S.stringR s :==> T.String + let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Classifier)) -> Elab m (Term :==> Type) -> Type <==: Elab m Term -> Type <==: Elab m Term let' p a b = Check $ \ _B -> do From cb6f4b5cc8706ecafaab8859780b32dbeb5dc002 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 8 Dec 2021 10:13:06 -0500 Subject: [PATCH 0479/1324] Combine contexts. --- src/Facet/Elab/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index e24ce16b0..219488a41 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -146,7 +146,7 @@ app mk operator operand = do a' <- censor @Usage (q ><<) $ check (operand ::: _A) pure $ mk f' a' :==> _B -appS :: (HasCallStack, Has (Throw Err) sig m) => S.Term t c => (HasCallStack => Elab m (t :==> Type)) -> (HasCallStack => Type <==: Elab m t) -> Elab m (t :==> Type) +appS :: (HasCallStack, Has (Throw Err) sig m, S.Term t c) => (HasCallStack => Elab m (t :==> Type)) -> (HasCallStack => Type <==: Elab m t) -> Elab m (t :==> Type) appS f a = do f' :==> _F <- f (_, q, _A, _B) <- assertFunction _F From 19e52147d23ba4bb4c8f6a96469703e146c08d84 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 10 Dec 2021 04:42:23 -0500 Subject: [PATCH 0480/1324] Avoid Classifier for valuie-level constructs. --- src/Facet/Elab/Term.hs | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 219488a41..08e1c0c73 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -131,12 +131,12 @@ tlam b = Check $ \ _T -> do d <- depth (zero, PVar (n :==> CK _A)) |- check (b ::: _B (T.free (LName (getUsed d) n))) -lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern (Name :==> Classifier)), Type <==: Elab m Term)] -> Type <==: Elab m Term +lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern (Name :==> Type)), Type <==: Elab m Term)] -> Type <==: Elab m Term lam cs = Check $ \ _T -> do (_, q, _A, _B) <- assertTacitFunction _T - Lam <$> traverse (\ (p, b) -> bind (p ::: (q, _A)) (check (b ::: _B))) cs + Lam <$> traverse (\ (p, b) -> bind (fmap (fmap CT) <$> p ::: (q, _A)) (check (b ::: _B))) cs -lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Classifier)) -> Type <==: Elab m Term -> Type <==: Elab m Term +lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Type)) -> Type <==: Elab m Term -> Type <==: Elab m Term lam1 p b = lam [(p, b)] app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Elab m (a :==> Type)) -> (HasCallStack => Type <==: Elab m b) -> Elab m (c :==> Type) @@ -182,17 +182,17 @@ comp b = Check $ \ _T -> do -- Pattern combinators -wildcardP :: Bind m (Pattern (Name :==> Classifier)) +wildcardP :: Bind m (Pattern (Name :==> Type)) wildcardP = Bind $ \ _T k -> k PWildcard -varP :: Name -> Bind m (Pattern (Name :==> Classifier)) -varP n = Bind $ \ _A k -> k (PVar (n :==> CT (wrap _A))) +varP :: Name -> Bind m (Pattern (Name :==> Type)) +varP n = Bind $ \ _A k -> k (PVar (n :==> wrap _A)) where wrap = \case T.Comp sig _A -> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (T.Comp sig _A) _T -> _T -conP :: (HasCallStack, Has (Throw Err) sig m) => QName -> [Bind m (Pattern (Name :==> Classifier))] -> Bind m (Pattern (Name :==> Classifier)) +conP :: (HasCallStack, Has (Throw Err) sig m) => QName -> [Bind m (Pattern (Name :==> Type))] -> Bind m (Pattern (Name :==> Type)) conP n fs = Bind $ \ _A k -> do n' :=: _ ::: _T <- resolveC n _T' <- maybe (pure _T) (foldl' (\ _T _A -> do t <- _T ; (_, _, b) <- assertQuantifier t ; pure (b _A)) (pure _T) . snd) (unNeutral _A) @@ -208,10 +208,10 @@ fieldsP = foldr cons nil nil = Bind $ \ _T k -> k ([], _T) -allP :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Name -> Bind m (Pattern (Name :==> Classifier)) +allP :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Name -> Bind m (Pattern (Name :==> Type)) allP n = Bind $ \ _A k -> do (sig, _T) <- assertComp _A - k (PVar (n :==> CT (T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (T.Comp sig _T)))) + k (PVar (n :==> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (T.Comp sig _T))) -- Expression elaboration @@ -244,14 +244,14 @@ checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC checkLam :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => [S.Clause] -> Type <==: Elab m Term checkLam cs = lam (snd vs) where - vs :: Has (Throw Err :+: Write Warn) sig m => ([QName :=: (Type <==: Elab m Term)], [(Bind m (Pattern (Name :==> Classifier)), Type <==: Elab m Term)]) + vs :: Has (Throw Err :+: Write Warn) sig m => ([QName :=: (Type <==: Elab m Term)], [(Bind m (Pattern (Name :==> Type)), Type <==: Elab m Term)]) vs = partitionEithers (map (\ (S.Clause (S.Ann _ _ p) b) -> case p of S.PVal p -> Right (bindPattern p, checkExpr b) S.PEff (S.Ann s _ (S.POp n fs k)) -> Left $ n :=: Check (\ _T -> pushSpan s (foldr (lam1 . bindPattern) (checkExpr b) (fromList fs:>k) <==: _T))) cs) -- FIXME: check for unique variable names -bindPattern :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.ValPattern -> Bind m (Pattern (Name :==> Classifier)) +bindPattern :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.ValPattern -> Bind m (Pattern (Name :==> Type)) bindPattern = withSpanB $ \case S.PWildcard -> wildcardP S.PVar n -> varP n @@ -282,7 +282,7 @@ abstractTerm body = go Nil Nil d <- depth pure $ body (TX.Var . Free . Right . toIndexed d <$> ts) (fs <*> pure d) -patternForArgType :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Type -> Name -> Bind m (Pattern (Name :==> Classifier)) +patternForArgType :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Type -> Name -> Bind m (Pattern (Name :==> Type)) patternForArgType = \case T.Comp{} -> allP _ -> varP From b14e703d9ad4224f8f36905461d0fb96e3c4020e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 10 Dec 2021 04:43:57 -0500 Subject: [PATCH 0481/1324] Move the Classifier construction into bind. --- src/Facet/Elab/Term.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 08e1c0c73..5b4e9e834 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -134,7 +134,7 @@ tlam b = Check $ \ _T -> do lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern (Name :==> Type)), Type <==: Elab m Term)] -> Type <==: Elab m Term lam cs = Check $ \ _T -> do (_, q, _A, _B) <- assertTacitFunction _T - Lam <$> traverse (\ (p, b) -> bind (fmap (fmap CT) <$> p ::: (q, _A)) (check (b ::: _B))) cs + Lam <$> traverse (\ (p, b) -> bind (p ::: (q, _A)) (check (b ::: _B))) cs lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Type)) -> Type <==: Elab m Term -> Type <==: Elab m Term lam1 p b = lam [(p, b)] @@ -161,7 +161,7 @@ stringS :: S.Term t c => Text -> Elab m (t :==> Type) stringS s = pure $ S.stringR s :==> T.String -let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Classifier)) -> Elab m (Term :==> Type) -> Type <==: Elab m Term -> Type <==: Elab m Term +let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Type)) -> Elab m (Term :==> Type) -> Type <==: Elab m Term -> Type <==: Elab m Term let' p a b = Check $ \ _B -> do a' :==> _A <- a (p', b') <- bind (p ::: (Many, _A)) (check (b ::: _B)) @@ -423,8 +423,8 @@ check (m ::: _T) = case _T of _T -> m <==: _T -bind :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Classifier)) ::: (Quantity, Type) -> Elab m b -> Elab m (Pattern Name, b) -bind (p ::: (q, _T)) m = runBind p _T (\ p' -> (proof <$> p',) <$> ((q, p') |- m)) +bind :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Type)) ::: (Quantity, Type) -> Elab m b -> Elab m (Pattern Name, b) +bind (p ::: (q, _T)) m = runBind p _T (\ p' -> (proof <$> p',) <$> ((q, fmap (fmap CT) p') |- m)) newtype Bind m a = Bind { runBind :: forall x . Type -> (a -> Elab m x) -> Elab m x } deriving (Functor) From 4868547c362b217e64241957eb0e2389135856c7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 10 Dec 2021 04:45:28 -0500 Subject: [PATCH 0482/1324] Construct computations without Classifier. --- src/Facet/Elab/Term.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 5b4e9e834..e09fd4a64 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -172,11 +172,11 @@ comp :: Has (Throw Err) sig m => Type <==: Elab m Term -> Type <==: Elab m Term comp b = Check $ \ _T -> do (sig, _B) <- assertComp _T StaticContext{ graph, module' } <- ask - let interfacePattern :: Has (Throw Err) sig m => Interface Type -> Elab m (RName :=: (Name :==> Classifier)) - interfacePattern (Interface n _) = maybe (freeVariable (toQ n)) (\ (n' :=: _T) -> pure ((n .:. n') :=: (n' :==> CT _T))) (listToMaybe (scopeToList . tm =<< unDInterface . def =<< lookupQ graph module' (toQ n))) + let interfacePattern :: Has (Throw Err) sig m => Interface Type -> Elab m (RName :=: (Name :==> Type)) + interfacePattern (Interface n _) = maybe (freeVariable (toQ n)) (\ (n' :=: _T) -> pure ((n .:. n') :=: (n' :==> _T))) (listToMaybe (scopeToList . tm =<< unDInterface . def =<< lookupQ graph module' (toQ n))) p' <- traverse interfacePattern (interfaces sig) -- FIXME: can we apply quantities to dictionaries? what would they mean? - b' <- (Many, PDict p') |- check (b ::: _B) + b' <- (Many, PDict (map (fmap (fmap CT)) p')) |- check (b ::: _B) pure $ E.Comp (map (fmap proof) p') b' From 90c26f6676aab5c633bb25f8b3f117a293cc6ab6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 10 Dec 2021 16:20:27 -0500 Subject: [PATCH 0483/1324] Update Term.hs --- src/Facet/Elab/Term.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index e09fd4a64..045e57887 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -139,6 +139,9 @@ lam cs = Check $ \ _T -> do lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Type)) -> Type <==: Elab m Term -> Type <==: Elab m Term lam1 p b = lam [(p, b)] +lam1'S :: S.Term t c => Name -> (Elab m t) -> Elab m t +lam1'S n _ = _ + app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Elab m (a :==> Type)) -> (HasCallStack => Type <==: Elab m b) -> Elab m (c :==> Type) app mk operator operand = do f' :==> _F <- operator From 7a726843eeba970dfd591f32b1008e6307afc77f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 10 Dec 2021 16:33:01 -0500 Subject: [PATCH 0484/1324] Define strengthening of scope-safe syntax. --- src/Facet/Sequent/Class.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index b286f5b04..7cd5d7c6b 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -3,6 +3,8 @@ module Facet.Sequent.Class ( -- * Term abstraction Term(..) + -- * Effectful abstractions +, strengthen -- * Commands , (:|:)(..) ) where @@ -11,6 +13,7 @@ import Control.Applicative (liftA2) import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable +import Data.Functor.Identity (Identity(runIdentity)) import Data.Text (Text) import Facet.Name (LName, Level, Name, RName) import Facet.Pattern (Pattern) @@ -40,6 +43,12 @@ class Term term coterm | coterm -> term, term -> coterm where infix 1 ||| +-- * Effectful abstractions + +strengthen :: Applicative m => m (Identity a) -> m a +strengthen = fmap runIdentity + + -- * Commands data term :|: coterm = term :|: coterm From bf586bafadc1a245533416c07385ae6dea67ac4e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 10 Dec 2021 16:38:59 -0500 Subject: [PATCH 0485/1324] =?UTF-8?q?Define=20an=20effectful=20constructor?= =?UTF-8?q?=20for=20=C2=B5R.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Sequent/Class.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 7cd5d7c6b..e150ff001 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -5,6 +5,7 @@ module Facet.Sequent.Class Term(..) -- * Effectful abstractions , strengthen +, µRA -- * Commands , (:|:)(..) ) where @@ -15,6 +16,7 @@ import Data.Bifunctor import Data.Bitraversable import Data.Functor.Identity (Identity(runIdentity)) import Data.Text (Text) +import Facet.Functor.Compose import Facet.Name (LName, Level, Name, RName) import Facet.Pattern (Pattern) import Facet.Quote (Quote(..)) @@ -49,6 +51,14 @@ strengthen :: Applicative m => m (Identity a) -> m a strengthen = fmap runIdentity +µRA + :: (Term t c, Applicative i, Applicative m) + => Name + -> (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j (t :|: c))) + -> m (i t) +µRA n f = fmap (µR n) . runC <$> f liftCOuter (liftCInner id) + + -- * Commands data term :|: coterm = term :|: coterm From a723c5a433afafa4769d7dda544fed13c1f85658 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 10 Dec 2021 16:39:51 -0500 Subject: [PATCH 0486/1324] =?UTF-8?q?Define=20an=20effectful=20constructor?= =?UTF-8?q?=20for=20=C2=B5L.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Sequent/Class.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index e150ff001..373b3680f 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -6,6 +6,7 @@ module Facet.Sequent.Class -- * Effectful abstractions , strengthen , µRA +, µLA -- * Commands , (:|:)(..) ) where @@ -58,6 +59,13 @@ strengthen = fmap runIdentity -> m (i t) µRA n f = fmap (µR n) . runC <$> f liftCOuter (liftCInner id) +µLA + :: (Term t c, Applicative i, Applicative m) + => Name + -> (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j (t :|: c))) + -> m (i c) +µLA n f = fmap (µL n) . runC <$> f liftCOuter (liftCInner id) + -- * Commands From 82e8189e5035e17fa109ef80fc1755f84bac9541 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 12 Dec 2021 14:38:33 -0500 Subject: [PATCH 0487/1324] :fire: --- src/Facet/Elab/Term.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 045e57887..563aeddeb 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -139,8 +139,6 @@ lam cs = Check $ \ _T -> do lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Type)) -> Type <==: Elab m Term -> Type <==: Elab m Term lam1 p b = lam [(p, b)] -lam1'S :: S.Term t c => Name -> (Elab m t) -> Elab m t -lam1'S n _ = _ app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Elab m (a :==> Type)) -> (HasCallStack => Type <==: Elab m b) -> Elab m (c :==> Type) app mk operator operand = do From 206f668aaf2a9d28e0d9e80935effb8566e2ff63 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 12 Dec 2021 14:38:48 -0500 Subject: [PATCH 0488/1324] Rename an import. --- src/Facet/Elab/Term.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 563aeddeb..1aee0b784 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -68,7 +68,7 @@ import Facet.Module as Module import Facet.Name import Facet.Pattern import Facet.Semiring (Few(..), zero, (><<)) -import qualified Facet.Sequent.Class as S +import qualified Facet.Sequent.Class as SQ import Facet.Snoc import Facet.Snoc.NonEmpty as NE import Facet.Source (Source) @@ -147,19 +147,19 @@ app mk operator operand = do a' <- censor @Usage (q ><<) $ check (operand ::: _A) pure $ mk f' a' :==> _B -appS :: (HasCallStack, Has (Throw Err) sig m, S.Term t c) => (HasCallStack => Elab m (t :==> Type)) -> (HasCallStack => Type <==: Elab m t) -> Elab m (t :==> Type) +appS :: (HasCallStack, Has (Throw Err) sig m, SQ.Term t c) => (HasCallStack => Elab m (t :==> Type)) -> (HasCallStack => Type <==: Elab m t) -> Elab m (t :==> Type) appS f a = do f' :==> _F <- f (_, q, _A, _B) <- assertFunction _F a' <- censor @Usage (q ><<) $ check (a ::: _A) - pure $ S.µR __ (\ k -> f' S.:|: S.funL a' k) :==> _B + pure $ SQ.µR __ (\ k -> f' SQ.:|: SQ.funL a' k) :==> _B string :: Text -> Elab m (Term :==> Type) string s = pure $ E.String s :==> T.String -stringS :: S.Term t c => Text -> Elab m (t :==> Type) -stringS s = pure $ S.stringR s :==> T.String +stringS :: SQ.Term t c => Text -> Elab m (t :==> Type) +stringS s = pure $ SQ.stringR s :==> T.String let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Type)) -> Elab m (Term :==> Type) -> Type <==: Elab m Term -> Type <==: Elab m Term From 576f13d7467a34eeb461d3655e69c18d1e3dcc73 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 12 Dec 2021 14:39:11 -0500 Subject: [PATCH 0489/1324] Lift funR through Applicative contexts. --- src/Facet/Sequent/Class.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 373b3680f..cb385e50c 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -6,6 +6,8 @@ module Facet.Sequent.Class -- * Effectful abstractions , strengthen , µRA +, Clause(..) +, funRA , µLA -- * Commands , (:|:)(..) @@ -15,13 +17,13 @@ import Control.Applicative (liftA2) import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable -import Data.Functor.Identity (Identity(runIdentity)) +import Data.Functor.Identity (Identity(..)) import Data.Text (Text) import Facet.Functor.Compose import Facet.Name (LName, Level, Name, RName) import Facet.Pattern (Pattern) import Facet.Quote (Quote(..)) -import Facet.Syntax (Var, (:=:)) +import Facet.Syntax (Var, (:=:)(..)) -- * Term abstraction @@ -59,6 +61,12 @@ strengthen = fmap runIdentity -> m (i t) µRA n f = fmap (µR n) . runC <$> f liftCOuter (liftCInner id) +newtype Clause i m t = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j (Pattern (Name :=: t)) -> m (j t) } + +funRA :: (Term t c, Applicative i, Applicative m) => [(Pattern Name, Clause i m t)] -> m (i t) +funRA cs = fmap funR <$> runC (traverse (\ (p, c) -> (p,) <$> C (runC <$> runClause c liftCOuter (liftCInner id))) cs) + + µLA :: (Term t c, Applicative i, Applicative m) => Name From 0133bc0379f4418cf766043c89e5e3ea069171de Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 12 Dec 2021 16:01:49 -0500 Subject: [PATCH 0490/1324] Traverse nested structures. --- src/Facet/Sequent/Class.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index cb385e50c..2ba36227f 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -64,7 +64,7 @@ strengthen = fmap runIdentity newtype Clause i m t = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j (Pattern (Name :=: t)) -> m (j t) } funRA :: (Term t c, Applicative i, Applicative m) => [(Pattern Name, Clause i m t)] -> m (i t) -funRA cs = fmap funR <$> runC (traverse (\ (p, c) -> (p,) <$> C (runC <$> runClause c liftCOuter (liftCInner id))) cs) +funRA cs = fmap funR <$> runC (traverse (traverse (\ c -> C (runC <$> runClause c liftCOuter (liftCInner id)))) cs) µLA From e5fd488010ef11124f3f3a3c2f8d3b1ed2d836dc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 12 Dec 2021 16:07:24 -0500 Subject: [PATCH 0491/1324] Abstract the structure of commmands. --- src/Facet/Elab/Term.hs | 6 +++--- src/Facet/Sequent/Class.hs | 18 +++++++++--------- src/Facet/Sequent/Expr.hs | 10 +++++----- src/Facet/Sequent/Norm.hs | 2 +- 4 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 1aee0b784..7579f6389 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -147,18 +147,18 @@ app mk operator operand = do a' <- censor @Usage (q ><<) $ check (operand ::: _A) pure $ mk f' a' :==> _B -appS :: (HasCallStack, Has (Throw Err) sig m, SQ.Term t c) => (HasCallStack => Elab m (t :==> Type)) -> (HasCallStack => Type <==: Elab m t) -> Elab m (t :==> Type) +appS :: (HasCallStack, Has (Throw Err) sig m, SQ.Term t c d) => (HasCallStack => Elab m (t :==> Type)) -> (HasCallStack => Type <==: Elab m t) -> Elab m (t :==> Type) appS f a = do f' :==> _F <- f (_, q, _A, _B) <- assertFunction _F a' <- censor @Usage (q ><<) $ check (a ::: _A) - pure $ SQ.µR __ (\ k -> f' SQ.:|: SQ.funL a' k) :==> _B + pure $ SQ.µR __ (\ k -> f' SQ.||| SQ.funL a' k) :==> _B string :: Text -> Elab m (Term :==> Type) string s = pure $ E.String s :==> T.String -stringS :: SQ.Term t c => Text -> Elab m (t :==> Type) +stringS :: SQ.Term t c d => Text -> Elab m (t :==> Type) stringS s = pure $ SQ.stringR s :==> T.String diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 2ba36227f..5225e66cb 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -27,10 +27,10 @@ import Facet.Syntax (Var, (:=:)(..)) -- * Term abstraction -class Term term coterm | coterm -> term, term -> coterm where +class Term term coterm command | coterm -> term command, term -> coterm command, command -> term coterm where -- Terms var :: Var (LName Level) -> term - µR :: Name -> (coterm -> term :|: coterm) -> term + µR :: Name -> (coterm -> command) -> term funR :: [(Pattern Name, Pattern (Name :=: term) -> term)] -> term conR :: RName -> [term] -> term stringR :: Text -> term @@ -39,11 +39,11 @@ class Term term coterm | coterm -> term, term -> coterm where -- Coterms covar :: Var (LName Level) -> coterm - µL :: Name -> (term -> term :|: coterm) -> coterm + µL :: Name -> (term -> command) -> coterm funL :: term -> coterm -> coterm -- Commands - (|||) :: term -> coterm -> term :|: coterm + (|||) :: term -> coterm -> command infix 1 ||| @@ -55,22 +55,22 @@ strengthen = fmap runIdentity µRA - :: (Term t c, Applicative i, Applicative m) + :: (Term t c d, Applicative i, Applicative m) => Name - -> (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j (t :|: c))) + -> (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) -> m (i t) µRA n f = fmap (µR n) . runC <$> f liftCOuter (liftCInner id) newtype Clause i m t = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j (Pattern (Name :=: t)) -> m (j t) } -funRA :: (Term t c, Applicative i, Applicative m) => [(Pattern Name, Clause i m t)] -> m (i t) +funRA :: (Term t c d, Applicative i, Applicative m) => [(Pattern Name, Clause i m t)] -> m (i t) funRA cs = fmap funR <$> runC (traverse (traverse (\ c -> C (runC <$> runClause c liftCOuter (liftCInner id)))) cs) µLA - :: (Term t c, Applicative i, Applicative m) + :: (Term t c d, Applicative i, Applicative m) => Name - -> (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j (t :|: c))) + -> (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j d)) -> m (i c) µLA n f = fmap (µL n) . runC <$> f liftCOuter (liftCInner id) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 16261a01d..a85809a17 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -7,7 +7,7 @@ module Facet.Sequent.Expr , (C.:|:)(..) ) where -import Data.Bitraversable (bisequenceA) +import Control.Applicative (liftA2) import Data.Text (Text) import Data.Traversable (mapAccumL) import Facet.Name @@ -36,9 +36,9 @@ data Coterm | FunL Term Coterm -instance C.Term (Quoter Term) (Quoter Coterm) where +instance C.Term (Quoter Term) (Quoter Coterm) (Quoter (Term C.:|: Coterm)) where var v = Quoter (\ d -> Var (toIndexed d v)) - µR n b = MuR n <$> binder (\ d' -> Quoter (\ d -> covar n (toIndexed d d'))) (bisequenceA . b) + µR n b = MuR n <$> binder (\ d' -> Quoter (\ d -> covar n (toIndexed d d'))) b funR ps = FunR <$> traverse (uncurry clause) ps conR n fs = ConR n <$> sequenceA fs stringR = pure . StringR @@ -46,10 +46,10 @@ instance C.Term (Quoter Term) (Quoter Coterm) where compR i b = CompR i . snd <$> clause (PDict i) b covar v = Quoter (\ d -> Covar (toIndexed d v)) - µL n b = MuL n <$> binder (\ d' -> Quoter (\ d -> var n (toIndexed d d'))) (bisequenceA . b) + µL n b = MuL n <$> binder (\ d' -> Quoter (\ d -> var n (toIndexed d d'))) b funL a b = FunL <$> a <*> b - (|||) = (C.:|:) + (|||) = liftA2 (C.:|:) var :: Name -> Index -> Term var n i = Var (Free (LName i n)) diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index a0ebab20a..fb563b3ac 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -42,7 +42,7 @@ data Coterm data Command = Term :|: Coterm -instance Class.Term Term Coterm where +instance Class.Term Term Coterm (Term Class.:|: Coterm) where var = Var µR = MuR funR = FunR From 3c74a4e342605ad16af85cf5d62abc0a84cbfc71 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 12 Dec 2021 16:09:08 -0500 Subject: [PATCH 0492/1324] Rename ||| to .|.. --- src/Facet/Elab/Term.hs | 2 +- src/Facet/Sequent/Class.hs | 4 ++-- src/Facet/Sequent/Expr.hs | 2 +- src/Facet/Sequent/Norm.hs | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 7579f6389..1a1aa4406 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -152,7 +152,7 @@ appS f a = do f' :==> _F <- f (_, q, _A, _B) <- assertFunction _F a' <- censor @Usage (q ><<) $ check (a ::: _A) - pure $ SQ.µR __ (\ k -> f' SQ.||| SQ.funL a' k) :==> _B + pure $ SQ.µR __ (\ k -> f' SQ..|. SQ.funL a' k) :==> _B string :: Text -> Elab m (Term :==> Type) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 5225e66cb..80e8d12e5 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -43,9 +43,9 @@ class Term term coterm command | coterm -> term command, term -> coterm command, funL :: term -> coterm -> coterm -- Commands - (|||) :: term -> coterm -> command + (.|.) :: term -> coterm -> command - infix 1 ||| + infix 1 .|. -- * Effectful abstractions diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index a85809a17..36023ff08 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -49,7 +49,7 @@ instance C.Term (Quoter Term) (Quoter Coterm) (Quoter (Term C.:|: Coterm)) where µL n b = MuL n <$> binder (\ d' -> Quoter (\ d -> var n (toIndexed d d'))) b funL a b = FunL <$> a <*> b - (|||) = liftA2 (C.:|:) + (.|.) = liftA2 (C.:|:) var :: Name -> Index -> Term var n i = Var (Free (LName i n)) diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index fb563b3ac..b9ad949ef 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -55,7 +55,7 @@ instance Class.Term Term Coterm (Term Class.:|: Coterm) where µL = MuL funL = FunL - (|||) = (Class.:|:) + (.|.) = (Class.:|:) instance Quote Term X.Term where From c5e8b75a6c4fa8f242aa35f4742d2cde296920ff Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 12 Dec 2021 16:11:40 -0500 Subject: [PATCH 0493/1324] Define a module for pretty-printing sequents. --- facet.cabal | 1 + src/Facet/Sequent/Print.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Sequent/Print.hs diff --git a/facet.cabal b/facet.cabal index 68cc3a4af..4d7ef5210 100644 --- a/facet.cabal +++ b/facet.cabal @@ -117,6 +117,7 @@ library Facet.Sequent.Class Facet.Sequent.Expr Facet.Sequent.Norm + Facet.Sequent.Print Facet.Snoc Facet.Snoc.NonEmpty Facet.Source diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs new file mode 100644 index 000000000..abf110477 --- /dev/null +++ b/src/Facet/Sequent/Print.hs @@ -0,0 +1,2 @@ +module Facet.Sequent.Print +() where From 580e90764dced8607d84462b753e143f9c95243a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 12 Dec 2021 16:14:28 -0500 Subject: [PATCH 0494/1324] Define a printer for sequents. --- src/Facet/Sequent/Print.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index abf110477..3c6af851b 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -1,2 +1,12 @@ +{-# LANGUAGE UndecidableInstances #-} module Facet.Sequent.Print -() where +( Print(..) +) where + +import qualified Facet.Style as S +import qualified Prettyprinter as PP +import qualified Silkscreen as P +import qualified Silkscreen.Printer.Rainbow as P + +newtype Print = Print { doc :: P.Rainbow (PP.Doc S.Style) } + deriving (Monoid, P.Printer, Semigroup) From fb6f74a9e9c1a0a1310fa512635a445be541b26f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 13 Dec 2021 08:26:20 -0500 Subject: [PATCH 0495/1324] Define a module for print options. --- facet.cabal | 1 + src/Facet/Print/Options.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Print/Options.hs diff --git a/facet.cabal b/facet.cabal index 4d7ef5210..3dbd81b5e 100644 --- a/facet.cabal +++ b/facet.cabal @@ -108,6 +108,7 @@ library Facet.Polarized Facet.Pretty Facet.Print + Facet.Print.Options Facet.Quote Facet.REPL Facet.REPL.Parser diff --git a/src/Facet/Print/Options.hs b/src/Facet/Print/Options.hs new file mode 100644 index 000000000..b14fee48f --- /dev/null +++ b/src/Facet/Print/Options.hs @@ -0,0 +1,2 @@ +module Facet.Print.Options +() where From cea4e6fc3b952a5e1557f817cf95521442a644f0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 13 Dec 2021 08:40:17 -0500 Subject: [PATCH 0496/1324] Move Options into its own module. --- src/Facet/Driver.hs | 6 +++--- src/Facet/Notice/Elab.hs | 4 ++-- src/Facet/Print.hs | 36 ++++--------------------------- src/Facet/Print/Options.hs | 43 +++++++++++++++++++++++++++++++++++++- src/Facet/REPL.hs | 10 ++++----- src/Facet/Run.hs | 4 ++-- 6 files changed, 58 insertions(+), 45 deletions(-) diff --git a/src/Facet/Driver.hs b/src/Facet/Driver.hs index 2af2e07a3..57d7c471b 100644 --- a/src/Facet/Driver.hs +++ b/src/Facet/Driver.hs @@ -44,7 +44,7 @@ import Facet.Notice.Elab (rethrowElabErrors, rethrowElabWarnings) import Facet.Notice.Parser (rethrowParseErrors) import Facet.Parser import Facet.Pretty -import Facet.Print (Options) +import Facet.Print (Options, Print) import Facet.Snoc import Facet.Source import Facet.Style @@ -91,7 +91,7 @@ kernel = Module kernelName [] [] $ Scope mempty -- Module loading -reloadModules :: (Has (Error (Notice.Notice (Doc Style)) :+: Output :+: State Options :+: State Target :+: Write (Notice.Notice (Doc Style))) sig m, MonadIO m) => m () +reloadModules :: (Has (Error (Notice.Notice (Doc Style)) :+: Output :+: State (Options Print) :+: State Target :+: Write (Notice.Notice (Doc Style))) sig m, MonadIO m) => m () reloadModules = do searchPaths <- uses searchPaths_ toList modules_ .= singleton Nothing kernel @@ -145,7 +145,7 @@ loadModuleHeader searchPaths target = do (name', is) <- rethrowParseErrors @_ @Style (runParserWithSource src (runFacet [] (whiteSpace *> moduleHeader))) pure (ModuleHeader name' src (map (Import.name . S.out) is)) -loadModule :: Has (Output :+: State Options :+: Throw (Notice.Notice (Doc Style)) :+: Write (Notice.Notice (Doc Style))) sig m => Graph -> ModuleHeader Module -> m Module +loadModule :: Has (Output :+: State (Options Print) :+: Throw (Notice.Notice (Doc Style)) :+: Write (Notice.Notice (Doc Style))) sig m => Graph -> ModuleHeader Module -> m Module loadModule graph (ModuleHeader _ src imports) = do let ops = foldMap (\ m -> map (\ (op, assoc) -> (name m, op, assoc)) (operators m)) imports m <- rethrowParseErrors @_ @Style (runParserWithSource src (runFacet (map makeOperator ops) (whole module'))) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index ff98c13f5..8653173ba 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -29,7 +29,7 @@ import Silkscreen -- Elaboration -rethrowElabErrors :: Applicative m => Options -> L.ThrowC (Notice (Doc Style)) Err m a -> m a +rethrowElabErrors :: Applicative m => Options Print -> L.ThrowC (Notice (Doc Style)) Err m a -> m a rethrowElabErrors opts = L.runThrow (pure . rethrow) where rethrow Err{ source, reason, context, subst, sig, callStack } = Notice.Notice (Just Error) [source] (printErrReason opts printCtx reason) @@ -57,7 +57,7 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) | otherwise -> id -printErrReason :: Options -> Env.Env Print -> ErrReason -> Doc Style +printErrReason :: Options Print -> Env.Env Print -> ErrReason -> Doc Style printErrReason opts ctx = group . \case FreeVariable n -> fillSep [reflow "variable not in scope:", pretty n] AmbiguousName n qs -> fillSep [reflow "ambiguous name", pretty n] <\> nest 2 (reflow "alternatives:" <\> unlines (map pretty qs)) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index f196fab37..0fe863389 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -36,6 +36,7 @@ import qualified Facet.Module as C import Facet.Name as Name import Facet.Pattern import Facet.Pretty (lower, upper) +import Facet.Print.Options import Facet.Quote import Facet.Semiring (one, zero) import Facet.Snoc @@ -117,35 +118,6 @@ f $$ a = askingPrec $ \case ($$*) = fmap group . foldl' ($$) --- Options - --- FIXME: add an option to control whether shifts are printed -data Options = Options - { rname :: RName -> Print - , instantiation :: Print -> Print -> Print - } - -verboseOptions :: Options -verboseOptions = Options - { rname = qualified - , instantiation = printInstantiation - } - -quietOptions :: Options -quietOptions = Options - { rname = unqualified - , instantiation = suppressInstantiation - } - -qualified, unqualified :: RName -> Print -qualified = pretty -unqualified (_:.:n) = pretty n - -printInstantiation, suppressInstantiation :: Print -> Print -> Print -printInstantiation = ($$) -suppressInstantiation = const - - intro, tintro :: Name -> Level -> Print intro n = name lower n . getLevel tintro n = name upper n . getLevel @@ -170,7 +142,7 @@ name f n d = setPrec Var . annotate (Name d) $ -- Printable class Printable t where - print :: Options -> Env Print -> t -> Print + print :: Options Print -> Env Print -> t -> Print instance Printable Print where print _ _ = id @@ -267,7 +239,7 @@ instance Printable C.Module where class Printable1 f where - printWith :: (Options -> Env Print -> a -> Print) -> Options -> Env Print -> f a -> Print + printWith :: (Options Print -> Env Print -> a -> Print) -> Options Print -> Env Print -> f a -> Print instance Printable1 Interface where printWith with opts@Options{ rname } env (Interface h sp) = rname h $$* fmap (with opts env) sp @@ -282,5 +254,5 @@ instance Printable1 Pattern where PDict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> rname n <+> equals <+> group (with opts env v)) os) <> flatAlt space line) -print1 :: (Printable1 f, Printable a) => Options -> Env Print -> f a -> Print +print1 :: (Printable1 f, Printable a) => Options Print -> Env Print -> f a -> Print print1 = printWith print diff --git a/src/Facet/Print/Options.hs b/src/Facet/Print/Options.hs index b14fee48f..aa4bd9713 100644 --- a/src/Facet/Print/Options.hs +++ b/src/Facet/Print/Options.hs @@ -1,2 +1,43 @@ module Facet.Print.Options -() where +( -- * Options + Options(..) +, verboseOptions +, quietOptions +, qualified +, unqualified +, printInstantiation +, suppressInstantiation +) where + +import Facet.Name +import Silkscreen + +-- Options + +-- FIXME: add an option to control whether shifts are printed +data Options p = Options + { rname :: RName -> p + , instantiation :: p -> p -> p + } + +verboseOptions :: Printer p => Options p +verboseOptions = Options + { rname = qualified + , instantiation = printInstantiation + } + +quietOptions :: Printer p => Options p +quietOptions = Options + { rname = unqualified + , instantiation = suppressInstantiation + } + +qualified, unqualified :: Printer p => RName -> p +qualified = pretty +unqualified (_:.:n) = pretty n + +printInstantiation :: Printer p => p -> p -> p +printInstantiation = (<+>) + +suppressInstantiation :: p -> p -> p +suppressInstantiation = const diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index 52efd64b3..a407071ca 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -71,7 +71,7 @@ repl searchPaths . fmap (const ExitSuccess) . runReadlineWithHistory . evalState (defaultREPLState & target_.searchPaths_ .~ Set.fromList searchPaths) - . evalState quietOptions + . evalState (quietOptions @Print) . evalEmpty $ loop @@ -111,7 +111,7 @@ defaultPromptFunction _ = pure $ setTitleCode "facet" <> "\STX" <> bold <> cyan plain = setSGRCode [] <> "\STX" -loop :: (Has (Empty :+: Input :+: Output :+: State Options :+: State REPL) sig m, MonadIO m) => m () +loop :: (Has (Empty :+: Input :+: Output :+: State (Options Print) :+: State REPL) sig m, MonadIO m) => m () loop = do -- FIXME: handle interrupts resp <- prompt @@ -160,7 +160,7 @@ path' :: TokenParsing p => p FilePath path' = stringLiteral <|> some (satisfy (not . isSpace)) -newtype Action = Action { runAction :: forall sig m . (Has (Empty :+: Error (Notice.Notice (Doc Style)) :+: Output :+: Reader Source :+: State Options :+: State REPL :+: I.Write (Notice.Notice (Doc Style))) sig m, MonadFail m, MonadIO m) => m () } +newtype Action = Action { runAction :: forall sig m . (Has (Empty :+: Error (Notice.Notice (Doc Style)) :+: Output :+: Reader Source :+: State (Options Print) :+: State REPL :+: I.Write (Notice.Notice (Doc Style))) sig m, MonadFail m, MonadIO m) => m () } showPaths, showModules, showTargets :: Action @@ -207,7 +207,7 @@ showEval e = Action $ do opts <- get outputDocLn (getPrint (ann (Print.print opts mempty e'' ::: Print.print opts mempty _T))) -runEvalMain :: (Has (Error (Notice.Notice (Doc Style)) :+: Output :+: Reader Graph :+: Reader Module :+: State Options) sig m, MonadFail m) => Term -> m Term +runEvalMain :: (Has (Error (Notice.Notice (Doc Style)) :+: Output :+: Reader Graph :+: Reader Module :+: State (Options Print)) sig m, MonadFail m) => Term -> m Term runEvalMain e = runEval (runQuoter 0 . quote =<< runReader mempty (eval e)) pure -- where -- hdl = [(write, Handler handle)] @@ -242,7 +242,7 @@ prompt = do p <- liftIO $ fn line fmap (sourceFromString Nothing line) <$> getInputLine p -runElab :: Has (State Options :+: State REPL) sig m => I.WriteC (Notice.Notice (Doc Style)) Elab.Warn (I.ThrowC (Notice.Notice (Doc Style)) Elab.Err (ReaderC MName (ReaderC Module (ReaderC Graph m)))) a -> m a +runElab :: Has (State (Options Print) :+: State REPL) sig m => I.WriteC (Notice.Notice (Doc Style)) Elab.Warn (I.ThrowC (Notice.Notice (Doc Style)) Elab.Err (ReaderC MName (ReaderC Module (ReaderC Graph m)))) a -> m a runElab m = do graph <- use (target_.modules_) localDefs <- use localDefs_ diff --git a/src/Facet/Run.hs b/src/Facet/Run.hs index 8adcbd392..1a5df2ecc 100644 --- a/src/Facet/Run.hs +++ b/src/Facet/Run.hs @@ -13,7 +13,7 @@ import Facet.Carrier.Write.General import Facet.Driver import Facet.Graph import Facet.Lens -import Facet.Print (quietOptions) +import Facet.Print (Print, quietOptions) import Facet.Source as Source import Facet.Style import Fresnel.At @@ -36,4 +36,4 @@ runFile searchPaths path = runStack $ do . evalState (Target mempty mempty (Set.fromList searchPaths)) . runError ((ExitFailure 1 <$) . outputDocLn . prettyNotice) pure . runWrite (outputDocLn . prettyNotice) - . evalState quietOptions + . evalState (quietOptions @Print) From cf6b1d46103c155e4d0b965ee591b55c5f1d1d23 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 13 Dec 2021 09:05:36 -0500 Subject: [PATCH 0497/1324] Define a Term instance for Print. --- src/Facet/Sequent/Print.hs | 56 +++++++++++++++++++++++++++++++++++++- 1 file changed, 55 insertions(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index 3c6af851b..5f32d9e14 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -1,12 +1,66 @@ +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE UndecidableInstances #-} module Facet.Sequent.Print ( Print(..) ) where +import Facet.Name +import Facet.Pattern (Pattern(..)) +import Facet.Print.Options +import qualified Facet.Sequent.Class as S import qualified Facet.Style as S +import Facet.Syntax import qualified Prettyprinter as PP import qualified Silkscreen as P import qualified Silkscreen.Printer.Rainbow as P -newtype Print = Print { doc :: P.Rainbow (PP.Doc S.Style) } +newtype Print = Print { doc :: Options Print -> Used -> P.Rainbow (PP.Doc S.Style) } deriving (Monoid, P.Printer, Semigroup) + +instance S.Term Print Print Print where + var = var + µR n b = P.pretty "µ" <> P.braces (nameVar n id P.<+> P.dot P.<+> nameVar n b) + funR cs = P.braces (P.encloseSep (P.flatAlt P.space mempty) (P.flatAlt P.space mempty) (P.comma <> P.space) (map (uncurry clause) cs)) + conR n fs = foldl1 (P.surround P.space) (S.var (Global n):fs) + stringR = P.pretty . show + dictR os = withOpts (\ Options{..} -> P.brackets (P.flatAlt P.space P.line <> commaSep (map (\ (n :=: v) -> rname n P.<+> P.equals P.<+> P.group v) os) <> P.flatAlt P.space P.line)) + compR p b = P.group + . P.align + . P.braces + . P.enclose P.space P.space $ clause (PDict p) b + + covar = var + µL n b = P.pretty "µ̃" <> P.braces (P.pretty n P.<+> P.dot P.<+> withLevel (\ d -> b (var (Free (LName (getUsed d) n))))) + funL a k = a P.<+> P.dot P.<+> k + + (.|.) = fmap (P.enclose P.langle P.rangle) . P.surround P.pipe + +withLevel :: (Used -> Print) -> Print +withLevel f = Print (\ o d -> doc (f d) o d) + +incrLevel :: Print -> Print +incrLevel p = Print (\ o -> doc p o . succ) + +withOpts :: (Options Print -> Print) -> Print +withOpts f = Print (\ o d -> doc (f o) o d) + +var :: Var (LName Level) -> Print +var v = case v of + Free (LName l n) -> P.pretty n <> P.pretty (getLevel l) + Global n -> P.pretty n + +nameVar :: Name -> (Print -> Print) -> Print +nameVar n b = withLevel (\ d -> incrLevel (b (var (Free (LName (getUsed d) n))))) + +pattern :: Options Print -> Pattern Print -> Print +pattern opts@Options{..} = \case + PWildcard -> P.pretty "_" + PVar p -> p + PCon n fs -> foldl1 (P.surround P.space) (S.var (Global n):map (pattern opts) fs) + PDict os -> P.brackets (P.flatAlt P.space P.line <> commaSep (map (\ (n :=: v) -> rname n P.<+> P.equals P.<+> P.group v) os) <> P.flatAlt P.space P.line) + +commaSep :: [Print] -> Print +commaSep = P.encloseSep mempty mempty (P.comma <> P.space) + +clause :: Pattern Name -> (Pattern (Name :=: Print) -> Print) -> Print +clause p b = let p' = (\ n -> n :=: nameVar n id) <$> p in withOpts (`pattern` fmap def p') P.<+> P.pretty "->" P.<+> b p' From 808b553d4db5cfbe09d22eecb93801d484b4eabc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 13 Dec 2021 09:09:11 -0500 Subject: [PATCH 0498/1324] Define a Show instance for Print. --- src/Facet/Sequent/Print.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index 5f32d9e14..5e8458a14 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -17,6 +17,13 @@ import qualified Silkscreen.Printer.Rainbow as P newtype Print = Print { doc :: Options Print -> Used -> P.Rainbow (PP.Doc S.Style) } deriving (Monoid, P.Printer, Semigroup) +getPrint :: Options Print -> Print -> PP.Doc S.Style +getPrint o p = P.runRainbow (P.annotate . S.Nest) 0 (doc (P.group p) o 0) + +instance Show Print where + showsPrec p = showsPrec p . getPrint quietOptions + + instance S.Term Print Print Print where var = var µR n b = P.pretty "µ" <> P.braces (nameVar n id P.<+> P.dot P.<+> nameVar n b) From bbda5c2e677dcc3655c0176d227012d3973a6a48 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 13 Dec 2021 13:28:23 -0500 Subject: [PATCH 0499/1324] Rename Term to Sequent. --- src/Facet/Elab/Term.hs | 4 ++-- src/Facet/Sequent/Class.hs | 12 ++++++------ src/Facet/Sequent/Expr.hs | 2 +- src/Facet/Sequent/Norm.hs | 2 +- src/Facet/Sequent/Print.hs | 2 +- 5 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 1a1aa4406..f43813519 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -147,7 +147,7 @@ app mk operator operand = do a' <- censor @Usage (q ><<) $ check (operand ::: _A) pure $ mk f' a' :==> _B -appS :: (HasCallStack, Has (Throw Err) sig m, SQ.Term t c d) => (HasCallStack => Elab m (t :==> Type)) -> (HasCallStack => Type <==: Elab m t) -> Elab m (t :==> Type) +appS :: (HasCallStack, Has (Throw Err) sig m, SQ.Sequent t c d) => (HasCallStack => Elab m (t :==> Type)) -> (HasCallStack => Type <==: Elab m t) -> Elab m (t :==> Type) appS f a = do f' :==> _F <- f (_, q, _A, _B) <- assertFunction _F @@ -158,7 +158,7 @@ appS f a = do string :: Text -> Elab m (Term :==> Type) string s = pure $ E.String s :==> T.String -stringS :: SQ.Term t c d => Text -> Elab m (t :==> Type) +stringS :: SQ.Sequent t c d => Text -> Elab m (t :==> Type) stringS s = pure $ SQ.stringR s :==> T.String diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 80e8d12e5..0a851d7c4 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -1,8 +1,8 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} module Facet.Sequent.Class -( -- * Term abstraction - Term(..) +( -- * Sequent abstraction + Sequent(..) -- * Effectful abstractions , strengthen , µRA @@ -27,7 +27,7 @@ import Facet.Syntax (Var, (:=:)(..)) -- * Term abstraction -class Term term coterm command | coterm -> term command, term -> coterm command, command -> term coterm where +class Sequent term coterm command | coterm -> term command, term -> coterm command, command -> term coterm where -- Terms var :: Var (LName Level) -> term µR :: Name -> (coterm -> command) -> term @@ -55,7 +55,7 @@ strengthen = fmap runIdentity µRA - :: (Term t c d, Applicative i, Applicative m) + :: (Sequent t c d, Applicative i, Applicative m) => Name -> (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) -> m (i t) @@ -63,12 +63,12 @@ strengthen = fmap runIdentity newtype Clause i m t = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j (Pattern (Name :=: t)) -> m (j t) } -funRA :: (Term t c d, Applicative i, Applicative m) => [(Pattern Name, Clause i m t)] -> m (i t) +funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause i m t)] -> m (i t) funRA cs = fmap funR <$> runC (traverse (traverse (\ c -> C (runC <$> runClause c liftCOuter (liftCInner id)))) cs) µLA - :: (Term t c d, Applicative i, Applicative m) + :: (Sequent t c d, Applicative i, Applicative m) => Name -> (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j d)) -> m (i c) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 36023ff08..464531751 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -36,7 +36,7 @@ data Coterm | FunL Term Coterm -instance C.Term (Quoter Term) (Quoter Coterm) (Quoter (Term C.:|: Coterm)) where +instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter (Term C.:|: Coterm)) where var v = Quoter (\ d -> Var (toIndexed d v)) µR n b = MuR n <$> binder (\ d' -> Quoter (\ d -> covar n (toIndexed d d'))) b funR ps = FunR <$> traverse (uncurry clause) ps diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index b9ad949ef..18d60cf71 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -42,7 +42,7 @@ data Coterm data Command = Term :|: Coterm -instance Class.Term Term Coterm (Term Class.:|: Coterm) where +instance Class.Sequent Term Coterm (Term Class.:|: Coterm) where var = Var µR = MuR funR = FunR diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index 5e8458a14..9d35bac1c 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -24,7 +24,7 @@ instance Show Print where showsPrec p = showsPrec p . getPrint quietOptions -instance S.Term Print Print Print where +instance S.Sequent Print Print Print where var = var µR n b = P.pretty "µ" <> P.braces (nameVar n id P.<+> P.dot P.<+> nameVar n b) funR cs = P.braces (P.encloseSep (P.flatAlt P.space mempty) (P.flatAlt P.space mempty) (P.comma <> P.space) (map (uncurry clause) cs)) From 6eaec30ae0e9577d2dac3b6c53d7e92b6549ba02 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 15 Dec 2021 10:03:52 -0500 Subject: [PATCH 0500/1324] Interpret Expr.Term & Coterm back into Sequents. --- src/Facet/Sequent/Expr.hs | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 464531751..1d36d4d28 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -5,11 +5,16 @@ module Facet.Sequent.Expr , Coterm(..) -- * Commands , (C.:|:)(..) + -- * Interpretation +, interpretTerm +, interpretCoterm +, interpretCommand ) where import Control.Applicative (liftA2) import Data.Text (Text) import Data.Traversable (mapAccumL) +import Facet.Env import Facet.Name import Facet.Pattern import Facet.Quote @@ -59,3 +64,25 @@ covar n i = Covar (Free (LName i n)) clause :: Pattern Name -> (Pattern (Name :=: Quoter Term) -> Quoter Term) -> Quoter (Pattern Name, Term) clause p b = Quoter (\ d -> let (d', p') = mapAccumL (\ d' n -> (succ d', n :=: Quoter (\ d -> var n (toIndexed d (getUsed d'))))) d p in (p, runQuoter d' (b p'))) + + +interpretTerm :: C.Sequent t c d => Env t -> Env c -> Term -> t +interpretTerm _G _D = \case + Var (Free n) -> _G `index` n + Var (Global n) -> C.var (Global n) + MuR n b -> C.µR n (\ k -> interpretCommand _G (_D |> PVar (n :=: k)) b) + FunR cs -> C.funR (map (fmap (\ t p -> interpretTerm (_G |> p) _D t)) cs) + ConR n fs -> C.conR n (map (interpretTerm _G _D) fs) + StringR s -> C.stringR s + DictR ops -> C.dictR (map (fmap (interpretTerm _G _D)) ops) + CompR i b -> C.compR i (\ p -> interpretTerm (_G |> p) _D b) + +interpretCoterm :: C.Sequent t c d => Env t -> Env c -> Coterm -> c +interpretCoterm _G _D = \case + Covar (Free n) -> _D `index` n + Covar (Global n) -> C.covar (Global n) + MuL n b -> C.µL n (\ t -> interpretCommand (_G |> PVar (n :=: t)) _D b) + FunL a k -> C.funL (interpretTerm _G _D a) (interpretCoterm _G _D k) + +interpretCommand :: C.Sequent t c d => Env t -> Env c -> Term C.:|: Coterm -> d +interpretCommand _G _D (t C.:|: c) = interpretTerm _G _D t C..|. interpretCoterm _G _D c From 5232c5f0031c7bc3936836f69dd1337fbb50df85 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 16 Dec 2021 17:38:51 -0500 Subject: [PATCH 0501/1324] Define a Quote instance for Command. --- src/Facet/Sequent/Norm.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index 18d60cf71..eec36de92 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -78,3 +78,7 @@ instance Quote Coterm X.Coterm where Covar v -> Quoter (\ d -> X.Covar (toIndexed d v)) MuL n b -> X.MuL n <$> quoteBinder (Quoter (\ d -> Var (Free (LName (getUsed d) n)))) b FunL a b -> liftA2 X.FunL (quote a) (quote b) + + +instance Quote Command (X.Term Class.:|: X.Coterm) where + quote (t :|: c) = (Class.:|:) <$> quote t <*> quote c From 6008b4c92f7168559a90946f91c1a17f651dda93 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 16 Dec 2021 17:39:00 -0500 Subject: [PATCH 0502/1324] Use Command for Norm. --- src/Facet/Sequent/Norm.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index eec36de92..42bae885e 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -21,7 +21,7 @@ import Facet.Syntax data Term = Var (Var (LName Level)) - | MuR Name (Coterm -> Term Class.:|: Coterm) + | MuR Name (Coterm -> Command) | FunR [(Pattern Name, Pattern (Name :=: Term) -> Term)] | ConR RName [Term] | StringR Text @@ -33,7 +33,7 @@ data Term data Coterm = Covar (Var (LName Level)) - | MuL Name (Term -> Term Class.:|: Coterm) + | MuL Name (Term -> Command) | FunL Term Coterm @@ -42,7 +42,7 @@ data Coterm data Command = Term :|: Coterm -instance Class.Sequent Term Coterm (Term Class.:|: Coterm) where +instance Class.Sequent Term Coterm Command where var = Var µR = MuR funR = FunR @@ -55,7 +55,7 @@ instance Class.Sequent Term Coterm (Term Class.:|: Coterm) where µL = MuL funL = FunL - (.|.) = (Class.:|:) + (.|.) = (:|:) instance Quote Term X.Term where From ab75d869c07a80f8188434b18f0239b455448ba8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 16 Dec 2021 17:43:02 -0500 Subject: [PATCH 0503/1324] Move :|: into Expr. --- src/Facet/Sequent/Class.hs | 25 ------------------------- src/Facet/Sequent/Expr.hs | 35 ++++++++++++++++++++++++++++------- src/Facet/Sequent/Norm.hs | 4 ++-- 3 files changed, 30 insertions(+), 34 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 0a851d7c4..421a5f52f 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE UndecidableInstances #-} module Facet.Sequent.Class ( -- * Sequent abstraction Sequent(..) @@ -9,20 +8,13 @@ module Facet.Sequent.Class , Clause(..) , funRA , µLA - -- * Commands -, (:|:)(..) ) where -import Control.Applicative (liftA2) -import Data.Bifoldable -import Data.Bifunctor -import Data.Bitraversable import Data.Functor.Identity (Identity(..)) import Data.Text (Text) import Facet.Functor.Compose import Facet.Name (LName, Level, Name, RName) import Facet.Pattern (Pattern) -import Facet.Quote (Quote(..)) import Facet.Syntax (Var, (:=:)(..)) -- * Term abstraction @@ -73,20 +65,3 @@ funRA cs = fmap funR <$> runC (traverse (traverse (\ c -> C (runC <$> runClause -> (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j d)) -> m (i c) µLA n f = fmap (µL n) . runC <$> f liftCOuter (liftCInner id) - - --- * Commands - -data term :|: coterm = term :|: coterm - -instance (Quote term1 term2, Quote coterm1 coterm2) => Quote (term1 :|: coterm1) (term2 :|: coterm2) where - quote (term :|: coterm) = liftA2 (:|:) (quote term) (quote coterm) - -instance Bifoldable (:|:) where - bifoldMap = bifoldMapDefault - -instance Bifunctor (:|:) where - bimap = bimapDefault - -instance Bitraversable (:|:) where - bitraverse f g (a :|: b) = (:|:) <$> f a <*> g b diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 1d36d4d28..628e57546 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -1,10 +1,11 @@ +{-# LANGUAGE UndecidableInstances #-} module Facet.Sequent.Expr ( -- * Terms Term(..) -- * Coterms , Coterm(..) -- * Commands -, (C.:|:)(..) +, (:|:)(..) -- * Interpretation , interpretTerm , interpretCoterm @@ -12,6 +13,9 @@ module Facet.Sequent.Expr ) where import Control.Applicative (liftA2) +import Data.Bifoldable (Bifoldable(..)) +import Data.Bifunctor (Bifunctor(..)) +import Data.Bitraversable (Bitraversable(..), bifoldMapDefault, bimapDefault) import Data.Text (Text) import Data.Traversable (mapAccumL) import Facet.Env @@ -25,7 +29,7 @@ import Facet.Syntax data Term = Var (Var (LName Index)) - | MuR Name (Term C.:|: Coterm) + | MuR Name (Term :|: Coterm) | FunR [(Pattern Name, Term)] | ConR RName [Term] | StringR Text @@ -37,11 +41,28 @@ data Term data Coterm = Covar (Var (LName Index)) - | MuL Name (Term C.:|: Coterm) + | MuL Name (Term :|: Coterm) | FunL Term Coterm -instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter (Term C.:|: Coterm)) where +-- Commands + +data term :|: coterm = term :|: coterm + +instance (Quote term1 term2, Quote coterm1 coterm2) => Quote (term1 :|: coterm1) (term2 :|: coterm2) where + quote (term :|: coterm) = liftA2 (:|:) (quote term) (quote coterm) + +instance Bifoldable (:|:) where + bifoldMap = bifoldMapDefault + +instance Bifunctor (:|:) where + bimap = bimapDefault + +instance Bitraversable (:|:) where + bitraverse f g (a :|: b) = (:|:) <$> f a <*> g b + + +instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter (Term :|: Coterm)) where var v = Quoter (\ d -> Var (toIndexed d v)) µR n b = MuR n <$> binder (\ d' -> Quoter (\ d -> covar n (toIndexed d d'))) b funR ps = FunR <$> traverse (uncurry clause) ps @@ -54,7 +75,7 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter (Term C.:|: Coterm)) wh µL n b = MuL n <$> binder (\ d' -> Quoter (\ d -> var n (toIndexed d d'))) b funL a b = FunL <$> a <*> b - (.|.) = liftA2 (C.:|:) + (.|.) = liftA2 (:|:) var :: Name -> Index -> Term var n i = Var (Free (LName i n)) @@ -84,5 +105,5 @@ interpretCoterm _G _D = \case MuL n b -> C.µL n (\ t -> interpretCommand (_G |> PVar (n :=: t)) _D b) FunL a k -> C.funL (interpretTerm _G _D a) (interpretCoterm _G _D k) -interpretCommand :: C.Sequent t c d => Env t -> Env c -> Term C.:|: Coterm -> d -interpretCommand _G _D (t C.:|: c) = interpretTerm _G _D t C..|. interpretCoterm _G _D c +interpretCommand :: C.Sequent t c d => Env t -> Env c -> Term :|: Coterm -> d +interpretCommand _G _D (t :|: c) = interpretTerm _G _D t C..|. interpretCoterm _G _D c diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index 42bae885e..0a4b69c9e 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -80,5 +80,5 @@ instance Quote Coterm X.Coterm where FunL a b -> liftA2 X.FunL (quote a) (quote b) -instance Quote Command (X.Term Class.:|: X.Coterm) where - quote (t :|: c) = (Class.:|:) <$> quote t <*> quote c +instance Quote Command (X.Term X.:|: X.Coterm) where + quote (t :|: c) = liftA2 (X.:|:) (quote t) (quote c) From 3633a6aba6e5bde088004cd94b6a9d2bd70ff28a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 16 Dec 2021 17:44:32 -0500 Subject: [PATCH 0504/1324] Specialize Command. --- src/Facet/Sequent/Expr.hs | 28 ++++++---------------------- src/Facet/Sequent/Norm.hs | 2 +- 2 files changed, 7 insertions(+), 23 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 628e57546..3be93d3a2 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE UndecidableInstances #-} module Facet.Sequent.Expr ( -- * Terms Term(..) -- * Coterms , Coterm(..) -- * Commands -, (:|:)(..) +, Command(..) -- * Interpretation , interpretTerm , interpretCoterm @@ -13,9 +12,6 @@ module Facet.Sequent.Expr ) where import Control.Applicative (liftA2) -import Data.Bifoldable (Bifoldable(..)) -import Data.Bifunctor (Bifunctor(..)) -import Data.Bitraversable (Bitraversable(..), bifoldMapDefault, bimapDefault) import Data.Text (Text) import Data.Traversable (mapAccumL) import Facet.Env @@ -29,7 +25,7 @@ import Facet.Syntax data Term = Var (Var (LName Index)) - | MuR Name (Term :|: Coterm) + | MuR Name Command | FunR [(Pattern Name, Term)] | ConR RName [Term] | StringR Text @@ -41,28 +37,16 @@ data Term data Coterm = Covar (Var (LName Index)) - | MuL Name (Term :|: Coterm) + | MuL Name Command | FunL Term Coterm -- Commands -data term :|: coterm = term :|: coterm +data Command = Term :|: Coterm -instance (Quote term1 term2, Quote coterm1 coterm2) => Quote (term1 :|: coterm1) (term2 :|: coterm2) where - quote (term :|: coterm) = liftA2 (:|:) (quote term) (quote coterm) -instance Bifoldable (:|:) where - bifoldMap = bifoldMapDefault - -instance Bifunctor (:|:) where - bimap = bimapDefault - -instance Bitraversable (:|:) where - bitraverse f g (a :|: b) = (:|:) <$> f a <*> g b - - -instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter (Term :|: Coterm)) where +instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where var v = Quoter (\ d -> Var (toIndexed d v)) µR n b = MuR n <$> binder (\ d' -> Quoter (\ d -> covar n (toIndexed d d'))) b funR ps = FunR <$> traverse (uncurry clause) ps @@ -105,5 +89,5 @@ interpretCoterm _G _D = \case MuL n b -> C.µL n (\ t -> interpretCommand (_G |> PVar (n :=: t)) _D b) FunL a k -> C.funL (interpretTerm _G _D a) (interpretCoterm _G _D k) -interpretCommand :: C.Sequent t c d => Env t -> Env c -> Term :|: Coterm -> d +interpretCommand :: C.Sequent t c d => Env t -> Env c -> Command -> d interpretCommand _G _D (t :|: c) = interpretTerm _G _D t C..|. interpretCoterm _G _D c diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index 0a4b69c9e..384cedc3e 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -80,5 +80,5 @@ instance Quote Coterm X.Coterm where FunL a b -> liftA2 X.FunL (quote a) (quote b) -instance Quote Command (X.Term X.:|: X.Coterm) where +instance Quote Command X.Command where quote (t :|: c) = liftA2 (X.:|:) (quote t) (quote c) From 547efd52544ba747a8cef92daf1a720ba0ce260e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 18 Dec 2021 13:36:16 -0500 Subject: [PATCH 0505/1324] Extract the per-clause handling. --- src/Facet/Sequent/Class.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 421a5f52f..9de6885de 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -56,7 +56,10 @@ strengthen = fmap runIdentity newtype Clause i m t = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j (Pattern (Name :=: t)) -> m (j t) } funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause i m t)] -> m (i t) -funRA cs = fmap funR <$> runC (traverse (traverse (\ c -> C (runC <$> runClause c liftCOuter (liftCInner id)))) cs) +funRA cs = fmap funR <$> runC (traverse (uncurry clause) cs) + where + clause :: (Functor m, Applicative i) => Pattern Name -> Clause i m t -> (m . i) (Pattern Name, Pattern (Name :=: t) -> t) + clause p c = (p,) <$> C (runC <$> runClause c liftCOuter (liftCInner id)) µLA From 26bd44548e796b07efceb4f99483e814a7037eb3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 18 Dec 2021 13:36:49 -0500 Subject: [PATCH 0506/1324] Unpack Clause on the left. --- src/Facet/Sequent/Class.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 9de6885de..7ca783255 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -59,7 +59,7 @@ funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause funRA cs = fmap funR <$> runC (traverse (uncurry clause) cs) where clause :: (Functor m, Applicative i) => Pattern Name -> Clause i m t -> (m . i) (Pattern Name, Pattern (Name :=: t) -> t) - clause p c = (p,) <$> C (runC <$> runClause c liftCOuter (liftCInner id)) + clause p (Clause c) = (p,) <$> C (runC <$> c liftCOuter (liftCInner id)) µLA From 2aa01846c0bc02283a07570a59c9b9d6f5ea0668 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 18 Dec 2021 13:37:40 -0500 Subject: [PATCH 0507/1324] Combine fmaps. --- src/Facet/Sequent/Class.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 7ca783255..25b5a6570 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -59,7 +59,7 @@ funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause funRA cs = fmap funR <$> runC (traverse (uncurry clause) cs) where clause :: (Functor m, Applicative i) => Pattern Name -> Clause i m t -> (m . i) (Pattern Name, Pattern (Name :=: t) -> t) - clause p (Clause c) = (p,) <$> C (runC <$> c liftCOuter (liftCInner id)) + clause p (Clause c) = C (fmap (p,) . runC <$> c liftCOuter (liftCInner id)) µLA From 5e1fa4928f0f1f97e7bb7294a7f9d37ec1880791 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 18 Dec 2021 13:38:43 -0500 Subject: [PATCH 0508/1324] Internalize an fmap. --- src/Facet/Sequent/Class.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 25b5a6570..17e389147 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -56,7 +56,7 @@ strengthen = fmap runIdentity newtype Clause i m t = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j (Pattern (Name :=: t)) -> m (j t) } funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause i m t)] -> m (i t) -funRA cs = fmap funR <$> runC (traverse (uncurry clause) cs) +funRA cs = runC (funR <$> traverse (uncurry clause) cs) where clause :: (Functor m, Applicative i) => Pattern Name -> Clause i m t -> (m . i) (Pattern Name, Pattern (Name :=: t) -> t) clause p (Clause c) = C (fmap (p,) . runC <$> c liftCOuter (liftCInner id)) From 62ddba956820c914d12e11e48028be01c21cdb91 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 18 Dec 2021 13:48:14 -0500 Subject: [PATCH 0509/1324] Add a type parameter for coterms. --- src/Facet/Sequent/Class.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 17e389147..eb23e8dbb 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -53,12 +53,12 @@ strengthen = fmap runIdentity -> m (i t) µRA n f = fmap (µR n) . runC <$> f liftCOuter (liftCInner id) -newtype Clause i m t = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j (Pattern (Name :=: t)) -> m (j t) } +newtype Clause i m t c = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j (Pattern (Name :=: t)) -> m (j t) } -funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause i m t)] -> m (i t) +funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause i m t c)] -> m (i t) funRA cs = runC (funR <$> traverse (uncurry clause) cs) where - clause :: (Functor m, Applicative i) => Pattern Name -> Clause i m t -> (m . i) (Pattern Name, Pattern (Name :=: t) -> t) + clause :: (Functor m, Applicative i) => Pattern Name -> Clause i m t c -> (m . i) (Pattern Name, Pattern (Name :=: t) -> t) clause p (Clause c) = C (fmap (p,) . runC <$> c liftCOuter (liftCInner id)) From c3bb546dbe0397f5aa533b98b2d9c3719455be4e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 18 Dec 2021 13:48:39 -0500 Subject: [PATCH 0510/1324] Add a type parameter for commands. --- src/Facet/Sequent/Class.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index eb23e8dbb..1eb223d1b 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -53,12 +53,12 @@ strengthen = fmap runIdentity -> m (i t) µRA n f = fmap (µR n) . runC <$> f liftCOuter (liftCInner id) -newtype Clause i m t c = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j (Pattern (Name :=: t)) -> m (j t) } +newtype Clause i m t c d = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j (Pattern (Name :=: t)) -> m (j t) } -funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause i m t c)] -> m (i t) +funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause i m t c d)] -> m (i t) funRA cs = runC (funR <$> traverse (uncurry clause) cs) where - clause :: (Functor m, Applicative i) => Pattern Name -> Clause i m t c -> (m . i) (Pattern Name, Pattern (Name :=: t) -> t) + clause :: (Functor m, Applicative i) => Pattern Name -> Clause i m t c d -> (m . i) (Pattern Name, Pattern (Name :=: t) -> t) clause p (Clause c) = C (fmap (p,) . runC <$> c liftCOuter (liftCInner id)) From a6424204e0ec7acde38f1ad70b3bc130ba3d8f1d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 19 Dec 2021 12:11:54 -0500 Subject: [PATCH 0511/1324] Ignore the camelCase hint. --- .hlint.yaml | 1 + 1 file changed, 1 insertion(+) create mode 100644 .hlint.yaml diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 000000000..ba7e13271 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1 @@ +- ignore: {name: Use camelCase} From 44383210dbb256663f52ff470dc0504dda1c5d2e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 19 Dec 2021 12:14:33 -0500 Subject: [PATCH 0512/1324] =?UTF-8?q?Factor=20out=20=C2=B5=CC=83.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Sequent/Print.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index 9d35bac1c..6ac5a77ec 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -37,7 +37,7 @@ instance S.Sequent Print Print Print where . P.enclose P.space P.space $ clause (PDict p) b covar = var - µL n b = P.pretty "µ̃" <> P.braces (P.pretty n P.<+> P.dot P.<+> withLevel (\ d -> b (var (Free (LName (getUsed d) n))))) + µL n b = µ̃ <> P.braces (P.pretty n P.<+> P.dot P.<+> withLevel (\ d -> b (var (Free (LName (getUsed d) n))))) funL a k = a P.<+> P.dot P.<+> k (.|.) = fmap (P.enclose P.langle P.rangle) . P.surround P.pipe @@ -71,3 +71,6 @@ commaSep = P.encloseSep mempty mempty (P.comma <> P.space) clause :: Pattern Name -> (Pattern (Name :=: Print) -> Print) -> Print clause p b = let p' = (\ n -> n :=: nameVar n id) <$> p in withOpts (`pattern` fmap def p') P.<+> P.pretty "->" P.<+> b p' + +µ̃ :: Print +µ̃ = P.pretty "µ̃" From 3fbbd700433ff6e414aed6a54c6582a9ff977f71 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 19 Dec 2021 12:35:51 -0500 Subject: [PATCH 0513/1324] Add a left rule for positive sums. --- src/Facet/Sequent/Class.hs | 1 + src/Facet/Sequent/Expr.hs | 3 +++ src/Facet/Sequent/Norm.hs | 3 +++ src/Facet/Sequent/Print.hs | 8 ++++++++ 4 files changed, 15 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 1eb223d1b..2ce8331b8 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -33,6 +33,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma covar :: Var (LName Level) -> coterm µL :: Name -> (term -> command) -> coterm funL :: term -> coterm -> coterm + sumL :: (term -> command) -> (term -> command) -> coterm -- Commands (.|.) :: term -> coterm -> command diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 3be93d3a2..075841692 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -39,6 +39,7 @@ data Coterm = Covar (Var (LName Index)) | MuL Name Command | FunL Term Coterm + | SumL Command Command -- Commands @@ -58,6 +59,7 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where covar v = Quoter (\ d -> Covar (toIndexed d v)) µL n b = MuL n <$> binder (\ d' -> Quoter (\ d -> var n (toIndexed d d'))) b funL a b = FunL <$> a <*> b + sumL l r = SumL <$> binder (\ d' -> Quoter (\ d -> var __ (toIndexed d d'))) l <*> binder (\ d' -> Quoter (\ d -> var __ (toIndexed d d'))) r (.|.) = liftA2 (:|:) @@ -88,6 +90,7 @@ interpretCoterm _G _D = \case Covar (Global n) -> C.covar (Global n) MuL n b -> C.µL n (\ t -> interpretCommand (_G |> PVar (n :=: t)) _D b) FunL a k -> C.funL (interpretTerm _G _D a) (interpretCoterm _G _D k) + SumL l r -> C.sumL (\ t -> interpretCommand (_G |> PVar (__ :=: t)) _D l) (\ t -> interpretCommand (_G |> PVar (__ :=: t)) _D r) interpretCommand :: C.Sequent t c d => Env t -> Env c -> Command -> d interpretCommand _G _D (t :|: c) = interpretTerm _G _D t C..|. interpretCoterm _G _D c diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index 384cedc3e..8036e37d6 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -35,6 +35,7 @@ data Coterm = Covar (Var (LName Level)) | MuL Name (Term -> Command) | FunL Term Coterm + | SumL (Term -> Command) (Term -> Command) -- Commands @@ -54,6 +55,7 @@ instance Class.Sequent Term Coterm Command where covar = Covar µL = MuL funL = FunL + sumL = SumL (.|.) = (:|:) @@ -78,6 +80,7 @@ instance Quote Coterm X.Coterm where Covar v -> Quoter (\ d -> X.Covar (toIndexed d v)) MuL n b -> X.MuL n <$> quoteBinder (Quoter (\ d -> Var (Free (LName (getUsed d) n)))) b FunL a b -> liftA2 X.FunL (quote a) (quote b) + SumL l r -> liftA2 X.SumL (quoteBinder (Quoter (\ d -> Var (Free (LName (getUsed d) __)))) l) (quoteBinder (Quoter (\ d -> Var (Free (LName (getUsed d) __)))) r) instance Quote Command X.Command where diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index 6ac5a77ec..d1d6bb562 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -6,6 +6,7 @@ module Facet.Sequent.Print import Facet.Name import Facet.Pattern (Pattern(..)) +import Facet.Pretty import Facet.Print.Options import qualified Facet.Sequent.Class as S import qualified Facet.Style as S @@ -39,6 +40,7 @@ instance S.Sequent Print Print Print where covar = var µL n b = µ̃ <> P.braces (P.pretty n P.<+> P.dot P.<+> withLevel (\ d -> b (var (Free (LName (getUsed d) n))))) funL a k = a P.<+> P.dot P.<+> k + sumL l r = µ̃ <> P.braces (commaSep [fresh (\ v -> anon v P.<+> P.dot P.<+> l (anon v)), fresh (\ v -> anon v P.<+> P.dot P.<+> r (anon v))]) (.|.) = fmap (P.enclose P.langle P.rangle) . P.surround P.pipe @@ -48,6 +50,12 @@ withLevel f = Print (\ o d -> doc (f d) o d) incrLevel :: Print -> Print incrLevel p = Print (\ o -> doc p o . succ) +fresh :: (Used -> Print) -> Print +fresh f = withLevel (incrLevel . f) + +anon :: Used -> Print +anon = lower . getLevel . getUsed + withOpts :: (Options Print -> Print) -> Print withOpts f = Print (\ o d -> doc (f o) o d) From 256c1e9b54aa900efc07a1c556ef6a263cb20d22 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 19 Dec 2021 12:36:15 -0500 Subject: [PATCH 0514/1324] Lift sumL into effectful contexts. --- src/Facet/Sequent/Class.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 2ce8331b8..c6dff9421 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -8,8 +8,10 @@ module Facet.Sequent.Class , Clause(..) , funRA , µLA +, sumLA ) where +import Control.Applicative (liftA2) import Data.Functor.Identity (Identity(..)) import Data.Text (Text) import Facet.Functor.Compose @@ -69,3 +71,10 @@ funRA cs = runC (funR <$> traverse (uncurry clause) cs) -> (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j d)) -> m (i c) µLA n f = fmap (µL n) . runC <$> f liftCOuter (liftCInner id) + +sumLA + :: (Sequent t c d, Applicative i, Applicative m) + => (forall j . Applicative j => j t -> m (j d)) + -> (forall j . Applicative j => j t -> m (j d)) + -> m (i c) +sumLA f g = (\ a b -> liftA2 sumL (runC a) (runC b)) <$> f (liftCInner id) <*> g (liftCInner id) From b25b45344053b48c428f543439e9c158c7e202fd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 19 Dec 2021 12:40:51 -0500 Subject: [PATCH 0515/1324] =?UTF-8?q?:fire:=20the=20Name=20params=20to=20t?= =?UTF-8?q?he=20=C2=B5=20abstractions.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Elab/Term.hs | 2 +- src/Facet/Sequent/Class.hs | 14 ++++++-------- src/Facet/Sequent/Expr.hs | 12 ++++++------ src/Facet/Sequent/Norm.hs | 8 ++++---- src/Facet/Sequent/Print.hs | 4 ++-- 5 files changed, 19 insertions(+), 21 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index f43813519..3c0258cbb 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -152,7 +152,7 @@ appS f a = do f' :==> _F <- f (_, q, _A, _B) <- assertFunction _F a' <- censor @Usage (q ><<) $ check (a ::: _A) - pure $ SQ.µR __ (\ k -> f' SQ..|. SQ.funL a' k) :==> _B + pure $ SQ.µR (\ k -> f' SQ..|. SQ.funL a' k) :==> _B string :: Text -> Elab m (Term :==> Type) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index c6dff9421..5a6686bb2 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -24,7 +24,7 @@ import Facet.Syntax (Var, (:=:)(..)) class Sequent term coterm command | coterm -> term command, term -> coterm command, command -> term coterm where -- Terms var :: Var (LName Level) -> term - µR :: Name -> (coterm -> command) -> term + µR :: (coterm -> command) -> term funR :: [(Pattern Name, Pattern (Name :=: term) -> term)] -> term conR :: RName -> [term] -> term stringR :: Text -> term @@ -33,7 +33,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma -- Coterms covar :: Var (LName Level) -> coterm - µL :: Name -> (term -> command) -> coterm + µL :: (term -> command) -> coterm funL :: term -> coterm -> coterm sumL :: (term -> command) -> (term -> command) -> coterm @@ -51,10 +51,9 @@ strengthen = fmap runIdentity µRA :: (Sequent t c d, Applicative i, Applicative m) - => Name - -> (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) + => (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) -> m (i t) -µRA n f = fmap (µR n) . runC <$> f liftCOuter (liftCInner id) +µRA f = fmap µR . runC <$> f liftCOuter (liftCInner id) newtype Clause i m t c d = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j (Pattern (Name :=: t)) -> m (j t) } @@ -67,10 +66,9 @@ funRA cs = runC (funR <$> traverse (uncurry clause) cs) µLA :: (Sequent t c d, Applicative i, Applicative m) - => Name - -> (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j d)) + => (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j d)) -> m (i c) -µLA n f = fmap (µL n) . runC <$> f liftCOuter (liftCInner id) +µLA f = fmap µL . runC <$> f liftCOuter (liftCInner id) sumLA :: (Sequent t c d, Applicative i, Applicative m) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 075841692..1b5d70df4 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -25,7 +25,7 @@ import Facet.Syntax data Term = Var (Var (LName Index)) - | MuR Name Command + | MuR Command | FunR [(Pattern Name, Term)] | ConR RName [Term] | StringR Text @@ -37,7 +37,7 @@ data Term data Coterm = Covar (Var (LName Index)) - | MuL Name Command + | MuL Command | FunL Term Coterm | SumL Command Command @@ -49,7 +49,7 @@ data Command = Term :|: Coterm instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where var v = Quoter (\ d -> Var (toIndexed d v)) - µR n b = MuR n <$> binder (\ d' -> Quoter (\ d -> covar n (toIndexed d d'))) b + µR b = MuR <$> binder (\ d' -> Quoter (\ d -> covar __ (toIndexed d d'))) b funR ps = FunR <$> traverse (uncurry clause) ps conR n fs = ConR n <$> sequenceA fs stringR = pure . StringR @@ -57,7 +57,7 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where compR i b = CompR i . snd <$> clause (PDict i) b covar v = Quoter (\ d -> Covar (toIndexed d v)) - µL n b = MuL n <$> binder (\ d' -> Quoter (\ d -> var n (toIndexed d d'))) b + µL b = MuL <$> binder (\ d' -> Quoter (\ d -> var __ (toIndexed d d'))) b funL a b = FunL <$> a <*> b sumL l r = SumL <$> binder (\ d' -> Quoter (\ d -> var __ (toIndexed d d'))) l <*> binder (\ d' -> Quoter (\ d -> var __ (toIndexed d d'))) r @@ -77,7 +77,7 @@ interpretTerm :: C.Sequent t c d => Env t -> Env c -> Term -> t interpretTerm _G _D = \case Var (Free n) -> _G `index` n Var (Global n) -> C.var (Global n) - MuR n b -> C.µR n (\ k -> interpretCommand _G (_D |> PVar (n :=: k)) b) + MuR b -> C.µR (\ k -> interpretCommand _G (_D |> PVar (__ :=: k)) b) FunR cs -> C.funR (map (fmap (\ t p -> interpretTerm (_G |> p) _D t)) cs) ConR n fs -> C.conR n (map (interpretTerm _G _D) fs) StringR s -> C.stringR s @@ -88,7 +88,7 @@ interpretCoterm :: C.Sequent t c d => Env t -> Env c -> Coterm -> c interpretCoterm _G _D = \case Covar (Free n) -> _D `index` n Covar (Global n) -> C.covar (Global n) - MuL n b -> C.µL n (\ t -> interpretCommand (_G |> PVar (n :=: t)) _D b) + MuL b -> C.µL (\ t -> interpretCommand (_G |> PVar (__ :=: t)) _D b) FunL a k -> C.funL (interpretTerm _G _D a) (interpretCoterm _G _D k) SumL l r -> C.sumL (\ t -> interpretCommand (_G |> PVar (__ :=: t)) _D l) (\ t -> interpretCommand (_G |> PVar (__ :=: t)) _D r) diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index 8036e37d6..6573744a0 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -21,7 +21,7 @@ import Facet.Syntax data Term = Var (Var (LName Level)) - | MuR Name (Coterm -> Command) + | MuR (Coterm -> Command) | FunR [(Pattern Name, Pattern (Name :=: Term) -> Term)] | ConR RName [Term] | StringR Text @@ -33,7 +33,7 @@ data Term data Coterm = Covar (Var (LName Level)) - | MuL Name (Term -> Command) + | MuL (Term -> Command) | FunL Term Coterm | SumL (Term -> Command) (Term -> Command) @@ -63,7 +63,7 @@ instance Class.Sequent Term Coterm Command where instance Quote Term X.Term where quote = \case Var v -> Quoter (\ d -> X.Var (toIndexed d v)) - MuR n b -> X.MuR n <$> quoteBinder (Quoter (\ d -> Covar (Free (LName (getUsed d) n)))) b + MuR b -> X.MuR <$> quoteBinder (Quoter (\ d -> Covar (Free (LName (getUsed d) __)))) b FunR ps -> X.FunR <$> traverse (uncurry clause) ps ConR n fs -> X.ConR n <$> traverse quote fs StringR t -> pure (X.StringR t) @@ -78,7 +78,7 @@ instance Quote Term X.Term where instance Quote Coterm X.Coterm where quote = \case Covar v -> Quoter (\ d -> X.Covar (toIndexed d v)) - MuL n b -> X.MuL n <$> quoteBinder (Quoter (\ d -> Var (Free (LName (getUsed d) n)))) b + MuL b -> X.MuL <$> quoteBinder (Quoter (\ d -> Var (Free (LName (getUsed d) __)))) b FunL a b -> liftA2 X.FunL (quote a) (quote b) SumL l r -> liftA2 X.SumL (quoteBinder (Quoter (\ d -> Var (Free (LName (getUsed d) __)))) l) (quoteBinder (Quoter (\ d -> Var (Free (LName (getUsed d) __)))) r) diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index d1d6bb562..21c5fdec3 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -27,7 +27,7 @@ instance Show Print where instance S.Sequent Print Print Print where var = var - µR n b = P.pretty "µ" <> P.braces (nameVar n id P.<+> P.dot P.<+> nameVar n b) + µR b = P.pretty "µ" <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) funR cs = P.braces (P.encloseSep (P.flatAlt P.space mempty) (P.flatAlt P.space mempty) (P.comma <> P.space) (map (uncurry clause) cs)) conR n fs = foldl1 (P.surround P.space) (S.var (Global n):fs) stringR = P.pretty . show @@ -38,7 +38,7 @@ instance S.Sequent Print Print Print where . P.enclose P.space P.space $ clause (PDict p) b covar = var - µL n b = µ̃ <> P.braces (P.pretty n P.<+> P.dot P.<+> withLevel (\ d -> b (var (Free (LName (getUsed d) n))))) + µL b = µ̃ <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) funL a k = a P.<+> P.dot P.<+> k sumL l r = µ̃ <> P.braces (commaSep [fresh (\ v -> anon v P.<+> P.dot P.<+> l (anon v)), fresh (\ v -> anon v P.<+> P.dot P.<+> r (anon v))]) From 1e9b244984974fece31f69230e596b18dd10df68 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 19 Dec 2021 12:44:17 -0500 Subject: [PATCH 0516/1324] Simplify clause handling. --- src/Facet/Sequent/Class.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 5a6686bb2..e1193ae4b 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -58,10 +58,10 @@ strengthen = fmap runIdentity newtype Clause i m t c d = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j (Pattern (Name :=: t)) -> m (j t) } funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause i m t c d)] -> m (i t) -funRA cs = runC (funR <$> traverse (uncurry clause) cs) +funRA cs = runC (funR <$> traverse (traverse (C . clause)) cs) where - clause :: (Functor m, Applicative i) => Pattern Name -> Clause i m t c d -> (m . i) (Pattern Name, Pattern (Name :=: t) -> t) - clause p (Clause c) = C (fmap (p,) . runC <$> c liftCOuter (liftCInner id)) + clause :: (Functor m, Applicative i) => Clause i m t c d -> m (i (Pattern (Name :=: t) -> t)) + clause (Clause c) = runC <$> c liftCOuter (liftCInner id) µLA From c37d1b838e17029b387f72f27cb7f6c959720cc0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 19 Dec 2021 12:47:19 -0500 Subject: [PATCH 0517/1324] Abstract binder handling out. --- src/Facet/Functor/Compose.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index 6a087fdb8..17a021810 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -6,6 +6,7 @@ module Facet.Functor.Compose , mapCInner , liftCOuter , mapCOuter +, binder ) where import Control.Applicative (Alternative(..)) @@ -35,3 +36,6 @@ liftCOuter = C . fmap pure mapCOuter :: (i (j a) -> i' (j' b)) -> ((i . j) a -> (i' . j') b) mapCOuter f = C . f . runC + +binder :: (Functor m, Applicative i) => (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) -> m (i (c -> d)) +binder c = runC <$> c liftCOuter (liftCInner id) From bf96ee45e0a966a7f50415bc49e23700a3945bec Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 19 Dec 2021 12:50:04 -0500 Subject: [PATCH 0518/1324] Add weakening rules to sumLA. --- src/Facet/Sequent/Class.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index e1193ae4b..e5a890c6f 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -72,7 +72,7 @@ funRA cs = runC (funR <$> traverse (traverse (C . clause)) cs) sumLA :: (Sequent t c d, Applicative i, Applicative m) - => (forall j . Applicative j => j t -> m (j d)) - -> (forall j . Applicative j => j t -> m (j d)) + => (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j d)) + -> (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j d)) -> m (i c) -sumLA f g = (\ a b -> liftA2 sumL (runC a) (runC b)) <$> f (liftCInner id) <*> g (liftCInner id) +sumLA f g = (\ a b -> liftA2 sumL (runC a) (runC b)) <$> f liftCOuter (liftCInner id) <*> g liftCOuter (liftCInner id) From fa3a3268aef4a4601b1753646ac4a49a4608b38c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 19 Dec 2021 12:51:13 -0500 Subject: [PATCH 0519/1324] Use the binder abstraction for all the effectful combinators. --- src/Facet/Sequent/Class.hs | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index e5a890c6f..1c3deb7a6 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -53,26 +53,23 @@ strengthen = fmap runIdentity :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) -> m (i t) -µRA f = fmap µR . runC <$> f liftCOuter (liftCInner id) +µRA f = fmap µR <$> binder f newtype Clause i m t c d = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j (Pattern (Name :=: t)) -> m (j t) } funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause i m t c d)] -> m (i t) -funRA cs = runC (funR <$> traverse (traverse (C . clause)) cs) - where - clause :: (Functor m, Applicative i) => Clause i m t c d -> m (i (Pattern (Name :=: t) -> t)) - clause (Clause c) = runC <$> c liftCOuter (liftCInner id) +funRA cs = runC (funR <$> traverse (traverse (\ (Clause c) -> C (binder c))) cs) µLA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j d)) -> m (i c) -µLA f = fmap µL . runC <$> f liftCOuter (liftCInner id) +µLA f = fmap µL <$> binder f sumLA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j d)) -> (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j d)) -> m (i c) -sumLA f g = (\ a b -> liftA2 sumL (runC a) (runC b)) <$> f liftCOuter (liftCInner id) <*> g liftCOuter (liftCInner id) +sumLA f g = liftA2 sumL <$> binder f <*> binder g From 70a8a823da3af3d8aaf4c5078b5f8e3684821423 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 19 Dec 2021 13:05:30 -0500 Subject: [PATCH 0520/1324] Add some construction. --- src/Facet/Sequent/Class.hs | 2 ++ src/Facet/Sequent/Expr.hs | 6 ++++++ src/Facet/Sequent/Norm.hs | 6 ++++++ src/Facet/Sequent/Print.hs | 2 ++ 4 files changed, 16 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 1c3deb7a6..dbf21b09d 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -26,6 +26,8 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma var :: Var (LName Level) -> term µR :: (coterm -> command) -> term funR :: [(Pattern Name, Pattern (Name :=: term) -> term)] -> term + sumR1 :: term -> term + sumR2 :: term -> term conR :: RName -> [term] -> term stringR :: Text -> term dictR :: [RName :=: term] -> term diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 1b5d70df4..560c475cc 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -27,6 +27,8 @@ data Term = Var (Var (LName Index)) | MuR Command | FunR [(Pattern Name, Term)] + | SumR1 Term + | SumR2 Term | ConR RName [Term] | StringR Text | DictR [RName :=: Term] @@ -51,6 +53,8 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where var v = Quoter (\ d -> Var (toIndexed d v)) µR b = MuR <$> binder (\ d' -> Quoter (\ d -> covar __ (toIndexed d d'))) b funR ps = FunR <$> traverse (uncurry clause) ps + sumR1 = fmap SumR1 + sumR2 = fmap SumR2 conR n fs = ConR n <$> sequenceA fs stringR = pure . StringR dictR i = DictR <$> traverse sequenceA i @@ -79,6 +83,8 @@ interpretTerm _G _D = \case Var (Global n) -> C.var (Global n) MuR b -> C.µR (\ k -> interpretCommand _G (_D |> PVar (__ :=: k)) b) FunR cs -> C.funR (map (fmap (\ t p -> interpretTerm (_G |> p) _D t)) cs) + SumR1 t -> C.sumR1 (interpretTerm _G _D t) + SumR2 t -> C.sumR2 (interpretTerm _G _D t) ConR n fs -> C.conR n (map (interpretTerm _G _D) fs) StringR s -> C.stringR s DictR ops -> C.dictR (map (fmap (interpretTerm _G _D)) ops) diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index 6573744a0..e400e4a21 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -23,6 +23,8 @@ data Term = Var (Var (LName Level)) | MuR (Coterm -> Command) | FunR [(Pattern Name, Pattern (Name :=: Term) -> Term)] + | SumR1 Term + | SumR2 Term | ConR RName [Term] | StringR Text | DictR [RName :=: Term] @@ -47,6 +49,8 @@ instance Class.Sequent Term Coterm Command where var = Var µR = MuR funR = FunR + sumR1 = SumR1 + sumR2 = SumR2 conR = ConR stringR = StringR dictR = DictR @@ -65,6 +69,8 @@ instance Quote Term X.Term where Var v -> Quoter (\ d -> X.Var (toIndexed d v)) MuR b -> X.MuR <$> quoteBinder (Quoter (\ d -> Covar (Free (LName (getUsed d) __)))) b FunR ps -> X.FunR <$> traverse (uncurry clause) ps + SumR1 t -> X.SumR1 <$> quote t + SumR2 t -> X.SumR2 <$> quote t ConR n fs -> X.ConR n <$> traverse quote fs StringR t -> pure (X.StringR t) DictR ops -> X.DictR <$> traverse (traverse quote) ops diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index 21c5fdec3..b877c2b6a 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -29,6 +29,8 @@ instance S.Sequent Print Print Print where var = var µR b = P.pretty "µ" <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) funR cs = P.braces (P.encloseSep (P.flatAlt P.space mempty) (P.flatAlt P.space mempty) (P.comma <> P.space) (map (uncurry clause) cs)) + sumR1 t = P.parens (P.pretty "inl" P.<+> t) + sumR2 t = P.parens (P.pretty "inr" P.<+> t) conR n fs = foldl1 (P.surround P.space) (S.var (Global n):fs) stringR = P.pretty . show dictR os = withOpts (\ Options{..} -> P.brackets (P.flatAlt P.space P.line <> commaSep (map (\ (n :=: v) -> rname n P.<+> P.equals P.<+> P.group v) os) <> P.flatAlt P.space P.line)) From 01db4b52d181840610f06629f2f48e4d19f13c00 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 19 Dec 2021 13:08:39 -0500 Subject: [PATCH 0521/1324] Swap the parameters to Clause. --- src/Facet/Sequent/Class.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index dbf21b09d..2b4572e76 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -57,9 +57,9 @@ strengthen = fmap runIdentity -> m (i t) µRA f = fmap µR <$> binder f -newtype Clause i m t c d = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j (Pattern (Name :=: t)) -> m (j t) } +newtype Clause m i t c d = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j (Pattern (Name :=: t)) -> m (j t) } -funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause i m t c d)] -> m (i t) +funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause m i t c d)] -> m (i t) funRA cs = runC (funR <$> traverse (traverse (\ (Clause c) -> C (binder c))) cs) From 2043fe1239c1c3a614c3e1b88de58d1b9289367c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 19 Dec 2021 13:09:56 -0500 Subject: [PATCH 0522/1324] Factor the variable type out. --- src/Facet/Sequent/Class.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 2b4572e76..617d8eece 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -57,9 +57,9 @@ strengthen = fmap runIdentity -> m (i t) µRA f = fmap µR <$> binder f -newtype Clause m i t c d = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j (Pattern (Name :=: t)) -> m (j t) } +newtype Clause m i t c d a = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j a -> m (j t) } -funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause m i t c d)] -> m (i t) +funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause m i t c d (Pattern (Name :=: t)))] -> m (i t) funRA cs = runC (funR <$> traverse (traverse (\ (Clause c) -> C (binder c))) cs) From 7908a139ba6160d0da6c0b7c25c03d7011d108fa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 19 Dec 2021 13:10:36 -0500 Subject: [PATCH 0523/1324] :fire: the phantom params. --- src/Facet/Sequent/Class.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 617d8eece..fb8b99929 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -57,9 +57,9 @@ strengthen = fmap runIdentity -> m (i t) µRA f = fmap µR <$> binder f -newtype Clause m i t c d a = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j a -> m (j t) } +newtype Clause m i t a = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j a -> m (j t) } -funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause m i t c d (Pattern (Name :=: t)))] -> m (i t) +funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause m i t (Pattern (Name :=: t)))] -> m (i t) funRA cs = runC (funR <$> traverse (traverse (\ (Clause c) -> C (binder c))) cs) From 227ca54f7434b3cdf7e528eff5de8ccef9253d5c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 19 Dec 2021 13:11:15 -0500 Subject: [PATCH 0524/1324] Swap the last two params. --- src/Facet/Sequent/Class.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index fb8b99929..2937cdbca 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -57,9 +57,9 @@ strengthen = fmap runIdentity -> m (i t) µRA f = fmap µR <$> binder f -newtype Clause m i t a = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j a -> m (j t) } +newtype Clause m i a b = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j a -> m (j b) } -funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause m i t (Pattern (Name :=: t)))] -> m (i t) +funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause m i (Pattern (Name :=: t)) t)] -> m (i t) funRA cs = runC (funR <$> traverse (traverse (\ (Clause c) -> C (binder c))) cs) From b1a35a2d69bd940194c37f91a68d1772eee6354c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 19 Dec 2021 13:12:31 -0500 Subject: [PATCH 0525/1324] Move Clause to Compose. --- src/Facet/Functor/Compose.hs | 3 +++ src/Facet/Sequent/Class.hs | 2 -- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index 17a021810..2eff55113 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -7,6 +7,7 @@ module Facet.Functor.Compose , liftCOuter , mapCOuter , binder +, Clause(..) ) where import Control.Applicative (Alternative(..)) @@ -39,3 +40,5 @@ mapCOuter f = C . f . runC binder :: (Functor m, Applicative i) => (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) -> m (i (c -> d)) binder c = runC <$> c liftCOuter (liftCInner id) + +newtype Clause m i a b = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j a -> m (j b) } diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 2937cdbca..5e0ac741b 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -57,8 +57,6 @@ strengthen = fmap runIdentity -> m (i t) µRA f = fmap µR <$> binder f -newtype Clause m i a b = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j a -> m (j b) } - funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause m i (Pattern (Name :=: t)) t)] -> m (i t) funRA cs = runC (funR <$> traverse (traverse (\ (Clause c) -> C (binder c))) cs) From 3f174f34d5062b64927d7bf5f14fe034a954148f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 19 Dec 2021 13:13:13 -0500 Subject: [PATCH 0526/1324] Heading. --- src/Facet/Functor/Compose.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index 2eff55113..dfd0630d7 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -6,6 +6,7 @@ module Facet.Functor.Compose , mapCInner , liftCOuter , mapCOuter + -- * Binding syntax , binder , Clause(..) ) where @@ -38,6 +39,9 @@ liftCOuter = C . fmap pure mapCOuter :: (i (j a) -> i' (j' b)) -> ((i . j) a -> (i' . j') b) mapCOuter f = C . f . runC + +-- Binding syntax + binder :: (Functor m, Applicative i) => (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) -> m (i (c -> d)) binder c = runC <$> c liftCOuter (liftCInner id) From af08a2b0509c1c0bae560ad1792d140f7d4efa40 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 19 Dec 2021 13:13:51 -0500 Subject: [PATCH 0527/1324] Lift. --- src/Facet/Functor/Compose.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index dfd0630d7..3ef1781a9 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -19,7 +19,7 @@ newtype (i . j) a = C { runC :: i (j a) } deriving (Functor) instance (Applicative i, Applicative j) => Applicative (i . j) where - pure = C . pure . pure + pure = liftCInner . pure C f <*> C a = C ((<*>) <$> f <*> a) instance (Alternative i, Applicative j) => Alternative (i . j) where From f13693b78ae8ab9ab74e9c3c2538168f94462cdc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 19 Dec 2021 13:24:40 -0500 Subject: [PATCH 0528/1324] N-ary sums. --- src/Facet/Sequent/Class.hs | 11 ++++------- src/Facet/Sequent/Expr.hs | 15 ++++++--------- src/Facet/Sequent/Norm.hs | 13 +++++-------- src/Facet/Sequent/Print.hs | 5 ++--- 4 files changed, 17 insertions(+), 27 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 5e0ac741b..715595812 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -11,7 +11,6 @@ module Facet.Sequent.Class , sumLA ) where -import Control.Applicative (liftA2) import Data.Functor.Identity (Identity(..)) import Data.Text (Text) import Facet.Functor.Compose @@ -26,8 +25,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma var :: Var (LName Level) -> term µR :: (coterm -> command) -> term funR :: [(Pattern Name, Pattern (Name :=: term) -> term)] -> term - sumR1 :: term -> term - sumR2 :: term -> term + sumR :: Int -> term -> term conR :: RName -> [term] -> term stringR :: Text -> term dictR :: [RName :=: term] -> term @@ -37,7 +35,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma covar :: Var (LName Level) -> coterm µL :: (term -> command) -> coterm funL :: term -> coterm -> coterm - sumL :: (term -> command) -> (term -> command) -> coterm + sumL :: [term -> command] -> coterm -- Commands (.|.) :: term -> coterm -> command @@ -69,7 +67,6 @@ funRA cs = runC (funR <$> traverse (traverse (\ (Clause c) -> C (binder c))) cs) sumLA :: (Sequent t c d, Applicative i, Applicative m) - => (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j d)) - -> (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j d)) + => [Clause m i t d] -> m (i c) -sumLA f g = liftA2 sumL <$> binder f <*> binder g +sumLA cs = runC (sumL <$> traverse (\ (Clause c) -> C (binder c)) cs) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 560c475cc..28bc08045 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -27,8 +27,7 @@ data Term = Var (Var (LName Index)) | MuR Command | FunR [(Pattern Name, Term)] - | SumR1 Term - | SumR2 Term + | SumR Int Term | ConR RName [Term] | StringR Text | DictR [RName :=: Term] @@ -41,7 +40,7 @@ data Coterm = Covar (Var (LName Index)) | MuL Command | FunL Term Coterm - | SumL Command Command + | SumL [Command] -- Commands @@ -53,8 +52,7 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where var v = Quoter (\ d -> Var (toIndexed d v)) µR b = MuR <$> binder (\ d' -> Quoter (\ d -> covar __ (toIndexed d d'))) b funR ps = FunR <$> traverse (uncurry clause) ps - sumR1 = fmap SumR1 - sumR2 = fmap SumR2 + sumR = fmap . SumR conR n fs = ConR n <$> sequenceA fs stringR = pure . StringR dictR i = DictR <$> traverse sequenceA i @@ -63,7 +61,7 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where covar v = Quoter (\ d -> Covar (toIndexed d v)) µL b = MuL <$> binder (\ d' -> Quoter (\ d -> var __ (toIndexed d d'))) b funL a b = FunL <$> a <*> b - sumL l r = SumL <$> binder (\ d' -> Quoter (\ d -> var __ (toIndexed d d'))) l <*> binder (\ d' -> Quoter (\ d -> var __ (toIndexed d d'))) r + sumL = fmap SumL . traverse (binder (\ d' -> Quoter (\ d -> var __ (toIndexed d d')))) (.|.) = liftA2 (:|:) @@ -83,8 +81,7 @@ interpretTerm _G _D = \case Var (Global n) -> C.var (Global n) MuR b -> C.µR (\ k -> interpretCommand _G (_D |> PVar (__ :=: k)) b) FunR cs -> C.funR (map (fmap (\ t p -> interpretTerm (_G |> p) _D t)) cs) - SumR1 t -> C.sumR1 (interpretTerm _G _D t) - SumR2 t -> C.sumR2 (interpretTerm _G _D t) + SumR i t -> C.sumR i (interpretTerm _G _D t) ConR n fs -> C.conR n (map (interpretTerm _G _D) fs) StringR s -> C.stringR s DictR ops -> C.dictR (map (fmap (interpretTerm _G _D)) ops) @@ -96,7 +93,7 @@ interpretCoterm _G _D = \case Covar (Global n) -> C.covar (Global n) MuL b -> C.µL (\ t -> interpretCommand (_G |> PVar (__ :=: t)) _D b) FunL a k -> C.funL (interpretTerm _G _D a) (interpretCoterm _G _D k) - SumL l r -> C.sumL (\ t -> interpretCommand (_G |> PVar (__ :=: t)) _D l) (\ t -> interpretCommand (_G |> PVar (__ :=: t)) _D r) + SumL cs -> C.sumL (map (\ d t -> interpretCommand (_G |> PVar (__ :=: t)) _D d) cs) interpretCommand :: C.Sequent t c d => Env t -> Env c -> Command -> d interpretCommand _G _D (t :|: c) = interpretTerm _G _D t C..|. interpretCoterm _G _D c diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index e400e4a21..c044e4723 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -23,8 +23,7 @@ data Term = Var (Var (LName Level)) | MuR (Coterm -> Command) | FunR [(Pattern Name, Pattern (Name :=: Term) -> Term)] - | SumR1 Term - | SumR2 Term + | SumR Int Term | ConR RName [Term] | StringR Text | DictR [RName :=: Term] @@ -37,7 +36,7 @@ data Coterm = Covar (Var (LName Level)) | MuL (Term -> Command) | FunL Term Coterm - | SumL (Term -> Command) (Term -> Command) + | SumL [Term -> Command] -- Commands @@ -49,8 +48,7 @@ instance Class.Sequent Term Coterm Command where var = Var µR = MuR funR = FunR - sumR1 = SumR1 - sumR2 = SumR2 + sumR = SumR conR = ConR stringR = StringR dictR = DictR @@ -69,8 +67,7 @@ instance Quote Term X.Term where Var v -> Quoter (\ d -> X.Var (toIndexed d v)) MuR b -> X.MuR <$> quoteBinder (Quoter (\ d -> Covar (Free (LName (getUsed d) __)))) b FunR ps -> X.FunR <$> traverse (uncurry clause) ps - SumR1 t -> X.SumR1 <$> quote t - SumR2 t -> X.SumR2 <$> quote t + SumR i t -> X.SumR i <$> quote t ConR n fs -> X.ConR n <$> traverse quote fs StringR t -> pure (X.StringR t) DictR ops -> X.DictR <$> traverse (traverse quote) ops @@ -86,7 +83,7 @@ instance Quote Coterm X.Coterm where Covar v -> Quoter (\ d -> X.Covar (toIndexed d v)) MuL b -> X.MuL <$> quoteBinder (Quoter (\ d -> Var (Free (LName (getUsed d) __)))) b FunL a b -> liftA2 X.FunL (quote a) (quote b) - SumL l r -> liftA2 X.SumL (quoteBinder (Quoter (\ d -> Var (Free (LName (getUsed d) __)))) l) (quoteBinder (Quoter (\ d -> Var (Free (LName (getUsed d) __)))) r) + SumL cs -> X.SumL <$> traverse (quoteBinder (Quoter (\ d -> Var (Free (LName (getUsed d) __))))) cs instance Quote Command X.Command where diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index b877c2b6a..d3725f7c5 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -29,8 +29,7 @@ instance S.Sequent Print Print Print where var = var µR b = P.pretty "µ" <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) funR cs = P.braces (P.encloseSep (P.flatAlt P.space mempty) (P.flatAlt P.space mempty) (P.comma <> P.space) (map (uncurry clause) cs)) - sumR1 t = P.parens (P.pretty "inl" P.<+> t) - sumR2 t = P.parens (P.pretty "inr" P.<+> t) + sumR i t = P.parens (P.pretty "in" <> P.pretty i P.<+> t) conR n fs = foldl1 (P.surround P.space) (S.var (Global n):fs) stringR = P.pretty . show dictR os = withOpts (\ Options{..} -> P.brackets (P.flatAlt P.space P.line <> commaSep (map (\ (n :=: v) -> rname n P.<+> P.equals P.<+> P.group v) os) <> P.flatAlt P.space P.line)) @@ -42,7 +41,7 @@ instance S.Sequent Print Print Print where covar = var µL b = µ̃ <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) funL a k = a P.<+> P.dot P.<+> k - sumL l r = µ̃ <> P.braces (commaSep [fresh (\ v -> anon v P.<+> P.dot P.<+> l (anon v)), fresh (\ v -> anon v P.<+> P.dot P.<+> r (anon v))]) + sumL cs = µ̃ <> P.braces (commaSep (map (\ c -> fresh (\ v -> anon v P.<+> P.dot P.<+> c (anon v))) cs)) (.|.) = fmap (P.enclose P.langle P.rangle) . P.surround P.pipe From 3274e9f9c6cb8c437776f631e23634ac181d33c0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 19 Dec 2021 13:33:36 -0500 Subject: [PATCH 0529/1324] Add n-ary products. --- src/Facet/Sequent/Class.hs | 1 + src/Facet/Sequent/Expr.hs | 3 +++ src/Facet/Sequent/Norm.hs | 3 +++ src/Facet/Sequent/Print.hs | 1 + 4 files changed, 8 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 715595812..88d4c4f3d 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -26,6 +26,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma µR :: (coterm -> command) -> term funR :: [(Pattern Name, Pattern (Name :=: term) -> term)] -> term sumR :: Int -> term -> term + prdR :: [term] -> term conR :: RName -> [term] -> term stringR :: Text -> term dictR :: [RName :=: term] -> term diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 28bc08045..124f42991 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -28,6 +28,7 @@ data Term | MuR Command | FunR [(Pattern Name, Term)] | SumR Int Term + | PrdR [Term] | ConR RName [Term] | StringR Text | DictR [RName :=: Term] @@ -53,6 +54,7 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where µR b = MuR <$> binder (\ d' -> Quoter (\ d -> covar __ (toIndexed d d'))) b funR ps = FunR <$> traverse (uncurry clause) ps sumR = fmap . SumR + prdR = fmap PrdR . sequenceA conR n fs = ConR n <$> sequenceA fs stringR = pure . StringR dictR i = DictR <$> traverse sequenceA i @@ -82,6 +84,7 @@ interpretTerm _G _D = \case MuR b -> C.µR (\ k -> interpretCommand _G (_D |> PVar (__ :=: k)) b) FunR cs -> C.funR (map (fmap (\ t p -> interpretTerm (_G |> p) _D t)) cs) SumR i t -> C.sumR i (interpretTerm _G _D t) + PrdR fs -> C.prdR (map (interpretTerm _G _D) fs) ConR n fs -> C.conR n (map (interpretTerm _G _D) fs) StringR s -> C.stringR s DictR ops -> C.dictR (map (fmap (interpretTerm _G _D)) ops) diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index c044e4723..722d8d843 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -24,6 +24,7 @@ data Term | MuR (Coterm -> Command) | FunR [(Pattern Name, Pattern (Name :=: Term) -> Term)] | SumR Int Term + | PrdR [Term] | ConR RName [Term] | StringR Text | DictR [RName :=: Term] @@ -49,6 +50,7 @@ instance Class.Sequent Term Coterm Command where µR = MuR funR = FunR sumR = SumR + prdR = PrdR conR = ConR stringR = StringR dictR = DictR @@ -68,6 +70,7 @@ instance Quote Term X.Term where MuR b -> X.MuR <$> quoteBinder (Quoter (\ d -> Covar (Free (LName (getUsed d) __)))) b FunR ps -> X.FunR <$> traverse (uncurry clause) ps SumR i t -> X.SumR i <$> quote t + PrdR fs -> X.PrdR <$> traverse quote fs ConR n fs -> X.ConR n <$> traverse quote fs StringR t -> pure (X.StringR t) DictR ops -> X.DictR <$> traverse (traverse quote) ops diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index d3725f7c5..73436dc13 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -30,6 +30,7 @@ instance S.Sequent Print Print Print where µR b = P.pretty "µ" <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) funR cs = P.braces (P.encloseSep (P.flatAlt P.space mempty) (P.flatAlt P.space mempty) (P.comma <> P.space) (map (uncurry clause) cs)) sumR i t = P.parens (P.pretty "in" <> P.pretty i P.<+> t) + prdR = P.tupled conR n fs = foldl1 (P.surround P.space) (S.var (Global n):fs) stringR = P.pretty . show dictR os = withOpts (\ Options{..} -> P.brackets (P.flatAlt P.space P.line <> commaSep (map (\ (n :=: v) -> rname n P.<+> P.equals P.<+> P.group v) os) <> P.flatAlt P.space P.line)) From fb5ea758ab323a139b9132166f0765c87abecea8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 19 Dec 2021 15:02:56 -0500 Subject: [PATCH 0530/1324] Eliminate n-ary products. --- src/Facet/Sequent/Class.hs | 1 + src/Facet/Sequent/Expr.hs | 3 +++ src/Facet/Sequent/Norm.hs | 3 +++ src/Facet/Sequent/Print.hs | 1 + 4 files changed, 8 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 88d4c4f3d..7b71ba215 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -37,6 +37,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma µL :: (term -> command) -> coterm funL :: term -> coterm -> coterm sumL :: [term -> command] -> coterm + prdL :: Int -> coterm -> coterm -- Commands (.|.) :: term -> coterm -> command diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 124f42991..1be168eb8 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -42,6 +42,7 @@ data Coterm | MuL Command | FunL Term Coterm | SumL [Command] + | PrdL Int Coterm -- Commands @@ -64,6 +65,7 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where µL b = MuL <$> binder (\ d' -> Quoter (\ d -> var __ (toIndexed d d'))) b funL a b = FunL <$> a <*> b sumL = fmap SumL . traverse (binder (\ d' -> Quoter (\ d -> var __ (toIndexed d d')))) + prdL = fmap . PrdL (.|.) = liftA2 (:|:) @@ -97,6 +99,7 @@ interpretCoterm _G _D = \case MuL b -> C.µL (\ t -> interpretCommand (_G |> PVar (__ :=: t)) _D b) FunL a k -> C.funL (interpretTerm _G _D a) (interpretCoterm _G _D k) SumL cs -> C.sumL (map (\ d t -> interpretCommand (_G |> PVar (__ :=: t)) _D d) cs) + PrdL i k -> C.prdL i (interpretCoterm _G _D k) interpretCommand :: C.Sequent t c d => Env t -> Env c -> Command -> d interpretCommand _G _D (t :|: c) = interpretTerm _G _D t C..|. interpretCoterm _G _D c diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index 722d8d843..e29fbddfe 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -38,6 +38,7 @@ data Coterm | MuL (Term -> Command) | FunL Term Coterm | SumL [Term -> Command] + | PrdL Int Coterm -- Commands @@ -60,6 +61,7 @@ instance Class.Sequent Term Coterm Command where µL = MuL funL = FunL sumL = SumL + prdL = PrdL (.|.) = (:|:) @@ -87,6 +89,7 @@ instance Quote Coterm X.Coterm where MuL b -> X.MuL <$> quoteBinder (Quoter (\ d -> Var (Free (LName (getUsed d) __)))) b FunL a b -> liftA2 X.FunL (quote a) (quote b) SumL cs -> X.SumL <$> traverse (quoteBinder (Quoter (\ d -> Var (Free (LName (getUsed d) __))))) cs + PrdL i k -> X.PrdL i <$> quote k instance Quote Command X.Command where diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index 73436dc13..b5d4117e7 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -43,6 +43,7 @@ instance S.Sequent Print Print Print where µL b = µ̃ <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) funL a k = a P.<+> P.dot P.<+> k sumL cs = µ̃ <> P.braces (commaSep (map (\ c -> fresh (\ v -> anon v P.<+> P.dot P.<+> c (anon v))) cs)) + prdL i k = P.parens (P.pretty "ex" <> P.pretty i P.<+> k) (.|.) = fmap (P.enclose P.langle P.rangle) . P.surround P.pipe From 49ca13bc9be26d015def97c98da3cb443364e8ab Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 20 Dec 2021 14:59:49 -0500 Subject: [PATCH 0531/1324] Index SumR by RName. --- src/Facet/Sequent/Class.hs | 2 +- src/Facet/Sequent/Expr.hs | 2 +- src/Facet/Sequent/Norm.hs | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 7b71ba215..a8bbc225d 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -25,7 +25,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma var :: Var (LName Level) -> term µR :: (coterm -> command) -> term funR :: [(Pattern Name, Pattern (Name :=: term) -> term)] -> term - sumR :: Int -> term -> term + sumR :: RName -> term -> term prdR :: [term] -> term conR :: RName -> [term] -> term stringR :: Text -> term diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 1be168eb8..8c3e98c5c 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -27,7 +27,7 @@ data Term = Var (Var (LName Index)) | MuR Command | FunR [(Pattern Name, Term)] - | SumR Int Term + | SumR RName Term | PrdR [Term] | ConR RName [Term] | StringR Text diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index e29fbddfe..b756bb5e3 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -23,7 +23,7 @@ data Term = Var (Var (LName Level)) | MuR (Coterm -> Command) | FunR [(Pattern Name, Pattern (Name :=: Term) -> Term)] - | SumR Int Term + | SumR RName Term | PrdR [Term] | ConR RName [Term] | StringR Text From 1c7caa0a73081313e433adc4454c8729d3786c5d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 20 Dec 2021 15:07:08 -0500 Subject: [PATCH 0532/1324] :fire: the ConR constructor. --- src/Facet/Sequent/Class.hs | 1 - src/Facet/Sequent/Expr.hs | 3 --- src/Facet/Sequent/Norm.hs | 3 --- 3 files changed, 7 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index a8bbc225d..e811c71d5 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -27,7 +27,6 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma funR :: [(Pattern Name, Pattern (Name :=: term) -> term)] -> term sumR :: RName -> term -> term prdR :: [term] -> term - conR :: RName -> [term] -> term stringR :: Text -> term dictR :: [RName :=: term] -> term compR :: [RName :=: Name] -> (Pattern (Name :=: term) -> term) -> term diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 8c3e98c5c..4fedf1688 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -29,7 +29,6 @@ data Term | FunR [(Pattern Name, Term)] | SumR RName Term | PrdR [Term] - | ConR RName [Term] | StringR Text | DictR [RName :=: Term] | CompR [RName :=: Name] Term @@ -56,7 +55,6 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where funR ps = FunR <$> traverse (uncurry clause) ps sumR = fmap . SumR prdR = fmap PrdR . sequenceA - conR n fs = ConR n <$> sequenceA fs stringR = pure . StringR dictR i = DictR <$> traverse sequenceA i compR i b = CompR i . snd <$> clause (PDict i) b @@ -87,7 +85,6 @@ interpretTerm _G _D = \case FunR cs -> C.funR (map (fmap (\ t p -> interpretTerm (_G |> p) _D t)) cs) SumR i t -> C.sumR i (interpretTerm _G _D t) PrdR fs -> C.prdR (map (interpretTerm _G _D) fs) - ConR n fs -> C.conR n (map (interpretTerm _G _D) fs) StringR s -> C.stringR s DictR ops -> C.dictR (map (fmap (interpretTerm _G _D)) ops) CompR i b -> C.compR i (\ p -> interpretTerm (_G |> p) _D b) diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index b756bb5e3..c2038143b 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -25,7 +25,6 @@ data Term | FunR [(Pattern Name, Pattern (Name :=: Term) -> Term)] | SumR RName Term | PrdR [Term] - | ConR RName [Term] | StringR Text | DictR [RName :=: Term] | CompR [RName :=: Name] (Pattern (Name :=: Term) -> Term) @@ -52,7 +51,6 @@ instance Class.Sequent Term Coterm Command where funR = FunR sumR = SumR prdR = PrdR - conR = ConR stringR = StringR dictR = DictR compR = CompR @@ -73,7 +71,6 @@ instance Quote Term X.Term where FunR ps -> X.FunR <$> traverse (uncurry clause) ps SumR i t -> X.SumR i <$> quote t PrdR fs -> X.PrdR <$> traverse quote fs - ConR n fs -> X.ConR n <$> traverse quote fs StringR t -> pure (X.StringR t) DictR ops -> X.DictR <$> traverse (traverse quote) ops CompR i b -> X.CompR i . snd <$> clause (PDict i) b From 7650db3b7010ca15e85f1466e41d7c8cc4a8afd4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 20 Dec 2021 15:08:46 -0500 Subject: [PATCH 0533/1324] Move strengthen into Compose. --- src/Facet/Functor/Compose.hs | 6 ++++++ src/Facet/Sequent/Class.hs | 6 ------ 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index 3ef1781a9..28d8b0c11 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -6,12 +6,14 @@ module Facet.Functor.Compose , mapCInner , liftCOuter , mapCOuter +, strengthen -- * Binding syntax , binder , Clause(..) ) where import Control.Applicative (Alternative(..)) +import Data.Functor.Identity (Identity(..)) -- Composition functor @@ -40,6 +42,10 @@ mapCOuter :: (i (j a) -> i' (j' b)) -> ((i . j) a -> (i' . j') b) mapCOuter f = C . f . runC +strengthen :: Applicative m => m (Identity a) -> m a +strengthen = fmap runIdentity + + -- Binding syntax binder :: (Functor m, Applicative i) => (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) -> m (i (c -> d)) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index e811c71d5..b9492bc6d 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -3,7 +3,6 @@ module Facet.Sequent.Class ( -- * Sequent abstraction Sequent(..) -- * Effectful abstractions -, strengthen , µRA , Clause(..) , funRA @@ -11,7 +10,6 @@ module Facet.Sequent.Class , sumLA ) where -import Data.Functor.Identity (Identity(..)) import Data.Text (Text) import Facet.Functor.Compose import Facet.Name (LName, Level, Name, RName) @@ -46,10 +44,6 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma -- * Effectful abstractions -strengthen :: Applicative m => m (Identity a) -> m a -strengthen = fmap runIdentity - - µRA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) From ba7ffb590795ea741064705acd5cc000dcd5252a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 20 Dec 2021 15:11:16 -0500 Subject: [PATCH 0534/1324] Rename liftCOuter to weaken. --- src/Facet/Functor/Compose.hs | 12 ++++++------ src/Facet/Type/Class.hs | 2 +- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index 28d8b0c11..9737d1191 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -4,9 +4,9 @@ module Facet.Functor.Compose -- * Introduction , liftCInner , mapCInner -, liftCOuter , mapCOuter , strengthen +, weaken -- * Binding syntax , binder , Clause(..) @@ -25,7 +25,7 @@ instance (Applicative i, Applicative j) => Applicative (i . j) where C f <*> C a = C ((<*>) <$> f <*> a) instance (Alternative i, Applicative j) => Alternative (i . j) where - empty = liftCOuter empty + empty = weaken empty C l <|> C r = C (l <|> r) @@ -35,9 +35,6 @@ liftCInner = C . pure mapCInner :: Functor i => (j a -> j' b) -> ((i . j) a -> (i . j') b) mapCInner f = C . fmap f . runC -liftCOuter :: (Functor i, Applicative j) => i a -> (i . j) a -liftCOuter = C . fmap pure - mapCOuter :: (i (j a) -> i' (j' b)) -> ((i . j) a -> (i' . j') b) mapCOuter f = C . f . runC @@ -45,10 +42,13 @@ mapCOuter f = C . f . runC strengthen :: Applicative m => m (Identity a) -> m a strengthen = fmap runIdentity +weaken :: (Functor i, Applicative j) => i a -> (i . j) a +weaken = C . fmap pure + -- Binding syntax binder :: (Functor m, Applicative i) => (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) -> m (i (c -> d)) -binder c = runC <$> c liftCOuter (liftCInner id) +binder c = runC <$> c weaken (liftCInner id) newtype Clause m i a b = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j a -> m (j b) } diff --git a/src/Facet/Type/Class.hs b/src/Facet/Type/Class.hs index 1a98539c2..5c515a1b2 100644 --- a/src/Facet/Type/Class.hs +++ b/src/Facet/Type/Class.hs @@ -24,4 +24,4 @@ class Type r where infixr 9 |- forAllA :: (Applicative m, Applicative i, Type r) => Name -> Kind -> (forall j . Applicative j => (i ~> j) -> j r -> m (j r)) -> m (i r) -forAllA n k b = fmap (forAll n k) . runC <$> b liftCOuter (liftCInner id) +forAllA n k b = fmap (forAll n k) . runC <$> b weaken (liftCInner id) From c8ca8837eac21a1214d40bcd34a185296617590c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 20 Dec 2021 15:12:30 -0500 Subject: [PATCH 0535/1324] Define forAllA using binder. --- src/Facet/Type/Class.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Type/Class.hs b/src/Facet/Type/Class.hs index 5c515a1b2..6a9f13f75 100644 --- a/src/Facet/Type/Class.hs +++ b/src/Facet/Type/Class.hs @@ -24,4 +24,4 @@ class Type r where infixr 9 |- forAllA :: (Applicative m, Applicative i, Type r) => Name -> Kind -> (forall j . Applicative j => (i ~> j) -> j r -> m (j r)) -> m (i r) -forAllA n k b = fmap (forAll n k) . runC <$> b weaken (liftCInner id) +forAllA n k b = fmap (forAll n k) <$> binder b From 04fc6ab68a0f1f18233befbc7163e2c70e8c3fda Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 20 Dec 2021 16:20:23 -0500 Subject: [PATCH 0536/1324] Fix a missed use of liftCOuter. --- src/Facet/Surface/Type/Class.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Surface/Type/Class.hs b/src/Facet/Surface/Type/Class.hs index d6d5c940f..90d1384e0 100644 --- a/src/Facet/Surface/Type/Class.hs +++ b/src/Facet/Surface/Type/Class.hs @@ -21,7 +21,7 @@ class Type r where tapp :: r -> r -> r forAllA :: (Applicative m, Applicative i, Type r) => m Name -> m Kind -> (forall j . Applicative j => (i ~> j) -> j r -> m (j r)) -> m (i r) -forAllA n k b = fmap fmap . forAll <$> n <*> k <*> (runC <$> b liftCOuter (liftCInner id)) +forAllA n k b = fmap fmap . forAll <$> n <*> k <*> (runC <$> b weaken (liftCInner id)) class Interface r where interface :: QName -> Snoc r -> r From 23eb3bbfa1677ff9a32721e03e237a0bfbdba8e6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Dec 2021 10:37:34 -0500 Subject: [PATCH 0537/1324] Align. --- src/Facet/Quote.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index 1db167013..b538d2010 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -82,7 +82,7 @@ runQuoter d (Quoter f) = f d -- | Build quoted first-order syntax from a higher-order representation. binder - :: (Level -> Quoter a) -- ^ Constructor for variables in @a@. + :: (Level -> Quoter a) -- ^ Constructor for variables in @a@. -> (Quoter a -> Quoter b) -- ^ The binder's scope, represented as a Haskell function mapping variables' values to complete terms. -> Quoter b -- ^ A 'Quoter' of the first-order term. binder with f = Quoter (\ d -> runQuoter (d + 1) (f (with (getUsed d)))) From 44e0cec0936119f0e8ccc43a08849eaefb09e821 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Dec 2021 13:26:00 -0500 Subject: [PATCH 0538/1324] Define a helper to quote multiple variables at a time. --- src/Facet/Quote.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index b538d2010..6c2c33653 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -13,6 +13,7 @@ module Facet.Quote , Quoter(..) , runQuoter , binder +, binderN ) where import Facet.Name (Level, Used(..)) @@ -86,3 +87,12 @@ binder -> (Quoter a -> Quoter b) -- ^ The binder's scope, represented as a Haskell function mapping variables' values to complete terms. -> Quoter b -- ^ A 'Quoter' of the first-order term. binder with f = Quoter (\ d -> runQuoter (d + 1) (f (with (getUsed d)))) + +-- | Build quoted first-order syntax from a higher-order representation taking multiple variables. +binderN + :: Int + -> (Level -> Quoter a) -- ^ Constructor for variables in @a@. + -> (Quoter [a] -> Quoter b) -- ^ The binder's scope, represented as a Haskell function mapping lists of variables' values to complete terms. + -> Quoter b -- ^ A 'Quoter' of the first-order term. +binderN n with f = Quoter (\ d -> runQuoter (d + n') (f (traverse (with . getUsed) [0..n']))) + where n' = fromIntegral n From 95ac020b3d4e30b8e71bba95185154ee9e38f1ba Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Dec 2021 13:35:59 -0500 Subject: [PATCH 0539/1324] Pass lists of variables in, not a quoter for their values. --- src/Facet/Quote.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index 6c2c33653..562d8cb9f 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -92,7 +92,7 @@ binder with f = Quoter (\ d -> runQuoter (d + 1) (f (with (getUsed d)))) binderN :: Int -> (Level -> Quoter a) -- ^ Constructor for variables in @a@. - -> (Quoter [a] -> Quoter b) -- ^ The binder's scope, represented as a Haskell function mapping lists of variables' values to complete terms. + -> ([Quoter a] -> Quoter b) -- ^ The binder's scope, represented as a Haskell function mapping lists of variables' values to complete terms. -> Quoter b -- ^ A 'Quoter' of the first-order term. -binderN n with f = Quoter (\ d -> runQuoter (d + n') (f (traverse (with . getUsed) [0..n']))) +binderN n with f = Quoter (\ d -> runQuoter (d + n') (f (map (with . getUsed) [0..n']))) where n' = fromIntegral n From d3883292728cf8414052d9b5784a9f8af414b87f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Dec 2021 13:45:03 -0500 Subject: [PATCH 0540/1324] Replace conR with n-ary products. --- src/Facet/Sequent/Class.hs | 2 +- src/Facet/Sequent/Expr.hs | 6 +++--- src/Facet/Sequent/Norm.hs | 4 ++-- src/Facet/Sequent/Print.hs | 3 +-- 4 files changed, 7 insertions(+), 8 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index b9492bc6d..2f92a0218 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -34,7 +34,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma µL :: (term -> command) -> coterm funL :: term -> coterm -> coterm sumL :: [term -> command] -> coterm - prdL :: Int -> coterm -> coterm + prdL :: Int -> ([term] -> command) -> coterm -- Commands (.|.) :: term -> coterm -> command diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 4fedf1688..519fdaeb8 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -41,7 +41,7 @@ data Coterm | MuL Command | FunL Term Coterm | SumL [Command] - | PrdL Int Coterm + | PrdL Int Command -- Commands @@ -63,7 +63,7 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where µL b = MuL <$> binder (\ d' -> Quoter (\ d -> var __ (toIndexed d d'))) b funL a b = FunL <$> a <*> b sumL = fmap SumL . traverse (binder (\ d' -> Quoter (\ d -> var __ (toIndexed d d')))) - prdL = fmap . PrdL + prdL i b = PrdL i <$> binderN i (\ d' -> Quoter (\ d -> var __ (toIndexed d d'))) b (.|.) = liftA2 (:|:) @@ -96,7 +96,7 @@ interpretCoterm _G _D = \case MuL b -> C.µL (\ t -> interpretCommand (_G |> PVar (__ :=: t)) _D b) FunL a k -> C.funL (interpretTerm _G _D a) (interpretCoterm _G _D k) SumL cs -> C.sumL (map (\ d t -> interpretCommand (_G |> PVar (__ :=: t)) _D d) cs) - PrdL i k -> C.prdL i (interpretCoterm _G _D k) + PrdL i c -> C.prdL i (\ cs -> interpretCommand (foldl (\ e c -> e |> PVar (__ :=: c)) _G cs) _D c) interpretCommand :: C.Sequent t c d => Env t -> Env c -> Command -> d interpretCommand _G _D (t :|: c) = interpretTerm _G _D t C..|. interpretCoterm _G _D c diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index c2038143b..57b6a5764 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -37,7 +37,7 @@ data Coterm | MuL (Term -> Command) | FunL Term Coterm | SumL [Term -> Command] - | PrdL Int Coterm + | PrdL Int ([Term] -> Command) -- Commands @@ -86,7 +86,7 @@ instance Quote Coterm X.Coterm where MuL b -> X.MuL <$> quoteBinder (Quoter (\ d -> Var (Free (LName (getUsed d) __)))) b FunL a b -> liftA2 X.FunL (quote a) (quote b) SumL cs -> X.SumL <$> traverse (quoteBinder (Quoter (\ d -> Var (Free (LName (getUsed d) __))))) cs - PrdL i k -> X.PrdL i <$> quote k + PrdL n k -> X.PrdL n <$> quoteBinder (Quoter (\ d -> map (\ d' -> Var (Free (LName (getUsed d + fromIntegral d') __))) [0..n])) k instance Quote Command X.Command where diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index b5d4117e7..8d3b3bc68 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -31,7 +31,6 @@ instance S.Sequent Print Print Print where funR cs = P.braces (P.encloseSep (P.flatAlt P.space mempty) (P.flatAlt P.space mempty) (P.comma <> P.space) (map (uncurry clause) cs)) sumR i t = P.parens (P.pretty "in" <> P.pretty i P.<+> t) prdR = P.tupled - conR n fs = foldl1 (P.surround P.space) (S.var (Global n):fs) stringR = P.pretty . show dictR os = withOpts (\ Options{..} -> P.brackets (P.flatAlt P.space P.line <> commaSep (map (\ (n :=: v) -> rname n P.<+> P.equals P.<+> P.group v) os) <> P.flatAlt P.space P.line)) compR p b = P.group @@ -43,7 +42,7 @@ instance S.Sequent Print Print Print where µL b = µ̃ <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) funL a k = a P.<+> P.dot P.<+> k sumL cs = µ̃ <> P.braces (commaSep (map (\ c -> fresh (\ v -> anon v P.<+> P.dot P.<+> c (anon v))) cs)) - prdL i k = P.parens (P.pretty "ex" <> P.pretty i P.<+> k) + prdL i k = P.parens (µ̃ <> withLevel (\ d -> k (map (\ i -> anon (d + fromIntegral i)) [0..i]))) (.|.) = fmap (P.enclose P.langle P.rangle) . P.surround P.pipe From 1954ed5c81c4eb4ef9ea9a242b6247f1bf361d6b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Dec 2021 17:20:14 -0500 Subject: [PATCH 0541/1324] Define a first attempt at lifting prdL through an effectful context. --- src/Facet/Sequent/Class.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 2f92a0218..491ad6ea6 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -8,6 +8,7 @@ module Facet.Sequent.Class , funRA , µLA , sumLA +, prdLA ) where import Data.Text (Text) @@ -65,3 +66,10 @@ sumLA => [Clause m i t d] -> m (i c) sumLA cs = runC (sumL <$> traverse (\ (Clause c) -> C (binder c)) cs) + +prdLA + :: (Sequent t c d, Applicative i, Applicative m) + => Int + -> (forall j . Applicative j => (forall x . i x -> j x) -> j [t] -> m (j d)) + -> m (i c) +prdLA i f = fmap (prdL i) <$> binder f From 69a1e3b864bb27988bb302c70d68dee09df88ddc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Dec 2021 22:18:33 -0500 Subject: [PATCH 0542/1324] Bump? --- .github/workflows/ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index ec3a046d8..018308b43 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -14,8 +14,8 @@ jobs: runs-on: ubuntu-latest strategy: matrix: - ghc: ["8.10.4"] - cabal: ["3.2.0.0"] + ghc: ["8.10"] + cabal: ["3.6"] steps: - uses: actions/checkout@v2 From 8206e25e535cf7eb68039ff4c4e25fdee0be79bd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 23 Dec 2021 03:01:53 -0500 Subject: [PATCH 0543/1324] Spacing. --- src/Facet/Elab/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 3c0258cbb..15f8cceb0 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -235,7 +235,7 @@ synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \cas checkExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Type <==: Elab m Term checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC expr $ \case - S.Hole n -> hole n + S.Hole n -> hole n S.Lam cs -> checkLam cs S.Var{} -> switch (synthExpr expr) S.App{} -> switch (synthExpr expr) From a6ae47c3d94b9c234abeab168afb963235fff4a4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 23 Dec 2021 03:12:31 -0500 Subject: [PATCH 0544/1324] Generalize as. --- src/Facet/Elab/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 15f8cceb0..2c2f5d467 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -97,7 +97,7 @@ switch m = Check $ \ _Exp -> m >>= \case a :==> T.Comp req _Act -> require req >> unify (Exp _Exp) (Act _Act) $> a a :==> _Act -> unify (Exp _Exp) (Act _Act) $> a -as :: (HasCallStack, Has (Throw Err) sig m) => (Type <==: Elab m Term) ::: Elab m (Type :==> Kind) -> Elab m (Term :==> Type) +as :: (HasCallStack, Has (Throw Err) sig m) => (Type <==: Elab m a) ::: Elab m (Type :==> Kind) -> Elab m (a :==> Type) as (m ::: _T) = do _T' <- Type.switch _T <==: KType a <- check (m ::: _T') From f4ce5e083423ea503a76c624bd51ab47e8dcc3c5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 23 Dec 2021 17:05:17 -0500 Subject: [PATCH 0545/1324] :fire: dictR & compR for the time being. --- src/Facet/Sequent/Class.hs | 2 -- src/Facet/Sequent/Expr.hs | 6 ------ src/Facet/Sequent/Norm.hs | 6 ------ src/Facet/Sequent/Print.hs | 5 ----- 4 files changed, 19 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 491ad6ea6..66d9cce57 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -27,8 +27,6 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma sumR :: RName -> term -> term prdR :: [term] -> term stringR :: Text -> term - dictR :: [RName :=: term] -> term - compR :: [RName :=: Name] -> (Pattern (Name :=: term) -> term) -> term -- Coterms covar :: Var (LName Level) -> coterm diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 519fdaeb8..5fe619ca5 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -30,8 +30,6 @@ data Term | SumR RName Term | PrdR [Term] | StringR Text - | DictR [RName :=: Term] - | CompR [RName :=: Name] Term -- Coterms @@ -56,8 +54,6 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where sumR = fmap . SumR prdR = fmap PrdR . sequenceA stringR = pure . StringR - dictR i = DictR <$> traverse sequenceA i - compR i b = CompR i . snd <$> clause (PDict i) b covar v = Quoter (\ d -> Covar (toIndexed d v)) µL b = MuL <$> binder (\ d' -> Quoter (\ d -> var __ (toIndexed d d'))) b @@ -86,8 +82,6 @@ interpretTerm _G _D = \case SumR i t -> C.sumR i (interpretTerm _G _D t) PrdR fs -> C.prdR (map (interpretTerm _G _D) fs) StringR s -> C.stringR s - DictR ops -> C.dictR (map (fmap (interpretTerm _G _D)) ops) - CompR i b -> C.compR i (\ p -> interpretTerm (_G |> p) _D b) interpretCoterm :: C.Sequent t c d => Env t -> Env c -> Coterm -> c interpretCoterm _G _D = \case diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index 57b6a5764..aadf9cfd3 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -26,8 +26,6 @@ data Term | SumR RName Term | PrdR [Term] | StringR Text - | DictR [RName :=: Term] - | CompR [RName :=: Name] (Pattern (Name :=: Term) -> Term) -- Coterms @@ -52,8 +50,6 @@ instance Class.Sequent Term Coterm Command where sumR = SumR prdR = PrdR stringR = StringR - dictR = DictR - compR = CompR covar = Covar µL = MuL @@ -72,8 +68,6 @@ instance Quote Term X.Term where SumR i t -> X.SumR i <$> quote t PrdR fs -> X.PrdR <$> traverse quote fs StringR t -> pure (X.StringR t) - DictR ops -> X.DictR <$> traverse (traverse quote) ops - CompR i b -> X.CompR i . snd <$> clause (PDict i) b where var d n = Var (Free (LName (getUsed d) n)) clause :: Pattern Name -> (Pattern (Name :=: Term) -> Term) -> Quoter (Pattern Name, X.Term) diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index 8d3b3bc68..a7b9eb1fd 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -32,11 +32,6 @@ instance S.Sequent Print Print Print where sumR i t = P.parens (P.pretty "in" <> P.pretty i P.<+> t) prdR = P.tupled stringR = P.pretty . show - dictR os = withOpts (\ Options{..} -> P.brackets (P.flatAlt P.space P.line <> commaSep (map (\ (n :=: v) -> rname n P.<+> P.equals P.<+> P.group v) os) <> P.flatAlt P.space P.line)) - compR p b = P.group - . P.align - . P.braces - . P.enclose P.space P.space $ clause (PDict p) b covar = var µL b = µ̃ <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) From 0cb9a3b52597e583e01d438074a38c9bbe7e28be Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 26 Dec 2021 01:54:42 -0500 Subject: [PATCH 0546/1324] :fire: names from sequent representations. --- src/Facet/Sequent/Class.hs | 12 ++++++------ src/Facet/Sequent/Expr.hs | 32 +++++++++++++++++--------------- src/Facet/Sequent/Norm.hs | 22 ++++++++++++---------- src/Facet/Sequent/Print.hs | 14 +++++++------- 4 files changed, 42 insertions(+), 38 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 66d9cce57..77ee36406 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -13,23 +13,23 @@ module Facet.Sequent.Class import Data.Text (Text) import Facet.Functor.Compose -import Facet.Name (LName, Level, Name, RName) +import Facet.Name (Level, Name, RName) import Facet.Pattern (Pattern) -import Facet.Syntax (Var, (:=:)(..)) +import Facet.Syntax (Var) -- * Term abstraction class Sequent term coterm command | coterm -> term command, term -> coterm command, command -> term coterm where -- Terms - var :: Var (LName Level) -> term + var :: Var Level -> term µR :: (coterm -> command) -> term - funR :: [(Pattern Name, Pattern (Name :=: term) -> term)] -> term + funR :: [(Pattern Name, Pattern term -> term)] -> term sumR :: RName -> term -> term prdR :: [term] -> term stringR :: Text -> term -- Coterms - covar :: Var (LName Level) -> coterm + covar :: Var Level -> coterm µL :: (term -> command) -> coterm funL :: term -> coterm -> coterm sumL :: [term -> command] -> coterm @@ -49,7 +49,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma -> m (i t) µRA f = fmap µR <$> binder f -funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause m i (Pattern (Name :=: t)) t)] -> m (i t) +funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause m i (Pattern t) t)] -> m (i t) funRA cs = runC (funR <$> traverse (traverse (\ (Clause c) -> C (binder c))) cs) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 5fe619ca5..745ef33a0 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -14,7 +14,6 @@ module Facet.Sequent.Expr import Control.Applicative (liftA2) import Data.Text (Text) import Data.Traversable (mapAccumL) -import Facet.Env import Facet.Name import Facet.Pattern import Facet.Quote @@ -24,7 +23,7 @@ import Facet.Syntax -- Terms data Term - = Var (Var (LName Index)) + = Var (Var Index) | MuR Command | FunR [(Pattern Name, Term)] | SumR RName Term @@ -35,7 +34,7 @@ data Term -- Coterms data Coterm - = Covar (Var (LName Index)) + = Covar (Var Index) | MuL Command | FunL Term Coterm | SumL [Command] @@ -64,33 +63,36 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where (.|.) = liftA2 (:|:) var :: Name -> Index -> Term -var n i = Var (Free (LName i n)) +var = const (Var . Free) covar :: Name -> Index -> Coterm -covar n i = Covar (Free (LName i n)) +covar = const (Covar . Free) -clause :: Pattern Name -> (Pattern (Name :=: Quoter Term) -> Quoter Term) -> Quoter (Pattern Name, Term) -clause p b = Quoter (\ d -> let (d', p') = mapAccumL (\ d' n -> (succ d', n :=: Quoter (\ d -> var n (toIndexed d (getUsed d'))))) d p in (p, runQuoter d' (b p'))) +clause :: Pattern Name -> (Pattern (Quoter Term) -> Quoter Term) -> Quoter (Pattern Name, Term) +clause p b = Quoter (\ d -> let (d', p') = mapAccumL (\ d' n -> (succ d', Quoter (\ d -> var n (toIndexed d (getUsed d'))))) d p in (p, runQuoter d' (b p'))) -interpretTerm :: C.Sequent t c d => Env t -> Env c -> Term -> t +interpretTerm :: C.Sequent t c d => [t] -> [c] -> Term -> t interpretTerm _G _D = \case Var (Free n) -> _G `index` n Var (Global n) -> C.var (Global n) - MuR b -> C.µR (\ k -> interpretCommand _G (_D |> PVar (__ :=: k)) b) - FunR cs -> C.funR (map (fmap (\ t p -> interpretTerm (_G |> p) _D t)) cs) + MuR b -> C.µR (\ k -> interpretCommand _G (k:_D) b) + FunR cs -> C.funR (map (fmap (\ t p -> interpretTerm (foldr (:) _G p) _D t)) cs) SumR i t -> C.sumR i (interpretTerm _G _D t) PrdR fs -> C.prdR (map (interpretTerm _G _D) fs) StringR s -> C.stringR s -interpretCoterm :: C.Sequent t c d => Env t -> Env c -> Coterm -> c +interpretCoterm :: C.Sequent t c d => [t] -> [c] -> Coterm -> c interpretCoterm _G _D = \case Covar (Free n) -> _D `index` n Covar (Global n) -> C.covar (Global n) - MuL b -> C.µL (\ t -> interpretCommand (_G |> PVar (__ :=: t)) _D b) + MuL b -> C.µL (\ t -> interpretCommand (t:_G) _D b) FunL a k -> C.funL (interpretTerm _G _D a) (interpretCoterm _G _D k) - SumL cs -> C.sumL (map (\ d t -> interpretCommand (_G |> PVar (__ :=: t)) _D d) cs) - PrdL i c -> C.prdL i (\ cs -> interpretCommand (foldl (\ e c -> e |> PVar (__ :=: c)) _G cs) _D c) + SumL cs -> C.sumL (map (\ d t -> interpretCommand (t:_G) _D d) cs) + PrdL i c -> C.prdL i (\ cs -> interpretCommand (foldl (flip (:)) _G cs) _D c) -interpretCommand :: C.Sequent t c d => Env t -> Env c -> Command -> d +interpretCommand :: C.Sequent t c d => [t] -> [c] -> Command -> d interpretCommand _G _D (t :|: c) = interpretTerm _G _D t C..|. interpretCoterm _G _D c + +index :: [a] -> Index -> a +index as (Index i) = as !! i diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index aadf9cfd3..1527253d4 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -20,9 +20,9 @@ import Facet.Syntax -- Terms data Term - = Var (Var (LName Level)) + = Var (Var Level) | MuR (Coterm -> Command) - | FunR [(Pattern Name, Pattern (Name :=: Term) -> Term)] + | FunR [(Pattern Name, Pattern Term -> Term)] | SumR RName Term | PrdR [Term] | StringR Text @@ -31,7 +31,7 @@ data Term -- Coterms data Coterm - = Covar (Var (LName Level)) + = Covar (Var Level) | MuL (Term -> Command) | FunL Term Coterm | SumL [Term -> Command] @@ -63,24 +63,26 @@ instance Class.Sequent Term Coterm Command where instance Quote Term X.Term where quote = \case Var v -> Quoter (\ d -> X.Var (toIndexed d v)) - MuR b -> X.MuR <$> quoteBinder (Quoter (\ d -> Covar (Free (LName (getUsed d) __)))) b + MuR b -> X.MuR <$> quoteBinder (Quoter (Covar . Free . getUsed)) b FunR ps -> X.FunR <$> traverse (uncurry clause) ps SumR i t -> X.SumR i <$> quote t PrdR fs -> X.PrdR <$> traverse quote fs StringR t -> pure (X.StringR t) where - var d n = Var (Free (LName (getUsed d) n)) - clause :: Pattern Name -> (Pattern (Name :=: Term) -> Term) -> Quoter (Pattern Name, X.Term) - clause p b = Quoter (\ d -> let (_, p') = mapAccumL (\ d' n -> (succ d', n :=: var d' n)) d p in (p, runQuoter d (quote (b p')))) + clause :: Pattern a -> (Pattern Term -> Term) -> Quoter (Pattern a, X.Term) + clause p b = Quoter (\ d -> let (_, p') = mapAccumL (\ d' _ -> (succ d', var d')) d p in (p, runQuoter d (quote (b p')))) + +var :: Used -> Term +var = Var . Free . getUsed instance Quote Coterm X.Coterm where quote = \case Covar v -> Quoter (\ d -> X.Covar (toIndexed d v)) - MuL b -> X.MuL <$> quoteBinder (Quoter (\ d -> Var (Free (LName (getUsed d) __)))) b + MuL b -> X.MuL <$> quoteBinder (Quoter var) b FunL a b -> liftA2 X.FunL (quote a) (quote b) - SumL cs -> X.SumL <$> traverse (quoteBinder (Quoter (\ d -> Var (Free (LName (getUsed d) __))))) cs - PrdL n k -> X.PrdL n <$> quoteBinder (Quoter (\ d -> map (\ d' -> Var (Free (LName (getUsed d + fromIntegral d') __))) [0..n])) k + SumL cs -> X.SumL <$> traverse (quoteBinder (Quoter var)) cs + PrdL n k -> X.PrdL n <$> quoteBinder (Quoter (\ d -> map (var . (d +) . fromIntegral) [0..n])) k instance Quote Command X.Command where diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index a7b9eb1fd..3db7e0517 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -56,13 +56,13 @@ anon = lower . getLevel . getUsed withOpts :: (Options Print -> Print) -> Print withOpts f = Print (\ o d -> doc (f o) o d) -var :: Var (LName Level) -> Print +var :: Var Level -> Print var v = case v of - Free (LName l n) -> P.pretty n <> P.pretty (getLevel l) - Global n -> P.pretty n + Free l -> lower (getLevel l) + Global n -> P.pretty n -nameVar :: Name -> (Print -> Print) -> Print -nameVar n b = withLevel (\ d -> incrLevel (b (var (Free (LName (getUsed d) n))))) +nameVar :: Print +nameVar = withLevel (incrLevel . var . Free . getUsed) pattern :: Options Print -> Pattern Print -> Print pattern opts@Options{..} = \case @@ -74,8 +74,8 @@ pattern opts@Options{..} = \case commaSep :: [Print] -> Print commaSep = P.encloseSep mempty mempty (P.comma <> P.space) -clause :: Pattern Name -> (Pattern (Name :=: Print) -> Print) -> Print -clause p b = let p' = (\ n -> n :=: nameVar n id) <$> p in withOpts (`pattern` fmap def p') P.<+> P.pretty "->" P.<+> b p' +clause :: Pattern Name -> (Pattern Print -> Print) -> Print +clause p b = let p' = nameVar <$ p in withOpts (`pattern` p') P.<+> P.pretty "->" P.<+> b p' µ̃ :: Print µ̃ = P.pretty "µ̃" From fe0eed17668a2818e57b6f2813156f56fbdd96e1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 26 Dec 2021 02:05:15 -0500 Subject: [PATCH 0547/1324] Define field selectors for LName. --- src/Facet/Name.hs | 5 ++++- src/Facet/Print.hs | 2 +- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index c2dbce978..567b54404 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -119,7 +119,10 @@ toQ (m :.: n) = toSnoc m :. n -- | Local names, consisting of a 'Level' or 'Index' to a pattern in an 'Env' or 'Context' and a 'Name' bound by said pattern. -data LName v = LName v Name +data LName v = LName + { ident :: v + , name :: Name + } deriving (Eq, Foldable, Functor, Ord, Show, Traversable) instance DeBruijn lv ix => DeBruijn (LName lv) (LName ix) where diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 0fe863389..48398ca49 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -33,7 +33,7 @@ import Facet.Env as Env import Facet.Interface import Facet.Kind import qualified Facet.Module as C -import Facet.Name as Name +import Facet.Name as Name hiding (name) import Facet.Pattern import Facet.Pretty (lower, upper) import Facet.Print.Options From 024730e6fa8df092b6438fb6f9cfabfa446c8d4c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 26 Dec 2021 02:12:14 -0500 Subject: [PATCH 0548/1324] Fix a reference to name. --- src/Facet/Driver.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Driver.hs b/src/Facet/Driver.hs index 57d7c471b..05e66414e 100644 --- a/src/Facet/Driver.hs +++ b/src/Facet/Driver.hs @@ -38,7 +38,7 @@ import qualified Facet.Elab.Term as Elab import Facet.Graph import Facet.Lens import Facet.Module hiding (Import(name), imports, imports_) -import Facet.Name +import Facet.Name hiding (name) import qualified Facet.Notice as Notice import Facet.Notice.Elab (rethrowElabErrors, rethrowElabWarnings) import Facet.Notice.Parser (rethrowParseErrors) From dd3741e84fedd819be4d343accb85727853df957 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 26 Dec 2021 02:21:19 -0500 Subject: [PATCH 0549/1324] Simplify funR to (term -> term) -> term. --- src/Facet/Sequent/Class.hs | 9 ++++----- src/Facet/Sequent/Expr.hs | 27 +++++++++++---------------- src/Facet/Sequent/Norm.hs | 9 ++------- src/Facet/Sequent/Print.hs | 16 +--------------- 4 files changed, 18 insertions(+), 43 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 77ee36406..f1dc91c01 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -13,8 +13,7 @@ module Facet.Sequent.Class import Data.Text (Text) import Facet.Functor.Compose -import Facet.Name (Level, Name, RName) -import Facet.Pattern (Pattern) +import Facet.Name (Level, RName) import Facet.Syntax (Var) -- * Term abstraction @@ -23,7 +22,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma -- Terms var :: Var Level -> term µR :: (coterm -> command) -> term - funR :: [(Pattern Name, Pattern term -> term)] -> term + funR :: (term -> term) -> term sumR :: RName -> term -> term prdR :: [term] -> term stringR :: Text -> term @@ -49,8 +48,8 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma -> m (i t) µRA f = fmap µR <$> binder f -funRA :: (Sequent t c d, Applicative i, Applicative m) => [(Pattern Name, Clause m i (Pattern t) t)] -> m (i t) -funRA cs = runC (funR <$> traverse (traverse (\ (Clause c) -> C (binder c))) cs) +funRA :: (Sequent t c d, Applicative i, Applicative m) => Clause m i t t -> m (i t) +funRA (Clause c) = runC (funR <$> C (binder c)) µLA diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 745ef33a0..d24d2cccd 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -13,9 +13,7 @@ module Facet.Sequent.Expr import Control.Applicative (liftA2) import Data.Text (Text) -import Data.Traversable (mapAccumL) import Facet.Name -import Facet.Pattern import Facet.Quote import qualified Facet.Sequent.Class as C import Facet.Syntax @@ -25,7 +23,7 @@ import Facet.Syntax data Term = Var (Var Index) | MuR Command - | FunR [(Pattern Name, Term)] + | FunR Term | SumR RName Term | PrdR [Term] | StringR Text @@ -48,28 +46,25 @@ data Command = Term :|: Coterm instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where var v = Quoter (\ d -> Var (toIndexed d v)) - µR b = MuR <$> binder (\ d' -> Quoter (\ d -> covar __ (toIndexed d d'))) b - funR ps = FunR <$> traverse (uncurry clause) ps + µR b = MuR <$> binder (\ d' -> Quoter (\ d -> covar (toIndexed d d'))) b + funR b = FunR <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b sumR = fmap . SumR prdR = fmap PrdR . sequenceA stringR = pure . StringR covar v = Quoter (\ d -> Covar (toIndexed d v)) - µL b = MuL <$> binder (\ d' -> Quoter (\ d -> var __ (toIndexed d d'))) b + µL b = MuL <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b funL a b = FunL <$> a <*> b - sumL = fmap SumL . traverse (binder (\ d' -> Quoter (\ d -> var __ (toIndexed d d')))) - prdL i b = PrdL i <$> binderN i (\ d' -> Quoter (\ d -> var __ (toIndexed d d'))) b + sumL = fmap SumL . traverse (binder (\ d' -> Quoter (\ d -> var (toIndexed d d')))) + prdL i b = PrdL i <$> binderN i (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b (.|.) = liftA2 (:|:) -var :: Name -> Index -> Term -var = const (Var . Free) +var :: Index -> Term +var = Var . Free -covar :: Name -> Index -> Coterm -covar = const (Covar . Free) - -clause :: Pattern Name -> (Pattern (Quoter Term) -> Quoter Term) -> Quoter (Pattern Name, Term) -clause p b = Quoter (\ d -> let (d', p') = mapAccumL (\ d' n -> (succ d', Quoter (\ d -> var n (toIndexed d (getUsed d'))))) d p in (p, runQuoter d' (b p'))) +covar :: Index -> Coterm +covar = Covar . Free interpretTerm :: C.Sequent t c d => [t] -> [c] -> Term -> t @@ -77,7 +72,7 @@ interpretTerm _G _D = \case Var (Free n) -> _G `index` n Var (Global n) -> C.var (Global n) MuR b -> C.µR (\ k -> interpretCommand _G (k:_D) b) - FunR cs -> C.funR (map (fmap (\ t p -> interpretTerm (foldr (:) _G p) _D t)) cs) + FunR b -> C.funR (\ a -> interpretTerm (a:_G) _D b) SumR i t -> C.sumR i (interpretTerm _G _D t) PrdR fs -> C.prdR (map (interpretTerm _G _D) fs) StringR s -> C.stringR s diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index 1527253d4..bd2cec213 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -9,9 +9,7 @@ module Facet.Sequent.Norm import Control.Applicative (liftA2) import Data.Text (Text) -import Data.Traversable (mapAccumL) import Facet.Name -import Facet.Pattern import Facet.Quote import qualified Facet.Sequent.Class as Class import qualified Facet.Sequent.Expr as X @@ -22,7 +20,7 @@ import Facet.Syntax data Term = Var (Var Level) | MuR (Coterm -> Command) - | FunR [(Pattern Name, Pattern Term -> Term)] + | FunR (Term -> Term) | SumR RName Term | PrdR [Term] | StringR Text @@ -64,13 +62,10 @@ instance Quote Term X.Term where quote = \case Var v -> Quoter (\ d -> X.Var (toIndexed d v)) MuR b -> X.MuR <$> quoteBinder (Quoter (Covar . Free . getUsed)) b - FunR ps -> X.FunR <$> traverse (uncurry clause) ps + FunR b -> X.FunR <$> quoteBinder (Quoter (Var . Free . getUsed)) b SumR i t -> X.SumR i <$> quote t PrdR fs -> X.PrdR <$> traverse quote fs StringR t -> pure (X.StringR t) - where - clause :: Pattern a -> (Pattern Term -> Term) -> Quoter (Pattern a, X.Term) - clause p b = Quoter (\ d -> let (_, p') = mapAccumL (\ d' _ -> (succ d', var d')) d p in (p, runQuoter d (quote (b p')))) var :: Used -> Term var = Var . Free . getUsed diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index 3db7e0517..822fc45f2 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -5,7 +5,6 @@ module Facet.Sequent.Print ) where import Facet.Name -import Facet.Pattern (Pattern(..)) import Facet.Pretty import Facet.Print.Options import qualified Facet.Sequent.Class as S @@ -28,7 +27,7 @@ instance Show Print where instance S.Sequent Print Print Print where var = var µR b = P.pretty "µ" <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) - funR cs = P.braces (P.encloseSep (P.flatAlt P.space mempty) (P.flatAlt P.space mempty) (P.comma <> P.space) (map (uncurry clause) cs)) + funR c = P.braces (let v = nameVar in v P.<+> P.pretty "->" P.<+> c v) sumR i t = P.parens (P.pretty "in" <> P.pretty i P.<+> t) prdR = P.tupled stringR = P.pretty . show @@ -53,9 +52,6 @@ fresh f = withLevel (incrLevel . f) anon :: Used -> Print anon = lower . getLevel . getUsed -withOpts :: (Options Print -> Print) -> Print -withOpts f = Print (\ o d -> doc (f o) o d) - var :: Var Level -> Print var v = case v of Free l -> lower (getLevel l) @@ -64,18 +60,8 @@ var v = case v of nameVar :: Print nameVar = withLevel (incrLevel . var . Free . getUsed) -pattern :: Options Print -> Pattern Print -> Print -pattern opts@Options{..} = \case - PWildcard -> P.pretty "_" - PVar p -> p - PCon n fs -> foldl1 (P.surround P.space) (S.var (Global n):map (pattern opts) fs) - PDict os -> P.brackets (P.flatAlt P.space P.line <> commaSep (map (\ (n :=: v) -> rname n P.<+> P.equals P.<+> P.group v) os) <> P.flatAlt P.space P.line) - commaSep :: [Print] -> Print commaSep = P.encloseSep mempty mempty (P.comma <> P.space) -clause :: Pattern Name -> (Pattern Print -> Print) -> Print -clause p b = let p' = nameVar <$ p in withOpts (`pattern` p') P.<+> P.pretty "->" P.<+> b p' - µ̃ :: Print µ̃ = P.pretty "µ̃" From fd4d81f25221a410f18b90b3f27c0e453dfd216f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 27 Dec 2021 07:39:51 -0500 Subject: [PATCH 0550/1324] Construct functions without Clause. --- src/Facet/Sequent/Class.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index f1dc91c01..48ddc3358 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -48,8 +48,8 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma -> m (i t) µRA f = fmap µR <$> binder f -funRA :: (Sequent t c d, Applicative i, Applicative m) => Clause m i t t -> m (i t) -funRA (Clause c) = runC (funR <$> C (binder c)) +funRA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j t))-> m (i t) +funRA f = fmap funR <$> binder f µLA From d54e00986d7d38939065fb3afddd9dc8174944f3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 27 Dec 2021 14:34:00 -0500 Subject: [PATCH 0551/1324] Define a lifted elaboration rule for lambdas. --- src/Facet/Elab/Term.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 2c2f5d467..1d2a47e5a 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -7,6 +7,7 @@ module Facet.Elab.Term -- * Term combinators , global , var +, varS , tlam , lam , app @@ -59,6 +60,7 @@ import Facet.Elab import Facet.Elab.Type hiding (switch) import qualified Facet.Elab.Type as Type import Facet.Functor.Check +import Facet.Functor.Compose import Facet.Functor.Synth import Facet.Graph import Facet.Interface @@ -139,6 +141,12 @@ lam cs = Check $ \ _T -> do lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Type)) -> Type <==: Elab m Term -> Type <==: Elab m Term lam1 p b = lam [(p, b)] +-- FIXME: scope-safety requires an outer environment and weakening +lamS :: (HasCallStack, Has (Throw Err) sig m, SQ.Sequent t c d) => (forall j . Applicative j => (j t :==> Type) -> (Type <==: Elab m (j t))) -> Type <==: Elab m t +lamS f = runC . strengthen $ SQ.funRA $ \ _ v -> C $ Check $ \ _T -> do + -- FIXME: how should we pass the quantity along to the higher-order function? + (_, _q, _A, _B) <- assertTacitFunction _T + check (f (v :==> _A) ::: _B) app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Elab m (a :==> Type)) -> (HasCallStack => Type <==: Elab m b) -> Elab m (c :==> Type) app mk operator operand = do From eaccb1eda032ab9cfe1d83d46c4db1f54d95c41c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 27 Dec 2021 15:42:15 -0500 Subject: [PATCH 0552/1324] Lift .|. through scope-safe contexts. --- src/Facet/Sequent/Class.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 48ddc3358..972ed8298 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -9,8 +9,10 @@ module Facet.Sequent.Class , µLA , sumLA , prdLA +, (.||.) ) where +import Control.Applicative (liftA2) import Data.Text (Text) import Facet.Functor.Compose import Facet.Name (Level, RName) @@ -70,3 +72,9 @@ prdLA -> (forall j . Applicative j => (forall x . i x -> j x) -> j [t] -> m (j d)) -> m (i c) prdLA i f = fmap (prdL i) <$> binder f + + +(.||.) :: (Applicative m, Applicative i, Sequent t c d) => m (i t) -> m (i c) -> m (i d) +(.||.) = liftA2 (liftA2 (.|.)) + +infix 1 .||. From 82afa6e033bfc0fc39dd7700a2a07d55c50ded42 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 28 Dec 2021 11:25:45 -0500 Subject: [PATCH 0553/1324] Define a type of scope-safe contexts. --- src/Facet/Sequent/Class.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 972ed8298..a0fede531 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FunctionalDependencies #-} module Facet.Sequent.Class ( -- * Sequent abstraction @@ -10,13 +11,14 @@ module Facet.Sequent.Class , sumLA , prdLA , (.||.) +, Ctx(..) ) where import Control.Applicative (liftA2) import Data.Text (Text) import Facet.Functor.Compose -import Facet.Name (Level, RName) -import Facet.Syntax (Var) +import Facet.Name (Level, Name, RName) +import Facet.Syntax (Var, type (~>)) -- * Term abstraction @@ -78,3 +80,8 @@ prdLA i f = fmap (prdL i) <$> binder f (.||.) = liftA2 (liftA2 (.|.)) infix 1 .||. + + +data Ctx j t + = Nil + | forall i . Entry Name (Ctx i t) (i ~> j) (j t) From 2c0c6dde221be49fe49285ebc3f80545fa92e7a3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 28 Dec 2021 11:25:56 -0500 Subject: [PATCH 0554/1324] Define lookup on scope-safe contexts. --- src/Facet/Sequent/Class.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index a0fede531..817895e9b 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -12,9 +12,11 @@ module Facet.Sequent.Class , prdLA , (.||.) , Ctx(..) +, lookupCtx ) where -import Control.Applicative (liftA2) +import Control.Applicative (Alternative(..), liftA2) +import Control.Monad (guard) import Data.Text (Text) import Facet.Functor.Compose import Facet.Name (Level, Name, RName) @@ -85,3 +87,11 @@ infix 1 .||. data Ctx j t = Nil | forall i . Entry Name (Ctx i t) (i ~> j) (j t) + +lookupCtx :: Name -> Ctx i t -> Maybe (i t) +lookupCtx n = go id + where + go :: (i ~> j) -> Ctx i t -> Maybe (j t) + go wk = \case + Nil -> Nothing + Entry n' c wk' t -> wk t <$ guard (n == n') <|> go (wk . wk') c From e5eea1ccda6b37ddca76869df999adc7f770589f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 31 Dec 2021 17:58:54 -0500 Subject: [PATCH 0555/1324] Spacing. --- src/Facet/Quote.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index 562d8cb9f..93c68a14b 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -72,7 +72,7 @@ instance (Quote v t, Show t) => Show (Quoting t v) where -- Quoters --- | 'Quoter' is used to construct first-order representations of syntax directly from higher-order APIs in final tagless style. +-- | 'Quoter' is used to construct first-order representations of syntax directly from higher-order APIs in final tagless style. -- -- This typically requires that quotation keep track of the current de Bruijn level, but this data is typically not recorded in ASTs. 'Quoter' instead constructs a function parameterized by the initial level, and thus passing around the current level as quoting proceeds in exactly the same manner as the reader monad. newtype Quoter a = Quoter (Used -> a) From 0fcf65e941d7f187ded08ee252bc7ee6454ff8ec Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 3 Jan 2022 11:36:34 -0500 Subject: [PATCH 0556/1324] Bump fresnel. --- cabal.project | 2 +- cabal.project.ci | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index df6f3b3f6..d5bcc0435 100644 --- a/cabal.project +++ b/cabal.project @@ -4,5 +4,5 @@ tests: True source-repository-package type: git location: https://github.com/robrix/fresnel.git - tag: dbb1c34c93c72e9207d0d8a01226efa2ff2e08d9 + tag: c56b7dc69d775ce5f1b2cbe9a3204e246f08227a subdir: fresnel diff --git a/cabal.project.ci b/cabal.project.ci index 2aee5e62c..fc3c9f220 100644 --- a/cabal.project.ci +++ b/cabal.project.ci @@ -7,5 +7,5 @@ package facet source-repository-package type: git location: https://github.com/robrix/fresnel.git - tag: dbb1c34c93c72e9207d0d8a01226efa2ff2e08d9 + tag: c56b7dc69d775ce5f1b2cbe9a3204e246f08227a subdir: fresnel From afb3daae8f00f2cecefb503b14faed67caaff7f7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 10 Jan 2022 13:11:59 -0500 Subject: [PATCH 0557/1324] Fix a symbol clash. --- src/Facet/Lexer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Lexer.hs b/src/Facet/Lexer.hs index 3606ef454..dd4b7de30 100644 --- a/src/Facet/Lexer.hs +++ b/src/Facet/Lexer.hs @@ -10,7 +10,7 @@ module Facet.Lexer import Data.Char (isSpace) import Data.Text (Text, pack) import Facet.Effect.Parser -import Facet.Name +import Facet.Name hiding (ident) import Facet.Snoc import Facet.Span import Text.Parser.Char From 21786a7c04c1189b5a4a225f0e9142c4fc2f07de Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jan 2022 19:26:51 -0500 Subject: [PATCH 0558/1324] Split out a binder analogue taking a function to fuse into the effectful context. --- src/Facet/Functor/Compose.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index 9737d1191..530237c7e 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -49,6 +49,9 @@ weaken = C . fmap pure -- Binding syntax binder :: (Functor m, Applicative i) => (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) -> m (i (c -> d)) -binder c = runC <$> c weaken (liftCInner id) +binder = binder_ id + +binder_ :: (Functor m, Applicative i) => (i (c -> d) -> e) -> (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) -> m e +binder_ f c = f . runC <$> c weaken (liftCInner id) newtype Clause m i a b = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j a -> m (j b) } From cde84c8e9ddb84bb044559df3464d63cc3251511 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jan 2022 19:30:30 -0500 Subject: [PATCH 0559/1324] temp --- src/Facet/Sequent/Class.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 817895e9b..3f4a9f3ef 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -5,7 +5,7 @@ module Facet.Sequent.Class Sequent(..) -- * Effectful abstractions , µRA -, Clause(..) +, C.Clause(..) , funRA , µLA , sumLA @@ -18,7 +18,7 @@ module Facet.Sequent.Class import Control.Applicative (Alternative(..), liftA2) import Control.Monad (guard) import Data.Text (Text) -import Facet.Functor.Compose +import Facet.Functor.Compose as C import Facet.Name (Level, Name, RName) import Facet.Syntax (Var, type (~>)) @@ -66,9 +66,9 @@ funRA f = fmap funR <$> binder f sumLA :: (Sequent t c d, Applicative i, Applicative m) - => [Clause m i t d] + => [C.Clause m i t d] -> m (i c) -sumLA cs = runC (sumL <$> traverse (\ (Clause c) -> C (binder c)) cs) +sumLA cs = runC (sumL <$> traverse (\ (C.Clause c) -> C (binder c)) cs) prdLA :: (Sequent t c d, Applicative i, Applicative m) From ccf0e6d72a50a5853724a8d0f7e602b9c0eb99d4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jan 2022 19:31:49 -0500 Subject: [PATCH 0560/1324] Fix an export. --- src/Facet/Elab/Term.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 1d2a47e5a..1b47f23fc 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -7,7 +7,6 @@ module Facet.Elab.Term -- * Term combinators , global , var -, varS , tlam , lam , app From da91237657c6f9c91b4b356687fe69bd7ab4708d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jan 2022 19:36:38 -0500 Subject: [PATCH 0561/1324] Replace binder with binder_. --- src/Facet/Functor/Compose.hs | 7 ++----- src/Facet/Sequent/Class.hs | 10 +++++----- src/Facet/Type/Class.hs | 2 +- 3 files changed, 8 insertions(+), 11 deletions(-) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index 530237c7e..51438e8af 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -48,10 +48,7 @@ weaken = C . fmap pure -- Binding syntax -binder :: (Functor m, Applicative i) => (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) -> m (i (c -> d)) -binder = binder_ id - -binder_ :: (Functor m, Applicative i) => (i (c -> d) -> e) -> (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) -> m e -binder_ f c = f . runC <$> c weaken (liftCInner id) +binder :: (Functor m, Applicative i) => (i (c -> d) -> e) -> (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) -> m e +binder f c = f . runC <$> c weaken (liftCInner id) newtype Clause m i a b = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j a -> m (j b) } diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 3f4a9f3ef..725e00a43 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -52,30 +52,30 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) -> m (i t) -µRA f = fmap µR <$> binder f +µRA = binder (fmap µR) funRA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j t))-> m (i t) -funRA f = fmap funR <$> binder f +funRA = binder (fmap funR) µLA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j d)) -> m (i c) -µLA f = fmap µL <$> binder f +µLA = binder (fmap µL) sumLA :: (Sequent t c d, Applicative i, Applicative m) => [C.Clause m i t d] -> m (i c) -sumLA cs = runC (sumL <$> traverse (\ (C.Clause c) -> C (binder c)) cs) +sumLA cs = runC (sumL <$> traverse (\ (C.Clause c) -> C (binder id c)) cs) prdLA :: (Sequent t c d, Applicative i, Applicative m) => Int -> (forall j . Applicative j => (forall x . i x -> j x) -> j [t] -> m (j d)) -> m (i c) -prdLA i f = fmap (prdL i) <$> binder f +prdLA i = binder (fmap (prdL i)) (.||.) :: (Applicative m, Applicative i, Sequent t c d) => m (i t) -> m (i c) -> m (i d) diff --git a/src/Facet/Type/Class.hs b/src/Facet/Type/Class.hs index 6a9f13f75..3ea39b24b 100644 --- a/src/Facet/Type/Class.hs +++ b/src/Facet/Type/Class.hs @@ -24,4 +24,4 @@ class Type r where infixr 9 |- forAllA :: (Applicative m, Applicative i, Type r) => Name -> Kind -> (forall j . Applicative j => (i ~> j) -> j r -> m (j r)) -> m (i r) -forAllA n k b = fmap (forAll n k) <$> binder b +forAllA n k = binder (fmap (forAll n k)) From 6e11b18b1abae0933a7240c61b3eea5b1b6e497a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jan 2022 19:37:06 -0500 Subject: [PATCH 0562/1324] Simplify mapCInner. --- src/Facet/Functor/Compose.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index 51438e8af..65d5dbb3b 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -33,7 +33,7 @@ liftCInner :: Applicative i => j a -> (i . j) a liftCInner = C . pure mapCInner :: Functor i => (j a -> j' b) -> ((i . j) a -> (i . j') b) -mapCInner f = C . fmap f . runC +mapCInner = mapCOuter . fmap mapCOuter :: (i (j a) -> i' (j' b)) -> ((i . j) a -> (i' . j') b) mapCOuter f = C . f . runC From 871439978877bda00975d337eb4efe879a64c1fb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jan 2022 19:38:13 -0500 Subject: [PATCH 0563/1324] Simplify mapCOuter. --- src/Facet/Functor/Compose.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index 65d5dbb3b..7936a213e 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -13,6 +13,7 @@ module Facet.Functor.Compose ) where import Control.Applicative (Alternative(..)) +import Data.Coerce (coerce) import Data.Functor.Identity (Identity(..)) -- Composition functor @@ -36,7 +37,7 @@ mapCInner :: Functor i => (j a -> j' b) -> ((i . j) a -> (i . j') b) mapCInner = mapCOuter . fmap mapCOuter :: (i (j a) -> i' (j' b)) -> ((i . j) a -> (i' . j') b) -mapCOuter f = C . f . runC +mapCOuter = coerce strengthen :: Applicative m => m (Identity a) -> m a From 48b5daf1101d266f7b8a4f7e8859d96ce7ba9468 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 23 Jan 2022 19:40:13 -0500 Subject: [PATCH 0564/1324] binder maintains scoping invariants. --- src/Facet/Functor/Compose.hs | 4 ++-- src/Facet/Sequent/Class.hs | 8 ++++---- src/Facet/Type/Class.hs | 2 +- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index 7936a213e..6059b856d 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -49,7 +49,7 @@ weaken = C . fmap pure -- Binding syntax -binder :: (Functor m, Applicative i) => (i (c -> d) -> e) -> (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) -> m e -binder f c = f . runC <$> c weaken (liftCInner id) +binder :: (Functor m, Applicative i) => ((c -> d) -> e) -> (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) -> m (i e) +binder f c = fmap f . runC <$> c weaken (liftCInner id) newtype Clause m i a b = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j a -> m (j b) } diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 725e00a43..026917ea0 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -52,17 +52,17 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) -> m (i t) -µRA = binder (fmap µR) +µRA = binder µR funRA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j t))-> m (i t) -funRA = binder (fmap funR) +funRA = binder funR µLA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j d)) -> m (i c) -µLA = binder (fmap µL) +µLA = binder µL sumLA :: (Sequent t c d, Applicative i, Applicative m) @@ -75,7 +75,7 @@ prdLA => Int -> (forall j . Applicative j => (forall x . i x -> j x) -> j [t] -> m (j d)) -> m (i c) -prdLA i = binder (fmap (prdL i)) +prdLA i = binder (prdL i) (.||.) :: (Applicative m, Applicative i, Sequent t c d) => m (i t) -> m (i c) -> m (i d) diff --git a/src/Facet/Type/Class.hs b/src/Facet/Type/Class.hs index 3ea39b24b..77f25c7a6 100644 --- a/src/Facet/Type/Class.hs +++ b/src/Facet/Type/Class.hs @@ -24,4 +24,4 @@ class Type r where infixr 9 |- forAllA :: (Applicative m, Applicative i, Type r) => Name -> Kind -> (forall j . Applicative j => (i ~> j) -> j r -> m (j r)) -> m (i r) -forAllA n k = binder (fmap (forAll n k)) +forAllA n k = binder (forAll n k) From acab2cf288b9043a9d22c1984ab6b3ebc432ea73 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 29 Jan 2022 11:45:57 -0500 Subject: [PATCH 0565/1324] Define a type of bindings in environments. --- src/Facet/Sequent/Class.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 026917ea0..3cd48f1fe 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -12,6 +12,7 @@ module Facet.Sequent.Class , prdLA , (.||.) , Ctx(..) +, Binding(..) , lookupCtx ) where @@ -88,6 +89,8 @@ data Ctx j t = Nil | forall i . Entry Name (Ctx i t) (i ~> j) (j t) +data Binding j t = forall i . Binding Name (i ~> j) (j t) + lookupCtx :: Name -> Ctx i t -> Maybe (i t) lookupCtx n = go id where From f093a1deb42501142138c9340c1e184876b049fd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 29 Jan 2022 11:46:31 -0500 Subject: [PATCH 0566/1324] Expose the outer scope. --- src/Facet/Sequent/Class.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 3cd48f1fe..963f710d9 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -89,7 +89,7 @@ data Ctx j t = Nil | forall i . Entry Name (Ctx i t) (i ~> j) (j t) -data Binding j t = forall i . Binding Name (i ~> j) (j t) +data Binding i j t = Binding Name (i ~> j) (j t) lookupCtx :: Name -> Ctx i t -> Maybe (i t) lookupCtx n = go id From bd201dbbde95456d4b8f3a2290a459316ae8ff75 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 29 Jan 2022 11:48:33 -0500 Subject: [PATCH 0567/1324] Ctx uses Binding. --- src/Facet/Sequent/Class.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 963f710d9..4d183da85 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -87,7 +87,9 @@ infix 1 .||. data Ctx j t = Nil - | forall i . Entry Name (Ctx i t) (i ~> j) (j t) + | forall i . Ctx i t :> Binding i j t + +infixl 5 :> data Binding i j t = Binding Name (i ~> j) (j t) @@ -96,5 +98,5 @@ lookupCtx n = go id where go :: (i ~> j) -> Ctx i t -> Maybe (j t) go wk = \case - Nil -> Nothing - Entry n' c wk' t -> wk t <$ guard (n == n') <|> go (wk . wk') c + Nil -> Nothing + c :> Binding n' wk' t -> wk t <$ guard (n == n') <|> go (wk . wk') c From 9d256eeb5ad4cc8f20adb03aa773d2c2ea0eb084 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 30 Jan 2022 03:25:03 -0500 Subject: [PATCH 0568/1324] Define a Binding type. --- src/Facet/Context.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index db7125ace..823bf22a5 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -2,6 +2,7 @@ module Facet.Context ( -- * Contexts Quantity , Context(..) +, Binding(..) , empty , (|>) , level @@ -25,6 +26,8 @@ import Prelude hiding (lookup) newtype Context = Context { elems :: S.Snoc (Quantity, Pattern (Name :==> Classifier)) } +data Binding = Binding Quantity (Pattern (Name :==> Classifier)) + empty :: Context empty = Context S.Nil From 21a7c224606ce2ffe0ef5f456a81ddf1eb2739ef Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 30 Jan 2022 03:32:20 -0500 Subject: [PATCH 0569/1324] Contexts hold Bindings. --- src/Facet/Context.hs | 10 +++++----- src/Facet/Elab.hs | 2 +- src/Facet/Notice/Elab.hs | 2 +- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index 823bf22a5..d3144aa40 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -24,7 +24,7 @@ import Facet.Usage import GHC.Stack import Prelude hiding (lookup) -newtype Context = Context { elems :: S.Snoc (Quantity, Pattern (Name :==> Classifier)) } +newtype Context = Context { elems :: S.Snoc Binding } data Binding = Binding Quantity (Pattern (Name :==> Classifier)) @@ -32,7 +32,7 @@ data Binding = Binding Quantity (Pattern (Name :==> Classifier)) empty :: Context empty = Context S.Nil -(|>) :: Context -> (Quantity, Pattern (Name :==> Classifier)) -> Context +(|>) :: Context -> Binding -> Context Context as |> a = Context (as S.:> a) infixl 5 |> @@ -40,7 +40,7 @@ infixl 5 |> level :: Context -> Used level (Context es) = Used (Level (length es)) -(!) :: HasCallStack => Context -> Index -> (Quantity, Pattern (Name :==> Classifier)) +(!) :: HasCallStack => Context -> Index -> Binding Context es' ! Index i' = withFrozenCallStack $ go es' i' where go (es S.:> e) i @@ -52,10 +52,10 @@ lookupIndex :: E.Has E.Empty sig m => Name -> Context -> m (LName Index, Quantit lookupIndex n = go (Index 0) . elems where go _ S.Nil = E.empty - go i (cs S.:> (q, p)) + go i (cs S.:> Binding q p) | Just (n' :==> t) <- find ((== n) . proof) p = pure (LName i n', q, t) | otherwise = go (succ i) cs toEnv :: Context -> Env.Env Type -toEnv c = Env.Env (S.fromList (zipWith (\ (_, p) d -> (\ b -> proof b :=: free (LName (getUsed d) (proof b))) <$> p) (toList (elems c)) [0..pred (level c)])) +toEnv c = Env.Env (S.fromList (zipWith (\ (Binding _ p) d -> (\ b -> proof b :=: free (LName (getUsed d) (proof b))) <$> p) (toList (elems c)) [0..pred (level c)])) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 52e316468..4350ef414 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -148,7 +148,7 @@ lookupInSig (m :. n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':.:_) _) (q, p) |- b = do sigma <- asks scale d <- depth - (u, a) <- censor (`Usage.withoutVars` Vars.singleton (getUsed d)) $ listen $ locally context_ (|> (q, p)) b + (u, a) <- censor (`Usage.withoutVars` Vars.singleton (getUsed d)) $ listen $ locally context_ (|> Binding q p) b for_ p $ \ (n :==> _T) -> do let exp = sigma >< q act = Usage.lookup (LName (getUsed d) n) u diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 8653173ba..2e958d704 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -42,7 +42,7 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) (_, _, printCtx, ctx) = foldl' combine (0, Env.empty, Env.empty, Nil) (elems context) subst' = map (\ (m :=: v) -> getPrint (Print.meta m <+> pretty '=' <+> maybe (pretty '?') (print opts printCtx) v)) (metas subst) sig' = getPrint . print opts printCtx . fmap (apply subst (toEnv context)) <$> (interfaces =<< sig) - combine (d, env, prints, ctx) (m, p) = + combine (d, env, prints, ctx) (Binding m p) = let roundtrip = apply subst env binding (n :==> _T) = ann (intro n d ::: mult m (case _T of CK _K -> print opts prints _K From 1ae02fbe8582641ab0fd849f8f56b21239eafb75 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 30 Jan 2022 03:36:51 -0500 Subject: [PATCH 0570/1324] Bindings have some arbitrary map between scopes. --- src/Facet/Context.hs | 7 ++++--- src/Facet/Elab.hs | 2 +- src/Facet/Notice/Elab.hs | 2 +- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index d3144aa40..6b5e81d20 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ExistentialQuantification #-} module Facet.Context ( -- * Contexts Quantity @@ -26,7 +27,7 @@ import Prelude hiding (lookup) newtype Context = Context { elems :: S.Snoc Binding } -data Binding = Binding Quantity (Pattern (Name :==> Classifier)) +data Binding = forall i j . Binding Quantity (i ~> j) (Pattern (Name :==> Classifier)) empty :: Context @@ -52,10 +53,10 @@ lookupIndex :: E.Has E.Empty sig m => Name -> Context -> m (LName Index, Quantit lookupIndex n = go (Index 0) . elems where go _ S.Nil = E.empty - go i (cs S.:> Binding q p) + go i (cs S.:> Binding q _ p) | Just (n' :==> t) <- find ((== n) . proof) p = pure (LName i n', q, t) | otherwise = go (succ i) cs toEnv :: Context -> Env.Env Type -toEnv c = Env.Env (S.fromList (zipWith (\ (Binding _ p) d -> (\ b -> proof b :=: free (LName (getUsed d) (proof b))) <$> p) (toList (elems c)) [0..pred (level c)])) +toEnv c = Env.Env (S.fromList (zipWith (\ (Binding _ _ p) d -> (\ b -> proof b :=: free (LName (getUsed d) (proof b))) <$> p) (toList (elems c)) [0..pred (level c)])) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 4350ef414..28dc6c537 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -148,7 +148,7 @@ lookupInSig (m :. n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':.:_) _) (q, p) |- b = do sigma <- asks scale d <- depth - (u, a) <- censor (`Usage.withoutVars` Vars.singleton (getUsed d)) $ listen $ locally context_ (|> Binding q p) b + (u, a) <- censor (`Usage.withoutVars` Vars.singleton (getUsed d)) $ listen $ locally context_ (|> Binding q id p) b for_ p $ \ (n :==> _T) -> do let exp = sigma >< q act = Usage.lookup (LName (getUsed d) n) u diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 2e958d704..7a6d084d4 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -42,7 +42,7 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) (_, _, printCtx, ctx) = foldl' combine (0, Env.empty, Env.empty, Nil) (elems context) subst' = map (\ (m :=: v) -> getPrint (Print.meta m <+> pretty '=' <+> maybe (pretty '?') (print opts printCtx) v)) (metas subst) sig' = getPrint . print opts printCtx . fmap (apply subst (toEnv context)) <$> (interfaces =<< sig) - combine (d, env, prints, ctx) (Binding m p) = + combine (d, env, prints, ctx) (Binding m _ p) = let roundtrip = apply subst env binding (n :==> _T) = ann (intro n d ::: mult m (case _T of CK _K -> print opts prints _K From 0f69f647cceac503f54c5089b2bfaee016135d9b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 09:38:01 -0500 Subject: [PATCH 0571/1324] Obviate the need for Classifier in Binding. --- src/Facet/Context.hs | 26 +++++++++++++++++++------- src/Facet/Elab.hs | 12 +++++++++--- src/Facet/Elab/Term.hs | 20 +++++++++----------- src/Facet/Elab/Type.hs | 8 +++----- src/Facet/Notice/Elab.hs | 17 +++++++++++------ src/Facet/Sequent/Class.hs | 30 +++++++++++++++--------------- src/Facet/Unify.hs | 4 +--- 7 files changed, 67 insertions(+), 50 deletions(-) diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index 6b5e81d20..649c4bcf8 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -16,6 +16,7 @@ import qualified Control.Effect.Empty as E import Data.Foldable (find, toList) import qualified Facet.Env as Env import Facet.Functor.Synth +import Facet.Kind (Kind) import Facet.Name import Facet.Pattern import qualified Facet.Snoc as S @@ -27,7 +28,9 @@ import Prelude hiding (lookup) newtype Context = Context { elems :: S.Snoc Binding } -data Binding = forall i j . Binding Quantity (i ~> j) (Pattern (Name :==> Classifier)) +data Binding + = forall i j . Type Quantity (i ~> j) (Pattern (Name :==> Type)) + | Kind (Name :==> Kind) empty :: Context @@ -49,14 +52,23 @@ Context es' ! Index i' = withFrozenCallStack $ go es' i' | otherwise = go es (i - 1) go _ _ = error $ "Facet.Context.!: index (" <> show i' <> ") out of bounds (" <> show (length es') <> ")" -lookupIndex :: E.Has E.Empty sig m => Name -> Context -> m (LName Index, Quantity, Classifier) +lookupIndex :: E.Has E.Empty sig m => Name -> Context -> m (LName Index, Either Kind (Quantity, Type)) lookupIndex n = go (Index 0) . elems where - go _ S.Nil = E.empty - go i (cs S.:> Binding q _ p) - | Just (n' :==> t) <- find ((== n) . proof) p = pure (LName i n', q, t) - | otherwise = go (succ i) cs + go _ S.Nil = E.empty + go i (cs S.:> b) = case b of + Type q _ p + | Just (n' :==> t) <- find ((== n) . proof) p -> pure (LName i n', Right (q, t)) + Kind (n' :==> k) + | n == n' -> pure (LName i n', Left k) + _ -> go (succ i) cs toEnv :: Context -> Env.Env Type -toEnv c = Env.Env (S.fromList (zipWith (\ (Binding _ _ p) d -> (\ b -> proof b :=: free (LName (getUsed d) (proof b))) <$> p) (toList (elems c)) [0..pred (level c)])) +toEnv c = Env.Env (S.fromList (zipWith toType (toList (elems c)) [0..pred (level c)])) + where + toType b d = case b of + Type _ _ p -> (\ b -> proof b :=: bind d (proof b)) <$> p + Kind (n :==> _) -> PVar (n :=: bind d n) + + bind d b = free (LName (getUsed d) b) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 28dc6c537..f261f70e8 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -11,6 +11,7 @@ module Facet.Elab , meta , instantiate , (|-) +, (||-) -- * Errors , pushSpan , Err(..) @@ -127,7 +128,7 @@ resolveC = resolveWith lookupC resolveQ :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (RName :=: Def) resolveQ = resolveWith lookupD -lookupInContext :: Has (Choose :+: Empty) sig m => QName -> Context -> m (LName Index, Quantity, Classifier) +lookupInContext :: Has (Choose :+: Empty) sig m => QName -> Context -> m (LName Index, Either Kind (Quantity, Type)) lookupInContext (m:.n) | m == Nil = lookupIndex n | otherwise = const empty @@ -144,11 +145,11 @@ lookupInSig (m :. n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':.:_) _) interfaceScope (_ :=: d) = case d of { DSubmodule (SInterface defs) _K -> pure defs ; _ -> empty } -(|-) :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Writer Usage) sig m) => (Quantity, Pattern (Name :==> Classifier)) -> m a -> m a +(|-) :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Writer Usage) sig m) => (Quantity, Pattern (Name :==> Type)) -> m a -> m a (q, p) |- b = do sigma <- asks scale d <- depth - (u, a) <- censor (`Usage.withoutVars` Vars.singleton (getUsed d)) $ listen $ locally context_ (|> Binding q id p) b + (u, a) <- censor (`Usage.withoutVars` Vars.singleton (getUsed d)) $ listen $ locally context_ (|> Type q id p) b for_ p $ \ (n :==> _T) -> do let exp = sigma >< q act = Usage.lookup (LName (getUsed d) n) u @@ -158,6 +159,11 @@ lookupInSig (m :. n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':.:_) _) infix 1 |- +(||-) :: Has (Reader ElabContext) sig m => (Name :==> Kind) -> m a -> m a +k ||- b = locally context_ (|> Kind k) b + +infix 1 ||- + -- | Test whether the first quantity suffices to satisfy a requirement of the second. sat :: Quantity -> Quantity -> Bool sat a b diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 1b47f23fc..4ae2ac7b1 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -68,7 +68,7 @@ import Facet.Lens as Lens (locally, view, views, (.=), (<~)) import Facet.Module as Module import Facet.Name import Facet.Pattern -import Facet.Semiring (Few(..), zero, (><<)) +import Facet.Semiring (Few(..), (><<)) import qualified Facet.Sequent.Class as SQ import Facet.Snoc import Facet.Snoc.NonEmpty as NE @@ -116,7 +116,7 @@ global (q ::: _T) = (\ (v ::: _T) -> v :==> _T) <$> instantiate const (Var (Glob -- FIXME: effect ops in the sig are available whether or not they’re in scope var :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (Term :==> Type) var n = views context_ (lookupInContext n) >>= \case - [(n', q, CT _T)] -> use n' q $> (Var (Free n') :==> _T) + [(n', Right (q, _T))] -> use n' q $> (Var (Free n') :==> _T) _ -> resolveQ n >>= \case n :=: DTerm _ _T -> global (n ::: _T) _ :=: _ -> freeVariable n @@ -130,7 +130,7 @@ tlam :: (HasCallStack, Has (Throw Err) sig m) => Type <==: Elab m Term -> Type < tlam b = Check $ \ _T -> do (n, _A, _B) <- assertQuantifier _T d <- depth - (zero, PVar (n :==> CK _A)) |- check (b ::: _B (T.free (LName (getUsed d) n))) + n :==> _A ||- check (b ::: _B (T.free (LName (getUsed d) n))) lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern (Name :==> Type)), Type <==: Elab m Term)] -> Type <==: Elab m Term lam cs = Check $ \ _T -> do @@ -184,7 +184,7 @@ comp b = Check $ \ _T -> do interfacePattern (Interface n _) = maybe (freeVariable (toQ n)) (\ (n' :=: _T) -> pure ((n .:. n') :=: (n' :==> _T))) (listToMaybe (scopeToList . tm =<< unDInterface . def =<< lookupQ graph module' (toQ n))) p' <- traverse interfacePattern (interfaces sig) -- FIXME: can we apply quantities to dictionaries? what would they mean? - b' <- (Many, PDict (map (fmap (fmap CT)) p')) |- check (b ::: _B) + b' <- (Many, PDict p') |- check (b ::: _B) pure $ E.Comp (map (fmap proof) p') b' @@ -269,12 +269,10 @@ bindPattern = withSpanB $ \case -- | Elaborate a type abstracted over another type’s parameters. -- -- This is used to elaborate data constructors & effect operations, which receive the type/interface parameters as implicit parameters ahead of their own explicit ones. -abstractType :: (HasCallStack, Has (Throw Err) sig m) => Elab m TX.Type -> Kind -> Elab m TX.Type -abstractType body = go - where - go = \case - KArrow (Just n) a b -> TX.ForAll n a <$> ((zero, PVar (n :==> CK a)) |- go b) - _ -> body +abstractType :: Algebra sig m => Elab m TX.Type -> Kind -> Elab m TX.Type +abstractType body = \case + KArrow (Just n) a b -> TX.ForAll n a <$> (n :==> a ||- abstractType body b) + _ -> body abstractTerm :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => (Snoc TX.Type -> Snoc Term -> Term) -> Type <==: Elab m Term abstractTerm body = go Nil Nil @@ -432,7 +430,7 @@ check (m ::: _T) = case _T of bind :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Type)) ::: (Quantity, Type) -> Elab m b -> Elab m (Pattern Name, b) -bind (p ::: (q, _T)) m = runBind p _T (\ p' -> (proof <$> p',) <$> ((q, fmap (fmap CT) p') |- m)) +bind (p ::: (q, _T)) m = runBind p _T (\ p' -> (proof <$> p',) <$> ((q, p') |- m)) newtype Bind m a = Bind { runBind :: forall x . Type -> (a -> Elab m x) -> Elab m x } deriving (Functor) diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 9ee721957..575a7be10 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -14,7 +14,6 @@ import Control.Applicative (liftA2) import Control.Effect.Throw import Control.Monad (unless) import Data.Foldable (foldl') -import Data.Functor (($>)) import Facet.Elab import Facet.Functor.Check import Facet.Functor.Synth @@ -23,7 +22,6 @@ import Facet.Kind import Facet.Lens (views) import Facet.Module import Facet.Name -import Facet.Pattern import Facet.Semiring (Few(..), one, zero) import Facet.Snoc import qualified Facet.Surface.Type.Expr as S @@ -34,8 +32,8 @@ import GHC.Stack tvar :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (TX.Type :==> Kind) tvar n = views context_ (lookupInContext n) >>= \case - [(n', q, CK _K)] -> use n' q $> (TX.Var (Free (Right n')) :==> _K) - _ -> resolveQ n >>= \case + [(n', Left _K)] -> pure (TX.Var (Free (Right n')) :==> _K) + _ -> resolveQ n >>= \case q :=: DSubmodule _ _K -> pure $ TX.Var (Global q) :==> _K _ -> freeVariable n @@ -51,7 +49,7 @@ _String = pure $ TX.String :==> KType forAll :: (HasCallStack, Has (Throw Err) sig m) => Name ::: Kind -> Elab m (TX.Type :==> Kind) -> Elab m (TX.Type :==> Kind) forAll (n ::: t) b = do - b' <- (zero, PVar (n :==> CK t)) |- switch b <==: KType + b' <- n :==> t ||- switch b <==: KType pure $ TX.ForAll n t b' :==> KType arrow :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> Elab m (a :==> Kind) -> Elab m (b :==> Kind) -> Elab m (c :==> Kind) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 7a6d084d4..126ab2e15 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -8,13 +8,14 @@ import Data.Foldable (foldl') import Data.Semigroup (stimes) import qualified Facet.Carrier.Throw.Inject as L import qualified Facet.Carrier.Write.Inject as L -import Facet.Context +import Facet.Context as C import Facet.Elab as Elab import qualified Facet.Env as Env import Facet.Functor.Synth import Facet.Interface (interfaces) import Facet.Name (LName(..)) import Facet.Notice as Notice hiding (level) +import Facet.Pattern import Facet.Pretty import Facet.Print as Print import Facet.Semiring (Few(..), one, zero) @@ -22,7 +23,7 @@ import Facet.Snoc import Facet.Style import Facet.Subst (metas) import Facet.Syntax hiding (ann) -import Facet.Type.Norm (Classifier(..), apply, free, metavar) +import Facet.Type.Norm (apply, free, metavar) import GHC.Stack import Prelude hiding (print, unlines) import Silkscreen @@ -42,11 +43,15 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) (_, _, printCtx, ctx) = foldl' combine (0, Env.empty, Env.empty, Nil) (elems context) subst' = map (\ (m :=: v) -> getPrint (Print.meta m <+> pretty '=' <+> maybe (pretty '?') (print opts printCtx) v)) (metas subst) sig' = getPrint . print opts printCtx . fmap (apply subst (toEnv context)) <$> (interfaces =<< sig) - combine (d, env, prints, ctx) (Binding m _ p) = + combine (d, env, prints, ctx) (C.Kind (n :==> _K)) = + let binding = ann (intro n d ::: print opts prints _K) + in ( succ d + , env Env.|> PVar (n :=: free (LName d n)) + , prints Env.|> PVar (n :=: intro n d) + , ctx :> getPrint (print opts prints binding) ) + combine (d, env, prints, ctx) (C.Type m _ p) = let roundtrip = apply subst env - binding (n :==> _T) = ann (intro n d ::: mult m (case _T of - CK _K -> print opts prints _K - CT _T -> print opts prints (roundtrip _T))) + binding (n :==> _T) = ann (intro n d ::: mult m (print opts prints (roundtrip _T))) in ( succ d , env Env.|> ((\ (n :==> _T) -> n :=: free (LName d n)) <$> p) , prints Env.|> ((\ (n :==> _) -> n :=: intro n d) <$> p) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 4d183da85..2677ceb65 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -11,9 +11,9 @@ module Facet.Sequent.Class , sumLA , prdLA , (.||.) -, Ctx(..) -, Binding(..) -, lookupCtx +-- , Ctx(..) +-- , Binding(..) +-- , lookupCtx ) where import Control.Applicative (Alternative(..), liftA2) @@ -85,18 +85,18 @@ prdLA i = binder (prdL i) infix 1 .||. -data Ctx j t - = Nil - | forall i . Ctx i t :> Binding i j t +-- data Ctx j t +-- = Nil +-- | forall i . Ctx i t :> Binding i j t -infixl 5 :> +-- infixl 5 :> -data Binding i j t = Binding Name (i ~> j) (j t) +-- data Binding i j t = Binding Name (i ~> j) (j t) -lookupCtx :: Name -> Ctx i t -> Maybe (i t) -lookupCtx n = go id - where - go :: (i ~> j) -> Ctx i t -> Maybe (j t) - go wk = \case - Nil -> Nothing - c :> Binding n' wk' t -> wk t <$ guard (n == n') <|> go (wk . wk') c +-- lookupCtx :: Name -> Ctx i t -> Maybe (i t) +-- lookupCtx n = go id +-- where +-- go :: (i ~> j) -> Ctx i t -> Maybe (j t) +-- go wk = \case +-- Nil -> Nothing +-- c :> Binding n' wk' t -> wk t <$ guard (n == n') <|> go (wk . wk') c diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index 82e2fa3ad..9c6caee12 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -23,10 +23,8 @@ import Facet.Functor.Synth import Facet.Interface import Facet.Kind import Facet.Name -import Facet.Pattern import Facet.Quote import Facet.Semialign -import Facet.Semiring import Facet.Snoc import Facet.Subst import Facet.Syntax @@ -61,7 +59,7 @@ unifyType = curry $ \case (TN.Ne (Free (Left v1)) Nil, TN.Ne (Free (Left v2)) Nil) -> flexFlex v1 v2 (TN.Ne (Free (Left v1)) Nil, t2) -> solve v1 t2 (t1, TN.Ne (Free (Left v2)) Nil) -> solve v2 t1 - (TN.ForAll _ t1 b1, TN.ForAll n t2 b2) -> depth >>= \ d -> evalTExpr =<< mkForAll d n <$> unifyKind t1 t2 <*> ((zero, PVar (n :==> CK t2)) |- unifyType (b1 (free (LName (getUsed d) n))) (b2 (free (LName (getUsed d) n)))) + (TN.ForAll _ t1 b1, TN.ForAll n t2 b2) -> depth >>= \ d -> evalTExpr =<< mkForAll d n <$> unifyKind t1 t2 <*> (n :==> t2 ||- unifyType (b1 (free (LName (getUsed d) n))) (b2 (free (LName (getUsed d) n)))) (TN.ForAll{}, _) -> mismatch (TN.Arrow _ _ a1 b1, TN.Arrow n q a2 b2) -> TN.Arrow n q <$> unifyType a1 a2 <*> unifyType b1 b2 (TN.Arrow{}, _) -> mismatch From bbe3337053e32c521abdfdda86eee4bd1a0d37de Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 09:38:42 -0500 Subject: [PATCH 0572/1324] :fire: MultiWayIf. --- src/Facet/Notice/Elab.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 126ab2e15..d2f276fc6 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -56,10 +56,10 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) , env Env.|> ((\ (n :==> _T) -> n :=: free (LName d n)) <$> p) , prints Env.|> ((\ (n :==> _) -> n :=: intro n d) <$> p) , ctx :> getPrint (print opts prints (binding <$> p)) ) - mult m = if - | m == zero -> (pretty "0" <+>) - | m == one -> (pretty "1" <+>) - | otherwise -> id + mult m + | m == zero = (pretty "0" <+>) + | m == one = (pretty "1" <+>) + | otherwise = id printErrReason :: Options Print -> Env.Env Print -> ErrReason -> Doc Style From ff3868f3c0ce76837b4d01cd65059bcd056f61e7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 09:45:28 -0500 Subject: [PATCH 0573/1324] Simplify combine for kinds. --- src/Facet/Notice/Elab.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index d2f276fc6..a946a5466 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -44,11 +44,10 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) subst' = map (\ (m :=: v) -> getPrint (Print.meta m <+> pretty '=' <+> maybe (pretty '?') (print opts printCtx) v)) (metas subst) sig' = getPrint . print opts printCtx . fmap (apply subst (toEnv context)) <$> (interfaces =<< sig) combine (d, env, prints, ctx) (C.Kind (n :==> _K)) = - let binding = ann (intro n d ::: print opts prints _K) - in ( succ d - , env Env.|> PVar (n :=: free (LName d n)) - , prints Env.|> PVar (n :=: intro n d) - , ctx :> getPrint (print opts prints binding) ) + ( succ d + , env Env.|> PVar (n :=: free (LName d n)) + , prints Env.|> PVar (n :=: intro n d) + , ctx :> getPrint (print opts prints (ann (intro n d ::: print opts prints _K))) ) combine (d, env, prints, ctx) (C.Type m _ p) = let roundtrip = apply subst env binding (n :==> _T) = ann (intro n d ::: mult m (print opts prints (roundtrip _T))) From 4102841cbc99774981e65b1d1d0fc024169ca38b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 09:46:09 -0500 Subject: [PATCH 0574/1324] Inline roundtrip. --- src/Facet/Notice/Elab.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index a946a5466..2330b664c 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -49,8 +49,7 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) , prints Env.|> PVar (n :=: intro n d) , ctx :> getPrint (print opts prints (ann (intro n d ::: print opts prints _K))) ) combine (d, env, prints, ctx) (C.Type m _ p) = - let roundtrip = apply subst env - binding (n :==> _T) = ann (intro n d ::: mult m (print opts prints (roundtrip _T))) + let binding (n :==> _T) = ann (intro n d ::: mult m (print opts prints (apply subst env _T))) in ( succ d , env Env.|> ((\ (n :==> _T) -> n :=: free (LName d n)) <$> p) , prints Env.|> ((\ (n :==> _) -> n :=: intro n d) <$> p) From f27a68b53ac09adc9c6431a7504fb5f8f82cd92a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 09:46:59 -0500 Subject: [PATCH 0575/1324] Simplify combine for types. --- src/Facet/Notice/Elab.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 2330b664c..b1e028a0e 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -49,11 +49,10 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) , prints Env.|> PVar (n :=: intro n d) , ctx :> getPrint (print opts prints (ann (intro n d ::: print opts prints _K))) ) combine (d, env, prints, ctx) (C.Type m _ p) = - let binding (n :==> _T) = ann (intro n d ::: mult m (print opts prints (apply subst env _T))) - in ( succ d - , env Env.|> ((\ (n :==> _T) -> n :=: free (LName d n)) <$> p) - , prints Env.|> ((\ (n :==> _) -> n :=: intro n d) <$> p) - , ctx :> getPrint (print opts prints (binding <$> p)) ) + ( succ d + , env Env.|> ((\ (n :==> _T) -> n :=: free (LName d n)) <$> p) + , prints Env.|> ((\ (n :==> _) -> n :=: intro n d) <$> p) + , ctx :> getPrint (print opts prints ((\ (n :==> _T) -> ann (intro n d ::: mult m (print opts prints (apply subst env _T)))) <$> p)) ) mult m | m == zero = (pretty "0" <+>) | m == one = (pretty "1" <+>) From fb552f26b253b43ba3f74882a054b30227b385d0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 12:09:15 -0500 Subject: [PATCH 0576/1324] Define a datatype for quantity annotations. --- src/Facet/Syntax.hs | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 89b43a0dd..40e1aac4a 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -9,6 +9,7 @@ module Facet.Syntax , _ty , (:=:)(..) , nm, def +, (:@)(..) -- * Variables , Var(..) -- * Decomposition @@ -103,6 +104,21 @@ def :: a :=: b -> b def (_ :=: b) = b +data a :@ b = a :@ b + deriving (Eq, Foldable, Functor, Ord, Show, Traversable) + +infixr 2 :@ + +instance Bifoldable (:@) where + bifoldMap = bifoldMapDefault + +instance Bifunctor (:@) where + bimap = bimapDefault + +instance Bitraversable (:@) where + bitraverse f g (a :@ b) = (:@) <$> f a <*> g b + + -- Variables data Var a From f84bc4e60bcf4c64b36c20fc082756727f208611 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 12:10:12 -0500 Subject: [PATCH 0577/1324] Project quantities out. --- src/Facet/Syntax.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 40e1aac4a..d54681b15 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -10,6 +10,7 @@ module Facet.Syntax , (:=:)(..) , nm, def , (:@)(..) +, qty -- * Variables , Var(..) -- * Decomposition @@ -118,6 +119,9 @@ instance Bifunctor (:@) where instance Bitraversable (:@) where bitraverse f g (a :@ b) = (:@) <$> f a <*> g b +qty :: p :@ q -> q +qty (_ :@ q) = q + -- Variables From f5a037c22e1abfd4e75624f7353a6437c0b9ad1d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 12:13:04 -0500 Subject: [PATCH 0578/1324] Fix the fixity. --- src/Facet/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index d54681b15..4ba02a76c 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -108,7 +108,7 @@ def (_ :=: b) = b data a :@ b = a :@ b deriving (Eq, Foldable, Functor, Ord, Show, Traversable) -infixr 2 :@ +infixl 1 :@ instance Bifoldable (:@) where bifoldMap = bifoldMapDefault From 5489a09bcf9fe79397a87d43c055f65f60f45fa8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 12:13:32 -0500 Subject: [PATCH 0579/1324] Pass the quantity along to the body of lamS. --- src/Facet/Elab/Term.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 4ae2ac7b1..6fe9990b5 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -141,11 +141,10 @@ lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Type lam1 p b = lam [(p, b)] -- FIXME: scope-safety requires an outer environment and weakening -lamS :: (HasCallStack, Has (Throw Err) sig m, SQ.Sequent t c d) => (forall j . Applicative j => (j t :==> Type) -> (Type <==: Elab m (j t))) -> Type <==: Elab m t +lamS :: (HasCallStack, Has (Throw Err) sig m, SQ.Sequent t c d) => (forall j . Applicative j => (j t :@ Quantity :==> Type) -> (Type <==: Elab m (j t))) -> Type <==: Elab m t lamS f = runC . strengthen $ SQ.funRA $ \ _ v -> C $ Check $ \ _T -> do - -- FIXME: how should we pass the quantity along to the higher-order function? - (_, _q, _A, _B) <- assertTacitFunction _T - check (f (v :==> _A) ::: _B) + (_, q, _A, _B) <- assertTacitFunction _T + check (f (v :@ q :==> _A) ::: _B) app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Elab m (a :==> Type)) -> (HasCallStack => Type <==: Elab m b) -> Elab m (c :==> Type) app mk operator operand = do From f78930e0dd4a4b6215e5a72a5ec96b3b686e24d7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 12:14:17 -0500 Subject: [PATCH 0580/1324] Export lamS. --- src/Facet/Elab/Term.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 6fe9990b5..db851c803 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -9,6 +9,7 @@ module Facet.Elab.Term , var , tlam , lam +, lamS , app , appS , string From c51548e491521a65820c4eb550632fcf9149448f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 12:15:08 -0500 Subject: [PATCH 0581/1324] Spacing. --- src/Facet/Elab/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index db851c803..0151dc8c9 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -142,7 +142,7 @@ lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Type lam1 p b = lam [(p, b)] -- FIXME: scope-safety requires an outer environment and weakening -lamS :: (HasCallStack, Has (Throw Err) sig m, SQ.Sequent t c d) => (forall j . Applicative j => (j t :@ Quantity :==> Type) -> (Type <==: Elab m (j t))) -> Type <==: Elab m t +lamS :: (HasCallStack, Has (Throw Err) sig m, SQ.Sequent t c d) => (forall j . Applicative j => (j t :@ Quantity :==> Type) -> (Type <==: Elab m (j t))) -> Type <==: Elab m t lamS f = runC . strengthen $ SQ.funRA $ \ _ v -> C $ Check $ \ _T -> do (_, q, _A, _B) <- assertTacitFunction _T check (f (v :@ q :==> _A) ::: _B) From 55755af1ef085001f6c6e16fa485042df861dece Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 12:18:40 -0500 Subject: [PATCH 0582/1324] lamS is scope safe. --- src/Facet/Elab/Term.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 0151dc8c9..7083ff6a9 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -141,11 +141,10 @@ lam cs = Check $ \ _T -> do lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Type)) -> Type <==: Elab m Term -> Type <==: Elab m Term lam1 p b = lam [(p, b)] --- FIXME: scope-safety requires an outer environment and weakening -lamS :: (HasCallStack, Has (Throw Err) sig m, SQ.Sequent t c d) => (forall j . Applicative j => (j t :@ Quantity :==> Type) -> (Type <==: Elab m (j t))) -> Type <==: Elab m t -lamS f = runC . strengthen $ SQ.funRA $ \ _ v -> C $ Check $ \ _T -> do +lamS :: (HasCallStack, Has (Throw Err) sig m, SQ.Sequent t c d, Applicative i) => (forall j . Applicative j => (i ~> j) -> (j t :@ Quantity :==> Type) -> (Type <==: Elab m (j t))) -> Type <==: Elab m (i t) +lamS f = runC $ SQ.funRA $ \ wk v -> C $ Check $ \ _T -> do (_, q, _A, _B) <- assertTacitFunction _T - check (f (v :@ q :==> _A) ::: _B) + check (f wk (v :@ q :==> _A) ::: _B) app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Elab m (a :==> Type)) -> (HasCallStack => Type <==: Elab m b) -> Elab m (c :==> Type) app mk operator operand = do From eaf845b2907a50f916a4c4b3e47e6a65260ebe38 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 12:23:00 -0500 Subject: [PATCH 0583/1324] Lift funL into scope-safe contexts. --- src/Facet/Sequent/Class.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 2677ceb65..82bc084d9 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -8,6 +8,7 @@ module Facet.Sequent.Class , C.Clause(..) , funRA , µLA +, funLA , sumLA , prdLA , (.||.) @@ -65,6 +66,13 @@ funRA = binder funR -> m (i c) µLA = binder µL +funLA + :: (Sequent t c d, Applicative i, Applicative m) + => m (i t) + -> m (i c) + -> m (i c) +funLA f a = liftA2 funL <$> f <*> a + sumLA :: (Sequent t c d, Applicative i, Applicative m) => [C.Clause m i t d] From 4416dcfe22454ff47f71c002be3555e963d06b6d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 12:23:35 -0500 Subject: [PATCH 0584/1324] :fire: ExistentialQuantification. --- src/Facet/Sequent/Class.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 82bc084d9..419fc7ddb 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FunctionalDependencies #-} module Facet.Sequent.Class ( -- * Sequent abstraction @@ -17,12 +16,11 @@ module Facet.Sequent.Class -- , lookupCtx ) where -import Control.Applicative (Alternative(..), liftA2) -import Control.Monad (guard) +import Control.Applicative (liftA2) import Data.Text (Text) import Facet.Functor.Compose as C -import Facet.Name (Level, Name, RName) -import Facet.Syntax (Var, type (~>)) +import Facet.Name (Level, RName) +import Facet.Syntax (Var) -- * Term abstraction From 9bb1a1b387b86a8e5c7560b907d683de35fe423c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 12:52:57 -0500 Subject: [PATCH 0585/1324] Make appS scope-safe. --- src/Facet/Elab/Term.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 7083ff6a9..c9a2b0f30 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -153,12 +153,12 @@ app mk operator operand = do a' <- censor @Usage (q ><<) $ check (operand ::: _A) pure $ mk f' a' :==> _B -appS :: (HasCallStack, Has (Throw Err) sig m, SQ.Sequent t c d) => (HasCallStack => Elab m (t :==> Type)) -> (HasCallStack => Type <==: Elab m t) -> Elab m (t :==> Type) +appS :: (HasCallStack, Has (Throw Err) sig m, SQ.Sequent t c d, Applicative i) => (HasCallStack => Elab m (i t :==> Type)) -> (HasCallStack => Type <==: Elab m (i t)) -> Elab m (i t :==> Type) appS f a = do f' :==> _F <- f (_, q, _A, _B) <- assertFunction _F a' <- censor @Usage (q ><<) $ check (a ::: _A) - pure $ SQ.µR (\ k -> f' SQ..|. SQ.funL a' k) :==> _B + (:==> _B) <$> SQ.µRA (\ wk k -> pure (wk f') SQ..||. SQ.funLA (pure (wk a')) (pure k)) string :: Text -> Elab m (Term :==> Type) From cab0860cb72632ae29fc0d44f67c32e15700a3f9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 12:55:08 -0500 Subject: [PATCH 0586/1324] Define a class for containers around terms. --- src/Facet/Syntax.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 4ba02a76c..8175add7e 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -2,7 +2,9 @@ {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE UndecidableInstances #-} module Facet.Syntax -( (:::)(..) +( -- * Term containers + HasTerm(..) +, (:::)(..) , tm , _tm , ty @@ -45,6 +47,12 @@ import Facet.Snoc import Facet.Span import Fresnel.Lens (Lens, Lens', lens) +-- Term containers + +class HasTerm p where + tm_ :: Lens (p s t) (p s' t') s s' + + data a ::: b = a ::: b deriving (Eq, Foldable, Functor, Ord, Show, Traversable) From c8d9e6bf01a5f9ce91028ee2204e968032aa8832 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 12:56:15 -0500 Subject: [PATCH 0587/1324] Specialize tm_ slightly. --- src/Facet/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 8175add7e..8347560f8 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -50,7 +50,7 @@ import Fresnel.Lens (Lens, Lens', lens) -- Term containers class HasTerm p where - tm_ :: Lens (p s t) (p s' t') s s' + tm_ :: Lens (p s t) (p s' t) s s' data a ::: b = a ::: b From ca9ae52879173f486f41ede450eebc028587a303 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 12:57:15 -0500 Subject: [PATCH 0588/1324] Define a HasTerm instance for :::. --- src/Facet/Syntax.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 8347560f8..d76a6535a 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -79,6 +79,9 @@ instance Eq2 (:::) where instance Ord2 (:::) where liftCompare2 compareA compareB (a1 ::: b1) (a2 ::: b2) = compareA a1 a2 <> compareB b1 b2 +instance HasTerm (:::) where + tm_ = lens (\ (a ::: _) -> a) (\ (_ ::: t) s' -> s' ::: t) + tm :: a ::: b -> a tm (a ::: _) = a From a698f7cfa52ddfba8f03ebafb01b3a2146c6a3b8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 12:58:33 -0500 Subject: [PATCH 0589/1324] Generalize tm to any HasTerm instance. --- src/Facet/Syntax.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index d76a6535a..667c4a2b0 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -4,8 +4,8 @@ module Facet.Syntax ( -- * Term containers HasTerm(..) -, (:::)(..) , tm +, (:::)(..) , _tm , ty , _ty @@ -45,6 +45,7 @@ import Data.Text (Text) import Facet.Name import Facet.Snoc import Facet.Span +import Fresnel.Getter ((^.)) import Fresnel.Lens (Lens, Lens', lens) -- Term containers @@ -52,6 +53,9 @@ import Fresnel.Lens (Lens, Lens', lens) class HasTerm p where tm_ :: Lens (p s t) (p s' t) s s' +tm :: HasTerm p => a `p` b -> a +tm c = c^.tm_ + data a ::: b = a ::: b deriving (Eq, Foldable, Functor, Ord, Show, Traversable) @@ -82,9 +86,6 @@ instance Ord2 (:::) where instance HasTerm (:::) where tm_ = lens (\ (a ::: _) -> a) (\ (_ ::: t) s' -> s' ::: t) -tm :: a ::: b -> a -tm (a ::: _) = a - _tm :: Lens (s ::: t) (s' ::: t) s s' _tm = lens tm (\ (_ ::: t) s' -> s' ::: t) From f216ff8f1d5d9a3800bc50d0266d83f815bbea8d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 12:59:28 -0500 Subject: [PATCH 0590/1324] :fire: _tm. --- src/Facet/Elab/Term.hs | 2 +- src/Facet/Syntax.hs | 4 ---- 2 files changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index c9a2b0f30..f720c66f1 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -348,7 +348,7 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os -- FIXME: check for redundant naming let elabScope :: (Has (State Module) sig m, Monoid a) => Name -> Prism' Submodule a -> Kind -> Kind <==: ReaderC Module m b -> (b -> m a) -> m () - elabScope dname p _K elab ret = letrec (scope_.decls_) dname (_DSubmodule._tm.p) (DSubmodule (review p mempty) _K) (runModule (elab <==: _K) >>= ret) + elabScope dname p _K elab ret = letrec (scope_.decls_) dname (_DSubmodule.tm_.p) (DSubmodule (review p mempty) _K) (runModule (elab <==: _K) >>= ret) -- elaborate all the types first es <- for ds $ \ (S.Ann _ _ (dname, S.Ann _ _ def)) -> case def of diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 667c4a2b0..73478cebe 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -6,7 +6,6 @@ module Facet.Syntax HasTerm(..) , tm , (:::)(..) -, _tm , ty , _ty , (:=:)(..) @@ -86,9 +85,6 @@ instance Ord2 (:::) where instance HasTerm (:::) where tm_ = lens (\ (a ::: _) -> a) (\ (_ ::: t) s' -> s' ::: t) -_tm :: Lens (s ::: t) (s' ::: t) s s' -_tm = lens tm (\ (_ ::: t) s' -> s' ::: t) - ty :: a ::: b -> b ty (_ ::: b) = b From 06298040a4004bdbd5671bb0f88e63688d039d68 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 13:00:28 -0500 Subject: [PATCH 0591/1324] Define a HasTerm instance for :=:. --- src/Facet/Syntax.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 73478cebe..07a1a3476 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -106,6 +106,9 @@ instance Bifunctor (:=:) where instance Bitraversable (:=:) where bitraverse f g (a :=: b) = (:=:) <$> f a <*> g b +instance HasTerm (:=:) where + tm_ = lens (\ (a :=: _) -> a) (\ (_ :=: t) s' -> s' :=: t) + nm :: a :=: b -> a nm (a :=: _) = a From 495e0bac1030a1d96f195288d3a6711ae34ec862 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 13:01:25 -0500 Subject: [PATCH 0592/1324] Define a HasTerm instance for :@. --- src/Facet/Syntax.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 07a1a3476..0324eba2f 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -130,6 +130,9 @@ instance Bifunctor (:@) where instance Bitraversable (:@) where bitraverse f g (a :@ b) = (:@) <$> f a <*> g b +instance HasTerm (:@) where + tm_ = lens (\ (a :@ _) -> a) (\ (_ :@ t) s' -> s' :@ t) + qty :: p :@ q -> q qty (_ :@ q) = q From 3ca7176d17f22b982581429012cfada755bc1029 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 31 Jan 2022 14:38:32 -0500 Subject: [PATCH 0593/1324] Simplify tm. --- src/Facet/Syntax.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 0324eba2f..e1b32cca6 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -44,7 +44,7 @@ import Data.Text (Text) import Facet.Name import Facet.Snoc import Facet.Span -import Fresnel.Getter ((^.)) +import Fresnel.Getter (view) import Fresnel.Lens (Lens, Lens', lens) -- Term containers @@ -53,7 +53,7 @@ class HasTerm p where tm_ :: Lens (p s t) (p s' t) s s' tm :: HasTerm p => a `p` b -> a -tm c = c^.tm_ +tm = view tm_ data a ::: b = a ::: b From 5bea10505e06247ef74cbaa9fc92f913e1595247 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 1 Feb 2022 19:37:01 -0500 Subject: [PATCH 0594/1324] Use the natural transformation syntax. --- src/Facet/Sequent/Class.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 419fc7ddb..9495d80fe 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -20,7 +20,7 @@ import Control.Applicative (liftA2) import Data.Text (Text) import Facet.Functor.Compose as C import Facet.Name (Level, RName) -import Facet.Syntax (Var) +import Facet.Syntax (Var, type (~>)) -- * Term abstraction @@ -50,17 +50,17 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma µRA :: (Sequent t c d, Applicative i, Applicative m) - => (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) + => (forall j . Applicative j => (i ~> j) -> j c -> m (j d)) -> m (i t) µRA = binder µR -funRA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j t))-> m (i t) +funRA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (i ~> j) -> j t -> m (j t))-> m (i t) funRA = binder funR µLA :: (Sequent t c d, Applicative i, Applicative m) - => (forall j . Applicative j => (forall x . i x -> j x) -> j t -> m (j d)) + => (forall j . Applicative j => (i ~> j) -> j t -> m (j d)) -> m (i c) µLA = binder µL @@ -80,7 +80,7 @@ sumLA cs = runC (sumL <$> traverse (\ (C.Clause c) -> C (binder id c)) cs) prdLA :: (Sequent t c d, Applicative i, Applicative m) => Int - -> (forall j . Applicative j => (forall x . i x -> j x) -> j [t] -> m (j d)) + -> (forall j . Applicative j => (i ~> j) -> j [t] -> m (j d)) -> m (i c) prdLA i = binder (prdL i) From 69f4df4a53a4218ab2199247213e27bde228723c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 6 Feb 2022 03:47:43 -0500 Subject: [PATCH 0595/1324] Weaken a constraint on findMaybeM. --- src/Facet/Elab/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index f720c66f1..7901b4ed2 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -416,7 +416,7 @@ require req = do Nothing -> missingInterface i Just _ -> pure () -findMaybeM :: (Foldable t, Monad m) => (a -> m (Maybe b)) -> t a -> m (Maybe b) +findMaybeM :: (Foldable t, Applicative m) => (a -> m (Maybe b)) -> t a -> m (Maybe b) findMaybeM p = getAp . fmap getFirst . foldMap (Ap . fmap First . p) From 160f6422bb085e7001ac38cd813c414885a43a9a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 6 Feb 2022 03:47:55 -0500 Subject: [PATCH 0596/1324] Rename findMaybeM to findMaybeA. --- src/Facet/Elab/Term.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 7901b4ed2..975f13650 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -412,12 +412,12 @@ provide sig m = do require :: (HasCallStack, Has (Throw Err) sig m) => Signature Type -> Elab m () require req = do prv <- view sig_ - for_ (interfaces req) $ \ i -> findMaybeM (findMaybeM (runUnifyMaybe . unifyInterface i) . interfaces) prv >>= \case + for_ (interfaces req) $ \ i -> findMaybeA (findMaybeA (runUnifyMaybe . unifyInterface i) . interfaces) prv >>= \case Nothing -> missingInterface i Just _ -> pure () -findMaybeM :: (Foldable t, Applicative m) => (a -> m (Maybe b)) -> t a -> m (Maybe b) -findMaybeM p = getAp . fmap getFirst . foldMap (Ap . fmap First . p) +findMaybeA :: (Foldable t, Applicative m) => (a -> m (Maybe b)) -> t a -> m (Maybe b) +findMaybeA p = getAp . fmap getFirst . foldMap (Ap . fmap First . p) -- Judgements From 24a3d25ad4b397f202bda080d36d6c77b1e5c078 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 6 Feb 2022 03:53:19 -0500 Subject: [PATCH 0597/1324] Align. --- src/Facet/Elab/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 975f13650..d19237117 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -283,7 +283,7 @@ abstractTerm body = go Nil Nil T.Arrow n q _A _B -> do d <- depth check (lam [(patternForArgType _A (fromMaybe __ n), go ts (fs :> \ d' -> Var (Free (LName (toIndexed d' (getUsed d)) (fromMaybe __ n)))))] ::: T.Arrow n q _A _B) - _T -> do + _T -> do d <- depth pure $ body (TX.Var . Free . Right . toIndexed d <$> ts) (fs <*> pure d) From 236694cc10c7c6f99d86f1f10d9f43b29ae7c3ce Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 6 Feb 2022 04:06:52 -0500 Subject: [PATCH 0598/1324] Elaborate globals to sequents. --- src/Facet/Elab/Term.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index d19237117..918e7ad21 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -6,6 +6,7 @@ module Facet.Elab.Term , as -- * Term combinators , global +, globalS , var , tlam , lam @@ -112,6 +113,10 @@ as (m ::: _T) = do global :: Algebra sig m => RName ::: Type -> Elab m (Term :==> Type) global (q ::: _T) = (\ (v ::: _T) -> v :==> _T) <$> instantiate const (Var (Global q) ::: _T) +-- FIXME: we’re instantiating when inspecting types in the REPL. +globalS :: (Algebra sig m, SQ.Sequent t c d) => RName ::: Type -> Elab m (t :==> Type) +globalS (q ::: _T) = (\ (v ::: _T) -> v :==> _T) <$> instantiate const (SQ.var (Global q) ::: _T) + -- FIXME: do we need to instantiate here to deal with rank-n applications? -- FIXME: effect ops not in the sig are reported as not in scope -- FIXME: effect ops in the sig are available whether or not they’re in scope From cec604595281448f51681cfc62265873c1b8e8f2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 6 Feb 2022 04:45:34 -0500 Subject: [PATCH 0599/1324] Align. --- src/Facet/Elab/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 918e7ad21..0c17ba62d 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -123,7 +123,7 @@ globalS (q ::: _T) = (\ (v ::: _T) -> v :==> _T) <$> instantiate const (SQ.var ( var :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (Term :==> Type) var n = views context_ (lookupInContext n) >>= \case [(n', Right (q, _T))] -> use n' q $> (Var (Free n') :==> _T) - _ -> resolveQ n >>= \case + _ -> resolveQ n >>= \case n :=: DTerm _ _T -> global (n ::: _T) _ :=: _ -> freeVariable n From a4d0499932465e702455f23f74e53736cceadac8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 6 Feb 2022 04:52:08 -0500 Subject: [PATCH 0600/1324] Elaborate variables to sequents. --- src/Facet/Elab/Term.hs | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 0c17ba62d..c14949cf6 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -8,6 +8,7 @@ module Facet.Elab.Term , global , globalS , var +, varS , tlam , lam , lamS @@ -55,7 +56,7 @@ import Data.Monoid (Ap(..), First(..)) import qualified Data.Set as Set import Data.Text (Text) import Data.Traversable (for, mapAccumL) -import Facet.Context (toEnv) +import Facet.Context (level, toEnv) import Facet.Effect.Write import Facet.Elab import Facet.Elab.Type hiding (switch) @@ -127,6 +128,19 @@ var n = views context_ (lookupInContext n) >>= \case n :=: DTerm _ _T -> global (n ::: _T) _ :=: _ -> freeVariable n +-- FIXME: do we need to instantiate here to deal with rank-n applications? +-- FIXME: effect ops not in the sig are reported as not in scope +-- FIXME: effect ops in the sig are available whether or not they’re in scope +varS :: (HasCallStack, Has (Throw Err) sig m, SQ.Sequent t c d) => QName -> Elab m (t :==> Type) +varS n = views context_ (lookupInContext n) >>= \case + [(n', Right (q, _T))] -> do + use n' q + d <- views context_ level + pure (SQ.var (Free (toLeveled d (ident n'))) :==> _T) + _ -> resolveQ n >>= \case + n :=: DTerm _ _T -> globalS (n ::: _T) + _ :=: _ -> freeVariable n + hole :: (HasCallStack, Has (Throw Err) sig m) => Name -> Type <==: Elab m a hole n = Check $ \ _T -> withFrozenCallStack $ err $ Hole n (CT _T) From f596270b06dc30bf2547a99c41682c34fad5fe17 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 6 Feb 2022 09:51:02 -0500 Subject: [PATCH 0601/1324] Define an effectful var constructor. --- src/Facet/Sequent/Class.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 9495d80fe..d9f84c9fe 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -3,6 +3,7 @@ module Facet.Sequent.Class ( -- * Sequent abstraction Sequent(..) -- * Effectful abstractions +, varA , µRA , C.Clause(..) , funRA @@ -48,6 +49,9 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma -- * Effectful abstractions +varA :: (Sequent t c d, Applicative i, Applicative m) => Var Level -> m (i t) +varA v = pure (pure (var v)) + µRA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (i ~> j) -> j c -> m (j d)) From 98e200d5fc55dccd591aba77068c451bc535cec8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 6 Feb 2022 09:52:29 -0500 Subject: [PATCH 0602/1324] Define an effectful covar constructor. --- src/Facet/Sequent/Class.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index d9f84c9fe..1466e2f95 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -7,6 +7,7 @@ module Facet.Sequent.Class , µRA , C.Clause(..) , funRA +, covarA , µLA , funLA , sumLA @@ -62,6 +63,9 @@ funRA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicativ funRA = binder funR +covarA :: (Sequent t c d, Applicative i, Applicative m) => Var Level -> m (i c) +covarA v = pure (pure (covar v)) + µLA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (i ~> j) -> j t -> m (j d)) From 178477a24485d1a4d1c6c9d72f161c267d9cc99a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 6 Feb 2022 09:54:33 -0500 Subject: [PATCH 0603/1324] Lift globalS and varS into scoped contexts. --- src/Facet/Elab/Term.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index c14949cf6..cccbb37ed 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -115,8 +115,10 @@ global :: Algebra sig m => RName ::: Type -> Elab m (Term :==> Type) global (q ::: _T) = (\ (v ::: _T) -> v :==> _T) <$> instantiate const (Var (Global q) ::: _T) -- FIXME: we’re instantiating when inspecting types in the REPL. -globalS :: (Algebra sig m, SQ.Sequent t c d) => RName ::: Type -> Elab m (t :==> Type) -globalS (q ::: _T) = (\ (v ::: _T) -> v :==> _T) <$> instantiate const (SQ.var (Global q) ::: _T) +globalS :: (Algebra sig m, SQ.Sequent t c d, Applicative i) => RName ::: Type -> Elab m (i t :==> Type) +globalS (q ::: _T) = do + v <- SQ.varA (Global q) + (\ (v ::: _T) -> v :==> _T) <$> instantiate const (v ::: _T) -- FIXME: do we need to instantiate here to deal with rank-n applications? -- FIXME: effect ops not in the sig are reported as not in scope @@ -131,12 +133,12 @@ var n = views context_ (lookupInContext n) >>= \case -- FIXME: do we need to instantiate here to deal with rank-n applications? -- FIXME: effect ops not in the sig are reported as not in scope -- FIXME: effect ops in the sig are available whether or not they’re in scope -varS :: (HasCallStack, Has (Throw Err) sig m, SQ.Sequent t c d) => QName -> Elab m (t :==> Type) +varS :: (HasCallStack, Has (Throw Err) sig m, SQ.Sequent t c d, Applicative i) => QName -> Elab m (i t :==> Type) varS n = views context_ (lookupInContext n) >>= \case [(n', Right (q, _T))] -> do use n' q d <- views context_ level - pure (SQ.var (Free (toLeveled d (ident n'))) :==> _T) + (:==> _T) <$> SQ.varA (Free (toLeveled d (ident n'))) _ -> resolveQ n >>= \case n :=: DTerm _ _T -> globalS (n ::: _T) _ :=: _ -> freeVariable n From 05d53f6b5bf8ddb84a99d9086dfadc766cf4dfdb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 6 Feb 2022 09:56:27 -0500 Subject: [PATCH 0604/1324] Define an effectful string constructor. --- src/Facet/Sequent/Class.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 1466e2f95..b052b5e97 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -7,6 +7,7 @@ module Facet.Sequent.Class , µRA , C.Clause(..) , funRA +, stringRA , covarA , µLA , funLA @@ -62,6 +63,9 @@ varA v = pure (pure (var v)) funRA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (i ~> j) -> j t -> m (j t))-> m (i t) funRA = binder funR +stringRA :: (Sequent t c d, Applicative i, Applicative m) => Text -> m (i t) +stringRA = pure . pure . stringR + covarA :: (Sequent t c d, Applicative i, Applicative m) => Var Level -> m (i c) covarA v = pure (pure (covar v)) From 7759fb041e42ca578e36ab9c866a3b8318f5b496 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 6 Feb 2022 09:56:57 -0500 Subject: [PATCH 0605/1324] Lift stringS into a scoped context. --- src/Facet/Elab/Term.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index cccbb37ed..79008e51f 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -185,8 +185,8 @@ appS f a = do string :: Text -> Elab m (Term :==> Type) string s = pure $ E.String s :==> T.String -stringS :: SQ.Sequent t c d => Text -> Elab m (t :==> Type) -stringS s = pure $ SQ.stringR s :==> T.String +stringS :: (SQ.Sequent t c d, Applicative i) => Text -> Elab m (i t :==> Type) +stringS s = (:==> T.String) <$> SQ.stringRA s let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Type)) -> Elab m (Term :==> Type) -> Type <==: Elab m Term -> Type <==: Elab m Term From b318f24ebe7244e00a4e9aa3cbc44fcf8afa4402 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 6 Feb 2022 10:04:35 -0500 Subject: [PATCH 0606/1324] Define a lifted constructor for synthesizing. --- src/Facet/Functor/Synth.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Facet/Functor/Synth.hs b/src/Facet/Functor/Synth.hs index 175e9280e..53be9f301 100644 --- a/src/Facet/Functor/Synth.hs +++ b/src/Facet/Functor/Synth.hs @@ -1,6 +1,8 @@ module Facet.Functor.Synth ( -- * Synth judgement (:==>)(..) + -- * Construction +, (==>) -- * Elimination , proof , prop @@ -27,6 +29,12 @@ instance Bitraversable (:==>) where bitraverse f g (a :==> _T) = (:==>) <$> f a <*> g _T +-- Construction + +(==>) :: Applicative m => m (i tm) -> m ty -> m (i tm :==> ty) +tm ==> ty = (:==>) <$> tm <*> ty + + -- Elimination proof :: a :==> b -> a From 684f82cdee48e488358b39fb4ef7634dc0836058 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 6 Feb 2022 10:06:21 -0500 Subject: [PATCH 0607/1324] Synthesize conveniently. --- src/Facet/Elab/Term.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 79008e51f..0c860015e 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -138,7 +138,7 @@ varS n = views context_ (lookupInContext n) >>= \case [(n', Right (q, _T))] -> do use n' q d <- views context_ level - (:==> _T) <$> SQ.varA (Free (toLeveled d (ident n'))) + SQ.varA (Free (toLeveled d (ident n'))) ==> pure _T _ -> resolveQ n >>= \case n :=: DTerm _ _T -> globalS (n ::: _T) _ :=: _ -> freeVariable n @@ -186,7 +186,7 @@ string :: Text -> Elab m (Term :==> Type) string s = pure $ E.String s :==> T.String stringS :: (SQ.Sequent t c d, Applicative i) => Text -> Elab m (i t :==> Type) -stringS s = (:==> T.String) <$> SQ.stringRA s +stringS s = SQ.stringRA s ==> pure T.String let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Type)) -> Elab m (Term :==> Type) -> Type <==: Elab m Term -> Type <==: Elab m Term From c93bf40816b94cc2a187f1471e4d0425c81a7df8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 12 Feb 2022 12:50:10 -0500 Subject: [PATCH 0608/1324] Define a quick spike of pattern coverage. --- src/Facet/Elab/Term.hs | 31 +++++++++++++++++++++++++++++-- 1 file changed, 29 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 0c860015e..0004f5390 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -24,6 +24,8 @@ module Facet.Elab.Term , conP , fieldsP , allP + -- * Pattern compilation +, coverTableau -- * Expression elaboration , synthExpr , checkExpr @@ -43,10 +45,11 @@ module Facet.Elab.Term ) where import Control.Algebra +import Control.Carrier.Empty.Church import Control.Carrier.Reader import Control.Carrier.State.Church +import Control.Carrier.Writer.Church import Control.Effect.Throw -import Control.Effect.Writer (censor) import Data.Bifunctor (first) import Data.Either (partitionEithers) import Data.Foldable @@ -62,7 +65,7 @@ import Facet.Elab import Facet.Elab.Type hiding (switch) import qualified Facet.Elab.Type as Type import Facet.Functor.Check -import Facet.Functor.Compose +import Facet.Functor.Compose hiding (Clause) import Facet.Functor.Synth import Facet.Graph import Facet.Interface @@ -242,6 +245,30 @@ allP n = Bind $ \ _A k -> do k (PVar (n :==> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (T.Comp sig _T))) +-- Pattern compilation + +newtype Clause = Clause { patterns :: [Pattern ()] } + +newtype Tableau = Tableau { clauses :: [Clause] } + +type Ctx = [Type] + +coverTableau :: Tableau -> Ctx -> Bool +coverTableau (Tableau t) c = run (evalState (Tableau t) (execEmpty (go c))) + where + go = \case + [] -> get >>= guard . all (null . patterns) . clauses + ty:tys -> coverClauses ty >>= \ ty' -> go (ty' <> tys) + +coverClauses :: Has Empty sig m => Type -> m [Type] +coverClauses = \case + T.String -> pure [] -- FIXME: check for wildcard/variable patterns + -- FIXME: type patterns to bind type variables? + T.ForAll{} -> pure [] -- FIXME: check for wildcard/variable patterns + T.Arrow{} -> pure [] -- FIXME: check for wildcard/variable patterns + T.Ne{} -> empty + T.Comp{} -> empty -- resolve signature, then treat as effect patterns + -- Expression elaboration synthExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Elab m (Term :==> Type) From f1a0ac25f9499f6acb266d267fa97f7cb1657fab Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 12 Feb 2022 12:53:59 -0500 Subject: [PATCH 0609/1324] Do away with some unnecessary noise. --- src/Facet/Elab/Term.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 0004f5390..eba3aaf32 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -254,14 +254,14 @@ newtype Tableau = Tableau { clauses :: [Clause] } type Ctx = [Type] coverTableau :: Tableau -> Ctx -> Bool -coverTableau (Tableau t) c = run (evalState (Tableau t) (execEmpty (go c))) +coverTableau tableau context = run (execEmpty (go context tableau)) where - go = \case - [] -> get >>= guard . all (null . patterns) . clauses - ty:tys -> coverClauses ty >>= \ ty' -> go (ty' <> tys) + go context tableau = case context of + [] -> guard (all (null . patterns) (clauses tableau)) + ty:tys -> coverClauses ty tableau >>= \ ty' -> go (ty' <> tys) tableau -coverClauses :: Has Empty sig m => Type -> m [Type] -coverClauses = \case +coverClauses :: Has Empty sig m => Type -> Tableau -> m [Type] +coverClauses ty clauses = case ty of T.String -> pure [] -- FIXME: check for wildcard/variable patterns -- FIXME: type patterns to bind type variables? T.ForAll{} -> pure [] -- FIXME: check for wildcard/variable patterns From 45a4dde0d49adfb7db1e72beec1b9798802f3631 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 12 Feb 2022 12:56:03 -0500 Subject: [PATCH 0610/1324] Bump fresnel. --- cabal.project | 2 +- cabal.project.ci | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index d5bcc0435..9b9446ab7 100644 --- a/cabal.project +++ b/cabal.project @@ -4,5 +4,5 @@ tests: True source-repository-package type: git location: https://github.com/robrix/fresnel.git - tag: c56b7dc69d775ce5f1b2cbe9a3204e246f08227a + tag: 573c4a0c7542e9e95a77b833fad7e37d2a31fc4e subdir: fresnel diff --git a/cabal.project.ci b/cabal.project.ci index fc3c9f220..de100ab6c 100644 --- a/cabal.project.ci +++ b/cabal.project.ci @@ -7,5 +7,5 @@ package facet source-repository-package type: git location: https://github.com/robrix/fresnel.git - tag: c56b7dc69d775ce5f1b2cbe9a3204e246f08227a + tag: 573c4a0c7542e9e95a77b833fad7e37d2a31fc4e subdir: fresnel From 2a5ec55ab0096b59ac1e943699009d692fe0ec8d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 12 Feb 2022 13:18:55 -0500 Subject: [PATCH 0611/1324] Check that all clauses match strings. --- src/Facet/Elab/Term.hs | 32 ++++++++++++++++++++++++-------- 1 file changed, 24 insertions(+), 8 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index eba3aaf32..c99c78f09 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -53,6 +53,7 @@ import Control.Effect.Throw import Data.Bifunctor (first) import Data.Either (partitionEithers) import Data.Foldable +import Data.Function ((&)) import Data.Functor import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import Data.Monoid (Ap(..), First(..)) @@ -90,11 +91,13 @@ import Facet.Type.Norm as T hiding (global) import Facet.Unify import Facet.Usage hiding (restrict) import Fresnel.At as At +import Fresnel.Fold (allOf, folded) +import Fresnel.Iso (Iso', coerced) import Fresnel.Ixed import Fresnel.Prism (Prism') import Fresnel.Review (review) -import Fresnel.Setter (Setter') -import Fresnel.Traversal (Traversal') +import Fresnel.Setter (Setter', (%~)) +import Fresnel.Traversal (Traversal', traversed) import GHC.Stack -- General combinators @@ -249,8 +252,14 @@ allP n = Bind $ \ _A k -> do newtype Clause = Clause { patterns :: [Pattern ()] } +patterns_ :: Iso' Clause [Pattern ()] +patterns_ = coerced + newtype Tableau = Tableau { clauses :: [Clause] } +clauses_ :: Iso' Tableau [Clause] +clauses_ = coerced + type Ctx = [Type] coverTableau :: Tableau -> Ctx -> Bool @@ -258,17 +267,24 @@ coverTableau tableau context = run (execEmpty (go context tableau)) where go context tableau = case context of [] -> guard (all (null . patterns) (clauses tableau)) - ty:tys -> coverClauses ty tableau >>= \ ty' -> go (ty' <> tys) tableau + ty:tys -> coverClauses ty tableau >>= \ (ty', tableau') -> go (ty' <> tys) tableau' -coverClauses :: Has Empty sig m => Type -> Tableau -> m [Type] -coverClauses ty clauses = case ty of - T.String -> pure [] -- FIXME: check for wildcard/variable patterns +coverClauses :: Has Empty sig m => Type -> Tableau -> m ([Type], Tableau) +coverClauses ty tableau = case ty of + T.String -> ([], tableau & clauses_.traversed.patterns_ %~ tail) <$ guard (allOf (clauses_.folded.patterns_.folded) isCatchAll tableau) -- FIXME: type patterns to bind type variables? - T.ForAll{} -> pure [] -- FIXME: check for wildcard/variable patterns - T.Arrow{} -> pure [] -- FIXME: check for wildcard/variable patterns + T.ForAll{} -> pure ([], tableau) -- FIXME: check for wildcard/variable patterns + T.Arrow{} -> pure ([], tableau) -- FIXME: check for wildcard/variable patterns T.Ne{} -> empty T.Comp{} -> empty -- resolve signature, then treat as effect patterns +isCatchAll :: Pattern a -> Bool +isCatchAll = \case + PWildcard -> True + PVar _ -> True + _ -> False + + -- Expression elaboration synthExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Elab m (Term :==> Type) From 7c00d5019f7e8a24f1abed5892650e8d3c199e5f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 12 Feb 2022 21:33:57 -0500 Subject: [PATCH 0612/1324] Decompose isCatchAll. --- src/Facet/Elab/Term.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index c99c78f09..b51b72658 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -45,6 +45,7 @@ module Facet.Elab.Term ) where import Control.Algebra +import Control.Applicative (liftA2) import Control.Carrier.Empty.Church import Control.Carrier.Reader import Control.Carrier.State.Church @@ -279,10 +280,14 @@ coverClauses ty tableau = case ty of T.Comp{} -> empty -- resolve signature, then treat as effect patterns isCatchAll :: Pattern a -> Bool -isCatchAll = \case - PWildcard -> True - PVar _ -> True - _ -> False +isCatchAll + = \case{ PWildcard -> True ; _ -> False } + ||| \case{ PVar _ -> True ; _ -> False } + +(|||) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) +(|||) = liftA2 (||) + +infixr 2 ||| -- Expression elaboration From 7b3b9e8550ed22e3197b28a4dd2074c8f8730126 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 12 Feb 2022 21:36:38 -0500 Subject: [PATCH 0613/1324] Factor out checking clause heads. --- src/Facet/Elab/Term.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index b51b72658..0f6468b65 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -272,12 +272,15 @@ coverTableau tableau context = run (execEmpty (go context tableau)) coverClauses :: Has Empty sig m => Type -> Tableau -> m ([Type], Tableau) coverClauses ty tableau = case ty of - T.String -> ([], tableau & clauses_.traversed.patterns_ %~ tail) <$ guard (allOf (clauses_.folded.patterns_.folded) isCatchAll tableau) + T.String -> ([], skip) <$ guard (eachClauseHead isCatchAll) -- FIXME: type patterns to bind type variables? - T.ForAll{} -> pure ([], tableau) -- FIXME: check for wildcard/variable patterns - T.Arrow{} -> pure ([], tableau) -- FIXME: check for wildcard/variable patterns + T.ForAll{} -> ([], skip) <$ guard (eachClauseHead isCatchAll) + T.Arrow{} -> ([], skip) <$ guard (eachClauseHead isCatchAll) T.Ne{} -> empty T.Comp{} -> empty -- resolve signature, then treat as effect patterns + where + eachClauseHead f = allOf (clauses_.folded.patterns_.folded) f tableau + skip = tableau & clauses_.traversed.patterns_ %~ tail isCatchAll :: Pattern a -> Bool isCatchAll From 3264b77e644118a13bb69e1e886bc43ef7ed61ef Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 12 Feb 2022 21:37:15 -0500 Subject: [PATCH 0614/1324] Factor the guard into eachClauseHead. --- src/Facet/Elab/Term.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 0f6468b65..e31f73157 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -272,14 +272,14 @@ coverTableau tableau context = run (execEmpty (go context tableau)) coverClauses :: Has Empty sig m => Type -> Tableau -> m ([Type], Tableau) coverClauses ty tableau = case ty of - T.String -> ([], skip) <$ guard (eachClauseHead isCatchAll) + T.String -> ([], skip) <$ eachClauseHead isCatchAll -- FIXME: type patterns to bind type variables? - T.ForAll{} -> ([], skip) <$ guard (eachClauseHead isCatchAll) - T.Arrow{} -> ([], skip) <$ guard (eachClauseHead isCatchAll) + T.ForAll{} -> ([], skip) <$ eachClauseHead isCatchAll + T.Arrow{} -> ([], skip) <$ eachClauseHead isCatchAll T.Ne{} -> empty T.Comp{} -> empty -- resolve signature, then treat as effect patterns where - eachClauseHead f = allOf (clauses_.folded.patterns_.folded) f tableau + eachClauseHead f = guard (allOf (clauses_.folded.patterns_.folded) f tableau) skip = tableau & clauses_.traversed.patterns_ %~ tail isCatchAll :: Pattern a -> Bool From 63857e3c250d548a509addcf64610e6f2e071819 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 12 Feb 2022 22:01:02 -0500 Subject: [PATCH 0615/1324] Generalize resolveWith. --- src/Facet/Elab.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index f261f70e8..e1c9ecb67 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -113,10 +113,10 @@ instantiate inst = go resolveWith - :: (HasCallStack, Has (Throw Err) sig m) + :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => (forall sig m . Has (Choose :+: Empty) sig m => Name -> Module -> m (RName :=: d)) -> QName - -> Elab m (RName :=: d) + -> m (RName :=: d) resolveWith lookup n = asks (\ StaticContext{ module', graph } -> lookupWith lookup graph module' n) >>= \case [] -> freeVariable n [v] -> pure v From e5e77b0aafb2d0b8f74ffc630b7678cbcdf8521b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 12 Feb 2022 22:01:44 -0500 Subject: [PATCH 0616/1324] Generalize resolveC/Q. --- src/Facet/Elab.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index e1c9ecb67..8a5eaab67 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -122,10 +122,10 @@ resolveWith lookup n = asks (\ StaticContext{ module', graph } -> lookupWith loo [v] -> pure v ds -> ambiguousName n (map (\ (q :=: _) -> q) ds) -resolveC :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (RName :=: Maybe Term ::: Type) +resolveC :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => QName -> m (RName :=: Maybe Term ::: Type) resolveC = resolveWith lookupC -resolveQ :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (RName :=: Def) +resolveQ :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => QName -> m (RName :=: Def) resolveQ = resolveWith lookupD lookupInContext :: Has (Choose :+: Empty) sig m => QName -> Context -> m (LName Index, Either Kind (Quantity, Type)) From 5a52cb6241d45f253386477489d1d5e091e86577 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Feb 2022 00:58:58 -0500 Subject: [PATCH 0617/1324] Initial stab at coverage for datatypes. --- src/Facet/Elab/Term.hs | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index e31f73157..d055553fe 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -47,9 +47,11 @@ module Facet.Elab.Term import Control.Algebra import Control.Applicative (liftA2) import Control.Carrier.Empty.Church +import Control.Carrier.NonDet.Church hiding (Alternative(..), guard) import Control.Carrier.Reader import Control.Carrier.State.Church import Control.Carrier.Writer.Church +import Control.Effect.Choose import Control.Effect.Throw import Data.Bifunctor (first) import Data.Either (partitionEithers) @@ -263,24 +265,35 @@ clauses_ = coerced type Ctx = [Type] -coverTableau :: Tableau -> Ctx -> Bool -coverTableau tableau context = run (execEmpty (go context tableau)) +coverTableau :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> m Bool +coverTableau tableau context = runNonDet (liftA2 (&&)) (const (pure True)) (pure False) (go context tableau) where go context tableau = case context of [] -> guard (all (null . patterns) (clauses tableau)) ty:tys -> coverClauses ty tableau >>= \ (ty', tableau') -> go (ty' <> tys) tableau' -coverClauses :: Has Empty sig m => Type -> Tableau -> m ([Type], Tableau) +coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Type -> Tableau -> m ([Type], Tableau) coverClauses ty tableau = case ty of T.String -> ([], skip) <$ eachClauseHead isCatchAll -- FIXME: type patterns to bind type variables? T.ForAll{} -> ([], skip) <$ eachClauseHead isCatchAll T.Arrow{} -> ([], skip) <$ eachClauseHead isCatchAll - T.Ne{} -> empty + T.Ne h _ -> case h of + Global n -> resolveQ (toQ n) >>= \case + _ :=: DSubmodule (SData scope) _ -> decomposeSum (scopeToList scope) + _ -> empty + _ -> empty T.Comp{} -> empty -- resolve signature, then treat as effect patterns where eachClauseHead f = guard (allOf (clauses_.folded.patterns_.folded) f tableau) skip = tableau & clauses_.traversed.patterns_ %~ tail + decomposeSum = \case + [] -> ([], skip) <$ eachClauseHead isCatchAll + [x] -> decomposeProduct x + -- FIXME: construct binary tree of eliminations + x:xs -> decomposeProduct x <|> decomposeSum xs + decomposeProduct = \case + _ -> empty isCatchAll :: Pattern a -> Bool isCatchAll From 75549efbe7fc0aca40c51541a9d002570eb77716 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Feb 2022 01:01:06 -0500 Subject: [PATCH 0618/1324] Rename skip to skipped. --- src/Facet/Elab/Term.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index d055553fe..b0aec257c 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -274,10 +274,10 @@ coverTableau tableau context = runNonDet (liftA2 (&&)) (const (pure True)) (pure coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Type -> Tableau -> m ([Type], Tableau) coverClauses ty tableau = case ty of - T.String -> ([], skip) <$ eachClauseHead isCatchAll + T.String -> ([], skipped) <$ eachClauseHead isCatchAll -- FIXME: type patterns to bind type variables? - T.ForAll{} -> ([], skip) <$ eachClauseHead isCatchAll - T.Arrow{} -> ([], skip) <$ eachClauseHead isCatchAll + T.ForAll{} -> ([], skipped) <$ eachClauseHead isCatchAll + T.Arrow{} -> ([], skipped) <$ eachClauseHead isCatchAll T.Ne h _ -> case h of Global n -> resolveQ (toQ n) >>= \case _ :=: DSubmodule (SData scope) _ -> decomposeSum (scopeToList scope) @@ -286,9 +286,9 @@ coverClauses ty tableau = case ty of T.Comp{} -> empty -- resolve signature, then treat as effect patterns where eachClauseHead f = guard (allOf (clauses_.folded.patterns_.folded) f tableau) - skip = tableau & clauses_.traversed.patterns_ %~ tail + skipped = tableau & clauses_.traversed.patterns_ %~ tail decomposeSum = \case - [] -> ([], skip) <$ eachClauseHead isCatchAll + [] -> ([], skipped) <$ eachClauseHead isCatchAll [x] -> decomposeProduct x -- FIXME: construct binary tree of eliminations x:xs -> decomposeProduct x <|> decomposeSum xs From 5747c248ce600702d19d2dc0e6702a8ac5b02472 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Feb 2022 01:05:26 -0500 Subject: [PATCH 0619/1324] Manage the tableau in a State effect. --- src/Facet/Elab/Term.hs | 55 +++++++++++++++++++++--------------------- 1 file changed, 28 insertions(+), 27 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index b0aec257c..dde89f410 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -266,34 +266,35 @@ clauses_ = coerced type Ctx = [Type] coverTableau :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> m Bool -coverTableau tableau context = runNonDet (liftA2 (&&)) (const (pure True)) (pure False) (go context tableau) +coverTableau tableau context = runNonDet (liftA2 (&&)) (const (pure True)) (pure False) (evalState tableau (go context)) where - go context tableau = case context of - [] -> guard (all (null . patterns) (clauses tableau)) - ty:tys -> coverClauses ty tableau >>= \ (ty', tableau') -> go (ty' <> tys) tableau' - -coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Type -> Tableau -> m ([Type], Tableau) -coverClauses ty tableau = case ty of - T.String -> ([], skipped) <$ eachClauseHead isCatchAll - -- FIXME: type patterns to bind type variables? - T.ForAll{} -> ([], skipped) <$ eachClauseHead isCatchAll - T.Arrow{} -> ([], skipped) <$ eachClauseHead isCatchAll - T.Ne h _ -> case h of - Global n -> resolveQ (toQ n) >>= \case - _ :=: DSubmodule (SData scope) _ -> decomposeSum (scopeToList scope) - _ -> empty - _ -> empty - T.Comp{} -> empty -- resolve signature, then treat as effect patterns - where - eachClauseHead f = guard (allOf (clauses_.folded.patterns_.folded) f tableau) - skipped = tableau & clauses_.traversed.patterns_ %~ tail - decomposeSum = \case - [] -> ([], skipped) <$ eachClauseHead isCatchAll - [x] -> decomposeProduct x - -- FIXME: construct binary tree of eliminations - x:xs -> decomposeProduct x <|> decomposeSum xs - decomposeProduct = \case - _ -> empty + go context = case context of + [] -> get >>= \ tableau -> guard (all (null . patterns) (clauses tableau)) + ty:tys -> coverClauses ty >>= \ ty' -> go (ty' <> tys) + +coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (State Tableau) sig m, Has (Throw Err) sig m) => Type -> m [Type] +coverClauses ty = do + tableau <- get + let skipped = tableau & clauses_.traversed.patterns_ %~ tail + eachClauseHead f = guard (allOf (clauses_.folded.patterns_.folded) f tableau) + decomposeSum = \case + [] -> [] <$ eachClauseHead isCatchAll <* put skipped + [x] -> decomposeProduct x + -- FIXME: construct binary tree of eliminations + x:xs -> decomposeProduct x <|> decomposeSum xs + decomposeProduct = \case + _ -> empty + case ty of + T.String -> [] <$ eachClauseHead isCatchAll <* put skipped + -- FIXME: type patterns to bind type variables? + T.ForAll{} -> [] <$ eachClauseHead isCatchAll <* put skipped + T.Arrow{} -> [] <$ eachClauseHead isCatchAll <* put skipped + T.Ne h _ -> case h of + Global n -> resolveQ (toQ n) >>= \case + _ :=: DSubmodule (SData scope) _ -> decomposeSum (scopeToList scope) + _ -> empty + _ -> empty + T.Comp{} -> empty -- resolve signature, then treat as effect patterns isCatchAll :: Pattern a -> Bool isCatchAll From d508967bcb2914ffe08a83c20cb95a179897d121 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Feb 2022 03:06:52 -0500 Subject: [PATCH 0620/1324] Define an optic for scopes and lists. --- src/Facet/Module.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index b8fd75c9b..a75ae56a4 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -10,6 +10,7 @@ module Facet.Module , lookupD , Scope(..) , decls_ +, toList_ , scopeFromList , scopeToList , lookupScope @@ -42,7 +43,7 @@ import Facet.Syntax import Facet.Term.Expr import Facet.Type.Norm import Fresnel.Fold (preview) -import Fresnel.Iso (coerced) +import Fresnel.Iso (Iso, coerced, iso) import Fresnel.Lens (Lens, Lens', lens) import Fresnel.Prism import Fresnel.Review (review) @@ -105,6 +106,9 @@ newtype Scope a = Scope { decls :: Map.Map Name a } decls_ :: Lens (Scope a) (Scope b) (Map.Map Name a) (Map.Map Name b) decls_ = coerced +toList_ :: Iso (Scope a) (Scope b) [Name :=: a] [Name :=: b] +toList_ = iso scopeToList scopeFromList + scopeFromList :: [Name :=: a] -> Scope a scopeFromList = Scope . Map.fromList . map (\ (n :=: v) -> (n, v)) From 9fd24a06ba95014253e96f8ea221510e02359ded Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Feb 2022 03:08:30 -0500 Subject: [PATCH 0621/1324] Strengthen decls_ to an Iso. --- src/Facet/Module.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index a75ae56a4..4738d9bc0 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -44,7 +44,7 @@ import Facet.Term.Expr import Facet.Type.Norm import Fresnel.Fold (preview) import Fresnel.Iso (Iso, coerced, iso) -import Fresnel.Lens (Lens, Lens', lens) +import Fresnel.Lens (Lens', lens) import Fresnel.Prism import Fresnel.Review (review) @@ -103,7 +103,7 @@ lookupD n Module{ name, scope } = maybe empty (pure . first (name:.:)) (lookupSc newtype Scope a = Scope { decls :: Map.Map Name a } deriving (Monoid, Semigroup) -decls_ :: Lens (Scope a) (Scope b) (Map.Map Name a) (Map.Map Name b) +decls_ :: Iso (Scope a) (Scope b) (Map.Map Name a) (Map.Map Name b) decls_ = coerced toList_ :: Iso (Scope a) (Scope b) [Name :=: a] [Name :=: b] From ec4685a27b6f365bd1e86076e9381bdacf9b1d68 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Feb 2022 03:15:41 -0500 Subject: [PATCH 0622/1324] Define an Iso for constructing and extracting data from pair syntax types. --- src/Facet/Syntax.hs | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index e1b32cca6..0b300fcaf 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -3,7 +3,8 @@ {-# LANGUAGE UndecidableInstances #-} module Facet.Syntax ( -- * Term containers - HasTerm(..) + IsPair(..) +, HasTerm(..) , tm , (:::)(..) , ty @@ -45,10 +46,15 @@ import Facet.Name import Facet.Snoc import Facet.Span import Fresnel.Getter (view) +import Fresnel.Iso (Iso, iso) import Fresnel.Lens (Lens, Lens', lens) -- Term containers +class IsPair p where + pair_ :: Iso (p a b) (p a' b') (a, b) (a', b') + + class HasTerm p where tm_ :: Lens (p s t) (p s' t) s s' @@ -82,6 +88,9 @@ instance Eq2 (:::) where instance Ord2 (:::) where liftCompare2 compareA compareB (a1 ::: b1) (a2 ::: b2) = compareA a1 a2 <> compareB b1 b2 +instance IsPair (:::) where + pair_ = iso ((,) <$> tm <*> ty) (uncurry (:::)) + instance HasTerm (:::) where tm_ = lens (\ (a ::: _) -> a) (\ (_ ::: t) s' -> s' ::: t) @@ -106,6 +115,9 @@ instance Bifunctor (:=:) where instance Bitraversable (:=:) where bitraverse f g (a :=: b) = (:=:) <$> f a <*> g b +instance IsPair (:=:) where + pair_ = iso ((,) <$> nm <*> def) (uncurry (:=:)) + instance HasTerm (:=:) where tm_ = lens (\ (a :=: _) -> a) (\ (_ :=: t) s' -> s' :=: t) @@ -130,6 +142,9 @@ instance Bifunctor (:@) where instance Bitraversable (:@) where bitraverse f g (a :@ b) = (:@) <$> f a <*> g b +instance IsPair (:@) where + pair_ = iso ((,) <$> tm <*> qty) (uncurry (:@)) + instance HasTerm (:@) where tm_ = lens (\ (a :@ _) -> a) (\ (_ :@ t) s' -> s' :@ t) From abf82e8de3edf663b9e16019899023fb80cafdd9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Feb 2022 03:18:01 -0500 Subject: [PATCH 0623/1324] Order scopes. --- src/Facet/Module.hs | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 4738d9bc0..9639075b9 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -43,7 +43,8 @@ import Facet.Syntax import Facet.Term.Expr import Facet.Type.Norm import Fresnel.Fold (preview) -import Fresnel.Iso (Iso, coerced, iso) +import Fresnel.Getter (view) +import Fresnel.Iso (Iso, coerced, fmapping, iso) import Fresnel.Lens (Lens', lens) import Fresnel.Prism import Fresnel.Review (review) @@ -85,14 +86,14 @@ foldMapC f = getChoosing #. foldMap (Choosing #. f) lookupC :: Has (Choose :+: Empty) sig m => Name -> Module -> m (RName :=: Maybe Term ::: Type) -lookupC n Module{ name, scope } = foldMapC matchDef (decls scope) +lookupC n Module{ name, scope } = foldMapC matchDef (map def (decls scope)) where matchDef = matchTerm <=< lookupScope n . tm <=< unDData matchTerm (n :=: d) = (name :.: n :=:) <$> unDTerm d -- | Look up effect operations. lookupE :: Has (Choose :+: Empty) sig m => Name -> Module -> m (RName :=: Def) -lookupE n Module{ name, scope } = foldMapC matchDef (decls scope) +lookupE n Module{ name, scope } = foldMapC matchDef (map def (decls scope)) where matchDef = fmap (bimap (name:.:) (DTerm Nothing)) . lookupScope n . tm <=< unDInterface @@ -100,23 +101,23 @@ lookupD :: Has Empty sig m => Name -> Module -> m (RName :=: Def) lookupD n Module{ name, scope } = maybe empty (pure . first (name:.:)) (lookupScope n scope) -newtype Scope a = Scope { decls :: Map.Map Name a } +newtype Scope a = Scope { decls :: [Name :=: a] } deriving (Monoid, Semigroup) decls_ :: Iso (Scope a) (Scope b) (Map.Map Name a) (Map.Map Name b) -decls_ = coerced +decls_ = toList_.fmapping pair_.iso Map.fromList Map.toList toList_ :: Iso (Scope a) (Scope b) [Name :=: a] [Name :=: b] -toList_ = iso scopeToList scopeFromList +toList_ = coerced scopeFromList :: [Name :=: a] -> Scope a -scopeFromList = Scope . Map.fromList . map (\ (n :=: v) -> (n, v)) +scopeFromList = review toList_ scopeToList :: Scope a -> [Name :=: a] -scopeToList = map (uncurry (:=:)) . Map.toList . decls +scopeToList = view toList_ lookupScope :: Has Empty sig m => Name -> Scope a -> m (Name :=: a) -lookupScope n (Scope ds) = maybe empty (pure . (n :=:)) (Map.lookup n ds) +lookupScope n (Scope ds) = maybe empty (pure . (n :=:)) (lookup n (map (\ (n :=: a) -> (n, a)) ds)) newtype Import = Import { name :: MName } From 24784beecb0f0cb19e75725ecfc35890adecb0d1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Feb 2022 09:40:21 -0500 Subject: [PATCH 0624/1324] Extract (most of) eachClauseHead. --- src/Facet/Elab/Term.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index dde89f410..f8279e44a 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -276,19 +276,18 @@ coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader El coverClauses ty = do tableau <- get let skipped = tableau & clauses_.traversed.patterns_ %~ tail - eachClauseHead f = guard (allOf (clauses_.folded.patterns_.folded) f tableau) decomposeSum = \case - [] -> [] <$ eachClauseHead isCatchAll <* put skipped + [] -> [] <$ guard (eachClauseHead isCatchAll tableau) <* put skipped [x] -> decomposeProduct x -- FIXME: construct binary tree of eliminations x:xs -> decomposeProduct x <|> decomposeSum xs decomposeProduct = \case _ -> empty case ty of - T.String -> [] <$ eachClauseHead isCatchAll <* put skipped + T.String -> [] <$ guard (eachClauseHead isCatchAll tableau) <* put skipped -- FIXME: type patterns to bind type variables? - T.ForAll{} -> [] <$ eachClauseHead isCatchAll <* put skipped - T.Arrow{} -> [] <$ eachClauseHead isCatchAll <* put skipped + T.ForAll{} -> [] <$ guard (eachClauseHead isCatchAll tableau) <* put skipped + T.Arrow{} -> [] <$ guard (eachClauseHead isCatchAll tableau) <* put skipped T.Ne h _ -> case h of Global n -> resolveQ (toQ n) >>= \case _ :=: DSubmodule (SData scope) _ -> decomposeSum (scopeToList scope) @@ -296,6 +295,9 @@ coverClauses ty = do _ -> empty T.Comp{} -> empty -- resolve signature, then treat as effect patterns +eachClauseHead :: (Pattern () -> Bool) -> Tableau -> Bool +eachClauseHead = allOf (clauses_.folded.patterns_.folded) + isCatchAll :: Pattern a -> Bool isCatchAll = \case{ PWildcard -> True ; _ -> False } From 45b4534f8c9f508012c47f5cc5446edd03472915 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Feb 2022 09:41:04 -0500 Subject: [PATCH 0625/1324] Use eachClauseHead to end the loop. --- src/Facet/Elab/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index f8279e44a..9056eecf1 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -269,7 +269,7 @@ coverTableau :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Stati coverTableau tableau context = runNonDet (liftA2 (&&)) (const (pure True)) (pure False) (evalState tableau (go context)) where go context = case context of - [] -> get >>= \ tableau -> guard (all (null . patterns) (clauses tableau)) + [] -> get >>= guard . eachClauseHead null ty:tys -> coverClauses ty >>= \ ty' -> go (ty' <> tys) coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (State Tableau) sig m, Has (Throw Err) sig m) => Type -> m [Type] From 9d202599a6a3188194202ecfe2da75cd41dd6aa4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Feb 2022 09:41:24 -0500 Subject: [PATCH 0626/1324] :fire: unused selectors. --- src/Facet/Elab/Term.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 9056eecf1..49c79c8d6 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -253,12 +253,12 @@ allP n = Bind $ \ _A k -> do -- Pattern compilation -newtype Clause = Clause { patterns :: [Pattern ()] } +newtype Clause = Clause [Pattern ()] patterns_ :: Iso' Clause [Pattern ()] patterns_ = coerced -newtype Tableau = Tableau { clauses :: [Clause] } +newtype Tableau = Tableau [Clause] clauses_ :: Iso' Tableau [Clause] clauses_ = coerced From 28cc3dc68d9355b21150808df3c0ccb01b6c0de4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Feb 2022 12:02:14 -0500 Subject: [PATCH 0627/1324] Define a prism for wildcard patterns. --- src/Facet/Pattern.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Facet/Pattern.hs b/src/Facet/Pattern.hs index f3d493fdb..bd1b19084 100644 --- a/src/Facet/Pattern.hs +++ b/src/Facet/Pattern.hs @@ -1,12 +1,14 @@ module Facet.Pattern ( -- * Patterns Pattern(..) +, _PWildcard , fill ) where import Data.Traversable (mapAccumL) import Facet.Name import Facet.Syntax +import Fresnel.Prism (Prism', prism') -- Patterns @@ -17,6 +19,11 @@ data Pattern a | PDict [RName :=: a] deriving (Eq, Foldable, Functor, Ord, Show, Traversable) +_PWildcard :: Prism' (Pattern a) () +_PWildcard = prism' (const PWildcard) (\case + PWildcard -> Just () + _ -> Nothing) + fill :: Traversable t => (b -> (b, c)) -> b -> t a -> (b, t c) fill f = mapAccumL (const . f) From 7a4d62ad89d4fa300ec3a52202b04e3566fd358f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Feb 2022 12:03:13 -0500 Subject: [PATCH 0628/1324] Define a prism for variable patterns. --- src/Facet/Pattern.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Pattern.hs b/src/Facet/Pattern.hs index bd1b19084..92fec20d6 100644 --- a/src/Facet/Pattern.hs +++ b/src/Facet/Pattern.hs @@ -2,6 +2,7 @@ module Facet.Pattern ( -- * Patterns Pattern(..) , _PWildcard +, _PVar , fill ) where @@ -24,6 +25,11 @@ _PWildcard = prism' (const PWildcard) (\case PWildcard -> Just () _ -> Nothing) +_PVar :: Prism' (Pattern a) a +_PVar = prism' PVar (\case + PVar a -> Just a + _ -> Nothing) + fill :: Traversable t => (b -> (b, c)) -> b -> t a -> (b, t c) fill f = mapAccumL (const . f) From 9fe1644719b83bde81d38512f9fbb9bff30a63f3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Feb 2022 12:04:27 -0500 Subject: [PATCH 0629/1324] Define a prism for constructor patterns. --- src/Facet/Pattern.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Pattern.hs b/src/Facet/Pattern.hs index 92fec20d6..703a69091 100644 --- a/src/Facet/Pattern.hs +++ b/src/Facet/Pattern.hs @@ -3,6 +3,7 @@ module Facet.Pattern Pattern(..) , _PWildcard , _PVar +, _PCon , fill ) where @@ -30,6 +31,11 @@ _PVar = prism' PVar (\case PVar a -> Just a _ -> Nothing) +_PCon :: Prism' (Pattern a) (RName, [Pattern a]) +_PCon = prism' (uncurry PCon) (\case + PCon h sp -> Just (h, sp) + _ -> Nothing) + fill :: Traversable t => (b -> (b, c)) -> b -> t a -> (b, t c) fill f = mapAccumL (const . f) From 251f9ecb952cacfd413da35338ad25afdb7481dc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Feb 2022 12:08:25 -0500 Subject: [PATCH 0630/1324] Tidy up isCatchAll using is and the prisms. --- src/Facet/Elab/Term.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 49c79c8d6..4f853d045 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -97,7 +97,7 @@ import Fresnel.At as At import Fresnel.Fold (allOf, folded) import Fresnel.Iso (Iso', coerced) import Fresnel.Ixed -import Fresnel.Prism (Prism') +import Fresnel.Prism (Prism', is) import Fresnel.Review (review) import Fresnel.Setter (Setter', (%~)) import Fresnel.Traversal (Traversal', traversed) @@ -299,9 +299,7 @@ eachClauseHead :: (Pattern () -> Bool) -> Tableau -> Bool eachClauseHead = allOf (clauses_.folded.patterns_.folded) isCatchAll :: Pattern a -> Bool -isCatchAll - = \case{ PWildcard -> True ; _ -> False } - ||| \case{ PVar _ -> True ; _ -> False } +isCatchAll = is _PWildcard ||| is _PVar (|||) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) (|||) = liftA2 (||) From 31de4d72d90eda84d88029bfee9f3b23a927fbb5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Feb 2022 12:12:12 -0500 Subject: [PATCH 0631/1324] Pass the whole context in. --- src/Facet/Elab/Term.hs | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 4f853d045..4ceed0e6d 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -269,11 +269,11 @@ coverTableau :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Stati coverTableau tableau context = runNonDet (liftA2 (&&)) (const (pure True)) (pure False) (evalState tableau (go context)) where go context = case context of - [] -> get >>= guard . eachClauseHead null - ty:tys -> coverClauses ty >>= \ ty' -> go (ty' <> tys) + [] -> get >>= guard . eachClauseHead null + ctx -> coverClauses ctx >>= go -coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (State Tableau) sig m, Has (Throw Err) sig m) => Type -> m [Type] -coverClauses ty = do +coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (State Tableau) sig m, Has (Throw Err) sig m) => [Type] -> m [Type] +coverClauses ctx = do tableau <- get let skipped = tableau & clauses_.traversed.patterns_ %~ tail decomposeSum = \case @@ -283,17 +283,18 @@ coverClauses ty = do x:xs -> decomposeProduct x <|> decomposeSum xs decomposeProduct = \case _ -> empty - case ty of - T.String -> [] <$ guard (eachClauseHead isCatchAll tableau) <* put skipped + case ctx of + T.String:ctx -> ctx <$ guard (eachClauseHead isCatchAll tableau) <* put skipped -- FIXME: type patterns to bind type variables? - T.ForAll{} -> [] <$ guard (eachClauseHead isCatchAll tableau) <* put skipped - T.Arrow{} -> [] <$ guard (eachClauseHead isCatchAll tableau) <* put skipped - T.Ne h _ -> case h of + T.ForAll{}:ctx -> ctx <$ guard (eachClauseHead isCatchAll tableau) <* put skipped + T.Arrow{}:ctx -> ctx <$ guard (eachClauseHead isCatchAll tableau) <* put skipped + T.Ne h _:_ -> case h of Global n -> resolveQ (toQ n) >>= \case _ :=: DSubmodule (SData scope) _ -> decomposeSum (scopeToList scope) _ -> empty _ -> empty - T.Comp{} -> empty -- resolve signature, then treat as effect patterns + T.Comp{}:_ -> empty -- resolve signature, then treat as effect patterns + [] -> [] <$ guard (eachClauseHead null tableau) eachClauseHead :: (Pattern () -> Bool) -> Tableau -> Bool eachClauseHead = allOf (clauses_.folded.patterns_.folded) From 628f5178ed0a59486f2c449fb7935cdfa672e587 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Feb 2022 16:07:34 -0500 Subject: [PATCH 0632/1324] Use the Ctx synonym. --- src/Facet/Elab/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 4ceed0e6d..96a5d74dd 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -272,7 +272,7 @@ coverTableau tableau context = runNonDet (liftA2 (&&)) (const (pure True)) (pure [] -> get >>= guard . eachClauseHead null ctx -> coverClauses ctx >>= go -coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (State Tableau) sig m, Has (Throw Err) sig m) => [Type] -> m [Type] +coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (State Tableau) sig m, Has (Throw Err) sig m) => Ctx -> m Ctx coverClauses ctx = do tableau <- get let skipped = tableau & clauses_.traversed.patterns_ %~ tail From 5d0ca450d2827dae80ed14b88466167c76a611ab Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Feb 2022 16:11:40 -0500 Subject: [PATCH 0633/1324] Manage the context via State. --- src/Facet/Elab/Term.hs | 21 +++++++++------------ 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 96a5d74dd..6f89b1f3d 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -266,35 +266,32 @@ clauses_ = coerced type Ctx = [Type] coverTableau :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> m Bool -coverTableau tableau context = runNonDet (liftA2 (&&)) (const (pure True)) (pure False) (evalState tableau (go context)) - where - go context = case context of - [] -> get >>= guard . eachClauseHead null - ctx -> coverClauses ctx >>= go +coverTableau tableau context = runNonDet (liftA2 (&&)) (const (pure True)) (pure False) (evalState tableau (evalState context coverClauses)) -coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (State Tableau) sig m, Has (Throw Err) sig m) => Ctx -> m Ctx -coverClauses ctx = do +coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State Ctx) sig m, Has (State (Subst Type)) sig m, Has (State Tableau) sig m, Has (Throw Err) sig m) => m () +coverClauses = do + ctx <- get tableau <- get let skipped = tableau & clauses_.traversed.patterns_ %~ tail decomposeSum = \case - [] -> [] <$ guard (eachClauseHead isCatchAll tableau) <* put skipped + [] -> guard (eachClauseHead isCatchAll tableau) <* put skipped <* put ctx [x] -> decomposeProduct x -- FIXME: construct binary tree of eliminations x:xs -> decomposeProduct x <|> decomposeSum xs decomposeProduct = \case _ -> empty case ctx of - T.String:ctx -> ctx <$ guard (eachClauseHead isCatchAll tableau) <* put skipped + T.String:ctx -> guard (eachClauseHead isCatchAll tableau) *> put skipped *> put ctx *> coverClauses -- FIXME: type patterns to bind type variables? - T.ForAll{}:ctx -> ctx <$ guard (eachClauseHead isCatchAll tableau) <* put skipped - T.Arrow{}:ctx -> ctx <$ guard (eachClauseHead isCatchAll tableau) <* put skipped + T.ForAll{}:ctx -> guard (eachClauseHead isCatchAll tableau) *> put skipped *> put ctx *> coverClauses + T.Arrow{}:ctx -> guard (eachClauseHead isCatchAll tableau) *> put skipped *> put ctx *> coverClauses T.Ne h _:_ -> case h of Global n -> resolveQ (toQ n) >>= \case _ :=: DSubmodule (SData scope) _ -> decomposeSum (scopeToList scope) _ -> empty _ -> empty T.Comp{}:_ -> empty -- resolve signature, then treat as effect patterns - [] -> [] <$ guard (eachClauseHead null tableau) + [] -> guard (eachClauseHead null tableau) eachClauseHead :: (Pattern () -> Bool) -> Tableau -> Bool eachClauseHead = allOf (clauses_.folded.patterns_.folded) From 550dfd1249610fa366c0bc71e67bad5def1726da Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Feb 2022 16:17:50 -0500 Subject: [PATCH 0634/1324] Pass the tableau and context around manually. --- src/Facet/Elab/Term.hs | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 6f89b1f3d..0a8ee15cf 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -266,32 +266,30 @@ clauses_ = coerced type Ctx = [Type] coverTableau :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> m Bool -coverTableau tableau context = runNonDet (liftA2 (&&)) (const (pure True)) (pure False) (evalState tableau (evalState context coverClauses)) +coverTableau tableau context = runNonDet (liftA2 (&&)) (const (pure True)) (pure False) (coverClauses tableau context) -coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State Ctx) sig m, Has (State (Subst Type)) sig m, Has (State Tableau) sig m, Has (Throw Err) sig m) => m () -coverClauses = do - ctx <- get - tableau <- get +coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> m (Tableau, Ctx) +coverClauses tableau ctx = do let skipped = tableau & clauses_.traversed.patterns_ %~ tail decomposeSum = \case - [] -> guard (eachClauseHead isCatchAll tableau) <* put skipped <* put ctx + [] -> guard (eachClauseHead isCatchAll tableau) *> coverClauses skipped ctx [x] -> decomposeProduct x -- FIXME: construct binary tree of eliminations x:xs -> decomposeProduct x <|> decomposeSum xs decomposeProduct = \case _ -> empty case ctx of - T.String:ctx -> guard (eachClauseHead isCatchAll tableau) *> put skipped *> put ctx *> coverClauses + T.String:ctx -> guard (eachClauseHead isCatchAll tableau) *> coverClauses skipped ctx -- FIXME: type patterns to bind type variables? - T.ForAll{}:ctx -> guard (eachClauseHead isCatchAll tableau) *> put skipped *> put ctx *> coverClauses - T.Arrow{}:ctx -> guard (eachClauseHead isCatchAll tableau) *> put skipped *> put ctx *> coverClauses + T.ForAll{}:ctx -> guard (eachClauseHead isCatchAll tableau) *> coverClauses skipped ctx + T.Arrow{}:ctx -> guard (eachClauseHead isCatchAll tableau) *> coverClauses skipped ctx T.Ne h _:_ -> case h of Global n -> resolveQ (toQ n) >>= \case _ :=: DSubmodule (SData scope) _ -> decomposeSum (scopeToList scope) _ -> empty _ -> empty T.Comp{}:_ -> empty -- resolve signature, then treat as effect patterns - [] -> guard (eachClauseHead null tableau) + [] -> (tableau, ctx) <$ guard (eachClauseHead null tableau) eachClauseHead :: (Pattern () -> Bool) -> Tableau -> Bool eachClauseHead = allOf (clauses_.folded.patterns_.folded) From 2ff0f5b201cf2ce95505a21817f2aa93b4b498a1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Feb 2022 16:21:59 -0500 Subject: [PATCH 0635/1324] Internalize guard into eachClauseHead again. --- src/Facet/Elab/Term.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 0a8ee15cf..11bb37a1c 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -272,27 +272,27 @@ coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader El coverClauses tableau ctx = do let skipped = tableau & clauses_.traversed.patterns_ %~ tail decomposeSum = \case - [] -> guard (eachClauseHead isCatchAll tableau) *> coverClauses skipped ctx + [] -> eachClauseHead isCatchAll tableau *> coverClauses skipped ctx [x] -> decomposeProduct x -- FIXME: construct binary tree of eliminations x:xs -> decomposeProduct x <|> decomposeSum xs decomposeProduct = \case _ -> empty case ctx of - T.String:ctx -> guard (eachClauseHead isCatchAll tableau) *> coverClauses skipped ctx + T.String:ctx -> eachClauseHead isCatchAll tableau *> coverClauses skipped ctx -- FIXME: type patterns to bind type variables? - T.ForAll{}:ctx -> guard (eachClauseHead isCatchAll tableau) *> coverClauses skipped ctx - T.Arrow{}:ctx -> guard (eachClauseHead isCatchAll tableau) *> coverClauses skipped ctx + T.ForAll{}:ctx -> eachClauseHead isCatchAll tableau *> coverClauses skipped ctx + T.Arrow{}:ctx -> eachClauseHead isCatchAll tableau *> coverClauses skipped ctx T.Ne h _:_ -> case h of Global n -> resolveQ (toQ n) >>= \case _ :=: DSubmodule (SData scope) _ -> decomposeSum (scopeToList scope) _ -> empty _ -> empty T.Comp{}:_ -> empty -- resolve signature, then treat as effect patterns - [] -> (tableau, ctx) <$ guard (eachClauseHead null tableau) + [] -> (tableau, ctx) <$ eachClauseHead null tableau -eachClauseHead :: (Pattern () -> Bool) -> Tableau -> Bool -eachClauseHead = allOf (clauses_.folded.patterns_.folded) +eachClauseHead :: Has Empty sig m => (Pattern () -> Bool) -> Tableau -> m () +eachClauseHead pred = guard . allOf (clauses_.folded.patterns_.folded) pred isCatchAll :: Pattern a -> Bool isCatchAll = is _PWildcard ||| is _PVar From 083304d251d7092edbe345e1c0b1e9340d1445fb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Feb 2022 16:28:18 -0500 Subject: [PATCH 0636/1324] Factor out dropping the head of all clauses in a tableau. --- src/Facet/Elab/Term.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 11bb37a1c..201669fd1 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -56,7 +56,6 @@ import Control.Effect.Throw import Data.Bifunctor (first) import Data.Either (partitionEithers) import Data.Foldable -import Data.Function ((&)) import Data.Functor import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import Data.Monoid (Ap(..), First(..)) @@ -270,19 +269,18 @@ coverTableau tableau context = runNonDet (liftA2 (&&)) (const (pure True)) (pure coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> m (Tableau, Ctx) coverClauses tableau ctx = do - let skipped = tableau & clauses_.traversed.patterns_ %~ tail - decomposeSum = \case - [] -> eachClauseHead isCatchAll tableau *> coverClauses skipped ctx + let decomposeSum = \case + [] -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx [x] -> decomposeProduct x -- FIXME: construct binary tree of eliminations x:xs -> decomposeProduct x <|> decomposeSum xs decomposeProduct = \case _ -> empty case ctx of - T.String:ctx -> eachClauseHead isCatchAll tableau *> coverClauses skipped ctx + T.String:ctx -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx -- FIXME: type patterns to bind type variables? - T.ForAll{}:ctx -> eachClauseHead isCatchAll tableau *> coverClauses skipped ctx - T.Arrow{}:ctx -> eachClauseHead isCatchAll tableau *> coverClauses skipped ctx + T.ForAll{}:ctx -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx + T.Arrow{}:ctx -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx T.Ne h _:_ -> case h of Global n -> resolveQ (toQ n) >>= \case _ :=: DSubmodule (SData scope) _ -> decomposeSum (scopeToList scope) @@ -291,6 +289,9 @@ coverClauses tableau ctx = do T.Comp{}:_ -> empty -- resolve signature, then treat as effect patterns [] -> (tableau, ctx) <$ eachClauseHead null tableau +dropClauseHead :: Tableau -> Tableau +dropClauseHead = clauses_.traversed.patterns_ %~ drop 1 + eachClauseHead :: Has Empty sig m => (Pattern () -> Bool) -> Tableau -> m () eachClauseHead pred = guard . allOf (clauses_.folded.patterns_.folded) pred From f144fdb65e775c876b3d3d9690d06d66d82bc571 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Feb 2022 16:28:57 -0500 Subject: [PATCH 0637/1324] :fire: returrns. --- src/Facet/Elab/Term.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 201669fd1..19091d55a 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -267,7 +267,7 @@ type Ctx = [Type] coverTableau :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> m Bool coverTableau tableau context = runNonDet (liftA2 (&&)) (const (pure True)) (pure False) (coverClauses tableau context) -coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> m (Tableau, Ctx) +coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> m () coverClauses tableau ctx = do let decomposeSum = \case [] -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx @@ -287,7 +287,7 @@ coverClauses tableau ctx = do _ -> empty _ -> empty T.Comp{}:_ -> empty -- resolve signature, then treat as effect patterns - [] -> (tableau, ctx) <$ eachClauseHead null tableau + [] -> eachClauseHead null tableau dropClauseHead :: Tableau -> Tableau dropClauseHead = clauses_.traversed.patterns_ %~ drop 1 From 4152f42f7e9523ee691a44bb5455777aaa77cc46 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 14 Feb 2022 16:00:02 -0500 Subject: [PATCH 0638/1324] :fire: a redundant language pragma. --- src/Facet/Type/Norm.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 5527aafe7..a8a7bdbb1 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ImportQualifiedPost #-} module Facet.Type.Norm ( -- * Types Type(..) From 338876a23abad1e0d022b3782956dfe1169a1a0a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 14 Feb 2022 16:02:14 -0500 Subject: [PATCH 0639/1324] Combine folds instead of booleans. --- src/Facet/Elab/Term.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 19091d55a..618974055 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -57,7 +57,7 @@ import Data.Bifunctor (first) import Data.Either (partitionEithers) import Data.Foldable import Data.Functor -import Data.Maybe (catMaybes, fromMaybe, listToMaybe) +import Data.Maybe (catMaybes, fromMaybe, isJust, listToMaybe) import Data.Monoid (Ap(..), First(..)) import qualified Data.Set as Set import Data.Text (Text) @@ -93,10 +93,11 @@ import Facet.Type.Norm as T hiding (global) import Facet.Unify import Facet.Usage hiding (restrict) import Fresnel.At as At -import Fresnel.Fold (allOf, folded) +import Fresnel.Fold (Fold, Union(..), allOf, folded, preview) +import Fresnel.Getter (to) import Fresnel.Iso (Iso', coerced) import Fresnel.Ixed -import Fresnel.Prism (Prism', is) +import Fresnel.Prism (Prism') import Fresnel.Review (review) import Fresnel.Setter (Setter', (%~)) import Fresnel.Traversal (Traversal', traversed) @@ -296,10 +297,10 @@ eachClauseHead :: Has Empty sig m => (Pattern () -> Bool) -> Tableau -> m () eachClauseHead pred = guard . allOf (clauses_.folded.patterns_.folded) pred isCatchAll :: Pattern a -> Bool -isCatchAll = is _PWildcard ||| is _PVar +isCatchAll = isJust . preview (_PWildcard ||| _PVar) -(|||) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) -(|||) = liftA2 (||) +(|||) :: Fold s a1 -> Fold s a2 -> Fold s () +p ||| q = getUnion (Union (p . to (const ())) <> Union (q . to (const ()))) infixr 2 ||| From c1a02ec60cee532e800c7bf651265eade0bb3c7d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 14 Feb 2022 23:11:38 -0500 Subject: [PATCH 0640/1324] Pass the tableau to decomposeSum. --- src/Facet/Elab/Term.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 618974055..a2adcdd47 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -270,11 +270,11 @@ coverTableau tableau context = runNonDet (liftA2 (&&)) (const (pure True)) (pure coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> m () coverClauses tableau ctx = do - let decomposeSum = \case + let decomposeSum tableau = \case [] -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx [x] -> decomposeProduct x -- FIXME: construct binary tree of eliminations - x:xs -> decomposeProduct x <|> decomposeSum xs + x:xs -> decomposeProduct x <|> decomposeSum tableau xs decomposeProduct = \case _ -> empty case ctx of @@ -284,7 +284,7 @@ coverClauses tableau ctx = do T.Arrow{}:ctx -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx T.Ne h _:_ -> case h of Global n -> resolveQ (toQ n) >>= \case - _ :=: DSubmodule (SData scope) _ -> decomposeSum (scopeToList scope) + _ :=: DSubmodule (SData scope) _ -> decomposeSum tableau (scopeToList scope) _ -> empty _ -> empty T.Comp{}:_ -> empty -- resolve signature, then treat as effect patterns From 19f54fd115176a1b83fa2a66314431814de055c7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 14 Feb 2022 23:11:55 -0500 Subject: [PATCH 0641/1324] Pass the tableau to decomposeProduct. --- src/Facet/Elab/Term.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index a2adcdd47..d07cb4c12 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -272,10 +272,10 @@ coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader El coverClauses tableau ctx = do let decomposeSum tableau = \case [] -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx - [x] -> decomposeProduct x + [x] -> decomposeProduct tableau x -- FIXME: construct binary tree of eliminations - x:xs -> decomposeProduct x <|> decomposeSum tableau xs - decomposeProduct = \case + x:xs -> decomposeProduct tableau x <|> decomposeSum tableau xs + decomposeProduct _tableau = \case _ -> empty case ctx of T.String:ctx -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx From 96db066e1ca038e81f73465707521273ae5aebb4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 14 Feb 2022 23:14:06 -0500 Subject: [PATCH 0642/1324] Extract decomposeProduct. --- src/Facet/Elab/Term.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index d07cb4c12..2f7a57194 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -275,8 +275,6 @@ coverClauses tableau ctx = do [x] -> decomposeProduct tableau x -- FIXME: construct binary tree of eliminations x:xs -> decomposeProduct tableau x <|> decomposeSum tableau xs - decomposeProduct _tableau = \case - _ -> empty case ctx of T.String:ctx -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx -- FIXME: type patterns to bind type variables? @@ -290,6 +288,10 @@ coverClauses tableau ctx = do T.Comp{}:_ -> empty -- resolve signature, then treat as effect patterns [] -> eachClauseHead null tableau +decomposeProduct :: Has Empty sig m => Tableau -> Name :=: Def -> m a +decomposeProduct _tableau = \case + _ -> empty + dropClauseHead :: Tableau -> Tableau dropClauseHead = clauses_.traversed.patterns_ %~ drop 1 From 4a82069a6d78554bbe4bd4c6bad83e97f52fe0a8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 14 Feb 2022 23:17:07 -0500 Subject: [PATCH 0643/1324] Extract decomposeSum. --- src/Facet/Elab/Term.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 2f7a57194..6eee0eb58 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -270,11 +270,6 @@ coverTableau tableau context = runNonDet (liftA2 (&&)) (const (pure True)) (pure coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> m () coverClauses tableau ctx = do - let decomposeSum tableau = \case - [] -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx - [x] -> decomposeProduct tableau x - -- FIXME: construct binary tree of eliminations - x:xs -> decomposeProduct tableau x <|> decomposeSum tableau xs case ctx of T.String:ctx -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx -- FIXME: type patterns to bind type variables? @@ -282,12 +277,19 @@ coverClauses tableau ctx = do T.Arrow{}:ctx -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx T.Ne h _:_ -> case h of Global n -> resolveQ (toQ n) >>= \case - _ :=: DSubmodule (SData scope) _ -> decomposeSum tableau (scopeToList scope) + _ :=: DSubmodule (SData scope) _ -> decomposeSum tableau ctx (scopeToList scope) _ -> empty _ -> empty T.Comp{}:_ -> empty -- resolve signature, then treat as effect patterns [] -> eachClauseHead null tableau +decomposeSum :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> [Name :=: Def] -> m () +decomposeSum tableau ctx = \case + [] -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx + [x] -> decomposeProduct tableau x + -- FIXME: construct binary tree of eliminations + x:xs -> decomposeProduct tableau x <|> decomposeSum tableau ctx xs + decomposeProduct :: Has Empty sig m => Tableau -> Name :=: Def -> m a decomposeProduct _tableau = \case _ -> empty From 756aaf2a8d163c27f55e4b315d3eda3d7ac11642 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 14 Feb 2022 23:22:06 -0500 Subject: [PATCH 0644/1324] Lambda case on the context. --- src/Facet/Elab/Term.hs | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 6eee0eb58..36bc21966 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -269,19 +269,18 @@ coverTableau :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Stati coverTableau tableau context = runNonDet (liftA2 (&&)) (const (pure True)) (pure False) (coverClauses tableau context) coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> m () -coverClauses tableau ctx = do - case ctx of - T.String:ctx -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx - -- FIXME: type patterns to bind type variables? - T.ForAll{}:ctx -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx - T.Arrow{}:ctx -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx - T.Ne h _:_ -> case h of - Global n -> resolveQ (toQ n) >>= \case - _ :=: DSubmodule (SData scope) _ -> decomposeSum tableau ctx (scopeToList scope) - _ -> empty - _ -> empty - T.Comp{}:_ -> empty -- resolve signature, then treat as effect patterns - [] -> eachClauseHead null tableau +coverClauses tableau = \case + T.String:ctx -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx + -- FIXME: type patterns to bind type variables? + T.ForAll{}:ctx -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx + T.Arrow{}:ctx -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx + c@(T.Ne h _:_) -> case h of + Global n -> resolveQ (toQ n) >>= \case + _ :=: DSubmodule (SData scope) _ -> decomposeSum tableau c (scopeToList scope) + _ -> empty + _ -> empty + T.Comp{}:_ -> empty -- resolve signature, then treat as effect patterns + [] -> eachClauseHead null tableau decomposeSum :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> [Name :=: Def] -> m () decomposeSum tableau ctx = \case From 8f9e3c6d6acc8f9c894c112cf05abb53497ffac3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Feb 2022 09:31:33 -0500 Subject: [PATCH 0645/1324] Represent pattern-matching patterns explicitly. --- src/Facet/Elab/Term.hs | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 36bc21966..f95864b8b 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE OverloadedStrings #-} module Facet.Elab.Term @@ -93,10 +94,11 @@ import Facet.Type.Norm as T hiding (global) import Facet.Unify import Facet.Usage hiding (restrict) import Fresnel.At as At -import Fresnel.Fold (Fold, Union(..), allOf, folded, preview) +import Fresnel.Fold (Fold, Union(..), allOf, folded, forOf_, preview) import Fresnel.Getter (to) import Fresnel.Iso (Iso', coerced) import Fresnel.Ixed +import Fresnel.List (head_) import Fresnel.Prism (Prism') import Fresnel.Review (review) import Fresnel.Setter (Setter', (%~)) @@ -265,15 +267,20 @@ clauses_ = coerced type Ctx = [Type] +data Branch s m = forall x . Branch (Fold s x) (x -> m ()) + coverTableau :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> m Bool coverTableau tableau context = runNonDet (liftA2 (&&)) (const (pure True)) (pure False) (coverClauses tableau context) coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> m () coverClauses tableau = \case - T.String:ctx -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx + T.String:ctx -> everyClauseHead tableau + [ Branch (_PWildcard ||| _PVar) (const (coverClauses (dropClauseHead tableau) ctx)) ] -- FIXME: type patterns to bind type variables? - T.ForAll{}:ctx -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx - T.Arrow{}:ctx -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx + T.ForAll{}:ctx -> everyClauseHead tableau + [ Branch (_PWildcard ||| _PVar) (const (coverClauses (dropClauseHead tableau) ctx)) ] + T.Arrow{}:ctx -> everyClauseHead tableau + [ Branch (_PWildcard ||| _PVar) (const (coverClauses (dropClauseHead tableau) ctx)) ] c@(T.Ne h _:_) -> case h of Global n -> resolveQ (toQ n) >>= \case _ :=: DSubmodule (SData scope) _ -> decomposeSum tableau c (scopeToList scope) @@ -299,6 +306,11 @@ dropClauseHead = clauses_.traversed.patterns_ %~ drop 1 eachClauseHead :: Has Empty sig m => (Pattern () -> Bool) -> Tableau -> m () eachClauseHead pred = guard . allOf (clauses_.folded.patterns_.folded) pred +everyClauseHead :: Has NonDet sig m => Tableau -> [Branch (Pattern ()) m] -> m () +everyClauseHead tableau = go where + go [] = empty + go (Branch b k:bs) = forOf_ (clauses_.folded.patterns_.head_) tableau (maybe (go bs) k . preview b) + isCatchAll :: Pattern a -> Bool isCatchAll = isJust . preview (_PWildcard ||| _PVar) From 5322a5483d6bb962e5ecb0fe58872d08881ebe08 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Feb 2022 09:32:00 -0500 Subject: [PATCH 0646/1324] NonDet. --- src/Facet/Elab/Term.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index f95864b8b..7ffaba8fd 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -272,7 +272,7 @@ data Branch s m = forall x . Branch (Fold s x) (x -> m ()) coverTableau :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> m Bool coverTableau tableau context = runNonDet (liftA2 (&&)) (const (pure True)) (pure False) (coverClauses tableau context) -coverClauses :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> m () +coverClauses :: (HasCallStack, Has NonDet sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> m () coverClauses tableau = \case T.String:ctx -> everyClauseHead tableau [ Branch (_PWildcard ||| _PVar) (const (coverClauses (dropClauseHead tableau) ctx)) ] @@ -289,7 +289,7 @@ coverClauses tableau = \case T.Comp{}:_ -> empty -- resolve signature, then treat as effect patterns [] -> eachClauseHead null tableau -decomposeSum :: (HasCallStack, Has Choose sig m, Has Empty sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> [Name :=: Def] -> m () +decomposeSum :: (HasCallStack, Has NonDet sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> [Name :=: Def] -> m () decomposeSum tableau ctx = \case [] -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx [x] -> decomposeProduct tableau x From 28643913c6094fa68b6ff78243d6833927dd8a15 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Feb 2022 09:32:38 -0500 Subject: [PATCH 0647/1324] Weaken the constraints for everyClauseHead. --- src/Facet/Elab/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 7ffaba8fd..4333fc9ad 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -306,7 +306,7 @@ dropClauseHead = clauses_.traversed.patterns_ %~ drop 1 eachClauseHead :: Has Empty sig m => (Pattern () -> Bool) -> Tableau -> m () eachClauseHead pred = guard . allOf (clauses_.folded.patterns_.folded) pred -everyClauseHead :: Has NonDet sig m => Tableau -> [Branch (Pattern ()) m] -> m () +everyClauseHead :: Has Empty sig m => Tableau -> [Branch (Pattern ()) m] -> m () everyClauseHead tableau = go where go [] = empty go (Branch b k:bs) = forOf_ (clauses_.folded.patterns_.head_) tableau (maybe (go bs) k . preview b) From 2d47f716ad38f7a765fc14b44634a80544dd87b6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Feb 2022 10:03:12 -0500 Subject: [PATCH 0648/1324] Use everyClauseHead in decomposeSum. --- src/Facet/Elab/Term.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 4333fc9ad..2c2e840ca 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -291,7 +291,8 @@ coverClauses tableau = \case decomposeSum :: (HasCallStack, Has NonDet sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> [Name :=: Def] -> m () decomposeSum tableau ctx = \case - [] -> eachClauseHead isCatchAll tableau *> coverClauses (dropClauseHead tableau) ctx + [] -> everyClauseHead tableau + [ Branch (_PWildcard ||| _PVar) (const (coverClauses (dropClauseHead tableau) ctx)) ] [x] -> decomposeProduct tableau x -- FIXME: construct binary tree of eliminations x:xs -> decomposeProduct tableau x <|> decomposeSum tableau ctx xs @@ -311,9 +312,6 @@ everyClauseHead tableau = go where go [] = empty go (Branch b k:bs) = forOf_ (clauses_.folded.patterns_.head_) tableau (maybe (go bs) k . preview b) -isCatchAll :: Pattern a -> Bool -isCatchAll = isJust . preview (_PWildcard ||| _PVar) - (|||) :: Fold s a1 -> Fold s a2 -> Fold s () p ||| q = getUnion (Union (p . to (const ())) <> Union (q . to (const ()))) From f33748d60e6d80811ae902a11d2117ea036f027a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 15:11:27 -0500 Subject: [PATCH 0649/1324] :fire: a redundant import. --- src/Facet/Elab/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 2c2e840ca..2cfd5018d 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -58,7 +58,7 @@ import Data.Bifunctor (first) import Data.Either (partitionEithers) import Data.Foldable import Data.Functor -import Data.Maybe (catMaybes, fromMaybe, isJust, listToMaybe) +import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import Data.Monoid (Ap(..), First(..)) import qualified Data.Set as Set import Data.Text (Text) From ea95a5dedb10d262bf64aac937ad17ddaa1158af Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 15:14:18 -0500 Subject: [PATCH 0650/1324] Handle Error.Lens more idiomatically. --- src/Facet/Carrier/Error/Lens.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Facet/Carrier/Error/Lens.hs b/src/Facet/Carrier/Error/Lens.hs index 14201fad6..ae965afe4 100644 --- a/src/Facet/Carrier/Error/Lens.hs +++ b/src/Facet/Carrier/Error/Lens.hs @@ -12,7 +12,8 @@ import Control.Algebra import Control.Carrier.Reader import Control.Effect.Error import Control.Monad.IO.Class -import Fresnel.Prism (Prism', withPrism) +import Fresnel.Prism (Prism', matching) +import Fresnel.Review (review) runError :: Prism' e f -> ErrorC e f m a -> m a runError prism (ErrorC m) = runReader (APrism' prism) m @@ -22,8 +23,8 @@ newtype ErrorC e f m a = ErrorC (ReaderC (APrism' e f) m a) instance Has (Error e) sig m => Algebra (Error f :+: sig) (ErrorC e f m) where alg hdl sig ctx = ErrorC $ ReaderC $ \ (APrism' prism) -> case sig of - L (L (Throw e)) -> throwError (withPrism prism (\ review _ -> review e)) - L (R (Catch m h)) -> runError prism (hdl (m <$ ctx)) `catchError` \ e -> withPrism prism (\ _ preview -> either throwError (runError prism . hdl . (<$ ctx) . h) (preview e)) + L (L (Throw e)) -> throwError (review prism e) + L (R (Catch m h)) -> runError prism (hdl (m <$ ctx)) `catchError` \ e -> either throwError (runError prism . hdl . (<$ ctx) . h) (matching prism e) R other -> alg (runError prism . hdl) other ctx From ae1cb03352b618c898ddcb23f378a976717efd31 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 15:16:17 -0500 Subject: [PATCH 0651/1324] Rename the .Lens carrier modules to .Optic. --- facet.cabal | 4 ++-- src/Facet/Carrier/Error/{Lens.hs => Optic.hs} | 2 +- src/Facet/Carrier/State/{Lens.hs => Optic.hs} | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) rename src/Facet/Carrier/Error/{Lens.hs => Optic.hs} (96%) rename src/Facet/Carrier/State/{Lens.hs => Optic.hs} (96%) diff --git a/facet.cabal b/facet.cabal index 3dbd81b5e..6bbdde423 100644 --- a/facet.cabal +++ b/facet.cabal @@ -60,14 +60,14 @@ common common library import: common exposed-modules: - Facet.Carrier.Error.Lens + Facet.Carrier.Error.Optic Facet.Carrier.Output.IO Facet.Carrier.Parser.Church Facet.Carrier.Profile.Flat Facet.Carrier.Profile.Identity Facet.Carrier.Profile.Tree Facet.Carrier.Readline.Haskeline - Facet.Carrier.State.Lens + Facet.Carrier.State.Optic Facet.Carrier.Throw.Inject Facet.Carrier.Time.System Facet.Carrier.Write.General diff --git a/src/Facet/Carrier/Error/Lens.hs b/src/Facet/Carrier/Error/Optic.hs similarity index 96% rename from src/Facet/Carrier/Error/Lens.hs rename to src/Facet/Carrier/Error/Optic.hs index ae965afe4..0845b0b28 100644 --- a/src/Facet/Carrier/Error/Lens.hs +++ b/src/Facet/Carrier/Error/Optic.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE UndecidableInstances #-} -module Facet.Carrier.Error.Lens +module Facet.Carrier.Error.Optic ( -- * Error carrier runError , ErrorC(..) diff --git a/src/Facet/Carrier/State/Lens.hs b/src/Facet/Carrier/State/Optic.hs similarity index 96% rename from src/Facet/Carrier/State/Lens.hs rename to src/Facet/Carrier/State/Optic.hs index 66ff15524..4f15d8a48 100644 --- a/src/Facet/Carrier/State/Lens.hs +++ b/src/Facet/Carrier/State/Optic.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE UndecidableInstances #-} -module Facet.Carrier.State.Lens +module Facet.Carrier.State.Optic ( -- * State carrier runState , StateC(..) From 273a9dbeb7b80cf6bd27ee7b1bf4eb800145335b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 15:23:32 -0500 Subject: [PATCH 0652/1324] Define a carrier for elaboration errors. --- src/Facet/Elab.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 8a5eaab67..11bd7e565 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} -- | This module defines the /elaboration/ of terms in 'S.Expr' into values in 'Type'. -- -- Elaboration is the only way 'Type's are constructed from untrusted terms, and so typechecking is performed at this point. If elaboration succeeds and a 'Type' is returned, that 'Type' does not require further verification; hence, 'Type's elide source span information. @@ -268,6 +270,15 @@ missingInterface :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticCont missingInterface i = withFrozenCallStack $ err $ MissingInterface i +newtype ErrC m a = ErrC { runErr :: m a } + deriving (Applicative, Functor, Monad) + +instance Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m => Algebra (Throw ErrReason :+: sig) (ErrC m) where + alg hdl sig ctx = case sig of + L (Throw e) -> err e + R other -> ErrC (alg (runErr . hdl) other ctx) + + -- Warnings data Warn = Warn From 58bdcf903923906c76c6a3b797895a5da7dcfe75 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 15:57:33 -0500 Subject: [PATCH 0653/1324] Define a prism for mismatch reasons. --- src/Facet/Elab.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 11bd7e565..7e133d36a 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -19,6 +19,7 @@ module Facet.Elab , Err(..) , ErrReason(..) , UnifyErrReason(..) +, _Mismatch , err , makeErr , couldNotUnify @@ -87,7 +88,7 @@ import Facet.Usage as Usage import Facet.Vars as Vars import Fresnel.Fold ((^?)) import Fresnel.Lens (Lens', lens) -import Fresnel.Prism (Prism') +import Fresnel.Prism (Prism', prism') import GHC.Stack import Prelude hiding (span, zipWith) @@ -217,6 +218,11 @@ data UnifyErrReason = Mismatch | Occurs Meta Classifier +_Mismatch :: Prism' UnifyErrReason () +_Mismatch = prism' (const Mismatch) (\case + Mismatch -> Just () + _ -> Nothing) + applySubst :: Context -> Subst Type -> ErrReason -> ErrReason applySubst ctx subst r = case r of FreeVariable{} -> r From 96eb2e7edf1b5aec89670a7851329c9043bc166f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 15:58:56 -0500 Subject: [PATCH 0654/1324] Define a prism for occurrence check failures. --- src/Facet/Elab.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 7e133d36a..a1ce2bf82 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -20,6 +20,7 @@ module Facet.Elab , ErrReason(..) , UnifyErrReason(..) , _Mismatch +, _Occurs , err , makeErr , couldNotUnify @@ -223,6 +224,11 @@ _Mismatch = prism' (const Mismatch) (\case Mismatch -> Just () _ -> Nothing) +_Occurs :: Prism' UnifyErrReason (Meta, Classifier) +_Occurs = prism' (uncurry Occurs) (\case + Occurs v c -> Just (v, c) + _ -> Nothing) + applySubst :: Context -> Subst Type -> ErrReason -> ErrReason applySubst ctx subst r = case r of FreeVariable{} -> r From 88999f971fa871e924276ab9183452e249d75168 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 16:00:34 -0500 Subject: [PATCH 0655/1324] Define a prism for free variables. --- src/Facet/Elab.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index a1ce2bf82..e77526fb5 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -18,6 +18,7 @@ module Facet.Elab , pushSpan , Err(..) , ErrReason(..) +, _FreeVariable , UnifyErrReason(..) , _Mismatch , _Occurs @@ -215,6 +216,11 @@ data ErrReason | Invariant String | MissingInterface (Interface Type) +_FreeVariable :: Prism' ErrReason QName +_FreeVariable = prism' FreeVariable (\case + FreeVariable n -> Just n + _ -> Nothing) + data UnifyErrReason = Mismatch | Occurs Meta Classifier From afedf3b8d5d4d4249cb9238ab8546155a7be0e21 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 16:01:58 -0500 Subject: [PATCH 0656/1324] Define a prism for ambiguous names. --- src/Facet/Elab.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index e77526fb5..137cea5e3 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -19,6 +19,7 @@ module Facet.Elab , Err(..) , ErrReason(..) , _FreeVariable +, _AmbiguousName , UnifyErrReason(..) , _Mismatch , _Occurs @@ -221,6 +222,11 @@ _FreeVariable = prism' FreeVariable (\case FreeVariable n -> Just n _ -> Nothing) +_AmbiguousName :: Prism' ErrReason (QName, [RName]) +_AmbiguousName = prism' (uncurry AmbiguousName) (\case + AmbiguousName n ns -> Just (n, ns) + _ -> Nothing) + data UnifyErrReason = Mismatch | Occurs Meta Classifier From 6f299c276b53c2a2ed524758e48cc7f923398d44 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 16:06:11 -0500 Subject: [PATCH 0657/1324] Define a prism for unification errors. --- src/Facet/Elab.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 137cea5e3..cfe0a885c 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -20,6 +20,7 @@ module Facet.Elab , ErrReason(..) , _FreeVariable , _AmbiguousName +, _Unify , UnifyErrReason(..) , _Mismatch , _Occurs @@ -227,6 +228,11 @@ _AmbiguousName = prism' (uncurry AmbiguousName) (\case AmbiguousName n ns -> Just (n, ns) _ -> Nothing) +_Unify :: Prism' ErrReason (UnifyErrReason, Exp (Either String Classifier), Act Classifier) +_Unify = prism' (\ (r, x, a) -> Unify r x a) (\case + Unify r x a -> Just (r, x, a) + _ -> Nothing) + data UnifyErrReason = Mismatch | Occurs Meta Classifier From f59f414aac39534d35cbde28d41c38e9b7c3618e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 16:15:12 -0500 Subject: [PATCH 0658/1324] Define a module for a call stack effect. --- facet.cabal | 1 + src/Facet/Effect/CallStack.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Effect/CallStack.hs diff --git a/facet.cabal b/facet.cabal index 6bbdde423..79228d74c 100644 --- a/facet.cabal +++ b/facet.cabal @@ -76,6 +76,7 @@ library Facet.Context Facet.Diff Facet.Driver + Facet.Effect.CallStack Facet.Effect.Parser Facet.Effect.Profile Facet.Effect.Readline diff --git a/src/Facet/Effect/CallStack.hs b/src/Facet/Effect/CallStack.hs new file mode 100644 index 000000000..1e45ec4e5 --- /dev/null +++ b/src/Facet/Effect/CallStack.hs @@ -0,0 +1,2 @@ +module Facet.Effect.CallStack +() where From bcdc2468a6cf54abe682842afcccd13d35df7d6d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 16:20:39 -0500 Subject: [PATCH 0659/1324] Define a call stack effect. --- src/Facet/Effect/CallStack.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/src/Facet/Effect/CallStack.hs b/src/Facet/Effect/CallStack.hs index 1e45ec4e5..0c4a55e37 100644 --- a/src/Facet/Effect/CallStack.hs +++ b/src/Facet/Effect/CallStack.hs @@ -1,2 +1,15 @@ +{-# LANGUAGE GADTs #-} module Facet.Effect.CallStack -() where +( pushCallStack +, CallStack(..) +) where + +import Control.Algebra +import Data.Text (Text) +import qualified Facet.Span as Span + +pushCallStack :: Has CallStack sig m => Text -> Span.Span -> m a -> m a +pushCallStack l s m = send (Push l s m) + +data CallStack m a where + Push :: Text -> Span.Span -> m a -> CallStack m a From 9381507647462463ce91c29965ee1bc2e779e6f0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 16:30:19 -0500 Subject: [PATCH 0660/1324] Push call sites from the current location. --- src/Facet/Effect/CallStack.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/src/Facet/Effect/CallStack.hs b/src/Facet/Effect/CallStack.hs index 0c4a55e37..e40b111d7 100644 --- a/src/Facet/Effect/CallStack.hs +++ b/src/Facet/Effect/CallStack.hs @@ -1,12 +1,19 @@ {-# LANGUAGE GADTs #-} module Facet.Effect.CallStack -( pushCallStack +( call +, pushCallStack , CallStack(..) ) where import Control.Algebra -import Data.Text (Text) +import Data.Text (Text, pack) import qualified Facet.Span as Span +import qualified GHC.Stack as Stack + +call :: (Stack.HasCallStack, Has CallStack sig m) => m a -> m a +call m = case Stack.getCallStack Stack.callStack of + (label, loc):_ -> pushCallStack (pack label) (Span.Span (Span.Pos (Stack.srcLocStartLine loc) (Stack.srcLocStartCol loc)) (Span.Pos (Stack.srcLocEndLine loc) (Stack.srcLocEndCol loc))) m + _ -> m pushCallStack :: Has CallStack sig m => Text -> Span.Span -> m a -> m a pushCallStack l s m = send (Push l s m) From 8cc6f7d01f05d5afc0d572859d40f36e2cf69e1b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 16:36:28 -0500 Subject: [PATCH 0661/1324] Define an operation to retrieve the current call stack. --- src/Facet/Effect/CallStack.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Effect/CallStack.hs b/src/Facet/Effect/CallStack.hs index e40b111d7..0392b36db 100644 --- a/src/Facet/Effect/CallStack.hs +++ b/src/Facet/Effect/CallStack.hs @@ -2,6 +2,7 @@ module Facet.Effect.CallStack ( call , pushCallStack +, callStack , CallStack(..) ) where @@ -18,5 +19,9 @@ call m = case Stack.getCallStack Stack.callStack of pushCallStack :: Has CallStack sig m => Text -> Span.Span -> m a -> m a pushCallStack l s m = send (Push l s m) +callStack :: Has CallStack sig m => m [(Text, Span.Span)] +callStack = send CallStack + data CallStack m a where Push :: Text -> Span.Span -> m a -> CallStack m a + CallStack :: CallStack m [(Text, Span.Span)] From c0e73b668da898a9d53fc204481b5a9ee1c0b147 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 16:37:30 -0500 Subject: [PATCH 0662/1324] Define a module for a CallStack carrier. --- facet.cabal | 1 + src/Facet/Carrier/CallStack/Stack.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Carrier/CallStack/Stack.hs diff --git a/facet.cabal b/facet.cabal index 79228d74c..5051b7768 100644 --- a/facet.cabal +++ b/facet.cabal @@ -60,6 +60,7 @@ common common library import: common exposed-modules: + Facet.Carrier.CallStack.Stack Facet.Carrier.Error.Optic Facet.Carrier.Output.IO Facet.Carrier.Parser.Church diff --git a/src/Facet/Carrier/CallStack/Stack.hs b/src/Facet/Carrier/CallStack/Stack.hs new file mode 100644 index 000000000..7a4677952 --- /dev/null +++ b/src/Facet/Carrier/CallStack/Stack.hs @@ -0,0 +1,2 @@ +module Facet.Carrier.CallStack.Stack +() where From 91285db4b44e219fd0eb75b73f31b7793f8775b1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 16:38:55 -0500 Subject: [PATCH 0663/1324] Define a CallStack carrier type. --- src/Facet/Carrier/CallStack/Stack.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/Facet/Carrier/CallStack/Stack.hs b/src/Facet/Carrier/CallStack/Stack.hs index 7a4677952..f8d81699f 100644 --- a/src/Facet/Carrier/CallStack/Stack.hs +++ b/src/Facet/Carrier/CallStack/Stack.hs @@ -1,2 +1,9 @@ module Facet.Carrier.CallStack.Stack -() where +( CallStackC(..) +) where + +import Control.Carrier.State.Church +import qualified Data.Text as Text +import qualified Facet.Span as Span + +newtype CallStackC m a = CallStackC (StateC [(Text.Text, Span.Span)] m a) From a0c5e528ca4893d8b35ab4eeadf40f6841294bb5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 16:39:32 -0500 Subject: [PATCH 0664/1324] Derive some modules. --- src/Facet/Carrier/CallStack/Stack.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Carrier/CallStack/Stack.hs b/src/Facet/Carrier/CallStack/Stack.hs index f8d81699f..e11ca5931 100644 --- a/src/Facet/Carrier/CallStack/Stack.hs +++ b/src/Facet/Carrier/CallStack/Stack.hs @@ -7,3 +7,4 @@ import qualified Data.Text as Text import qualified Facet.Span as Span newtype CallStackC m a = CallStackC (StateC [(Text.Text, Span.Span)] m a) + deriving (Applicative, Functor, Monad) From 6d4294ff5b211901c2f1d4459885224047888588 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 16:45:06 -0500 Subject: [PATCH 0665/1324] CallStackC is a Reader. --- src/Facet/Carrier/CallStack/Stack.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Carrier/CallStack/Stack.hs b/src/Facet/Carrier/CallStack/Stack.hs index e11ca5931..7db4ac121 100644 --- a/src/Facet/Carrier/CallStack/Stack.hs +++ b/src/Facet/Carrier/CallStack/Stack.hs @@ -2,9 +2,9 @@ module Facet.Carrier.CallStack.Stack ( CallStackC(..) ) where -import Control.Carrier.State.Church +import Control.Carrier.Reader import qualified Data.Text as Text import qualified Facet.Span as Span -newtype CallStackC m a = CallStackC (StateC [(Text.Text, Span.Span)] m a) +newtype CallStackC m a = CallStackC { runCallStackC :: ReaderC [(Text.Text, Span.Span)] m a } deriving (Applicative, Functor, Monad) From 67b3302f8517ab38d37cc2f5f190a172c56e7293 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 16:49:01 -0500 Subject: [PATCH 0666/1324] Define an Algebra instance for CallStackC. --- src/Facet/Carrier/CallStack/Stack.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/src/Facet/Carrier/CallStack/Stack.hs b/src/Facet/Carrier/CallStack/Stack.hs index 7db4ac121..e7d9d7972 100644 --- a/src/Facet/Carrier/CallStack/Stack.hs +++ b/src/Facet/Carrier/CallStack/Stack.hs @@ -1,10 +1,23 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE UndecidableInstances #-} module Facet.Carrier.CallStack.Stack -( CallStackC(..) +( -- * CallStack carrier + CallStackC(..) + -- * CallStack effect +, module Facet.Effect.CallStack ) where +import Control.Algebra import Control.Carrier.Reader import qualified Data.Text as Text +import Facet.Effect.CallStack import qualified Facet.Span as Span newtype CallStackC m a = CallStackC { runCallStackC :: ReaderC [(Text.Text, Span.Span)] m a } deriving (Applicative, Functor, Monad) + +instance Algebra sig m => Algebra (CallStack :+: sig) (CallStackC m) where + alg hdl sig ctx = CallStackC $ case sig of + L (Push l s m) -> local ((l, s):) (runCallStackC (hdl (m <$ ctx))) + L CallStack -> asks (<$ ctx) + R other -> alg (runCallStackC . hdl) (R other) ctx From 6ce537804d764365853d1e6c1d9e59542f297fa3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 19:15:15 -0500 Subject: [PATCH 0667/1324] Define a type synonym for callstacks. --- src/Facet/Effect/CallStack.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Facet/Effect/CallStack.hs b/src/Facet/Effect/CallStack.hs index 0392b36db..90add8dd3 100644 --- a/src/Facet/Effect/CallStack.hs +++ b/src/Facet/Effect/CallStack.hs @@ -2,6 +2,7 @@ module Facet.Effect.CallStack ( call , pushCallStack +, Stack , callStack , CallStack(..) ) where @@ -19,9 +20,11 @@ call m = case Stack.getCallStack Stack.callStack of pushCallStack :: Has CallStack sig m => Text -> Span.Span -> m a -> m a pushCallStack l s m = send (Push l s m) -callStack :: Has CallStack sig m => m [(Text, Span.Span)] +type Stack = [(Text, Span.Span)] + +callStack :: Has CallStack sig m => m Stack callStack = send CallStack data CallStack m a where Push :: Text -> Span.Span -> m a -> CallStack m a - CallStack :: CallStack m [(Text, Span.Span)] + CallStack :: CallStack m Stack From daf9bda92d36fef4cc075e3ec258a583c7bbb850 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 19:23:35 -0500 Subject: [PATCH 0668/1324] Define a module for source references. --- facet.cabal | 1 + src/Facet/Source/Reference.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Source/Reference.hs diff --git a/facet.cabal b/facet.cabal index 5051b7768..7041599d2 100644 --- a/facet.cabal +++ b/facet.cabal @@ -124,6 +124,7 @@ library Facet.Snoc Facet.Snoc.NonEmpty Facet.Source + Facet.Source.Reference Facet.Span Facet.Style Facet.Subst diff --git a/src/Facet/Source/Reference.hs b/src/Facet/Source/Reference.hs new file mode 100644 index 000000000..955e2d8e2 --- /dev/null +++ b/src/Facet/Source/Reference.hs @@ -0,0 +1,2 @@ +module Facet.Source.Reference +() where From 0e1a37864821d1ba583c752adf5a42e9ba15c705 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 19:24:27 -0500 Subject: [PATCH 0669/1324] Define source references. --- src/Facet/Source/Reference.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/Facet/Source/Reference.hs b/src/Facet/Source/Reference.hs index 955e2d8e2..3ad069c85 100644 --- a/src/Facet/Source/Reference.hs +++ b/src/Facet/Source/Reference.hs @@ -1,2 +1,10 @@ module Facet.Source.Reference -() where +( Reference(..) +) where + +import qualified Facet.Span as Span + +data Reference = Reference + { path :: Maybe FilePath + , span :: Span.Span + } From a611b2ed2eba8e329825b20b23c869a3909f9ed2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 19:25:43 -0500 Subject: [PATCH 0670/1324] Define optics for Reference. --- src/Facet/Source/Reference.hs | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/src/Facet/Source/Reference.hs b/src/Facet/Source/Reference.hs index 3ad069c85..2663460ff 100644 --- a/src/Facet/Source/Reference.hs +++ b/src/Facet/Source/Reference.hs @@ -1,10 +1,25 @@ module Facet.Source.Reference ( Reference(..) +, path_ +, span_ ) where import qualified Facet.Span as Span +import Fresnel.Lens (Lens', lens) +import Prelude hiding (span) data Reference = Reference { path :: Maybe FilePath , span :: Span.Span } + +path_ :: Lens' Reference (Maybe FilePath) +path_ = lens path $ \ e path -> e{ path } +{-# INLINE path_ #-} + +-- | A lens over the 'Span.Span' from a 'Reference'. +-- +-- Note that it is the caller’s responsibility to ensure that this span and the 'lines' are in agreement as to line numbers. +span_ :: Lens' Reference Span.Span +span_ = lens span $ \ e span -> e{ span } +{-# INLINE span_ #-} From 154a68a49ca947cac38c372b963591121d972732 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 19:28:46 -0500 Subject: [PATCH 0671/1324] Derive some instances. --- src/Facet/Source/Reference.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Source/Reference.hs b/src/Facet/Source/Reference.hs index 2663460ff..0d4feba06 100644 --- a/src/Facet/Source/Reference.hs +++ b/src/Facet/Source/Reference.hs @@ -12,6 +12,7 @@ data Reference = Reference { path :: Maybe FilePath , span :: Span.Span } + deriving (Eq, Ord, Show) path_ :: Lens' Reference (Maybe FilePath) path_ = lens path $ \ e path -> e{ path } From 67b8a93f63e41145325ad16cf101b557d382d73b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 19:33:28 -0500 Subject: [PATCH 0672/1324] Use Reference in Source. --- src/Facet/Carrier/Parser/Church.hs | 2 +- src/Facet/Driver.hs | 3 ++- src/Facet/Run.hs | 3 ++- src/Facet/Source.hs | 21 ++++++++++++--------- src/Facet/Style.hs | 5 +++-- test/Facet/Source/Test.hs | 5 +++-- 6 files changed, 23 insertions(+), 16 deletions(-) diff --git a/src/Facet/Carrier/Parser/Church.hs b/src/Facet/Carrier/Parser/Church.hs index 629f63f09..1f1ed1821 100644 --- a/src/Facet/Carrier/Parser/Church.hs +++ b/src/Facet/Carrier/Parser/Church.hs @@ -57,7 +57,7 @@ runParserWithFile path p = do {-# INLINE runParserWithFile #-} runParserWithSource :: Has (Throw (Source, Err)) sig m => Source -> ParserC m a -> m a -runParserWithSource src@(Source _ _ _ (Line line _ _:|_)) = runParser (const pure) failure failure input +runParserWithSource src@(Source _ _ (Line line _ _:|_)) = runParser (const pure) failure failure input where input = Input (Pos line 0) (contents src) failure = throwError . (,) src diff --git a/src/Facet/Driver.hs b/src/Facet/Driver.hs index 05e66414e..49d158511 100644 --- a/src/Facet/Driver.hs +++ b/src/Facet/Driver.hs @@ -47,6 +47,7 @@ import Facet.Pretty import Facet.Print (Options, Print) import Facet.Snoc import Facet.Source +import Facet.Source.Reference import Facet.Style import qualified Facet.Surface.Module as Import (Import(..)) import Facet.Syntax as S @@ -109,7 +110,7 @@ reloadModules = do case loaded of Just loaded -> (Just <$> do outputDocLn $ annotate Progress (brackets (ratio (i :: Int) nModules)) <+> nest 2 (group (fillSep [ pretty "Loading", prettyMName name ])) - storeModule name (path src) =<< loadModule graph loaded) + storeModule name (path (reference src)) =<< loadModule graph loaded) `catchError` \ err -> Nothing <$ outputDocLn (prettyNotice err) Nothing -> do outputDocLn $ annotate Progress (brackets (ratio i nModules)) <+> nest 2 (group (fillSep [ pretty "Skipping", prettyMName name ])) diff --git a/src/Facet/Run.hs b/src/Facet/Run.hs index 1a5df2ecc..a29a5ff30 100644 --- a/src/Facet/Run.hs +++ b/src/Facet/Run.hs @@ -15,6 +15,7 @@ import Facet.Graph import Facet.Lens import Facet.Print (Print, quietOptions) import Facet.Source as Source +import Facet.Source.Reference as Source import Facet.Style import Fresnel.At import Fresnel.Getter ((^.)) @@ -28,7 +29,7 @@ runFile searchPaths path = runStack $ do ExitSuccess <$ for_ modules (\ h@(ModuleHeader name src _) -> do graph <- use modules_ let loaded = traverse (\ name -> graph^.at name >>= snd) h - for_ loaded (storeModule name (Source.path src) <=< loadModule graph)) + for_ loaded (storeModule name (Source.path (Source.reference src)) <=< loadModule graph)) where runStack = runOutput diff --git a/src/Facet/Source.hs b/src/Facet/Source.hs index bfa334fc0..322bc15dd 100644 --- a/src/Facet/Source.hs +++ b/src/Facet/Source.hs @@ -16,28 +16,31 @@ module Facet.Source import Control.Exception (assert) import qualified Data.List.NonEmpty as NE import Data.Monoid (Endo(..)) +import qualified Facet.Source.Reference as R import qualified Facet.Span as Span import Fresnel.Lens (Lens', lens) import Prelude hiding (lines, span) import qualified Prettyprinter as P data Source = Source - { path :: Maybe FilePath - , span :: Span.Span - , contents :: String -- FIXME: Text - , lines :: NE.NonEmpty Line + { reference :: R.Reference + , contents :: String -- FIXME: Text + , lines :: NE.NonEmpty Line } deriving (Eq, Ord, Show) +reference_ :: Lens' Source R.Reference +reference_ = lens reference $ \ e reference -> e{ reference } + path_ :: Lens' Source (Maybe FilePath) -path_ = lens path $ \ e path -> e{ path } +path_ = reference_. R.path_ {-# INLINE path_ #-} -- | A lens over the 'Span.Span' from a 'Source'. -- -- Note that it is the caller’s responsibility to ensure that this span and the 'lines' are in agreement as to line numbers. span_ :: Lens' Source Span.Span -span_ = lens span $ \ e span -> e{ span } +span_ = reference_. R.span_ {-# INLINE span_ #-} -- | A lens over a 'Source'’s contents. @@ -74,7 +77,7 @@ instance P.Pretty LineEnding where sourceFromString :: Maybe FilePath -> Int -> String -> Source -sourceFromString path line contents = Source path span contents lines +sourceFromString path line contents = Source (R.Reference path span) contents lines where span = Span.Span (Span.Pos line 0) (let Line i s e = NE.last lines in Span.Pos i (length s + case e of EOF -> 0 @@ -107,7 +110,7 @@ src ! pos = NE.head $ src !.. Span.Span pos pos infixl 9 ! (!..) :: Source -> Span.Span -> NE.NonEmpty Line -Source _ _ _ lines !.. span +Source _ _ lines !.. span = assert (endLine >= startLine) $ NE.fromList $ takeWhile (\ (Line i _ _) -> i <= endLine) @@ -121,7 +124,7 @@ infixl 9 !.. slice :: Source -> Span.Span -> Source -slice (Source path _ _ lines) span' = Source path span' contents' lines' +slice (Source (R.Reference path _) _ lines) span' = Source (R.Reference path span') contents' lines' where contents' = appEndo (foldMap (\ (Line _ s e) -> Endo (s <>) <> case e of EOF -> mempty diff --git a/src/Facet/Style.hs b/src/Facet/Style.hs index 4c5139197..1c4f7ec78 100644 --- a/src/Facet/Style.hs +++ b/src/Facet/Style.hs @@ -12,6 +12,7 @@ import Data.Maybe (fromMaybe) import qualified Facet.Notice as Notice import Facet.Pretty import Facet.Source +import Facet.Source.Reference import qualified Facet.Span as Span import qualified Prettyprinter as P import Silkscreen @@ -84,7 +85,7 @@ prettyNotice (Notice.Notice level src reason context) = concatWith (surround har , context >>= \ ctx -> [ mempty, annotate Context ctx ]]) where header = nest 2 (group (fillSep - [ foldMap (\ (Source path span _ _) -> annotate Path (pretty (fromMaybe "(interactive)" path)) <> colon <> prettySpan span <> colon) src <> foldMap ((space <>) . (<> colon) . prettyLevel) level + [ foldMap (\ (Source (Reference path span) _ _) -> annotate Path (pretty (fromMaybe "(interactive)" path)) <> colon <> prettySpan span <> colon) src <> foldMap ((space <>) . (<> colon) . prettyLevel) level , annotate Reason reason ])) @@ -93,7 +94,7 @@ prettyNotice (Notice.Notice level src reason context) = concatWith (surround har Notice.Warn -> P.pretty "warning" Notice.Error -> P.pretty "error" - ref (Source _ span _ (line:|_)) = annotate Gutter (pretty (succ (Span.line (Span.start span)))) <+> align (vcat + ref (Source (Reference _ span) _ (line:|_)) = annotate Gutter (pretty (succ (Span.line (Span.start span)))) <+> align (vcat [ annotate Gutter (pretty '|') <+> prettyLine line , annotate Gutter (pretty '|') <+> padding span <> annotate Caret (caret (lineLength line) span) ]) diff --git a/test/Facet/Source/Test.hs b/test/Facet/Source/Test.hs index 930270bb4..dff18f235 100644 --- a/test/Facet/Source/Test.hs +++ b/test/Facet/Source/Test.hs @@ -6,6 +6,7 @@ module Facet.Source.Test import Data.List (isPrefixOf) import qualified Data.List.NonEmpty as NE import Facet.Source +import Facet.Source.Reference import Facet.Span import Hedgehog import qualified Hedgehog.Gen as Gen @@ -26,10 +27,10 @@ tests = checkParallel $$(discover) prop_sourceFromString_returns_empty_string_for_empty_string = property $ - sourceFromString Nothing 0 "" === Source Nothing (Span (Pos 0 0) (Pos 0 0)) "" (NE.fromList [Line 0 "" EOF]) + sourceFromString Nothing 0 "" === Source (Reference Nothing (Span (Pos 0 0) (Pos 0 0))) "" (NE.fromList [Line 0 "" EOF]) prop_sourceFromString_returns_two_empty_strings_for_a_newline = property $ - sourceFromString Nothing 0 "\n" === Source Nothing (Span (Pos 0 0) (Pos 1 0)) "\n" (NE.fromList [Line 0 "" LF, Line 1 "" EOF]) + sourceFromString Nothing 0 "\n" === Source (Reference Nothing (Span (Pos 0 0) (Pos 1 0))) "\n" (NE.fromList [Line 0 "" LF, Line 1 "" EOF]) prop_returns_one_more_string_than_there_are_newlines = property $ do s <- forAll (Gen.string (Range.linear 1 100) From e8389e2106d32df7f1ab05ee3be9d84f9834748e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 19:36:44 -0500 Subject: [PATCH 0673/1324] Use the Stack synonym in the carrier. --- src/Facet/Carrier/CallStack/Stack.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/Facet/Carrier/CallStack/Stack.hs b/src/Facet/Carrier/CallStack/Stack.hs index e7d9d7972..1f460ea93 100644 --- a/src/Facet/Carrier/CallStack/Stack.hs +++ b/src/Facet/Carrier/CallStack/Stack.hs @@ -7,13 +7,11 @@ module Facet.Carrier.CallStack.Stack , module Facet.Effect.CallStack ) where -import Control.Algebra -import Control.Carrier.Reader -import qualified Data.Text as Text -import Facet.Effect.CallStack -import qualified Facet.Span as Span +import Control.Algebra +import Control.Carrier.Reader +import Facet.Effect.CallStack -newtype CallStackC m a = CallStackC { runCallStackC :: ReaderC [(Text.Text, Span.Span)] m a } +newtype CallStackC m a = CallStackC { runCallStackC :: ReaderC Stack m a } deriving (Applicative, Functor, Monad) instance Algebra sig m => Algebra (CallStack :+: sig) (CallStackC m) where From 157b27a5a55a084085435970818d171e32c3360c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 19:37:01 -0500 Subject: [PATCH 0674/1324] Call stacks have file paths. --- src/Facet/Effect/CallStack.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Facet/Effect/CallStack.hs b/src/Facet/Effect/CallStack.hs index 90add8dd3..bdf45b635 100644 --- a/src/Facet/Effect/CallStack.hs +++ b/src/Facet/Effect/CallStack.hs @@ -9,22 +9,23 @@ module Facet.Effect.CallStack import Control.Algebra import Data.Text (Text, pack) +import qualified Facet.Source.Reference as Ref import qualified Facet.Span as Span import qualified GHC.Stack as Stack call :: (Stack.HasCallStack, Has CallStack sig m) => m a -> m a call m = case Stack.getCallStack Stack.callStack of - (label, loc):_ -> pushCallStack (pack label) (Span.Span (Span.Pos (Stack.srcLocStartLine loc) (Stack.srcLocStartCol loc)) (Span.Pos (Stack.srcLocEndLine loc) (Stack.srcLocEndCol loc))) m + (label, loc):_ -> pushCallStack (pack label) (Ref.Reference (Just (Stack.srcLocFile loc)) (Span.Span (Span.Pos (Stack.srcLocStartLine loc) (Stack.srcLocStartCol loc)) (Span.Pos (Stack.srcLocEndLine loc) (Stack.srcLocEndCol loc)))) m _ -> m -pushCallStack :: Has CallStack sig m => Text -> Span.Span -> m a -> m a +pushCallStack :: Has CallStack sig m => Text -> Ref.Reference -> m a -> m a pushCallStack l s m = send (Push l s m) -type Stack = [(Text, Span.Span)] +type Stack = [(Text, Ref.Reference)] callStack :: Has CallStack sig m => m Stack callStack = send CallStack data CallStack m a where - Push :: Text -> Span.Span -> m a -> CallStack m a + Push :: Text -> Ref.Reference -> m a -> CallStack m a CallStack :: CallStack m Stack From 743c16b03ad066a0912b210538c53b1dd38dcf9d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Feb 2022 19:39:12 -0500 Subject: [PATCH 0675/1324] Define a handler for CallStackC. --- src/Facet/Carrier/CallStack/Stack.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Facet/Carrier/CallStack/Stack.hs b/src/Facet/Carrier/CallStack/Stack.hs index 1f460ea93..aa3fb4255 100644 --- a/src/Facet/Carrier/CallStack/Stack.hs +++ b/src/Facet/Carrier/CallStack/Stack.hs @@ -2,7 +2,8 @@ {-# LANGUAGE UndecidableInstances #-} module Facet.Carrier.CallStack.Stack ( -- * CallStack carrier - CallStackC(..) + runCallStack +, CallStackC(..) -- * CallStack effect , module Facet.Effect.CallStack ) where @@ -11,6 +12,9 @@ import Control.Algebra import Control.Carrier.Reader import Facet.Effect.CallStack +runCallStack :: CallStackC m a -> m a +runCallStack = runReader [] . runCallStackC + newtype CallStackC m a = CallStackC { runCallStackC :: ReaderC Stack m a } deriving (Applicative, Functor, Monad) From 8c505d84811641afc97550284b24facf101d4220 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 20 Feb 2022 00:15:51 -0500 Subject: [PATCH 0676/1324] Generalize switch. --- src/Facet/Elab/Type.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 575a7be10..b6f0d5009 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -11,6 +11,8 @@ module Facet.Elab.Type import Control.Algebra import Control.Applicative (liftA2) +import Control.Effect.Reader +import Control.Effect.State import Control.Effect.Throw import Control.Monad (unless) import Data.Foldable (foldl') @@ -24,6 +26,7 @@ import Facet.Module import Facet.Name import Facet.Semiring (Few(..), one, zero) import Facet.Snoc +import Facet.Subst import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) import qualified Facet.Type.Expr as TX @@ -105,7 +108,7 @@ assertTypeConstructor = assertMatch _KArrow "_ -> _" -- Judgements -switch :: (HasCallStack, Has (Throw Err) sig m) => Elab m (a :==> Kind) -> Kind <==: Elab m a +switch :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => m (a :==> Kind) -> Kind <==: m a switch m = Check $ \ _K -> do a :==> _KA <- m a <$ unless (_KA == _K) (couldNotUnify (Exp (CK _K)) (Act (CK _KA))) From e1dea279d4003d2862ae4dd1c11ef3168147d756 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 20 Feb 2022 00:19:08 -0500 Subject: [PATCH 0677/1324] Generalize abstractType. --- src/Facet/Elab/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 2cfd5018d..02552b66a 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -365,7 +365,7 @@ bindPattern = withSpanB $ \case -- | Elaborate a type abstracted over another type’s parameters. -- -- This is used to elaborate data constructors & effect operations, which receive the type/interface parameters as implicit parameters ahead of their own explicit ones. -abstractType :: Algebra sig m => Elab m TX.Type -> Kind -> Elab m TX.Type +abstractType :: Has (Reader ElabContext) sig m => m TX.Type -> Kind -> m TX.Type abstractType body = \case KArrow (Just n) a b -> TX.ForAll n a <$> (n :==> a ||- abstractType body b) _ -> body From 3800fb84c8baf39f0e02f23248b3686a6bd32040 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 20 Feb 2022 00:20:43 -0500 Subject: [PATCH 0678/1324] Generalize _String. --- src/Facet/Elab/Type.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index b6f0d5009..9806c47f6 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -46,7 +46,7 @@ ivar n = resolveQ n >>= \case _ -> freeVariable n -_String :: Elab m (TX.Type :==> Kind) +_String :: Applicative m => m (TX.Type :==> Kind) _String = pure $ TX.String :==> KType From 611281043556c8b26519556dc2bc334bc6e09cd6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 21 Feb 2022 20:06:10 -0500 Subject: [PATCH 0679/1324] Get fresnel from hackage. --- cabal.project | 6 ------ cabal.project.ci | 6 ------ 2 files changed, 12 deletions(-) diff --git a/cabal.project b/cabal.project index 9b9446ab7..7ef286b0d 100644 --- a/cabal.project +++ b/cabal.project @@ -1,8 +1,2 @@ packages: . tests: True - -source-repository-package - type: git - location: https://github.com/robrix/fresnel.git - tag: 573c4a0c7542e9e95a77b833fad7e37d2a31fc4e - subdir: fresnel diff --git a/cabal.project.ci b/cabal.project.ci index de100ab6c..dd5c5c333 100644 --- a/cabal.project.ci +++ b/cabal.project.ci @@ -3,9 +3,3 @@ tests: True package facet ghc-options: -Werror - -source-repository-package - type: git - location: https://github.com/robrix/fresnel.git - tag: 573c4a0c7542e9e95a77b833fad7e37d2a31fc4e - subdir: fresnel From 6b2a58b4e1f561b16f275e7ed6bb4b54f123d05c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 22 Feb 2022 12:23:19 -0500 Subject: [PATCH 0680/1324] Partition tableaux per-constructor. --- src/Facet/Elab/Term.hs | 38 ++++++++++++++++++++++++++++---------- 1 file changed, 28 insertions(+), 10 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 02552b66a..65e665a90 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -94,7 +94,7 @@ import Facet.Type.Norm as T hiding (global) import Facet.Unify import Facet.Usage hiding (restrict) import Fresnel.At as At -import Fresnel.Fold (Fold, Union(..), allOf, folded, forOf_, preview) +import Fresnel.Fold (Fold, Union(..), allOf, folded, forOf_, has, preview) import Fresnel.Getter (to) import Fresnel.Iso (Iso', coerced) import Fresnel.Ixed @@ -291,15 +291,33 @@ coverClauses tableau = \case decomposeSum :: (HasCallStack, Has NonDet sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> [Name :=: Def] -> m () decomposeSum tableau ctx = \case - [] -> everyClauseHead tableau - [ Branch (_PWildcard ||| _PVar) (const (coverClauses (dropClauseHead tableau) ctx)) ] - [x] -> decomposeProduct tableau x - -- FIXME: construct binary tree of eliminations - x:xs -> decomposeProduct tableau x <|> decomposeSum tableau ctx xs - -decomposeProduct :: Has Empty sig m => Tableau -> Name :=: Def -> m a -decomposeProduct _tableau = \case - _ -> empty + [] -> empty + xs -> let partitions = tableauPartitions tableau ctx xs in getChoosing (foldMap (\ (tableau', ctx') -> Choosing (coverClauses tableau' ctx')) partitions) + +tableauPartitions :: Tableau -> Ctx -> [Name :=: Def] -> [(Tableau, Ctx)] +-- FIXME: check for inapplicable patterns in tableau +tableauPartitions _ _ [] = [] +tableauPartitions tableau ctx ((n :=: d):cs) = + let (tableau', tableau'') = partitionTableau tableau n in + case d of + DTerm _ ty -> (tableau', typeOf ty <> ctx):tableauPartitions tableau'' ctx cs + _ -> [] + +partitionTableau :: Tableau -> Name -> (Tableau, Tableau) +partitionTableau (Tableau clauses) name = (Tableau (filter matched clauses), Tableau (filter unmatched clauses)) + where + matched (Clause (p:_)) = case p of + PWildcard -> True + PVar _ -> True + PCon (_:.:name') _ -> name == name' + _ -> False + matched _ = False + unmatched = has (patterns_.head_.(_PWildcard ||| _PVar)) + +typeOf :: Type -> Ctx +typeOf = \case + T.Arrow _ _ _A _B -> _A : typeOf _B + _T -> [_T] dropClauseHead :: Tableau -> Tableau dropClauseHead = clauses_.traversed.patterns_ %~ drop 1 From 19259e2750cdb306c1e153d6efac48f1fc3c212b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 22 Feb 2022 13:17:00 -0500 Subject: [PATCH 0681/1324] Tighten up tableau partitioning. --- src/Facet/Elab/Term.hs | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 65e665a90..4068c0ab9 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -304,15 +304,12 @@ tableauPartitions tableau ctx ((n :=: d):cs) = _ -> [] partitionTableau :: Tableau -> Name -> (Tableau, Tableau) -partitionTableau (Tableau clauses) name = (Tableau (filter matched clauses), Tableau (filter unmatched clauses)) +partitionTableau (Tableau clauses) name = + ( Tableau (filter (has (patterns_.head_.(to conMatches ||| _PWildcard ||| _PVar))) clauses) + , Tableau (filter (has (patterns_.head_.(to (not . conMatches) ||| _PWildcard ||| _PVar))) clauses) ) where - matched (Clause (p:_)) = case p of - PWildcard -> True - PVar _ -> True - PCon (_:.:name') _ -> name == name' - _ -> False - matched _ = False - unmatched = has (patterns_.head_.(_PWildcard ||| _PVar)) + conMatches (PCon (_:.:name') _) = name == name' + conMatches _ = False typeOf :: Type -> Ctx typeOf = \case From 3159cb33c04ee744691bc0f09cd89d7ae4e57e3d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Feb 2022 19:58:53 -0500 Subject: [PATCH 0682/1324] Define a module for pattern elaboration. --- facet.cabal | 1 + src/Facet/Elab/Pattern.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Elab/Pattern.hs diff --git a/facet.cabal b/facet.cabal index 7041599d2..322546673 100644 --- a/facet.cabal +++ b/facet.cabal @@ -85,6 +85,7 @@ library Facet.Effect.Time.System Facet.Effect.Write Facet.Elab + Facet.Elab.Pattern Facet.Elab.Term Facet.Elab.Type Facet.Env diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs new file mode 100644 index 000000000..6989ac3a9 --- /dev/null +++ b/src/Facet/Elab/Pattern.hs @@ -0,0 +1,2 @@ +module Facet.Elab.Pattern +() where From b844cabd5e0f2eeda2c53d32c4046bb24121e96c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Feb 2022 22:16:07 -0500 Subject: [PATCH 0683/1324] Move the normalized type module under Syntax. --- facet.cabal | 2 +- src/Facet/Context.hs | 2 +- src/Facet/Elab.hs | 2 +- src/Facet/Elab/Term.hs | 2 +- src/Facet/Elab/Type.hs | 2 +- src/Facet/Module.hs | 2 +- src/Facet/Notice/Elab.hs | 2 +- src/Facet/Print.hs | 2 +- src/Facet/{Type/Norm.hs => Syntax/Norm/Type.hs} | 6 +++--- src/Facet/Unify.hs | 2 +- test/Facet/Core/Type/Test.hs | 2 +- 11 files changed, 13 insertions(+), 13 deletions(-) rename src/Facet/{Type/Norm.hs => Syntax/Norm/Type.hs} (97%) diff --git a/facet.cabal b/facet.cabal index 322546673..96d84241d 100644 --- a/facet.cabal +++ b/facet.cabal @@ -134,13 +134,13 @@ library Facet.Surface.Type.Class Facet.Surface.Type.Expr Facet.Syntax + Facet.Syntax.Norm.Type Facet.Term.Class Facet.Term.Expr Facet.Term.Norm Facet.Timing Facet.Type.Class Facet.Type.Expr - Facet.Type.Norm Facet.Unify Facet.Usage Facet.Vars diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index 649c4bcf8..0ff62e41f 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -21,7 +21,7 @@ import Facet.Name import Facet.Pattern import qualified Facet.Snoc as S import Facet.Syntax -import Facet.Type.Norm +import Facet.Syntax.Norm.Type import Facet.Usage import GHC.Stack import Prelude hiding (lookup) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index cfe0a885c..ab5feba13 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -85,9 +85,9 @@ import Facet.Source (Source, slice) import Facet.Span (Span(..)) import Facet.Subst import Facet.Syntax hiding (context_) +import Facet.Syntax.Norm.Type as TN import Facet.Term.Expr as E import qualified Facet.Type.Expr as TX -import Facet.Type.Norm as TN import Facet.Usage as Usage import Facet.Vars as Vars import Fresnel.Fold ((^?)) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 4068c0ab9..218b65ced 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -88,9 +88,9 @@ import qualified Facet.Surface.Module as S import qualified Facet.Surface.Term.Expr as S import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) +import Facet.Syntax.Norm.Type as T hiding (global) import Facet.Term.Expr as E import qualified Facet.Type.Expr as TX -import Facet.Type.Norm as T hiding (global) import Facet.Unify import Facet.Usage hiding (restrict) import Fresnel.At as At diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 9806c47f6..3c1bab91f 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -29,8 +29,8 @@ import Facet.Snoc import Facet.Subst import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) +import Facet.Syntax.Norm.Type import qualified Facet.Type.Expr as TX -import Facet.Type.Norm import GHC.Stack tvar :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (TX.Type :==> Kind) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 9639075b9..55cba285a 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -40,8 +40,8 @@ import qualified Data.Map as Map import Facet.Kind import Facet.Name import Facet.Syntax +import Facet.Syntax.Norm.Type import Facet.Term.Expr -import Facet.Type.Norm import Fresnel.Fold (preview) import Fresnel.Getter (view) import Fresnel.Iso (Iso, coerced, fmapping, iso) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index b1e028a0e..7078f30b9 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -23,7 +23,7 @@ import Facet.Snoc import Facet.Style import Facet.Subst (metas) import Facet.Syntax hiding (ann) -import Facet.Type.Norm (apply, free, metavar) +import Facet.Syntax.Norm.Type (apply, free, metavar) import GHC.Stack import Prelude hiding (print, unlines) import Silkscreen diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 48398ca49..1e1a3a41f 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -42,10 +42,10 @@ import Facet.Semiring (one, zero) import Facet.Snoc import Facet.Style import Facet.Syntax hiding (Ann(..)) +import qualified Facet.Syntax.Norm.Type as TN import qualified Facet.Term.Expr as C import qualified Facet.Term.Norm as N import qualified Facet.Type.Expr as TX -import qualified Facet.Type.Norm as TN import Prelude hiding (print) import qualified Prettyprinter as PP import Silkscreen as P diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Syntax/Norm/Type.hs similarity index 97% rename from src/Facet/Type/Norm.hs rename to src/Facet/Syntax/Norm/Type.hs index a8a7bdbb1..3ad9c9cf6 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Syntax/Norm/Type.hs @@ -1,4 +1,4 @@ -module Facet.Type.Norm +module Facet.Syntax.Norm.Type ( -- * Types Type(..) , _String @@ -55,8 +55,8 @@ instance C.Type Type where string = String forAll = ForAll arrow = Arrow - var = Facet.Type.Norm.var - ($$) = (Facet.Type.Norm.$$) + var = Facet.Syntax.Norm.Type.var + ($$) = (Facet.Syntax.Norm.Type.$$) (|-) = Comp instance Quote Type TX.Type where diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index 9c6caee12..32335f8cf 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -28,8 +28,8 @@ import Facet.Semialign import Facet.Snoc import Facet.Subst import Facet.Syntax +import Facet.Syntax.Norm.Type as TN import qualified Facet.Type.Expr as TX -import Facet.Type.Norm as TN import Facet.Usage import GHC.Stack diff --git a/test/Facet/Core/Type/Test.hs b/test/Facet/Core/Type/Test.hs index 689470336..a1bdee382 100644 --- a/test/Facet/Core/Type/Test.hs +++ b/test/Facet/Core/Type/Test.hs @@ -11,7 +11,7 @@ import Facet.Quote import Facet.Semiring import Facet.Syntax import Facet.Type.Expr -import Facet.Type.Norm (eval) +import Facet.Syntax.Norm.Type (eval) import Hedgehog hiding (Var, eval) tests :: IO Bool From 7be40db40c6d0d4838e515a5cdc6f4c8e7368419 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Feb 2022 22:22:10 -0500 Subject: [PATCH 0684/1324] Rename Facet.Type.Expr to Facet.Syntax.Expr.Type. --- facet.cabal | 2 +- src/Facet/Elab.hs | 2 +- src/Facet/Elab/Term.hs | 2 +- src/Facet/Elab/Type.hs | 2 +- src/Facet/Print.hs | 2 +- src/Facet/{Type/Expr.hs => Syntax/Expr/Type.hs} | 2 +- src/Facet/Syntax/Norm/Type.hs | 2 +- src/Facet/Unify.hs | 2 +- test/Facet/Core/Type/Test.hs | 2 +- 9 files changed, 9 insertions(+), 9 deletions(-) rename src/Facet/{Type/Expr.hs => Syntax/Expr/Type.hs} (96%) diff --git a/facet.cabal b/facet.cabal index 96d84241d..4eda6583d 100644 --- a/facet.cabal +++ b/facet.cabal @@ -134,13 +134,13 @@ library Facet.Surface.Type.Class Facet.Surface.Type.Expr Facet.Syntax + Facet.Syntax.Expr.Type Facet.Syntax.Norm.Type Facet.Term.Class Facet.Term.Expr Facet.Term.Norm Facet.Timing Facet.Type.Class - Facet.Type.Expr Facet.Unify Facet.Usage Facet.Vars diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index ab5feba13..d7945152a 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -85,9 +85,9 @@ import Facet.Source (Source, slice) import Facet.Span (Span(..)) import Facet.Subst import Facet.Syntax hiding (context_) +import qualified Facet.Syntax.Expr.Type as TX import Facet.Syntax.Norm.Type as TN import Facet.Term.Expr as E -import qualified Facet.Type.Expr as TX import Facet.Usage as Usage import Facet.Vars as Vars import Fresnel.Fold ((^?)) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 218b65ced..466424152 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -88,9 +88,9 @@ import qualified Facet.Surface.Module as S import qualified Facet.Surface.Term.Expr as S import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) +import qualified Facet.Syntax.Expr.Type as TX import Facet.Syntax.Norm.Type as T hiding (global) import Facet.Term.Expr as E -import qualified Facet.Type.Expr as TX import Facet.Unify import Facet.Usage hiding (restrict) import Fresnel.At as At diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 3c1bab91f..9572bac6c 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -29,8 +29,8 @@ import Facet.Snoc import Facet.Subst import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) +import qualified Facet.Syntax.Expr.Type as TX import Facet.Syntax.Norm.Type -import qualified Facet.Type.Expr as TX import GHC.Stack tvar :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (TX.Type :==> Kind) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 1e1a3a41f..4a4e47cd1 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -42,10 +42,10 @@ import Facet.Semiring (one, zero) import Facet.Snoc import Facet.Style import Facet.Syntax hiding (Ann(..)) +import qualified Facet.Syntax.Expr.Type as TX import qualified Facet.Syntax.Norm.Type as TN import qualified Facet.Term.Expr as C import qualified Facet.Term.Norm as N -import qualified Facet.Type.Expr as TX import Prelude hiding (print) import qualified Prettyprinter as PP import Silkscreen as P diff --git a/src/Facet/Type/Expr.hs b/src/Facet/Syntax/Expr/Type.hs similarity index 96% rename from src/Facet/Type/Expr.hs rename to src/Facet/Syntax/Expr/Type.hs index 2f8e65e7c..3e14d69bb 100644 --- a/src/Facet/Type/Expr.hs +++ b/src/Facet/Syntax/Expr/Type.hs @@ -1,4 +1,4 @@ -module Facet.Type.Expr +module Facet.Syntax.Expr.Type ( Type(..) ) where diff --git a/src/Facet/Syntax/Norm/Type.hs b/src/Facet/Syntax/Norm/Type.hs index 3ad9c9cf6..b2f6a11a3 100644 --- a/src/Facet/Syntax/Norm/Type.hs +++ b/src/Facet/Syntax/Norm/Type.hs @@ -34,8 +34,8 @@ import Facet.Quote import Facet.Snoc import Facet.Subst import Facet.Syntax +import qualified Facet.Syntax.Expr.Type as TX import qualified Facet.Type.Class as C -import qualified Facet.Type.Expr as TX import Facet.Usage hiding (singleton) import Fresnel.Prism (Prism', prism') import GHC.Stack diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index 32335f8cf..f0f1477cf 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -28,8 +28,8 @@ import Facet.Semialign import Facet.Snoc import Facet.Subst import Facet.Syntax +import qualified Facet.Syntax.Expr.Type as TX import Facet.Syntax.Norm.Type as TN -import qualified Facet.Type.Expr as TX import Facet.Usage import GHC.Stack diff --git a/test/Facet/Core/Type/Test.hs b/test/Facet/Core/Type/Test.hs index a1bdee382..13544ce38 100644 --- a/test/Facet/Core/Type/Test.hs +++ b/test/Facet/Core/Type/Test.hs @@ -10,7 +10,7 @@ import Facet.Name import Facet.Quote import Facet.Semiring import Facet.Syntax -import Facet.Type.Expr +import Facet.Syntax.Expr.Type import Facet.Syntax.Norm.Type (eval) import Hedgehog hiding (Var, eval) From 81f4c0661a28386b7f97e8a6c591da9cdfcbce8b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Feb 2022 22:24:08 -0500 Subject: [PATCH 0685/1324] Rename Facet.Pattern to Facet.Syntax.Pattern. --- facet.cabal | 2 +- src/Facet/Context.hs | 2 +- src/Facet/Elab.hs | 2 +- src/Facet/Elab/Term.hs | 2 +- src/Facet/Env.hs | 2 +- src/Facet/Eval.hs | 2 +- src/Facet/Notice/Elab.hs | 2 +- src/Facet/Print.hs | 2 +- src/Facet/Syntax/Norm/Type.hs | 2 +- src/Facet/{ => Syntax}/Pattern.hs | 2 +- src/Facet/Term/Expr.hs | 2 +- src/Facet/Term/Norm.hs | 2 +- 12 files changed, 12 insertions(+), 12 deletions(-) rename src/Facet/{ => Syntax}/Pattern.hs (96%) diff --git a/facet.cabal b/facet.cabal index 4eda6583d..14737b8e1 100644 --- a/facet.cabal +++ b/facet.cabal @@ -107,7 +107,6 @@ library Facet.Notice.Parser Facet.Parser Facet.Parser.Table - Facet.Pattern Facet.Polarized Facet.Pretty Facet.Print @@ -136,6 +135,7 @@ library Facet.Syntax Facet.Syntax.Expr.Type Facet.Syntax.Norm.Type + Facet.Syntax.Pattern Facet.Term.Class Facet.Term.Expr Facet.Term.Norm diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index 0ff62e41f..d032d140b 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -18,10 +18,10 @@ import qualified Facet.Env as Env import Facet.Functor.Synth import Facet.Kind (Kind) import Facet.Name -import Facet.Pattern import qualified Facet.Snoc as S import Facet.Syntax import Facet.Syntax.Norm.Type +import Facet.Syntax.Pattern import Facet.Usage import GHC.Stack import Prelude hiding (lookup) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index d7945152a..97fa10c14 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -76,7 +76,6 @@ import Facet.Kind import Facet.Lens hiding (use) import Facet.Module import Facet.Name hiding (L, R) -import Facet.Pattern import Facet.Quote import Facet.Semiring import Facet.Snoc @@ -87,6 +86,7 @@ import Facet.Subst import Facet.Syntax hiding (context_) import qualified Facet.Syntax.Expr.Type as TX import Facet.Syntax.Norm.Type as TN +import Facet.Syntax.Pattern import Facet.Term.Expr as E import Facet.Usage as Usage import Facet.Vars as Vars diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 466424152..b542e078e 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -77,7 +77,6 @@ import Facet.Kind import Facet.Lens as Lens (locally, view, views, (.=), (<~)) import Facet.Module as Module import Facet.Name -import Facet.Pattern import Facet.Semiring (Few(..), (><<)) import qualified Facet.Sequent.Class as SQ import Facet.Snoc @@ -90,6 +89,7 @@ import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) import qualified Facet.Syntax.Expr.Type as TX import Facet.Syntax.Norm.Type as T hiding (global) +import Facet.Syntax.Pattern import Facet.Term.Expr as E import Facet.Unify import Facet.Usage hiding (restrict) diff --git a/src/Facet/Env.hs b/src/Facet/Env.hs index 1420f600a..d7d5bf4cb 100644 --- a/src/Facet/Env.hs +++ b/src/Facet/Env.hs @@ -11,9 +11,9 @@ import Control.Applicative ((<|>)) import Control.Monad (guard) import Data.Maybe (fromMaybe) import Facet.Name -import Facet.Pattern import Facet.Snoc import Facet.Syntax +import Facet.Syntax.Pattern import GHC.Stack import Prelude hiding (lookup) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 06326014d..82608d7f5 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -40,11 +40,11 @@ import Facet.Env as Env import Facet.Graph import Facet.Module import Facet.Name hiding (Op) -import Facet.Pattern import Facet.Quote import Facet.Semialign (zipWithM) import Facet.Snoc.NonEmpty as NE hiding ((|>)) import Facet.Syntax +import Facet.Syntax.Pattern import Facet.Term.Expr import GHC.Stack (HasCallStack) import Prelude hiding (zipWith) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 7078f30b9..2906fd7f9 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -15,7 +15,6 @@ import Facet.Functor.Synth import Facet.Interface (interfaces) import Facet.Name (LName(..)) import Facet.Notice as Notice hiding (level) -import Facet.Pattern import Facet.Pretty import Facet.Print as Print import Facet.Semiring (Few(..), one, zero) @@ -24,6 +23,7 @@ import Facet.Style import Facet.Subst (metas) import Facet.Syntax hiding (ann) import Facet.Syntax.Norm.Type (apply, free, metavar) +import Facet.Syntax.Pattern import GHC.Stack import Prelude hiding (print, unlines) import Silkscreen diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 4a4e47cd1..2e699e508 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -34,7 +34,6 @@ import Facet.Interface import Facet.Kind import qualified Facet.Module as C import Facet.Name as Name hiding (name) -import Facet.Pattern import Facet.Pretty (lower, upper) import Facet.Print.Options import Facet.Quote @@ -44,6 +43,7 @@ import Facet.Style import Facet.Syntax hiding (Ann(..)) import qualified Facet.Syntax.Expr.Type as TX import qualified Facet.Syntax.Norm.Type as TN +import Facet.Syntax.Pattern import qualified Facet.Term.Expr as C import qualified Facet.Term.Norm as N import Prelude hiding (print) diff --git a/src/Facet/Syntax/Norm/Type.hs b/src/Facet/Syntax/Norm/Type.hs index b2f6a11a3..1367ac708 100644 --- a/src/Facet/Syntax/Norm/Type.hs +++ b/src/Facet/Syntax/Norm/Type.hs @@ -29,12 +29,12 @@ import Facet.Env hiding (empty) import Facet.Interface import Facet.Kind import Facet.Name -import Facet.Pattern import Facet.Quote import Facet.Snoc import Facet.Subst import Facet.Syntax import qualified Facet.Syntax.Expr.Type as TX +import Facet.Syntax.Pattern import qualified Facet.Type.Class as C import Facet.Usage hiding (singleton) import Fresnel.Prism (Prism', prism') diff --git a/src/Facet/Pattern.hs b/src/Facet/Syntax/Pattern.hs similarity index 96% rename from src/Facet/Pattern.hs rename to src/Facet/Syntax/Pattern.hs index 703a69091..afc19ab41 100644 --- a/src/Facet/Pattern.hs +++ b/src/Facet/Syntax/Pattern.hs @@ -1,4 +1,4 @@ -module Facet.Pattern +module Facet.Syntax.Pattern ( -- * Patterns Pattern(..) , _PWildcard diff --git a/src/Facet/Term/Expr.hs b/src/Facet/Term/Expr.hs index ee9b73fce..7b23f40f0 100644 --- a/src/Facet/Term/Expr.hs +++ b/src/Facet/Term/Expr.hs @@ -5,8 +5,8 @@ module Facet.Term.Expr import Data.Text (Text) import Facet.Name -import Facet.Pattern import Facet.Syntax +import Facet.Syntax.Pattern -- Term expressions diff --git a/src/Facet/Term/Norm.hs b/src/Facet/Term/Norm.hs index ff5fb2051..eb11ff703 100644 --- a/src/Facet/Term/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -11,11 +11,11 @@ import Data.Text (Text) import Data.Traversable (mapAccumL) import Facet.Env import Facet.Name -import Facet.Pattern import Facet.Quote import Facet.Semialign (zipWithM) import Facet.Snoc import Facet.Syntax +import Facet.Syntax.Pattern import qualified Facet.Term.Expr as X data Term From 10057e78bf6713c6937c8fbd85517fe4f5296b66 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Feb 2022 22:24:33 -0500 Subject: [PATCH 0686/1324] :fire: an unused language extension. --- src/Facet/Eval.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 82608d7f5..9ff8862c7 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} From 478c23439b8079655b7add7db0409b6c2854a6fc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Feb 2022 22:27:09 -0500 Subject: [PATCH 0687/1324] Rename Facet.Type.Class to Facet.Syntax.Class.Type. --- facet.cabal | 2 +- src/Facet/{Type/Class.hs => Syntax/Class/Type.hs} | 2 +- src/Facet/Syntax/Expr/Type.hs | 2 +- src/Facet/Syntax/Norm/Type.hs | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) rename src/Facet/{Type/Class.hs => Syntax/Class/Type.hs} (95%) diff --git a/facet.cabal b/facet.cabal index 14737b8e1..6f9fcfad2 100644 --- a/facet.cabal +++ b/facet.cabal @@ -133,6 +133,7 @@ library Facet.Surface.Type.Class Facet.Surface.Type.Expr Facet.Syntax + Facet.Syntax.Class.Type Facet.Syntax.Expr.Type Facet.Syntax.Norm.Type Facet.Syntax.Pattern @@ -140,7 +141,6 @@ library Facet.Term.Expr Facet.Term.Norm Facet.Timing - Facet.Type.Class Facet.Unify Facet.Usage Facet.Vars diff --git a/src/Facet/Type/Class.hs b/src/Facet/Syntax/Class/Type.hs similarity index 95% rename from src/Facet/Type/Class.hs rename to src/Facet/Syntax/Class/Type.hs index 77f25c7a6..b2ea6d8ee 100644 --- a/src/Facet/Type/Class.hs +++ b/src/Facet/Syntax/Class/Type.hs @@ -1,4 +1,4 @@ -module Facet.Type.Class +module Facet.Syntax.Class.Type ( -- * Types Type(..) , forAllA diff --git a/src/Facet/Syntax/Expr/Type.hs b/src/Facet/Syntax/Expr/Type.hs index 3e14d69bb..d8f26e391 100644 --- a/src/Facet/Syntax/Expr/Type.hs +++ b/src/Facet/Syntax/Expr/Type.hs @@ -8,7 +8,7 @@ import Facet.Kind import Facet.Name import Facet.Quote import Facet.Syntax -import qualified Facet.Type.Class as C +import qualified Facet.Syntax.Class.Type as C import Facet.Usage data Type diff --git a/src/Facet/Syntax/Norm/Type.hs b/src/Facet/Syntax/Norm/Type.hs index 1367ac708..16344738d 100644 --- a/src/Facet/Syntax/Norm/Type.hs +++ b/src/Facet/Syntax/Norm/Type.hs @@ -33,9 +33,9 @@ import Facet.Quote import Facet.Snoc import Facet.Subst import Facet.Syntax +import qualified Facet.Syntax.Class.Type as C import qualified Facet.Syntax.Expr.Type as TX import Facet.Syntax.Pattern -import qualified Facet.Type.Class as C import Facet.Usage hiding (singleton) import Fresnel.Prism (Prism', prism') import GHC.Stack From 4800e430c0a9b9b992c5bb5119e05b90379831e9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Feb 2022 22:28:35 -0500 Subject: [PATCH 0688/1324] Revert "Rename Facet.Type.Class to Facet.Syntax.Class.Type." This reverts commit 478c23439b8079655b7add7db0409b6c2854a6fc. --- facet.cabal | 2 +- src/Facet/Syntax/Expr/Type.hs | 2 +- src/Facet/Syntax/Norm/Type.hs | 2 +- src/Facet/{Syntax/Class/Type.hs => Type/Class.hs} | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) rename src/Facet/{Syntax/Class/Type.hs => Type/Class.hs} (95%) diff --git a/facet.cabal b/facet.cabal index 6f9fcfad2..14737b8e1 100644 --- a/facet.cabal +++ b/facet.cabal @@ -133,7 +133,6 @@ library Facet.Surface.Type.Class Facet.Surface.Type.Expr Facet.Syntax - Facet.Syntax.Class.Type Facet.Syntax.Expr.Type Facet.Syntax.Norm.Type Facet.Syntax.Pattern @@ -141,6 +140,7 @@ library Facet.Term.Expr Facet.Term.Norm Facet.Timing + Facet.Type.Class Facet.Unify Facet.Usage Facet.Vars diff --git a/src/Facet/Syntax/Expr/Type.hs b/src/Facet/Syntax/Expr/Type.hs index d8f26e391..3e14d69bb 100644 --- a/src/Facet/Syntax/Expr/Type.hs +++ b/src/Facet/Syntax/Expr/Type.hs @@ -8,7 +8,7 @@ import Facet.Kind import Facet.Name import Facet.Quote import Facet.Syntax -import qualified Facet.Syntax.Class.Type as C +import qualified Facet.Type.Class as C import Facet.Usage data Type diff --git a/src/Facet/Syntax/Norm/Type.hs b/src/Facet/Syntax/Norm/Type.hs index 16344738d..1367ac708 100644 --- a/src/Facet/Syntax/Norm/Type.hs +++ b/src/Facet/Syntax/Norm/Type.hs @@ -33,9 +33,9 @@ import Facet.Quote import Facet.Snoc import Facet.Subst import Facet.Syntax -import qualified Facet.Syntax.Class.Type as C import qualified Facet.Syntax.Expr.Type as TX import Facet.Syntax.Pattern +import qualified Facet.Type.Class as C import Facet.Usage hiding (singleton) import Fresnel.Prism (Prism', prism') import GHC.Stack diff --git a/src/Facet/Syntax/Class/Type.hs b/src/Facet/Type/Class.hs similarity index 95% rename from src/Facet/Syntax/Class/Type.hs rename to src/Facet/Type/Class.hs index b2ea6d8ee..77f25c7a6 100644 --- a/src/Facet/Syntax/Class/Type.hs +++ b/src/Facet/Type/Class.hs @@ -1,4 +1,4 @@ -module Facet.Syntax.Class.Type +module Facet.Type.Class ( -- * Types Type(..) , forAllA From 2d3ef1e13607bc9f3ff5403ae11d0d3db473cc77 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Feb 2022 22:28:41 -0500 Subject: [PATCH 0689/1324] Revert "Rename Facet.Pattern to Facet.Syntax.Pattern." This reverts commit 81f4c0661a28386b7f97e8a6c591da9cdfcbce8b. --- facet.cabal | 2 +- src/Facet/Context.hs | 2 +- src/Facet/Elab.hs | 2 +- src/Facet/Elab/Term.hs | 2 +- src/Facet/Env.hs | 2 +- src/Facet/Eval.hs | 2 +- src/Facet/Notice/Elab.hs | 2 +- src/Facet/{Syntax => }/Pattern.hs | 2 +- src/Facet/Print.hs | 2 +- src/Facet/Syntax/Norm/Type.hs | 2 +- src/Facet/Term/Expr.hs | 2 +- src/Facet/Term/Norm.hs | 2 +- 12 files changed, 12 insertions(+), 12 deletions(-) rename src/Facet/{Syntax => }/Pattern.hs (96%) diff --git a/facet.cabal b/facet.cabal index 14737b8e1..4eda6583d 100644 --- a/facet.cabal +++ b/facet.cabal @@ -107,6 +107,7 @@ library Facet.Notice.Parser Facet.Parser Facet.Parser.Table + Facet.Pattern Facet.Polarized Facet.Pretty Facet.Print @@ -135,7 +136,6 @@ library Facet.Syntax Facet.Syntax.Expr.Type Facet.Syntax.Norm.Type - Facet.Syntax.Pattern Facet.Term.Class Facet.Term.Expr Facet.Term.Norm diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index d032d140b..0ff62e41f 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -18,10 +18,10 @@ import qualified Facet.Env as Env import Facet.Functor.Synth import Facet.Kind (Kind) import Facet.Name +import Facet.Pattern import qualified Facet.Snoc as S import Facet.Syntax import Facet.Syntax.Norm.Type -import Facet.Syntax.Pattern import Facet.Usage import GHC.Stack import Prelude hiding (lookup) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 97fa10c14..d7945152a 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -76,6 +76,7 @@ import Facet.Kind import Facet.Lens hiding (use) import Facet.Module import Facet.Name hiding (L, R) +import Facet.Pattern import Facet.Quote import Facet.Semiring import Facet.Snoc @@ -86,7 +87,6 @@ import Facet.Subst import Facet.Syntax hiding (context_) import qualified Facet.Syntax.Expr.Type as TX import Facet.Syntax.Norm.Type as TN -import Facet.Syntax.Pattern import Facet.Term.Expr as E import Facet.Usage as Usage import Facet.Vars as Vars diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index b542e078e..466424152 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -77,6 +77,7 @@ import Facet.Kind import Facet.Lens as Lens (locally, view, views, (.=), (<~)) import Facet.Module as Module import Facet.Name +import Facet.Pattern import Facet.Semiring (Few(..), (><<)) import qualified Facet.Sequent.Class as SQ import Facet.Snoc @@ -89,7 +90,6 @@ import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) import qualified Facet.Syntax.Expr.Type as TX import Facet.Syntax.Norm.Type as T hiding (global) -import Facet.Syntax.Pattern import Facet.Term.Expr as E import Facet.Unify import Facet.Usage hiding (restrict) diff --git a/src/Facet/Env.hs b/src/Facet/Env.hs index d7d5bf4cb..1420f600a 100644 --- a/src/Facet/Env.hs +++ b/src/Facet/Env.hs @@ -11,9 +11,9 @@ import Control.Applicative ((<|>)) import Control.Monad (guard) import Data.Maybe (fromMaybe) import Facet.Name +import Facet.Pattern import Facet.Snoc import Facet.Syntax -import Facet.Syntax.Pattern import GHC.Stack import Prelude hiding (lookup) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 9ff8862c7..75e9541bb 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -39,11 +39,11 @@ import Facet.Env as Env import Facet.Graph import Facet.Module import Facet.Name hiding (Op) +import Facet.Pattern import Facet.Quote import Facet.Semialign (zipWithM) import Facet.Snoc.NonEmpty as NE hiding ((|>)) import Facet.Syntax -import Facet.Syntax.Pattern import Facet.Term.Expr import GHC.Stack (HasCallStack) import Prelude hiding (zipWith) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 2906fd7f9..7078f30b9 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -15,6 +15,7 @@ import Facet.Functor.Synth import Facet.Interface (interfaces) import Facet.Name (LName(..)) import Facet.Notice as Notice hiding (level) +import Facet.Pattern import Facet.Pretty import Facet.Print as Print import Facet.Semiring (Few(..), one, zero) @@ -23,7 +24,6 @@ import Facet.Style import Facet.Subst (metas) import Facet.Syntax hiding (ann) import Facet.Syntax.Norm.Type (apply, free, metavar) -import Facet.Syntax.Pattern import GHC.Stack import Prelude hiding (print, unlines) import Silkscreen diff --git a/src/Facet/Syntax/Pattern.hs b/src/Facet/Pattern.hs similarity index 96% rename from src/Facet/Syntax/Pattern.hs rename to src/Facet/Pattern.hs index afc19ab41..703a69091 100644 --- a/src/Facet/Syntax/Pattern.hs +++ b/src/Facet/Pattern.hs @@ -1,4 +1,4 @@ -module Facet.Syntax.Pattern +module Facet.Pattern ( -- * Patterns Pattern(..) , _PWildcard diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 2e699e508..4a4e47cd1 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -34,6 +34,7 @@ import Facet.Interface import Facet.Kind import qualified Facet.Module as C import Facet.Name as Name hiding (name) +import Facet.Pattern import Facet.Pretty (lower, upper) import Facet.Print.Options import Facet.Quote @@ -43,7 +44,6 @@ import Facet.Style import Facet.Syntax hiding (Ann(..)) import qualified Facet.Syntax.Expr.Type as TX import qualified Facet.Syntax.Norm.Type as TN -import Facet.Syntax.Pattern import qualified Facet.Term.Expr as C import qualified Facet.Term.Norm as N import Prelude hiding (print) diff --git a/src/Facet/Syntax/Norm/Type.hs b/src/Facet/Syntax/Norm/Type.hs index 1367ac708..b2f6a11a3 100644 --- a/src/Facet/Syntax/Norm/Type.hs +++ b/src/Facet/Syntax/Norm/Type.hs @@ -29,12 +29,12 @@ import Facet.Env hiding (empty) import Facet.Interface import Facet.Kind import Facet.Name +import Facet.Pattern import Facet.Quote import Facet.Snoc import Facet.Subst import Facet.Syntax import qualified Facet.Syntax.Expr.Type as TX -import Facet.Syntax.Pattern import qualified Facet.Type.Class as C import Facet.Usage hiding (singleton) import Fresnel.Prism (Prism', prism') diff --git a/src/Facet/Term/Expr.hs b/src/Facet/Term/Expr.hs index 7b23f40f0..ee9b73fce 100644 --- a/src/Facet/Term/Expr.hs +++ b/src/Facet/Term/Expr.hs @@ -5,8 +5,8 @@ module Facet.Term.Expr import Data.Text (Text) import Facet.Name +import Facet.Pattern import Facet.Syntax -import Facet.Syntax.Pattern -- Term expressions diff --git a/src/Facet/Term/Norm.hs b/src/Facet/Term/Norm.hs index eb11ff703..ff5fb2051 100644 --- a/src/Facet/Term/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -11,11 +11,11 @@ import Data.Text (Text) import Data.Traversable (mapAccumL) import Facet.Env import Facet.Name +import Facet.Pattern import Facet.Quote import Facet.Semialign (zipWithM) import Facet.Snoc import Facet.Syntax -import Facet.Syntax.Pattern import qualified Facet.Term.Expr as X data Term From 0fbf9d297c9cdb96e5126f02e7619cb55e6f644d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Feb 2022 22:28:44 -0500 Subject: [PATCH 0690/1324] Revert "Rename Facet.Type.Expr to Facet.Syntax.Expr.Type." This reverts commit 7be40db40c6d0d4838e515a5cdc6f4c8e7368419. --- facet.cabal | 2 +- src/Facet/Elab.hs | 2 +- src/Facet/Elab/Term.hs | 2 +- src/Facet/Elab/Type.hs | 2 +- src/Facet/Print.hs | 2 +- src/Facet/Syntax/Norm/Type.hs | 2 +- src/Facet/{Syntax/Expr/Type.hs => Type/Expr.hs} | 2 +- src/Facet/Unify.hs | 2 +- test/Facet/Core/Type/Test.hs | 2 +- 9 files changed, 9 insertions(+), 9 deletions(-) rename src/Facet/{Syntax/Expr/Type.hs => Type/Expr.hs} (96%) diff --git a/facet.cabal b/facet.cabal index 4eda6583d..96d84241d 100644 --- a/facet.cabal +++ b/facet.cabal @@ -134,13 +134,13 @@ library Facet.Surface.Type.Class Facet.Surface.Type.Expr Facet.Syntax - Facet.Syntax.Expr.Type Facet.Syntax.Norm.Type Facet.Term.Class Facet.Term.Expr Facet.Term.Norm Facet.Timing Facet.Type.Class + Facet.Type.Expr Facet.Unify Facet.Usage Facet.Vars diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index d7945152a..ab5feba13 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -85,9 +85,9 @@ import Facet.Source (Source, slice) import Facet.Span (Span(..)) import Facet.Subst import Facet.Syntax hiding (context_) -import qualified Facet.Syntax.Expr.Type as TX import Facet.Syntax.Norm.Type as TN import Facet.Term.Expr as E +import qualified Facet.Type.Expr as TX import Facet.Usage as Usage import Facet.Vars as Vars import Fresnel.Fold ((^?)) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 466424152..218b65ced 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -88,9 +88,9 @@ import qualified Facet.Surface.Module as S import qualified Facet.Surface.Term.Expr as S import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) -import qualified Facet.Syntax.Expr.Type as TX import Facet.Syntax.Norm.Type as T hiding (global) import Facet.Term.Expr as E +import qualified Facet.Type.Expr as TX import Facet.Unify import Facet.Usage hiding (restrict) import Fresnel.At as At diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 9572bac6c..3c1bab91f 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -29,8 +29,8 @@ import Facet.Snoc import Facet.Subst import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) -import qualified Facet.Syntax.Expr.Type as TX import Facet.Syntax.Norm.Type +import qualified Facet.Type.Expr as TX import GHC.Stack tvar :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (TX.Type :==> Kind) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 4a4e47cd1..1e1a3a41f 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -42,10 +42,10 @@ import Facet.Semiring (one, zero) import Facet.Snoc import Facet.Style import Facet.Syntax hiding (Ann(..)) -import qualified Facet.Syntax.Expr.Type as TX import qualified Facet.Syntax.Norm.Type as TN import qualified Facet.Term.Expr as C import qualified Facet.Term.Norm as N +import qualified Facet.Type.Expr as TX import Prelude hiding (print) import qualified Prettyprinter as PP import Silkscreen as P diff --git a/src/Facet/Syntax/Norm/Type.hs b/src/Facet/Syntax/Norm/Type.hs index b2f6a11a3..3ad9c9cf6 100644 --- a/src/Facet/Syntax/Norm/Type.hs +++ b/src/Facet/Syntax/Norm/Type.hs @@ -34,8 +34,8 @@ import Facet.Quote import Facet.Snoc import Facet.Subst import Facet.Syntax -import qualified Facet.Syntax.Expr.Type as TX import qualified Facet.Type.Class as C +import qualified Facet.Type.Expr as TX import Facet.Usage hiding (singleton) import Fresnel.Prism (Prism', prism') import GHC.Stack diff --git a/src/Facet/Syntax/Expr/Type.hs b/src/Facet/Type/Expr.hs similarity index 96% rename from src/Facet/Syntax/Expr/Type.hs rename to src/Facet/Type/Expr.hs index 3e14d69bb..2f8e65e7c 100644 --- a/src/Facet/Syntax/Expr/Type.hs +++ b/src/Facet/Type/Expr.hs @@ -1,4 +1,4 @@ -module Facet.Syntax.Expr.Type +module Facet.Type.Expr ( Type(..) ) where diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index f0f1477cf..32335f8cf 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -28,8 +28,8 @@ import Facet.Semialign import Facet.Snoc import Facet.Subst import Facet.Syntax -import qualified Facet.Syntax.Expr.Type as TX import Facet.Syntax.Norm.Type as TN +import qualified Facet.Type.Expr as TX import Facet.Usage import GHC.Stack diff --git a/test/Facet/Core/Type/Test.hs b/test/Facet/Core/Type/Test.hs index 13544ce38..a1bdee382 100644 --- a/test/Facet/Core/Type/Test.hs +++ b/test/Facet/Core/Type/Test.hs @@ -10,7 +10,7 @@ import Facet.Name import Facet.Quote import Facet.Semiring import Facet.Syntax -import Facet.Syntax.Expr.Type +import Facet.Type.Expr import Facet.Syntax.Norm.Type (eval) import Hedgehog hiding (Var, eval) From b23e683ae42b20f9d5444cf1c8413ea2538b812c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Feb 2022 22:28:49 -0500 Subject: [PATCH 0691/1324] Revert "Move the normalized type module under Syntax." This reverts commit b844cabd5e0f2eeda2c53d32c4046bb24121e96c. --- facet.cabal | 2 +- src/Facet/Context.hs | 2 +- src/Facet/Elab.hs | 2 +- src/Facet/Elab/Term.hs | 2 +- src/Facet/Elab/Type.hs | 2 +- src/Facet/Module.hs | 2 +- src/Facet/Notice/Elab.hs | 2 +- src/Facet/Print.hs | 2 +- src/Facet/{Syntax/Norm/Type.hs => Type/Norm.hs} | 6 +++--- src/Facet/Unify.hs | 2 +- test/Facet/Core/Type/Test.hs | 2 +- 11 files changed, 13 insertions(+), 13 deletions(-) rename src/Facet/{Syntax/Norm/Type.hs => Type/Norm.hs} (97%) diff --git a/facet.cabal b/facet.cabal index 96d84241d..322546673 100644 --- a/facet.cabal +++ b/facet.cabal @@ -134,13 +134,13 @@ library Facet.Surface.Type.Class Facet.Surface.Type.Expr Facet.Syntax - Facet.Syntax.Norm.Type Facet.Term.Class Facet.Term.Expr Facet.Term.Norm Facet.Timing Facet.Type.Class Facet.Type.Expr + Facet.Type.Norm Facet.Unify Facet.Usage Facet.Vars diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index 0ff62e41f..649c4bcf8 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -21,7 +21,7 @@ import Facet.Name import Facet.Pattern import qualified Facet.Snoc as S import Facet.Syntax -import Facet.Syntax.Norm.Type +import Facet.Type.Norm import Facet.Usage import GHC.Stack import Prelude hiding (lookup) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index ab5feba13..cfe0a885c 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -85,9 +85,9 @@ import Facet.Source (Source, slice) import Facet.Span (Span(..)) import Facet.Subst import Facet.Syntax hiding (context_) -import Facet.Syntax.Norm.Type as TN import Facet.Term.Expr as E import qualified Facet.Type.Expr as TX +import Facet.Type.Norm as TN import Facet.Usage as Usage import Facet.Vars as Vars import Fresnel.Fold ((^?)) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 218b65ced..4068c0ab9 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -88,9 +88,9 @@ import qualified Facet.Surface.Module as S import qualified Facet.Surface.Term.Expr as S import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) -import Facet.Syntax.Norm.Type as T hiding (global) import Facet.Term.Expr as E import qualified Facet.Type.Expr as TX +import Facet.Type.Norm as T hiding (global) import Facet.Unify import Facet.Usage hiding (restrict) import Fresnel.At as At diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 3c1bab91f..9806c47f6 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -29,8 +29,8 @@ import Facet.Snoc import Facet.Subst import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) -import Facet.Syntax.Norm.Type import qualified Facet.Type.Expr as TX +import Facet.Type.Norm import GHC.Stack tvar :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (TX.Type :==> Kind) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 55cba285a..9639075b9 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -40,8 +40,8 @@ import qualified Data.Map as Map import Facet.Kind import Facet.Name import Facet.Syntax -import Facet.Syntax.Norm.Type import Facet.Term.Expr +import Facet.Type.Norm import Fresnel.Fold (preview) import Fresnel.Getter (view) import Fresnel.Iso (Iso, coerced, fmapping, iso) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 7078f30b9..b1e028a0e 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -23,7 +23,7 @@ import Facet.Snoc import Facet.Style import Facet.Subst (metas) import Facet.Syntax hiding (ann) -import Facet.Syntax.Norm.Type (apply, free, metavar) +import Facet.Type.Norm (apply, free, metavar) import GHC.Stack import Prelude hiding (print, unlines) import Silkscreen diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 1e1a3a41f..48398ca49 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -42,10 +42,10 @@ import Facet.Semiring (one, zero) import Facet.Snoc import Facet.Style import Facet.Syntax hiding (Ann(..)) -import qualified Facet.Syntax.Norm.Type as TN import qualified Facet.Term.Expr as C import qualified Facet.Term.Norm as N import qualified Facet.Type.Expr as TX +import qualified Facet.Type.Norm as TN import Prelude hiding (print) import qualified Prettyprinter as PP import Silkscreen as P diff --git a/src/Facet/Syntax/Norm/Type.hs b/src/Facet/Type/Norm.hs similarity index 97% rename from src/Facet/Syntax/Norm/Type.hs rename to src/Facet/Type/Norm.hs index 3ad9c9cf6..a8a7bdbb1 100644 --- a/src/Facet/Syntax/Norm/Type.hs +++ b/src/Facet/Type/Norm.hs @@ -1,4 +1,4 @@ -module Facet.Syntax.Norm.Type +module Facet.Type.Norm ( -- * Types Type(..) , _String @@ -55,8 +55,8 @@ instance C.Type Type where string = String forAll = ForAll arrow = Arrow - var = Facet.Syntax.Norm.Type.var - ($$) = (Facet.Syntax.Norm.Type.$$) + var = Facet.Type.Norm.var + ($$) = (Facet.Type.Norm.$$) (|-) = Comp instance Quote Type TX.Type where diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index 32335f8cf..9c6caee12 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -28,8 +28,8 @@ import Facet.Semialign import Facet.Snoc import Facet.Subst import Facet.Syntax -import Facet.Syntax.Norm.Type as TN import qualified Facet.Type.Expr as TX +import Facet.Type.Norm as TN import Facet.Usage import GHC.Stack diff --git a/test/Facet/Core/Type/Test.hs b/test/Facet/Core/Type/Test.hs index a1bdee382..689470336 100644 --- a/test/Facet/Core/Type/Test.hs +++ b/test/Facet/Core/Type/Test.hs @@ -11,7 +11,7 @@ import Facet.Quote import Facet.Semiring import Facet.Syntax import Facet.Type.Expr -import Facet.Syntax.Norm.Type (eval) +import Facet.Type.Norm (eval) import Hedgehog hiding (Var, eval) tests :: IO Bool From cb28963792ee114cc57e1744a0c8662cb6e9d5d4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 25 Feb 2022 00:46:25 -0500 Subject: [PATCH 0692/1324] Define clauses. --- src/Facet/Elab/Pattern.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 6989ac3a9..95e440fe9 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -1,2 +1,7 @@ module Facet.Elab.Pattern -() where +( Clause(..) +) where + +import Facet.Pattern + +newtype Clause = Clause [Pattern ()] From 196eeeb7d9d2a1d3635d9515fe82a94ab0510236 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 25 Feb 2022 00:46:55 -0500 Subject: [PATCH 0693/1324] Define an iso on clauses. --- src/Facet/Elab/Pattern.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 95e440fe9..a84ee0f03 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -1,7 +1,12 @@ module Facet.Elab.Pattern ( Clause(..) +, patterns_ ) where import Facet.Pattern +import Fresnel.Iso newtype Clause = Clause [Pattern ()] + +patterns_ :: Iso' Clause [Pattern ()] +patterns_ = coerced From b0cc202383b537099ea8bbc932c201ab9ec4f3d1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 25 Feb 2022 00:47:11 -0500 Subject: [PATCH 0694/1324] Define tableaux. --- src/Facet/Elab/Pattern.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index a84ee0f03..7f8907691 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -1,6 +1,7 @@ module Facet.Elab.Pattern ( Clause(..) , patterns_ +, Tableau(..) ) where import Facet.Pattern @@ -10,3 +11,5 @@ newtype Clause = Clause [Pattern ()] patterns_ :: Iso' Clause [Pattern ()] patterns_ = coerced + +newtype Tableau = Tableau [Clause] From 8a94053116402fb7607765aa96ce9617e1fd5b88 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 25 Feb 2022 00:47:40 -0500 Subject: [PATCH 0695/1324] Define an iso over tableaux. --- src/Facet/Elab/Pattern.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 7f8907691..a6a7f0e0e 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -2,6 +2,7 @@ module Facet.Elab.Pattern ( Clause(..) , patterns_ , Tableau(..) +, clauses_ ) where import Facet.Pattern @@ -13,3 +14,6 @@ patterns_ :: Iso' Clause [Pattern ()] patterns_ = coerced newtype Tableau = Tableau [Clause] + +clauses_ :: Iso' Tableau [Clause] +clauses_ = coerced From 7534143a740500679ebc336787167f38e9586bee Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 25 Feb 2022 00:48:25 -0500 Subject: [PATCH 0696/1324] Parameterize Clause. --- src/Facet/Elab/Pattern.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index a6a7f0e0e..41ff3905d 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -8,12 +8,12 @@ module Facet.Elab.Pattern import Facet.Pattern import Fresnel.Iso -newtype Clause = Clause [Pattern ()] +newtype Clause a = Clause [Pattern a] -patterns_ :: Iso' Clause [Pattern ()] +patterns_ :: Iso' (Clause a) [Pattern a] patterns_ = coerced -newtype Tableau = Tableau [Clause] +newtype Tableau = Tableau [Clause ()] -clauses_ :: Iso' Tableau [Clause] +clauses_ :: Iso' Tableau [Clause ()] clauses_ = coerced From 5110472bd2c827c9d83093216e1256ea4e50d148 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 25 Feb 2022 00:49:00 -0500 Subject: [PATCH 0697/1324] Parameterize Tableau. --- src/Facet/Elab/Pattern.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 41ff3905d..4314775b9 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -13,7 +13,7 @@ newtype Clause a = Clause [Pattern a] patterns_ :: Iso' (Clause a) [Pattern a] patterns_ = coerced -newtype Tableau = Tableau [Clause ()] +newtype Tableau a = Tableau [Clause a] -clauses_ :: Iso' Tableau [Clause ()] +clauses_ :: Iso' (Tableau a) [Clause a] clauses_ = coerced From c16480c5d13c25e7dc4e743e403ece991439f810 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 25 Feb 2022 01:05:55 -0500 Subject: [PATCH 0698/1324] Define branches. --- src/Facet/Elab/Pattern.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 4314775b9..e7bb2d45d 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -1,11 +1,14 @@ +{-# LANGUAGE ExistentialQuantification #-} module Facet.Elab.Pattern ( Clause(..) , patterns_ , Tableau(..) , clauses_ +, Branch(..) ) where import Facet.Pattern +import Fresnel.Fold import Fresnel.Iso newtype Clause a = Clause [Pattern a] @@ -17,3 +20,6 @@ newtype Tableau a = Tableau [Clause a] clauses_ :: Iso' (Tableau a) [Clause a] clauses_ = coerced + + +data Branch s m a = forall x . Branch (Fold s x) (x -> m a) From 4cf99b4ce737a16410834dd68101fa07f240cf61 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 25 Feb 2022 21:06:21 -0500 Subject: [PATCH 0699/1324] Define a coverage judgement. --- src/Facet/Elab/Pattern.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index e7bb2d45d..303f5c47e 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -5,6 +5,8 @@ module Facet.Elab.Pattern , Tableau(..) , clauses_ , Branch(..) + -- * Coverage judgement +, Covers(..) ) where import Facet.Pattern @@ -23,3 +25,8 @@ clauses_ = coerced data Branch s m a = forall x . Branch (Fold s x) (x -> m a) + + +-- Coverage judgement + +newtype Covers m a = Covers { covers :: m a } From daab4b2c3ac4ee5c65e6146d4fd5f2d4d5d53291 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 25 Feb 2022 21:18:36 -0500 Subject: [PATCH 0700/1324] Define a unioning operator on Folds. --- src/Facet/Elab/Pattern.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 303f5c47e..07ef0c694 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -5,6 +5,7 @@ module Facet.Elab.Pattern , Tableau(..) , clauses_ , Branch(..) +, (\/) -- * Coverage judgement , Covers(..) ) where @@ -26,6 +27,11 @@ clauses_ = coerced data Branch s m a = forall x . Branch (Fold s x) (x -> m a) +(\/) :: Fold s a -> Fold s a -> Fold s a +f1 \/ f2 = getUnion (Union f1 <> Union f2) + +infixr 2 \/ + -- Coverage judgement From 7acd5546efc8ef8006e3fa9103367ba77a34674d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Feb 2022 11:30:51 -0500 Subject: [PATCH 0701/1324] Coverage takes a context. --- src/Facet/Elab/Pattern.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 07ef0c694..c183a6344 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -11,6 +11,7 @@ module Facet.Elab.Pattern ) where import Facet.Pattern +import Facet.Type.Norm (Type) import Fresnel.Fold import Fresnel.Iso @@ -35,4 +36,4 @@ infixr 2 \/ -- Coverage judgement -newtype Covers m a = Covers { covers :: m a } +newtype Covers m a = Covers { covers :: [Type] -> m a } From 26cb56312dd7933827c1db5a48627d1a047accff Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Feb 2022 11:34:33 -0500 Subject: [PATCH 0702/1324] Define coverage of a single type. --- src/Facet/Elab/Pattern.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index c183a6344..facb630cf 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -8,8 +8,11 @@ module Facet.Elab.Pattern , (\/) -- * Coverage judgement , Covers(..) +, coverOne ) where +import Control.Carrier.State.Church +import Control.Effect.Empty import Facet.Pattern import Facet.Type.Norm (Type) import Fresnel.Fold @@ -36,4 +39,10 @@ infixr 2 \/ -- Coverage judgement -newtype Covers m a = Covers { covers :: [Type] -> m a } +newtype Covers m a = Covers { covers :: StateC [Type] m a } + + +coverOne :: Has Empty sig m => Covers m () +coverOne = Covers $ get @[Type] >>= \case + [] -> empty + _:ctx -> put ctx From a98682e9cb43ac6f04066deba772ff6e33718299 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Feb 2022 17:25:58 -0500 Subject: [PATCH 0703/1324] Derive some instances. --- src/Facet/Elab/Pattern.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index facb630cf..06c767db4 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -40,6 +40,7 @@ infixr 2 \/ -- Coverage judgement newtype Covers m a = Covers { covers :: StateC [Type] m a } + deriving (Applicative, Functor, Monad) coverOne :: Has Empty sig m => Covers m () From 5990e1aefe7878655922888698cfb7e2d1981f56 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Feb 2022 19:17:57 -0500 Subject: [PATCH 0704/1324] Support ghc 9.2. --- facet.cabal | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/facet.cabal b/facet.cabal index 322546673..d02d5d694 100644 --- a/facet.cabal +++ b/facet.cabal @@ -35,6 +35,9 @@ common common ghc-options: -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module + if (impl(ghc >= 9.2)) + ghc-options: + -Wno-missing-kind-signatures default-extensions: DeriveTraversable DerivingStrategies @@ -150,7 +153,7 @@ library Paths_facet build-depends: , ansi-terminal - , base ^>= 4.14 + , base >= 4.14 && < 5 , charset , colour , containers @@ -188,8 +191,11 @@ test-suite test , base , containers , facet - , hedgehog ^>= 1 + , hedgehog >= 1 && < 1.2 , parsers + if (impl(ghc >= 9.2)) + ghc-options: + -Wno-missing-signatures executable facetc From c0c9c3a34c945c54ec1ee7cf3ee3a12ea81f58d3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Feb 2022 22:45:38 -0500 Subject: [PATCH 0705/1324] Impredicativity. --- src/Facet/REPL/Parser.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/REPL/Parser.hs b/src/Facet/REPL/Parser.hs index 363ac12b3..98189ef0a 100644 --- a/src/Facet/REPL/Parser.hs +++ b/src/Facet/REPL/Parser.hs @@ -33,7 +33,7 @@ command symbols usage meta parse = Commands parseCommands :: (Has Parser sig p, TokenParsing p) => Commands a -> p a -parseCommands = runCommandParser . _parseCommands +parseCommands c = runCommandParser (_parseCommands c) data Commands a = Commands { getCommands :: [Command] @@ -66,10 +66,10 @@ instance Alternative CommandParser where some (CommandParser m) = CommandParser (some m) instance Monad CommandParser where - m >>= f = CommandParser (runCommandParser m >>= runCommandParser . f) + m >>= f = CommandParser (runCommandParser m >>= \ a -> runCommandParser (f a)) instance Algebra Parser CommandParser where - alg hdl sig ctx = CommandParser $ alg (runCommandParser . hdl) (inj sig) ctx + alg hdl sig ctx = CommandParser $ alg (\ m -> runCommandParser (hdl m)) (inj sig) ctx instance Parsing CommandParser where try (CommandParser m) = CommandParser (try m) From c714de5551de87523c25aa0ac3336041d9d963fd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Feb 2022 22:54:13 -0500 Subject: [PATCH 0706/1324] Silence some warnings. --- src/Facet/Driver.hs | 2 +- src/Facet/Elab.hs | 4 ++-- src/Facet/Module.hs | 2 +- src/Facet/Print.hs | 3 +++ src/Facet/REPL.hs | 3 ++- src/Facet/Run.hs | 2 +- 6 files changed, 10 insertions(+), 6 deletions(-) diff --git a/src/Facet/Driver.hs b/src/Facet/Driver.hs index 49d158511..f58c42c09 100644 --- a/src/Facet/Driver.hs +++ b/src/Facet/Driver.hs @@ -106,7 +106,7 @@ reloadModules = do let nModules = length modules results <- for (zip [1..] modules) $ \ (i, h@(ModuleHeader name src _)) -> do graph <- use modules_ - let loaded = traverse (\ name -> graph^.at name >>= snd) h + let loaded = traverse (\ name -> graph ^. at name >>= snd) h case loaded of Just loaded -> (Just <$> do outputDocLn $ annotate Progress (brackets (ratio (i :: Int) nModules)) <+> nest 2 (group (fillSep [ pretty "Loading", prettyMName name ])) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index cfe0a885c..65f158e87 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -354,10 +354,10 @@ data ElabContext = ElabContext } context_ :: Lens' ElabContext Context -context_ = lens (\ ElabContext{ context } -> context) (\ e context -> (e :: ElabContext){ context }) +context_ = lens (\ ElabContext{ context } -> context) (\ ElabContext{ sig, spans } context -> ElabContext{ context, sig, spans }) sig_ :: Lens' ElabContext [Signature Type] -sig_ = lens (\ ElabContext{ sig } -> sig) (\ e sig -> (e :: ElabContext){ sig }) +sig_ = lens (\ ElabContext{ sig } -> sig) (\ ElabContext{ context, spans } sig -> ElabContext{ context, sig, spans }) spans_ :: Lens' ElabContext (Snoc Span) spans_ = lens spans (\ e spans -> e{ spans }) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 9639075b9..5b381473f 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -63,7 +63,7 @@ data Module = Module } name_ :: Lens' Module MName -name_ = lens (\ Module{ name } -> name) (\ m name -> (m :: Module){ name }) +name_ = lens (\ Module{ name } -> name) (\ Module{ imports, operators, scope } name -> Module{ name, imports, operators, scope }) imports_ :: Lens' Module [Import] imports_ = lens imports (\ m imports -> m{ imports }) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 48398ca49..4e4e333a1 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -121,6 +121,8 @@ f $$ a = askingPrec $ \case intro, tintro :: Name -> Level -> Print intro n = name lower n . getLevel tintro n = name upper n . getLevel + +qvar :: (P.Level p ~ Precedence, PrecedencePrinter p) => QName -> p qvar (_ :. n) = setPrec Var (pretty n) lname :: LName Level -> Print @@ -129,6 +131,7 @@ lname (LName d n) = intro n d meta :: Meta -> Print meta (Meta m) = setPrec Var $ annotate (Name m) $ pretty '?' <> upper m +local :: Name -> Level -> Print local n d = name lower n (getLevel d) name :: (Int -> Print) -> Name -> Int -> Print diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index a407071ca..773588459 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -38,6 +38,7 @@ import Facet.Graph import Facet.Interface as I import Facet.Lens import Facet.Module +import Facet.Module as Module (Module(..)) import Facet.Name as Name import qualified Facet.Notice as Notice import Facet.Notice.Elab @@ -247,4 +248,4 @@ runElab m = do graph <- use (target_.modules_) localDefs <- use localDefs_ opts <- get - runReader graph . runReader localDefs . runReader ((name :: Module -> MName) localDefs) . rethrowElabErrors opts . rethrowElabWarnings $ m + runReader graph . runReader localDefs . runReader (Module.name localDefs) . rethrowElabErrors opts . rethrowElabWarnings $ m diff --git a/src/Facet/Run.hs b/src/Facet/Run.hs index a29a5ff30..a956ef136 100644 --- a/src/Facet/Run.hs +++ b/src/Facet/Run.hs @@ -28,7 +28,7 @@ runFile searchPaths path = runStack $ do -- FIXME: look up and evaluate the main function in the module we were passed? ExitSuccess <$ for_ modules (\ h@(ModuleHeader name src _) -> do graph <- use modules_ - let loaded = traverse (\ name -> graph^.at name >>= snd) h + let loaded = traverse (\ name -> graph ^. at name >>= snd) h for_ loaded (storeModule name (Source.path (Source.reference src)) <=< loadModule graph)) where runStack From 05f9b57f619dddea0680068d5e8f0f93d0314aa2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 27 Feb 2022 10:49:34 -0500 Subject: [PATCH 0707/1324] Use optics to select the context. This is pointless now but should be more useful later. --- facet.cabal | 1 + src/Facet/Elab/Pattern.hs | 8 ++++++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/facet.cabal b/facet.cabal index d02d5d694..43020ff1c 100644 --- a/facet.cabal +++ b/facet.cabal @@ -161,6 +161,7 @@ library , exceptions ^>= 0.10 , filepath , fresnel + , fresnel-fused-effects , fused-effects , haskeline ^>= 0.8.1 , optparse-applicative diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 06c767db4..3f576f0eb 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -15,6 +15,7 @@ import Control.Carrier.State.Church import Control.Effect.Empty import Facet.Pattern import Facet.Type.Norm (Type) +import Fresnel.Effect import Fresnel.Fold import Fresnel.Iso @@ -44,6 +45,9 @@ newtype Covers m a = Covers { covers :: StateC [Type] m a } coverOne :: Has Empty sig m => Covers m () -coverOne = Covers $ get @[Type] >>= \case +coverOne = Covers $ use context_ >>= \case [] -> empty - _:ctx -> put ctx + _:ctx -> context_ .= ctx + +context_ :: Iso' [Type] [Type] +context_ = iso id id From 58eeb4026bb92f50a1a62b08ec1659429eb1a851 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 27 Feb 2022 10:57:43 -0500 Subject: [PATCH 0708/1324] Derive an Algebra instance for Covers. --- src/Facet/Elab/Pattern.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 3f576f0eb..49dd522d0 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -11,6 +11,7 @@ module Facet.Elab.Pattern , coverOne ) where +import Control.Algebra import Control.Carrier.State.Church import Control.Effect.Empty import Facet.Pattern @@ -41,11 +42,11 @@ infixr 2 \/ -- Coverage judgement newtype Covers m a = Covers { covers :: StateC [Type] m a } - deriving (Applicative, Functor, Monad) + deriving (Algebra (State [Type] :+: sig), Applicative, Functor, Monad) coverOne :: Has Empty sig m => Covers m () -coverOne = Covers $ use context_ >>= \case +coverOne = use context_ >>= \case [] -> empty _:ctx -> context_ .= ctx From d55e3917bb6d020417ad3e6f18098e9eae1003e3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 27 Feb 2022 11:03:26 -0500 Subject: [PATCH 0709/1324] Generalize patterns_. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 49dd522d0..95bcdb267 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -22,7 +22,7 @@ import Fresnel.Iso newtype Clause a = Clause [Pattern a] -patterns_ :: Iso' (Clause a) [Pattern a] +patterns_ :: Iso (Clause a) (Clause b) [Pattern a] [Pattern b] patterns_ = coerced newtype Tableau a = Tableau [Clause a] From bce581bd205bff279a9bd6086d72ec0bfce89616 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 27 Feb 2022 11:03:49 -0500 Subject: [PATCH 0710/1324] Generalize clauses_. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 95bcdb267..d6e95b997 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -27,7 +27,7 @@ patterns_ = coerced newtype Tableau a = Tableau [Clause a] -clauses_ :: Iso' (Tableau a) [Clause a] +clauses_ :: Iso (Tableau a) (Tableau b) [Clause a] [Clause b] clauses_ = coerced From f01a2d23bdcebbf06e49362c3156bb9517669267 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 27 Feb 2022 11:05:21 -0500 Subject: [PATCH 0711/1324] Tableaux hold contexts. --- src/Facet/Elab/Pattern.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index d6e95b997..cda075370 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -19,16 +19,17 @@ import Facet.Type.Norm (Type) import Fresnel.Effect import Fresnel.Fold import Fresnel.Iso +import Fresnel.Lens newtype Clause a = Clause [Pattern a] patterns_ :: Iso (Clause a) (Clause b) [Pattern a] [Pattern b] patterns_ = coerced -newtype Tableau a = Tableau [Clause a] +data Tableau a = Tableau [Type] [Clause a] -clauses_ :: Iso (Tableau a) (Tableau b) [Clause a] [Clause b] -clauses_ = coerced +clauses_ :: Lens (Tableau a) (Tableau b) [Clause a] [Clause b] +clauses_ = lens (\ (Tableau _ clauses) -> clauses) (\ (Tableau context _) clauses -> Tableau context clauses) data Branch s m a = forall x . Branch (Fold s x) (x -> m a) From 9917ffe35b562c73a1946336396f7834c3156b92 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 27 Feb 2022 11:09:40 -0500 Subject: [PATCH 0712/1324] context_ operates on tableaux. --- src/Facet/Elab/Pattern.hs | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index cda075370..3239599e6 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -14,6 +14,7 @@ module Facet.Elab.Pattern import Control.Algebra import Control.Carrier.State.Church import Control.Effect.Empty +import Facet.Name import Facet.Pattern import Facet.Type.Norm (Type) import Fresnel.Effect @@ -21,16 +22,19 @@ import Fresnel.Fold import Fresnel.Iso import Fresnel.Lens -newtype Clause a = Clause [Pattern a] +newtype Clause = Clause [Pattern Name] -patterns_ :: Iso (Clause a) (Clause b) [Pattern a] [Pattern b] +patterns_ :: Iso' Clause [Pattern Name] patterns_ = coerced -data Tableau a = Tableau [Type] [Clause a] +data Tableau = Tableau [Type] [Clause] -clauses_ :: Lens (Tableau a) (Tableau b) [Clause a] [Clause b] +clauses_ :: Lens' Tableau [Clause] clauses_ = lens (\ (Tableau _ clauses) -> clauses) (\ (Tableau context _) clauses -> Tableau context clauses) +context_ :: Lens' Tableau [Type] +context_ = lens (\ (Tableau context _) -> context) (\ (Tableau _ clauses) context -> Tableau context clauses) + data Branch s m a = forall x . Branch (Fold s x) (x -> m a) @@ -42,14 +46,11 @@ infixr 2 \/ -- Coverage judgement -newtype Covers m a = Covers { covers :: StateC [Type] m a } - deriving (Algebra (State [Type] :+: sig), Applicative, Functor, Monad) +newtype Covers m a = Covers { covers :: StateC Tableau m a } + deriving (Algebra (State Tableau :+: sig), Applicative, Functor, Monad) coverOne :: Has Empty sig m => Covers m () coverOne = use context_ >>= \case [] -> empty _:ctx -> context_ .= ctx - -context_ :: Iso' [Type] [Type] -context_ = iso id id From 1e0f6af140970c4457afa27953c8d7c14f03a416 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 27 Feb 2022 11:11:32 -0500 Subject: [PATCH 0713/1324] Field selectors. --- src/Facet/Elab/Pattern.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 3239599e6..7f338ea3c 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -27,7 +27,10 @@ newtype Clause = Clause [Pattern Name] patterns_ :: Iso' Clause [Pattern Name] patterns_ = coerced -data Tableau = Tableau [Type] [Clause] +data Tableau = Tableau + { context :: [Type] + , clauses :: [Clause] + } clauses_ :: Lens' Tableau [Clause] clauses_ = lens (\ (Tableau _ clauses) -> clauses) (\ (Tableau context _) clauses -> Tableau context clauses) From d6a7b100b03a41dd92aec44a15f005a7b4f466a4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 27 Feb 2022 11:12:51 -0500 Subject: [PATCH 0714/1324] Tidy up the lenses. --- src/Facet/Elab/Pattern.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 7f338ea3c..4a7107a60 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -33,10 +33,10 @@ data Tableau = Tableau } clauses_ :: Lens' Tableau [Clause] -clauses_ = lens (\ (Tableau _ clauses) -> clauses) (\ (Tableau context _) clauses -> Tableau context clauses) +clauses_ = lens clauses (\ t clauses -> t{clauses}) context_ :: Lens' Tableau [Type] -context_ = lens (\ (Tableau context _) -> context) (\ (Tableau _ clauses) context -> Tableau context clauses) +context_ = lens context (\ t context -> t{context}) data Branch s m a = forall x . Branch (Fold s x) (x -> m a) From 4b7266a649ea9a9f4f606234c4a8a95641375dec Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 27 Feb 2022 21:29:33 -0500 Subject: [PATCH 0715/1324] Match strings. --- src/Facet/Elab/Pattern.hs | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 4a7107a60..53e8906e7 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -9,18 +9,22 @@ module Facet.Elab.Pattern -- * Coverage judgement , Covers(..) , coverOne +, coverStep ) where import Control.Algebra import Control.Carrier.State.Church +import Control.Effect.Choose import Control.Effect.Empty +import Control.Effect.NonDet (NonDet) import Facet.Name import Facet.Pattern -import Facet.Type.Norm (Type) +import Facet.Type.Norm as T (Type(..)) import Fresnel.Effect import Fresnel.Fold import Fresnel.Iso import Fresnel.Lens +import Fresnel.List (head_) newtype Clause = Clause [Pattern Name] @@ -57,3 +61,11 @@ coverOne :: Has Empty sig m => Covers m () coverOne = use context_ >>= \case [] -> empty _:ctx -> context_ .= ctx + +coverStep :: Has NonDet sig m => Covers m () +coverStep = uses context_ (preview head_) >>= \case + Just T.String -> uses clauses_ (foldMapOf (folded.patterns_.head_) (Choosing . \case + PWildcard -> context_ %= tail + PVar _ -> context_ %= tail + _ -> empty)) >>= getChoosing + _ -> empty From ebe8d66ade7c704fcf7302f322aec31c68b0d55f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 02:07:45 -0500 Subject: [PATCH 0716/1324] Advance the clauses. --- src/Facet/Elab/Pattern.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 53e8906e7..e7ffa4e44 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -25,6 +25,7 @@ import Fresnel.Fold import Fresnel.Iso import Fresnel.Lens import Fresnel.List (head_) +import Fresnel.Traversal (traversed) newtype Clause = Clause [Pattern Name] @@ -65,7 +66,7 @@ coverOne = use context_ >>= \case coverStep :: Has NonDet sig m => Covers m () coverStep = uses context_ (preview head_) >>= \case Just T.String -> uses clauses_ (foldMapOf (folded.patterns_.head_) (Choosing . \case - PWildcard -> context_ %= tail - PVar _ -> context_ %= tail + PWildcard -> context_ %= tail >> clauses_.traversed.patterns_ %= tail + PVar _ -> context_ %= tail >> clauses_.traversed.patterns_ %= tail _ -> empty)) >>= getChoosing _ -> empty From c720e5f8a00430bbef49f5a28ffe0a8756dc0ede Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 02:09:48 -0500 Subject: [PATCH 0717/1324] Compute coverage for foralls. --- src/Facet/Elab/Pattern.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index e7ffa4e44..04c936852 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -69,4 +69,8 @@ coverStep = uses context_ (preview head_) >>= \case PWildcard -> context_ %= tail >> clauses_.traversed.patterns_ %= tail PVar _ -> context_ %= tail >> clauses_.traversed.patterns_ %= tail _ -> empty)) >>= getChoosing + Just T.ForAll{} -> uses clauses_ (foldMapOf (folded.patterns_.head_) (Choosing . \case + PWildcard -> context_ %= tail >> clauses_.traversed.patterns_ %= tail + PVar _ -> context_ %= tail >> clauses_.traversed.patterns_ %= tail + _ -> empty)) >>= getChoosing _ -> empty From c7cca9b65f846a76473117f803e54f9ebd07795f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 02:12:23 -0500 Subject: [PATCH 0718/1324] Simplify. --- src/Facet/Elab/Pattern.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 04c936852..619e60c8d 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -65,12 +65,12 @@ coverOne = use context_ >>= \case coverStep :: Has NonDet sig m => Covers m () coverStep = uses context_ (preview head_) >>= \case - Just T.String -> uses clauses_ (foldMapOf (folded.patterns_.head_) (Choosing . \case + Just T.String -> use clauses_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case PWildcard -> context_ %= tail >> clauses_.traversed.patterns_ %= tail PVar _ -> context_ %= tail >> clauses_.traversed.patterns_ %= tail - _ -> empty)) >>= getChoosing - Just T.ForAll{} -> uses clauses_ (foldMapOf (folded.patterns_.head_) (Choosing . \case + _ -> empty) + Just T.ForAll{} -> use clauses_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case PWildcard -> context_ %= tail >> clauses_.traversed.patterns_ %= tail PVar _ -> context_ %= tail >> clauses_.traversed.patterns_ %= tail - _ -> empty)) >>= getChoosing + _ -> empty) _ -> empty From 9c5171aa8394475bcf6d48164d38bd989569f832 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 02:12:40 -0500 Subject: [PATCH 0719/1324] Spacing. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 619e60c8d..f0987040f 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -65,7 +65,7 @@ coverOne = use context_ >>= \case coverStep :: Has NonDet sig m => Covers m () coverStep = uses context_ (preview head_) >>= \case - Just T.String -> use clauses_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case + Just T.String -> use clauses_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case PWildcard -> context_ %= tail >> clauses_.traversed.patterns_ %= tail PVar _ -> context_ %= tail >> clauses_.traversed.patterns_ %= tail _ -> empty) From d53c72a8ac2d78cd7bb452a21b14e7b30ca26c05 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 02:14:59 -0500 Subject: [PATCH 0720/1324] Rename clauses to heads. --- src/Facet/Elab/Pattern.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index f0987040f..cfc811ed6 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -3,7 +3,7 @@ module Facet.Elab.Pattern ( Clause(..) , patterns_ , Tableau(..) -, clauses_ +, heads_ , Branch(..) , (\/) -- * Coverage judgement @@ -34,11 +34,11 @@ patterns_ = coerced data Tableau = Tableau { context :: [Type] - , clauses :: [Clause] + , heads :: [Clause] } -clauses_ :: Lens' Tableau [Clause] -clauses_ = lens clauses (\ t clauses -> t{clauses}) +heads_ :: Lens' Tableau [Clause] +heads_ = lens heads (\ t heads -> t{heads}) context_ :: Lens' Tableau [Type] context_ = lens context (\ t context -> t{context}) @@ -65,12 +65,12 @@ coverOne = use context_ >>= \case coverStep :: Has NonDet sig m => Covers m () coverStep = uses context_ (preview head_) >>= \case - Just T.String -> use clauses_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case - PWildcard -> context_ %= tail >> clauses_.traversed.patterns_ %= tail - PVar _ -> context_ %= tail >> clauses_.traversed.patterns_ %= tail + Just T.String -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case + PWildcard -> context_ %= tail >> heads_.traversed.patterns_ %= tail + PVar _ -> context_ %= tail >> heads_.traversed.patterns_ %= tail _ -> empty) - Just T.ForAll{} -> use clauses_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case - PWildcard -> context_ %= tail >> clauses_.traversed.patterns_ %= tail - PVar _ -> context_ %= tail >> clauses_.traversed.patterns_ %= tail + Just T.ForAll{} -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case + PWildcard -> context_ %= tail >> heads_.traversed.patterns_ %= tail + PVar _ -> context_ %= tail >> heads_.traversed.patterns_ %= tail _ -> empty) _ -> empty From 1343f146274dcebed6355a000b53f2f2d98d323b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 02:19:55 -0500 Subject: [PATCH 0721/1324] Advance tableaux in a single step. --- src/Facet/Elab/Pattern.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index cfc811ed6..62e2ab1d0 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -25,7 +25,6 @@ import Fresnel.Fold import Fresnel.Iso import Fresnel.Lens import Fresnel.List (head_) -import Fresnel.Traversal (traversed) newtype Clause = Clause [Pattern Name] @@ -43,6 +42,9 @@ heads_ = lens heads (\ t heads -> t{heads}) context_ :: Lens' Tableau [Type] context_ = lens context (\ t context -> t{context}) +advance :: Tableau -> Tableau +advance Tableau{ context, heads } = Tableau (tail context) (tail heads) + data Branch s m a = forall x . Branch (Fold s x) (x -> m a) @@ -66,11 +68,11 @@ coverOne = use context_ >>= \case coverStep :: Has NonDet sig m => Covers m () coverStep = uses context_ (preview head_) >>= \case Just T.String -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case - PWildcard -> context_ %= tail >> heads_.traversed.patterns_ %= tail - PVar _ -> context_ %= tail >> heads_.traversed.patterns_ %= tail + PWildcard -> modify advance + PVar _ -> modify advance _ -> empty) Just T.ForAll{} -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case - PWildcard -> context_ %= tail >> heads_.traversed.patterns_ %= tail - PVar _ -> context_ %= tail >> heads_.traversed.patterns_ %= tail + PWildcard -> modify advance + PVar _ -> modify advance _ -> empty) _ -> empty From 7a9e8216c9b535b58eb62e6f1eb014caffa345a2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 02:22:12 -0500 Subject: [PATCH 0722/1324] Compute coverage for arrow types. --- src/Facet/Elab/Pattern.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 62e2ab1d0..019ace52b 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -75,4 +75,8 @@ coverStep = uses context_ (preview head_) >>= \case PWildcard -> modify advance PVar _ -> modify advance _ -> empty) + Just T.Arrow{} -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case + PWildcard -> modify advance + PVar _ -> modify advance + _ -> empty) _ -> empty From ed99d9afba56c0da3f391b2c5e4b9b34e1d99dc2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 02:23:40 -0500 Subject: [PATCH 0723/1324] Compute coverage for computations, for now. --- src/Facet/Elab/Pattern.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 019ace52b..dc73ae8d7 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -79,4 +79,5 @@ coverStep = uses context_ (preview head_) >>= \case PWildcard -> modify advance PVar _ -> modify advance _ -> empty) + Just T.Comp{} -> empty _ -> empty From 52f620f4d055518c48ce6d70f613d89fe62fc6d4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 02:23:46 -0500 Subject: [PATCH 0724/1324] Spacing. --- src/Facet/Elab/Pattern.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index dc73ae8d7..d39c18842 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -75,9 +75,9 @@ coverStep = uses context_ (preview head_) >>= \case PWildcard -> modify advance PVar _ -> modify advance _ -> empty) - Just T.Arrow{} -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case + Just T.Arrow{} -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case PWildcard -> modify advance PVar _ -> modify advance _ -> empty) - Just T.Comp{} -> empty + Just T.Comp{} -> empty _ -> empty From e493eaa6d735bce5e2e505b941e57328e5495509 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 02:30:59 -0500 Subject: [PATCH 0725/1324] Ignore a 9.2 warning. --- .ghci.repl | 2 ++ script/ghci-flags | 5 +++-- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/.ghci.repl b/.ghci.repl index 53e0699d2..77ad1e2f7 100644 --- a/.ghci.repl +++ b/.ghci.repl @@ -32,6 +32,8 @@ -- 8.10+ :seti -Wno-missing-safe-haskell-mode :seti -Wno-prepositive-qualified-module +-- 9.2+ +:seti -Wno-missing-kind-signatures -- We have this one on in the project but not in the REPL to reduce noise :seti -Wno-type-defaults diff --git a/script/ghci-flags b/script/ghci-flags index 595402add..14c014eda 100755 --- a/script/ghci-flags +++ b/script/ghci-flags @@ -66,8 +66,9 @@ function flags { echo "-Wno-name-shadowing" echo "-Wno-safe" echo "-Wno-unsafe" - [[ "$ghc_version" = 8.8.* ]] || [[ "$ghc_version" = 8.10.* ]] && echo "-Wno-missing-deriving-strategies" || true - [[ "$ghc_version" = 8.10.* ]] && echo "-Wno-missing-safe-haskell-mode" && echo "-Wno-prepositive-qualified-module" && echo "-Wno-unused-packages" + [[ "$ghc_version" = 8.8.* ]] || [[ "$ghc_version" = 8.10.* ]] || [[ "$ghc_version" = 9.2.* ]] && echo "-Wno-missing-deriving-strategies" || true + [[ "$ghc_version" = 8.10.* ]] || [[ "$ghc_version" = 9.2.* ]] && echo "-Wno-missing-safe-haskell-mode" && echo "-Wno-prepositive-qualified-module" && echo "-Wno-unused-packages" + [[ "$ghc_version" = 9.2.* ]] && echo "-Wno-missing-kind-signatures" echo "-XDeriveTraversable" echo "-XDerivingStrategies" From a8eb1f6fa7765e2343ad3408e64181a0ecc66a92 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 10:03:42 -0500 Subject: [PATCH 0726/1324] Use nm instead of a lambda. --- src/Facet/Elab.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 65f158e87..e0d32a0cc 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -127,7 +127,7 @@ resolveWith resolveWith lookup n = asks (\ StaticContext{ module', graph } -> lookupWith lookup graph module' n) >>= \case [] -> freeVariable n [v] -> pure v - ds -> ambiguousName n (map (\ (q :=: _) -> q) ds) + ds -> ambiguousName n (map nm ds) resolveC :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => QName -> m (RName :=: Maybe Term ::: Type) resolveC = resolveWith lookupC From e84bbc27018f1aca36114ca5511bfa1c7d9b573b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 10:20:05 -0500 Subject: [PATCH 0727/1324] Define an operator to construct spine-form applications. --- src/Facet/Type/Class.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Type/Class.hs b/src/Facet/Type/Class.hs index 77f25c7a6..c2598abcf 100644 --- a/src/Facet/Type/Class.hs +++ b/src/Facet/Type/Class.hs @@ -4,6 +4,7 @@ module Facet.Type.Class , forAllA ) where +import Data.Foldable (foldl') import Facet.Functor.Compose import Facet.Interface (Signature) import Facet.Kind (Kind) @@ -20,6 +21,9 @@ class Type r where var :: Var (Either Meta (LName Level)) -> r ($$) :: r -> r -> r infixl 9 $$ + ($$$) :: Foldable t => Var (Either Meta (LName Level)) -> t r -> r + h $$$ sp = foldl' ($$) (var h) sp + infixl 9 $$$ (|-) :: Signature r -> r -> r infixr 9 |- From dcbbd2379bec7845e1de8dbefc75e141b6935122 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 10:33:18 -0500 Subject: [PATCH 0728/1324] Specialize $$$ for Type. --- src/Facet/Type/Norm.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index a8a7bdbb1..18bd1cfb0 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -57,6 +57,7 @@ instance C.Type Type where arrow = Arrow var = Facet.Type.Norm.var ($$) = (Facet.Type.Norm.$$) + h $$$ sp = Ne h (foldl' (:>) Nil sp) (|-) = Comp instance Quote Type TX.Type where From 1786042476d6b7527fda58d916007f676b8e9e4b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 12:59:51 -0500 Subject: [PATCH 0729/1324] Redefine Type for now. --- src/Facet/Elab/Pattern.hs | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index d39c18842..ced2b7557 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -2,6 +2,7 @@ module Facet.Elab.Pattern ( Clause(..) , patterns_ +, Type(..) , Tableau(..) , heads_ , Branch(..) @@ -17,9 +18,9 @@ import Control.Carrier.State.Church import Control.Effect.Choose import Control.Effect.Empty import Control.Effect.NonDet (NonDet) +import Facet.Interface import Facet.Name import Facet.Pattern -import Facet.Type.Norm as T (Type(..)) import Fresnel.Effect import Fresnel.Fold import Fresnel.Iso @@ -31,6 +32,16 @@ newtype Clause = Clause [Pattern Name] patterns_ :: Iso' Clause [Pattern Name] patterns_ = coerced + +data Type + = String + | ForAll + | Arrow + | Sum [Type] + | Prd [Type] + | Comp (Signature Type) + + data Tableau = Tableau { context :: [Type] , heads :: [Clause] @@ -67,17 +78,17 @@ coverOne = use context_ >>= \case coverStep :: Has NonDet sig m => Covers m () coverStep = uses context_ (preview head_) >>= \case - Just T.String -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case + Just String -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case PWildcard -> modify advance PVar _ -> modify advance _ -> empty) - Just T.ForAll{} -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case + Just ForAll{} -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case PWildcard -> modify advance PVar _ -> modify advance _ -> empty) - Just T.Arrow{} -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case + Just Arrow{} -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case PWildcard -> modify advance PVar _ -> modify advance _ -> empty) - Just T.Comp{} -> empty + Just Comp{} -> empty _ -> empty From ca461d1ddd81489d46da99fcd318794223bc2500 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 13:01:18 -0500 Subject: [PATCH 0730/1324] Compute coverage for unit. --- src/Facet/Elab/Pattern.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index ced2b7557..30d14067a 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -90,5 +90,9 @@ coverStep = uses context_ (preview head_) >>= \case PWildcard -> modify advance PVar _ -> modify advance _ -> empty) + Just (Prd []) -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case + PWildcard -> modify advance + PVar _ -> modify advance + _ -> empty) Just Comp{} -> empty _ -> empty From 75018244a942e33045c9b7255f12ebf861391e54 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 13:14:32 -0500 Subject: [PATCH 0731/1324] Split out binary sums/products and their units. --- src/Facet/Elab/Pattern.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 30d14067a..6ab3fe840 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -37,8 +37,10 @@ data Type = String | ForAll | Arrow - | Sum [Type] - | Prd [Type] + | Zero + | One + | Type :+ Type + | Type :* Type | Comp (Signature Type) @@ -90,7 +92,7 @@ coverStep = uses context_ (preview head_) >>= \case PWildcard -> modify advance PVar _ -> modify advance _ -> empty) - Just (Prd []) -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case + Just One{} -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case PWildcard -> modify advance PVar _ -> modify advance _ -> empty) From 3a657e1400bd214f08df71aa935ce7efb23cbeb3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 13:34:25 -0500 Subject: [PATCH 0732/1324] Define patterns locally. --- src/Facet/Elab/Pattern.hs | 37 +++++++++++++++++++++---------------- 1 file changed, 21 insertions(+), 16 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 6ab3fe840..cbfe65586 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ExistentialQuantification #-} module Facet.Elab.Pattern -( Clause(..) +( Pattern(..) +, Clause(..) , patterns_ , Type(..) , Tableau(..) @@ -20,16 +21,20 @@ import Control.Effect.Empty import Control.Effect.NonDet (NonDet) import Facet.Interface import Facet.Name -import Facet.Pattern import Fresnel.Effect import Fresnel.Fold import Fresnel.Iso import Fresnel.Lens import Fresnel.List (head_) -newtype Clause = Clause [Pattern Name] +data Pattern + = Wildcard + | Var Name + | Pair Pattern Pattern -patterns_ :: Iso' Clause [Pattern Name] +newtype Clause = Clause [Pattern] + +patterns_ :: Iso' Clause [Pattern] patterns_ = coerced @@ -81,20 +86,20 @@ coverOne = use context_ >>= \case coverStep :: Has NonDet sig m => Covers m () coverStep = uses context_ (preview head_) >>= \case Just String -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case - PWildcard -> modify advance - PVar _ -> modify advance - _ -> empty) + Wildcard -> modify advance + Var _ -> modify advance + _ -> empty) Just ForAll{} -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case - PWildcard -> modify advance - PVar _ -> modify advance - _ -> empty) + Wildcard -> modify advance + Var _ -> modify advance + _ -> empty) Just Arrow{} -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case - PWildcard -> modify advance - PVar _ -> modify advance - _ -> empty) + Wildcard -> modify advance + Var _ -> modify advance + _ -> empty) Just One{} -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case - PWildcard -> modify advance - PVar _ -> modify advance - _ -> empty) + Wildcard -> modify advance + Var _ -> modify advance + _ -> empty) Just Comp{} -> empty _ -> empty From 2afe07966bd6219e25ff778d6ac711cf0b1fb917 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 13:35:14 -0500 Subject: [PATCH 0733/1324] Add unit patterns. --- src/Facet/Elab/Pattern.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index cbfe65586..40f57dffd 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -30,6 +30,7 @@ import Fresnel.List (head_) data Pattern = Wildcard | Var Name + | Unit | Pair Pattern Pattern newtype Clause = Clause [Pattern] From 54c2e2411b4fc120a9ccddb2d5b386601673de0b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 13:35:34 -0500 Subject: [PATCH 0734/1324] Unit matches at type One. --- src/Facet/Elab/Pattern.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 40f57dffd..ce4b3dcd4 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -101,6 +101,7 @@ coverStep = uses context_ (preview head_) >>= \case Just One{} -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case Wildcard -> modify advance Var _ -> modify advance + Unit -> modify advance _ -> empty) Just Comp{} -> empty _ -> empty From a7b04200477eeafcecd61f6ecaa0bc25abc62057 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 13:36:55 -0500 Subject: [PATCH 0735/1324] Compute coverage for products. --- src/Facet/Elab/Pattern.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index ce4b3dcd4..bcb40b7f6 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -26,6 +26,7 @@ import Fresnel.Fold import Fresnel.Iso import Fresnel.Lens import Fresnel.List (head_) +import Fresnel.Traversal (traversed) data Pattern = Wildcard @@ -103,5 +104,11 @@ coverStep = uses context_ (preview head_) >>= \case Var _ -> modify advance Unit -> modify advance _ -> empty) + Just (t1 :* t2) -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case + Wildcard -> context_ %= (\ ctx -> t1:t2:ctx) >> heads_.traversed.patterns_ %= (\ clause -> Wildcard:Wildcard:clause) + -- FIXME: this should bind fresh names + Var n -> context_ %= (\ ctx -> t1:t2:ctx) >> heads_.traversed.patterns_ %= (\ clause -> Var n:Var n:clause) + Pair p1 p2 -> context_ %= (\ ctx -> t1:t2:ctx) >> heads_.traversed.patterns_ %= (\ clause -> p1:p2:clause) + _ -> empty) Just Comp{} -> empty _ -> empty From ae1dad980da80a3c403b2227f9ce3c2b6707ee77 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 13:37:37 -0500 Subject: [PATCH 0736/1324] Compute coverage for the zero type. --- src/Facet/Elab/Pattern.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index bcb40b7f6..4550002e8 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -99,6 +99,10 @@ coverStep = uses context_ (preview head_) >>= \case Wildcard -> modify advance Var _ -> modify advance _ -> empty) + Just Zero -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case + Wildcard -> modify advance + Var _ -> modify advance + _ -> empty) Just One{} -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case Wildcard -> modify advance Var _ -> modify advance From 189a4c780694339cd3919be1a3c402b03b22556c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 13:38:50 -0500 Subject: [PATCH 0737/1324] Define InL/R patterns for sums. --- src/Facet/Elab/Pattern.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 4550002e8..d1c42253c 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -32,6 +32,8 @@ data Pattern = Wildcard | Var Name | Unit + | InL Pattern + | InR Pattern | Pair Pattern Pattern newtype Clause = Clause [Pattern] From c1f23bea48a2f19885f33b12737d5d04fceff873 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 13:39:03 -0500 Subject: [PATCH 0738/1324] Spacing. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index d1c42253c..b86da43bc 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -105,7 +105,7 @@ coverStep = uses context_ (preview head_) >>= \case Wildcard -> modify advance Var _ -> modify advance _ -> empty) - Just One{} -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case + Just One -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case Wildcard -> modify advance Var _ -> modify advance Unit -> modify advance From c7f31cfdef05c087916af9e9bb64f60289b7a60a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Feb 2022 23:08:00 -0500 Subject: [PATCH 0739/1324] Avoid branching for non-sum types. --- src/Facet/Elab/Pattern.hs | 42 +++++++++++++++++++-------------------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index b86da43bc..4fe55670e 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -89,27 +89,27 @@ coverOne = use context_ >>= \case coverStep :: Has NonDet sig m => Covers m () coverStep = uses context_ (preview head_) >>= \case - Just String -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case - Wildcard -> modify advance - Var _ -> modify advance - _ -> empty) - Just ForAll{} -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case - Wildcard -> modify advance - Var _ -> modify advance - _ -> empty) - Just Arrow{} -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case - Wildcard -> modify advance - Var _ -> modify advance - _ -> empty) - Just Zero -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case - Wildcard -> modify advance - Var _ -> modify advance - _ -> empty) - Just One -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case - Wildcard -> modify advance - Var _ -> modify advance - Unit -> modify advance - _ -> empty) + Just String -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case + Wildcard -> pure () + Var _ -> pure () + _ -> empty) >> modify advance + Just ForAll{} -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case + Wildcard -> pure () + Var _ -> pure () + _ -> empty) >> modify advance + Just Arrow{} -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case + Wildcard -> pure () + Var _ -> pure () + _ -> empty) >> modify advance + Just Zero -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case + Wildcard -> pure () + Var _ -> pure () + _ -> empty) >> modify advance + Just One -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case + Wildcard -> pure () + Var _ -> pure () + Unit -> pure () + _ -> empty) >> modify advance Just (t1 :* t2) -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case Wildcard -> context_ %= (\ ctx -> t1:t2:ctx) >> heads_.traversed.patterns_ %= (\ clause -> Wildcard:Wildcard:clause) -- FIXME: this should bind fresh names From 807571ddfa0717542385196dd16276143c69ebb6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 1 Mar 2022 02:04:43 -0500 Subject: [PATCH 0740/1324] Match the entire context. --- src/Facet/Elab/Pattern.hs | 37 +++++++++++++++++-------------------- 1 file changed, 17 insertions(+), 20 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 4fe55670e..ccc7f26e5 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -21,7 +21,7 @@ import Control.Effect.Empty import Control.Effect.NonDet (NonDet) import Facet.Interface import Facet.Name -import Fresnel.Effect +import Fresnel.Effect hiding (view) import Fresnel.Fold import Fresnel.Iso import Fresnel.Lens @@ -64,9 +64,6 @@ heads_ = lens heads (\ t heads -> t{heads}) context_ :: Lens' Tableau [Type] context_ = lens context (\ t context -> t{context}) -advance :: Tableau -> Tableau -advance Tableau{ context, heads } = Tableau (tail context) (tail heads) - data Branch s m a = forall x . Branch (Fold s x) (x -> m a) @@ -88,33 +85,33 @@ coverOne = use context_ >>= \case _:ctx -> context_ .= ctx coverStep :: Has NonDet sig m => Covers m () -coverStep = uses context_ (preview head_) >>= \case - Just String -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case +coverStep = use context_ >>= \case + String:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case Wildcard -> pure () Var _ -> pure () - _ -> empty) >> modify advance - Just ForAll{} -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case + _ -> empty) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail + ForAll{}:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case Wildcard -> pure () Var _ -> pure () - _ -> empty) >> modify advance - Just Arrow{} -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case + _ -> empty) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail + Arrow{}:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case Wildcard -> pure () Var _ -> pure () - _ -> empty) >> modify advance - Just Zero -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case + _ -> empty) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail + Zero:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case Wildcard -> pure () Var _ -> pure () - _ -> empty) >> modify advance - Just One -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case + _ -> empty) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail + One:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case Wildcard -> pure () Var _ -> pure () Unit -> pure () - _ -> empty) >> modify advance - Just (t1 :* t2) -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case - Wildcard -> context_ %= (\ ctx -> t1:t2:ctx) >> heads_.traversed.patterns_ %= (\ clause -> Wildcard:Wildcard:clause) + _ -> empty) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail + (t1 :* t2):ctx -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case + Wildcard -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> Wildcard:Wildcard:clause) -- FIXME: this should bind fresh names - Var n -> context_ %= (\ ctx -> t1:t2:ctx) >> heads_.traversed.patterns_ %= (\ clause -> Var n:Var n:clause) - Pair p1 p2 -> context_ %= (\ ctx -> t1:t2:ctx) >> heads_.traversed.patterns_ %= (\ clause -> p1:p2:clause) + Var n -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> Var n:Var n:clause) + Pair p1 p2 -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> p1:p2:clause) _ -> empty) - Just Comp{} -> empty + Comp{}:_ -> empty _ -> empty From f766fc6633d116032acc70d77d38a415fc0be36e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 1 Mar 2022 02:10:34 -0500 Subject: [PATCH 0741/1324] Compute coverage for sums. --- src/Facet/Elab/Pattern.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index ccc7f26e5..556409f59 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -107,6 +107,15 @@ coverStep = use context_ >>= \case Var _ -> pure () Unit -> pure () _ -> empty) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail + (t1 :+ t2):ctx -> uses heads_ (foldMapOf (folded.patterns_) (\case + Wildcard:ps -> Just ([Clause (Wildcard:ps)], [Clause (Wildcard:ps)]) + Var n:ps -> Just ([Clause (Var n:ps)], [Clause (Var n:ps)]) + InL p:ps -> Just ([Clause (p:ps)], [Clause []]) + InR q:qs -> Just ([Clause []], [Clause (q:qs)]) + _ -> Nothing)) + >>= \case + Just (cs1, cs2) -> put (Tableau (t1:ctx) cs1) <|> put (Tableau (t2:ctx) cs2) + Nothing -> empty (t1 :* t2):ctx -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case Wildcard -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> Wildcard:Wildcard:clause) -- FIXME: this should bind fresh names From 434cc8f00b29bc0bb44dcacc7ce9e28932818b2c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 1 Mar 2022 02:12:47 -0500 Subject: [PATCH 0742/1324] Terminate successfully on the empty context. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 556409f59..c86a0afdd 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -123,4 +123,4 @@ coverStep = use context_ >>= \case Pair p1 p2 -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> p1:p2:clause) _ -> empty) Comp{}:_ -> empty - _ -> empty + [] -> pure () From ddc30bc9370169f13d93fe72390bcfc22a5d84dd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 1 Mar 2022 02:14:02 -0500 Subject: [PATCH 0743/1324] Add a FIXME about clause exhaustion. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index c86a0afdd..0a509a807 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -123,4 +123,4 @@ coverStep = use context_ >>= \case Pair p1 p2 -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> p1:p2:clause) _ -> empty) Comp{}:_ -> empty - [] -> pure () + [] -> pure () -- FIXME: fail if clauses aren't all empty From dc2b15a9ca4b0ddb8f7b606899bef505b726a497 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 1 Mar 2022 02:14:34 -0500 Subject: [PATCH 0744/1324] :fire: coverOne. --- src/Facet/Elab/Pattern.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 0a509a807..db4663696 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -10,7 +10,6 @@ module Facet.Elab.Pattern , (\/) -- * Coverage judgement , Covers(..) -, coverOne , coverStep ) where @@ -79,11 +78,6 @@ newtype Covers m a = Covers { covers :: StateC Tableau m a } deriving (Algebra (State Tableau :+: sig), Applicative, Functor, Monad) -coverOne :: Has Empty sig m => Covers m () -coverOne = use context_ >>= \case - [] -> empty - _:ctx -> context_ .= ctx - coverStep :: Has NonDet sig m => Covers m () coverStep = use context_ >>= \case String:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case From 279864f48fc0d554c2a5f24e7e6681e3acd7f5e8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 1 Mar 2022 10:07:45 -0500 Subject: [PATCH 0745/1324] Define a high-level coverage test. --- src/Facet/Elab/Pattern.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index db4663696..2d4416658 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -10,10 +10,13 @@ module Facet.Elab.Pattern , (\/) -- * Coverage judgement , Covers(..) +, covers , coverStep ) where import Control.Algebra +import Control.Applicative (liftA2) +import Control.Carrier.NonDet.Church (runNonDet) import Control.Carrier.State.Church import Control.Effect.Choose import Control.Effect.Empty @@ -74,10 +77,16 @@ infixr 2 \/ -- Coverage judgement -newtype Covers m a = Covers { covers :: StateC Tableau m a } +newtype Covers m a = Covers { runCovers :: StateC Tableau m a } deriving (Algebra (State Tableau :+: sig), Applicative, Functor, Monad) +covers :: Tableau -> Bool +covers t = run (runNonDet (liftA2 (&&)) (const (pure True)) (pure True) (execState t (runCovers go))) where + go = use context_ >>= \case + [] -> pure () + _ -> coverStep >> go + coverStep :: Has NonDet sig m => Covers m () coverStep = use context_ >>= \case String:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case From dc2ae08e968c66448f23b7faded7f61930fb51a4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 1 Mar 2022 11:00:43 -0500 Subject: [PATCH 0746/1324] Don't assume success. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 2d4416658..8cacff9ba 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -82,7 +82,7 @@ newtype Covers m a = Covers { runCovers :: StateC Tableau m a } covers :: Tableau -> Bool -covers t = run (runNonDet (liftA2 (&&)) (const (pure True)) (pure True) (execState t (runCovers go))) where +covers t = run (runNonDet (liftA2 (&&)) (const (pure True)) (pure False) (execState t (runCovers go))) where go = use context_ >>= \case [] -> pure () _ -> coverStep >> go From 7d6898e6617bcecd90710f607b7d04e0aaf86178 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Mar 2022 17:15:55 -0500 Subject: [PATCH 0747/1324] Derive a MonadFail instance for Covers. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 8cacff9ba..43ef5a4ba 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -78,7 +78,7 @@ infixr 2 \/ -- Coverage judgement newtype Covers m a = Covers { runCovers :: StateC Tableau m a } - deriving (Algebra (State Tableau :+: sig), Applicative, Functor, Monad) + deriving (Algebra (State Tableau :+: sig), Applicative, Functor, Monad, MonadFail) covers :: Tableau -> Bool From 8358b127d42b555ebfc71522c5209b99fa8cde79 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Mar 2022 17:16:10 -0500 Subject: [PATCH 0748/1324] Provide a MonadFail instance during coverage checking. --- src/Facet/Elab/Pattern.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 43ef5a4ba..052b60339 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -16,6 +16,7 @@ module Facet.Elab.Pattern import Control.Algebra import Control.Applicative (liftA2) +import Control.Carrier.Fail.Either import Control.Carrier.NonDet.Church (runNonDet) import Control.Carrier.State.Church import Control.Effect.Choose @@ -82,7 +83,7 @@ newtype Covers m a = Covers { runCovers :: StateC Tableau m a } covers :: Tableau -> Bool -covers t = run (runNonDet (liftA2 (&&)) (const (pure True)) (pure False) (execState t (runCovers go))) where +covers t = run (runNonDet (liftA2 (&&)) (const (pure True)) (pure False) (runFail (execState t (runCovers go)))) where go = use context_ >>= \case [] -> pure () _ -> coverStep >> go From ab86622a999a126cb9ffc8c9c1d8d6e8f5c30c5b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Mar 2022 17:18:53 -0500 Subject: [PATCH 0749/1324] Fail with an error message. --- src/Facet/Elab/Pattern.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 052b60339..98ce70d12 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -88,29 +88,29 @@ covers t = run (runNonDet (liftA2 (&&)) (const (pure True)) (pure False) (runFai [] -> pure () _ -> coverStep >> go -coverStep :: Has NonDet sig m => Covers m () +coverStep :: (Has NonDet sig m, MonadFail m) => Covers m () coverStep = use context_ >>= \case String:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case Wildcard -> pure () Var _ -> pure () - _ -> empty) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail + _ -> fail "unexpected pattern") >> context_ .= ctx >> heads_.traversed.patterns_ %= tail ForAll{}:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case Wildcard -> pure () Var _ -> pure () - _ -> empty) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail + _ -> fail "unexpected pattern") >> context_ .= ctx >> heads_.traversed.patterns_ %= tail Arrow{}:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case Wildcard -> pure () Var _ -> pure () - _ -> empty) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail + _ -> fail "unexpected pattern") >> context_ .= ctx >> heads_.traversed.patterns_ %= tail Zero:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case Wildcard -> pure () Var _ -> pure () - _ -> empty) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail + _ -> fail "unexpected pattern") >> context_ .= ctx >> heads_.traversed.patterns_ %= tail One:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case Wildcard -> pure () Var _ -> pure () Unit -> pure () - _ -> empty) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail + _ -> fail "unexpected pattern") >> context_ .= ctx >> heads_.traversed.patterns_ %= tail (t1 :+ t2):ctx -> uses heads_ (foldMapOf (folded.patterns_) (\case Wildcard:ps -> Just ([Clause (Wildcard:ps)], [Clause (Wildcard:ps)]) Var n:ps -> Just ([Clause (Var n:ps)], [Clause (Var n:ps)]) @@ -119,12 +119,12 @@ coverStep = use context_ >>= \case _ -> Nothing)) >>= \case Just (cs1, cs2) -> put (Tableau (t1:ctx) cs1) <|> put (Tableau (t2:ctx) cs2) - Nothing -> empty - (t1 :* t2):ctx -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) empty (\case + Nothing -> fail "unexpected pattern" + (t1 :* t2):ctx -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) (fail "unexpected pattern") (\case Wildcard -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> Wildcard:Wildcard:clause) -- FIXME: this should bind fresh names Var n -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> Var n:Var n:clause) Pair p1 p2 -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> p1:p2:clause) - _ -> empty) - Comp{}:_ -> empty + _ -> fail "unexpected pattern") + Comp{}:_ -> fail "unexpected pattern" [] -> pure () -- FIXME: fail if clauses aren't all empty From ba284a2e4aaf47ad7c1baaf2e9d78521b0c104f6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Mar 2022 17:19:29 -0500 Subject: [PATCH 0750/1324] Return error messages. --- src/Facet/Elab/Pattern.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 98ce70d12..16f813149 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -82,8 +82,8 @@ newtype Covers m a = Covers { runCovers :: StateC Tableau m a } deriving (Algebra (State Tableau :+: sig), Applicative, Functor, Monad, MonadFail) -covers :: Tableau -> Bool -covers t = run (runNonDet (liftA2 (&&)) (const (pure True)) (pure False) (runFail (execState t (runCovers go)))) where +covers :: Tableau -> Either String Bool +covers t = run (runFail (runNonDet (liftA2 (&&)) (const (pure True)) (pure False) (execState t (runCovers go)))) where go = use context_ >>= \case [] -> pure () _ -> coverStep >> go From 185b5810707a9bf4ccf8fd97806e0a633bfedd3c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Mar 2022 20:26:08 -0500 Subject: [PATCH 0751/1324] Run coverage checking in Choose. --- src/Facet/Elab/Pattern.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 16f813149..7386a5287 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -16,12 +16,10 @@ module Facet.Elab.Pattern import Control.Algebra import Control.Applicative (liftA2) +import Control.Carrier.Choose.Church (runChoose) import Control.Carrier.Fail.Either -import Control.Carrier.NonDet.Church (runNonDet) import Control.Carrier.State.Church import Control.Effect.Choose -import Control.Effect.Empty -import Control.Effect.NonDet (NonDet) import Facet.Interface import Facet.Name import Fresnel.Effect hiding (view) @@ -83,12 +81,12 @@ newtype Covers m a = Covers { runCovers :: StateC Tableau m a } covers :: Tableau -> Either String Bool -covers t = run (runFail (runNonDet (liftA2 (&&)) (const (pure True)) (pure False) (execState t (runCovers go)))) where +covers t = run (runFail (runChoose (liftA2 (&&)) (const (pure True)) (execState t (runCovers go)))) where go = use context_ >>= \case [] -> pure () _ -> coverStep >> go -coverStep :: (Has NonDet sig m, MonadFail m) => Covers m () +coverStep :: (Has Choose sig m, MonadFail m) => Covers m () coverStep = use context_ >>= \case String:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case Wildcard -> pure () From 70a18b46c61ece9c4fa6554c567bfbc5669e6cea Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Mar 2022 20:26:17 -0500 Subject: [PATCH 0752/1324] Derive some instances for Pattern. --- src/Facet/Elab/Pattern.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 7386a5287..865a52096 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -36,6 +36,7 @@ data Pattern | InL Pattern | InR Pattern | Pair Pattern Pattern + deriving (Eq, Ord, Show) newtype Clause = Clause [Pattern] From 1fd8dd8af8f2783187cc9f42b335f75fd617622f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Mar 2022 20:32:19 -0500 Subject: [PATCH 0753/1324] Parameterize Pattern by the type of variables. --- src/Facet/Elab/Pattern.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 865a52096..cdc9edecb 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -29,18 +29,18 @@ import Fresnel.Lens import Fresnel.List (head_) import Fresnel.Traversal (traversed) -data Pattern +data Pattern a = Wildcard - | Var Name + | Var a | Unit - | InL Pattern - | InR Pattern - | Pair Pattern Pattern + | InL (Pattern a) + | InR (Pattern a) + | Pair (Pattern a) (Pattern a) deriving (Eq, Ord, Show) -newtype Clause = Clause [Pattern] +newtype Clause = Clause [Pattern Name] -patterns_ :: Iso' Clause [Pattern] +patterns_ :: Iso' Clause [Pattern Name] patterns_ = coerced From bada245c15d660e3f70f180ad1bee78bbd6f7857 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Mar 2022 20:32:42 -0500 Subject: [PATCH 0754/1324] Derive some more instances for Pattern. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index cdc9edecb..eaa5abfe0 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -36,7 +36,7 @@ data Pattern a | InL (Pattern a) | InR (Pattern a) | Pair (Pattern a) (Pattern a) - deriving (Eq, Ord, Show) + deriving (Eq, Foldable, Functor, Ord, Show, Traversable) newtype Clause = Clause [Pattern Name] From 25e1429c256ad28ddf0fbc18124facd4a6596072 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Mar 2022 20:34:27 -0500 Subject: [PATCH 0755/1324] Spacing. --- src/Facet/Elab/Pattern.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index eaa5abfe0..174f31803 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -38,6 +38,7 @@ data Pattern a | Pair (Pattern a) (Pattern a) deriving (Eq, Foldable, Functor, Ord, Show, Traversable) + newtype Clause = Clause [Pattern Name] patterns_ :: Iso' Clause [Pattern Name] From 116bc5c9edfa9b474464220a921ed1969ea30305 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 2 Mar 2022 20:37:08 -0500 Subject: [PATCH 0756/1324] Define Applicative & Monad instances for Pattern. --- src/Facet/Elab/Pattern.hs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 174f31803..b630e6160 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -20,6 +20,7 @@ import Control.Carrier.Choose.Church (runChoose) import Control.Carrier.Fail.Either import Control.Carrier.State.Church import Control.Effect.Choose +import Control.Monad (ap) import Facet.Interface import Facet.Name import Fresnel.Effect hiding (view) @@ -38,6 +39,19 @@ data Pattern a | Pair (Pattern a) (Pattern a) deriving (Eq, Foldable, Functor, Ord, Show, Traversable) +instance Applicative Pattern where + pure = Var + (<*>) = ap + +instance Monad Pattern where + m >>= f = case m of + Wildcard -> Wildcard + Var a -> f a + Unit -> Unit + InL p -> InL (p >>= f) + InR q -> InR (q >>= f) + Pair p q -> Pair (p >>= f) (q >>= f) + newtype Clause = Clause [Pattern Name] From d6e49651ecbde43209149aa2e6fc9b6a25a0655d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 3 Mar 2022 17:59:39 -0500 Subject: [PATCH 0757/1324] Show the erroring pattern(s). --- src/Facet/Elab/Pattern.hs | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index b630e6160..07ec9e053 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -107,38 +107,38 @@ coverStep = use context_ >>= \case String:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case Wildcard -> pure () Var _ -> pure () - _ -> fail "unexpected pattern") >> context_ .= ctx >> heads_.traversed.patterns_ %= tail + p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail ForAll{}:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case Wildcard -> pure () Var _ -> pure () - _ -> fail "unexpected pattern") >> context_ .= ctx >> heads_.traversed.patterns_ %= tail + p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail Arrow{}:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case Wildcard -> pure () Var _ -> pure () - _ -> fail "unexpected pattern") >> context_ .= ctx >> heads_.traversed.patterns_ %= tail + p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail Zero:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case Wildcard -> pure () Var _ -> pure () - _ -> fail "unexpected pattern") >> context_ .= ctx >> heads_.traversed.patterns_ %= tail + p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail One:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case Wildcard -> pure () Var _ -> pure () Unit -> pure () - _ -> fail "unexpected pattern") >> context_ .= ctx >> heads_.traversed.patterns_ %= tail + p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail (t1 :+ t2):ctx -> uses heads_ (foldMapOf (folded.patterns_) (\case - Wildcard:ps -> Just ([Clause (Wildcard:ps)], [Clause (Wildcard:ps)]) - Var n:ps -> Just ([Clause (Var n:ps)], [Clause (Var n:ps)]) - InL p:ps -> Just ([Clause (p:ps)], [Clause []]) - InR q:qs -> Just ([Clause []], [Clause (q:qs)]) - _ -> Nothing)) + Wildcard:ps -> ([], [Clause (Wildcard:ps)], [Clause (Wildcard:ps)]) + Var n:ps -> ([], [Clause (Var n:ps)], [Clause (Var n:ps)]) + InL p:ps -> ([], [Clause (p:ps)], [Clause []]) + InR q:qs -> ([], [Clause []], [Clause (q:qs)]) + p -> ([p], [], []))) >>= \case - Just (cs1, cs2) -> put (Tableau (t1:ctx) cs1) <|> put (Tableau (t2:ctx) cs2) - Nothing -> fail "unexpected pattern" - (t1 :* t2):ctx -> use heads_ >>= foldMapByOf (folded.patterns_.head_) (<|>) (fail "unexpected pattern") (\case + ([], cs1, cs2) -> put (Tableau (t1:ctx) cs1) <|> put (Tableau (t2:ctx) cs2) + (ps, _, _) -> fail ("unexpected patterns: " <> show ps) + (t1 :* t2):ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case Wildcard -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> Wildcard:Wildcard:clause) -- FIXME: this should bind fresh names Var n -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> Var n:Var n:clause) Pair p1 p2 -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> p1:p2:clause) - _ -> fail "unexpected pattern") - Comp{}:_ -> fail "unexpected pattern" + p -> fail ("unexpected pattern: " <> show p)) + Comp{}:_ -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\ p -> fail ("unexpected pattern: " <> show p)) [] -> pure () -- FIXME: fail if clauses aren't all empty From 1696fbd23f97508b3a944c3174a67b98325103ed Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 3 Mar 2022 18:09:26 -0500 Subject: [PATCH 0758/1324] Handle errors as they come. --- src/Facet/Elab/Pattern.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 07ec9e053..a1869a700 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -19,6 +19,7 @@ import Control.Applicative (liftA2) import Control.Carrier.Choose.Church (runChoose) import Control.Carrier.Fail.Either import Control.Carrier.State.Church +import Control.Carrier.Writer.Church (execWriter) import Control.Effect.Choose import Control.Monad (ap) import Facet.Interface @@ -125,15 +126,14 @@ coverStep = use context_ >>= \case Var _ -> pure () Unit -> pure () p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail - (t1 :+ t2):ctx -> uses heads_ (foldMapOf (folded.patterns_) (\case - Wildcard:ps -> ([], [Clause (Wildcard:ps)], [Clause (Wildcard:ps)]) - Var n:ps -> ([], [Clause (Var n:ps)], [Clause (Var n:ps)]) - InL p:ps -> ([], [Clause (p:ps)], [Clause []]) - InR q:qs -> ([], [Clause []], [Clause (q:qs)]) - p -> ([p], [], []))) - >>= \case - ([], cs1, cs2) -> put (Tableau (t1:ctx) cs1) <|> put (Tableau (t2:ctx) cs2) - (ps, _, _) -> fail ("unexpected patterns: " <> show ps) + (t1 :+ t2):ctx -> use heads_ >>= execWriter . traverseOf_ (folded.patterns_) (\case + Wildcard:ps -> pure ([Clause (Wildcard:ps)], [Clause (Wildcard:ps)]) + Var n:ps -> pure ([Clause (Var n:ps)], [Clause (Var n:ps)]) + InL p:ps -> pure ([Clause (p:ps)], [Clause []]) + InR q:qs -> pure ([Clause []], [Clause (q:qs)]) + p:_ -> fail ("unexpected pattern: " <> show p) + _ -> fail "no patterns to match sum") + >>= \ (cs1, cs2) -> put (Tableau (t1:ctx) cs1) <|> put (Tableau (t2:ctx) cs2) (t1 :* t2):ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case Wildcard -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> Wildcard:Wildcard:clause) -- FIXME: this should bind fresh names From b1c850d34707ebecb3f5231afd0be3297e452b86 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 3 Mar 2022 19:06:03 -0500 Subject: [PATCH 0759/1324] Rename Pattern to Atom. --- src/Facet/Elab/Pattern.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index a1869a700..4a0d2adf6 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} module Facet.Elab.Pattern -( Pattern(..) +( Atom(..) , Clause(..) , patterns_ , Type(..) @@ -31,20 +31,20 @@ import Fresnel.Lens import Fresnel.List (head_) import Fresnel.Traversal (traversed) -data Pattern a +data Atom a = Wildcard | Var a | Unit - | InL (Pattern a) - | InR (Pattern a) - | Pair (Pattern a) (Pattern a) + | InL (Atom a) + | InR (Atom a) + | Pair (Atom a) (Atom a) deriving (Eq, Foldable, Functor, Ord, Show, Traversable) -instance Applicative Pattern where +instance Applicative Atom where pure = Var (<*>) = ap -instance Monad Pattern where +instance Monad Atom where m >>= f = case m of Wildcard -> Wildcard Var a -> f a @@ -54,9 +54,9 @@ instance Monad Pattern where Pair p q -> Pair (p >>= f) (q >>= f) -newtype Clause = Clause [Pattern Name] +newtype Clause = Clause [Atom Name] -patterns_ :: Iso' Clause [Pattern Name] +patterns_ :: Iso' Clause [Atom Name] patterns_ = coerced From e43fc703e54ac5faaec3c208b47d6a34239801f8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 3 Mar 2022 21:02:03 -0500 Subject: [PATCH 0760/1324] Revert "Rename Pattern to Atom." This reverts commit b1c850d34707ebecb3f5231afd0be3297e452b86. --- src/Facet/Elab/Pattern.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 4a0d2adf6..a1869a700 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} module Facet.Elab.Pattern -( Atom(..) +( Pattern(..) , Clause(..) , patterns_ , Type(..) @@ -31,20 +31,20 @@ import Fresnel.Lens import Fresnel.List (head_) import Fresnel.Traversal (traversed) -data Atom a +data Pattern a = Wildcard | Var a | Unit - | InL (Atom a) - | InR (Atom a) - | Pair (Atom a) (Atom a) + | InL (Pattern a) + | InR (Pattern a) + | Pair (Pattern a) (Pattern a) deriving (Eq, Foldable, Functor, Ord, Show, Traversable) -instance Applicative Atom where +instance Applicative Pattern where pure = Var (<*>) = ap -instance Monad Atom where +instance Monad Pattern where m >>= f = case m of Wildcard -> Wildcard Var a -> f a @@ -54,9 +54,9 @@ instance Monad Atom where Pair p q -> Pair (p >>= f) (q >>= f) -newtype Clause = Clause [Atom Name] +newtype Clause = Clause [Pattern Name] -patterns_ :: Iso' Clause [Atom Name] +patterns_ :: Iso' Clause [Pattern Name] patterns_ = coerced From 2a8eb1d4475c33da457730f35be55e0650a1ff58 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 3 Mar 2022 22:17:23 -0500 Subject: [PATCH 0761/1324] Add datatypes. --- src/Facet/Elab/Pattern.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index a1869a700..a1fb986bd 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -4,6 +4,7 @@ module Facet.Elab.Pattern , Clause(..) , patterns_ , Type(..) +, Constructor(..) , Tableau(..) , heads_ , Branch(..) @@ -69,7 +70,12 @@ data Type | Type :+ Type | Type :* Type | Comp (Signature Type) + | Datatype RName [Constructor] +data Constructor = Constructor + { name :: RName + , fields :: [Type] + } data Tableau = Tableau { context :: [Type] @@ -141,4 +147,5 @@ coverStep = use context_ >>= \case Pair p1 p2 -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> p1:p2:clause) p -> fail ("unexpected pattern: " <> show p)) Comp{}:_ -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\ p -> fail ("unexpected pattern: " <> show p)) + Datatype{}:_ -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\ p -> fail ("unexpected pattern: " <> show p)) [] -> pure () -- FIXME: fail if clauses aren't all empty From 7b2bcf4b484826a76af2f625b9ba7a0f0fa3d60d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 4 Mar 2022 00:08:37 -0500 Subject: [PATCH 0762/1324] Derive some instances. --- src/Facet/Elab/Pattern.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index a1fb986bd..81fc10405 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -71,11 +71,13 @@ data Type | Type :* Type | Comp (Signature Type) | Datatype RName [Constructor] + deriving (Eq, Ord, Show) data Constructor = Constructor { name :: RName , fields :: [Type] } + deriving (Eq, Ord, Show) data Tableau = Tableau { context :: [Type] From c70af9f9728277ed29d850a6c9ab6cde8de5aea4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 5 Mar 2022 01:33:34 -0500 Subject: [PATCH 0763/1324] Treat empty datatypes like Zero. --- src/Facet/Elab/Pattern.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 81fc10405..7cf019b2b 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -149,5 +149,9 @@ coverStep = use context_ >>= \case Pair p1 p2 -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> p1:p2:clause) p -> fail ("unexpected pattern: " <> show p)) Comp{}:_ -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\ p -> fail ("unexpected pattern: " <> show p)) + Datatype _ []:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case + Wildcard -> pure () + Var _ -> pure () + p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail Datatype{}:_ -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\ p -> fail ("unexpected pattern: " <> show p)) [] -> pure () -- FIXME: fail if clauses aren't all empty From df179683444960b4ceea4ceb70d9ca464c18c860 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 5 Mar 2022 01:35:59 -0500 Subject: [PATCH 0764/1324] :fire: Zero. --- src/Facet/Elab/Pattern.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 7cf019b2b..b83d5bef1 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -65,7 +65,6 @@ data Type = String | ForAll | Arrow - | Zero | One | Type :+ Type | Type :* Type @@ -125,10 +124,6 @@ coverStep = use context_ >>= \case Wildcard -> pure () Var _ -> pure () p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail - Zero:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case - Wildcard -> pure () - Var _ -> pure () - p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail One:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case Wildcard -> pure () Var _ -> pure () From 57cafd4a02565bf462b3059ebd580e031ec7cd2d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 5 Mar 2022 01:40:26 -0500 Subject: [PATCH 0765/1324] Treat single, no-field constructors as unit. --- src/Facet/Elab/Pattern.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index b83d5bef1..3cfa8424e 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -148,5 +148,10 @@ coverStep = use context_ >>= \case Wildcard -> pure () Var _ -> pure () p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail + Datatype _ [Constructor _ []]:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case + Wildcard -> pure () + Var _ -> pure () + Unit -> pure () + p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail Datatype{}:_ -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\ p -> fail ("unexpected pattern: " <> show p)) [] -> pure () -- FIXME: fail if clauses aren't all empty From 77f217f0f99a9ee5cb586d324b301d7110f2c6b5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 5 Mar 2022 01:42:56 -0500 Subject: [PATCH 0766/1324] Add Cons patterns. --- src/Facet/Elab/Pattern.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 3cfa8424e..a016101dc 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -36,6 +36,7 @@ data Pattern a = Wildcard | Var a | Unit + | Cons RName [Pattern a] | InL (Pattern a) | InR (Pattern a) | Pair (Pattern a) (Pattern a) @@ -50,6 +51,7 @@ instance Monad Pattern where Wildcard -> Wildcard Var a -> f a Unit -> Unit + Cons n p -> Cons n (map (>>= f) p) InL p -> InL (p >>= f) InR q -> InR (q >>= f) Pair p q -> Pair (p >>= f) (q >>= f) From 3841f7bf53a03c5b1b590e3063890807ab6dd866 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 5 Mar 2022 01:44:12 -0500 Subject: [PATCH 0767/1324] Match against constructor patterns. --- src/Facet/Elab/Pattern.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index a016101dc..0d0ae49c9 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -150,10 +150,10 @@ coverStep = use context_ >>= \case Wildcard -> pure () Var _ -> pure () p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail - Datatype _ [Constructor _ []]:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case - Wildcard -> pure () - Var _ -> pure () - Unit -> pure () - p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail + Datatype _ [Constructor m []]:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case + Wildcard -> pure () + Var _ -> pure () + Cons n [] | m == n -> pure () + p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail Datatype{}:_ -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\ p -> fail ("unexpected pattern: " <> show p)) [] -> pure () -- FIXME: fail if clauses aren't all empty From 8370a323bba69997caf741ca2147cdd19acff65e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 5 Mar 2022 12:22:58 -0500 Subject: [PATCH 0768/1324] :fire: Unit patterns. --- src/Facet/Elab/Pattern.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 0d0ae49c9..f0fbfd997 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -35,7 +35,6 @@ import Fresnel.Traversal (traversed) data Pattern a = Wildcard | Var a - | Unit | Cons RName [Pattern a] | InL (Pattern a) | InR (Pattern a) @@ -50,7 +49,6 @@ instance Monad Pattern where m >>= f = case m of Wildcard -> Wildcard Var a -> f a - Unit -> Unit Cons n p -> Cons n (map (>>= f) p) InL p -> InL (p >>= f) InR q -> InR (q >>= f) @@ -127,10 +125,10 @@ coverStep = use context_ >>= \case Var _ -> pure () p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail One:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case - Wildcard -> pure () - Var _ -> pure () - Unit -> pure () - p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail + Wildcard -> pure () + Var _ -> pure () + Cons _ [] -> pure () + p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail (t1 :+ t2):ctx -> use heads_ >>= execWriter . traverseOf_ (folded.patterns_) (\case Wildcard:ps -> pure ([Clause (Wildcard:ps)], [Clause (Wildcard:ps)]) Var n:ps -> pure ([Clause (Var n:ps)], [Clause (Var n:ps)]) From 5605ed2244d875658ae4a8acb7f41ab715a2e6f4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 5 Mar 2022 12:29:17 -0500 Subject: [PATCH 0769/1324] Define an eliminator for strings. --- src/Facet/Sequent/Class.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index b052b5e97..fd88a4d60 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -42,6 +42,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma funL :: term -> coterm -> coterm sumL :: [term -> command] -> coterm prdL :: Int -> ([term] -> command) -> coterm + stringL :: (term -> command) -> coterm -- Commands (.|.) :: term -> coterm -> command From 263838bdf9fc76f9d08455c56b8772eeb83299cb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 5 Mar 2022 12:30:53 -0500 Subject: [PATCH 0770/1324] Lift stringL into effectful contexts. --- src/Facet/Sequent/Class.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index fd88a4d60..8f58a81bc 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -13,6 +13,7 @@ module Facet.Sequent.Class , funLA , sumLA , prdLA +, stringLA , (.||.) -- , Ctx(..) -- , Binding(..) @@ -97,6 +98,12 @@ prdLA -> m (i c) prdLA i = binder (prdL i) +stringLA + :: (Sequent t c d, Applicative i, Applicative m) + => (forall j . Applicative j => (i ~> j) -> j t -> m (j d)) + -> m (i c) +stringLA = binder stringL + (.||.) :: (Applicative m, Applicative i, Sequent t c d) => m (i t) -> m (i c) -> m (i d) (.||.) = liftA2 (liftA2 (.|.)) From ab8c9e3a8c83c6f4c7161e0d7986c4f39b3257ea Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 12 Mar 2022 01:33:17 -0500 Subject: [PATCH 0771/1324] Spacing. --- src/Facet/Sequent/Class.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 8f58a81bc..b2f8416a0 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -62,7 +62,7 @@ varA v = pure (pure (var v)) -> m (i t) µRA = binder µR -funRA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (i ~> j) -> j t -> m (j t))-> m (i t) +funRA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (i ~> j) -> j t -> m (j t)) -> m (i t) funRA = binder funR stringRA :: (Sequent t c d, Applicative i, Applicative m) => Text -> m (i t) From 7e7defe3ce55fa3fd9008f7858289ee4ea9e970e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 11:06:58 -0400 Subject: [PATCH 0772/1324] Give clauses a body. --- src/Facet/Elab/Pattern.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index f0fbfd997..987cefbd0 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -27,7 +27,6 @@ import Facet.Interface import Facet.Name import Fresnel.Effect hiding (view) import Fresnel.Fold -import Fresnel.Iso import Fresnel.Lens import Fresnel.List (head_) import Fresnel.Traversal (traversed) @@ -55,10 +54,10 @@ instance Monad Pattern where Pair p q -> Pair (p >>= f) (q >>= f) -newtype Clause = Clause [Pattern Name] +data Clause a = Clause { patterns :: [Pattern Name], body :: a } -patterns_ :: Iso' Clause [Pattern Name] -patterns_ = coerced +patterns_ :: Lens' (Clause a) [Pattern Name] +patterns_ = lens patterns (\ c patterns -> c{patterns}) data Type @@ -80,10 +79,10 @@ data Constructor = Constructor data Tableau = Tableau { context :: [Type] - , heads :: [Clause] + , heads :: [Clause ()] } -heads_ :: Lens' Tableau [Clause] +heads_ :: Lens' Tableau [Clause ()] heads_ = lens heads (\ t heads -> t{heads}) context_ :: Lens' Tableau [Type] From 410ef0e36d0d8baf22017b53cb4c4bc85422bfa9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 11:18:23 -0400 Subject: [PATCH 0773/1324] Extract pattern matching. --- src/Facet/Elab/Pattern.hs | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 987cefbd0..a1e327b5a 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -111,19 +111,19 @@ covers t = run (runFail (runChoose (liftA2 (&&)) (const (pure True)) (execState coverStep :: (Has Choose sig m, MonadFail m) => Covers m () coverStep = use context_ >>= \case - String:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case + String:ctx -> match (\case Wildcard -> pure () Var _ -> pure () p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail - ForAll{}:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case + ForAll{}:ctx -> match (\case Wildcard -> pure () Var _ -> pure () p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail - Arrow{}:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case + Arrow{}:ctx -> match (\case Wildcard -> pure () Var _ -> pure () p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail - One:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case + One:ctx -> match (\case Wildcard -> pure () Var _ -> pure () Cons _ [] -> pure () @@ -136,21 +136,24 @@ coverStep = use context_ >>= \case p:_ -> fail ("unexpected pattern: " <> show p) _ -> fail "no patterns to match sum") >>= \ (cs1, cs2) -> put (Tableau (t1:ctx) cs1) <|> put (Tableau (t2:ctx) cs2) - (t1 :* t2):ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case + (t1 :* t2):ctx -> match (\case Wildcard -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> Wildcard:Wildcard:clause) -- FIXME: this should bind fresh names Var n -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> Var n:Var n:clause) Pair p1 p2 -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> p1:p2:clause) p -> fail ("unexpected pattern: " <> show p)) - Comp{}:_ -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\ p -> fail ("unexpected pattern: " <> show p)) - Datatype _ []:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case + Comp{}:_ -> match (\ p -> fail ("unexpected pattern: " <> show p)) + Datatype _ []:ctx -> match (\case Wildcard -> pure () Var _ -> pure () p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail - Datatype _ [Constructor m []]:ctx -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\case + Datatype _ [Constructor m []]:ctx -> match (\case Wildcard -> pure () Var _ -> pure () Cons n [] | m == n -> pure () p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail - Datatype{}:_ -> use heads_ >>= traverseOf_ (folded.patterns_.head_) (\ p -> fail ("unexpected pattern: " <> show p)) + Datatype{}:_ -> match (\ p -> fail ("unexpected pattern: " <> show p)) [] -> pure () -- FIXME: fail if clauses aren't all empty + +match :: Algebra sig m => (Pattern Name -> Covers m ()) -> Covers m () +match f = use heads_ >>= traverseOf_ (folded.patterns_.head_) f From 90758e9d77bdd33b4234179887e9dc391dab53b9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 11:31:54 -0400 Subject: [PATCH 0774/1324] Define a Semigroup instance for Covers. --- src/Facet/Elab/Pattern.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index a1e327b5a..9221fb723 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -102,6 +102,9 @@ infixr 2 \/ newtype Covers m a = Covers { runCovers :: StateC Tableau m a } deriving (Algebra (State Tableau :+: sig), Applicative, Functor, Monad, MonadFail) +instance Semigroup a => Semigroup (Covers m a) where + a <> b = liftA2 (<>) a b + covers :: Tableau -> Either String Bool covers t = run (runFail (runChoose (liftA2 (&&)) (const (pure True)) (execState t (runCovers go)))) where From c3364e40b06868cf7b4000880554f8a599e8bbb3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 11:32:02 -0400 Subject: [PATCH 0775/1324] Define a Monoid instance for Covers. --- src/Facet/Elab/Pattern.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 9221fb723..dbed3829c 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -105,6 +105,9 @@ newtype Covers m a = Covers { runCovers :: StateC Tableau m a } instance Semigroup a => Semigroup (Covers m a) where a <> b = liftA2 (<>) a b +instance Monoid a => Monoid (Covers m a) where + mempty = pure mempty + covers :: Tableau -> Either String Bool covers t = run (runFail (runChoose (liftA2 (&&)) (const (pure True)) (execState t (runCovers go)))) where From 0886351f596a09c7c7ce53168bd50fcc34b7b9cc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 11:37:08 -0400 Subject: [PATCH 0776/1324] Fix up the sum case. --- src/Facet/Elab/Pattern.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index dbed3829c..6b7201ec9 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -20,7 +20,6 @@ import Control.Applicative (liftA2) import Control.Carrier.Choose.Church (runChoose) import Control.Carrier.Fail.Either import Control.Carrier.State.Church -import Control.Carrier.Writer.Church (execWriter) import Control.Effect.Choose import Control.Monad (ap) import Facet.Interface @@ -134,11 +133,11 @@ coverStep = use context_ >>= \case Var _ -> pure () Cons _ [] -> pure () p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail - (t1 :+ t2):ctx -> use heads_ >>= execWriter . traverseOf_ (folded.patterns_) (\case - Wildcard:ps -> pure ([Clause (Wildcard:ps)], [Clause (Wildcard:ps)]) - Var n:ps -> pure ([Clause (Var n:ps)], [Clause (Var n:ps)]) - InL p:ps -> pure ([Clause (p:ps)], [Clause []]) - InR q:qs -> pure ([Clause []], [Clause (q:qs)]) + (t1 :+ t2):ctx -> use heads_ >>= foldMapOf (folded.patterns_) (\case + Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) + Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) + InL p:ps -> pure ([Clause (p:ps) ()], [Clause [] ()]) + InR q:qs -> pure ([Clause [] ()], [Clause (q:qs) ()]) p:_ -> fail ("unexpected pattern: " <> show p) _ -> fail "no patterns to match sum") >>= \ (cs1, cs2) -> put (Tableau (t1:ctx) cs1) <|> put (Tableau (t2:ctx) cs2) From 6a082d8522f81240054d04a9db214945cb3d5b78 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 11:37:55 -0400 Subject: [PATCH 0777/1324] Update a FIXME. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 6b7201ec9..f4ba24e26 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -143,7 +143,7 @@ coverStep = use context_ >>= \case >>= \ (cs1, cs2) -> put (Tableau (t1:ctx) cs1) <|> put (Tableau (t2:ctx) cs2) (t1 :* t2):ctx -> match (\case Wildcard -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> Wildcard:Wildcard:clause) - -- FIXME: this should bind fresh names + -- FIXME: substitute variables out for wildcards so we don't have to bind fresh variable names Var n -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> Var n:Var n:clause) Pair p1 p2 -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> p1:p2:clause) p -> fail ("unexpected pattern: " <> show p)) From cfbf1bb43f5556b2805e84a45ddfeae898dd88c8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 12:58:28 -0400 Subject: [PATCH 0778/1324] Pluralize. --- src/Facet/Elab/Pattern.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index f4ba24e26..4b343838d 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -142,10 +142,10 @@ coverStep = use context_ >>= \case _ -> fail "no patterns to match sum") >>= \ (cs1, cs2) -> put (Tableau (t1:ctx) cs1) <|> put (Tableau (t2:ctx) cs2) (t1 :* t2):ctx -> match (\case - Wildcard -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> Wildcard:Wildcard:clause) + Wildcard -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clauses -> Wildcard:Wildcard:clauses) -- FIXME: substitute variables out for wildcards so we don't have to bind fresh variable names - Var n -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> Var n:Var n:clause) - Pair p1 p2 -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clause -> p1:p2:clause) + Var n -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clauses -> Var n:Var n:clauses) + Pair p1 p2 -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clauses -> p1:p2:clauses) p -> fail ("unexpected pattern: " <> show p)) Comp{}:_ -> match (\ p -> fail ("unexpected pattern: " <> show p)) Datatype _ []:ctx -> match (\case From 4a7fb26b268e76a1d9da907c74b4018a9baccc73 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 12:58:54 -0400 Subject: [PATCH 0779/1324] Take the tail of the clauses. --- src/Facet/Elab/Pattern.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 4b343838d..70b732c63 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -142,10 +142,10 @@ coverStep = use context_ >>= \case _ -> fail "no patterns to match sum") >>= \ (cs1, cs2) -> put (Tableau (t1:ctx) cs1) <|> put (Tableau (t2:ctx) cs2) (t1 :* t2):ctx -> match (\case - Wildcard -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clauses -> Wildcard:Wildcard:clauses) + Wildcard -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clauses -> Wildcard:Wildcard:tail clauses) -- FIXME: substitute variables out for wildcards so we don't have to bind fresh variable names - Var n -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clauses -> Var n:Var n:clauses) - Pair p1 p2 -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clauses -> p1:p2:clauses) + Var n -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clauses -> Var n:Var n:tail clauses) + Pair p1 p2 -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clauses -> p1:p2:tail clauses) p -> fail ("unexpected pattern: " <> show p)) Comp{}:_ -> match (\ p -> fail ("unexpected pattern: " <> show p)) Datatype _ []:ctx -> match (\case From 8e225806adc23a4d637cb94424a72ea04cf3382d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 13:00:31 -0400 Subject: [PATCH 0780/1324] Factor the context update out. --- src/Facet/Elab/Pattern.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 70b732c63..4f3a6474e 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -142,11 +142,11 @@ coverStep = use context_ >>= \case _ -> fail "no patterns to match sum") >>= \ (cs1, cs2) -> put (Tableau (t1:ctx) cs1) <|> put (Tableau (t2:ctx) cs2) (t1 :* t2):ctx -> match (\case - Wildcard -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clauses -> Wildcard:Wildcard:tail clauses) + Wildcard -> heads_.traversed.patterns_ %= (\ clauses -> Wildcard:Wildcard:tail clauses) -- FIXME: substitute variables out for wildcards so we don't have to bind fresh variable names - Var n -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clauses -> Var n:Var n:tail clauses) - Pair p1 p2 -> context_ .= t1:t2:ctx >> heads_.traversed.patterns_ %= (\ clauses -> p1:p2:tail clauses) - p -> fail ("unexpected pattern: " <> show p)) + Var n -> heads_.traversed.patterns_ %= (\ clauses -> Var n:Var n:tail clauses) + Pair p1 p2 -> heads_.traversed.patterns_ %= (\ clauses -> p1:p2:tail clauses) + p -> fail ("unexpected pattern: " <> show p)) >> context_ .= t1:t2:ctx Comp{}:_ -> match (\ p -> fail ("unexpected pattern: " <> show p)) Datatype _ []:ctx -> match (\case Wildcard -> pure () From 1e37b49abc9721a082705bf9e418ff33a44d4ce5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 13:03:46 -0400 Subject: [PATCH 0781/1324] Factor the context update further out. --- src/Facet/Elab/Pattern.hs | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 4f3a6474e..e0171fa9a 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -116,23 +116,23 @@ covers t = run (runFail (runChoose (liftA2 (&&)) (const (pure True)) (execState coverStep :: (Has Choose sig m, MonadFail m) => Covers m () coverStep = use context_ >>= \case - String:ctx -> match (\case + String:ctx -> match ctx (\case Wildcard -> pure () Var _ -> pure () - p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail - ForAll{}:ctx -> match (\case + p -> fail ("unexpected pattern: " <> show p)) >> heads_.traversed.patterns_ %= tail + ForAll{}:ctx -> match ctx (\case Wildcard -> pure () Var _ -> pure () - p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail - Arrow{}:ctx -> match (\case + p -> fail ("unexpected pattern: " <> show p)) >> heads_.traversed.patterns_ %= tail + Arrow{}:ctx -> match ctx (\case Wildcard -> pure () Var _ -> pure () - p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail - One:ctx -> match (\case + p -> fail ("unexpected pattern: " <> show p)) >> heads_.traversed.patterns_ %= tail + One:ctx -> match ctx (\case Wildcard -> pure () Var _ -> pure () Cons _ [] -> pure () - p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail + p -> fail ("unexpected pattern: " <> show p)) >> heads_.traversed.patterns_ %= tail (t1 :+ t2):ctx -> use heads_ >>= foldMapOf (folded.patterns_) (\case Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) @@ -141,24 +141,24 @@ coverStep = use context_ >>= \case p:_ -> fail ("unexpected pattern: " <> show p) _ -> fail "no patterns to match sum") >>= \ (cs1, cs2) -> put (Tableau (t1:ctx) cs1) <|> put (Tableau (t2:ctx) cs2) - (t1 :* t2):ctx -> match (\case + (t1 :* t2):ctx -> match (t1:t2:ctx) (\case Wildcard -> heads_.traversed.patterns_ %= (\ clauses -> Wildcard:Wildcard:tail clauses) -- FIXME: substitute variables out for wildcards so we don't have to bind fresh variable names Var n -> heads_.traversed.patterns_ %= (\ clauses -> Var n:Var n:tail clauses) Pair p1 p2 -> heads_.traversed.patterns_ %= (\ clauses -> p1:p2:tail clauses) - p -> fail ("unexpected pattern: " <> show p)) >> context_ .= t1:t2:ctx - Comp{}:_ -> match (\ p -> fail ("unexpected pattern: " <> show p)) - Datatype _ []:ctx -> match (\case + p -> fail ("unexpected pattern: " <> show p)) + Comp{}:ctx -> match ctx (\ p -> fail ("unexpected pattern: " <> show p)) + Datatype _ []:ctx -> match ctx (\case Wildcard -> pure () Var _ -> pure () - p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail - Datatype _ [Constructor m []]:ctx -> match (\case + p -> fail ("unexpected pattern: " <> show p)) >> heads_.traversed.patterns_ %= tail + Datatype _ [Constructor m []]:ctx -> match ctx (\case Wildcard -> pure () Var _ -> pure () Cons n [] | m == n -> pure () - p -> fail ("unexpected pattern: " <> show p)) >> context_ .= ctx >> heads_.traversed.patterns_ %= tail - Datatype{}:_ -> match (\ p -> fail ("unexpected pattern: " <> show p)) + p -> fail ("unexpected pattern: " <> show p)) >> heads_.traversed.patterns_ %= tail + Datatype{}:ctx -> match ctx (\ p -> fail ("unexpected pattern: " <> show p)) [] -> pure () -- FIXME: fail if clauses aren't all empty -match :: Algebra sig m => (Pattern Name -> Covers m ()) -> Covers m () -match f = use heads_ >>= traverseOf_ (folded.patterns_.head_) f +match :: Algebra sig m => [Type] -> (Pattern Name -> Covers m ()) -> Covers m () +match ctx f = use heads_ >>= traverseOf_ (folded.patterns_.head_) f >> context_ .= ctx From 979a7ab9ba8445c8f75a3c6594e589d75287a47a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 13:11:10 -0400 Subject: [PATCH 0782/1324] Factor out the tableau mutation. --- src/Facet/Elab/Pattern.hs | 40 +++++++++++++++++++-------------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index e0171fa9a..6d99fedfc 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -21,7 +21,7 @@ import Control.Carrier.Choose.Church (runChoose) import Control.Carrier.Fail.Either import Control.Carrier.State.Church import Control.Effect.Choose -import Control.Monad (ap) +import Control.Monad (ap, (<=<)) import Facet.Interface import Facet.Name import Fresnel.Effect hiding (view) @@ -117,21 +117,21 @@ covers t = run (runFail (runChoose (liftA2 (&&)) (const (pure True)) (execState coverStep :: (Has Choose sig m, MonadFail m) => Covers m () coverStep = use context_ >>= \case String:ctx -> match ctx (\case - Wildcard -> pure () - Var _ -> pure () + Wildcard -> pure tail + Var _ -> pure tail p -> fail ("unexpected pattern: " <> show p)) >> heads_.traversed.patterns_ %= tail ForAll{}:ctx -> match ctx (\case - Wildcard -> pure () - Var _ -> pure () + Wildcard -> pure tail + Var _ -> pure tail p -> fail ("unexpected pattern: " <> show p)) >> heads_.traversed.patterns_ %= tail Arrow{}:ctx -> match ctx (\case - Wildcard -> pure () - Var _ -> pure () + Wildcard -> pure tail + Var _ -> pure tail p -> fail ("unexpected pattern: " <> show p)) >> heads_.traversed.patterns_ %= tail One:ctx -> match ctx (\case - Wildcard -> pure () - Var _ -> pure () - Cons _ [] -> pure () + Wildcard -> pure tail + Var _ -> pure tail + Cons _ [] -> pure tail p -> fail ("unexpected pattern: " <> show p)) >> heads_.traversed.patterns_ %= tail (t1 :+ t2):ctx -> use heads_ >>= foldMapOf (folded.patterns_) (\case Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) @@ -142,23 +142,23 @@ coverStep = use context_ >>= \case _ -> fail "no patterns to match sum") >>= \ (cs1, cs2) -> put (Tableau (t1:ctx) cs1) <|> put (Tableau (t2:ctx) cs2) (t1 :* t2):ctx -> match (t1:t2:ctx) (\case - Wildcard -> heads_.traversed.patterns_ %= (\ clauses -> Wildcard:Wildcard:tail clauses) + Wildcard -> pure (\ clauses -> Wildcard:Wildcard:tail clauses) -- FIXME: substitute variables out for wildcards so we don't have to bind fresh variable names - Var n -> heads_.traversed.patterns_ %= (\ clauses -> Var n:Var n:tail clauses) - Pair p1 p2 -> heads_.traversed.patterns_ %= (\ clauses -> p1:p2:tail clauses) + Var n -> pure (\ clauses -> Var n:Var n:tail clauses) + Pair p1 p2 -> pure (\ clauses -> p1:p2:tail clauses) p -> fail ("unexpected pattern: " <> show p)) Comp{}:ctx -> match ctx (\ p -> fail ("unexpected pattern: " <> show p)) Datatype _ []:ctx -> match ctx (\case - Wildcard -> pure () - Var _ -> pure () + Wildcard -> pure tail + Var _ -> pure tail p -> fail ("unexpected pattern: " <> show p)) >> heads_.traversed.patterns_ %= tail Datatype _ [Constructor m []]:ctx -> match ctx (\case - Wildcard -> pure () - Var _ -> pure () - Cons n [] | m == n -> pure () + Wildcard -> pure tail + Var _ -> pure tail + Cons n [] | m == n -> pure tail p -> fail ("unexpected pattern: " <> show p)) >> heads_.traversed.patterns_ %= tail Datatype{}:ctx -> match ctx (\ p -> fail ("unexpected pattern: " <> show p)) [] -> pure () -- FIXME: fail if clauses aren't all empty -match :: Algebra sig m => [Type] -> (Pattern Name -> Covers m ()) -> Covers m () -match ctx f = use heads_ >>= traverseOf_ (folded.patterns_.head_) f >> context_ .= ctx +match :: Algebra sig m => [Type] -> (Pattern Name -> Covers m ([Pattern Name] -> [Pattern Name])) -> Covers m () +match ctx f = use heads_ >>= traverseOf_ (folded.patterns_.head_) ((\ g -> heads_.traversed.patterns_ %= g) <=< f) >> context_ .= ctx From f67a6d7d637331e050ed13b10310fbc66d63a01b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 13:58:04 -0400 Subject: [PATCH 0783/1324] :fire: duplicate mutations to the heads. --- src/Facet/Elab/Pattern.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 6d99fedfc..a81fff089 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -119,20 +119,20 @@ coverStep = use context_ >>= \case String:ctx -> match ctx (\case Wildcard -> pure tail Var _ -> pure tail - p -> fail ("unexpected pattern: " <> show p)) >> heads_.traversed.patterns_ %= tail + p -> fail ("unexpected pattern: " <> show p)) ForAll{}:ctx -> match ctx (\case Wildcard -> pure tail Var _ -> pure tail - p -> fail ("unexpected pattern: " <> show p)) >> heads_.traversed.patterns_ %= tail + p -> fail ("unexpected pattern: " <> show p)) Arrow{}:ctx -> match ctx (\case Wildcard -> pure tail Var _ -> pure tail - p -> fail ("unexpected pattern: " <> show p)) >> heads_.traversed.patterns_ %= tail + p -> fail ("unexpected pattern: " <> show p)) One:ctx -> match ctx (\case Wildcard -> pure tail Var _ -> pure tail Cons _ [] -> pure tail - p -> fail ("unexpected pattern: " <> show p)) >> heads_.traversed.patterns_ %= tail + p -> fail ("unexpected pattern: " <> show p)) (t1 :+ t2):ctx -> use heads_ >>= foldMapOf (folded.patterns_) (\case Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) @@ -151,12 +151,12 @@ coverStep = use context_ >>= \case Datatype _ []:ctx -> match ctx (\case Wildcard -> pure tail Var _ -> pure tail - p -> fail ("unexpected pattern: " <> show p)) >> heads_.traversed.patterns_ %= tail + p -> fail ("unexpected pattern: " <> show p)) Datatype _ [Constructor m []]:ctx -> match ctx (\case Wildcard -> pure tail Var _ -> pure tail Cons n [] | m == n -> pure tail - p -> fail ("unexpected pattern: " <> show p)) >> heads_.traversed.patterns_ %= tail + p -> fail ("unexpected pattern: " <> show p)) Datatype{}:ctx -> match ctx (\ p -> fail ("unexpected pattern: " <> show p)) [] -> pure () -- FIXME: fail if clauses aren't all empty From 2a707a4c784fda285979141903399ffad557df1f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 15:58:30 -0400 Subject: [PATCH 0784/1324] Combine the opaque patterns. --- src/Facet/Elab/Pattern.hs | 14 ++------------ 1 file changed, 2 insertions(+), 12 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index a81fff089..525601ace 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -60,9 +60,7 @@ patterns_ = lens patterns (\ c patterns -> c{patterns}) data Type - = String - | ForAll - | Arrow + = Opaque | One | Type :+ Type | Type :* Type @@ -116,15 +114,7 @@ covers t = run (runFail (runChoose (liftA2 (&&)) (const (pure True)) (execState coverStep :: (Has Choose sig m, MonadFail m) => Covers m () coverStep = use context_ >>= \case - String:ctx -> match ctx (\case - Wildcard -> pure tail - Var _ -> pure tail - p -> fail ("unexpected pattern: " <> show p)) - ForAll{}:ctx -> match ctx (\case - Wildcard -> pure tail - Var _ -> pure tail - p -> fail ("unexpected pattern: " <> show p)) - Arrow{}:ctx -> match ctx (\case + Opaque:ctx -> match ctx (\case Wildcard -> pure tail Var _ -> pure tail p -> fail ("unexpected pattern: " <> show p)) From cb7abc29f46656656dc49e0cb96dd870b8aff20b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 16:01:10 -0400 Subject: [PATCH 0785/1324] :fire: Datatype & Constructor. The intention here is that the caller will translate into the available constructors instead. --- src/Facet/Elab/Pattern.hs | 18 ------------------ 1 file changed, 18 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 525601ace..303a17868 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -4,7 +4,6 @@ module Facet.Elab.Pattern , Clause(..) , patterns_ , Type(..) -, Constructor(..) , Tableau(..) , heads_ , Branch(..) @@ -65,13 +64,6 @@ data Type | Type :+ Type | Type :* Type | Comp (Signature Type) - | Datatype RName [Constructor] - deriving (Eq, Ord, Show) - -data Constructor = Constructor - { name :: RName - , fields :: [Type] - } deriving (Eq, Ord, Show) data Tableau = Tableau @@ -138,16 +130,6 @@ coverStep = use context_ >>= \case Pair p1 p2 -> pure (\ clauses -> p1:p2:tail clauses) p -> fail ("unexpected pattern: " <> show p)) Comp{}:ctx -> match ctx (\ p -> fail ("unexpected pattern: " <> show p)) - Datatype _ []:ctx -> match ctx (\case - Wildcard -> pure tail - Var _ -> pure tail - p -> fail ("unexpected pattern: " <> show p)) - Datatype _ [Constructor m []]:ctx -> match ctx (\case - Wildcard -> pure tail - Var _ -> pure tail - Cons n [] | m == n -> pure tail - p -> fail ("unexpected pattern: " <> show p)) - Datatype{}:ctx -> match ctx (\ p -> fail ("unexpected pattern: " <> show p)) [] -> pure () -- FIXME: fail if clauses aren't all empty match :: Algebra sig m => [Type] -> (Pattern Name -> Covers m ([Pattern Name] -> [Pattern Name])) -> Covers m () From 65c5462d2674dd090925a2b0df914a94ecf6f606 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 16:30:39 -0400 Subject: [PATCH 0786/1324] Give fixity & precedence for the Type operators. --- src/Facet/Elab/Pattern.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 303a17868..a6349828e 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -66,6 +66,9 @@ data Type | Comp (Signature Type) deriving (Eq, Ord, Show) +infixl 6 :+ +infixl 7 :* + data Tableau = Tableau { context :: [Type] , heads :: [Clause ()] From 9b65a22952f9f4e027cc276ac32fcdae94baf337 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 16:31:42 -0400 Subject: [PATCH 0787/1324] :fire: parens. --- src/Facet/Elab/Pattern.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index a6349828e..88bd00035 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -118,7 +118,7 @@ coverStep = use context_ >>= \case Var _ -> pure tail Cons _ [] -> pure tail p -> fail ("unexpected pattern: " <> show p)) - (t1 :+ t2):ctx -> use heads_ >>= foldMapOf (folded.patterns_) (\case + t1 :+ t2:ctx -> use heads_ >>= foldMapOf (folded.patterns_) (\case Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) InL p:ps -> pure ([Clause (p:ps) ()], [Clause [] ()]) @@ -126,7 +126,7 @@ coverStep = use context_ >>= \case p:_ -> fail ("unexpected pattern: " <> show p) _ -> fail "no patterns to match sum") >>= \ (cs1, cs2) -> put (Tableau (t1:ctx) cs1) <|> put (Tableau (t2:ctx) cs2) - (t1 :* t2):ctx -> match (t1:t2:ctx) (\case + t1 :* t2:ctx -> match (t1:t2:ctx) (\case Wildcard -> pure (\ clauses -> Wildcard:Wildcard:tail clauses) -- FIXME: substitute variables out for wildcards so we don't have to bind fresh variable names Var n -> pure (\ clauses -> Var n:Var n:tail clauses) From 156ffcab4b5c2ac2698d134d6b4ad86c5f99c04c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 17:20:11 -0400 Subject: [PATCH 0788/1324] Simplify matching. --- src/Facet/Elab/Pattern.hs | 31 +++++++++++++++---------------- 1 file changed, 15 insertions(+), 16 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 88bd00035..8a14713e1 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -20,14 +20,13 @@ import Control.Carrier.Choose.Church (runChoose) import Control.Carrier.Fail.Either import Control.Carrier.State.Church import Control.Effect.Choose -import Control.Monad (ap, (<=<)) +import Control.Monad (ap) import Facet.Interface import Facet.Name import Fresnel.Effect hiding (view) import Fresnel.Fold import Fresnel.Lens -import Fresnel.List (head_) -import Fresnel.Traversal (traversed) +import Fresnel.Traversal (traverseOf, traversed) data Pattern a = Wildcard @@ -110,14 +109,14 @@ covers t = run (runFail (runChoose (liftA2 (&&)) (const (pure True)) (execState coverStep :: (Has Choose sig m, MonadFail m) => Covers m () coverStep = use context_ >>= \case Opaque:ctx -> match ctx (\case - Wildcard -> pure tail - Var _ -> pure tail - p -> fail ("unexpected pattern: " <> show p)) + Wildcard:ps -> pure ps + Var _:ps -> pure ps + p -> fail ("unexpected pattern: " <> show p)) One:ctx -> match ctx (\case - Wildcard -> pure tail - Var _ -> pure tail - Cons _ [] -> pure tail - p -> fail ("unexpected pattern: " <> show p)) + Wildcard:ps -> pure ps + Var _:ps -> pure ps + Cons _ []:ps -> pure ps + p -> fail ("unexpected pattern: " <> show p)) t1 :+ t2:ctx -> use heads_ >>= foldMapOf (folded.patterns_) (\case Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) @@ -127,13 +126,13 @@ coverStep = use context_ >>= \case _ -> fail "no patterns to match sum") >>= \ (cs1, cs2) -> put (Tableau (t1:ctx) cs1) <|> put (Tableau (t2:ctx) cs2) t1 :* t2:ctx -> match (t1:t2:ctx) (\case - Wildcard -> pure (\ clauses -> Wildcard:Wildcard:tail clauses) + Wildcard:ps -> pure (Wildcard:Wildcard:ps) -- FIXME: substitute variables out for wildcards so we don't have to bind fresh variable names - Var n -> pure (\ clauses -> Var n:Var n:tail clauses) - Pair p1 p2 -> pure (\ clauses -> p1:p2:tail clauses) - p -> fail ("unexpected pattern: " <> show p)) + Var n:ps -> pure (Var n:Var n:ps) + Pair p1 p2:ps -> pure (p1:p2:ps) + p -> fail ("unexpected pattern: " <> show p)) Comp{}:ctx -> match ctx (\ p -> fail ("unexpected pattern: " <> show p)) [] -> pure () -- FIXME: fail if clauses aren't all empty -match :: Algebra sig m => [Type] -> (Pattern Name -> Covers m ([Pattern Name] -> [Pattern Name])) -> Covers m () -match ctx f = use heads_ >>= traverseOf_ (folded.patterns_.head_) ((\ g -> heads_.traversed.patterns_ %= g) <=< f) >> context_ .= ctx +match :: Algebra sig m => [Type] -> ([Pattern Name] -> Covers m [Pattern Name]) -> Covers m () +match ctx f = heads_ <~ (use heads_ >>= traverseOf (traversed.patterns_) f) >> context_ .= ctx From e7181b4694dac9a3d2a4090fdbd6b1b08a2e2dc7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 17:22:55 -0400 Subject: [PATCH 0789/1324] Parameterize Tableau by the type of clause bodies. --- src/Facet/Elab/Pattern.hs | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 8a14713e1..7649ba573 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -68,15 +68,15 @@ data Type infixl 6 :+ infixl 7 :* -data Tableau = Tableau +data Tableau a = Tableau { context :: [Type] - , heads :: [Clause ()] + , heads :: [Clause a] } -heads_ :: Lens' Tableau [Clause ()] +heads_ :: Lens (Tableau a) (Tableau b) [Clause a] [Clause b] heads_ = lens heads (\ t heads -> t{heads}) -context_ :: Lens' Tableau [Type] +context_ :: Lens' (Tableau a) [Type] context_ = lens context (\ t context -> t{context}) @@ -90,8 +90,8 @@ infixr 2 \/ -- Coverage judgement -newtype Covers m a = Covers { runCovers :: StateC Tableau m a } - deriving (Algebra (State Tableau :+: sig), Applicative, Functor, Monad, MonadFail) +newtype Covers m a = Covers { runCovers :: StateC (Tableau ()) m a } + deriving (Algebra (State (Tableau ()) :+: sig), Applicative, Functor, Monad, MonadFail) instance Semigroup a => Semigroup (Covers m a) where a <> b = liftA2 (<>) a b @@ -100,14 +100,14 @@ instance Monoid a => Monoid (Covers m a) where mempty = pure mempty -covers :: Tableau -> Either String Bool +covers :: Tableau () -> Either String Bool covers t = run (runFail (runChoose (liftA2 (&&)) (const (pure True)) (execState t (runCovers go)))) where - go = use context_ >>= \case + go = use (context_ @()) >>= \case [] -> pure () _ -> coverStep >> go coverStep :: (Has Choose sig m, MonadFail m) => Covers m () -coverStep = use context_ >>= \case +coverStep = use (context_ @()) >>= \case Opaque:ctx -> match ctx (\case Wildcard:ps -> pure ps Var _:ps -> pure ps @@ -117,7 +117,7 @@ coverStep = use context_ >>= \case Var _:ps -> pure ps Cons _ []:ps -> pure ps p -> fail ("unexpected pattern: " <> show p)) - t1 :+ t2:ctx -> use heads_ >>= foldMapOf (folded.patterns_) (\case + t1 :+ t2:ctx -> use (heads_ @()) >>= foldMapOf (folded.patterns_) (\case Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) InL p:ps -> pure ([Clause (p:ps) ()], [Clause [] ()]) @@ -135,4 +135,4 @@ coverStep = use context_ >>= \case [] -> pure () -- FIXME: fail if clauses aren't all empty match :: Algebra sig m => [Type] -> ([Pattern Name] -> Covers m [Pattern Name]) -> Covers m () -match ctx f = heads_ <~ (use heads_ >>= traverseOf (traversed.patterns_) f) >> context_ .= ctx +match ctx f = (heads_ @()) <~ (use heads_ >>= traverseOf (traversed.patterns_) f) >> (context_ @()) .= ctx From 5bea8c2b99e4f8fe0540035e134052da187ad038 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 20:51:41 -0400 Subject: [PATCH 0790/1324] Rewrite match using lens operators. --- src/Facet/Elab/Pattern.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 7649ba573..a25ec4b24 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -25,6 +25,7 @@ import Facet.Interface import Facet.Name import Fresnel.Effect hiding (view) import Fresnel.Fold +import Fresnel.Getter import Fresnel.Lens import Fresnel.Traversal (traverseOf, traversed) @@ -135,4 +136,16 @@ coverStep = use (context_ @()) >>= \case [] -> pure () -- FIXME: fail if clauses aren't all empty match :: Algebra sig m => [Type] -> ([Pattern Name] -> Covers m [Pattern Name]) -> Covers m () -match ctx f = (heads_ @()) <~ (use heads_ >>= traverseOf (traversed.patterns_) f) >> (context_ @()) .= ctx +match ctx f = heads_ @() <~> traverseOf (traversed.patterns_) f >> context_ @() .= ctx + +-- | Compose a getter onto the input of a Kleisli arrow and run it on the 'State'. +(~>) :: Has (State s) sig m => Getter s a -> (a -> m b) -> m b +o ~> k = use o >>= k + +infixr 2 ~> + +-- | Compose a lens onto either side of a Kleisli arrow and run it on the 'State'. +(<~>) :: Has (State s) sig m => Lens' s a -> (a -> m a) -> m () +o <~> k = o <~ o ~> k + +infixr 2 <~> From 9dc8d6fc259f9e3d95f96a961cb25da9b3766494 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 23:13:01 -0400 Subject: [PATCH 0791/1324] Replace Cons patterns with Unit. --- src/Facet/Elab/Pattern.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index a25ec4b24..23801ca3b 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -32,7 +32,7 @@ import Fresnel.Traversal (traverseOf, traversed) data Pattern a = Wildcard | Var a - | Cons RName [Pattern a] + | Unit | InL (Pattern a) | InR (Pattern a) | Pair (Pattern a) (Pattern a) @@ -45,8 +45,8 @@ instance Applicative Pattern where instance Monad Pattern where m >>= f = case m of Wildcard -> Wildcard + Unit -> Unit Var a -> f a - Cons n p -> Cons n (map (>>= f) p) InL p -> InL (p >>= f) InR q -> InR (q >>= f) Pair p q -> Pair (p >>= f) (q >>= f) @@ -114,10 +114,10 @@ coverStep = use (context_ @()) >>= \case Var _:ps -> pure ps p -> fail ("unexpected pattern: " <> show p)) One:ctx -> match ctx (\case - Wildcard:ps -> pure ps - Var _:ps -> pure ps - Cons _ []:ps -> pure ps - p -> fail ("unexpected pattern: " <> show p)) + Wildcard:ps -> pure ps + Var _:ps -> pure ps + Unit:ps -> pure ps + p -> fail ("unexpected pattern: " <> show p)) t1 :+ t2:ctx -> use (heads_ @()) >>= foldMapOf (folded.patterns_) (\case Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) From 1a8a545030e0ef3a66539395554b60abf8972770 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 23:15:41 -0400 Subject: [PATCH 0792/1324] :fire: Comp for now. --- src/Facet/Elab/Pattern.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 23801ca3b..47b533710 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -21,7 +21,6 @@ import Control.Carrier.Fail.Either import Control.Carrier.State.Church import Control.Effect.Choose import Control.Monad (ap) -import Facet.Interface import Facet.Name import Fresnel.Effect hiding (view) import Fresnel.Fold @@ -63,7 +62,6 @@ data Type | One | Type :+ Type | Type :* Type - | Comp (Signature Type) deriving (Eq, Ord, Show) infixl 6 :+ @@ -132,7 +130,6 @@ coverStep = use (context_ @()) >>= \case Var n:ps -> pure (Var n:Var n:ps) Pair p1 p2:ps -> pure (p1:p2:ps) p -> fail ("unexpected pattern: " <> show p)) - Comp{}:ctx -> match ctx (\ p -> fail ("unexpected pattern: " <> show p)) [] -> pure () -- FIXME: fail if clauses aren't all empty match :: Algebra sig m => [Type] -> ([Pattern Name] -> Covers m [Pattern Name]) -> Covers m () From eb135e3e8cf41ed9fa89fe2a763280657fbaa8da Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 13 Mar 2022 23:36:09 -0400 Subject: [PATCH 0793/1324] :fire: the State. --- src/Facet/Elab/Pattern.hs | 53 +++++++++++++++------------------------ 1 file changed, 20 insertions(+), 33 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 47b533710..03805848a 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -18,14 +18,13 @@ import Control.Algebra import Control.Applicative (liftA2) import Control.Carrier.Choose.Church (runChoose) import Control.Carrier.Fail.Either -import Control.Carrier.State.Church import Control.Effect.Choose import Control.Monad (ap) +import Data.Function import Facet.Name -import Fresnel.Effect hiding (view) import Fresnel.Fold -import Fresnel.Getter import Fresnel.Lens +import Fresnel.Setter import Fresnel.Traversal (traverseOf, traversed) data Pattern a @@ -89,60 +88,48 @@ infixr 2 \/ -- Coverage judgement -newtype Covers m a = Covers { runCovers :: StateC (Tableau ()) m a } - deriving (Algebra (State (Tableau ()) :+: sig), Applicative, Functor, Monad, MonadFail) +newtype Covers m a = Covers { runCovers :: m a } + deriving (Algebra sig, Applicative, Functor, Monad, MonadFail) -instance Semigroup a => Semigroup (Covers m a) where +instance (Applicative m, Semigroup a) => Semigroup (Covers m a) where a <> b = liftA2 (<>) a b -instance Monoid a => Monoid (Covers m a) where +instance (Applicative m, Monoid a) => Monoid (Covers m a) where mempty = pure mempty covers :: Tableau () -> Either String Bool -covers t = run (runFail (runChoose (liftA2 (&&)) (const (pure True)) (execState t (runCovers go)))) where - go = use (context_ @()) >>= \case +covers t = run (runFail (runChoose (liftA2 (&&)) (const (pure True)) (runCovers (go t)))) where + go tableau = case context tableau of [] -> pure () - _ -> coverStep >> go + _ -> coverStep tableau >>= go -coverStep :: (Has Choose sig m, MonadFail m) => Covers m () -coverStep = use (context_ @()) >>= \case - Opaque:ctx -> match ctx (\case +coverStep :: (Has Choose sig m, MonadFail m) => Tableau () -> Covers m (Tableau ()) +coverStep tableau = case context tableau of + Opaque:ctx -> match (tableau & context_ .~ ctx) (\case Wildcard:ps -> pure ps Var _:ps -> pure ps p -> fail ("unexpected pattern: " <> show p)) - One:ctx -> match ctx (\case + One:ctx -> match (tableau & context_ .~ ctx) (\case Wildcard:ps -> pure ps Var _:ps -> pure ps Unit:ps -> pure ps p -> fail ("unexpected pattern: " <> show p)) - t1 :+ t2:ctx -> use (heads_ @()) >>= foldMapOf (folded.patterns_) (\case + t1 :+ t2:ctx -> foldMapOf (folded.patterns_) (\case Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) InL p:ps -> pure ([Clause (p:ps) ()], [Clause [] ()]) InR q:qs -> pure ([Clause [] ()], [Clause (q:qs) ()]) p:_ -> fail ("unexpected pattern: " <> show p) - _ -> fail "no patterns to match sum") - >>= \ (cs1, cs2) -> put (Tableau (t1:ctx) cs1) <|> put (Tableau (t2:ctx) cs2) - t1 :* t2:ctx -> match (t1:t2:ctx) (\case + _ -> fail "no patterns to match sum") (heads tableau) + >>= \ (cs1, cs2) -> pure (Tableau (t1:ctx) cs1) <|> pure (Tableau (t2:ctx) cs2) + t1 :* t2:ctx -> match (tableau & context_ .~ t1:t2:ctx) (\case Wildcard:ps -> pure (Wildcard:Wildcard:ps) -- FIXME: substitute variables out for wildcards so we don't have to bind fresh variable names Var n:ps -> pure (Var n:Var n:ps) Pair p1 p2:ps -> pure (p1:p2:ps) p -> fail ("unexpected pattern: " <> show p)) - [] -> pure () -- FIXME: fail if clauses aren't all empty + [] -> pure tableau -- FIXME: fail if clauses aren't all empty -match :: Algebra sig m => [Type] -> ([Pattern Name] -> Covers m [Pattern Name]) -> Covers m () -match ctx f = heads_ @() <~> traverseOf (traversed.patterns_) f >> context_ @() .= ctx - --- | Compose a getter onto the input of a Kleisli arrow and run it on the 'State'. -(~>) :: Has (State s) sig m => Getter s a -> (a -> m b) -> m b -o ~> k = use o >>= k - -infixr 2 ~> - --- | Compose a lens onto either side of a Kleisli arrow and run it on the 'State'. -(<~>) :: Has (State s) sig m => Lens' s a -> (a -> m a) -> m () -o <~> k = o <~ o ~> k - -infixr 2 <~> +match :: Algebra sig m => Tableau () -> ([Pattern Name] -> Covers m [Pattern Name]) -> Covers m (Tableau ()) +match tableau f = flip (set (heads_ @())) tableau <$> traverseOf (traversed.patterns_) f (heads tableau) From 00a28ddb8d99c5e8458d1d74d09f4176006fa1f8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 14 Mar 2022 09:35:37 -0400 Subject: [PATCH 0794/1324] Sort. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 03805848a..0242e3023 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -43,8 +43,8 @@ instance Applicative Pattern where instance Monad Pattern where m >>= f = case m of Wildcard -> Wildcard - Unit -> Unit Var a -> f a + Unit -> Unit InL p -> InL (p >>= f) InR q -> InR (q >>= f) Pair p q -> Pair (p >>= f) (q >>= f) From 5afd7184dbfff28f4d86b2be6e0d041ef3f2af35 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 14 Mar 2022 09:37:00 -0400 Subject: [PATCH 0795/1324] Define prisms for Pattern. --- src/Facet/Elab/Pattern.hs | 32 ++++++++++++++++++++++++++++++++ 1 file changed, 32 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 0242e3023..057109040 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -24,6 +24,7 @@ import Data.Function import Facet.Name import Fresnel.Fold import Fresnel.Lens +import Fresnel.Prism (Prism', prism') import Fresnel.Setter import Fresnel.Traversal (traverseOf, traversed) @@ -50,6 +51,37 @@ instance Monad Pattern where Pair p q -> Pair (p >>= f) (q >>= f) +_Wildcard :: Prism' (Pattern a) () +_Wildcard = prism' (const Wildcard) (\case + Wildcard -> Just () + _ -> Nothing) + +_Var :: Prism' (Pattern a) a +_Var = prism' Var (\case + Var a -> Just a + _ -> Nothing) + +_Unit :: Prism' (Pattern a) () +_Unit = prism' (const Unit) (\case + Unit -> Just () + _ -> Nothing) + +_Inl :: Prism' (Pattern a) (Pattern a) +_Inl = prism' InL (\case + InL p -> Just p + _ -> Nothing) + +_Inr :: Prism' (Pattern a) (Pattern a) +_Inr = prism' InR (\case + InR p -> Just p + _ -> Nothing) + +_Pair :: Prism' (Pattern a) (Pattern a, Pattern a) +_Pair = prism' (uncurry Pair) (\case + Pair p q -> Just (p, q) + _ -> Nothing) + + data Clause a = Clause { patterns :: [Pattern Name], body :: a } patterns_ :: Lens' (Clause a) [Pattern Name] From f523a8d3f5c527e1561e69bbbc0be4fcae6f9e7d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 14 Mar 2022 09:54:41 -0400 Subject: [PATCH 0796/1324] Simplify Covers. --- src/Facet/Elab/Pattern.hs | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 057109040..e0316d03b 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE UndecidableInstances #-} module Facet.Elab.Pattern ( Pattern(..) , Clause(..) @@ -16,10 +17,11 @@ module Facet.Elab.Pattern import Control.Algebra import Control.Applicative (liftA2) -import Control.Carrier.Choose.Church (runChoose) +import Control.Carrier.Choose.Church (ChooseC, runChoose) import Control.Carrier.Fail.Either import Control.Effect.Choose import Control.Monad (ap) +import Control.Monad.Trans.Class import Data.Function import Facet.Name import Fresnel.Fold @@ -120,8 +122,14 @@ infixr 2 \/ -- Coverage judgement -newtype Covers m a = Covers { runCovers :: m a } - deriving (Algebra sig, Applicative, Functor, Monad, MonadFail) +runCovers :: (FailC m r -> FailC m r -> FailC m r) -> (a -> FailC m r) -> Covers m a -> m (Either String r) +runCovers fork leaf (Covers m) = runFail (runChoose fork leaf m) + +newtype Covers m a = Covers (ChooseC (FailC m) a) + deriving (Algebra (Choose :+: Fail :+: sig), Applicative, Functor, Monad) + +instance Algebra sig m => MonadFail (Covers m) where + fail = Covers . lift . fail instance (Applicative m, Semigroup a) => Semigroup (Covers m a) where a <> b = liftA2 (<>) a b @@ -131,12 +139,12 @@ instance (Applicative m, Monoid a) => Monoid (Covers m a) where covers :: Tableau () -> Either String Bool -covers t = run (runFail (runChoose (liftA2 (&&)) (const (pure True)) (runCovers (go t)))) where +covers t = run (runCovers (liftA2 (&&)) (const (pure True)) (go t)) where go tableau = case context tableau of [] -> pure () _ -> coverStep tableau >>= go -coverStep :: (Has Choose sig m, MonadFail m) => Tableau () -> Covers m (Tableau ()) +coverStep :: Algebra sig m => Tableau () -> Covers m (Tableau ()) coverStep tableau = case context tableau of Opaque:ctx -> match (tableau & context_ .~ ctx) (\case Wildcard:ps -> pure ps @@ -163,5 +171,5 @@ coverStep tableau = case context tableau of p -> fail ("unexpected pattern: " <> show p)) [] -> pure tableau -- FIXME: fail if clauses aren't all empty -match :: Algebra sig m => Tableau () -> ([Pattern Name] -> Covers m [Pattern Name]) -> Covers m (Tableau ()) +match :: Tableau () -> ([Pattern Name] -> Covers m [Pattern Name]) -> Covers m (Tableau ()) match tableau f = flip (set (heads_ @())) tableau <$> traverseOf (traversed.patterns_) f (heads tableau) From 814a3b52218f6bdf6715e31d595a681a5f212925 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 14 Mar 2022 09:56:39 -0400 Subject: [PATCH 0797/1324] Eta-reduce. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index e0316d03b..267d69701 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -132,7 +132,7 @@ instance Algebra sig m => MonadFail (Covers m) where fail = Covers . lift . fail instance (Applicative m, Semigroup a) => Semigroup (Covers m a) where - a <> b = liftA2 (<>) a b + (<>) = liftA2 (<>) instance (Applicative m, Monoid a) => Monoid (Covers m a) where mempty = pure mempty From c5c3ed991fb9155ee661550e329febec4aeb5be3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 14 Mar 2022 17:17:03 -0400 Subject: [PATCH 0798/1324] Dedent. --- src/Facet/Elab/Pattern.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 267d69701..5c53e8b0f 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -156,12 +156,12 @@ coverStep tableau = case context tableau of Unit:ps -> pure ps p -> fail ("unexpected pattern: " <> show p)) t1 :+ t2:ctx -> foldMapOf (folded.patterns_) (\case - Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) - Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) - InL p:ps -> pure ([Clause (p:ps) ()], [Clause [] ()]) - InR q:qs -> pure ([Clause [] ()], [Clause (q:qs) ()]) - p:_ -> fail ("unexpected pattern: " <> show p) - _ -> fail "no patterns to match sum") (heads tableau) + Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) + Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) + InL p:ps -> pure ([Clause (p:ps) ()], [Clause [] ()]) + InR q:qs -> pure ([Clause [] ()], [Clause (q:qs) ()]) + p:_ -> fail ("unexpected pattern: " <> show p) + _ -> fail "no patterns to match sum") (heads tableau) >>= \ (cs1, cs2) -> pure (Tableau (t1:ctx) cs1) <|> pure (Tableau (t2:ctx) cs2) t1 :* t2:ctx -> match (tableau & context_ .~ t1:t2:ctx) (\case Wildcard:ps -> pure (Wildcard:Wildcard:ps) From 9616a7c82fcb3ac440c31c49e47fb97896de9690 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 14 Mar 2022 17:38:15 -0400 Subject: [PATCH 0799/1324] :fire: Covers. --- src/Facet/Elab/Pattern.hs | 85 ++++++++++++++------------------------- 1 file changed, 31 insertions(+), 54 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 5c53e8b0f..6287b0ceb 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -10,19 +10,13 @@ module Facet.Elab.Pattern , Branch(..) , (\/) -- * Coverage judgement -, Covers(..) , covers , coverStep ) where -import Control.Algebra -import Control.Applicative (liftA2) -import Control.Carrier.Choose.Church (ChooseC, runChoose) -import Control.Carrier.Fail.Either -import Control.Effect.Choose -import Control.Monad (ap) -import Control.Monad.Trans.Class +import Control.Monad (ap, join) import Data.Function +import Data.Monoid import Facet.Name import Fresnel.Fold import Fresnel.Lens @@ -122,54 +116,37 @@ infixr 2 \/ -- Coverage judgement -runCovers :: (FailC m r -> FailC m r -> FailC m r) -> (a -> FailC m r) -> Covers m a -> m (Either String r) -runCovers fork leaf (Covers m) = runFail (runChoose fork leaf m) +covers :: Tableau () -> Either String [Tableau ()] +covers tableau = case context tableau of + [] -> Right [tableau] + _ -> coverStep tableau >>= fmap join . traverse covers -newtype Covers m a = Covers (ChooseC (FailC m) a) - deriving (Algebra (Choose :+: Fail :+: sig), Applicative, Functor, Monad) - -instance Algebra sig m => MonadFail (Covers m) where - fail = Covers . lift . fail - -instance (Applicative m, Semigroup a) => Semigroup (Covers m a) where - (<>) = liftA2 (<>) - -instance (Applicative m, Monoid a) => Monoid (Covers m a) where - mempty = pure mempty - - -covers :: Tableau () -> Either String Bool -covers t = run (runCovers (liftA2 (&&)) (const (pure True)) (go t)) where - go tableau = case context tableau of - [] -> pure () - _ -> coverStep tableau >>= go - -coverStep :: Algebra sig m => Tableau () -> Covers m (Tableau ()) +coverStep :: Tableau () -> Either String [Tableau ()] coverStep tableau = case context tableau of - Opaque:ctx -> match (tableau & context_ .~ ctx) (\case - Wildcard:ps -> pure ps - Var _:ps -> pure ps - p -> fail ("unexpected pattern: " <> show p)) - One:ctx -> match (tableau & context_ .~ ctx) (\case - Wildcard:ps -> pure ps - Var _:ps -> pure ps - Unit:ps -> pure ps - p -> fail ("unexpected pattern: " <> show p)) - t1 :+ t2:ctx -> foldMapOf (folded.patterns_) (\case - Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) - Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) - InL p:ps -> pure ([Clause (p:ps) ()], [Clause [] ()]) - InR q:qs -> pure ([Clause [] ()], [Clause (q:qs) ()]) - p:_ -> fail ("unexpected pattern: " <> show p) - _ -> fail "no patterns to match sum") (heads tableau) - >>= \ (cs1, cs2) -> pure (Tableau (t1:ctx) cs1) <|> pure (Tableau (t2:ctx) cs2) - t1 :* t2:ctx -> match (tableau & context_ .~ t1:t2:ctx) (\case - Wildcard:ps -> pure (Wildcard:Wildcard:ps) + Opaque:ctx -> pure <$> match (tableau & context_ .~ ctx) (\case + Wildcard:ps -> Right ps + Var _:ps -> Right ps + p -> Left ("unexpected pattern: " <> show p)) + One:ctx -> pure <$> match (tableau & context_ .~ ctx) (\case + Wildcard:ps -> Right ps + Var _:ps -> Right ps + Unit:ps -> Right ps + p -> Left ("unexpected pattern: " <> show p)) + t1 :+ t2:ctx -> getAp (foldMapOf (folded.patterns_) (Ap . \case + Wildcard:ps -> Right ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) + Var n:ps -> Right ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) + InL p:ps -> Right ([Clause (p:ps) ()], [Clause [] ()]) + InR q:qs -> Right ([Clause [] ()], [Clause (q:qs) ()]) + p:_ -> Left ("unexpected pattern: " <> show p) + _ -> Left "no patterns to match sum") (heads tableau)) + >>= \ (cs1, cs2) -> Right [Tableau (t1:ctx) cs1, Tableau (t2:ctx) cs2] + t1 :* t2:ctx -> pure <$> match (tableau & context_ .~ t1:t2:ctx) (\case + Wildcard:ps -> Right (Wildcard:Wildcard:ps) -- FIXME: substitute variables out for wildcards so we don't have to bind fresh variable names - Var n:ps -> pure (Var n:Var n:ps) - Pair p1 p2:ps -> pure (p1:p2:ps) - p -> fail ("unexpected pattern: " <> show p)) - [] -> pure tableau -- FIXME: fail if clauses aren't all empty + Var n:ps -> Right (Var n:Var n:ps) + Pair p1 p2:ps -> Right (p1:p2:ps) + p -> Left ("unexpected pattern: " <> show p)) + [] -> Right [tableau] -- FIXME: fail if clauses aren't all empty -match :: Tableau () -> ([Pattern Name] -> Covers m [Pattern Name]) -> Covers m (Tableau ()) +match :: Tableau () -> ([Pattern Name] -> Either String [Pattern Name]) -> Either String (Tableau ()) match tableau f = flip (set (heads_ @())) tableau <$> traverseOf (traversed.patterns_) f (heads tableau) From b065ab84553ba91c7428f2ac08960a361497e73a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 14 Mar 2022 20:38:42 -0400 Subject: [PATCH 0800/1324] Simplify how the tableau is updated. --- src/Facet/Elab/Pattern.hs | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 6287b0ceb..33daccda3 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -6,6 +6,7 @@ module Facet.Elab.Pattern , patterns_ , Type(..) , Tableau(..) +, context_ , heads_ , Branch(..) , (\/) @@ -15,13 +16,11 @@ module Facet.Elab.Pattern ) where import Control.Monad (ap, join) -import Data.Function import Data.Monoid import Facet.Name import Fresnel.Fold import Fresnel.Lens import Fresnel.Prism (Prism', prism') -import Fresnel.Setter import Fresnel.Traversal (traverseOf, traversed) data Pattern a @@ -122,12 +121,12 @@ covers tableau = case context tableau of _ -> coverStep tableau >>= fmap join . traverse covers coverStep :: Tableau () -> Either String [Tableau ()] -coverStep tableau = case context tableau of - Opaque:ctx -> pure <$> match (tableau & context_ .~ ctx) (\case +coverStep tableau@(Tableau context heads) = case context of + Opaque:ctx -> pure . Tableau ctx <$> match heads (\case Wildcard:ps -> Right ps Var _:ps -> Right ps p -> Left ("unexpected pattern: " <> show p)) - One:ctx -> pure <$> match (tableau & context_ .~ ctx) (\case + One:ctx -> pure . Tableau ctx <$> match heads (\case Wildcard:ps -> Right ps Var _:ps -> Right ps Unit:ps -> Right ps @@ -138,9 +137,9 @@ coverStep tableau = case context tableau of InL p:ps -> Right ([Clause (p:ps) ()], [Clause [] ()]) InR q:qs -> Right ([Clause [] ()], [Clause (q:qs) ()]) p:_ -> Left ("unexpected pattern: " <> show p) - _ -> Left "no patterns to match sum") (heads tableau)) + _ -> Left "no patterns to match sum") heads) >>= \ (cs1, cs2) -> Right [Tableau (t1:ctx) cs1, Tableau (t2:ctx) cs2] - t1 :* t2:ctx -> pure <$> match (tableau & context_ .~ t1:t2:ctx) (\case + t1 :* t2:ctx -> pure . Tableau (t1:t2:ctx) <$> match heads (\case Wildcard:ps -> Right (Wildcard:Wildcard:ps) -- FIXME: substitute variables out for wildcards so we don't have to bind fresh variable names Var n:ps -> Right (Var n:Var n:ps) @@ -148,5 +147,5 @@ coverStep tableau = case context tableau of p -> Left ("unexpected pattern: " <> show p)) [] -> Right [tableau] -- FIXME: fail if clauses aren't all empty -match :: Tableau () -> ([Pattern Name] -> Either String [Pattern Name]) -> Either String (Tableau ()) -match tableau f = flip (set (heads_ @())) tableau <$> traverseOf (traversed.patterns_) f (heads tableau) +match :: [Clause ()] -> ([Pattern Name] -> Either String [Pattern Name]) -> Either String [Clause ()] +match heads f = traverseOf (traversed.patterns_) f heads From 0a3bc9c1b9e7e70613109979aa86011eb0ea3d9f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 14 Mar 2022 20:39:06 -0400 Subject: [PATCH 0801/1324] Generalize match. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 33daccda3..ae72a123e 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -147,5 +147,5 @@ coverStep tableau@(Tableau context heads) = case context of p -> Left ("unexpected pattern: " <> show p)) [] -> Right [tableau] -- FIXME: fail if clauses aren't all empty -match :: [Clause ()] -> ([Pattern Name] -> Either String [Pattern Name]) -> Either String [Clause ()] +match :: [Clause a] -> ([Pattern Name] -> Either String [Pattern Name]) -> Either String [Clause a] match heads f = traverseOf (traversed.patterns_) f heads From 69b32445eb0374ec69829c44c92319a16ae00388 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 14 Mar 2022 20:39:27 -0400 Subject: [PATCH 0802/1324] Reorder. --- src/Facet/Elab/Pattern.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index ae72a123e..d08fca6ba 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -98,12 +98,12 @@ data Tableau a = Tableau , heads :: [Clause a] } -heads_ :: Lens (Tableau a) (Tableau b) [Clause a] [Clause b] -heads_ = lens heads (\ t heads -> t{heads}) - context_ :: Lens' (Tableau a) [Type] context_ = lens context (\ t context -> t{context}) +heads_ :: Lens (Tableau a) (Tableau b) [Clause a] [Clause b] +heads_ = lens heads (\ t heads -> t{heads}) + data Branch s m a = forall x . Branch (Fold s x) (x -> m a) From 3e225338e22746d74cdd2feab40509b9b27925c2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 14 Mar 2022 20:41:02 -0400 Subject: [PATCH 0803/1324] Simplify match. --- src/Facet/Elab/Pattern.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index d08fca6ba..10b0f70dc 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -21,7 +21,7 @@ import Facet.Name import Fresnel.Fold import Fresnel.Lens import Fresnel.Prism (Prism', prism') -import Fresnel.Traversal (traverseOf, traversed) +import Fresnel.Traversal (forOf, traversed) data Pattern a = Wildcard @@ -148,4 +148,4 @@ coverStep tableau@(Tableau context heads) = case context of [] -> Right [tableau] -- FIXME: fail if clauses aren't all empty match :: [Clause a] -> ([Pattern Name] -> Either String [Pattern Name]) -> Either String [Clause a] -match heads f = traverseOf (traversed.patterns_) f heads +match = forOf (traversed.patterns_) From 94edfecd1876c1d36da41b5592984cc931c16170 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 14 Mar 2022 20:41:37 -0400 Subject: [PATCH 0804/1324] :fire: match. --- src/Facet/Elab/Pattern.hs | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 10b0f70dc..cfa3d01ee 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -122,11 +122,11 @@ covers tableau = case context tableau of coverStep :: Tableau () -> Either String [Tableau ()] coverStep tableau@(Tableau context heads) = case context of - Opaque:ctx -> pure . Tableau ctx <$> match heads (\case + Opaque:ctx -> pure . Tableau ctx <$> forOf (traversed.patterns_) heads (\case Wildcard:ps -> Right ps Var _:ps -> Right ps p -> Left ("unexpected pattern: " <> show p)) - One:ctx -> pure . Tableau ctx <$> match heads (\case + One:ctx -> pure . Tableau ctx <$> forOf (traversed.patterns_) heads (\case Wildcard:ps -> Right ps Var _:ps -> Right ps Unit:ps -> Right ps @@ -139,13 +139,10 @@ coverStep tableau@(Tableau context heads) = case context of p:_ -> Left ("unexpected pattern: " <> show p) _ -> Left "no patterns to match sum") heads) >>= \ (cs1, cs2) -> Right [Tableau (t1:ctx) cs1, Tableau (t2:ctx) cs2] - t1 :* t2:ctx -> pure . Tableau (t1:t2:ctx) <$> match heads (\case + t1 :* t2:ctx -> pure . Tableau (t1:t2:ctx) <$> forOf (traversed.patterns_) heads (\case Wildcard:ps -> Right (Wildcard:Wildcard:ps) -- FIXME: substitute variables out for wildcards so we don't have to bind fresh variable names Var n:ps -> Right (Var n:Var n:ps) Pair p1 p2:ps -> Right (p1:p2:ps) p -> Left ("unexpected pattern: " <> show p)) [] -> Right [tableau] -- FIXME: fail if clauses aren't all empty - -match :: [Clause a] -> ([Pattern Name] -> Either String [Pattern Name]) -> Either String [Clause a] -match = forOf (traversed.patterns_) From e49e45e2368964d88a88d907baae43dea667be55 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 09:32:36 -0400 Subject: [PATCH 0805/1324] Instantiate wildcards for One. --- src/Facet/Elab/Pattern.hs | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index cfa3d01ee..2e4c9da6d 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -16,11 +16,14 @@ module Facet.Elab.Pattern ) where import Control.Monad (ap, join) +import Data.Function import Data.Monoid import Facet.Name import Fresnel.Fold import Fresnel.Lens +import Fresnel.List (head_) import Fresnel.Prism (Prism', prism') +import Fresnel.Setter import Fresnel.Traversal (forOf, traversed) data Pattern a @@ -126,11 +129,9 @@ coverStep tableau@(Tableau context heads) = case context of Wildcard:ps -> Right ps Var _:ps -> Right ps p -> Left ("unexpected pattern: " <> show p)) - One:ctx -> pure . Tableau ctx <$> forOf (traversed.patterns_) heads (\case - Wildcard:ps -> Right ps - Var _:ps -> Right ps - Unit:ps -> Right ps - p -> Left ("unexpected pattern: " <> show p)) + One:ctx -> pure . Tableau ctx <$> forOf (traversed.patterns_) [ x & patterns_.head_ %~ instantiateHead Unit | x <- heads ] (\case + Unit:ps -> Right ps + p -> Left ("unexpected pattern: " <> show p)) t1 :+ t2:ctx -> getAp (foldMapOf (folded.patterns_) (Ap . \case Wildcard:ps -> Right ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) Var n:ps -> Right ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) @@ -146,3 +147,8 @@ coverStep tableau@(Tableau context heads) = case context of Pair p1 p2:ps -> Right (p1:p2:ps) p -> Left ("unexpected pattern: " <> show p)) [] -> Right [tableau] -- FIXME: fail if clauses aren't all empty + +instantiateHead :: Pattern Name -> Pattern Name -> Pattern Name +instantiateHead d Wildcard = d +instantiateHead d (Var _) = d -- FIXME: let-bind any variables first +instantiateHead _ p = p From 6cc213664bc76cc5e725633d0acb73cad4bbbd01 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 09:38:53 -0400 Subject: [PATCH 0806/1324] Factor error formatting out. --- src/Facet/Elab/Pattern.hs | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 2e4c9da6d..e61cfcdb5 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -121,31 +121,34 @@ infixr 2 \/ covers :: Tableau () -> Either String [Tableau ()] covers tableau = case context tableau of [] -> Right [tableau] - _ -> coverStep tableau >>= fmap join . traverse covers + _ -> either (Left . uncurry formatError) Right (coverStep tableau) >>= fmap join . traverse covers + where + formatError t = \case + [] -> "expected " <> show t <> ", got nothing" + p:_ -> "expected " <> show t <> ", got " <> show p -coverStep :: Tableau () -> Either String [Tableau ()] +coverStep :: Tableau () -> Either (Type, [Pattern Name]) [Tableau ()] coverStep tableau@(Tableau context heads) = case context of Opaque:ctx -> pure . Tableau ctx <$> forOf (traversed.patterns_) heads (\case Wildcard:ps -> Right ps Var _:ps -> Right ps - p -> Left ("unexpected pattern: " <> show p)) + ps -> Left (Opaque, ps)) One:ctx -> pure . Tableau ctx <$> forOf (traversed.patterns_) [ x & patterns_.head_ %~ instantiateHead Unit | x <- heads ] (\case Unit:ps -> Right ps - p -> Left ("unexpected pattern: " <> show p)) + ps -> Left (One, ps)) t1 :+ t2:ctx -> getAp (foldMapOf (folded.patterns_) (Ap . \case Wildcard:ps -> Right ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) Var n:ps -> Right ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) InL p:ps -> Right ([Clause (p:ps) ()], [Clause [] ()]) InR q:qs -> Right ([Clause [] ()], [Clause (q:qs) ()]) - p:_ -> Left ("unexpected pattern: " <> show p) - _ -> Left "no patterns to match sum") heads) + ps -> Left (t1 :+ t2, ps)) heads) >>= \ (cs1, cs2) -> Right [Tableau (t1:ctx) cs1, Tableau (t2:ctx) cs2] t1 :* t2:ctx -> pure . Tableau (t1:t2:ctx) <$> forOf (traversed.patterns_) heads (\case Wildcard:ps -> Right (Wildcard:Wildcard:ps) -- FIXME: substitute variables out for wildcards so we don't have to bind fresh variable names Var n:ps -> Right (Var n:Var n:ps) Pair p1 p2:ps -> Right (p1:p2:ps) - p -> Left ("unexpected pattern: " <> show p)) + ps -> Left (t1 :* t2, ps)) [] -> Right [tableau] -- FIXME: fail if clauses aren't all empty instantiateHead :: Pattern Name -> Pattern Name -> Pattern Name From 856654e0f5b16deee222e87e68307fa6484c2ffd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 09:46:15 -0400 Subject: [PATCH 0807/1324] Tidy up the One case slightly. --- src/Facet/Elab/Pattern.hs | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index e61cfcdb5..c90496868 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -16,12 +16,10 @@ module Facet.Elab.Pattern ) where import Control.Monad (ap, join) -import Data.Function import Data.Monoid import Facet.Name import Fresnel.Fold import Fresnel.Lens -import Fresnel.List (head_) import Fresnel.Prism (Prism', prism') import Fresnel.Setter import Fresnel.Traversal (forOf, traversed) @@ -133,9 +131,9 @@ coverStep tableau@(Tableau context heads) = case context of Wildcard:ps -> Right ps Var _:ps -> Right ps ps -> Left (Opaque, ps)) - One:ctx -> pure . Tableau ctx <$> forOf (traversed.patterns_) [ x & patterns_.head_ %~ instantiateHead Unit | x <- heads ] (\case + One:ctx -> pure . set context_ ctx <$> forOf (heads_.traversed.patterns_) tableau ((\case Unit:ps -> Right ps - ps -> Left (One, ps)) + ps -> Left (One, ps)) . instantiateHead Unit) t1 :+ t2:ctx -> getAp (foldMapOf (folded.patterns_) (Ap . \case Wildcard:ps -> Right ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) Var n:ps -> Right ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) @@ -151,7 +149,7 @@ coverStep tableau@(Tableau context heads) = case context of ps -> Left (t1 :* t2, ps)) [] -> Right [tableau] -- FIXME: fail if clauses aren't all empty -instantiateHead :: Pattern Name -> Pattern Name -> Pattern Name -instantiateHead d Wildcard = d -instantiateHead d (Var _) = d -- FIXME: let-bind any variables first -instantiateHead _ p = p +instantiateHead :: Pattern Name -> [Pattern Name] -> [Pattern Name] +instantiateHead d (Wildcard:ps) = d:ps +instantiateHead d (Var _:ps) = d:ps -- FIXME: let-bind any variables first +instantiateHead _ p = p From d78c4350263cf9201632ce5ae76710476df25ed7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 09:50:18 -0400 Subject: [PATCH 0808/1324] Factor out a pattern match. --- src/Facet/Elab/Pattern.hs | 41 ++++++++++++++++++++------------------- 1 file changed, 21 insertions(+), 20 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index c90496868..fe92de52f 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -127,26 +127,27 @@ covers tableau = case context tableau of coverStep :: Tableau () -> Either (Type, [Pattern Name]) [Tableau ()] coverStep tableau@(Tableau context heads) = case context of - Opaque:ctx -> pure . Tableau ctx <$> forOf (traversed.patterns_) heads (\case - Wildcard:ps -> Right ps - Var _:ps -> Right ps - ps -> Left (Opaque, ps)) - One:ctx -> pure . set context_ ctx <$> forOf (heads_.traversed.patterns_) tableau ((\case - Unit:ps -> Right ps - ps -> Left (One, ps)) . instantiateHead Unit) - t1 :+ t2:ctx -> getAp (foldMapOf (folded.patterns_) (Ap . \case - Wildcard:ps -> Right ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) - Var n:ps -> Right ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) - InL p:ps -> Right ([Clause (p:ps) ()], [Clause [] ()]) - InR q:qs -> Right ([Clause [] ()], [Clause (q:qs) ()]) - ps -> Left (t1 :+ t2, ps)) heads) - >>= \ (cs1, cs2) -> Right [Tableau (t1:ctx) cs1, Tableau (t2:ctx) cs2] - t1 :* t2:ctx -> pure . Tableau (t1:t2:ctx) <$> forOf (traversed.patterns_) heads (\case - Wildcard:ps -> Right (Wildcard:Wildcard:ps) - -- FIXME: substitute variables out for wildcards so we don't have to bind fresh variable names - Var n:ps -> Right (Var n:Var n:ps) - Pair p1 p2:ps -> Right (p1:p2:ps) - ps -> Left (t1 :* t2, ps)) + t:ctx -> case t of + Opaque -> pure . Tableau ctx <$> forOf (traversed.patterns_) heads (\case + Wildcard:ps -> Right ps + Var _:ps -> Right ps + ps -> Left (Opaque, ps)) + One -> pure . set context_ ctx <$> forOf (heads_.traversed.patterns_) tableau ((\case + Unit:ps -> Right ps + ps -> Left (One, ps)) . instantiateHead Unit) + t1 :+ t2 -> getAp (foldMapOf (folded.patterns_) (Ap . \case + Wildcard:ps -> Right ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) + Var n:ps -> Right ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) + InL p:ps -> Right ([Clause (p:ps) ()], [Clause [] ()]) + InR q:qs -> Right ([Clause [] ()], [Clause (q:qs) ()]) + ps -> Left (t1 :+ t2, ps)) heads) + >>= \ (cs1, cs2) -> Right [Tableau (t1:ctx) cs1, Tableau (t2:ctx) cs2] + t1 :* t2 -> pure . Tableau (t1:t2:ctx) <$> forOf (traversed.patterns_) heads (\case + Wildcard:ps -> Right (Wildcard:Wildcard:ps) + -- FIXME: substitute variables out for wildcards so we don't have to bind fresh variable names + Var n:ps -> Right (Var n:Var n:ps) + Pair p1 p2:ps -> Right (p1:p2:ps) + ps -> Left (t1 :* t2, ps)) [] -> Right [tableau] -- FIXME: fail if clauses aren't all empty instantiateHead :: Pattern Name -> [Pattern Name] -> [Pattern Name] From e8d47e54708612b19276c5b1ed0b9f46704ae490 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 09:50:49 -0400 Subject: [PATCH 0809/1324] Return the type symbolically. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index fe92de52f..3bf4a724a 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -134,7 +134,7 @@ coverStep tableau@(Tableau context heads) = case context of ps -> Left (Opaque, ps)) One -> pure . set context_ ctx <$> forOf (heads_.traversed.patterns_) tableau ((\case Unit:ps -> Right ps - ps -> Left (One, ps)) . instantiateHead Unit) + ps -> Left (t, ps)) . instantiateHead Unit) t1 :+ t2 -> getAp (foldMapOf (folded.patterns_) (Ap . \case Wildcard:ps -> Right ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) Var n:ps -> Right ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) From 94bd153b62267835b69aca751d7bac0f97756b17 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 10:14:06 -0400 Subject: [PATCH 0810/1324] Generalize slightly. --- src/Facet/Elab/Pattern.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 3bf4a724a..70e6713d7 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -20,7 +20,7 @@ import Data.Monoid import Facet.Name import Fresnel.Fold import Fresnel.Lens -import Fresnel.Prism (Prism', prism') +import Fresnel.Prism (Prism', matching', prism') import Fresnel.Setter import Fresnel.Traversal (forOf, traversed) @@ -133,8 +133,8 @@ coverStep tableau@(Tableau context heads) = case context of Var _:ps -> Right ps ps -> Left (Opaque, ps)) One -> pure . set context_ ctx <$> forOf (heads_.traversed.patterns_) tableau ((\case - Unit:ps -> Right ps - ps -> Left (t, ps)) . instantiateHead Unit) + p:ps -> maybe (Left (t, ps)) (const (Right ps)) (matching' _Unit p) + [] -> Left (t, [])) . instantiateHead Unit) t1 :+ t2 -> getAp (foldMapOf (folded.patterns_) (Ap . \case Wildcard:ps -> Right ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) Var n:ps -> Right ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) From 109b8e78c26b0e7adf376db447544308eef6b5a7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 10:15:39 -0400 Subject: [PATCH 0811/1324] Correct the error case. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 70e6713d7..47d9f0a89 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -133,7 +133,7 @@ coverStep tableau@(Tableau context heads) = case context of Var _:ps -> Right ps ps -> Left (Opaque, ps)) One -> pure . set context_ ctx <$> forOf (heads_.traversed.patterns_) tableau ((\case - p:ps -> maybe (Left (t, ps)) (const (Right ps)) (matching' _Unit p) + p:ps -> maybe (Left (t, p:ps)) (const (Right ps)) (matching' _Unit p) [] -> Left (t, [])) . instantiateHead Unit) t1 :+ t2 -> getAp (foldMapOf (folded.patterns_) (Ap . \case Wildcard:ps -> Right ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) From ea04d1f7d4a35b245595c06f51d450d389471361 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 10:20:28 -0400 Subject: [PATCH 0812/1324] Abbreviate further. --- src/Facet/Elab/Pattern.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 47d9f0a89..a0dc264b1 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -16,11 +16,13 @@ module Facet.Elab.Pattern ) where import Control.Monad (ap, join) +import Data.Bifunctor import Data.Monoid import Facet.Name import Fresnel.Fold import Fresnel.Lens -import Fresnel.Prism (Prism', matching', prism') +import Fresnel.List (head_) +import Fresnel.Prism (Prism', matching, prism') import Fresnel.Setter import Fresnel.Traversal (forOf, traversed) @@ -132,9 +134,7 @@ coverStep tableau@(Tableau context heads) = case context of Wildcard:ps -> Right ps Var _:ps -> Right ps ps -> Left (Opaque, ps)) - One -> pure . set context_ ctx <$> forOf (heads_.traversed.patterns_) tableau ((\case - p:ps -> maybe (Left (t, p:ps)) (const (Right ps)) (matching' _Unit p) - [] -> Left (t, [])) . instantiateHead Unit) + One -> pure . set context_ ctx <$> forOf (heads_.traversed.patterns_) tableau ((\ ps -> bimap (t,) (const ps) (matching (head_._Unit) ps)) . instantiateHead Unit) t1 :+ t2 -> getAp (foldMapOf (folded.patterns_) (Ap . \case Wildcard:ps -> Right ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) Var n:ps -> Right ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) From 30d018a234f0fa6704788bd93d8e190215e7e0a9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 10:24:55 -0400 Subject: [PATCH 0813/1324] Reinstate a coverage judgement type. --- src/Facet/Elab/Pattern.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index a0dc264b1..2cf63c782 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -11,6 +11,7 @@ module Facet.Elab.Pattern , Branch(..) , (\/) -- * Coverage judgement +, Covers(..) , covers , coverStep ) where @@ -118,6 +119,10 @@ infixr 2 \/ -- Coverage judgement +newtype Covers e a = Covers { runCovers :: Either e [a] } + deriving (Functor) + + covers :: Tableau () -> Either String [Tableau ()] covers tableau = case context tableau of [] -> Right [tableau] From 0bb450f8fd656e0cd1254910c9c58fb2b6d5bd1a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 10:25:16 -0400 Subject: [PATCH 0814/1324] Covers is Applicative. --- src/Facet/Elab/Pattern.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 2cf63c782..90b3d253f 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -16,6 +16,7 @@ module Facet.Elab.Pattern , coverStep ) where +import Control.Applicative (liftA2) import Control.Monad (ap, join) import Data.Bifunctor import Data.Monoid @@ -122,6 +123,11 @@ infixr 2 \/ newtype Covers e a = Covers { runCovers :: Either e [a] } deriving (Functor) +instance Applicative (Covers e) where + pure = Covers . pure . pure + + Covers f <*> Covers a = Covers (liftA2 (<*>) f a) + covers :: Tableau () -> Either String [Tableau ()] covers tableau = case context tableau of From def618e3a9110d30586db5ee492edd53ee58e975 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 10:28:05 -0400 Subject: [PATCH 0815/1324] Define a sketchy Monad instance. --- src/Facet/Elab/Pattern.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 90b3d253f..21181777c 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -128,6 +128,9 @@ instance Applicative (Covers e) where Covers f <*> Covers a = Covers (liftA2 (<*>) f a) +instance Monad (Covers e) where + Covers m >>= k = Covers (m >>= sequenceA . (>>= sequenceA . runCovers . k)) + covers :: Tableau () -> Either String [Tableau ()] covers tableau = case context tableau of From b57777887cb8e6f8fcbd97c4ae11a00869103024 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 10:29:25 -0400 Subject: [PATCH 0816/1324] Simplify mapping over Either. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 21181777c..b839873c1 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -135,7 +135,7 @@ instance Monad (Covers e) where covers :: Tableau () -> Either String [Tableau ()] covers tableau = case context tableau of [] -> Right [tableau] - _ -> either (Left . uncurry formatError) Right (coverStep tableau) >>= fmap join . traverse covers + _ -> first (uncurry formatError) (coverStep tableau) >>= fmap join . traverse covers where formatError t = \case [] -> "expected " <> show t <> ", got nothing" From b25f3db3874b32ef64bf70d7752fc4c7d8a6e635 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 10:30:25 -0400 Subject: [PATCH 0817/1324] Define a Bifunctor instance for Covers. --- src/Facet/Elab/Pattern.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index b839873c1..a948e9564 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -123,6 +123,9 @@ infixr 2 \/ newtype Covers e a = Covers { runCovers :: Either e [a] } deriving (Functor) +instance Bifunctor Covers where + bimap f g (Covers e) = Covers (bimap f (fmap g) e) + instance Applicative (Covers e) where pure = Covers . pure . pure From 57e3b1168c37de9127512be528e5aba6fc0e80f9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 10:35:07 -0400 Subject: [PATCH 0818/1324] Make the Monad instance slightly less sketchy. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index a948e9564..79433c487 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -132,7 +132,7 @@ instance Applicative (Covers e) where Covers f <*> Covers a = Covers (liftA2 (<*>) f a) instance Monad (Covers e) where - Covers m >>= k = Covers (m >>= sequenceA . (>>= sequenceA . runCovers . k)) + Covers m >>= k = Covers (m >>= fmap join . traverse (runCovers . k)) covers :: Tableau () -> Either String [Tableau ()] From d0a23b5bd70a7c78c27b80288437ba0f44394eca Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 10:35:39 -0400 Subject: [PATCH 0819/1324] Define an Alternative instance for Covers. --- src/Facet/Elab/Pattern.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 79433c487..e2feede30 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -16,7 +16,7 @@ module Facet.Elab.Pattern , coverStep ) where -import Control.Applicative (liftA2) +import Control.Applicative (Alternative(..), liftA2) import Control.Monad (ap, join) import Data.Bifunctor import Data.Monoid @@ -131,6 +131,11 @@ instance Applicative (Covers e) where Covers f <*> Covers a = Covers (liftA2 (<*>) f a) +instance Alternative (Covers e) where + empty = Covers (Right []) + + Covers a <|> Covers b = Covers (liftA2 (<|>) a b) + instance Monad (Covers e) where Covers m >>= k = Covers (m >>= fmap join . traverse (runCovers . k)) From 5736058058ea25c18af54a33d70ebc77d399fe4e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 10:40:34 -0400 Subject: [PATCH 0820/1324] Check coverage in Covers. --- src/Facet/Elab/Pattern.hs | 47 ++++++++++++++++++++++----------------- 1 file changed, 26 insertions(+), 21 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index e2feede30..5e865c428 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -139,38 +139,43 @@ instance Alternative (Covers e) where instance Monad (Covers e) where Covers m >>= k = Covers (m >>= fmap join . traverse (runCovers . k)) +throw :: e -> Covers e a +throw = Covers . Left -covers :: Tableau () -> Either String [Tableau ()] +except :: Either e a -> Covers e a +except = either throw pure + +covers :: Tableau () -> Covers String (Tableau ()) covers tableau = case context tableau of - [] -> Right [tableau] - _ -> first (uncurry formatError) (coverStep tableau) >>= fmap join . traverse covers + [] -> pure tableau + _ -> first (uncurry formatError) (coverStep tableau) >>= covers where formatError t = \case [] -> "expected " <> show t <> ", got nothing" p:_ -> "expected " <> show t <> ", got " <> show p -coverStep :: Tableau () -> Either (Type, [Pattern Name]) [Tableau ()] +coverStep :: Tableau () -> Covers (Type, [Pattern Name]) (Tableau ()) coverStep tableau@(Tableau context heads) = case context of t:ctx -> case t of - Opaque -> pure . Tableau ctx <$> forOf (traversed.patterns_) heads (\case - Wildcard:ps -> Right ps - Var _:ps -> Right ps - ps -> Left (Opaque, ps)) - One -> pure . set context_ ctx <$> forOf (heads_.traversed.patterns_) tableau ((\ ps -> bimap (t,) (const ps) (matching (head_._Unit) ps)) . instantiateHead Unit) + Opaque -> Tableau ctx <$> forOf (traversed.patterns_) heads (\case + Wildcard:ps -> pure ps + Var _:ps -> pure ps + ps -> throw (Opaque, ps)) + One -> set context_ ctx <$> forOf (heads_.traversed.patterns_) tableau ((\ ps -> bimap (t,) (const ps) (except (matching (head_._Unit) ps))) . instantiateHead Unit) t1 :+ t2 -> getAp (foldMapOf (folded.patterns_) (Ap . \case - Wildcard:ps -> Right ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) - Var n:ps -> Right ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) - InL p:ps -> Right ([Clause (p:ps) ()], [Clause [] ()]) - InR q:qs -> Right ([Clause [] ()], [Clause (q:qs) ()]) - ps -> Left (t1 :+ t2, ps)) heads) - >>= \ (cs1, cs2) -> Right [Tableau (t1:ctx) cs1, Tableau (t2:ctx) cs2] - t1 :* t2 -> pure . Tableau (t1:t2:ctx) <$> forOf (traversed.patterns_) heads (\case - Wildcard:ps -> Right (Wildcard:Wildcard:ps) + Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) + Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) + InL p:ps -> pure ([Clause (p:ps) ()], [Clause [] ()]) + InR q:qs -> pure ([Clause [] ()], [Clause (q:qs) ()]) + ps -> throw (t1 :+ t2, ps)) heads) + >>= \ (cs1, cs2) -> pure (Tableau (t1:ctx) cs1) <|> pure (Tableau (t2:ctx) cs2) + t1 :* t2 -> Tableau (t1:t2:ctx) <$> forOf (traversed.patterns_) heads (\case + Wildcard:ps -> pure (Wildcard:Wildcard:ps) -- FIXME: substitute variables out for wildcards so we don't have to bind fresh variable names - Var n:ps -> Right (Var n:Var n:ps) - Pair p1 p2:ps -> Right (p1:p2:ps) - ps -> Left (t1 :* t2, ps)) - [] -> Right [tableau] -- FIXME: fail if clauses aren't all empty + Var n:ps -> pure (Var n:Var n:ps) + Pair p1 p2:ps -> pure (p1:p2:ps) + ps -> throw (t1 :* t2, ps)) + [] -> pure tableau -- FIXME: fail if clauses aren't all empty instantiateHead :: Pattern Name -> [Pattern Name] -> [Pattern Name] instantiateHead d (Wildcard:ps) = d:ps From 5e7879670123db96d8c9615afcad31e8e0c7c6c1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 10:46:56 -0400 Subject: [PATCH 0821/1324] Redefine Covers using hand-rolled nondeterminism. --- src/Facet/Elab/Pattern.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 5e865c428..46884e64b 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -16,8 +16,8 @@ module Facet.Elab.Pattern , coverStep ) where -import Control.Applicative (Alternative(..), liftA2) -import Control.Monad (ap, join) +import Control.Applicative (Alternative(..)) +import Control.Monad (ap) import Data.Bifunctor import Data.Monoid import Facet.Name @@ -120,27 +120,27 @@ infixr 2 \/ -- Coverage judgement -newtype Covers e a = Covers { runCovers :: Either e [a] } +newtype Covers e a = Covers { runCovers :: forall r . (r -> r -> r) -> (a -> r) -> r -> (e -> r) -> r } deriving (Functor) instance Bifunctor Covers where - bimap f g (Covers e) = Covers (bimap f (fmap g) e) + bimap f g (Covers e) = Covers (\ fork leaf nil err -> e fork (leaf . g) nil (err . f)) instance Applicative (Covers e) where - pure = Covers . pure . pure + pure a = Covers (\ _ leaf _ _ -> leaf a) - Covers f <*> Covers a = Covers (liftA2 (<*>) f a) + (<*>) = ap instance Alternative (Covers e) where - empty = Covers (Right []) + empty = Covers (\ _ _ nil _ -> nil) - Covers a <|> Covers b = Covers (liftA2 (<|>) a b) + Covers a <|> Covers b = Covers (\ (<|>) leaf nil err -> a (<|>) leaf nil err <|> b (<|>) leaf nil err) instance Monad (Covers e) where - Covers m >>= k = Covers (m >>= fmap join . traverse (runCovers . k)) + Covers m >>= k = Covers (\ fork leaf nil err -> m fork (\ a -> runCovers (k a) fork leaf nil err) nil err) throw :: e -> Covers e a -throw = Covers . Left +throw e = Covers (\ _ _ _ err -> err e) except :: Either e a -> Covers e a except = either throw pure From 6e7ad6f5dc61040b84fc5f2dec0b7601c0972d4b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 12:02:56 -0400 Subject: [PATCH 0822/1324] Clarify the One case. --- src/Facet/Elab/Pattern.hs | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 46884e64b..1ec323b41 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -23,9 +23,7 @@ import Data.Monoid import Facet.Name import Fresnel.Fold import Fresnel.Lens -import Fresnel.List (head_) import Fresnel.Prism (Prism', matching, prism') -import Fresnel.Setter import Fresnel.Traversal (forOf, traversed) data Pattern a @@ -142,9 +140,6 @@ instance Monad (Covers e) where throw :: e -> Covers e a throw e = Covers (\ _ _ _ err -> err e) -except :: Either e a -> Covers e a -except = either throw pure - covers :: Tableau () -> Covers String (Tableau ()) covers tableau = case context tableau of [] -> pure tableau @@ -161,7 +156,9 @@ coverStep tableau@(Tableau context heads) = case context of Wildcard:ps -> pure ps Var _:ps -> pure ps ps -> throw (Opaque, ps)) - One -> set context_ ctx <$> forOf (heads_.traversed.patterns_) tableau ((\ ps -> bimap (t,) (const ps) (except (matching (head_._Unit) ps))) . instantiateHead Unit) + One -> Tableau ctx <$> forOf (traversed.patterns_) heads (\case + p:ps | Right _ <- matching _Unit (instantiateHead Unit p) -> pure ps + ps -> throw (t, ps)) t1 :+ t2 -> getAp (foldMapOf (folded.patterns_) (Ap . \case Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) @@ -177,7 +174,7 @@ coverStep tableau@(Tableau context heads) = case context of ps -> throw (t1 :* t2, ps)) [] -> pure tableau -- FIXME: fail if clauses aren't all empty -instantiateHead :: Pattern Name -> [Pattern Name] -> [Pattern Name] -instantiateHead d (Wildcard:ps) = d:ps -instantiateHead d (Var _:ps) = d:ps -- FIXME: let-bind any variables first -instantiateHead _ p = p +instantiateHead :: Pattern Name -> Pattern Name -> Pattern Name +instantiateHead d Wildcard = d +instantiateHead d (Var _) = d -- FIXME: let-bind any variables first +instantiateHead _ p = p From 8620ade73d26caba0aab9e6ce0aae6edcc6efdc0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 12:05:46 -0400 Subject: [PATCH 0823/1324] Compute canonical patterns. --- src/Facet/Elab/Pattern.hs | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 1ec323b41..8afd2ae18 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -16,7 +16,7 @@ module Facet.Elab.Pattern , coverStep ) where -import Control.Applicative (Alternative(..)) +import Control.Applicative (Alternative(..), asum) import Control.Monad (ap) import Data.Bifunctor import Data.Monoid @@ -156,9 +156,11 @@ coverStep tableau@(Tableau context heads) = case context of Wildcard:ps -> pure ps Var _:ps -> pure ps ps -> throw (Opaque, ps)) - One -> Tableau ctx <$> forOf (traversed.patterns_) heads (\case - p:ps | Right _ <- matching _Unit (instantiateHead Unit p) -> pure ps - ps -> throw (t, ps)) + One -> do + canonical <- asum (map pure (wild t)) + Tableau ctx <$> forOf (traversed.patterns_) heads (\case + p:ps | Right _ <- matching _Unit (instantiateHead canonical p) -> pure ps + ps -> throw (t, ps)) t1 :+ t2 -> getAp (foldMapOf (folded.patterns_) (Ap . \case Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) @@ -178,3 +180,11 @@ instantiateHead :: Pattern Name -> Pattern Name -> Pattern Name instantiateHead d Wildcard = d instantiateHead d (Var _) = d -- FIXME: let-bind any variables first instantiateHead _ p = p + + +wild :: Type -> [Pattern Name] +wild = \case + Opaque -> [Wildcard] + One -> [Unit] + _ :+ _ -> [InL Wildcard, InR Wildcard] + _ :* _ -> [Pair Wildcard Wildcard] From fbeb1dc1885c40047e90a467c67f84340a40c663 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 12:26:51 -0400 Subject: [PATCH 0824/1324] Abbreviate throwing. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 8afd2ae18..68da969a7 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -166,7 +166,7 @@ coverStep tableau@(Tableau context heads) = case context of Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) InL p:ps -> pure ([Clause (p:ps) ()], [Clause [] ()]) InR q:qs -> pure ([Clause [] ()], [Clause (q:qs) ()]) - ps -> throw (t1 :+ t2, ps)) heads) + ps -> throw (t, ps)) heads) >>= \ (cs1, cs2) -> pure (Tableau (t1:ctx) cs1) <|> pure (Tableau (t2:ctx) cs2) t1 :* t2 -> Tableau (t1:t2:ctx) <$> forOf (traversed.patterns_) heads (\case Wildcard:ps -> pure (Wildcard:Wildcard:ps) From dd518699c3740b63ca3584cf8469e86be0473ee8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 12:28:40 -0400 Subject: [PATCH 0825/1324] Define Semigroup & Monoid instances for Covers. --- src/Facet/Elab/Pattern.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 68da969a7..effc7e3de 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -16,7 +16,7 @@ module Facet.Elab.Pattern , coverStep ) where -import Control.Applicative (Alternative(..), asum) +import Control.Applicative (Alternative(..), asum, liftA2) import Control.Monad (ap) import Data.Bifunctor import Data.Monoid @@ -137,6 +137,12 @@ instance Alternative (Covers e) where instance Monad (Covers e) where Covers m >>= k = Covers (\ fork leaf nil err -> m fork (\ a -> runCovers (k a) fork leaf nil err) nil err) +instance Semigroup a => Semigroup (Covers e a) where + (<>) = liftA2 (<>) + +instance Monoid a => Monoid (Covers e a) where + mempty = pure mempty + throw :: e -> Covers e a throw e = Covers (\ _ _ _ err -> err e) From ddd3332299d830643e47a8dc035af4008ce860b3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 12:28:53 -0400 Subject: [PATCH 0826/1324] Simplify sum decomposition. --- src/Facet/Elab/Pattern.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index effc7e3de..bf3d74bb3 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -19,7 +19,6 @@ module Facet.Elab.Pattern import Control.Applicative (Alternative(..), asum, liftA2) import Control.Monad (ap) import Data.Bifunctor -import Data.Monoid import Facet.Name import Fresnel.Fold import Fresnel.Lens @@ -167,12 +166,12 @@ coverStep tableau@(Tableau context heads) = case context of Tableau ctx <$> forOf (traversed.patterns_) heads (\case p:ps | Right _ <- matching _Unit (instantiateHead canonical p) -> pure ps ps -> throw (t, ps)) - t1 :+ t2 -> getAp (foldMapOf (folded.patterns_) (Ap . \case + t1 :+ t2 -> foldMapOf (folded.patterns_) (\case Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) InL p:ps -> pure ([Clause (p:ps) ()], [Clause [] ()]) InR q:qs -> pure ([Clause [] ()], [Clause (q:qs) ()]) - ps -> throw (t, ps)) heads) + ps -> throw (t, ps)) heads >>= \ (cs1, cs2) -> pure (Tableau (t1:ctx) cs1) <|> pure (Tableau (t2:ctx) cs2) t1 :* t2 -> Tableau (t1:t2:ctx) <$> forOf (traversed.patterns_) heads (\case Wildcard:ps -> pure (Wildcard:Wildcard:ps) From 0210bcef773ff8c9fc975fc9145ebbff46915916 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 12:31:58 -0400 Subject: [PATCH 0827/1324] Return the type along with canonical patterns. --- src/Facet/Elab/Pattern.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index bf3d74bb3..5b48144c6 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -162,10 +162,10 @@ coverStep tableau@(Tableau context heads) = case context of Var _:ps -> pure ps ps -> throw (Opaque, ps)) One -> do - canonical <- asum (map pure (wild t)) + (ty, canonical) <- asum (map pure (wild t)) Tableau ctx <$> forOf (traversed.patterns_) heads (\case p:ps | Right _ <- matching _Unit (instantiateHead canonical p) -> pure ps - ps -> throw (t, ps)) + ps -> throw (ty, ps)) t1 :+ t2 -> foldMapOf (folded.patterns_) (\case Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) @@ -187,9 +187,9 @@ instantiateHead d (Var _) = d -- FIXME: let-bind any variables first instantiateHead _ p = p -wild :: Type -> [Pattern Name] +wild :: Type -> [(Type, Pattern Name)] wild = \case - Opaque -> [Wildcard] - One -> [Unit] - _ :+ _ -> [InL Wildcard, InR Wildcard] - _ :* _ -> [Pair Wildcard Wildcard] + Opaque -> [(Opaque, Wildcard)] + One -> [(One, Unit)] + s :+ t -> [(s, InL Wildcard), (t, InR Wildcard)] + s :* t -> [(s :* t, Pair Wildcard Wildcard)] From 4bb9e14157b1afe978ac9ec3605a4ec4969e3020 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 12:32:58 -0400 Subject: [PATCH 0828/1324] Return a prefix on the context. --- src/Facet/Elab/Pattern.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 5b48144c6..582bbf6eb 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -163,9 +163,9 @@ coverStep tableau@(Tableau context heads) = case context of ps -> throw (Opaque, ps)) One -> do (ty, canonical) <- asum (map pure (wild t)) - Tableau ctx <$> forOf (traversed.patterns_) heads (\case + Tableau (ty <> ctx) <$> forOf (traversed.patterns_) heads (\case p:ps | Right _ <- matching _Unit (instantiateHead canonical p) -> pure ps - ps -> throw (ty, ps)) + ps -> throw (t, ps)) t1 :+ t2 -> foldMapOf (folded.patterns_) (\case Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) @@ -187,9 +187,9 @@ instantiateHead d (Var _) = d -- FIXME: let-bind any variables first instantiateHead _ p = p -wild :: Type -> [(Type, Pattern Name)] +wild :: Type -> [([Type], Pattern Name)] wild = \case - Opaque -> [(Opaque, Wildcard)] - One -> [(One, Unit)] - s :+ t -> [(s, InL Wildcard), (t, InR Wildcard)] - s :* t -> [(s :* t, Pair Wildcard Wildcard)] + Opaque -> [([], Wildcard)] + One -> [([], Unit)] + s :+ t -> [([s], InL Wildcard), ([t], InR Wildcard)] + s :* t -> [([s, t], Pair Wildcard Wildcard)] From b56a6af7e2c16b4e134c8c0a0918d61aa751197b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 12:34:23 -0400 Subject: [PATCH 0829/1324] Rename a variable. --- src/Facet/Elab/Pattern.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 582bbf6eb..525d6be58 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -162,8 +162,8 @@ coverStep tableau@(Tableau context heads) = case context of Var _:ps -> pure ps ps -> throw (Opaque, ps)) One -> do - (ty, canonical) <- asum (map pure (wild t)) - Tableau (ty <> ctx) <$> forOf (traversed.patterns_) heads (\case + (prefix, canonical) <- asum (map pure (wild t)) + Tableau (prefix <> ctx) <$> forOf (traversed.patterns_) heads (\case p:ps | Right _ <- matching _Unit (instantiateHead canonical p) -> pure ps ps -> throw (t, ps)) t1 :+ t2 -> foldMapOf (folded.patterns_) (\case From 85330bcf958eb93460b09746278813735578c9bd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 18:36:48 -0400 Subject: [PATCH 0830/1324] Instantiate wildcards in Covers. --- src/Facet/Elab/Pattern.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 525d6be58..f751ae8f7 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -16,7 +16,7 @@ module Facet.Elab.Pattern , coverStep ) where -import Control.Applicative (Alternative(..), asum, liftA2) +import Control.Applicative (Alternative(..), liftA2) import Control.Monad (ap) import Data.Bifunctor import Facet.Name @@ -162,7 +162,7 @@ coverStep tableau@(Tableau context heads) = case context of Var _:ps -> pure ps ps -> throw (Opaque, ps)) One -> do - (prefix, canonical) <- asum (map pure (wild t)) + (prefix, canonical) <- wild t Tableau (prefix <> ctx) <$> forOf (traversed.patterns_) heads (\case p:ps | Right _ <- matching _Unit (instantiateHead canonical p) -> pure ps ps -> throw (t, ps)) @@ -187,9 +187,9 @@ instantiateHead d (Var _) = d -- FIXME: let-bind any variables first instantiateHead _ p = p -wild :: Type -> [([Type], Pattern Name)] +wild :: Type -> Covers e ([Type], Pattern Name) wild = \case - Opaque -> [([], Wildcard)] - One -> [([], Unit)] - s :+ t -> [([s], InL Wildcard), ([t], InR Wildcard)] - s :* t -> [([s, t], Pair Wildcard Wildcard)] + Opaque -> pure ([], Wildcard) + One -> pure ([], Unit) + s :+ t -> pure ([s], InL Wildcard) <|> pure ([t], InR Wildcard) + s :* t -> pure ([s, t], Pair Wildcard Wildcard) From 95f1c3cfd3235a23adaeab8df25e68e2c423910f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 22:56:44 -0400 Subject: [PATCH 0831/1324] Match pairs using wildcards. --- src/Facet/Elab/Pattern.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index f751ae8f7..80d975f66 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -173,12 +173,11 @@ coverStep tableau@(Tableau context heads) = case context of InR q:qs -> pure ([Clause [] ()], [Clause (q:qs) ()]) ps -> throw (t, ps)) heads >>= \ (cs1, cs2) -> pure (Tableau (t1:ctx) cs1) <|> pure (Tableau (t2:ctx) cs2) - t1 :* t2 -> Tableau (t1:t2:ctx) <$> forOf (traversed.patterns_) heads (\case - Wildcard:ps -> pure (Wildcard:Wildcard:ps) - -- FIXME: substitute variables out for wildcards so we don't have to bind fresh variable names - Var n:ps -> pure (Var n:Var n:ps) - Pair p1 p2:ps -> pure (p1:p2:ps) - ps -> throw (t1 :* t2, ps)) + _ :* _ -> do + (prefix, canonical) <- wild t + Tableau (prefix <> ctx) <$> forOf (traversed.patterns_) heads (\case + p:ps | Right (p1, p2) <- matching _Pair (instantiateHead canonical p) -> pure (p1:p2:ps) + ps -> throw (t, ps)) [] -> pure tableau -- FIXME: fail if clauses aren't all empty instantiateHead :: Pattern Name -> Pattern Name -> Pattern Name From da9c3a8f66bda2354634aeb53e0fe100b665a4ef Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 22:58:26 -0400 Subject: [PATCH 0832/1324] Handle the empty context case up front. --- src/Facet/Elab/Pattern.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 80d975f66..06449ef10 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -155,7 +155,8 @@ covers tableau = case context tableau of p:_ -> "expected " <> show t <> ", got " <> show p coverStep :: Tableau () -> Covers (Type, [Pattern Name]) (Tableau ()) -coverStep tableau@(Tableau context heads) = case context of +coverStep tableau@(Tableau [] _) = pure tableau -- FIXME: fail if clauses aren't all empty +coverStep (Tableau context heads) = case context of t:ctx -> case t of Opaque -> Tableau ctx <$> forOf (traversed.patterns_) heads (\case Wildcard:ps -> pure ps @@ -178,7 +179,6 @@ coverStep tableau@(Tableau context heads) = case context of Tableau (prefix <> ctx) <$> forOf (traversed.patterns_) heads (\case p:ps | Right (p1, p2) <- matching _Pair (instantiateHead canonical p) -> pure (p1:p2:ps) ps -> throw (t, ps)) - [] -> pure tableau -- FIXME: fail if clauses aren't all empty instantiateHead :: Pattern Name -> Pattern Name -> Pattern Name instantiateHead d Wildcard = d From 1b36bb827daff6e360361ce5d89df5255c6225d9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 15 Mar 2022 22:59:01 -0400 Subject: [PATCH 0833/1324] Match the context deeply. --- src/Facet/Elab/Pattern.hs | 45 +++++++++++++++++++-------------------- 1 file changed, 22 insertions(+), 23 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 06449ef10..dd3c4364d 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -156,29 +156,28 @@ covers tableau = case context tableau of coverStep :: Tableau () -> Covers (Type, [Pattern Name]) (Tableau ()) coverStep tableau@(Tableau [] _) = pure tableau -- FIXME: fail if clauses aren't all empty -coverStep (Tableau context heads) = case context of - t:ctx -> case t of - Opaque -> Tableau ctx <$> forOf (traversed.patterns_) heads (\case - Wildcard:ps -> pure ps - Var _:ps -> pure ps - ps -> throw (Opaque, ps)) - One -> do - (prefix, canonical) <- wild t - Tableau (prefix <> ctx) <$> forOf (traversed.patterns_) heads (\case - p:ps | Right _ <- matching _Unit (instantiateHead canonical p) -> pure ps - ps -> throw (t, ps)) - t1 :+ t2 -> foldMapOf (folded.patterns_) (\case - Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) - Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) - InL p:ps -> pure ([Clause (p:ps) ()], [Clause [] ()]) - InR q:qs -> pure ([Clause [] ()], [Clause (q:qs) ()]) - ps -> throw (t, ps)) heads - >>= \ (cs1, cs2) -> pure (Tableau (t1:ctx) cs1) <|> pure (Tableau (t2:ctx) cs2) - _ :* _ -> do - (prefix, canonical) <- wild t - Tableau (prefix <> ctx) <$> forOf (traversed.patterns_) heads (\case - p:ps | Right (p1, p2) <- matching _Pair (instantiateHead canonical p) -> pure (p1:p2:ps) - ps -> throw (t, ps)) +coverStep (Tableau (t:ctx) heads) = case t of + Opaque -> Tableau ctx <$> forOf (traversed.patterns_) heads (\case + Wildcard:ps -> pure ps + Var _:ps -> pure ps + ps -> throw (Opaque, ps)) + One -> do + (prefix, canonical) <- wild t + Tableau (prefix <> ctx) <$> forOf (traversed.patterns_) heads (\case + p:ps | Right _ <- matching _Unit (instantiateHead canonical p) -> pure ps + ps -> throw (t, ps)) + t1 :+ t2 -> foldMapOf (folded.patterns_) (\case + Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) + Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) + InL p:ps -> pure ([Clause (p:ps) ()], [Clause [] ()]) + InR q:qs -> pure ([Clause [] ()], [Clause (q:qs) ()]) + ps -> throw (t, ps)) heads + >>= \ (cs1, cs2) -> pure (Tableau (t1:ctx) cs1) <|> pure (Tableau (t2:ctx) cs2) + _ :* _ -> do + (prefix, canonical) <- wild t + Tableau (prefix <> ctx) <$> forOf (traversed.patterns_) heads (\case + p:ps | Right (p1, p2) <- matching _Pair (instantiateHead canonical p) -> pure (p1:p2:ps) + ps -> throw (t, ps)) instantiateHead :: Pattern Name -> Pattern Name -> Pattern Name instantiateHead d Wildcard = d From 61ae00a8c9214140803a56875f9dd479969bf23d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Mar 2022 01:01:11 -0400 Subject: [PATCH 0834/1324] Factor out matching. --- src/Facet/Elab/Pattern.hs | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index dd3c4364d..68a04b059 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -156,16 +156,12 @@ covers tableau = case context tableau of coverStep :: Tableau () -> Covers (Type, [Pattern Name]) (Tableau ()) coverStep tableau@(Tableau [] _) = pure tableau -- FIXME: fail if clauses aren't all empty -coverStep (Tableau (t:ctx) heads) = case t of +coverStep tableau@(Tableau (t:ctx) heads) = case t of Opaque -> Tableau ctx <$> forOf (traversed.patterns_) heads (\case Wildcard:ps -> pure ps Var _:ps -> pure ps ps -> throw (Opaque, ps)) - One -> do - (prefix, canonical) <- wild t - Tableau (prefix <> ctx) <$> forOf (traversed.patterns_) heads (\case - p:ps | Right _ <- matching _Unit (instantiateHead canonical p) -> pure ps - ps -> throw (t, ps)) + One -> match _Unit tableau t1 :+ t2 -> foldMapOf (folded.patterns_) (\case Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) @@ -179,6 +175,15 @@ coverStep (Tableau (t:ctx) heads) = case t of p:ps | Right (p1, p2) <- matching _Pair (instantiateHead canonical p) -> pure (p1:p2:ps) ps -> throw (t, ps)) +match :: Prism' (Pattern Name) a -> Tableau () -> Covers (Type, [Pattern Name]) (Tableau ()) +match _ tableau@(Tableau [] _) = pure tableau +match o (Tableau (t:ctx) heads) = do + (prefix, canonical) <- wild t + Tableau (prefix <> ctx) <$> forOf (traversed.patterns_) heads (\case + p:ps | Right _ <- matching o (instantiateHead canonical p) -> pure ps + ps -> throw (t, ps)) + + instantiateHead :: Pattern Name -> Pattern Name -> Pattern Name instantiateHead d Wildcard = d instantiateHead d (Var _) = d -- FIXME: let-bind any variables first From d693f719f4be4ae1a1bc0e64f666ae3a0c3f01ee Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Mar 2022 01:04:48 -0400 Subject: [PATCH 0835/1324] Match and decompose. --- src/Facet/Elab/Pattern.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 68a04b059..46bf1f264 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -22,7 +22,7 @@ import Data.Bifunctor import Facet.Name import Fresnel.Fold import Fresnel.Lens -import Fresnel.Prism (Prism', matching, prism') +import Fresnel.Prism (Prism', matching, matching', prism') import Fresnel.Traversal (forOf, traversed) data Pattern a @@ -161,7 +161,7 @@ coverStep tableau@(Tableau (t:ctx) heads) = case t of Wildcard:ps -> pure ps Var _:ps -> pure ps ps -> throw (Opaque, ps)) - One -> match _Unit tableau + One -> match (([] <$) . matching' _Unit) tableau t1 :+ t2 -> foldMapOf (folded.patterns_) (\case Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) @@ -175,13 +175,13 @@ coverStep tableau@(Tableau (t:ctx) heads) = case t of p:ps | Right (p1, p2) <- matching _Pair (instantiateHead canonical p) -> pure (p1:p2:ps) ps -> throw (t, ps)) -match :: Prism' (Pattern Name) a -> Tableau () -> Covers (Type, [Pattern Name]) (Tableau ()) +match :: (Pattern Name -> Maybe [Pattern Name]) -> Tableau () -> Covers (Type, [Pattern Name]) (Tableau ()) match _ tableau@(Tableau [] _) = pure tableau -match o (Tableau (t:ctx) heads) = do +match decompose (Tableau (t:ctx) heads) = do (prefix, canonical) <- wild t Tableau (prefix <> ctx) <$> forOf (traversed.patterns_) heads (\case - p:ps | Right _ <- matching o (instantiateHead canonical p) -> pure ps - ps -> throw (t, ps)) + p:ps | Just p' <- decompose (instantiateHead canonical p) -> pure (p' <> ps) + ps -> throw (t, ps)) instantiateHead :: Pattern Name -> Pattern Name -> Pattern Name From 5916a61114837268963fddaf5c8ea30c3ffaf715 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Mar 2022 01:18:29 -0400 Subject: [PATCH 0836/1324] Match products with the helper. --- src/Facet/Elab/Pattern.hs | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 46bf1f264..e93fdda53 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -22,7 +22,7 @@ import Data.Bifunctor import Facet.Name import Fresnel.Fold import Fresnel.Lens -import Fresnel.Prism (Prism', matching, matching', prism') +import Fresnel.Prism (Prism', matching', prism') import Fresnel.Traversal (forOf, traversed) data Pattern a @@ -169,11 +169,7 @@ coverStep tableau@(Tableau (t:ctx) heads) = case t of InR q:qs -> pure ([Clause [] ()], [Clause (q:qs) ()]) ps -> throw (t, ps)) heads >>= \ (cs1, cs2) -> pure (Tableau (t1:ctx) cs1) <|> pure (Tableau (t2:ctx) cs2) - _ :* _ -> do - (prefix, canonical) <- wild t - Tableau (prefix <> ctx) <$> forOf (traversed.patterns_) heads (\case - p:ps | Right (p1, p2) <- matching _Pair (instantiateHead canonical p) -> pure (p1:p2:ps) - ps -> throw (t, ps)) + _ :* _ -> match (fmap (\ (a, b) -> [a, b]) . matching' _Pair) tableau match :: (Pattern Name -> Maybe [Pattern Name]) -> Tableau () -> Covers (Type, [Pattern Name]) (Tableau ()) match _ tableau@(Tableau [] _) = pure tableau From a6483ce4809c9770190a4055cac78ad14d60e93e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Mar 2022 07:55:30 -0400 Subject: [PATCH 0837/1324] Match opaque types using match. --- src/Facet/Elab/Pattern.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index e93fdda53..93e7d8857 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -157,10 +157,7 @@ covers tableau = case context tableau of coverStep :: Tableau () -> Covers (Type, [Pattern Name]) (Tableau ()) coverStep tableau@(Tableau [] _) = pure tableau -- FIXME: fail if clauses aren't all empty coverStep tableau@(Tableau (t:ctx) heads) = case t of - Opaque -> Tableau ctx <$> forOf (traversed.patterns_) heads (\case - Wildcard:ps -> pure ps - Var _:ps -> pure ps - ps -> throw (Opaque, ps)) + Opaque -> match (([] <$) . matching' _Wildcard) tableau One -> match (([] <$) . matching' _Unit) tableau t1 :+ t2 -> foldMapOf (folded.patterns_) (\case Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) From 7760db105071e706599af939f1f65a82b484e881 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Mar 2022 08:16:24 -0400 Subject: [PATCH 0838/1324] Rename the left/right optics. --- src/Facet/Elab/Pattern.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 93e7d8857..294d311b5 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -63,13 +63,13 @@ _Unit = prism' (const Unit) (\case Unit -> Just () _ -> Nothing) -_Inl :: Prism' (Pattern a) (Pattern a) -_Inl = prism' InL (\case +_InL :: Prism' (Pattern a) (Pattern a) +_InL = prism' InL (\case InL p -> Just p _ -> Nothing) -_Inr :: Prism' (Pattern a) (Pattern a) -_Inr = prism' InR (\case +_InR :: Prism' (Pattern a) (Pattern a) +_InR = prism' InR (\case InR p -> Just p _ -> Nothing) From eb4a1b3903adaa1544467f04fcebcac56e6691b7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Mar 2022 08:18:58 -0400 Subject: [PATCH 0839/1324] Check coverage of sums using match. --- src/Facet/Elab/Pattern.hs | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 294d311b5..685856420 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -156,16 +156,10 @@ covers tableau = case context tableau of coverStep :: Tableau () -> Covers (Type, [Pattern Name]) (Tableau ()) coverStep tableau@(Tableau [] _) = pure tableau -- FIXME: fail if clauses aren't all empty -coverStep tableau@(Tableau (t:ctx) heads) = case t of - Opaque -> match (([] <$) . matching' _Wildcard) tableau - One -> match (([] <$) . matching' _Unit) tableau - t1 :+ t2 -> foldMapOf (folded.patterns_) (\case - Wildcard:ps -> pure ([Clause (Wildcard:ps) ()], [Clause (Wildcard:ps) ()]) - Var n:ps -> pure ([Clause (Var n:ps) ()], [Clause (Var n:ps) ()]) - InL p:ps -> pure ([Clause (p:ps) ()], [Clause [] ()]) - InR q:qs -> pure ([Clause [] ()], [Clause (q:qs) ()]) - ps -> throw (t, ps)) heads - >>= \ (cs1, cs2) -> pure (Tableau (t1:ctx) cs1) <|> pure (Tableau (t2:ctx) cs2) +coverStep tableau@(Tableau (t:_) _) = case t of + Opaque -> match (([] <$) . matching' _Wildcard) tableau + One -> match (([] <$) . matching' _Unit) tableau + _ :+ _ -> match (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) tableau _ :* _ -> match (fmap (\ (a, b) -> [a, b]) . matching' _Pair) tableau match :: (Pattern Name -> Maybe [Pattern Name]) -> Tableau () -> Covers (Type, [Pattern Name]) (Tableau ()) From 5c72127b0937439428f2015284f8154cc8c23b95 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Mar 2022 08:25:37 -0400 Subject: [PATCH 0840/1324] Rename the coverage loop. --- src/Facet/Elab/Pattern.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 685856420..1ffb29a99 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -12,7 +12,7 @@ module Facet.Elab.Pattern , (\/) -- * Coverage judgement , Covers(..) -, covers +, coverLoop , coverStep ) where @@ -145,10 +145,10 @@ instance Monoid a => Monoid (Covers e a) where throw :: e -> Covers e a throw e = Covers (\ _ _ _ err -> err e) -covers :: Tableau () -> Covers String (Tableau ()) -covers tableau = case context tableau of +coverLoop :: Tableau () -> Covers String (Tableau ()) +coverLoop tableau = case context tableau of [] -> pure tableau - _ -> first (uncurry formatError) (coverStep tableau) >>= covers + _ -> first (uncurry formatError) (coverStep tableau) >>= coverLoop where formatError t = \case [] -> "expected " <> show t <> ", got nothing" From f9154448367e56faa531da664e420ada17a112f9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Mar 2022 08:27:33 -0400 Subject: [PATCH 0841/1324] Define an entry point for coverage. --- src/Facet/Elab/Pattern.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 1ffb29a99..81ace318f 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -12,6 +12,7 @@ module Facet.Elab.Pattern , (\/) -- * Coverage judgement , Covers(..) +, covers , coverLoop , coverStep ) where @@ -145,6 +146,9 @@ instance Monoid a => Monoid (Covers e a) where throw :: e -> Covers e a throw e = Covers (\ _ _ _ err -> err e) +covers :: Tableau () -> Bool +covers t = runCovers (coverLoop t) (&&) (const True) True (const False) + coverLoop :: Tableau () -> Covers String (Tableau ()) coverLoop tableau = case context tableau of [] -> pure tableau From 2ab63286b161decffdae67c6b9552c64f0890c26 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Mar 2022 20:17:15 -0400 Subject: [PATCH 0842/1324] Implement stringL. --- src/Facet/Sequent/Print.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index 822fc45f2..7b23ef6c2 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -37,6 +37,7 @@ instance S.Sequent Print Print Print where funL a k = a P.<+> P.dot P.<+> k sumL cs = µ̃ <> P.braces (commaSep (map (\ c -> fresh (\ v -> anon v P.<+> P.dot P.<+> c (anon v))) cs)) prdL i k = P.parens (µ̃ <> withLevel (\ d -> k (map (\ i -> anon (d + fromIntegral i)) [0..i]))) + stringL b = P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) (.|.) = fmap (P.enclose P.langle P.rangle) . P.surround P.pipe From c3907099490fd333d814a2d5055c421a1f23847c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Mar 2022 20:19:09 -0400 Subject: [PATCH 0843/1324] Use the latest cabal. --- .github/workflows/ci.yml | 1 - 1 file changed, 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 018308b43..4031295fa 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -15,7 +15,6 @@ jobs: strategy: matrix: ghc: ["8.10"] - cabal: ["3.6"] steps: - uses: actions/checkout@v2 From 55305ccc01f78ed7b2c7a8de21ba5825eb5c49ca Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Mar 2022 20:19:36 -0400 Subject: [PATCH 0844/1324] Build on 9.2. --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 4031295fa..3b4c0e1a4 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -14,7 +14,7 @@ jobs: runs-on: ubuntu-latest strategy: matrix: - ghc: ["8.10"] + ghc: ["8.10", "9.2"] steps: - uses: actions/checkout@v2 From 68b92b49aed3488f0aebb793533a0ca9f2318952 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Mar 2022 20:24:23 -0400 Subject: [PATCH 0845/1324] Use the maintained Haskell CI action. --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 3b4c0e1a4..878fcbb4b 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -20,7 +20,7 @@ jobs: - uses: actions/checkout@v2 if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/main' - - uses: actions/setup-haskell@v1.1.4 + - uses: haskell/actions/setup@v1 name: Setup Haskell with: ghc-version: ${{ matrix.ghc }} From e73e78cc26715788db79a5464a389aa2c166f62e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Mar 2022 20:28:33 -0400 Subject: [PATCH 0846/1324] :fire: stringL. --- src/Facet/Sequent/Class.hs | 8 -------- src/Facet/Sequent/Print.hs | 1 - 2 files changed, 9 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index b2f8416a0..d034d521f 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -13,7 +13,6 @@ module Facet.Sequent.Class , funLA , sumLA , prdLA -, stringLA , (.||.) -- , Ctx(..) -- , Binding(..) @@ -43,7 +42,6 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma funL :: term -> coterm -> coterm sumL :: [term -> command] -> coterm prdL :: Int -> ([term] -> command) -> coterm - stringL :: (term -> command) -> coterm -- Commands (.|.) :: term -> coterm -> command @@ -98,12 +96,6 @@ prdLA -> m (i c) prdLA i = binder (prdL i) -stringLA - :: (Sequent t c d, Applicative i, Applicative m) - => (forall j . Applicative j => (i ~> j) -> j t -> m (j d)) - -> m (i c) -stringLA = binder stringL - (.||.) :: (Applicative m, Applicative i, Sequent t c d) => m (i t) -> m (i c) -> m (i d) (.||.) = liftA2 (liftA2 (.|.)) diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index 7b23ef6c2..822fc45f2 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -37,7 +37,6 @@ instance S.Sequent Print Print Print where funL a k = a P.<+> P.dot P.<+> k sumL cs = µ̃ <> P.braces (commaSep (map (\ c -> fresh (\ v -> anon v P.<+> P.dot P.<+> c (anon v))) cs)) prdL i k = P.parens (µ̃ <> withLevel (\ d -> k (map (\ i -> anon (d + fromIntegral i)) [0..i]))) - stringL b = P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) (.|.) = fmap (P.enclose P.langle P.rangle) . P.surround P.pipe From 0629fa4a5ac783c31d0e9e0ec759ea2d87d74878 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 16 Mar 2022 20:41:41 -0400 Subject: [PATCH 0847/1324] :fire: the dependency on fresnel-fused-effects. --- facet.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/facet.cabal b/facet.cabal index 43020ff1c..d02d5d694 100644 --- a/facet.cabal +++ b/facet.cabal @@ -161,7 +161,6 @@ library , exceptions ^>= 0.10 , filepath , fresnel - , fresnel-fused-effects , fused-effects , haskeline ^>= 0.8.1 , optparse-applicative From b1d07266fba2a16506351a99418d6471f3992994 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Mar 2022 09:23:35 -0400 Subject: [PATCH 0848/1324] Generalize match over Tableau types. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 81ace318f..13b012178 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -166,7 +166,7 @@ coverStep tableau@(Tableau (t:_) _) = case t of _ :+ _ -> match (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) tableau _ :* _ -> match (fmap (\ (a, b) -> [a, b]) . matching' _Pair) tableau -match :: (Pattern Name -> Maybe [Pattern Name]) -> Tableau () -> Covers (Type, [Pattern Name]) (Tableau ()) +match :: (Pattern Name -> Maybe [Pattern Name]) -> Tableau a -> Covers (Type, [Pattern Name]) (Tableau a) match _ tableau@(Tableau [] _) = pure tableau match decompose (Tableau (t:ctx) heads) = do (prefix, canonical) <- wild t From 3fec986fcb5f3bf664c9f8ee820c89d78b6e02ac Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Mar 2022 09:24:08 -0400 Subject: [PATCH 0849/1324] Generalize coverStep over Tableau types. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 13b012178..9b51fb2b4 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -158,7 +158,7 @@ coverLoop tableau = case context tableau of [] -> "expected " <> show t <> ", got nothing" p:_ -> "expected " <> show t <> ", got " <> show p -coverStep :: Tableau () -> Covers (Type, [Pattern Name]) (Tableau ()) +coverStep :: Tableau a -> Covers (Type, [Pattern Name]) (Tableau a) coverStep tableau@(Tableau [] _) = pure tableau -- FIXME: fail if clauses aren't all empty coverStep tableau@(Tableau (t:_) _) = case t of Opaque -> match (([] <$) . matching' _Wildcard) tableau From 9411230f445e087daabe3507419e2fc526e78055 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Mar 2022 09:24:28 -0400 Subject: [PATCH 0850/1324] Generalize coverLoop over Tableau types. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 9b51fb2b4..f95ee7b82 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -149,7 +149,7 @@ throw e = Covers (\ _ _ _ err -> err e) covers :: Tableau () -> Bool covers t = runCovers (coverLoop t) (&&) (const True) True (const False) -coverLoop :: Tableau () -> Covers String (Tableau ()) +coverLoop :: Tableau a -> Covers String (Tableau a) coverLoop tableau = case context tableau of [] -> pure tableau _ -> first (uncurry formatError) (coverStep tableau) >>= coverLoop From cdc2b8db70d056c9feaa7171a158c4bacad2c204 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Mar 2022 09:27:22 -0400 Subject: [PATCH 0851/1324] Generalize covers over the Tableau type. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index f95ee7b82..734ffe73f 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -146,7 +146,7 @@ instance Monoid a => Monoid (Covers e a) where throw :: e -> Covers e a throw e = Covers (\ _ _ _ err -> err e) -covers :: Tableau () -> Bool +covers :: Tableau a -> Bool covers t = runCovers (coverLoop t) (&&) (const True) True (const False) coverLoop :: Tableau a -> Covers String (Tableau a) From e8780966266a487f99ed4fac237b91f2989db7e8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Mar 2022 09:29:04 -0400 Subject: [PATCH 0852/1324] Add a FIXME. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 734ffe73f..19f052387 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -163,7 +163,7 @@ coverStep tableau@(Tableau [] _) = pure tableau -- FIXME: fail if clauses aren't coverStep tableau@(Tableau (t:_) _) = case t of Opaque -> match (([] <$) . matching' _Wildcard) tableau One -> match (([] <$) . matching' _Unit) tableau - _ :+ _ -> match (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) tableau + _ :+ _ -> match (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) tableau -- FIXME: match once and partition results _ :* _ -> match (fmap (\ (a, b) -> [a, b]) . matching' _Pair) tableau match :: (Pattern Name -> Maybe [Pattern Name]) -> Tableau a -> Covers (Type, [Pattern Name]) (Tableau a) From 7e46bd4c0f3a8ef2ce8592ef3d5a5c11ac0e7cd0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Mar 2022 09:29:23 -0400 Subject: [PATCH 0853/1324] Duplicate a FIXME. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 19f052387..619cf46c2 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -151,7 +151,7 @@ covers t = runCovers (coverLoop t) (&&) (const True) True (const False) coverLoop :: Tableau a -> Covers String (Tableau a) coverLoop tableau = case context tableau of - [] -> pure tableau + [] -> pure tableau -- FIXME: fail if clauses aren't all empty _ -> first (uncurry formatError) (coverStep tableau) >>= coverLoop where formatError t = \case From 113a47820e8ef7cfb712812efbd923ccf8d3fd68 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Mar 2022 09:44:40 -0400 Subject: [PATCH 0854/1324] Combine terminal cases. --- src/Facet/Elab/Pattern.hs | 28 +++++++++++++++------------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 619cf46c2..9eb80c4be 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -17,14 +17,15 @@ module Facet.Elab.Pattern , coverStep ) where -import Control.Applicative (Alternative(..), liftA2) -import Control.Monad (ap) -import Data.Bifunctor -import Facet.Name -import Fresnel.Fold -import Fresnel.Lens -import Fresnel.Prism (Prism', matching', prism') -import Fresnel.Traversal (forOf, traversed) +import Control.Applicative (Alternative(..), liftA2) +import Control.Monad (ap) +import Data.Bifunctor +import qualified Data.List.NonEmpty as NE +import Facet.Name +import Fresnel.Fold +import Fresnel.Lens +import Fresnel.Prism (Prism', matching', prism') +import Fresnel.Traversal (forOf, traversed) data Pattern a = Wildcard @@ -151,20 +152,21 @@ covers t = runCovers (coverLoop t) (&&) (const True) True (const False) coverLoop :: Tableau a -> Covers String (Tableau a) coverLoop tableau = case context tableau of - [] -> pure tableau -- FIXME: fail if clauses aren't all empty - _ -> first (uncurry formatError) (coverStep tableau) >>= coverLoop + [] -> pure tableau -- FIXME: fail if clauses aren't all empty + t:ts -> first (uncurry formatError) (coverStep (t NE.:| ts) (heads tableau)) >>= coverLoop where formatError t = \case [] -> "expected " <> show t <> ", got nothing" p:_ -> "expected " <> show t <> ", got " <> show p -coverStep :: Tableau a -> Covers (Type, [Pattern Name]) (Tableau a) -coverStep tableau@(Tableau [] _) = pure tableau -- FIXME: fail if clauses aren't all empty -coverStep tableau@(Tableau (t:_) _) = case t of +coverStep :: NE.NonEmpty Type -> [Clause a] -> Covers (Type, [Pattern Name]) (Tableau a) +coverStep ctx@(t NE.:| _) cs = case t of Opaque -> match (([] <$) . matching' _Wildcard) tableau One -> match (([] <$) . matching' _Unit) tableau _ :+ _ -> match (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) tableau -- FIXME: match once and partition results _ :* _ -> match (fmap (\ (a, b) -> [a, b]) . matching' _Pair) tableau + where + tableau = Tableau (NE.toList ctx) cs match :: (Pattern Name -> Maybe [Pattern Name]) -> Tableau a -> Covers (Type, [Pattern Name]) (Tableau a) match _ tableau@(Tableau [] _) = pure tableau From b20ed122070d94b7f3cafe3cc855d09d1851256c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Mar 2022 09:47:41 -0400 Subject: [PATCH 0855/1324] Non-tacit. --- src/Facet/Elab/Pattern.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 9eb80c4be..0ddce5dba 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -161,10 +161,10 @@ coverLoop tableau = case context tableau of coverStep :: NE.NonEmpty Type -> [Clause a] -> Covers (Type, [Pattern Name]) (Tableau a) coverStep ctx@(t NE.:| _) cs = case t of - Opaque -> match (([] <$) . matching' _Wildcard) tableau - One -> match (([] <$) . matching' _Unit) tableau + Opaque -> match (\ p -> [] <$ matching' _Wildcard p) tableau + One -> match (\ p -> [] <$ matching' _Unit p) tableau _ :+ _ -> match (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) tableau -- FIXME: match once and partition results - _ :* _ -> match (fmap (\ (a, b) -> [a, b]) . matching' _Pair) tableau + _ :* _ -> match (\ p -> (\ (a, b) -> [a, b]) <$> matching' _Pair p) tableau where tableau = Tableau (NE.toList ctx) cs From 54a4de980febb618b06043de5c22b7c858f88ece Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Mar 2022 09:55:36 -0400 Subject: [PATCH 0856/1324] Obviate the need for another terminal case. --- src/Facet/Elab/Pattern.hs | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 0ddce5dba..a8f249420 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -160,17 +160,14 @@ coverLoop tableau = case context tableau of p:_ -> "expected " <> show t <> ", got " <> show p coverStep :: NE.NonEmpty Type -> [Clause a] -> Covers (Type, [Pattern Name]) (Tableau a) -coverStep ctx@(t NE.:| _) cs = case t of - Opaque -> match (\ p -> [] <$ matching' _Wildcard p) tableau - One -> match (\ p -> [] <$ matching' _Unit p) tableau - _ :+ _ -> match (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) tableau -- FIXME: match once and partition results - _ :* _ -> match (\ p -> (\ (a, b) -> [a, b]) <$> matching' _Pair p) tableau - where - tableau = Tableau (NE.toList ctx) cs - -match :: (Pattern Name -> Maybe [Pattern Name]) -> Tableau a -> Covers (Type, [Pattern Name]) (Tableau a) -match _ tableau@(Tableau [] _) = pure tableau -match decompose (Tableau (t:ctx) heads) = do +coverStep ctx@(t NE.:| _) heads = case t of + Opaque -> match (\ p -> [] <$ matching' _Wildcard p) ctx heads + One -> match (\ p -> [] <$ matching' _Unit p) ctx heads + _ :+ _ -> match (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) ctx heads -- FIXME: match once and partition results + _ :* _ -> match (\ p -> (\ (a, b) -> [a, b]) <$> matching' _Pair p) ctx heads + +match :: (Pattern Name -> Maybe [Pattern Name]) -> NE.NonEmpty Type -> [Clause a] -> Covers (Type, [Pattern Name]) (Tableau a) +match decompose (t NE.:| ctx) heads = do (prefix, canonical) <- wild t Tableau (prefix <> ctx) <$> forOf (traversed.patterns_) heads (\case p:ps | Just p' <- decompose (instantiateHead canonical p) -> pure (p' <> ps) From b5318cb617f80a1cf2b30a831cac2e35d7fee7d5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Mar 2022 14:43:18 -0400 Subject: [PATCH 0857/1324] :fire: the Semigroup & Monoid instances for Covers. --- src/Facet/Elab/Pattern.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index a8f249420..974528ec4 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -17,7 +17,7 @@ module Facet.Elab.Pattern , coverStep ) where -import Control.Applicative (Alternative(..), liftA2) +import Control.Applicative (Alternative(..)) import Control.Monad (ap) import Data.Bifunctor import qualified Data.List.NonEmpty as NE @@ -138,12 +138,6 @@ instance Alternative (Covers e) where instance Monad (Covers e) where Covers m >>= k = Covers (\ fork leaf nil err -> m fork (\ a -> runCovers (k a) fork leaf nil err) nil err) -instance Semigroup a => Semigroup (Covers e a) where - (<>) = liftA2 (<>) - -instance Monoid a => Monoid (Covers e a) where - mempty = pure mempty - throw :: e -> Covers e a throw e = Covers (\ _ _ _ err -> err e) From c4b56ac1f1c22484d5c06032d9a3ad26a6d8b9bf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Mar 2022 14:48:47 -0400 Subject: [PATCH 0858/1324] Inline wild. --- src/Facet/Elab/Pattern.hs | 24 ++++++++---------------- 1 file changed, 8 insertions(+), 16 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 974528ec4..4dbbf496b 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -155,14 +155,14 @@ coverLoop tableau = case context tableau of coverStep :: NE.NonEmpty Type -> [Clause a] -> Covers (Type, [Pattern Name]) (Tableau a) coverStep ctx@(t NE.:| _) heads = case t of - Opaque -> match (\ p -> [] <$ matching' _Wildcard p) ctx heads - One -> match (\ p -> [] <$ matching' _Unit p) ctx heads - _ :+ _ -> match (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) ctx heads -- FIXME: match once and partition results - _ :* _ -> match (\ p -> (\ (a, b) -> [a, b]) <$> matching' _Pair p) ctx heads - -match :: (Pattern Name -> Maybe [Pattern Name]) -> NE.NonEmpty Type -> [Clause a] -> Covers (Type, [Pattern Name]) (Tableau a) -match decompose (t NE.:| ctx) heads = do - (prefix, canonical) <- wild t + Opaque -> match (\ p -> [] <$ matching' _Wildcard p) (pure ([], Wildcard)) ctx heads + One -> match (\ p -> [] <$ matching' _Unit p) (pure ([], Unit)) ctx heads + s :+ t -> match (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) (pure ([s], InL Wildcard) <|> pure ([t], InR Wildcard)) ctx heads -- FIXME: match once and partition results + s :* t -> match (\ p -> (\ (a, b) -> [a, b]) <$> matching' _Pair p) (pure ([s, t], Pair Wildcard Wildcard)) ctx heads + +match :: (Pattern Name -> Maybe [Pattern Name]) -> Covers (Type, [Pattern Name]) ([Type], Pattern Name) -> NE.NonEmpty Type -> [Clause a] -> Covers (Type, [Pattern Name]) (Tableau a) +match decompose inst (t NE.:| ctx) heads = do + (prefix, canonical) <- inst Tableau (prefix <> ctx) <$> forOf (traversed.patterns_) heads (\case p:ps | Just p' <- decompose (instantiateHead canonical p) -> pure (p' <> ps) ps -> throw (t, ps)) @@ -172,11 +172,3 @@ instantiateHead :: Pattern Name -> Pattern Name -> Pattern Name instantiateHead d Wildcard = d instantiateHead d (Var _) = d -- FIXME: let-bind any variables first instantiateHead _ p = p - - -wild :: Type -> Covers e ([Type], Pattern Name) -wild = \case - Opaque -> pure ([], Wildcard) - One -> pure ([], Unit) - s :+ t -> pure ([s], InL Wildcard) <|> pure ([t], InR Wildcard) - s :* t -> pure ([s, t], Pair Wildcard Wildcard) From 044a470999d236bf429a5321409c72bb24895c13 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Mar 2022 14:50:22 -0400 Subject: [PATCH 0859/1324] Pass the decomposition function last. --- src/Facet/Elab/Pattern.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 4dbbf496b..472c9841a 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -155,13 +155,13 @@ coverLoop tableau = case context tableau of coverStep :: NE.NonEmpty Type -> [Clause a] -> Covers (Type, [Pattern Name]) (Tableau a) coverStep ctx@(t NE.:| _) heads = case t of - Opaque -> match (\ p -> [] <$ matching' _Wildcard p) (pure ([], Wildcard)) ctx heads - One -> match (\ p -> [] <$ matching' _Unit p) (pure ([], Unit)) ctx heads - s :+ t -> match (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) (pure ([s], InL Wildcard) <|> pure ([t], InR Wildcard)) ctx heads -- FIXME: match once and partition results - s :* t -> match (\ p -> (\ (a, b) -> [a, b]) <$> matching' _Pair p) (pure ([s, t], Pair Wildcard Wildcard)) ctx heads + Opaque -> match (pure ([], Wildcard)) ctx heads (\ p -> [] <$ matching' _Wildcard p) + One -> match (pure ([], Unit)) ctx heads (\ p -> [] <$ matching' _Unit p) + s :+ t -> match (pure ([s], InL Wildcard) <|> pure ([t], InR Wildcard)) ctx heads (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) -- FIXME: match once and partition results + s :* t -> match (pure ([s, t], Pair Wildcard Wildcard)) ctx heads (\ p -> (\ (a, b) -> [a, b]) <$> matching' _Pair p) -match :: (Pattern Name -> Maybe [Pattern Name]) -> Covers (Type, [Pattern Name]) ([Type], Pattern Name) -> NE.NonEmpty Type -> [Clause a] -> Covers (Type, [Pattern Name]) (Tableau a) -match decompose inst (t NE.:| ctx) heads = do +match :: Covers (Type, [Pattern Name]) ([Type], Pattern Name) -> NE.NonEmpty Type -> [Clause a] -> (Pattern Name -> Maybe [Pattern Name]) -> Covers (Type, [Pattern Name]) (Tableau a) +match inst (t NE.:| ctx) heads decompose = do (prefix, canonical) <- inst Tableau (prefix <> ctx) <$> forOf (traversed.patterns_) heads (\case p:ps | Just p' <- decompose (instantiateHead canonical p) -> pure (p' <> ps) From 916ea6fcd26f0628b0a1121e2264bde4d692ccf1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Mar 2022 14:51:39 -0400 Subject: [PATCH 0860/1324] Take instantiation as a list. --- src/Facet/Elab/Pattern.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 472c9841a..8f4162cce 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -17,7 +17,7 @@ module Facet.Elab.Pattern , coverStep ) where -import Control.Applicative (Alternative(..)) +import Control.Applicative (Alternative(..), asum) import Control.Monad (ap) import Data.Bifunctor import qualified Data.List.NonEmpty as NE @@ -160,9 +160,9 @@ coverStep ctx@(t NE.:| _) heads = case t of s :+ t -> match (pure ([s], InL Wildcard) <|> pure ([t], InR Wildcard)) ctx heads (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) -- FIXME: match once and partition results s :* t -> match (pure ([s, t], Pair Wildcard Wildcard)) ctx heads (\ p -> (\ (a, b) -> [a, b]) <$> matching' _Pair p) -match :: Covers (Type, [Pattern Name]) ([Type], Pattern Name) -> NE.NonEmpty Type -> [Clause a] -> (Pattern Name -> Maybe [Pattern Name]) -> Covers (Type, [Pattern Name]) (Tableau a) +match :: [([Type], Pattern Name)] -> NE.NonEmpty Type -> [Clause a] -> (Pattern Name -> Maybe [Pattern Name]) -> Covers (Type, [Pattern Name]) (Tableau a) match inst (t NE.:| ctx) heads decompose = do - (prefix, canonical) <- inst + (prefix, canonical) <- asum (pure <$> inst) Tableau (prefix <> ctx) <$> forOf (traversed.patterns_) heads (\case p:ps | Just p' <- decompose (instantiateHead canonical p) -> pure (p' <> ps) ps -> throw (t, ps)) From bb14411b6d794f4f99d5a23c5b3cd3a7ace1dfcf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 17 Mar 2022 14:52:32 -0400 Subject: [PATCH 0861/1324] Pass instantiation as a list. --- src/Facet/Elab/Pattern.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 8f4162cce..0aaba896d 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -155,10 +155,10 @@ coverLoop tableau = case context tableau of coverStep :: NE.NonEmpty Type -> [Clause a] -> Covers (Type, [Pattern Name]) (Tableau a) coverStep ctx@(t NE.:| _) heads = case t of - Opaque -> match (pure ([], Wildcard)) ctx heads (\ p -> [] <$ matching' _Wildcard p) - One -> match (pure ([], Unit)) ctx heads (\ p -> [] <$ matching' _Unit p) - s :+ t -> match (pure ([s], InL Wildcard) <|> pure ([t], InR Wildcard)) ctx heads (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) -- FIXME: match once and partition results - s :* t -> match (pure ([s, t], Pair Wildcard Wildcard)) ctx heads (\ p -> (\ (a, b) -> [a, b]) <$> matching' _Pair p) + Opaque -> match [([], Wildcard)] ctx heads (\ p -> [] <$ matching' _Wildcard p) + One -> match [([], Unit)] ctx heads (\ p -> [] <$ matching' _Unit p) + s :+ t -> match [([s], InL Wildcard), ([t], InR Wildcard)] ctx heads (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) -- FIXME: match once and partition results + s :* t -> match [([s, t], Pair Wildcard Wildcard)] ctx heads (\ p -> (\ (a, b) -> [a, b]) <$> matching' _Pair p) match :: [([Type], Pattern Name)] -> NE.NonEmpty Type -> [Clause a] -> (Pattern Name -> Maybe [Pattern Name]) -> Covers (Type, [Pattern Name]) (Tableau a) match inst (t NE.:| ctx) heads decompose = do From 1d2888a2d5a60b40a0232494fa41abedaac511ad Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Mar 2022 14:22:55 -0400 Subject: [PATCH 0862/1324] Add function types. --- src/Facet/Elab/Pattern.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 0aaba896d..8f393624f 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -92,10 +92,12 @@ data Type | One | Type :+ Type | Type :* Type + | Type :-> Type deriving (Eq, Ord, Show) infixl 6 :+ infixl 7 :* +infixl 1 :-> data Tableau a = Tableau { context :: [Type] @@ -155,10 +157,11 @@ coverLoop tableau = case context tableau of coverStep :: NE.NonEmpty Type -> [Clause a] -> Covers (Type, [Pattern Name]) (Tableau a) coverStep ctx@(t NE.:| _) heads = case t of - Opaque -> match [([], Wildcard)] ctx heads (\ p -> [] <$ matching' _Wildcard p) - One -> match [([], Unit)] ctx heads (\ p -> [] <$ matching' _Unit p) - s :+ t -> match [([s], InL Wildcard), ([t], InR Wildcard)] ctx heads (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) -- FIXME: match once and partition results - s :* t -> match [([s, t], Pair Wildcard Wildcard)] ctx heads (\ p -> (\ (a, b) -> [a, b]) <$> matching' _Pair p) + Opaque -> match [([], Wildcard)] ctx heads (\ p -> [] <$ matching' _Wildcard p) + One -> match [([], Unit)] ctx heads (\ p -> [] <$ matching' _Unit p) + s :+ t -> match [([s], InL Wildcard), ([t], InR Wildcard)] ctx heads (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) -- FIXME: match once and partition results + s :* t -> match [([s, t], Pair Wildcard Wildcard)] ctx heads (\ p -> (\ (a, b) -> [a, b]) <$> matching' _Pair p) + _ :-> _ -> match [([], Wildcard)] ctx heads (\ p -> [] <$ matching' _Wildcard p) match :: [([Type], Pattern Name)] -> NE.NonEmpty Type -> [Clause a] -> (Pattern Name -> Maybe [Pattern Name]) -> Covers (Type, [Pattern Name]) (Tableau a) match inst (t NE.:| ctx) heads decompose = do From fca2509db4b9b3e3568ca6323f8a1dead45d0424 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Mar 2022 15:20:20 -0400 Subject: [PATCH 0863/1324] Factor the tableau out of covers. --- src/Facet/Elab/Pattern.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 8f393624f..3b943b273 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -143,8 +143,8 @@ instance Monad (Covers e) where throw :: e -> Covers e a throw e = Covers (\ _ _ _ err -> err e) -covers :: Tableau a -> Bool -covers t = runCovers (coverLoop t) (&&) (const True) True (const False) +covers :: [Type] -> [Clause a] -> Bool +covers ctx heads = runCovers (coverLoop (Tableau ctx heads)) (&&) (const True) True (const False) coverLoop :: Tableau a -> Covers String (Tableau a) coverLoop tableau = case context tableau of From a7120fd05f22c198f5361daf1ddf860f02043989 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Mar 2022 15:21:47 -0400 Subject: [PATCH 0864/1324] Factor the Tableau out of coverLoop. --- src/Facet/Elab/Pattern.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 3b943b273..aeb248fb9 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -144,12 +144,12 @@ throw :: e -> Covers e a throw e = Covers (\ _ _ _ err -> err e) covers :: [Type] -> [Clause a] -> Bool -covers ctx heads = runCovers (coverLoop (Tableau ctx heads)) (&&) (const True) True (const False) +covers ctx heads = runCovers (coverLoop ctx heads) (&&) (const True) True (const False) -coverLoop :: Tableau a -> Covers String (Tableau a) -coverLoop tableau = case context tableau of - [] -> pure tableau -- FIXME: fail if clauses aren't all empty - t:ts -> first (uncurry formatError) (coverStep (t NE.:| ts) (heads tableau)) >>= coverLoop +coverLoop :: [Type] -> [Clause a] -> Covers String (Tableau a) +coverLoop ctx heads = case ctx of + [] -> pure (Tableau ctx heads) -- FIXME: fail if clauses aren't all empty + t:ts -> first (uncurry formatError) (coverStep (t NE.:| ts) heads) >>= \ (Tableau ctx heads) -> coverLoop ctx heads where formatError t = \case [] -> "expected " <> show t <> ", got nothing" From d4c313653ddd1a06cd4a04522b5207933d223d77 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Mar 2022 15:22:26 -0400 Subject: [PATCH 0865/1324] Return the context and heads from coverLoop directly. --- src/Facet/Elab/Pattern.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index aeb248fb9..308c7d213 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -146,9 +146,9 @@ throw e = Covers (\ _ _ _ err -> err e) covers :: [Type] -> [Clause a] -> Bool covers ctx heads = runCovers (coverLoop ctx heads) (&&) (const True) True (const False) -coverLoop :: [Type] -> [Clause a] -> Covers String (Tableau a) +coverLoop :: [Type] -> [Clause a] -> Covers String ([Type], [Clause a]) coverLoop ctx heads = case ctx of - [] -> pure (Tableau ctx heads) -- FIXME: fail if clauses aren't all empty + [] -> pure (ctx, heads) -- FIXME: fail if clauses aren't all empty t:ts -> first (uncurry formatError) (coverStep (t NE.:| ts) heads) >>= \ (Tableau ctx heads) -> coverLoop ctx heads where formatError t = \case From 7a0f7aa6df3e4839a70a4f0b536c1e4509a2dc43 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Mar 2022 15:23:47 -0400 Subject: [PATCH 0866/1324] Factor the Tableau out of coverStep & match. --- src/Facet/Elab/Pattern.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 308c7d213..2c3a4dcbf 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -149,13 +149,13 @@ covers ctx heads = runCovers (coverLoop ctx heads) (&&) (const True) True (const coverLoop :: [Type] -> [Clause a] -> Covers String ([Type], [Clause a]) coverLoop ctx heads = case ctx of [] -> pure (ctx, heads) -- FIXME: fail if clauses aren't all empty - t:ts -> first (uncurry formatError) (coverStep (t NE.:| ts) heads) >>= \ (Tableau ctx heads) -> coverLoop ctx heads + t:ts -> first (uncurry formatError) (coverStep (t NE.:| ts) heads) >>= uncurry coverLoop where formatError t = \case [] -> "expected " <> show t <> ", got nothing" p:_ -> "expected " <> show t <> ", got " <> show p -coverStep :: NE.NonEmpty Type -> [Clause a] -> Covers (Type, [Pattern Name]) (Tableau a) +coverStep :: NE.NonEmpty Type -> [Clause a] -> Covers (Type, [Pattern Name]) ([Type], [Clause a]) coverStep ctx@(t NE.:| _) heads = case t of Opaque -> match [([], Wildcard)] ctx heads (\ p -> [] <$ matching' _Wildcard p) One -> match [([], Unit)] ctx heads (\ p -> [] <$ matching' _Unit p) @@ -163,10 +163,10 @@ coverStep ctx@(t NE.:| _) heads = case t of s :* t -> match [([s, t], Pair Wildcard Wildcard)] ctx heads (\ p -> (\ (a, b) -> [a, b]) <$> matching' _Pair p) _ :-> _ -> match [([], Wildcard)] ctx heads (\ p -> [] <$ matching' _Wildcard p) -match :: [([Type], Pattern Name)] -> NE.NonEmpty Type -> [Clause a] -> (Pattern Name -> Maybe [Pattern Name]) -> Covers (Type, [Pattern Name]) (Tableau a) +match :: [([Type], Pattern Name)] -> NE.NonEmpty Type -> [Clause a] -> (Pattern Name -> Maybe [Pattern Name]) -> Covers (Type, [Pattern Name]) ([Type], [Clause a]) match inst (t NE.:| ctx) heads decompose = do (prefix, canonical) <- asum (pure <$> inst) - Tableau (prefix <> ctx) <$> forOf (traversed.patterns_) heads (\case + (prefix <> ctx,) <$> forOf (traversed.patterns_) heads (\case p:ps | Just p' <- decompose (instantiateHead canonical p) -> pure (p' <> ps) ps -> throw (t, ps)) From 6cc78fa9a6fa8914e0f8c058ce0109e44e962c1b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Mar 2022 15:24:22 -0400 Subject: [PATCH 0867/1324] :fire: Tableau. --- src/Facet/Elab/Pattern.hs | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 2c3a4dcbf..b0b7f76e6 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -5,9 +5,6 @@ module Facet.Elab.Pattern , Clause(..) , patterns_ , Type(..) -, Tableau(..) -, context_ -, heads_ , Branch(..) , (\/) -- * Coverage judgement @@ -99,17 +96,6 @@ infixl 6 :+ infixl 7 :* infixl 1 :-> -data Tableau a = Tableau - { context :: [Type] - , heads :: [Clause a] - } - -context_ :: Lens' (Tableau a) [Type] -context_ = lens context (\ t context -> t{context}) - -heads_ :: Lens (Tableau a) (Tableau b) [Clause a] [Clause b] -heads_ = lens heads (\ t heads -> t{heads}) - data Branch s m a = forall x . Branch (Fold s x) (x -> m a) From 5eea180a0e5e18499a928fa72f49c7a71fbe735b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Mar 2022 15:30:22 -0400 Subject: [PATCH 0868/1324] Iterate down a single type. --- src/Facet/Elab/Pattern.hs | 51 +++++++++++++++++++-------------------- 1 file changed, 25 insertions(+), 26 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index b0b7f76e6..f26edd8f8 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -14,15 +14,14 @@ module Facet.Elab.Pattern , coverStep ) where -import Control.Applicative (Alternative(..), asum) -import Control.Monad (ap) -import Data.Bifunctor -import qualified Data.List.NonEmpty as NE -import Facet.Name -import Fresnel.Fold -import Fresnel.Lens -import Fresnel.Prism (Prism', matching', prism') -import Fresnel.Traversal (forOf, traversed) +import Control.Applicative (Alternative(..), asum) +import Control.Monad (ap) +import Data.Bifunctor +import Facet.Name +import Fresnel.Fold +import Fresnel.Lens +import Fresnel.Prism (Prism', matching', prism') +import Fresnel.Traversal (forOf, traversed) data Pattern a = Wildcard @@ -129,32 +128,32 @@ instance Monad (Covers e) where throw :: e -> Covers e a throw e = Covers (\ _ _ _ err -> err e) -covers :: [Type] -> [Clause a] -> Bool -covers ctx heads = runCovers (coverLoop ctx heads) (&&) (const True) True (const False) +covers :: Type -> [Clause a] -> Bool +covers ty heads = runCovers (coverLoop ty heads) (&&) (const True) True (const False) -coverLoop :: [Type] -> [Clause a] -> Covers String ([Type], [Clause a]) -coverLoop ctx heads = case ctx of - [] -> pure (ctx, heads) -- FIXME: fail if clauses aren't all empty - t:ts -> first (uncurry formatError) (coverStep (t NE.:| ts) heads) >>= uncurry coverLoop +coverLoop :: Type -> [Clause a] -> Covers String (Type, [Clause a]) +coverLoop ty heads = case ty of + hd :-> tl -> first (uncurry formatError) (coverStep hd tl heads) >>= uncurry coverLoop + ty -> pure (ty, heads) -- FIXME: fail if clauses aren't all empty where formatError t = \case [] -> "expected " <> show t <> ", got nothing" p:_ -> "expected " <> show t <> ", got " <> show p -coverStep :: NE.NonEmpty Type -> [Clause a] -> Covers (Type, [Pattern Name]) ([Type], [Clause a]) -coverStep ctx@(t NE.:| _) heads = case t of - Opaque -> match [([], Wildcard)] ctx heads (\ p -> [] <$ matching' _Wildcard p) - One -> match [([], Unit)] ctx heads (\ p -> [] <$ matching' _Unit p) - s :+ t -> match [([s], InL Wildcard), ([t], InR Wildcard)] ctx heads (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) -- FIXME: match once and partition results - s :* t -> match [([s, t], Pair Wildcard Wildcard)] ctx heads (\ p -> (\ (a, b) -> [a, b]) <$> matching' _Pair p) - _ :-> _ -> match [([], Wildcard)] ctx heads (\ p -> [] <$ matching' _Wildcard p) +coverStep :: Type -> Type -> [Clause a] -> Covers (Type, [Pattern Name]) (Type, [Clause a]) +coverStep hd tl heads = case hd of + Opaque -> match [([], Wildcard)] hd tl heads (\ p -> [] <$ matching' _Wildcard p) + One -> match [([], Unit)] hd tl heads (\ p -> [] <$ matching' _Unit p) + s :+ t -> match [([s], InL Wildcard), ([t], InR Wildcard)] hd tl heads (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) -- FIXME: match once and partition results + s :* t -> match [([s, t], Pair Wildcard Wildcard)] hd tl heads (\ p -> (\ (a, b) -> [a, b]) <$> matching' _Pair p) + _ :-> _ -> match [([], Wildcard)] hd tl heads (\ p -> [] <$ matching' _Wildcard p) -match :: [([Type], Pattern Name)] -> NE.NonEmpty Type -> [Clause a] -> (Pattern Name -> Maybe [Pattern Name]) -> Covers (Type, [Pattern Name]) ([Type], [Clause a]) -match inst (t NE.:| ctx) heads decompose = do +match :: [([Type], Pattern Name)] -> Type -> Type -> [Clause a] -> (Pattern Name -> Maybe [Pattern Name]) -> Covers (Type, [Pattern Name]) (Type, [Clause a]) +match inst hd tl heads decompose = do (prefix, canonical) <- asum (pure <$> inst) - (prefix <> ctx,) <$> forOf (traversed.patterns_) heads (\case + (foldr (:->) tl prefix,) <$> forOf (traversed.patterns_) heads (\case p:ps | Just p' <- decompose (instantiateHead canonical p) -> pure (p' <> ps) - ps -> throw (t, ps)) + ps -> throw (hd, ps)) instantiateHead :: Pattern Name -> Pattern Name -> Pattern Name From 5b936ca4c65fd2fd33fc8580b8baf34f34edccea Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Mar 2022 15:34:03 -0400 Subject: [PATCH 0869/1324] Only pass the head type to coverStep. --- src/Facet/Elab/Pattern.hs | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index f26edd8f8..c613f92a1 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -133,25 +133,25 @@ covers ty heads = runCovers (coverLoop ty heads) (&&) (const True) True (const F coverLoop :: Type -> [Clause a] -> Covers String (Type, [Clause a]) coverLoop ty heads = case ty of - hd :-> tl -> first (uncurry formatError) (coverStep hd tl heads) >>= uncurry coverLoop + hd :-> tl -> first (uncurry formatError) (coverStep hd heads) >>= \ (prefix, hd) -> coverLoop (prefix tl) hd ty -> pure (ty, heads) -- FIXME: fail if clauses aren't all empty where formatError t = \case [] -> "expected " <> show t <> ", got nothing" p:_ -> "expected " <> show t <> ", got " <> show p -coverStep :: Type -> Type -> [Clause a] -> Covers (Type, [Pattern Name]) (Type, [Clause a]) -coverStep hd tl heads = case hd of - Opaque -> match [([], Wildcard)] hd tl heads (\ p -> [] <$ matching' _Wildcard p) - One -> match [([], Unit)] hd tl heads (\ p -> [] <$ matching' _Unit p) - s :+ t -> match [([s], InL Wildcard), ([t], InR Wildcard)] hd tl heads (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) -- FIXME: match once and partition results - s :* t -> match [([s, t], Pair Wildcard Wildcard)] hd tl heads (\ p -> (\ (a, b) -> [a, b]) <$> matching' _Pair p) - _ :-> _ -> match [([], Wildcard)] hd tl heads (\ p -> [] <$ matching' _Wildcard p) +coverStep :: Type -> [Clause a] -> Covers (Type, [Pattern Name]) (Type -> Type, [Clause a]) +coverStep hd heads = case hd of + Opaque -> match [([], Wildcard)] hd heads (\ p -> [] <$ matching' _Wildcard p) + One -> match [([], Unit)] hd heads (\ p -> [] <$ matching' _Unit p) + s :+ t -> match [([s], InL Wildcard), ([t], InR Wildcard)] hd heads (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) -- FIXME: match once and partition results + s :* t -> match [([s, t], Pair Wildcard Wildcard)] hd heads (\ p -> (\ (a, b) -> [a, b]) <$> matching' _Pair p) + _ :-> _ -> match [([], Wildcard)] hd heads (\ p -> [] <$ matching' _Wildcard p) -match :: [([Type], Pattern Name)] -> Type -> Type -> [Clause a] -> (Pattern Name -> Maybe [Pattern Name]) -> Covers (Type, [Pattern Name]) (Type, [Clause a]) -match inst hd tl heads decompose = do +match :: [([Type], Pattern Name)] -> Type -> [Clause a] -> (Pattern Name -> Maybe [Pattern Name]) -> Covers (Type, [Pattern Name]) (Type -> Type, [Clause a]) +match inst hd heads decompose = do (prefix, canonical) <- asum (pure <$> inst) - (foldr (:->) tl prefix,) <$> forOf (traversed.patterns_) heads (\case + (\ tl -> foldr (:->) tl prefix,) <$> forOf (traversed.patterns_) heads (\case p:ps | Just p' <- decompose (instantiateHead canonical p) -> pure (p' <> ps) ps -> throw (hd, ps)) From 41ed093d04ecc653324500eea37af5d21b3ad6ef Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Mar 2022 15:46:42 -0400 Subject: [PATCH 0870/1324] Define coverStep in CPS. --- src/Facet/Elab/Pattern.hs | 33 +++++++++++++++------------------ 1 file changed, 15 insertions(+), 18 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index c613f92a1..8407f85a7 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -131,29 +131,26 @@ throw e = Covers (\ _ _ _ err -> err e) covers :: Type -> [Clause a] -> Bool covers ty heads = runCovers (coverLoop ty heads) (&&) (const True) True (const False) -coverLoop :: Type -> [Clause a] -> Covers String (Type, [Clause a]) +coverLoop :: Type -> [Clause a] -> Covers (Type, [Pattern Name]) (Type, [Clause a]) coverLoop ty heads = case ty of - hd :-> tl -> first (uncurry formatError) (coverStep hd heads) >>= \ (prefix, hd) -> coverLoop (prefix tl) hd + hd :-> tl -> (coverStep hd heads (\ prefix hd -> coverLoop (prefix tl) hd)) ty -> pure (ty, heads) -- FIXME: fail if clauses aren't all empty - where - formatError t = \case - [] -> "expected " <> show t <> ", got nothing" - p:_ -> "expected " <> show t <> ", got " <> show p - -coverStep :: Type -> [Clause a] -> Covers (Type, [Pattern Name]) (Type -> Type, [Clause a]) -coverStep hd heads = case hd of - Opaque -> match [([], Wildcard)] hd heads (\ p -> [] <$ matching' _Wildcard p) - One -> match [([], Unit)] hd heads (\ p -> [] <$ matching' _Unit p) - s :+ t -> match [([s], InL Wildcard), ([t], InR Wildcard)] hd heads (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) -- FIXME: match once and partition results - s :* t -> match [([s, t], Pair Wildcard Wildcard)] hd heads (\ p -> (\ (a, b) -> [a, b]) <$> matching' _Pair p) - _ :-> _ -> match [([], Wildcard)] hd heads (\ p -> [] <$ matching' _Wildcard p) - -match :: [([Type], Pattern Name)] -> Type -> [Clause a] -> (Pattern Name -> Maybe [Pattern Name]) -> Covers (Type, [Pattern Name]) (Type -> Type, [Clause a]) -match inst hd heads decompose = do + +coverStep :: Type -> [Clause a] -> ((Type -> Type) -> [Clause a] -> Covers (Type, [Pattern Name]) x) -> Covers (Type, [Pattern Name]) x +coverStep hd heads k = case hd of + Opaque -> match [([], Wildcard)] hd heads (\ p -> [] <$ matching' _Wildcard p) k + One -> match [([], Unit)] hd heads (\ p -> [] <$ matching' _Unit p) k + s :+ t -> match [([s], InL Wildcard), ([t], InR Wildcard)] hd heads (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) k -- FIXME: match once and partition results + s :* t -> match [([s, t], Pair Wildcard Wildcard)] hd heads (\ p -> (\ (a, b) -> [a, b]) <$> matching' _Pair p) k + _ :-> _ -> match [([], Wildcard)] hd heads (\ p -> [] <$ matching' _Wildcard p) k + +match :: [([Type], Pattern Name)] -> Type -> [Clause a] -> (Pattern Name -> Maybe [Pattern Name]) -> ((Type -> Type) -> [Clause a] -> Covers (Type, [Pattern Name]) x) -> Covers (Type, [Pattern Name]) x +match inst hd heads decompose k = do (prefix, canonical) <- asum (pure <$> inst) - (\ tl -> foldr (:->) tl prefix,) <$> forOf (traversed.patterns_) heads (\case + heads' <- forOf (traversed.patterns_) heads (\case p:ps | Just p' <- decompose (instantiateHead canonical p) -> pure (p' <> ps) ps -> throw (hd, ps)) + k (\ tl -> foldr (:->) tl prefix) heads' instantiateHead :: Pattern Name -> Pattern Name -> Pattern Name From ad8f8ac8017ac76230e76e24340bff6f49aa8161 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Mar 2022 15:47:11 -0400 Subject: [PATCH 0871/1324] :fire: parens. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 8407f85a7..e1ed6a2ae 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -133,7 +133,7 @@ covers ty heads = runCovers (coverLoop ty heads) (&&) (const True) True (const F coverLoop :: Type -> [Clause a] -> Covers (Type, [Pattern Name]) (Type, [Clause a]) coverLoop ty heads = case ty of - hd :-> tl -> (coverStep hd heads (\ prefix hd -> coverLoop (prefix tl) hd)) + hd :-> tl -> coverStep hd heads (\ prefix hd -> coverLoop (prefix tl) hd) ty -> pure (ty, heads) -- FIXME: fail if clauses aren't all empty coverStep :: Type -> [Clause a] -> ((Type -> Type) -> [Clause a] -> Covers (Type, [Pattern Name]) x) -> Covers (Type, [Pattern Name]) x From 9d7cd0ffc2a2bac6b7ffc2e89d744b79cfa0b5c6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Mar 2022 15:55:06 -0400 Subject: [PATCH 0872/1324] :fire: the Bifunctor instance for Covers. --- src/Facet/Elab/Pattern.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index e1ed6a2ae..66ea0153d 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -16,7 +16,6 @@ module Facet.Elab.Pattern import Control.Applicative (Alternative(..), asum) import Control.Monad (ap) -import Data.Bifunctor import Facet.Name import Fresnel.Fold import Fresnel.Lens @@ -109,9 +108,6 @@ infixr 2 \/ newtype Covers e a = Covers { runCovers :: forall r . (r -> r -> r) -> (a -> r) -> r -> (e -> r) -> r } deriving (Functor) -instance Bifunctor Covers where - bimap f g (Covers e) = Covers (\ fork leaf nil err -> e fork (leaf . g) nil (err . f)) - instance Applicative (Covers e) where pure a = Covers (\ _ leaf _ _ -> leaf a) From 6e05dc8a21515750b2e883927e0bac7baa852fe1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 19 Mar 2022 15:56:29 -0400 Subject: [PATCH 0873/1324] Specialize Covers' error type. --- src/Facet/Elab/Pattern.hs | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 66ea0153d..6f1c2665a 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -105,34 +105,34 @@ infixr 2 \/ -- Coverage judgement -newtype Covers e a = Covers { runCovers :: forall r . (r -> r -> r) -> (a -> r) -> r -> (e -> r) -> r } +newtype Covers a = Covers { runCovers :: forall r . (r -> r -> r) -> (a -> r) -> r -> (Type -> [Pattern Name] -> r) -> r } deriving (Functor) -instance Applicative (Covers e) where +instance Applicative Covers where pure a = Covers (\ _ leaf _ _ -> leaf a) (<*>) = ap -instance Alternative (Covers e) where +instance Alternative Covers where empty = Covers (\ _ _ nil _ -> nil) Covers a <|> Covers b = Covers (\ (<|>) leaf nil err -> a (<|>) leaf nil err <|> b (<|>) leaf nil err) -instance Monad (Covers e) where +instance Monad Covers where Covers m >>= k = Covers (\ fork leaf nil err -> m fork (\ a -> runCovers (k a) fork leaf nil err) nil err) -throw :: e -> Covers e a -throw e = Covers (\ _ _ _ err -> err e) +throw :: Type -> [Pattern Name] -> Covers a +throw ty ps = Covers (\ _ _ _ err -> err ty ps) covers :: Type -> [Clause a] -> Bool -covers ty heads = runCovers (coverLoop ty heads) (&&) (const True) True (const False) +covers ty heads = runCovers (coverLoop ty heads) (&&) (const True) True (const (const False)) -coverLoop :: Type -> [Clause a] -> Covers (Type, [Pattern Name]) (Type, [Clause a]) +coverLoop :: Type -> [Clause a] -> Covers (Type, [Clause a]) coverLoop ty heads = case ty of hd :-> tl -> coverStep hd heads (\ prefix hd -> coverLoop (prefix tl) hd) ty -> pure (ty, heads) -- FIXME: fail if clauses aren't all empty -coverStep :: Type -> [Clause a] -> ((Type -> Type) -> [Clause a] -> Covers (Type, [Pattern Name]) x) -> Covers (Type, [Pattern Name]) x +coverStep :: Type -> [Clause a] -> ((Type -> Type) -> [Clause a] -> Covers x) -> Covers x coverStep hd heads k = case hd of Opaque -> match [([], Wildcard)] hd heads (\ p -> [] <$ matching' _Wildcard p) k One -> match [([], Unit)] hd heads (\ p -> [] <$ matching' _Unit p) k @@ -140,12 +140,12 @@ coverStep hd heads k = case hd of s :* t -> match [([s, t], Pair Wildcard Wildcard)] hd heads (\ p -> (\ (a, b) -> [a, b]) <$> matching' _Pair p) k _ :-> _ -> match [([], Wildcard)] hd heads (\ p -> [] <$ matching' _Wildcard p) k -match :: [([Type], Pattern Name)] -> Type -> [Clause a] -> (Pattern Name -> Maybe [Pattern Name]) -> ((Type -> Type) -> [Clause a] -> Covers (Type, [Pattern Name]) x) -> Covers (Type, [Pattern Name]) x +match :: [([Type], Pattern Name)] -> Type -> [Clause a] -> (Pattern Name -> Maybe [Pattern Name]) -> ((Type -> Type) -> [Clause a] -> Covers x) -> Covers x match inst hd heads decompose k = do (prefix, canonical) <- asum (pure <$> inst) heads' <- forOf (traversed.patterns_) heads (\case p:ps | Just p' <- decompose (instantiateHead canonical p) -> pure (p' <> ps) - ps -> throw (hd, ps)) + ps -> throw hd ps) k (\ tl -> foldr (:->) tl prefix) heads' From bdf908e6df74bfc792c8bf32db51dc6d98221a3c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 20 Mar 2022 08:35:58 -0400 Subject: [PATCH 0874/1324] Sequent function rules return commands. --- src/Facet/Elab/Term.hs | 2 +- src/Facet/Sequent/Class.hs | 6 +++--- src/Facet/Sequent/Expr.hs | 6 +++--- src/Facet/Sequent/Norm.hs | 4 ++-- src/Facet/Sequent/Print.hs | 5 +---- 5 files changed, 10 insertions(+), 13 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 4068c0ab9..be594de98 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -173,7 +173,7 @@ lam cs = Check $ \ _T -> do lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Type)) -> Type <==: Elab m Term -> Type <==: Elab m Term lam1 p b = lam [(p, b)] -lamS :: (HasCallStack, Has (Throw Err) sig m, SQ.Sequent t c d, Applicative i) => (forall j . Applicative j => (i ~> j) -> (j t :@ Quantity :==> Type) -> (Type <==: Elab m (j t))) -> Type <==: Elab m (i t) +lamS :: (HasCallStack, Has (Throw Err) sig m, SQ.Sequent t c d, Applicative i) => (forall j . Applicative j => (i ~> j) -> (j (t, c) :@ Quantity :==> Type) -> (Type <==: Elab m (j d))) -> Type <==: Elab m (i t) lamS f = runC $ SQ.funRA $ \ wk v -> C $ Check $ \ _T -> do (_, q, _A, _B) <- assertTacitFunction _T check (f wk (v :@ q :==> _A) ::: _B) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index d034d521f..638c7d433 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -31,7 +31,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma -- Terms var :: Var Level -> term µR :: (coterm -> command) -> term - funR :: (term -> term) -> term + funR :: (term -> coterm -> command) -> term sumR :: RName -> term -> term prdR :: [term] -> term stringR :: Text -> term @@ -60,8 +60,8 @@ varA v = pure (pure (var v)) -> m (i t) µRA = binder µR -funRA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (i ~> j) -> j t -> m (j t)) -> m (i t) -funRA = binder funR +funRA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (i ~> j) -> j (t, c) -> m (j d)) -> m (i t) +funRA = binder (funR . curry) stringRA :: (Sequent t c d, Applicative i, Applicative m) => Text -> m (i t) stringRA = pure . pure . stringR diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index d24d2cccd..0d460b4d6 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -23,7 +23,7 @@ import Facet.Syntax data Term = Var (Var Index) | MuR Command - | FunR Term + | FunR Command | SumR RName Term | PrdR [Term] | StringR Text @@ -47,7 +47,7 @@ data Command = Term :|: Coterm instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where var v = Quoter (\ d -> Var (toIndexed d v)) µR b = MuR <$> binder (\ d' -> Quoter (\ d -> covar (toIndexed d d'))) b - funR b = FunR <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b + funR b = FunR <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) (\ t -> binder (\ d'' -> Quoter (\ d -> covar (toIndexed d d''))) (b t)) sumR = fmap . SumR prdR = fmap PrdR . sequenceA stringR = pure . StringR @@ -72,7 +72,7 @@ interpretTerm _G _D = \case Var (Free n) -> _G `index` n Var (Global n) -> C.var (Global n) MuR b -> C.µR (\ k -> interpretCommand _G (k:_D) b) - FunR b -> C.funR (\ a -> interpretTerm (a:_G) _D b) + FunR b -> C.funR (\ a k -> interpretCommand (a:_G) (k:_D) b) SumR i t -> C.sumR i (interpretTerm _G _D t) PrdR fs -> C.prdR (map (interpretTerm _G _D) fs) StringR s -> C.stringR s diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index bd2cec213..b0fe889ce 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -20,7 +20,7 @@ import Facet.Syntax data Term = Var (Var Level) | MuR (Coterm -> Command) - | FunR (Term -> Term) + | FunR (Term -> Coterm -> Command) | SumR RName Term | PrdR [Term] | StringR Text @@ -62,7 +62,7 @@ instance Quote Term X.Term where quote = \case Var v -> Quoter (\ d -> X.Var (toIndexed d v)) MuR b -> X.MuR <$> quoteBinder (Quoter (Covar . Free . getUsed)) b - FunR b -> X.FunR <$> quoteBinder (Quoter (Var . Free . getUsed)) b + FunR b -> X.FunR <$> Quoter (\ d -> runQuoter (d + 2) (quote (b (Var (Free (getUsed d))) (Covar (Free (getUsed (d + 1))))))) SumR i t -> X.SumR i <$> quote t PrdR fs -> X.PrdR <$> traverse quote fs StringR t -> pure (X.StringR t) diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index 822fc45f2..152ed98dc 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -27,7 +27,7 @@ instance Show Print where instance S.Sequent Print Print Print where var = var µR b = P.pretty "µ" <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) - funR c = P.braces (let v = nameVar in v P.<+> P.pretty "->" P.<+> c v) + funR c = P.braces (fresh (\ u -> fresh (\ v -> P.brackets (anon u <> P.comma P.<+> anon v) P.<+> P.pretty "->" P.<+> c (anon u) (anon v)))) sumR i t = P.parens (P.pretty "in" <> P.pretty i P.<+> t) prdR = P.tupled stringR = P.pretty . show @@ -57,9 +57,6 @@ var v = case v of Free l -> lower (getLevel l) Global n -> P.pretty n -nameVar :: Print -nameVar = withLevel (incrLevel . var . Free . getUsed) - commaSep :: [Print] -> Print commaSep = P.encloseSep mempty mempty (P.comma <> P.space) From c130318a990aff5f7f3a8c1ee95f4d92ab600593 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 20 Mar 2022 08:45:06 -0400 Subject: [PATCH 0875/1324] funRA provides separate terms & coterms. --- src/Facet/Elab/Term.hs | 6 +++--- src/Facet/Sequent/Class.hs | 5 +++-- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index be594de98..d1a8395ef 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -173,10 +173,10 @@ lam cs = Check $ \ _T -> do lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Type)) -> Type <==: Elab m Term -> Type <==: Elab m Term lam1 p b = lam [(p, b)] -lamS :: (HasCallStack, Has (Throw Err) sig m, SQ.Sequent t c d, Applicative i) => (forall j . Applicative j => (i ~> j) -> (j (t, c) :@ Quantity :==> Type) -> (Type <==: Elab m (j d))) -> Type <==: Elab m (i t) -lamS f = runC $ SQ.funRA $ \ wk v -> C $ Check $ \ _T -> do +lamS :: (HasCallStack, Has (Throw Err) sig m, SQ.Sequent t c d, Applicative i) => (forall j . Applicative j => (i ~> j) -> (j t :@ Quantity :==> Type) -> (j c :@ Quantity :==> Type) -> (Type <==: Elab m (j d))) -> Type <==: Elab m (i t) +lamS f = runC $ SQ.funRA $ \ wk a k -> C $ Check $ \ _T -> do (_, q, _A, _B) <- assertTacitFunction _T - check (f wk (v :@ q :==> _A) ::: _B) + check (f wk (a :@ q :==> _A) (k :@ q :==> _B) ::: _B) app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Elab m (a :==> Type)) -> (HasCallStack => Type <==: Elab m b) -> Elab m (c :==> Type) app mk operator operand = do diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 638c7d433..efee1bb87 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -60,8 +60,9 @@ varA v = pure (pure (var v)) -> m (i t) µRA = binder µR -funRA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (i ~> j) -> j (t, c) -> m (j d)) -> m (i t) -funRA = binder (funR . curry) +funRA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (i ~> j) -> j t -> j c -> m (j d)) -> m (i t) +funRA f = inner (\ wk v -> f wk (fst <$> v) (snd <$> v)) where + inner = binder (funR . curry) stringRA :: (Sequent t c d, Applicative i, Applicative m) => Text -> m (i t) stringRA = pure . pure . stringR From b869bc36fee5987457699883ed52435bd74a86ab Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 20 Mar 2022 08:48:46 -0400 Subject: [PATCH 0876/1324] Function types associate rightwards. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 6f1c2665a..b53c70a63 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -92,7 +92,7 @@ data Type infixl 6 :+ infixl 7 :* -infixl 1 :-> +infixr 1 :-> data Branch s m a = forall x . Branch (Fold s x) (x -> m a) From 1076d217128002facd9976e8983c90f45ccb5546 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 20 Mar 2022 15:58:42 -0400 Subject: [PATCH 0877/1324] Lift funLA uniformly. --- src/Facet/Sequent/Class.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index efee1bb87..0afd4511f 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -82,7 +82,7 @@ funLA => m (i t) -> m (i c) -> m (i c) -funLA f a = liftA2 funL <$> f <*> a +funLA = liftA2 (liftA2 funL) sumLA :: (Sequent t c d, Applicative i, Applicative m) From 70e342b1f857dd7a64600c20b04ad7c21e692fb4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 20 Mar 2022 16:01:08 -0400 Subject: [PATCH 0878/1324] Rename fun* to lam*. --- src/Facet/Elab/Term.hs | 6 +++--- src/Facet/Sequent/Class.hs | 18 +++++++++--------- src/Facet/Sequent/Expr.hs | 12 ++++++------ src/Facet/Sequent/Norm.hs | 12 ++++++------ src/Facet/Sequent/Print.hs | 4 ++-- 5 files changed, 26 insertions(+), 26 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index d1a8395ef..ed21fa660 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -174,7 +174,7 @@ lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Type lam1 p b = lam [(p, b)] lamS :: (HasCallStack, Has (Throw Err) sig m, SQ.Sequent t c d, Applicative i) => (forall j . Applicative j => (i ~> j) -> (j t :@ Quantity :==> Type) -> (j c :@ Quantity :==> Type) -> (Type <==: Elab m (j d))) -> Type <==: Elab m (i t) -lamS f = runC $ SQ.funRA $ \ wk a k -> C $ Check $ \ _T -> do +lamS f = runC $ SQ.lamRA $ \ wk a k -> C $ Check $ \ _T -> do (_, q, _A, _B) <- assertTacitFunction _T check (f wk (a :@ q :==> _A) (k :@ q :==> _B) ::: _B) @@ -190,7 +190,7 @@ appS f a = do f' :==> _F <- f (_, q, _A, _B) <- assertFunction _F a' <- censor @Usage (q ><<) $ check (a ::: _A) - (:==> _B) <$> SQ.µRA (\ wk k -> pure (wk f') SQ..||. SQ.funLA (pure (wk a')) (pure k)) + (:==> _B) <$> SQ.µRA (\ wk k -> pure (wk f') SQ..||. SQ.lamLA (pure (wk a')) (pure k)) string :: Text -> Elab m (Term :==> Type) @@ -490,7 +490,7 @@ letrec getter key projection initial final = do assertQuantifier :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Name, Kind, Type -> Type) assertQuantifier = assertMatch _ForAll "{_} -> _" --- | Expect a tacit (non-variable-binding) function type. +-- | Expect a tacit (non-variable-binding) lamction type. assertTacitFunction :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Maybe Name, Quantity, Type, Type) assertTacitFunction = assertMatch _Arrow "_ -> _" diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 0afd4511f..b4e36343d 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -6,11 +6,11 @@ module Facet.Sequent.Class , varA , µRA , C.Clause(..) -, funRA +, lamRA , stringRA , covarA , µLA -, funLA +, lamLA , sumLA , prdLA , (.||.) @@ -31,7 +31,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma -- Terms var :: Var Level -> term µR :: (coterm -> command) -> term - funR :: (term -> coterm -> command) -> term + lamR :: (term -> coterm -> command) -> term sumR :: RName -> term -> term prdR :: [term] -> term stringR :: Text -> term @@ -39,7 +39,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma -- Coterms covar :: Var Level -> coterm µL :: (term -> command) -> coterm - funL :: term -> coterm -> coterm + lamL :: term -> coterm -> coterm sumL :: [term -> command] -> coterm prdL :: Int -> ([term] -> command) -> coterm @@ -60,9 +60,9 @@ varA v = pure (pure (var v)) -> m (i t) µRA = binder µR -funRA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (i ~> j) -> j t -> j c -> m (j d)) -> m (i t) -funRA f = inner (\ wk v -> f wk (fst <$> v) (snd <$> v)) where - inner = binder (funR . curry) +lamRA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (i ~> j) -> j t -> j c -> m (j d)) -> m (i t) +lamRA f = inner (\ wk v -> f wk (fst <$> v) (snd <$> v)) where + inner = binder (lamR . curry) stringRA :: (Sequent t c d, Applicative i, Applicative m) => Text -> m (i t) stringRA = pure . pure . stringR @@ -77,12 +77,12 @@ covarA v = pure (pure (covar v)) -> m (i c) µLA = binder µL -funLA +lamLA :: (Sequent t c d, Applicative i, Applicative m) => m (i t) -> m (i c) -> m (i c) -funLA = liftA2 (liftA2 funL) +lamLA = liftA2 (liftA2 lamL) sumLA :: (Sequent t c d, Applicative i, Applicative m) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 0d460b4d6..b7dd822a8 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -23,7 +23,7 @@ import Facet.Syntax data Term = Var (Var Index) | MuR Command - | FunR Command + | LamR Command | SumR RName Term | PrdR [Term] | StringR Text @@ -34,7 +34,7 @@ data Term data Coterm = Covar (Var Index) | MuL Command - | FunL Term Coterm + | LamL Term Coterm | SumL [Command] | PrdL Int Command @@ -47,14 +47,14 @@ data Command = Term :|: Coterm instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where var v = Quoter (\ d -> Var (toIndexed d v)) µR b = MuR <$> binder (\ d' -> Quoter (\ d -> covar (toIndexed d d'))) b - funR b = FunR <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) (\ t -> binder (\ d'' -> Quoter (\ d -> covar (toIndexed d d''))) (b t)) + lamR b = LamR <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) (\ t -> binder (\ d'' -> Quoter (\ d -> covar (toIndexed d d''))) (b t)) sumR = fmap . SumR prdR = fmap PrdR . sequenceA stringR = pure . StringR covar v = Quoter (\ d -> Covar (toIndexed d v)) µL b = MuL <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b - funL a b = FunL <$> a <*> b + lamL a b = LamL <$> a <*> b sumL = fmap SumL . traverse (binder (\ d' -> Quoter (\ d -> var (toIndexed d d')))) prdL i b = PrdL i <$> binderN i (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b @@ -72,7 +72,7 @@ interpretTerm _G _D = \case Var (Free n) -> _G `index` n Var (Global n) -> C.var (Global n) MuR b -> C.µR (\ k -> interpretCommand _G (k:_D) b) - FunR b -> C.funR (\ a k -> interpretCommand (a:_G) (k:_D) b) + LamR b -> C.lamR (\ a k -> interpretCommand (a:_G) (k:_D) b) SumR i t -> C.sumR i (interpretTerm _G _D t) PrdR fs -> C.prdR (map (interpretTerm _G _D) fs) StringR s -> C.stringR s @@ -82,7 +82,7 @@ interpretCoterm _G _D = \case Covar (Free n) -> _D `index` n Covar (Global n) -> C.covar (Global n) MuL b -> C.µL (\ t -> interpretCommand (t:_G) _D b) - FunL a k -> C.funL (interpretTerm _G _D a) (interpretCoterm _G _D k) + LamL a k -> C.lamL (interpretTerm _G _D a) (interpretCoterm _G _D k) SumL cs -> C.sumL (map (\ d t -> interpretCommand (t:_G) _D d) cs) PrdL i c -> C.prdL i (\ cs -> interpretCommand (foldl (flip (:)) _G cs) _D c) diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index b0fe889ce..c8b6c5e28 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -20,7 +20,7 @@ import Facet.Syntax data Term = Var (Var Level) | MuR (Coterm -> Command) - | FunR (Term -> Coterm -> Command) + | LamR (Term -> Coterm -> Command) | SumR RName Term | PrdR [Term] | StringR Text @@ -31,7 +31,7 @@ data Term data Coterm = Covar (Var Level) | MuL (Term -> Command) - | FunL Term Coterm + | LamL Term Coterm | SumL [Term -> Command] | PrdL Int ([Term] -> Command) @@ -44,14 +44,14 @@ data Command = Term :|: Coterm instance Class.Sequent Term Coterm Command where var = Var µR = MuR - funR = FunR + lamR = LamR sumR = SumR prdR = PrdR stringR = StringR covar = Covar µL = MuL - funL = FunL + lamL = LamL sumL = SumL prdL = PrdL @@ -62,7 +62,7 @@ instance Quote Term X.Term where quote = \case Var v -> Quoter (\ d -> X.Var (toIndexed d v)) MuR b -> X.MuR <$> quoteBinder (Quoter (Covar . Free . getUsed)) b - FunR b -> X.FunR <$> Quoter (\ d -> runQuoter (d + 2) (quote (b (Var (Free (getUsed d))) (Covar (Free (getUsed (d + 1))))))) + LamR b -> X.LamR <$> Quoter (\ d -> runQuoter (d + 2) (quote (b (Var (Free (getUsed d))) (Covar (Free (getUsed (d + 1))))))) SumR i t -> X.SumR i <$> quote t PrdR fs -> X.PrdR <$> traverse quote fs StringR t -> pure (X.StringR t) @@ -75,7 +75,7 @@ instance Quote Coterm X.Coterm where quote = \case Covar v -> Quoter (\ d -> X.Covar (toIndexed d v)) MuL b -> X.MuL <$> quoteBinder (Quoter var) b - FunL a b -> liftA2 X.FunL (quote a) (quote b) + LamL a b -> liftA2 X.LamL (quote a) (quote b) SumL cs -> X.SumL <$> traverse (quoteBinder (Quoter var)) cs PrdL n k -> X.PrdL n <$> quoteBinder (Quoter (\ d -> map (var . (d +) . fromIntegral) [0..n])) k diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index 152ed98dc..c582d34b3 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -27,14 +27,14 @@ instance Show Print where instance S.Sequent Print Print Print where var = var µR b = P.pretty "µ" <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) - funR c = P.braces (fresh (\ u -> fresh (\ v -> P.brackets (anon u <> P.comma P.<+> anon v) P.<+> P.pretty "->" P.<+> c (anon u) (anon v)))) + lamR c = P.braces (fresh (\ u -> fresh (\ v -> P.brackets (anon u <> P.comma P.<+> anon v) P.<+> P.pretty "->" P.<+> c (anon u) (anon v)))) sumR i t = P.parens (P.pretty "in" <> P.pretty i P.<+> t) prdR = P.tupled stringR = P.pretty . show covar = var µL b = µ̃ <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) - funL a k = a P.<+> P.dot P.<+> k + lamL a k = a P.<+> P.dot P.<+> k sumL cs = µ̃ <> P.braces (commaSep (map (\ c -> fresh (\ v -> anon v P.<+> P.dot P.<+> c (anon v))) cs)) prdL i k = P.parens (µ̃ <> withLevel (\ d -> k (map (\ i -> anon (d + fromIntegral i)) [0..i]))) From 6d9fc8f382354a5ebd08a413c04dd407f8958c99 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 20 Mar 2022 23:24:39 -0400 Subject: [PATCH 0879/1324] Define an infix synonym for application. --- src/Facet/Sequent/Class.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index b4e36343d..03198df79 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -2,6 +2,7 @@ module Facet.Sequent.Class ( -- * Sequent abstraction Sequent(..) +, (.$.) -- * Effectful abstractions , varA , µRA @@ -48,6 +49,11 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma infix 1 .|. +(.$.) :: Sequent term coterm command => term -> coterm -> coterm +(.$.) = lamL + +infixr 9 .$. + -- * Effectful abstractions From a08d52b72eaf4ead0d7344d7c0834fb2140179bf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 20 Mar 2022 23:25:37 -0400 Subject: [PATCH 0880/1324] Define an infix synonym for lifted application. --- src/Facet/Sequent/Class.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 03198df79..4fb66a9de 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -8,6 +8,7 @@ module Facet.Sequent.Class , µRA , C.Clause(..) , lamRA +, (.$$.) , stringRA , covarA , µLA @@ -90,6 +91,15 @@ lamLA -> m (i c) lamLA = liftA2 (liftA2 lamL) +(.$$.) + :: (Sequent t c d, Applicative i, Applicative m) + => m (i t) + -> m (i c) + -> m (i c) +(.$$.) = lamLA + +infixr 9 .$$. + sumLA :: (Sequent t c d, Applicative i, Applicative m) => [C.Clause m i t d] From 914b1eaee98553d16fac8b7e8bbf5d3db579f37b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 20 Mar 2022 23:30:20 -0400 Subject: [PATCH 0881/1324] Tacit. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index b53c70a63..bae265808 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -129,7 +129,7 @@ covers ty heads = runCovers (coverLoop ty heads) (&&) (const True) True (const ( coverLoop :: Type -> [Clause a] -> Covers (Type, [Clause a]) coverLoop ty heads = case ty of - hd :-> tl -> coverStep hd heads (\ prefix hd -> coverLoop (prefix tl) hd) + hd :-> tl -> coverStep hd heads (\ prefix -> coverLoop (prefix tl)) ty -> pure (ty, heads) -- FIXME: fail if clauses aren't all empty coverStep :: Type -> [Clause a] -> ((Type -> Type) -> [Clause a] -> Covers x) -> Covers x From 74e4d12b5b95c175d862568f6b056a55332efa36 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 21 Mar 2022 08:05:19 -0400 Subject: [PATCH 0882/1324] Replace n-ary sums with binary ones, for now. --- src/Facet/Sequent/Class.hs | 18 +++++++++++++----- src/Facet/Sequent/Expr.hs | 15 +++++++++------ src/Facet/Sequent/Norm.hs | 13 ++++++++----- src/Facet/Sequent/Print.hs | 5 +++-- 4 files changed, 33 insertions(+), 18 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 4fb66a9de..2a2608428 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -24,7 +24,7 @@ module Facet.Sequent.Class import Control.Applicative (liftA2) import Data.Text (Text) import Facet.Functor.Compose as C -import Facet.Name (Level, RName) +import Facet.Name (Level) import Facet.Syntax (Var, type (~>)) -- * Term abstraction @@ -34,7 +34,8 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma var :: Var Level -> term µR :: (coterm -> command) -> term lamR :: (term -> coterm -> command) -> term - sumR :: RName -> term -> term + sumR1 :: term -> term + sumR2 :: term -> term prdR :: [term] -> term stringR :: Text -> term @@ -42,7 +43,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma covar :: Var Level -> coterm µL :: (term -> command) -> coterm lamL :: term -> coterm -> coterm - sumL :: [term -> command] -> coterm + sumL :: (term -> command) -> (term -> command) -> coterm prdL :: Int -> ([term] -> command) -> coterm -- Commands @@ -102,9 +103,16 @@ infixr 9 .$$. sumLA :: (Sequent t c d, Applicative i, Applicative m) - => [C.Clause m i t d] + => (forall j . Applicative j => (i ~> j) -> j t -> m (j d)) + -> (forall j . Applicative j => (i ~> j) -> j t -> m (j d)) -> m (i c) -sumLA cs = runC (sumL <$> traverse (\ (C.Clause c) -> C (binder id c)) cs) +sumLA l r = liftA2 sumL <$> binder id l <*> binder id r + +-- sumLA +-- :: (Sequent t c d, Applicative i, Applicative m) +-- => [C.Clause m i t d] +-- -> m (i c) +-- sumLA cs = runC (sumL <$> traverse (\ (C.Clause c) -> C (binder id c)) cs) prdLA :: (Sequent t c d, Applicative i, Applicative m) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index b7dd822a8..d9e4234ec 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -24,7 +24,8 @@ data Term = Var (Var Index) | MuR Command | LamR Command - | SumR RName Term + | SumR1 Term + | SumR2 Term | PrdR [Term] | StringR Text @@ -35,7 +36,7 @@ data Coterm = Covar (Var Index) | MuL Command | LamL Term Coterm - | SumL [Command] + | SumL Command Command | PrdL Int Command @@ -48,14 +49,15 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where var v = Quoter (\ d -> Var (toIndexed d v)) µR b = MuR <$> binder (\ d' -> Quoter (\ d -> covar (toIndexed d d'))) b lamR b = LamR <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) (\ t -> binder (\ d'' -> Quoter (\ d -> covar (toIndexed d d''))) (b t)) - sumR = fmap . SumR + sumR1 = fmap SumR1 + sumR2 = fmap SumR2 prdR = fmap PrdR . sequenceA stringR = pure . StringR covar v = Quoter (\ d -> Covar (toIndexed d v)) µL b = MuL <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b lamL a b = LamL <$> a <*> b - sumL = fmap SumL . traverse (binder (\ d' -> Quoter (\ d -> var (toIndexed d d')))) + sumL l r = SumL <$> go l <*> go r where go = binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) prdL i b = PrdL i <$> binderN i (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b (.|.) = liftA2 (:|:) @@ -73,7 +75,8 @@ interpretTerm _G _D = \case Var (Global n) -> C.var (Global n) MuR b -> C.µR (\ k -> interpretCommand _G (k:_D) b) LamR b -> C.lamR (\ a k -> interpretCommand (a:_G) (k:_D) b) - SumR i t -> C.sumR i (interpretTerm _G _D t) + SumR1 t -> C.sumR1 (interpretTerm _G _D t) + SumR2 t -> C.sumR2 (interpretTerm _G _D t) PrdR fs -> C.prdR (map (interpretTerm _G _D) fs) StringR s -> C.stringR s @@ -83,7 +86,7 @@ interpretCoterm _G _D = \case Covar (Global n) -> C.covar (Global n) MuL b -> C.µL (\ t -> interpretCommand (t:_G) _D b) LamL a k -> C.lamL (interpretTerm _G _D a) (interpretCoterm _G _D k) - SumL cs -> C.sumL (map (\ d t -> interpretCommand (t:_G) _D d) cs) + SumL l r -> C.sumL (go l) (go r) where go d t =interpretCommand (t:_G) _D d PrdL i c -> C.prdL i (\ cs -> interpretCommand (foldl (flip (:)) _G cs) _D c) interpretCommand :: C.Sequent t c d => [t] -> [c] -> Command -> d diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index c8b6c5e28..5f49b6edb 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -21,7 +21,8 @@ data Term = Var (Var Level) | MuR (Coterm -> Command) | LamR (Term -> Coterm -> Command) - | SumR RName Term + | SumR1 Term + | SumR2 Term | PrdR [Term] | StringR Text @@ -32,7 +33,7 @@ data Coterm = Covar (Var Level) | MuL (Term -> Command) | LamL Term Coterm - | SumL [Term -> Command] + | SumL (Term -> Command) (Term -> Command) | PrdL Int ([Term] -> Command) @@ -45,7 +46,8 @@ instance Class.Sequent Term Coterm Command where var = Var µR = MuR lamR = LamR - sumR = SumR + sumR1 = SumR1 + sumR2 = SumR2 prdR = PrdR stringR = StringR @@ -63,7 +65,8 @@ instance Quote Term X.Term where Var v -> Quoter (\ d -> X.Var (toIndexed d v)) MuR b -> X.MuR <$> quoteBinder (Quoter (Covar . Free . getUsed)) b LamR b -> X.LamR <$> Quoter (\ d -> runQuoter (d + 2) (quote (b (Var (Free (getUsed d))) (Covar (Free (getUsed (d + 1))))))) - SumR i t -> X.SumR i <$> quote t + SumR1 t -> X.SumR1 <$> quote t + SumR2 t -> X.SumR2 <$> quote t PrdR fs -> X.PrdR <$> traverse quote fs StringR t -> pure (X.StringR t) @@ -76,7 +79,7 @@ instance Quote Coterm X.Coterm where Covar v -> Quoter (\ d -> X.Covar (toIndexed d v)) MuL b -> X.MuL <$> quoteBinder (Quoter var) b LamL a b -> liftA2 X.LamL (quote a) (quote b) - SumL cs -> X.SumL <$> traverse (quoteBinder (Quoter var)) cs + SumL l r -> X.SumL <$> quoteBinder (Quoter var) l <*> quoteBinder (Quoter var) r PrdL n k -> X.PrdL n <$> quoteBinder (Quoter (\ d -> map (var . (d +) . fromIntegral) [0..n])) k diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index c582d34b3..31050a832 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -28,14 +28,15 @@ instance S.Sequent Print Print Print where var = var µR b = P.pretty "µ" <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) lamR c = P.braces (fresh (\ u -> fresh (\ v -> P.brackets (anon u <> P.comma P.<+> anon v) P.<+> P.pretty "->" P.<+> c (anon u) (anon v)))) - sumR i t = P.parens (P.pretty "in" <> P.pretty i P.<+> t) + sumR1 t = P.parens (P.pretty "inl" P.<+> t) + sumR2 t = P.parens (P.pretty "inr" P.<+> t) prdR = P.tupled stringR = P.pretty . show covar = var µL b = µ̃ <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) lamL a k = a P.<+> P.dot P.<+> k - sumL cs = µ̃ <> P.braces (commaSep (map (\ c -> fresh (\ v -> anon v P.<+> P.dot P.<+> c (anon v))) cs)) + sumL l r = µ̃ <> P.braces (commaSep [go l, go r]) where go c = fresh (\ v -> anon v P.<+> P.dot P.<+> c (anon v)) prdL i k = P.parens (µ̃ <> withLevel (\ d -> k (map (\ i -> anon (d + fromIntegral i)) [0..i]))) (.|.) = fmap (P.enclose P.langle P.rangle) . P.surround P.pipe From 0f36ec8882426db63c2a18f10bc01e2eb95b83bc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 21 Mar 2022 08:15:00 -0400 Subject: [PATCH 0883/1324] Replace n-ary products with binary ones, for now. --- src/Facet/Sequent/Class.hs | 21 ++++++++++++++------- src/Facet/Sequent/Expr.hs | 15 +++++++++------ src/Facet/Sequent/Norm.hs | 13 ++++++++----- src/Facet/Sequent/Print.hs | 5 +++-- 4 files changed, 34 insertions(+), 20 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 2a2608428..bc3f6a7a2 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -14,7 +14,8 @@ module Facet.Sequent.Class , µLA , lamLA , sumLA -, prdLA +, prdL1A +, prdL2A , (.||.) -- , Ctx(..) -- , Binding(..) @@ -36,7 +37,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma lamR :: (term -> coterm -> command) -> term sumR1 :: term -> term sumR2 :: term -> term - prdR :: [term] -> term + prdR :: term -> term -> term stringR :: Text -> term -- Coterms @@ -44,7 +45,8 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma µL :: (term -> command) -> coterm lamL :: term -> coterm -> coterm sumL :: (term -> command) -> (term -> command) -> coterm - prdL :: Int -> ([term] -> command) -> coterm + prdL1 :: (term -> command) -> coterm + prdL2 :: (term -> command) -> coterm -- Commands (.|.) :: term -> coterm -> command @@ -114,12 +116,17 @@ sumLA l r = liftA2 sumL <$> binder id l <*> binder id r -- -> m (i c) -- sumLA cs = runC (sumL <$> traverse (\ (C.Clause c) -> C (binder id c)) cs) -prdLA +prdL1A :: (Sequent t c d, Applicative i, Applicative m) - => Int - -> (forall j . Applicative j => (i ~> j) -> j [t] -> m (j d)) + => (forall j . Applicative j => (i ~> j) -> j t -> m (j d)) + -> m (i c) +prdL1A = binder prdL1 + +prdL2A + :: (Sequent t c d, Applicative i, Applicative m) + => (forall j . Applicative j => (i ~> j) -> j t -> m (j d)) -> m (i c) -prdLA i = binder (prdL i) +prdL2A = binder prdL2 (.||.) :: (Applicative m, Applicative i, Sequent t c d) => m (i t) -> m (i c) -> m (i d) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index d9e4234ec..2757fd2e6 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -26,7 +26,7 @@ data Term | LamR Command | SumR1 Term | SumR2 Term - | PrdR [Term] + | PrdR Term Term | StringR Text @@ -37,7 +37,8 @@ data Coterm | MuL Command | LamL Term Coterm | SumL Command Command - | PrdL Int Command + | PrdL1 Command + | PrdL2 Command -- Commands @@ -51,14 +52,15 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where lamR b = LamR <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) (\ t -> binder (\ d'' -> Quoter (\ d -> covar (toIndexed d d''))) (b t)) sumR1 = fmap SumR1 sumR2 = fmap SumR2 - prdR = fmap PrdR . sequenceA + prdR l r = PrdR <$> l <*> r stringR = pure . StringR covar v = Quoter (\ d -> Covar (toIndexed d v)) µL b = MuL <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b lamL a b = LamL <$> a <*> b sumL l r = SumL <$> go l <*> go r where go = binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) - prdL i b = PrdL i <$> binderN i (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b + prdL1 b = PrdL1 <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b + prdL2 b = PrdL2 <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b (.|.) = liftA2 (:|:) @@ -77,7 +79,7 @@ interpretTerm _G _D = \case LamR b -> C.lamR (\ a k -> interpretCommand (a:_G) (k:_D) b) SumR1 t -> C.sumR1 (interpretTerm _G _D t) SumR2 t -> C.sumR2 (interpretTerm _G _D t) - PrdR fs -> C.prdR (map (interpretTerm _G _D) fs) + PrdR l r -> C.prdR (interpretTerm _G _D l) (interpretTerm _G _D r) StringR s -> C.stringR s interpretCoterm :: C.Sequent t c d => [t] -> [c] -> Coterm -> c @@ -87,7 +89,8 @@ interpretCoterm _G _D = \case MuL b -> C.µL (\ t -> interpretCommand (t:_G) _D b) LamL a k -> C.lamL (interpretTerm _G _D a) (interpretCoterm _G _D k) SumL l r -> C.sumL (go l) (go r) where go d t =interpretCommand (t:_G) _D d - PrdL i c -> C.prdL i (\ cs -> interpretCommand (foldl (flip (:)) _G cs) _D c) + PrdL1 c -> C.prdL1 (\ t -> interpretCommand (t:_G) _D c) + PrdL2 c -> C.prdL2 (\ t -> interpretCommand (t:_G) _D c) interpretCommand :: C.Sequent t c d => [t] -> [c] -> Command -> d interpretCommand _G _D (t :|: c) = interpretTerm _G _D t C..|. interpretCoterm _G _D c diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index 5f49b6edb..b1623ed9e 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -23,7 +23,7 @@ data Term | LamR (Term -> Coterm -> Command) | SumR1 Term | SumR2 Term - | PrdR [Term] + | PrdR Term Term | StringR Text @@ -34,7 +34,8 @@ data Coterm | MuL (Term -> Command) | LamL Term Coterm | SumL (Term -> Command) (Term -> Command) - | PrdL Int ([Term] -> Command) + | PrdL1 (Term -> Command) + | PrdL2 (Term -> Command) -- Commands @@ -55,7 +56,8 @@ instance Class.Sequent Term Coterm Command where µL = MuL lamL = LamL sumL = SumL - prdL = PrdL + prdL1 = PrdL1 + prdL2 = PrdL2 (.|.) = (:|:) @@ -67,7 +69,7 @@ instance Quote Term X.Term where LamR b -> X.LamR <$> Quoter (\ d -> runQuoter (d + 2) (quote (b (Var (Free (getUsed d))) (Covar (Free (getUsed (d + 1))))))) SumR1 t -> X.SumR1 <$> quote t SumR2 t -> X.SumR2 <$> quote t - PrdR fs -> X.PrdR <$> traverse quote fs + PrdR l r -> X.PrdR <$> quote l <*> quote r StringR t -> pure (X.StringR t) var :: Used -> Term @@ -80,7 +82,8 @@ instance Quote Coterm X.Coterm where MuL b -> X.MuL <$> quoteBinder (Quoter var) b LamL a b -> liftA2 X.LamL (quote a) (quote b) SumL l r -> X.SumL <$> quoteBinder (Quoter var) l <*> quoteBinder (Quoter var) r - PrdL n k -> X.PrdL n <$> quoteBinder (Quoter (\ d -> map (var . (d +) . fromIntegral) [0..n])) k + PrdL1 k -> X.PrdL1 <$> quoteBinder (Quoter var) k + PrdL2 k -> X.PrdL2 <$> quoteBinder (Quoter var) k instance Quote Command X.Command where diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index 31050a832..d8b99cc59 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -30,14 +30,15 @@ instance S.Sequent Print Print Print where lamR c = P.braces (fresh (\ u -> fresh (\ v -> P.brackets (anon u <> P.comma P.<+> anon v) P.<+> P.pretty "->" P.<+> c (anon u) (anon v)))) sumR1 t = P.parens (P.pretty "inl" P.<+> t) sumR2 t = P.parens (P.pretty "inr" P.<+> t) - prdR = P.tupled + prdR l r = P.tupled [l, r] stringR = P.pretty . show covar = var µL b = µ̃ <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) lamL a k = a P.<+> P.dot P.<+> k sumL l r = µ̃ <> P.braces (commaSep [go l, go r]) where go c = fresh (\ v -> anon v P.<+> P.dot P.<+> c (anon v)) - prdL i k = P.parens (µ̃ <> withLevel (\ d -> k (map (\ i -> anon (d + fromIntegral i)) [0..i]))) + prdL1 k = P.parens (µ̃ <> P.braces (P.pretty "πl" P.<+> fresh (\ v -> anon v P.<+> P.dot P.<+> k (anon v)))) + prdL2 k = P.parens (µ̃ <> P.braces (P.pretty "πr" P.<+> fresh (\ v -> anon v P.<+> P.dot P.<+> k (anon v)))) (.|.) = fmap (P.enclose P.langle P.rangle) . P.surround P.pipe From 4de26a5e21b66aca46d4c4f768f955ba88ba207d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 21 Mar 2022 08:15:11 -0400 Subject: [PATCH 0884/1324] Spacing. --- src/Facet/Sequent/Expr.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 2757fd2e6..b76fb1f95 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -88,7 +88,7 @@ interpretCoterm _G _D = \case Covar (Global n) -> C.covar (Global n) MuL b -> C.µL (\ t -> interpretCommand (t:_G) _D b) LamL a k -> C.lamL (interpretTerm _G _D a) (interpretCoterm _G _D k) - SumL l r -> C.sumL (go l) (go r) where go d t =interpretCommand (t:_G) _D d + SumL l r -> C.sumL (go l) (go r) where go d t = interpretCommand (t:_G) _D d PrdL1 c -> C.prdL1 (\ t -> interpretCommand (t:_G) _D c) PrdL2 c -> C.prdL2 (\ t -> interpretCommand (t:_G) _D c) From b38e4d450f5c8fc86a0d15d372e2e8157fea2081 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 21 Mar 2022 09:12:41 -0400 Subject: [PATCH 0885/1324] Pass coterms to the left product rules. --- src/Facet/Sequent/Class.hs | 12 ++++++------ src/Facet/Sequent/Expr.hs | 12 ++++++------ src/Facet/Sequent/Norm.hs | 8 ++++---- src/Facet/Sequent/Print.hs | 4 ++-- 4 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index bc3f6a7a2..dc1605a74 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -45,8 +45,8 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma µL :: (term -> command) -> coterm lamL :: term -> coterm -> coterm sumL :: (term -> command) -> (term -> command) -> coterm - prdL1 :: (term -> command) -> coterm - prdL2 :: (term -> command) -> coterm + prdL1 :: coterm -> coterm + prdL2 :: coterm -> coterm -- Commands (.|.) :: term -> coterm -> command @@ -118,15 +118,15 @@ sumLA l r = liftA2 sumL <$> binder id l <*> binder id r prdL1A :: (Sequent t c d, Applicative i, Applicative m) - => (forall j . Applicative j => (i ~> j) -> j t -> m (j d)) + => m (i c) -> m (i c) -prdL1A = binder prdL1 +prdL1A = fmap (fmap prdL1) prdL2A :: (Sequent t c d, Applicative i, Applicative m) - => (forall j . Applicative j => (i ~> j) -> j t -> m (j d)) + => m (i c) -> m (i c) -prdL2A = binder prdL2 +prdL2A = fmap (fmap prdL2) (.||.) :: (Applicative m, Applicative i, Sequent t c d) => m (i t) -> m (i c) -> m (i d) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index b76fb1f95..0c8ed95d5 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -37,8 +37,8 @@ data Coterm | MuL Command | LamL Term Coterm | SumL Command Command - | PrdL1 Command - | PrdL2 Command + | PrdL1 Coterm + | PrdL2 Coterm -- Commands @@ -59,8 +59,8 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where µL b = MuL <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b lamL a b = LamL <$> a <*> b sumL l r = SumL <$> go l <*> go r where go = binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) - prdL1 b = PrdL1 <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b - prdL2 b = PrdL2 <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b + prdL1 b = PrdL1 <$> b + prdL2 b = PrdL2 <$> b (.|.) = liftA2 (:|:) @@ -89,8 +89,8 @@ interpretCoterm _G _D = \case MuL b -> C.µL (\ t -> interpretCommand (t:_G) _D b) LamL a k -> C.lamL (interpretTerm _G _D a) (interpretCoterm _G _D k) SumL l r -> C.sumL (go l) (go r) where go d t = interpretCommand (t:_G) _D d - PrdL1 c -> C.prdL1 (\ t -> interpretCommand (t:_G) _D c) - PrdL2 c -> C.prdL2 (\ t -> interpretCommand (t:_G) _D c) + PrdL1 c -> C.prdL1 (interpretCoterm _G _D c) + PrdL2 c -> C.prdL2 (interpretCoterm _G _D c) interpretCommand :: C.Sequent t c d => [t] -> [c] -> Command -> d interpretCommand _G _D (t :|: c) = interpretTerm _G _D t C..|. interpretCoterm _G _D c diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index b1623ed9e..950c70a08 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -34,8 +34,8 @@ data Coterm | MuL (Term -> Command) | LamL Term Coterm | SumL (Term -> Command) (Term -> Command) - | PrdL1 (Term -> Command) - | PrdL2 (Term -> Command) + | PrdL1 Coterm + | PrdL2 Coterm -- Commands @@ -82,8 +82,8 @@ instance Quote Coterm X.Coterm where MuL b -> X.MuL <$> quoteBinder (Quoter var) b LamL a b -> liftA2 X.LamL (quote a) (quote b) SumL l r -> X.SumL <$> quoteBinder (Quoter var) l <*> quoteBinder (Quoter var) r - PrdL1 k -> X.PrdL1 <$> quoteBinder (Quoter var) k - PrdL2 k -> X.PrdL2 <$> quoteBinder (Quoter var) k + PrdL1 k -> X.PrdL1 <$> quote k + PrdL2 k -> X.PrdL2 <$> quote k instance Quote Command X.Command where diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index d8b99cc59..db353b548 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -37,8 +37,8 @@ instance S.Sequent Print Print Print where µL b = µ̃ <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) lamL a k = a P.<+> P.dot P.<+> k sumL l r = µ̃ <> P.braces (commaSep [go l, go r]) where go c = fresh (\ v -> anon v P.<+> P.dot P.<+> c (anon v)) - prdL1 k = P.parens (µ̃ <> P.braces (P.pretty "πl" P.<+> fresh (\ v -> anon v P.<+> P.dot P.<+> k (anon v)))) - prdL2 k = P.parens (µ̃ <> P.braces (P.pretty "πr" P.<+> fresh (\ v -> anon v P.<+> P.dot P.<+> k (anon v)))) + prdL1 k = P.parens (µ̃ <> P.braces (P.pretty "πl" P.<+> k)) + prdL2 k = P.parens (µ̃ <> P.braces (P.pretty "πr" P.<+> k)) (.|.) = fmap (P.enclose P.langle P.rangle) . P.surround P.pipe From 5eb591005762b478487f2a59033c3cdb9579bfd5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 21 Mar 2022 09:14:57 -0400 Subject: [PATCH 0886/1324] Pass coterms to the left sum rule. --- src/Facet/Sequent/Class.hs | 8 ++++---- src/Facet/Sequent/Expr.hs | 6 +++--- src/Facet/Sequent/Norm.hs | 4 ++-- src/Facet/Sequent/Print.hs | 2 +- 4 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index dc1605a74..e0cbe33d4 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -44,7 +44,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma covar :: Var Level -> coterm µL :: (term -> command) -> coterm lamL :: term -> coterm -> coterm - sumL :: (term -> command) -> (term -> command) -> coterm + sumL :: coterm -> coterm -> coterm prdL1 :: coterm -> coterm prdL2 :: coterm -> coterm @@ -105,10 +105,10 @@ infixr 9 .$$. sumLA :: (Sequent t c d, Applicative i, Applicative m) - => (forall j . Applicative j => (i ~> j) -> j t -> m (j d)) - -> (forall j . Applicative j => (i ~> j) -> j t -> m (j d)) + => m (i c) + -> m (i c) -> m (i c) -sumLA l r = liftA2 sumL <$> binder id l <*> binder id r +sumLA l r = liftA2 sumL <$> l <*> r -- sumLA -- :: (Sequent t c d, Applicative i, Applicative m) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 0c8ed95d5..747ea5936 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -36,7 +36,7 @@ data Coterm = Covar (Var Index) | MuL Command | LamL Term Coterm - | SumL Command Command + | SumL Coterm Coterm | PrdL1 Coterm | PrdL2 Coterm @@ -58,7 +58,7 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where covar v = Quoter (\ d -> Covar (toIndexed d v)) µL b = MuL <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b lamL a b = LamL <$> a <*> b - sumL l r = SumL <$> go l <*> go r where go = binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) + sumL l r = SumL <$> l <*> r prdL1 b = PrdL1 <$> b prdL2 b = PrdL2 <$> b @@ -88,7 +88,7 @@ interpretCoterm _G _D = \case Covar (Global n) -> C.covar (Global n) MuL b -> C.µL (\ t -> interpretCommand (t:_G) _D b) LamL a k -> C.lamL (interpretTerm _G _D a) (interpretCoterm _G _D k) - SumL l r -> C.sumL (go l) (go r) where go d t = interpretCommand (t:_G) _D d + SumL l r -> C.sumL (interpretCoterm _G _D l) (interpretCoterm _G _D r) PrdL1 c -> C.prdL1 (interpretCoterm _G _D c) PrdL2 c -> C.prdL2 (interpretCoterm _G _D c) diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index 950c70a08..97e496a13 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -33,7 +33,7 @@ data Coterm = Covar (Var Level) | MuL (Term -> Command) | LamL Term Coterm - | SumL (Term -> Command) (Term -> Command) + | SumL Coterm Coterm | PrdL1 Coterm | PrdL2 Coterm @@ -81,7 +81,7 @@ instance Quote Coterm X.Coterm where Covar v -> Quoter (\ d -> X.Covar (toIndexed d v)) MuL b -> X.MuL <$> quoteBinder (Quoter var) b LamL a b -> liftA2 X.LamL (quote a) (quote b) - SumL l r -> X.SumL <$> quoteBinder (Quoter var) l <*> quoteBinder (Quoter var) r + SumL l r -> X.SumL <$> quote l <*> quote r PrdL1 k -> X.PrdL1 <$> quote k PrdL2 k -> X.PrdL2 <$> quote k diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index db353b548..12a4f78da 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -36,7 +36,7 @@ instance S.Sequent Print Print Print where covar = var µL b = µ̃ <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) lamL a k = a P.<+> P.dot P.<+> k - sumL l r = µ̃ <> P.braces (commaSep [go l, go r]) where go c = fresh (\ v -> anon v P.<+> P.dot P.<+> c (anon v)) + sumL l r = P.pretty "case" <> P.braces (commaSep [l, r]) prdL1 k = P.parens (µ̃ <> P.braces (P.pretty "πl" P.<+> k)) prdL2 k = P.parens (µ̃ <> P.braces (P.pretty "πr" P.<+> k)) From 0a161ad5dad8dee0f744f274d7ed9fa2a504914d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 21 Mar 2022 09:57:26 -0400 Subject: [PATCH 0887/1324] Add let bindings to Sequent. --- src/Facet/Sequent/Class.hs | 1 + src/Facet/Sequent/Expr.hs | 6 +++++- src/Facet/Sequent/Norm.hs | 6 +++++- src/Facet/Sequent/Print.hs | 1 + 4 files changed, 12 insertions(+), 2 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index e0cbe33d4..e198e3f81 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -50,6 +50,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma -- Commands (.|.) :: term -> coterm -> command + let' :: term -> (term -> command) -> command infix 1 .|. diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 747ea5936..4e1396615 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -43,7 +43,9 @@ data Coterm -- Commands -data Command = Term :|: Coterm +data Command + = Term :|: Coterm + | Let Term Command instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where @@ -63,6 +65,7 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where prdL2 b = PrdL2 <$> b (.|.) = liftA2 (:|:) + let' t b = Let <$> t <*> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b var :: Index -> Term var = Var . Free @@ -94,6 +97,7 @@ interpretCoterm _G _D = \case interpretCommand :: C.Sequent t c d => [t] -> [c] -> Command -> d interpretCommand _G _D (t :|: c) = interpretTerm _G _D t C..|. interpretCoterm _G _D c +interpretCommand _G _D (Let t b) = C.let' (interpretTerm _G _D t) (\ t -> interpretCommand (t:_G) _D b) index :: [a] -> Index -> a index as (Index i) = as !! i diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index 97e496a13..353f196a8 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -40,7 +40,9 @@ data Coterm -- Commands -data Command = Term :|: Coterm +data Command + = Term :|: Coterm + | Let Term (Term -> Command) instance Class.Sequent Term Coterm Command where @@ -60,6 +62,7 @@ instance Class.Sequent Term Coterm Command where prdL2 = PrdL2 (.|.) = (:|:) + let' = Let instance Quote Term X.Term where @@ -88,3 +91,4 @@ instance Quote Coterm X.Coterm where instance Quote Command X.Command where quote (t :|: c) = liftA2 (X.:|:) (quote t) (quote c) + quote (Let t b) = X.Let <$> quote t <*> quoteBinder (Quoter var) b diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index 12a4f78da..1c84b6403 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -41,6 +41,7 @@ instance S.Sequent Print Print Print where prdL2 k = P.parens (µ̃ <> P.braces (P.pretty "πr" P.<+> k)) (.|.) = fmap (P.enclose P.langle P.rangle) . P.surround P.pipe + let' v b = P.pretty "let" P.<+> withLevel anon P.<+> P.pretty '=' P.<+> v P.<+> P.pretty "in" P.<+> fresh (b . anon) withLevel :: (Used -> Print) -> Print withLevel f = Print (\ o d -> doc (f d) o d) From 8b905a0c0eff7e3f9050042a5ea5f745128ad37a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 21 Mar 2022 10:02:17 -0400 Subject: [PATCH 0888/1324] Lift let bindings. --- src/Facet/Sequent/Class.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index e198e3f81..c62c6c0d0 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -17,6 +17,7 @@ module Facet.Sequent.Class , prdL1A , prdL2A , (.||.) +, letA -- , Ctx(..) -- , Binding(..) -- , lookupCtx @@ -135,6 +136,9 @@ prdL2A = fmap (fmap prdL2) infix 1 .||. +letA :: (Applicative m, Applicative i, Sequent t c d) => m (i t) -> (forall j . Applicative j => (i ~> j) -> j t -> m (j d)) -> m (i d) +letA t b = liftA2 let' <$> t <*> (runC <$> b weaken (liftCInner id)) + -- data Ctx j t -- = Nil From b526da0109fc2848652b4d512a7105812748d191 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 Mar 2022 09:10:40 -0400 Subject: [PATCH 0889/1324] :fire: the re-export of Clause. --- src/Facet/Sequent/Class.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index c62c6c0d0..27d61f224 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -6,7 +6,6 @@ module Facet.Sequent.Class -- * Effectful abstractions , varA , µRA -, C.Clause(..) , lamRA , (.$$.) , stringRA From bc4fbf7afb72e5f62764f83c277fca42be68307e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 Mar 2022 09:11:27 -0400 Subject: [PATCH 0890/1324] Define pattern compilation. --- src/Facet/Elab/Pattern.hs | 55 ++++++++++++++++++++++++++++++++++----- 1 file changed, 48 insertions(+), 7 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index bae265808..9ef21a852 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -12,15 +12,22 @@ module Facet.Elab.Pattern , covers , coverLoop , coverStep +, loop ) where -import Control.Applicative (Alternative(..), asum) -import Control.Monad (ap) -import Facet.Name -import Fresnel.Fold -import Fresnel.Lens -import Fresnel.Prism (Prism', matching', prism') -import Fresnel.Traversal (forOf, traversed) +import Control.Applicative (Alternative(..), asum) +import Control.Monad (ap) +import Data.Bifunctor (first) +import Data.Foldable (fold) +import Data.Monoid (First(..)) +import Data.Traversable (for) +import Facet.Name +import qualified Facet.Sequent.Class as SQ +import Facet.Syntax ((:::)(..)) +import Fresnel.Fold +import Fresnel.Lens +import Fresnel.Prism (Prism', matching', prism') +import Fresnel.Traversal (forOf, traversed) data Pattern a = Wildcard @@ -153,3 +160,37 @@ instantiateHead :: Pattern Name -> Pattern Name -> Pattern Name instantiateHead d Wildcard = d instantiateHead d (Var _) = d -- FIXME: let-bind any variables first instantiateHead _ p = p + + +loop :: (SQ.Sequent term coterm command, Applicative i) => [i term ::: Type] -> [Clause command] -> Maybe (i command) +loop ty heads = case ty of + (_ ::: Opaque):ts -> do + heads' <- forOf (traversed.patterns_) heads (\case + p:ps | Wildcard <- instantiateHead Wildcard p -> Just ps + _ -> Nothing) + loop ts heads' + (_ ::: One):ts -> do + heads' <- forOf (traversed.patterns_) heads (\case + p:ps | Unit <- instantiateHead Unit p -> Just ps + _ -> Nothing) + loop ts heads' + (u ::: _A :* _B):ts -> do + heads' <- forOf (traversed.patterns_) heads (\case + p:ps | Pair p q <- instantiateHead (Pair Wildcard Wildcard) p -> Just (p:q:ps) + _ -> Nothing) + let a wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL1A (pure k)) + b wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL2A (pure k)) + SQ.letA (a id) (\ wkA a -> SQ.letA (b wkA) (\ wkB b -> + loop ((wkB a ::: _A) : (b ::: _B) : map (first (wkB . wkA)) ts) heads')) + (u ::: _A :+ _B):ts -> do + (headsL, headsR) <- fold <$> for heads (\case + Clause (p:ps) b -> case instantiateHead Wildcard p of + InL p -> Just ([Clause (p:ps) b], []) + InR p -> Just ([], [Clause (p:ps) b]) + Wildcard -> Just ([Clause (Wildcard:ps) b], [Clause (Wildcard:ps) b]) + _ -> Nothing + _ -> Nothing) + pure u SQ..||. SQ.sumLA (SQ.µLA (\ wk a -> loop ((a ::: _A):map (first wk) ts) headsL)) (SQ.µLA (\ wk b -> loop ((b ::: _B):map (first wk) ts) headsR)) + [] + | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) -> Just (pure b) + _ -> Nothing From 868ea6e08b9009a3d21deae95a386d28b446736d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 Mar 2022 09:13:40 -0400 Subject: [PATCH 0891/1324] Format. --- src/Facet/Elab/Pattern.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 9ef21a852..c368fcdff 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -191,6 +191,5 @@ loop ty heads = case ty of _ -> Nothing _ -> Nothing) pure u SQ..||. SQ.sumLA (SQ.µLA (\ wk a -> loop ((a ::: _A):map (first wk) ts) headsL)) (SQ.µLA (\ wk b -> loop ((b ::: _B):map (first wk) ts) headsR)) - [] - | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) -> Just (pure b) + [] | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) -> Just (pure b) _ -> Nothing From e4ed90715728094094966fcaf5990f1c141c34b9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 08:05:45 -0400 Subject: [PATCH 0892/1324] Match function types explicitly. --- src/Facet/Elab/Pattern.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index c368fcdff..ccf0d7ea9 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -169,6 +169,11 @@ loop ty heads = case ty of p:ps | Wildcard <- instantiateHead Wildcard p -> Just ps _ -> Nothing) loop ts heads' + (_ ::: (_ :-> _)):ts -> do + heads' <- forOf (traversed.patterns_) heads (\case + p:ps | Wildcard <- instantiateHead Wildcard p -> Just ps + _ -> Nothing) + loop ts heads' (_ ::: One):ts -> do heads' <- forOf (traversed.patterns_) heads (\case p:ps | Unit <- instantiateHead Unit p -> Just ps From a4c44c706bac096b4825249b63dcede1fab34e0a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 08:55:06 -0400 Subject: [PATCH 0893/1324] Abbreviate the trivial cases. --- src/Facet/Elab/Pattern.hs | 23 ++++++++--------------- 1 file changed, 8 insertions(+), 15 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index ccf0d7ea9..dd5268c95 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -164,21 +164,9 @@ instantiateHead _ p = p loop :: (SQ.Sequent term coterm command, Applicative i) => [i term ::: Type] -> [Clause command] -> Maybe (i command) loop ty heads = case ty of - (_ ::: Opaque):ts -> do - heads' <- forOf (traversed.patterns_) heads (\case - p:ps | Wildcard <- instantiateHead Wildcard p -> Just ps - _ -> Nothing) - loop ts heads' - (_ ::: (_ :-> _)):ts -> do - heads' <- forOf (traversed.patterns_) heads (\case - p:ps | Wildcard <- instantiateHead Wildcard p -> Just ps - _ -> Nothing) - loop ts heads' - (_ ::: One):ts -> do - heads' <- forOf (traversed.patterns_) heads (\case - p:ps | Unit <- instantiateHead Unit p -> Just ps - _ -> Nothing) - loop ts heads' + (_ ::: Opaque):ts -> match' (fmap (const []) . matching' _Wildcard) heads Wildcard >>= loop ts + (_ ::: (_ :-> _)):ts -> match' (fmap (const []) . matching' _Wildcard) heads Wildcard >>= loop ts + (_ ::: One):ts -> match' (fmap (const []) . matching' _Unit) heads Unit >>= loop ts (u ::: _A :* _B):ts -> do heads' <- forOf (traversed.patterns_) heads (\case p:ps | Pair p q <- instantiateHead (Pair Wildcard Wildcard) p -> Just (p:q:ps) @@ -198,3 +186,8 @@ loop ty heads = case ty of pure u SQ..||. SQ.sumLA (SQ.µLA (\ wk a -> loop ((a ::: _A):map (first wk) ts) headsL)) (SQ.µLA (\ wk b -> loop ((b ::: _B):map (first wk) ts) headsR)) [] | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) -> Just (pure b) _ -> Nothing + +match' :: (Pattern Name -> Maybe [Pattern Name]) -> [Clause command] -> Pattern Name -> Maybe [Clause command] +match' decompose heads p' = forOf (traversed.patterns_) heads (\case + p:ps | Just prefix <- decompose (instantiateHead p' p) -> Just (prefix <> ps) + _ -> Nothing) From ad16f73b4a9ceeba67230168883978ce2d151d12 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 09:00:23 -0400 Subject: [PATCH 0894/1324] Abbreviate the pair case. --- src/Facet/Elab/Pattern.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index dd5268c95..5a3a30c7a 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -168,9 +168,7 @@ loop ty heads = case ty of (_ ::: (_ :-> _)):ts -> match' (fmap (const []) . matching' _Wildcard) heads Wildcard >>= loop ts (_ ::: One):ts -> match' (fmap (const []) . matching' _Unit) heads Unit >>= loop ts (u ::: _A :* _B):ts -> do - heads' <- forOf (traversed.patterns_) heads (\case - p:ps | Pair p q <- instantiateHead (Pair Wildcard Wildcard) p -> Just (p:q:ps) - _ -> Nothing) + heads' <- match' (fmap (\ (p, q) -> [p, q]) . matching' _Pair) heads Unit let a wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL1A (pure k)) b wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL2A (pure k)) SQ.letA (a id) (\ wkA a -> SQ.letA (b wkA) (\ wkB b -> From 38a5456f1a2eeb81043f858da0cf8f46f690e563 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 09:09:17 -0400 Subject: [PATCH 0895/1324] Fix an export for ghc 8.10. --- src/Facet/Elab/Pattern.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 5a3a30c7a..d5138d133 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -15,10 +15,10 @@ module Facet.Elab.Pattern , loop ) where -import Control.Applicative (Alternative(..), asum) +import Control.Applicative (Alternative(..)) import Control.Monad (ap) import Data.Bifunctor (first) -import Data.Foldable (fold) +import Data.Foldable (asum, fold) import Data.Monoid (First(..)) import Data.Traversable (for) import Facet.Name From aa326433e462d4166f258097ac4d30fb7fb66ffe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 09:10:04 -0400 Subject: [PATCH 0896/1324] :fire: the old coverage judgement. --- src/Facet/Elab/Pattern.hs | 51 +-------------------------------------- 1 file changed, 1 insertion(+), 50 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index d5138d133..87f9d3e60 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -8,17 +8,12 @@ module Facet.Elab.Pattern , Branch(..) , (\/) -- * Coverage judgement -, Covers(..) -, covers -, coverLoop -, coverStep , loop ) where -import Control.Applicative (Alternative(..)) import Control.Monad (ap) import Data.Bifunctor (first) -import Data.Foldable (asum, fold) +import Data.Foldable (fold) import Data.Monoid (First(..)) import Data.Traversable (for) import Facet.Name @@ -112,50 +107,6 @@ infixr 2 \/ -- Coverage judgement -newtype Covers a = Covers { runCovers :: forall r . (r -> r -> r) -> (a -> r) -> r -> (Type -> [Pattern Name] -> r) -> r } - deriving (Functor) - -instance Applicative Covers where - pure a = Covers (\ _ leaf _ _ -> leaf a) - - (<*>) = ap - -instance Alternative Covers where - empty = Covers (\ _ _ nil _ -> nil) - - Covers a <|> Covers b = Covers (\ (<|>) leaf nil err -> a (<|>) leaf nil err <|> b (<|>) leaf nil err) - -instance Monad Covers where - Covers m >>= k = Covers (\ fork leaf nil err -> m fork (\ a -> runCovers (k a) fork leaf nil err) nil err) - -throw :: Type -> [Pattern Name] -> Covers a -throw ty ps = Covers (\ _ _ _ err -> err ty ps) - -covers :: Type -> [Clause a] -> Bool -covers ty heads = runCovers (coverLoop ty heads) (&&) (const True) True (const (const False)) - -coverLoop :: Type -> [Clause a] -> Covers (Type, [Clause a]) -coverLoop ty heads = case ty of - hd :-> tl -> coverStep hd heads (\ prefix -> coverLoop (prefix tl)) - ty -> pure (ty, heads) -- FIXME: fail if clauses aren't all empty - -coverStep :: Type -> [Clause a] -> ((Type -> Type) -> [Clause a] -> Covers x) -> Covers x -coverStep hd heads k = case hd of - Opaque -> match [([], Wildcard)] hd heads (\ p -> [] <$ matching' _Wildcard p) k - One -> match [([], Unit)] hd heads (\ p -> [] <$ matching' _Unit p) k - s :+ t -> match [([s], InL Wildcard), ([t], InR Wildcard)] hd heads (\ p -> pure <$> (matching' _InL p <|> matching' _InR p)) k -- FIXME: match once and partition results - s :* t -> match [([s, t], Pair Wildcard Wildcard)] hd heads (\ p -> (\ (a, b) -> [a, b]) <$> matching' _Pair p) k - _ :-> _ -> match [([], Wildcard)] hd heads (\ p -> [] <$ matching' _Wildcard p) k - -match :: [([Type], Pattern Name)] -> Type -> [Clause a] -> (Pattern Name -> Maybe [Pattern Name]) -> ((Type -> Type) -> [Clause a] -> Covers x) -> Covers x -match inst hd heads decompose k = do - (prefix, canonical) <- asum (pure <$> inst) - heads' <- forOf (traversed.patterns_) heads (\case - p:ps | Just p' <- decompose (instantiateHead canonical p) -> pure (p' <> ps) - ps -> throw hd ps) - k (\ tl -> foldr (:->) tl prefix) heads' - - instantiateHead :: Pattern Name -> Pattern Name -> Pattern Name instantiateHead d Wildcard = d instantiateHead d (Var _) = d -- FIXME: let-bind any variables first From 8acca99b750079349bee7a8e07eb7db444e2741b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 09:11:53 -0400 Subject: [PATCH 0897/1324] Rename. --- src/Facet/Elab/Pattern.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 87f9d3e60..b17b07951 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -115,11 +115,11 @@ instantiateHead _ p = p loop :: (SQ.Sequent term coterm command, Applicative i) => [i term ::: Type] -> [Clause command] -> Maybe (i command) loop ty heads = case ty of - (_ ::: Opaque):ts -> match' (fmap (const []) . matching' _Wildcard) heads Wildcard >>= loop ts - (_ ::: (_ :-> _)):ts -> match' (fmap (const []) . matching' _Wildcard) heads Wildcard >>= loop ts - (_ ::: One):ts -> match' (fmap (const []) . matching' _Unit) heads Unit >>= loop ts + (_ ::: Opaque):ts -> match (fmap (const []) . matching' _Wildcard) heads Wildcard >>= loop ts + (_ ::: (_ :-> _)):ts -> match (fmap (const []) . matching' _Wildcard) heads Wildcard >>= loop ts + (_ ::: One):ts -> match (fmap (const []) . matching' _Unit) heads Unit >>= loop ts (u ::: _A :* _B):ts -> do - heads' <- match' (fmap (\ (p, q) -> [p, q]) . matching' _Pair) heads Unit + heads' <- match (fmap (\ (p, q) -> [p, q]) . matching' _Pair) heads Unit let a wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL1A (pure k)) b wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL2A (pure k)) SQ.letA (a id) (\ wkA a -> SQ.letA (b wkA) (\ wkB b -> @@ -136,7 +136,7 @@ loop ty heads = case ty of [] | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) -> Just (pure b) _ -> Nothing -match' :: (Pattern Name -> Maybe [Pattern Name]) -> [Clause command] -> Pattern Name -> Maybe [Clause command] -match' decompose heads p' = forOf (traversed.patterns_) heads (\case +match :: (Pattern Name -> Maybe [Pattern Name]) -> [Clause command] -> Pattern Name -> Maybe [Clause command] +match decompose heads p' = forOf (traversed.patterns_) heads (\case p:ps | Just prefix <- decompose (instantiateHead p' p) -> Just (prefix <> ps) _ -> Nothing) From 2ad90ac232ebb4184018887fcbd93a699b6ad9bc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 09:12:29 -0400 Subject: [PATCH 0898/1324] Rename loop to compilePattern. --- src/Facet/Elab/Pattern.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index b17b07951..72e75ebd8 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -8,7 +8,7 @@ module Facet.Elab.Pattern , Branch(..) , (\/) -- * Coverage judgement -, loop +, compilePattern ) where import Control.Monad (ap) @@ -113,17 +113,17 @@ instantiateHead d (Var _) = d -- FIXME: let-bind any variables first instantiateHead _ p = p -loop :: (SQ.Sequent term coterm command, Applicative i) => [i term ::: Type] -> [Clause command] -> Maybe (i command) -loop ty heads = case ty of - (_ ::: Opaque):ts -> match (fmap (const []) . matching' _Wildcard) heads Wildcard >>= loop ts - (_ ::: (_ :-> _)):ts -> match (fmap (const []) . matching' _Wildcard) heads Wildcard >>= loop ts - (_ ::: One):ts -> match (fmap (const []) . matching' _Unit) heads Unit >>= loop ts +compilePattern :: (SQ.Sequent term coterm command, Applicative i) => [i term ::: Type] -> [Clause command] -> Maybe (i command) +compilePattern ty heads = case ty of + (_ ::: Opaque):ts -> match (fmap (const []) . matching' _Wildcard) heads Wildcard >>= compilePattern ts + (_ ::: (_ :-> _)):ts -> match (fmap (const []) . matching' _Wildcard) heads Wildcard >>= compilePattern ts + (_ ::: One):ts -> match (fmap (const []) . matching' _Unit) heads Unit >>= compilePattern ts (u ::: _A :* _B):ts -> do heads' <- match (fmap (\ (p, q) -> [p, q]) . matching' _Pair) heads Unit let a wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL1A (pure k)) b wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL2A (pure k)) SQ.letA (a id) (\ wkA a -> SQ.letA (b wkA) (\ wkB b -> - loop ((wkB a ::: _A) : (b ::: _B) : map (first (wkB . wkA)) ts) heads')) + compilePattern ((wkB a ::: _A) : (b ::: _B) : map (first (wkB . wkA)) ts) heads')) (u ::: _A :+ _B):ts -> do (headsL, headsR) <- fold <$> for heads (\case Clause (p:ps) b -> case instantiateHead Wildcard p of @@ -132,7 +132,7 @@ loop ty heads = case ty of Wildcard -> Just ([Clause (Wildcard:ps) b], [Clause (Wildcard:ps) b]) _ -> Nothing _ -> Nothing) - pure u SQ..||. SQ.sumLA (SQ.µLA (\ wk a -> loop ((a ::: _A):map (first wk) ts) headsL)) (SQ.µLA (\ wk b -> loop ((b ::: _B):map (first wk) ts) headsR)) + pure u SQ..||. SQ.sumLA (SQ.µLA (\ wk a -> compilePattern ((a ::: _A):map (first wk) ts) headsL)) (SQ.µLA (\ wk b -> compilePattern ((b ::: _B):map (first wk) ts) headsR)) [] | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) -> Just (pure b) _ -> Nothing From aa40551fb95737ea4f22f9a00be09de7ded547bc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 11:51:53 -0400 Subject: [PATCH 0899/1324] :fire: Branch. --- src/Facet/Elab/Pattern.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 72e75ebd8..8da28de17 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -5,7 +5,6 @@ module Facet.Elab.Pattern , Clause(..) , patterns_ , Type(..) -, Branch(..) , (\/) -- * Coverage judgement , compilePattern @@ -97,8 +96,6 @@ infixl 7 :* infixr 1 :-> -data Branch s m a = forall x . Branch (Fold s x) (x -> m a) - (\/) :: Fold s a -> Fold s a -> Fold s a f1 \/ f2 = getUnion (Union f1 <> Union f2) From 4622d07a2fa53f41cc7a45deac7f770e5debc49b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 11:52:30 -0400 Subject: [PATCH 0900/1324] :fire \/. --- src/Facet/Elab/Pattern.hs | 8 -------- 1 file changed, 8 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 8da28de17..cb8c4242f 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -5,7 +5,6 @@ module Facet.Elab.Pattern , Clause(..) , patterns_ , Type(..) -, (\/) -- * Coverage judgement , compilePattern ) where @@ -18,7 +17,6 @@ import Data.Traversable (for) import Facet.Name import qualified Facet.Sequent.Class as SQ import Facet.Syntax ((:::)(..)) -import Fresnel.Fold import Fresnel.Lens import Fresnel.Prism (Prism', matching', prism') import Fresnel.Traversal (forOf, traversed) @@ -96,12 +94,6 @@ infixl 7 :* infixr 1 :-> -(\/) :: Fold s a -> Fold s a -> Fold s a -f1 \/ f2 = getUnion (Union f1 <> Union f2) - -infixr 2 \/ - - -- Coverage judgement instantiateHead :: Pattern Name -> Pattern Name -> Pattern Name From 20965fabe7c6d9e313566c97c3c4cbb272fe9d9e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 15:17:55 -0400 Subject: [PATCH 0901/1324] Generalize constructions. --- src/Facet/Elab/Pattern.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index cb8c4242f..ae4b00b7d 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -116,16 +116,16 @@ compilePattern ty heads = case ty of (u ::: _A :+ _B):ts -> do (headsL, headsR) <- fold <$> for heads (\case Clause (p:ps) b -> case instantiateHead Wildcard p of - InL p -> Just ([Clause (p:ps) b], []) - InR p -> Just ([], [Clause (p:ps) b]) - Wildcard -> Just ([Clause (Wildcard:ps) b], [Clause (Wildcard:ps) b]) + InL p -> pure ([Clause (p:ps) b], []) + InR p -> pure ([], [Clause (p:ps) b]) + Wildcard -> pure ([Clause (Wildcard:ps) b], [Clause (Wildcard:ps) b]) _ -> Nothing _ -> Nothing) pure u SQ..||. SQ.sumLA (SQ.µLA (\ wk a -> compilePattern ((a ::: _A):map (first wk) ts) headsL)) (SQ.µLA (\ wk b -> compilePattern ((b ::: _B):map (first wk) ts) headsR)) - [] | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) -> Just (pure b) + [] | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) -> pure (pure b) _ -> Nothing match :: (Pattern Name -> Maybe [Pattern Name]) -> [Clause command] -> Pattern Name -> Maybe [Clause command] match decompose heads p' = forOf (traversed.patterns_) heads (\case - p:ps | Just prefix <- decompose (instantiateHead p' p) -> Just (prefix <> ps) + p:ps | Just prefix <- decompose (instantiateHead p' p) -> pure (prefix <> ps) _ -> Nothing) From 2dcad97d2c69613365038db02ebe48ae652457a9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 15:20:05 -0400 Subject: [PATCH 0902/1324] Generalize failures. --- src/Facet/Elab/Pattern.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index ae4b00b7d..dbd91af21 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -9,6 +9,7 @@ module Facet.Elab.Pattern , compilePattern ) where +import Control.Effect.Empty import Control.Monad (ap) import Data.Bifunctor (first) import Data.Foldable (fold) @@ -102,7 +103,7 @@ instantiateHead d (Var _) = d -- FIXME: let-bind any variables first instantiateHead _ p = p -compilePattern :: (SQ.Sequent term coterm command, Applicative i) => [i term ::: Type] -> [Clause command] -> Maybe (i command) +compilePattern :: (Has Empty sig m, SQ.Sequent term coterm command, Applicative i) => [i term ::: Type] -> [Clause command] -> m (i command) compilePattern ty heads = case ty of (_ ::: Opaque):ts -> match (fmap (const []) . matching' _Wildcard) heads Wildcard >>= compilePattern ts (_ ::: (_ :-> _)):ts -> match (fmap (const []) . matching' _Wildcard) heads Wildcard >>= compilePattern ts @@ -119,13 +120,13 @@ compilePattern ty heads = case ty of InL p -> pure ([Clause (p:ps) b], []) InR p -> pure ([], [Clause (p:ps) b]) Wildcard -> pure ([Clause (Wildcard:ps) b], [Clause (Wildcard:ps) b]) - _ -> Nothing - _ -> Nothing) + _ -> empty + _ -> empty) pure u SQ..||. SQ.sumLA (SQ.µLA (\ wk a -> compilePattern ((a ::: _A):map (first wk) ts) headsL)) (SQ.µLA (\ wk b -> compilePattern ((b ::: _B):map (first wk) ts) headsR)) [] | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) -> pure (pure b) - _ -> Nothing + _ -> empty -match :: (Pattern Name -> Maybe [Pattern Name]) -> [Clause command] -> Pattern Name -> Maybe [Clause command] +match :: Has Empty sig m => (Pattern Name -> Maybe [Pattern Name]) -> [Clause command] -> Pattern Name -> m [Clause command] match decompose heads p' = forOf (traversed.patterns_) heads (\case p:ps | Just prefix <- decompose (instantiateHead p' p) -> pure (prefix <> ps) - _ -> Nothing) + _ -> empty) From 59c24fcb3dff768466606385f65f26a75e1eee43 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 17:26:34 -0400 Subject: [PATCH 0903/1324] Instantiate variables to wildcards. --- src/Facet/Elab/Pattern.hs | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index dbd91af21..db3d619e3 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -97,26 +97,25 @@ infixr 1 :-> -- Coverage judgement -instantiateHead :: Pattern Name -> Pattern Name -> Pattern Name -instantiateHead d Wildcard = d -instantiateHead d (Var _) = d -- FIXME: let-bind any variables first -instantiateHead _ p = p +instantiateHead :: Pattern Name -> Pattern Name +instantiateHead (Var _) = Wildcard -- FIXME: let-bind any variables first +instantiateHead p = p compilePattern :: (Has Empty sig m, SQ.Sequent term coterm command, Applicative i) => [i term ::: Type] -> [Clause command] -> m (i command) compilePattern ty heads = case ty of - (_ ::: Opaque):ts -> match (fmap (const []) . matching' _Wildcard) heads Wildcard >>= compilePattern ts - (_ ::: (_ :-> _)):ts -> match (fmap (const []) . matching' _Wildcard) heads Wildcard >>= compilePattern ts - (_ ::: One):ts -> match (fmap (const []) . matching' _Unit) heads Unit >>= compilePattern ts + (_ ::: Opaque):ts -> match (fmap (const []) . matching' _Wildcard) heads >>= compilePattern ts + (_ ::: (_ :-> _)):ts -> match (fmap (const []) . matching' _Wildcard) heads >>= compilePattern ts + (_ ::: One):ts -> match (fmap (const []) . matching' _Unit) heads >>= compilePattern ts (u ::: _A :* _B):ts -> do - heads' <- match (fmap (\ (p, q) -> [p, q]) . matching' _Pair) heads Unit + heads' <- match (fmap (\ (p, q) -> [p, q]) . matching' _Pair) heads let a wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL1A (pure k)) b wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL2A (pure k)) SQ.letA (a id) (\ wkA a -> SQ.letA (b wkA) (\ wkB b -> compilePattern ((wkB a ::: _A) : (b ::: _B) : map (first (wkB . wkA)) ts) heads')) (u ::: _A :+ _B):ts -> do (headsL, headsR) <- fold <$> for heads (\case - Clause (p:ps) b -> case instantiateHead Wildcard p of + Clause (p:ps) b -> case instantiateHead p of InL p -> pure ([Clause (p:ps) b], []) InR p -> pure ([], [Clause (p:ps) b]) Wildcard -> pure ([Clause (Wildcard:ps) b], [Clause (Wildcard:ps) b]) @@ -126,7 +125,7 @@ compilePattern ty heads = case ty of [] | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) -> pure (pure b) _ -> empty -match :: Has Empty sig m => (Pattern Name -> Maybe [Pattern Name]) -> [Clause command] -> Pattern Name -> m [Clause command] -match decompose heads p' = forOf (traversed.patterns_) heads (\case - p:ps | Just prefix <- decompose (instantiateHead p' p) -> pure (prefix <> ps) - _ -> empty) +match :: Has Empty sig m => (Pattern Name -> Maybe [Pattern Name]) -> [Clause command] -> m [Clause command] +match decompose heads = forOf (traversed.patterns_) heads (\case + p:ps | Just prefix <- decompose (instantiateHead p) -> pure (prefix <> ps) + _ -> empty) From e059c3ef7ed9ede0ba7881b5a89457498003cb31 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 17:28:20 -0400 Subject: [PATCH 0904/1324] Correct how pairs are matched. --- src/Facet/Elab/Pattern.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index db3d619e3..aefcb9d81 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -9,6 +9,7 @@ module Facet.Elab.Pattern , compilePattern ) where +import Control.Applicative ((<|>)) import Control.Effect.Empty import Control.Monad (ap) import Data.Bifunctor (first) @@ -108,7 +109,7 @@ compilePattern ty heads = case ty of (_ ::: (_ :-> _)):ts -> match (fmap (const []) . matching' _Wildcard) heads >>= compilePattern ts (_ ::: One):ts -> match (fmap (const []) . matching' _Unit) heads >>= compilePattern ts (u ::: _A :* _B):ts -> do - heads' <- match (fmap (\ (p, q) -> [p, q]) . matching' _Pair) heads + heads' <- match (\ p -> (\ (p, q) -> [p, q]) <$> matching' _Pair p <|> const [Wildcard, Wildcard] <$> matching' _Wildcard p) heads let a wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL1A (pure k)) b wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL2A (pure k)) SQ.letA (a id) (\ wkA a -> SQ.letA (b wkA) (\ wkB b -> From 92067e602ddcaf3ac2ba86a8587cdba6ba92f88e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 17:29:34 -0400 Subject: [PATCH 0905/1324] Simplify pair matching. --- src/Facet/Elab/Pattern.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index aefcb9d81..7f8cb867e 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -9,7 +9,6 @@ module Facet.Elab.Pattern , compilePattern ) where -import Control.Applicative ((<|>)) import Control.Effect.Empty import Control.Monad (ap) import Data.Bifunctor (first) @@ -109,7 +108,7 @@ compilePattern ty heads = case ty of (_ ::: (_ :-> _)):ts -> match (fmap (const []) . matching' _Wildcard) heads >>= compilePattern ts (_ ::: One):ts -> match (fmap (const []) . matching' _Unit) heads >>= compilePattern ts (u ::: _A :* _B):ts -> do - heads' <- match (\ p -> (\ (p, q) -> [p, q]) <$> matching' _Pair p <|> const [Wildcard, Wildcard] <$> matching' _Wildcard p) heads + heads' <- match (\case{ Pair p q -> Just [p, q] ; Wildcard -> Just [Wildcard, Wildcard] ; _ -> Nothing }) heads let a wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL1A (pure k)) b wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL2A (pure k)) SQ.letA (a id) (\ wkA a -> SQ.letA (b wkA) (\ wkB b -> From 6e44f33c0715fcce2c9825edd8c2eeb01aa9b6bd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 17:35:34 -0400 Subject: [PATCH 0906/1324] Simplify matches. --- src/Facet/Elab/Pattern.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 7f8cb867e..3a945b241 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -18,8 +18,10 @@ import Data.Traversable (for) import Facet.Name import qualified Facet.Sequent.Class as SQ import Facet.Syntax ((:::)(..)) -import Fresnel.Lens -import Fresnel.Prism (Prism', matching', prism') +import Fresnel.Fold (preview) +import Fresnel.Getter (to) +import Fresnel.Lens (Lens', lens) +import Fresnel.Prism (Prism', prism') import Fresnel.Traversal (forOf, traversed) data Pattern a @@ -104,9 +106,9 @@ instantiateHead p = p compilePattern :: (Has Empty sig m, SQ.Sequent term coterm command, Applicative i) => [i term ::: Type] -> [Clause command] -> m (i command) compilePattern ty heads = case ty of - (_ ::: Opaque):ts -> match (fmap (const []) . matching' _Wildcard) heads >>= compilePattern ts - (_ ::: (_ :-> _)):ts -> match (fmap (const []) . matching' _Wildcard) heads >>= compilePattern ts - (_ ::: One):ts -> match (fmap (const []) . matching' _Unit) heads >>= compilePattern ts + (_ ::: Opaque):ts -> match (preview (_Wildcard.to (const []))) heads >>= compilePattern ts + (_ ::: (_ :-> _)):ts -> match (preview (_Wildcard.to (const []))) heads >>= compilePattern ts + (_ ::: One):ts -> match (preview (_Unit.to (const []))) heads >>= compilePattern ts (u ::: _A :* _B):ts -> do heads' <- match (\case{ Pair p q -> Just [p, q] ; Wildcard -> Just [Wildcard, Wildcard] ; _ -> Nothing }) heads let a wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL1A (pure k)) From 74ce34f79a2e835913303edf5d6c4d734ec3d23b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 17:37:24 -0400 Subject: [PATCH 0907/1324] Match pairs using previews. --- src/Facet/Elab/Pattern.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 3a945b241..6fe9a8d91 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -9,6 +9,7 @@ module Facet.Elab.Pattern , compilePattern ) where +import Control.Applicative ((<|>)) import Control.Effect.Empty import Control.Monad (ap) import Data.Bifunctor (first) @@ -110,7 +111,7 @@ compilePattern ty heads = case ty of (_ ::: (_ :-> _)):ts -> match (preview (_Wildcard.to (const []))) heads >>= compilePattern ts (_ ::: One):ts -> match (preview (_Unit.to (const []))) heads >>= compilePattern ts (u ::: _A :* _B):ts -> do - heads' <- match (\case{ Pair p q -> Just [p, q] ; Wildcard -> Just [Wildcard, Wildcard] ; _ -> Nothing }) heads + heads' <- match (\ p -> preview (_Pair.to (\ (p, q) -> [p, q])) p <|> preview (_Wildcard.to (const [Wildcard, Wildcard])) p) heads let a wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL1A (pure k)) b wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL2A (pure k)) SQ.letA (a id) (\ wkA a -> SQ.letA (b wkA) (\ wkB b -> From 65dc9870b4fa255e52a01866191080d89f2830b5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 17:40:54 -0400 Subject: [PATCH 0908/1324] Match using folds. --- src/Facet/Elab/Pattern.hs | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 6fe9a8d91..df9383cef 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -9,7 +9,6 @@ module Facet.Elab.Pattern , compilePattern ) where -import Control.Applicative ((<|>)) import Control.Effect.Empty import Control.Monad (ap) import Data.Bifunctor (first) @@ -19,7 +18,7 @@ import Data.Traversable (for) import Facet.Name import qualified Facet.Sequent.Class as SQ import Facet.Syntax ((:::)(..)) -import Fresnel.Fold (preview) +import Fresnel.Fold (Fold, Union(..), preview) import Fresnel.Getter (to) import Fresnel.Lens (Lens', lens) import Fresnel.Prism (Prism', prism') @@ -107,11 +106,11 @@ instantiateHead p = p compilePattern :: (Has Empty sig m, SQ.Sequent term coterm command, Applicative i) => [i term ::: Type] -> [Clause command] -> m (i command) compilePattern ty heads = case ty of - (_ ::: Opaque):ts -> match (preview (_Wildcard.to (const []))) heads >>= compilePattern ts - (_ ::: (_ :-> _)):ts -> match (preview (_Wildcard.to (const []))) heads >>= compilePattern ts - (_ ::: One):ts -> match (preview (_Unit.to (const []))) heads >>= compilePattern ts + (_ ::: Opaque):ts -> match (_Wildcard.to (const [])) heads >>= compilePattern ts + (_ ::: (_ :-> _)):ts -> match (_Wildcard.to (const [])) heads >>= compilePattern ts + (_ ::: One):ts -> match (_Unit.to (const [])) heads >>= compilePattern ts (u ::: _A :* _B):ts -> do - heads' <- match (\ p -> preview (_Pair.to (\ (p, q) -> [p, q])) p <|> preview (_Wildcard.to (const [Wildcard, Wildcard])) p) heads + heads' <- match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Wildcard.to (const [Wildcard, Wildcard])))) heads let a wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL1A (pure k)) b wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL2A (pure k)) SQ.letA (a id) (\ wkA a -> SQ.letA (b wkA) (\ wkB b -> @@ -128,7 +127,7 @@ compilePattern ty heads = case ty of [] | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) -> pure (pure b) _ -> empty -match :: Has Empty sig m => (Pattern Name -> Maybe [Pattern Name]) -> [Clause command] -> m [Clause command] -match decompose heads = forOf (traversed.patterns_) heads (\case - p:ps | Just prefix <- decompose (instantiateHead p) -> pure (prefix <> ps) +match :: Has Empty sig m => Fold (Pattern Name) [Pattern Name] -> [Clause command] -> m [Clause command] +match o heads = forOf (traversed.patterns_) heads (\case + p:ps | Just prefix <- preview o (instantiateHead p) -> pure (prefix <> ps) _ -> empty) From 4eb51137c1cf965e09a9e730f9205c111c09a72a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 17:42:26 -0400 Subject: [PATCH 0909/1324] Align. --- src/Facet/Elab/Pattern.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index df9383cef..b368ef929 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -106,9 +106,9 @@ instantiateHead p = p compilePattern :: (Has Empty sig m, SQ.Sequent term coterm command, Applicative i) => [i term ::: Type] -> [Clause command] -> m (i command) compilePattern ty heads = case ty of - (_ ::: Opaque):ts -> match (_Wildcard.to (const [])) heads >>= compilePattern ts + (_ ::: Opaque):ts -> match (_Wildcard.to (const [])) heads >>= compilePattern ts (_ ::: (_ :-> _)):ts -> match (_Wildcard.to (const [])) heads >>= compilePattern ts - (_ ::: One):ts -> match (_Unit.to (const [])) heads >>= compilePattern ts + (_ ::: One):ts -> match (_Unit.to (const [])) heads >>= compilePattern ts (u ::: _A :* _B):ts -> do heads' <- match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Wildcard.to (const [Wildcard, Wildcard])))) heads let a wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL1A (pure k)) From 592e02bdd567c513d070090369bc0420a5e20766 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 19:57:18 -0400 Subject: [PATCH 0910/1324] :fire: occursCheckFailure. --- src/Facet/Elab.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index e0d32a0cc..b5678b605 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -27,7 +27,6 @@ module Facet.Elab , err , makeErr , couldNotUnify -, occursCheckFailure , couldNotSynthesize , resourceMismatch , freeVariable @@ -281,9 +280,6 @@ mismatch exp act = withFrozenCallStack $ err $ Unify Mismatch exp act couldNotUnify :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m) => Exp Classifier -> Act Classifier -> m a couldNotUnify t1 t2 = withFrozenCallStack $ mismatch (Right <$> t1) t2 -occursCheckFailure :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m) => Meta -> Classifier -> Exp Classifier -> Act Classifier -> m a -occursCheckFailure m v exp act = withFrozenCallStack $ err $ Unify (Occurs m v) (Right <$> exp) act - couldNotSynthesize :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m) => m a couldNotSynthesize = withFrozenCallStack $ err CouldNotSynthesize From 5796bc746f5865f88058c9e9d27eced6d750f5e9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 20:05:43 -0400 Subject: [PATCH 0911/1324] Split up unification errors by sort. --- src/Facet/Elab.hs | 53 +++++++++++++++++++++++----------------- src/Facet/Elab/Term.hs | 6 ++--- src/Facet/Elab/Type.hs | 4 +-- src/Facet/Notice/Elab.hs | 13 +++++++++- src/Facet/Unify.hs | 28 ++++++++++----------- 5 files changed, 61 insertions(+), 43 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index b5678b605..d9837a6ba 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -20,13 +20,15 @@ module Facet.Elab , ErrReason(..) , _FreeVariable , _AmbiguousName -, _Unify +, _UnifyType , UnifyErrReason(..) , _Mismatch , _Occurs , err , makeErr -, couldNotUnify +, mismatchTypes +, mismatchKinds +, couldNotUnifyKinds , couldNotSynthesize , resourceMismatch , freeVariable @@ -91,7 +93,7 @@ import Facet.Usage as Usage import Facet.Vars as Vars import Fresnel.Fold ((^?)) import Fresnel.Lens (Lens', lens) -import Fresnel.Prism (Prism', prism') +import Fresnel.Prism (Prism, Prism', prism, prism') import GHC.Stack import Prelude hiding (span, zipWith) @@ -212,7 +214,8 @@ data ErrReason | AmbiguousName QName [RName] | CouldNotSynthesize | ResourceMismatch Name Quantity Quantity - | Unify UnifyErrReason (Exp (Either String Classifier)) (Act Classifier) + | UnifyType (UnifyErrReason Type) (Exp (Either String Type)) (Act Type) + | UnifyKind (UnifyErrReason Type) (Exp (Either String Kind)) (Act Kind) | Hole Name Classifier | Invariant String | MissingInterface (Interface Type) @@ -227,24 +230,24 @@ _AmbiguousName = prism' (uncurry AmbiguousName) (\case AmbiguousName n ns -> Just (n, ns) _ -> Nothing) -_Unify :: Prism' ErrReason (UnifyErrReason, Exp (Either String Classifier), Act Classifier) -_Unify = prism' (\ (r, x, a) -> Unify r x a) (\case - Unify r x a -> Just (r, x, a) - _ -> Nothing) +_UnifyType :: Prism' ErrReason (UnifyErrReason Type, Exp (Either String Type), Act Type) +_UnifyType = prism' (\ (r, x, a) -> UnifyType r x a) (\case + UnifyType r x a -> Just (r, x, a) + _ -> Nothing) -data UnifyErrReason +data UnifyErrReason t = Mismatch - | Occurs Meta Classifier + | Occurs Meta t -_Mismatch :: Prism' UnifyErrReason () +_Mismatch :: Prism' (UnifyErrReason t) () _Mismatch = prism' (const Mismatch) (\case Mismatch -> Just () _ -> Nothing) -_Occurs :: Prism' UnifyErrReason (Meta, Classifier) -_Occurs = prism' (uncurry Occurs) (\case - Occurs v c -> Just (v, c) - _ -> Nothing) +_Occurs :: Prism (UnifyErrReason s) (UnifyErrReason t) (Meta, s) (Meta, t) +_Occurs = prism (uncurry Occurs) (\case + Occurs v c -> Right (v, c) + Mismatch -> Left Mismatch) applySubst :: Context -> Subst Type -> ErrReason -> ErrReason applySubst ctx subst r = case r of @@ -253,7 +256,8 @@ applySubst ctx subst r = case r of CouldNotSynthesize{} -> r ResourceMismatch{} -> r -- NB: not substituting in @r@ because we want to retain the cyclic occurrence (and finitely) - Unify r exp act -> Unify r (fmap roundtripS <$> exp) (roundtripS <$> act) + UnifyType r exp act -> UnifyType r (fmap roundtrip <$> exp) (roundtrip <$> act) + UnifyKind{} -> r Hole n t -> Hole n (roundtripS t) Invariant{} -> r MissingInterface i -> MissingInterface (roundtrip <$> i) @@ -274,11 +278,14 @@ makeErr reason = do subst <- get pure $ Err (maybe source (slice source) (peek spans)) (applySubst context subst reason) context subst sig GHC.Stack.callStack -mismatch :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m) => Exp (Either String Classifier) -> Act Classifier -> m a -mismatch exp act = withFrozenCallStack $ err $ Unify Mismatch exp act +mismatchTypes :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m) => Exp (Either String Type) -> Act Type -> m a +mismatchTypes exp act = withFrozenCallStack $ err $ UnifyType Mismatch exp act -couldNotUnify :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m) => Exp Classifier -> Act Classifier -> m a -couldNotUnify t1 t2 = withFrozenCallStack $ mismatch (Right <$> t1) t2 +mismatchKinds :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m) => Exp (Either String Kind) -> Act Kind -> m a +mismatchKinds exp act = withFrozenCallStack $ err $ UnifyKind Mismatch exp act + +couldNotUnifyKinds :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m) => Exp Kind -> Act Kind -> m a +couldNotUnifyKinds t1 t2 = withFrozenCallStack $ mismatchKinds (Right <$> t1) t2 couldNotSynthesize :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m) => m a couldNotSynthesize = withFrozenCallStack $ err CouldNotSynthesize @@ -326,11 +333,11 @@ warn reason = do -- Patterns -assertMatch :: (HasCallStack, Has (Throw Err) sig m, Classified s) => Prism' s a -> String -> s -> Elab m a -assertMatch pat exp _T = maybe (mismatch (Exp (Left exp)) (Act (classified _T))) pure (_T ^? pat) +assertMatch :: (Exp (Either String b) -> Act s -> Elab m a) -> Prism' s a -> String -> s -> Elab m a +assertMatch mismatch pat exp _T = maybe (mismatch (Exp (Left exp)) (Act _T)) pure (_T ^? pat) assertFunction :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Maybe Name, Quantity, Type, Type) -assertFunction = assertMatch _Arrow "_ -> _" +assertFunction = assertMatch mismatchTypes _Arrow "_ -> _" -- Unification diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index ed21fa660..3919fb197 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -488,15 +488,15 @@ letrec getter key projection initial final = do -- Errors assertQuantifier :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Name, Kind, Type -> Type) -assertQuantifier = assertMatch _ForAll "{_} -> _" +assertQuantifier = assertMatch mismatchTypes _ForAll "{_} -> _" -- | Expect a tacit (non-variable-binding) lamction type. assertTacitFunction :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Maybe Name, Quantity, Type, Type) -assertTacitFunction = assertMatch _Arrow "_ -> _" +assertTacitFunction = assertMatch mismatchTypes _Arrow "_ -> _" -- | Expect a computation type with effects. assertComp :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Signature Type, Type) -assertComp = assertMatch _Comp "[_] _" +assertComp = assertMatch mismatchTypes _Comp "[_] _" -- Elaboration diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 9806c47f6..17fe05b0f 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -103,7 +103,7 @@ synthInterface (S.Ann s _ (S.Interface h sp)) = pushSpan s $ do -- Assertions assertTypeConstructor :: (HasCallStack, Has (Throw Err) sig m) => Kind -> Elab m (Maybe Name, Kind, Kind) -assertTypeConstructor = assertMatch _KArrow "_ -> _" +assertTypeConstructor = assertMatch mismatchKinds _KArrow "_ -> _" -- Judgements @@ -111,4 +111,4 @@ assertTypeConstructor = assertMatch _KArrow "_ -> _" switch :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => m (a :==> Kind) -> Kind <==: m a switch m = Check $ \ _K -> do a :==> _KA <- m - a <$ unless (_KA == _K) (couldNotUnify (Exp (CK _K)) (Act (CK _KA))) + a <$ unless (_KA == _K) (couldNotUnifyKinds (Exp _K) (Act _KA)) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index b1e028a0e..54d745aed 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -72,7 +72,18 @@ printErrReason opts ctx = group . \case Zero -> pretty "0" One -> pretty "1" Many -> pretty "arbitrarily many" - Unify r (Exp exp) (Act act) -> reason r + UnifyType r (Exp exp) (Act act) -> reason r + <> hardline <> pretty "expected:" <> align exp' + <> hardline <> pretty " actual:" <> align act' + where + reason = \case + Mismatch -> pretty "mismatch" + Occurs v t -> reflow "infinite type:" <+> getPrint (print opts ctx (metavar v)) <+> reflow "occurs in" <+> getPrint (print opts ctx t) + exp' = either reflow (getPrint . print opts ctx) exp + act' = getPrint (print opts ctx act) + -- line things up nicely for e.g. wrapped function types + align = nest 2 . (flatAlt (line <> stimes (3 :: Int) space) mempty <>) + UnifyKind r (Exp exp) (Act act) -> reason r <> hardline <> pretty "expected:" <> align exp' <> hardline <> pretty " actual:" <> align act' where diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index 9c6caee12..c13ee16fe 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -39,19 +39,19 @@ import GHC.Stack unify :: (HasCallStack, Has (Throw Err) sig m) => Exp Type -> Act Type -> Elab m Type unify t1 t2 = runUnify t1 t2 (unifyType (getExp t1) (getAct t2)) -runUnify :: Has (Throw Err) sig m => Exp Type -> Act Type -> ThrowC Err (WithCallStack UnifyErrReason) (Elab m) a -> Elab m a -runUnify t1 t2 = runThrow (withCallStack (\ r -> makeErr (Unify r (Right . CT <$> t1) (CT <$> t2)))) +runUnify :: Has (Throw Err) sig m => Exp Type -> Act Type -> ThrowC Err (WithCallStack (UnifyErrReason Type)) (Elab m) a -> Elab m a +runUnify t1 t2 = runThrow (withCallStack (\ r -> makeErr (UnifyType r (Right <$> t1) t2))) -runUnifyMaybe :: Applicative m => ErrorC (WithCallStack UnifyErrReason) m a -> m (Maybe a) +runUnifyMaybe :: Applicative m => ErrorC (WithCallStack (UnifyErrReason Type)) m a -> m (Maybe a) runUnifyMaybe = runError (const (pure Nothing)) (pure . Just) -mismatch :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => m a -mismatch = withFrozenCallStack $ throwError $ WithCallStack GHC.Stack.callStack Mismatch +mismatch :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack (UnifyErrReason Type)) :+: Writer Usage) sig m) => m a +mismatch = withFrozenCallStack $ throwError $ WithCallStack GHC.Stack.callStack (Mismatch @Type) -occurs :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Type -> m a -occurs v t = withFrozenCallStack $ throwError $ WithCallStack GHC.Stack.callStack (Occurs v (CT t)) +occurs :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack (UnifyErrReason Type)) :+: Writer Usage) sig m) => Meta -> Type -> m a +occurs v t = withFrozenCallStack $ throwError $ WithCallStack GHC.Stack.callStack (Occurs v t) -unifyType :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Type -> Type -> m Type +unifyType :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack (UnifyErrReason Type)) :+: Writer Usage) sig m) => Type -> Type -> m Type unifyType = curry $ \case (TN.Comp s1 t1, TN.Comp s2 t2) -> TN.Comp . fromInterfaces <$> unifySpine unifyInterface (interfaces s1) (interfaces s2) <*> unifyType t1 t2 (TN.Comp s1 t1, t2) -> TN.Comp s1 <$> unifyType t1 t2 @@ -70,19 +70,19 @@ unifyType = curry $ \case where mkForAll d n k b = TX.ForAll n k (runQuoter (succ d) (quote b)) -unifyKind :: Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m => Kind -> Kind -> m Kind +unifyKind :: Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack (UnifyErrReason Type)) :+: Writer Usage) sig m => Kind -> Kind -> m Kind unifyKind k1 k2 = if k1 == k2 then pure k2 else mismatch -unifyVar :: (Eq a, Eq b, HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Var (Either a b) -> Var (Either a b) -> m (Var (Either a b)) +unifyVar :: (Eq a, Eq b, HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack (UnifyErrReason Type)) :+: Writer Usage) sig m) => Var (Either a b) -> Var (Either a b) -> m (Var (Either a b)) unifyVar v1 v2 = if v1 == v2 then pure v2 else mismatch -unifyInterface :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Interface Type -> Interface Type -> m (Interface Type) +unifyInterface :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack (UnifyErrReason Type)) :+: Writer Usage) sig m) => Interface Type -> Interface Type -> m (Interface Type) unifyInterface (Interface h1 sp1) (Interface h2 sp2) = Interface h2 <$ unless (h1 == h2) mismatch <*> unifySpine unifyType sp1 sp2 -unifySpine :: (Traversable t, Zip t, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => (a -> b -> m c) -> t a -> t b -> m (t c) +unifySpine :: (Traversable t, Zip t, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack (UnifyErrReason Type)) :+: Writer Usage) sig m) => (a -> b -> m c) -> t a -> t b -> m (t c) unifySpine f sp1 sp2 = unless (length sp1 == length sp2) mismatch >> zipWithM f sp1 sp2 -flexFlex :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Meta -> m Type +flexFlex :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack (UnifyErrReason Type)) :+: Writer Usage) sig m) => Meta -> Meta -> m Type flexFlex v1 v2 | v1 == v2 = pure (metavar v2) | otherwise = gets (\ s -> (lookupMeta v1 s, lookupMeta v2 s)) >>= \case @@ -91,7 +91,7 @@ flexFlex v1 v2 (Nothing, Just t2) -> unifyType (metavar v1) t2 (Nothing, Nothing) -> solve v1 (metavar v2) -solve :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Type -> m Type +solve :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack (UnifyErrReason Type)) :+: Writer Usage) sig m) => Meta -> Type -> m Type solve v t = do d <- depth if occursIn v (getUsed d) t then From 581c7e12074d9d0b7391a12151bdfd94312fe087 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 20:07:01 -0400 Subject: [PATCH 0912/1324] Specialize Hole to Type. --- src/Facet/Elab.hs | 7 ++----- src/Facet/Elab/Term.hs | 2 +- 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index d9837a6ba..4a36cecbf 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -216,7 +216,7 @@ data ErrReason | ResourceMismatch Name Quantity Quantity | UnifyType (UnifyErrReason Type) (Exp (Either String Type)) (Act Type) | UnifyKind (UnifyErrReason Type) (Exp (Either String Kind)) (Act Kind) - | Hole Name Classifier + | Hole Name Type | Invariant String | MissingInterface (Interface Type) @@ -258,13 +258,10 @@ applySubst ctx subst r = case r of -- NB: not substituting in @r@ because we want to retain the cyclic occurrence (and finitely) UnifyType r exp act -> UnifyType r (fmap roundtrip <$> exp) (roundtrip <$> act) UnifyKind{} -> r - Hole n t -> Hole n (roundtripS t) + Hole n t -> Hole n (roundtrip t) Invariant{} -> r MissingInterface i -> MissingInterface (roundtrip <$> i) where - roundtripS = \case - CK k -> CK k - CT k -> CT $ roundtrip k roundtrip = apply subst (toEnv ctx) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 3919fb197..e6adb1f6e 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -156,7 +156,7 @@ varS n = views context_ (lookupInContext n) >>= \case hole :: (HasCallStack, Has (Throw Err) sig m) => Name -> Type <==: Elab m a -hole n = Check $ \ _T -> withFrozenCallStack $ err $ Hole n (CT _T) +hole n = Check $ \ _T -> withFrozenCallStack $ err $ Hole n _T tlam :: (HasCallStack, Has (Throw Err) sig m) => Type <==: Elab m Term -> Type <==: Elab m Term From 1f9fcd75898ff1b0b2ec83385bc55d7b65df3f34 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 20:07:28 -0400 Subject: [PATCH 0913/1324] :fire: the obsolete Printable instance for Classifier. --- src/Facet/Print.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 4e4e333a1..5adadd10e 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -153,11 +153,6 @@ instance Printable Print where instance (Quote v t, Printable t) => Printable (Quoting t v) where print opts env = print opts env . runQuoter (level env) . quote . getQuoting -instance Printable TN.Classifier where - print opts env = \case - TN.CK k -> print opts env k - TN.CT t -> print opts env t - instance Printable Kind where print opts env = \case KType -> annotate Type $ pretty "Type" From 2e7b77aecd02d89eb1d8509d23147a56f8fd6414 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 20:08:00 -0400 Subject: [PATCH 0914/1324] :fire: classification. --- src/Facet/Type/Norm.hs | 16 ---------------- 1 file changed, 16 deletions(-) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 18bd1cfb0..b77454518 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -11,8 +11,6 @@ module Facet.Type.Norm , metavar , unNeutral , unComp -, Classifier(..) -, Classified(..) , occursIn -- ** Elimination , ($$) @@ -110,20 +108,6 @@ unComp = \case _T -> empty -data Classifier - = CK Kind - | CT Type - -class Classified t where - classified :: t -> Classifier - -instance Classified Kind where - classified = CK - -instance Classified Type where - classified = CT - - occursIn :: Meta -> Level -> Type -> Bool occursIn p = go where From ec82b6b446f7cfa26039e36b6d646194301ea62f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 20:09:59 -0400 Subject: [PATCH 0915/1324] Kind unification errors are always mismatches. --- src/Facet/Elab.hs | 4 ++-- src/Facet/Notice/Elab.hs | 5 +---- 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 4a36cecbf..e88528905 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -215,7 +215,7 @@ data ErrReason | CouldNotSynthesize | ResourceMismatch Name Quantity Quantity | UnifyType (UnifyErrReason Type) (Exp (Either String Type)) (Act Type) - | UnifyKind (UnifyErrReason Type) (Exp (Either String Kind)) (Act Kind) + | UnifyKind (Exp (Either String Kind)) (Act Kind) | Hole Name Type | Invariant String | MissingInterface (Interface Type) @@ -279,7 +279,7 @@ mismatchTypes :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext mismatchTypes exp act = withFrozenCallStack $ err $ UnifyType Mismatch exp act mismatchKinds :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m) => Exp (Either String Kind) -> Act Kind -> m a -mismatchKinds exp act = withFrozenCallStack $ err $ UnifyKind Mismatch exp act +mismatchKinds exp act = withFrozenCallStack $ err $ UnifyKind exp act couldNotUnifyKinds :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m) => Exp Kind -> Act Kind -> m a couldNotUnifyKinds t1 t2 = withFrozenCallStack $ mismatchKinds (Right <$> t1) t2 diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 54d745aed..30e07548e 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -83,13 +83,10 @@ printErrReason opts ctx = group . \case act' = getPrint (print opts ctx act) -- line things up nicely for e.g. wrapped function types align = nest 2 . (flatAlt (line <> stimes (3 :: Int) space) mempty <>) - UnifyKind r (Exp exp) (Act act) -> reason r + UnifyKind (Exp exp) (Act act) -> pretty "mismatch" <> hardline <> pretty "expected:" <> align exp' <> hardline <> pretty " actual:" <> align act' where - reason = \case - Mismatch -> pretty "mismatch" - Occurs v t -> reflow "infinite type:" <+> getPrint (print opts ctx (metavar v)) <+> reflow "occurs in" <+> getPrint (print opts ctx t) exp' = either reflow (getPrint . print opts ctx) exp act' = getPrint (print opts ctx act) -- line things up nicely for e.g. wrapped function types From afe5ad8470b0f85dbf58f2a71cf794b62b430760 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 20:12:03 -0400 Subject: [PATCH 0916/1324] Specialize UnifyErrReason to Type. --- src/Facet/Elab.hs | 20 ++++++++++---------- src/Facet/Unify.hs | 24 ++++++++++++------------ 2 files changed, 22 insertions(+), 22 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index e88528905..9e7053d1b 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -93,7 +93,7 @@ import Facet.Usage as Usage import Facet.Vars as Vars import Fresnel.Fold ((^?)) import Fresnel.Lens (Lens', lens) -import Fresnel.Prism (Prism, Prism', prism, prism') +import Fresnel.Prism (Prism', prism') import GHC.Stack import Prelude hiding (span, zipWith) @@ -214,7 +214,7 @@ data ErrReason | AmbiguousName QName [RName] | CouldNotSynthesize | ResourceMismatch Name Quantity Quantity - | UnifyType (UnifyErrReason Type) (Exp (Either String Type)) (Act Type) + | UnifyType UnifyErrReason (Exp (Either String Type)) (Act Type) | UnifyKind (Exp (Either String Kind)) (Act Kind) | Hole Name Type | Invariant String @@ -230,24 +230,24 @@ _AmbiguousName = prism' (uncurry AmbiguousName) (\case AmbiguousName n ns -> Just (n, ns) _ -> Nothing) -_UnifyType :: Prism' ErrReason (UnifyErrReason Type, Exp (Either String Type), Act Type) +_UnifyType :: Prism' ErrReason (UnifyErrReason, Exp (Either String Type), Act Type) _UnifyType = prism' (\ (r, x, a) -> UnifyType r x a) (\case UnifyType r x a -> Just (r, x, a) _ -> Nothing) -data UnifyErrReason t +data UnifyErrReason = Mismatch - | Occurs Meta t + | Occurs Meta Type -_Mismatch :: Prism' (UnifyErrReason t) () +_Mismatch :: Prism' UnifyErrReason () _Mismatch = prism' (const Mismatch) (\case Mismatch -> Just () _ -> Nothing) -_Occurs :: Prism (UnifyErrReason s) (UnifyErrReason t) (Meta, s) (Meta, t) -_Occurs = prism (uncurry Occurs) (\case - Occurs v c -> Right (v, c) - Mismatch -> Left Mismatch) +_Occurs :: Prism' UnifyErrReason (Meta, Type) +_Occurs = prism' (uncurry Occurs) (\case + Occurs v c -> Just (v, c) + _ -> Nothing) applySubst :: Context -> Subst Type -> ErrReason -> ErrReason applySubst ctx subst r = case r of diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index c13ee16fe..a4507d009 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -39,19 +39,19 @@ import GHC.Stack unify :: (HasCallStack, Has (Throw Err) sig m) => Exp Type -> Act Type -> Elab m Type unify t1 t2 = runUnify t1 t2 (unifyType (getExp t1) (getAct t2)) -runUnify :: Has (Throw Err) sig m => Exp Type -> Act Type -> ThrowC Err (WithCallStack (UnifyErrReason Type)) (Elab m) a -> Elab m a +runUnify :: Has (Throw Err) sig m => Exp Type -> Act Type -> ThrowC Err (WithCallStack UnifyErrReason) (Elab m) a -> Elab m a runUnify t1 t2 = runThrow (withCallStack (\ r -> makeErr (UnifyType r (Right <$> t1) t2))) -runUnifyMaybe :: Applicative m => ErrorC (WithCallStack (UnifyErrReason Type)) m a -> m (Maybe a) +runUnifyMaybe :: Applicative m => ErrorC (WithCallStack UnifyErrReason) m a -> m (Maybe a) runUnifyMaybe = runError (const (pure Nothing)) (pure . Just) -mismatch :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack (UnifyErrReason Type)) :+: Writer Usage) sig m) => m a -mismatch = withFrozenCallStack $ throwError $ WithCallStack GHC.Stack.callStack (Mismatch @Type) +mismatch :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => m a +mismatch = withFrozenCallStack $ throwError $ WithCallStack GHC.Stack.callStack Mismatch -occurs :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack (UnifyErrReason Type)) :+: Writer Usage) sig m) => Meta -> Type -> m a +occurs :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Type -> m a occurs v t = withFrozenCallStack $ throwError $ WithCallStack GHC.Stack.callStack (Occurs v t) -unifyType :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack (UnifyErrReason Type)) :+: Writer Usage) sig m) => Type -> Type -> m Type +unifyType :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Type -> Type -> m Type unifyType = curry $ \case (TN.Comp s1 t1, TN.Comp s2 t2) -> TN.Comp . fromInterfaces <$> unifySpine unifyInterface (interfaces s1) (interfaces s2) <*> unifyType t1 t2 (TN.Comp s1 t1, t2) -> TN.Comp s1 <$> unifyType t1 t2 @@ -70,19 +70,19 @@ unifyType = curry $ \case where mkForAll d n k b = TX.ForAll n k (runQuoter (succ d) (quote b)) -unifyKind :: Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack (UnifyErrReason Type)) :+: Writer Usage) sig m => Kind -> Kind -> m Kind +unifyKind :: Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m => Kind -> Kind -> m Kind unifyKind k1 k2 = if k1 == k2 then pure k2 else mismatch -unifyVar :: (Eq a, Eq b, HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack (UnifyErrReason Type)) :+: Writer Usage) sig m) => Var (Either a b) -> Var (Either a b) -> m (Var (Either a b)) +unifyVar :: (Eq a, Eq b, HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Var (Either a b) -> Var (Either a b) -> m (Var (Either a b)) unifyVar v1 v2 = if v1 == v2 then pure v2 else mismatch -unifyInterface :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack (UnifyErrReason Type)) :+: Writer Usage) sig m) => Interface Type -> Interface Type -> m (Interface Type) +unifyInterface :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Interface Type -> Interface Type -> m (Interface Type) unifyInterface (Interface h1 sp1) (Interface h2 sp2) = Interface h2 <$ unless (h1 == h2) mismatch <*> unifySpine unifyType sp1 sp2 -unifySpine :: (Traversable t, Zip t, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack (UnifyErrReason Type)) :+: Writer Usage) sig m) => (a -> b -> m c) -> t a -> t b -> m (t c) +unifySpine :: (Traversable t, Zip t, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => (a -> b -> m c) -> t a -> t b -> m (t c) unifySpine f sp1 sp2 = unless (length sp1 == length sp2) mismatch >> zipWithM f sp1 sp2 -flexFlex :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack (UnifyErrReason Type)) :+: Writer Usage) sig m) => Meta -> Meta -> m Type +flexFlex :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Meta -> m Type flexFlex v1 v2 | v1 == v2 = pure (metavar v2) | otherwise = gets (\ s -> (lookupMeta v1 s, lookupMeta v2 s)) >>= \case @@ -91,7 +91,7 @@ flexFlex v1 v2 (Nothing, Just t2) -> unifyType (metavar v1) t2 (Nothing, Nothing) -> solve v1 (metavar v2) -solve :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack (UnifyErrReason Type)) :+: Writer Usage) sig m) => Meta -> Type -> m Type +solve :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Type -> m Type solve v t = do d <- depth if occursIn v (getUsed d) t then From 885d3bd7e13dd739a344aca101f18050e646b8f2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 Mar 2022 20:12:08 -0400 Subject: [PATCH 0917/1324] Spacing. --- src/Facet/Unify.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index a4507d009..c1238c202 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -49,7 +49,7 @@ mismatch :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: mismatch = withFrozenCallStack $ throwError $ WithCallStack GHC.Stack.callStack Mismatch occurs :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Type -> m a -occurs v t = withFrozenCallStack $ throwError $ WithCallStack GHC.Stack.callStack (Occurs v t) +occurs v t = withFrozenCallStack $ throwError $ WithCallStack GHC.Stack.callStack (Occurs v t) unifyType :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Type -> Type -> m Type unifyType = curry $ \case From 4169be457ff6d501b9444a54727e14de831349d8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 25 Mar 2022 07:10:05 -0400 Subject: [PATCH 0918/1324] Define a module for core sequent types. --- facet.cabal | 1 + src/Facet/Sequent/Type.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Sequent/Type.hs diff --git a/facet.cabal b/facet.cabal index d02d5d694..22e6d94b3 100644 --- a/facet.cabal +++ b/facet.cabal @@ -125,6 +125,7 @@ library Facet.Sequent.Expr Facet.Sequent.Norm Facet.Sequent.Print + Facet.Sequent.Type Facet.Snoc Facet.Snoc.NonEmpty Facet.Source diff --git a/src/Facet/Sequent/Type.hs b/src/Facet/Sequent/Type.hs new file mode 100644 index 000000000..2a89300c0 --- /dev/null +++ b/src/Facet/Sequent/Type.hs @@ -0,0 +1,2 @@ +module Facet.Sequent.Type +() where From f6d97e5b245753645fd4bcef88b5be6ad81dbf6c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 25 Mar 2022 07:11:04 -0400 Subject: [PATCH 0919/1324] Move Type into its own module. --- src/Facet/Elab/Pattern.hs | 15 +-------------- src/Facet/Sequent/Type.hs | 15 ++++++++++++++- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index b368ef929..7e343aa1f 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -4,7 +4,6 @@ module Facet.Elab.Pattern ( Pattern(..) , Clause(..) , patterns_ -, Type(..) -- * Coverage judgement , compilePattern ) where @@ -17,6 +16,7 @@ import Data.Monoid (First(..)) import Data.Traversable (for) import Facet.Name import qualified Facet.Sequent.Class as SQ +import Facet.Sequent.Type import Facet.Syntax ((:::)(..)) import Fresnel.Fold (Fold, Union(..), preview) import Fresnel.Getter (to) @@ -84,19 +84,6 @@ patterns_ :: Lens' (Clause a) [Pattern Name] patterns_ = lens patterns (\ c patterns -> c{patterns}) -data Type - = Opaque - | One - | Type :+ Type - | Type :* Type - | Type :-> Type - deriving (Eq, Ord, Show) - -infixl 6 :+ -infixl 7 :* -infixr 1 :-> - - -- Coverage judgement instantiateHead :: Pattern Name -> Pattern Name diff --git a/src/Facet/Sequent/Type.hs b/src/Facet/Sequent/Type.hs index 2a89300c0..06e9c8a2d 100644 --- a/src/Facet/Sequent/Type.hs +++ b/src/Facet/Sequent/Type.hs @@ -1,2 +1,15 @@ module Facet.Sequent.Type -() where +( Type(..) +) where + +data Type + = Opaque + | One + | Type :+ Type + | Type :* Type + | Type :-> Type + deriving (Eq, Ord, Show) + +infixl 6 :+ +infixl 7 :* +infixr 1 :-> From 996628e6102db6ed1facfb18cf952ef50e76967d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 25 Mar 2022 07:11:56 -0400 Subject: [PATCH 0920/1324] Define a module for core sequent patterns. --- facet.cabal | 1 + src/Facet/Sequent/Pattern.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Sequent/Pattern.hs diff --git a/facet.cabal b/facet.cabal index 22e6d94b3..3d87f06bd 100644 --- a/facet.cabal +++ b/facet.cabal @@ -124,6 +124,7 @@ library Facet.Sequent.Class Facet.Sequent.Expr Facet.Sequent.Norm + Facet.Sequent.Pattern Facet.Sequent.Print Facet.Sequent.Type Facet.Snoc diff --git a/src/Facet/Sequent/Pattern.hs b/src/Facet/Sequent/Pattern.hs new file mode 100644 index 000000000..ff2e811ac --- /dev/null +++ b/src/Facet/Sequent/Pattern.hs @@ -0,0 +1,2 @@ +module Facet.Sequent.Pattern +() where From 018d68aeba434b639ab6ffd643a879ffa74ea5e7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 25 Mar 2022 07:13:51 -0400 Subject: [PATCH 0921/1324] Move Pattern into its own module. --- src/Facet/Elab/Pattern.hs | 60 ++------------------------------ src/Facet/Sequent/Pattern.hs | 66 +++++++++++++++++++++++++++++++++++- 2 files changed, 67 insertions(+), 59 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 7e343aa1f..5a3133b63 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -1,83 +1,27 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE UndecidableInstances #-} module Facet.Elab.Pattern -( Pattern(..) -, Clause(..) +( Clause(..) , patterns_ -- * Coverage judgement , compilePattern ) where import Control.Effect.Empty -import Control.Monad (ap) import Data.Bifunctor (first) import Data.Foldable (fold) import Data.Monoid (First(..)) import Data.Traversable (for) import Facet.Name import qualified Facet.Sequent.Class as SQ +import Facet.Sequent.Pattern import Facet.Sequent.Type import Facet.Syntax ((:::)(..)) import Fresnel.Fold (Fold, Union(..), preview) import Fresnel.Getter (to) import Fresnel.Lens (Lens', lens) -import Fresnel.Prism (Prism', prism') import Fresnel.Traversal (forOf, traversed) -data Pattern a - = Wildcard - | Var a - | Unit - | InL (Pattern a) - | InR (Pattern a) - | Pair (Pattern a) (Pattern a) - deriving (Eq, Foldable, Functor, Ord, Show, Traversable) - -instance Applicative Pattern where - pure = Var - (<*>) = ap - -instance Monad Pattern where - m >>= f = case m of - Wildcard -> Wildcard - Var a -> f a - Unit -> Unit - InL p -> InL (p >>= f) - InR q -> InR (q >>= f) - Pair p q -> Pair (p >>= f) (q >>= f) - - -_Wildcard :: Prism' (Pattern a) () -_Wildcard = prism' (const Wildcard) (\case - Wildcard -> Just () - _ -> Nothing) - -_Var :: Prism' (Pattern a) a -_Var = prism' Var (\case - Var a -> Just a - _ -> Nothing) - -_Unit :: Prism' (Pattern a) () -_Unit = prism' (const Unit) (\case - Unit -> Just () - _ -> Nothing) - -_InL :: Prism' (Pattern a) (Pattern a) -_InL = prism' InL (\case - InL p -> Just p - _ -> Nothing) - -_InR :: Prism' (Pattern a) (Pattern a) -_InR = prism' InR (\case - InR p -> Just p - _ -> Nothing) - -_Pair :: Prism' (Pattern a) (Pattern a, Pattern a) -_Pair = prism' (uncurry Pair) (\case - Pair p q -> Just (p, q) - _ -> Nothing) - - data Clause a = Clause { patterns :: [Pattern Name], body :: a } patterns_ :: Lens' (Clause a) [Pattern Name] diff --git a/src/Facet/Sequent/Pattern.hs b/src/Facet/Sequent/Pattern.hs index ff2e811ac..bc8a3cebc 100644 --- a/src/Facet/Sequent/Pattern.hs +++ b/src/Facet/Sequent/Pattern.hs @@ -1,2 +1,66 @@ module Facet.Sequent.Pattern -() where +( Pattern(..) + -- * Prisms +, _Wildcard +, _Var +, _Unit +, _InL +, _InR +, _Pair +) where + +import Control.Monad (ap) +import Fresnel.Prism (Prism', prism') + +data Pattern a + = Wildcard + | Var a + | Unit + | InL (Pattern a) + | InR (Pattern a) + | Pair (Pattern a) (Pattern a) + deriving (Eq, Foldable, Functor, Ord, Show, Traversable) + +instance Applicative Pattern where + pure = Var + (<*>) = ap + +instance Monad Pattern where + m >>= f = case m of + Wildcard -> Wildcard + Var a -> f a + Unit -> Unit + InL p -> InL (p >>= f) + InR q -> InR (q >>= f) + Pair p q -> Pair (p >>= f) (q >>= f) + + +_Wildcard :: Prism' (Pattern a) () +_Wildcard = prism' (const Wildcard) (\case + Wildcard -> Just () + _ -> Nothing) + +_Var :: Prism' (Pattern a) a +_Var = prism' Var (\case + Var a -> Just a + _ -> Nothing) + +_Unit :: Prism' (Pattern a) () +_Unit = prism' (const Unit) (\case + Unit -> Just () + _ -> Nothing) + +_InL :: Prism' (Pattern a) (Pattern a) +_InL = prism' InL (\case + InL p -> Just p + _ -> Nothing) + +_InR :: Prism' (Pattern a) (Pattern a) +_InR = prism' InR (\case + InR p -> Just p + _ -> Nothing) + +_Pair :: Prism' (Pattern a) (Pattern a, Pattern a) +_Pair = prism' (uncurry Pair) (\case + Pair p q -> Just (p, q) + _ -> Nothing) From 0e6d14757910c7f53a71a543d12ec99b3d1310a4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 25 Mar 2022 07:45:55 -0400 Subject: [PATCH 0922/1324] :fire: the old pattern coverage code. --- src/Facet/Elab/Term.hs | 94 +----------------------------------------- 1 file changed, 2 insertions(+), 92 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index e6adb1f6e..1fce79f28 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -25,8 +25,6 @@ module Facet.Elab.Term , conP , fieldsP , allP - -- * Pattern compilation -, coverTableau -- * Expression elaboration , synthExpr , checkExpr @@ -46,13 +44,9 @@ module Facet.Elab.Term ) where import Control.Algebra -import Control.Applicative (liftA2) -import Control.Carrier.Empty.Church -import Control.Carrier.NonDet.Church hiding (Alternative(..), guard) import Control.Carrier.Reader import Control.Carrier.State.Church import Control.Carrier.Writer.Church -import Control.Effect.Choose import Control.Effect.Throw import Data.Bifunctor (first) import Data.Either (partitionEithers) @@ -94,15 +88,11 @@ import Facet.Type.Norm as T hiding (global) import Facet.Unify import Facet.Usage hiding (restrict) import Fresnel.At as At -import Fresnel.Fold (Fold, Union(..), allOf, folded, forOf_, has, preview) -import Fresnel.Getter (to) -import Fresnel.Iso (Iso', coerced) import Fresnel.Ixed -import Fresnel.List (head_) import Fresnel.Prism (Prism') import Fresnel.Review (review) -import Fresnel.Setter (Setter', (%~)) -import Fresnel.Traversal (Traversal', traversed) +import Fresnel.Setter (Setter') +import Fresnel.Traversal (Traversal') import GHC.Stack -- General combinators @@ -253,86 +243,6 @@ allP n = Bind $ \ _A k -> do k (PVar (n :==> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (T.Comp sig _T))) --- Pattern compilation - -newtype Clause = Clause [Pattern ()] - -patterns_ :: Iso' Clause [Pattern ()] -patterns_ = coerced - -newtype Tableau = Tableau [Clause] - -clauses_ :: Iso' Tableau [Clause] -clauses_ = coerced - -type Ctx = [Type] - -data Branch s m = forall x . Branch (Fold s x) (x -> m ()) - -coverTableau :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> m Bool -coverTableau tableau context = runNonDet (liftA2 (&&)) (const (pure True)) (pure False) (coverClauses tableau context) - -coverClauses :: (HasCallStack, Has NonDet sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> m () -coverClauses tableau = \case - T.String:ctx -> everyClauseHead tableau - [ Branch (_PWildcard ||| _PVar) (const (coverClauses (dropClauseHead tableau) ctx)) ] - -- FIXME: type patterns to bind type variables? - T.ForAll{}:ctx -> everyClauseHead tableau - [ Branch (_PWildcard ||| _PVar) (const (coverClauses (dropClauseHead tableau) ctx)) ] - T.Arrow{}:ctx -> everyClauseHead tableau - [ Branch (_PWildcard ||| _PVar) (const (coverClauses (dropClauseHead tableau) ctx)) ] - c@(T.Ne h _:_) -> case h of - Global n -> resolveQ (toQ n) >>= \case - _ :=: DSubmodule (SData scope) _ -> decomposeSum tableau c (scopeToList scope) - _ -> empty - _ -> empty - T.Comp{}:_ -> empty -- resolve signature, then treat as effect patterns - [] -> eachClauseHead null tableau - -decomposeSum :: (HasCallStack, Has NonDet sig m, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Tableau -> Ctx -> [Name :=: Def] -> m () -decomposeSum tableau ctx = \case - [] -> empty - xs -> let partitions = tableauPartitions tableau ctx xs in getChoosing (foldMap (\ (tableau', ctx') -> Choosing (coverClauses tableau' ctx')) partitions) - -tableauPartitions :: Tableau -> Ctx -> [Name :=: Def] -> [(Tableau, Ctx)] --- FIXME: check for inapplicable patterns in tableau -tableauPartitions _ _ [] = [] -tableauPartitions tableau ctx ((n :=: d):cs) = - let (tableau', tableau'') = partitionTableau tableau n in - case d of - DTerm _ ty -> (tableau', typeOf ty <> ctx):tableauPartitions tableau'' ctx cs - _ -> [] - -partitionTableau :: Tableau -> Name -> (Tableau, Tableau) -partitionTableau (Tableau clauses) name = - ( Tableau (filter (has (patterns_.head_.(to conMatches ||| _PWildcard ||| _PVar))) clauses) - , Tableau (filter (has (patterns_.head_.(to (not . conMatches) ||| _PWildcard ||| _PVar))) clauses) ) - where - conMatches (PCon (_:.:name') _) = name == name' - conMatches _ = False - -typeOf :: Type -> Ctx -typeOf = \case - T.Arrow _ _ _A _B -> _A : typeOf _B - _T -> [_T] - -dropClauseHead :: Tableau -> Tableau -dropClauseHead = clauses_.traversed.patterns_ %~ drop 1 - -eachClauseHead :: Has Empty sig m => (Pattern () -> Bool) -> Tableau -> m () -eachClauseHead pred = guard . allOf (clauses_.folded.patterns_.folded) pred - -everyClauseHead :: Has Empty sig m => Tableau -> [Branch (Pattern ()) m] -> m () -everyClauseHead tableau = go where - go [] = empty - go (Branch b k:bs) = forOf_ (clauses_.folded.patterns_.head_) tableau (maybe (go bs) k . preview b) - -(|||) :: Fold s a1 -> Fold s a2 -> Fold s () -p ||| q = getUnion (Union (p . to (const ())) <> Union (q . to (const ()))) - -infixr 2 ||| - - -- Expression elaboration synthExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Elab m (Term :==> Type) From 23f8fdbb6aa4fb82a7c6274645c0f509e61bebf4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 25 Mar 2022 10:12:40 -0400 Subject: [PATCH 0923/1324] Correct docs. --- src/Facet/Elab/Term.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 1fce79f28..fc0ee21e8 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -287,9 +287,9 @@ bindPattern = withSpanB $ \case S.PCon n ps -> conP n (map bindPattern ps) --- | Elaborate a type abstracted over another type’s parameters. +-- | Elaborate a type abstracted over a kind’s parameters. -- --- This is used to elaborate data constructors & effect operations, which receive the type/interface parameters as implicit parameters ahead of their own explicit ones. +-- This is used to elaborate data constructors & effect operations, which receive the type/interface's kind's parameters as implicit parameters ahead of their own explicit ones. abstractType :: Has (Reader ElabContext) sig m => m TX.Type -> Kind -> m TX.Type abstractType body = \case KArrow (Just n) a b -> TX.ForAll n a <$> (n :==> a ||- abstractType body b) From 95c864086a421690ca3f59061edf92a09dcbd36d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 00:07:44 -0400 Subject: [PATCH 0924/1324] Add unit (co)terms. --- src/Facet/Sequent/Class.hs | 2 ++ src/Facet/Sequent/Expr.hs | 6 ++++++ src/Facet/Sequent/Norm.hs | 6 ++++++ src/Facet/Sequent/Print.hs | 2 ++ 4 files changed, 16 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 27d61f224..23732c83c 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -37,6 +37,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma lamR :: (term -> coterm -> command) -> term sumR1 :: term -> term sumR2 :: term -> term + unitR :: term prdR :: term -> term -> term stringR :: Text -> term @@ -45,6 +46,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma µL :: (term -> command) -> coterm lamL :: term -> coterm -> coterm sumL :: coterm -> coterm -> coterm + unitL :: coterm prdL1 :: coterm -> coterm prdL2 :: coterm -> coterm diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 4e1396615..139324703 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -26,6 +26,7 @@ data Term | LamR Command | SumR1 Term | SumR2 Term + | UnitR | PrdR Term Term | StringR Text @@ -37,6 +38,7 @@ data Coterm | MuL Command | LamL Term Coterm | SumL Coterm Coterm + | UnitL | PrdL1 Coterm | PrdL2 Coterm @@ -54,6 +56,7 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where lamR b = LamR <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) (\ t -> binder (\ d'' -> Quoter (\ d -> covar (toIndexed d d''))) (b t)) sumR1 = fmap SumR1 sumR2 = fmap SumR2 + unitR = pure UnitR prdR l r = PrdR <$> l <*> r stringR = pure . StringR @@ -61,6 +64,7 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where µL b = MuL <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b lamL a b = LamL <$> a <*> b sumL l r = SumL <$> l <*> r + unitL = pure UnitL prdL1 b = PrdL1 <$> b prdL2 b = PrdL2 <$> b @@ -82,6 +86,7 @@ interpretTerm _G _D = \case LamR b -> C.lamR (\ a k -> interpretCommand (a:_G) (k:_D) b) SumR1 t -> C.sumR1 (interpretTerm _G _D t) SumR2 t -> C.sumR2 (interpretTerm _G _D t) + UnitR -> C.unitR PrdR l r -> C.prdR (interpretTerm _G _D l) (interpretTerm _G _D r) StringR s -> C.stringR s @@ -92,6 +97,7 @@ interpretCoterm _G _D = \case MuL b -> C.µL (\ t -> interpretCommand (t:_G) _D b) LamL a k -> C.lamL (interpretTerm _G _D a) (interpretCoterm _G _D k) SumL l r -> C.sumL (interpretCoterm _G _D l) (interpretCoterm _G _D r) + UnitL -> C.unitL PrdL1 c -> C.prdL1 (interpretCoterm _G _D c) PrdL2 c -> C.prdL2 (interpretCoterm _G _D c) diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index 353f196a8..b12d24d4f 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -23,6 +23,7 @@ data Term | LamR (Term -> Coterm -> Command) | SumR1 Term | SumR2 Term + | UnitR | PrdR Term Term | StringR Text @@ -34,6 +35,7 @@ data Coterm | MuL (Term -> Command) | LamL Term Coterm | SumL Coterm Coterm + | UnitL | PrdL1 Coterm | PrdL2 Coterm @@ -51,6 +53,7 @@ instance Class.Sequent Term Coterm Command where lamR = LamR sumR1 = SumR1 sumR2 = SumR2 + unitR = UnitR prdR = PrdR stringR = StringR @@ -58,6 +61,7 @@ instance Class.Sequent Term Coterm Command where µL = MuL lamL = LamL sumL = SumL + unitL = UnitL prdL1 = PrdL1 prdL2 = PrdL2 @@ -72,6 +76,7 @@ instance Quote Term X.Term where LamR b -> X.LamR <$> Quoter (\ d -> runQuoter (d + 2) (quote (b (Var (Free (getUsed d))) (Covar (Free (getUsed (d + 1))))))) SumR1 t -> X.SumR1 <$> quote t SumR2 t -> X.SumR2 <$> quote t + UnitR -> pure X.UnitR PrdR l r -> X.PrdR <$> quote l <*> quote r StringR t -> pure (X.StringR t) @@ -85,6 +90,7 @@ instance Quote Coterm X.Coterm where MuL b -> X.MuL <$> quoteBinder (Quoter var) b LamL a b -> liftA2 X.LamL (quote a) (quote b) SumL l r -> X.SumL <$> quote l <*> quote r + UnitL -> pure X.UnitL PrdL1 k -> X.PrdL1 <$> quote k PrdL2 k -> X.PrdL2 <$> quote k diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index 1c84b6403..1d085947c 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -30,6 +30,7 @@ instance S.Sequent Print Print Print where lamR c = P.braces (fresh (\ u -> fresh (\ v -> P.brackets (anon u <> P.comma P.<+> anon v) P.<+> P.pretty "->" P.<+> c (anon u) (anon v)))) sumR1 t = P.parens (P.pretty "inl" P.<+> t) sumR2 t = P.parens (P.pretty "inr" P.<+> t) + unitR = P.parens mempty prdR l r = P.tupled [l, r] stringR = P.pretty . show @@ -37,6 +38,7 @@ instance S.Sequent Print Print Print where µL b = µ̃ <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) lamL a k = a P.<+> P.dot P.<+> k sumL l r = P.pretty "case" <> P.braces (commaSep [l, r]) + unitL = P.pretty "_" prdL1 k = P.parens (µ̃ <> P.braces (P.pretty "πl" P.<+> k)) prdL2 k = P.parens (µ̃ <> P.braces (P.pretty "πr" P.<+> k)) From 7a399f6c819cf1c8f5afffa4a53025af7916dc26 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 08:40:32 -0400 Subject: [PATCH 0925/1324] Reformat sums. --- src/Facet/Elab/Pattern.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 5a3133b63..aeb765d5c 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -54,7 +54,9 @@ compilePattern ty heads = case ty of Wildcard -> pure ([Clause (Wildcard:ps) b], [Clause (Wildcard:ps) b]) _ -> empty _ -> empty) - pure u SQ..||. SQ.sumLA (SQ.µLA (\ wk a -> compilePattern ((a ::: _A):map (first wk) ts) headsL)) (SQ.µLA (\ wk b -> compilePattern ((b ::: _B):map (first wk) ts) headsR)) + pure u SQ..||. SQ.sumLA + (SQ.µLA (\ wk a -> compilePattern ((a ::: _A):map (first wk) ts) headsL)) + (SQ.µLA (\ wk b -> compilePattern ((b ::: _B):map (first wk) ts) headsR)) [] | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) -> pure (pure b) _ -> empty From f07f38faf9bdd931231ddef23c698ea1bdb51f36 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 11:29:05 -0400 Subject: [PATCH 0926/1324] Compile patterns to terms. --- src/Facet/Elab/Pattern.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index aeb765d5c..bcc20a45a 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -35,17 +35,17 @@ instantiateHead (Var _) = Wildcard -- FIXME: let-bind any variables first instantiateHead p = p -compilePattern :: (Has Empty sig m, SQ.Sequent term coterm command, Applicative i) => [i term ::: Type] -> [Clause command] -> m (i command) -compilePattern ty heads = case ty of - (_ ::: Opaque):ts -> match (_Wildcard.to (const [])) heads >>= compilePattern ts - (_ ::: (_ :-> _)):ts -> match (_Wildcard.to (const [])) heads >>= compilePattern ts - (_ ::: One):ts -> match (_Unit.to (const [])) heads >>= compilePattern ts +compilePattern :: (Has Empty sig m, SQ.Sequent term coterm command, Applicative i) => [i term ::: Type] -> [Clause command] -> m (i term) +compilePattern ty heads = SQ.lamRA $ \ wk _v k -> case ty of + (_ ::: Opaque):ts -> (match (_Wildcard.to (const [])) heads >>= compilePattern (map (first wk) ts)) SQ..||. pure k + (_ ::: (_ :-> _)):ts -> (match (_Wildcard.to (const [])) heads >>= compilePattern (map (first wk) ts)) SQ..||. pure k + (_ ::: One):ts -> (match (_Unit.to (const [])) heads >>= compilePattern (map (first wk) ts)) SQ..||. pure k (u ::: _A :* _B):ts -> do heads' <- match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Wildcard.to (const [Wildcard, Wildcard])))) heads let a wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL1A (pure k)) b wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL2A (pure k)) - SQ.letA (a id) (\ wkA a -> SQ.letA (b wkA) (\ wkB b -> - compilePattern ((wkB a ::: _A) : (b ::: _B) : map (first (wkB . wkA)) ts) heads')) + SQ.letA (a wk) (\ wkA a -> SQ.letA (b (wkA . wk)) (\ wkB b -> + compilePattern ((wkB a ::: _A) : (b ::: _B) : map (first (wkB . wkA . wk)) ts) heads' SQ..||. pure (wkB (wkA k)))) (u ::: _A :+ _B):ts -> do (headsL, headsR) <- fold <$> for heads (\case Clause (p:ps) b -> case instantiateHead p of @@ -54,9 +54,9 @@ compilePattern ty heads = case ty of Wildcard -> pure ([Clause (Wildcard:ps) b], [Clause (Wildcard:ps) b]) _ -> empty _ -> empty) - pure u SQ..||. SQ.sumLA - (SQ.µLA (\ wk a -> compilePattern ((a ::: _A):map (first wk) ts) headsL)) - (SQ.µLA (\ wk b -> compilePattern ((b ::: _B):map (first wk) ts) headsR)) + pure (wk u) SQ..||. SQ.sumLA + (SQ.µLA (\ wk' a -> compilePattern ((a ::: _A):map (first (wk' . wk)) ts) headsL SQ..||. pure (wk' k))) + (SQ.µLA (\ wk' b -> compilePattern ((b ::: _B):map (first (wk' . wk)) ts) headsR SQ..||. pure (wk' k))) [] | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) -> pure (pure b) _ -> empty From 273cbe91eee8e63b739eb36ff76ecff4af95e0d7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 11:29:36 -0400 Subject: [PATCH 0927/1324] Rename compilePattern to compileClauses. --- src/Facet/Elab/Pattern.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index bcc20a45a..bf9b0b330 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -4,7 +4,7 @@ module Facet.Elab.Pattern ( Clause(..) , patterns_ -- * Coverage judgement -, compilePattern +, compileClauses ) where import Control.Effect.Empty @@ -35,17 +35,17 @@ instantiateHead (Var _) = Wildcard -- FIXME: let-bind any variables first instantiateHead p = p -compilePattern :: (Has Empty sig m, SQ.Sequent term coterm command, Applicative i) => [i term ::: Type] -> [Clause command] -> m (i term) -compilePattern ty heads = SQ.lamRA $ \ wk _v k -> case ty of - (_ ::: Opaque):ts -> (match (_Wildcard.to (const [])) heads >>= compilePattern (map (first wk) ts)) SQ..||. pure k - (_ ::: (_ :-> _)):ts -> (match (_Wildcard.to (const [])) heads >>= compilePattern (map (first wk) ts)) SQ..||. pure k - (_ ::: One):ts -> (match (_Unit.to (const [])) heads >>= compilePattern (map (first wk) ts)) SQ..||. pure k +compileClauses :: (Has Empty sig m, SQ.Sequent term coterm command, Applicative i) => [i term ::: Type] -> [Clause command] -> m (i term) +compileClauses ty heads = SQ.lamRA $ \ wk _v k -> case ty of + (_ ::: Opaque):ts -> (match (_Wildcard.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k + (_ ::: (_ :-> _)):ts -> (match (_Wildcard.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k + (_ ::: One):ts -> (match (_Unit.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k (u ::: _A :* _B):ts -> do heads' <- match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Wildcard.to (const [Wildcard, Wildcard])))) heads let a wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL1A (pure k)) b wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL2A (pure k)) SQ.letA (a wk) (\ wkA a -> SQ.letA (b (wkA . wk)) (\ wkB b -> - compilePattern ((wkB a ::: _A) : (b ::: _B) : map (first (wkB . wkA . wk)) ts) heads' SQ..||. pure (wkB (wkA k)))) + compileClauses ((wkB a ::: _A) : (b ::: _B) : map (first (wkB . wkA . wk)) ts) heads' SQ..||. pure (wkB (wkA k)))) (u ::: _A :+ _B):ts -> do (headsL, headsR) <- fold <$> for heads (\case Clause (p:ps) b -> case instantiateHead p of @@ -55,8 +55,8 @@ compilePattern ty heads = SQ.lamRA $ \ wk _v k -> case ty of _ -> empty _ -> empty) pure (wk u) SQ..||. SQ.sumLA - (SQ.µLA (\ wk' a -> compilePattern ((a ::: _A):map (first (wk' . wk)) ts) headsL SQ..||. pure (wk' k))) - (SQ.µLA (\ wk' b -> compilePattern ((b ::: _B):map (first (wk' . wk)) ts) headsR SQ..||. pure (wk' k))) + (SQ.µLA (\ wk' a -> compileClauses ((a ::: _A):map (first (wk' . wk)) ts) headsL SQ..||. pure (wk' k))) + (SQ.µLA (\ wk' b -> compileClauses ((b ::: _B):map (first (wk' . wk)) ts) headsR SQ..||. pure (wk' k))) [] | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) -> pure (pure b) _ -> empty From 53a702dd1cc404550452cb0555aba01f930f4322 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 11:31:41 -0400 Subject: [PATCH 0928/1324] Clauses hold terms. --- src/Facet/Elab/Pattern.hs | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index bf9b0b330..7a029e8d4 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -35,18 +35,18 @@ instantiateHead (Var _) = Wildcard -- FIXME: let-bind any variables first instantiateHead p = p -compileClauses :: (Has Empty sig m, SQ.Sequent term coterm command, Applicative i) => [i term ::: Type] -> [Clause command] -> m (i term) -compileClauses ty heads = SQ.lamRA $ \ wk _v k -> case ty of - (_ ::: Opaque):ts -> (match (_Wildcard.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k - (_ ::: (_ :-> _)):ts -> (match (_Wildcard.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k - (_ ::: One):ts -> (match (_Unit.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k - (u ::: _A :* _B):ts -> do +compileClauses :: (Has Empty sig m, SQ.Sequent term coterm command, Applicative i) => [i term ::: Type] -> [Clause term] -> m (i term) +compileClauses (ty:ts) heads = SQ.lamRA $ \ wk _v k -> case ty of + (_ ::: Opaque) -> (match (_Wildcard.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k + (_ ::: (_ :-> _)) -> (match (_Wildcard.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k + (_ ::: One) -> (match (_Unit.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k + (u ::: _A :* _B) -> do heads' <- match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Wildcard.to (const [Wildcard, Wildcard])))) heads let a wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL1A (pure k)) b wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL2A (pure k)) SQ.letA (a wk) (\ wkA a -> SQ.letA (b (wkA . wk)) (\ wkB b -> compileClauses ((wkB a ::: _A) : (b ::: _B) : map (first (wkB . wkA . wk)) ts) heads' SQ..||. pure (wkB (wkA k)))) - (u ::: _A :+ _B):ts -> do + (u ::: _A :+ _B) -> do (headsL, headsR) <- fold <$> for heads (\case Clause (p:ps) b -> case instantiateHead p of InL p -> pure ([Clause (p:ps) b], []) @@ -57,8 +57,9 @@ compileClauses ty heads = SQ.lamRA $ \ wk _v k -> case ty of pure (wk u) SQ..||. SQ.sumLA (SQ.µLA (\ wk' a -> compileClauses ((a ::: _A):map (first (wk' . wk)) ts) headsL SQ..||. pure (wk' k))) (SQ.µLA (\ wk' b -> compileClauses ((b ::: _B):map (first (wk' . wk)) ts) headsR SQ..||. pure (wk' k))) - [] | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) -> pure (pure b) - _ -> empty +compileClauses [] heads + | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) = pure (pure b) + | otherwise = empty match :: Has Empty sig m => Fold (Pattern Name) [Pattern Name] -> [Clause command] -> m [Clause command] match o heads = forOf (traversed.patterns_) heads (\case From 57268371fe740e0cc4648432b1d0910feff72462 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 12:03:22 -0400 Subject: [PATCH 0929/1324] :fire: do. --- src/Facet/Elab/Pattern.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 7a029e8d4..bfb8bddfe 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -40,11 +40,10 @@ compileClauses (ty:ts) heads = SQ.lamRA $ \ wk _v k -> case ty of (_ ::: Opaque) -> (match (_Wildcard.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k (_ ::: (_ :-> _)) -> (match (_Wildcard.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k (_ ::: One) -> (match (_Unit.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k - (u ::: _A :* _B) -> do - heads' <- match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Wildcard.to (const [Wildcard, Wildcard])))) heads + (u ::: _A :* _B) -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Wildcard.to (const [Wildcard, Wildcard])))) heads >>= \ heads' -> let a wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL1A (pure k)) b wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL2A (pure k)) - SQ.letA (a wk) (\ wkA a -> SQ.letA (b (wkA . wk)) (\ wkB b -> + in SQ.letA (a wk) (\ wkA a -> SQ.letA (b (wkA . wk)) (\ wkB b -> compileClauses ((wkB a ::: _A) : (b ::: _B) : map (first (wkB . wkA . wk)) ts) heads' SQ..||. pure (wkB (wkA k)))) (u ::: _A :+ _B) -> do (headsL, headsR) <- fold <$> for heads (\case From 02ab4d0e8b415d07b1eb376b2d75ffa22eb82f37 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 12:04:27 -0400 Subject: [PATCH 0930/1324] Rename. --- src/Facet/Elab/Pattern.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index bfb8bddfe..c46cd79c8 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -41,8 +41,8 @@ compileClauses (ty:ts) heads = SQ.lamRA $ \ wk _v k -> case ty of (_ ::: (_ :-> _)) -> (match (_Wildcard.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k (_ ::: One) -> (match (_Unit.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k (u ::: _A :* _B) -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Wildcard.to (const [Wildcard, Wildcard])))) heads >>= \ heads' -> - let a wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL1A (pure k)) - b wk' = SQ.µRA (\ wk k -> pure (wk (wk' u)) SQ..||. SQ.prdL2A (pure k)) + let a wk = SQ.µRA (\ wk' k -> pure (wk' (wk u)) SQ..||. SQ.prdL1A (pure k)) + b wk = SQ.µRA (\ wk' k -> pure (wk' (wk u)) SQ..||. SQ.prdL2A (pure k)) in SQ.letA (a wk) (\ wkA a -> SQ.letA (b (wkA . wk)) (\ wkB b -> compileClauses ((wkB a ::: _A) : (b ::: _B) : map (first (wkB . wkA . wk)) ts) heads' SQ..||. pure (wkB (wkA k)))) (u ::: _A :+ _B) -> do From 70d846799c95c2e0fa1620e3e31a4c7216cc6f5b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 13:08:27 -0400 Subject: [PATCH 0931/1324] :fire: let bindings. --- src/Facet/Elab/Pattern.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index c46cd79c8..7e1afdb20 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -41,9 +41,8 @@ compileClauses (ty:ts) heads = SQ.lamRA $ \ wk _v k -> case ty of (_ ::: (_ :-> _)) -> (match (_Wildcard.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k (_ ::: One) -> (match (_Unit.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k (u ::: _A :* _B) -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Wildcard.to (const [Wildcard, Wildcard])))) heads >>= \ heads' -> - let a wk = SQ.µRA (\ wk' k -> pure (wk' (wk u)) SQ..||. SQ.prdL1A (pure k)) - b wk = SQ.µRA (\ wk' k -> pure (wk' (wk u)) SQ..||. SQ.prdL2A (pure k)) - in SQ.letA (a wk) (\ wkA a -> SQ.letA (b (wkA . wk)) (\ wkB b -> + SQ.letA (SQ.µRA (\ wk' k -> pure (wk' (wk u)) SQ..||. SQ.prdL1A (pure k))) (\ wkA a -> + SQ.letA (SQ.µRA (\ wk' k -> pure (wk' (wkA (wk u))) SQ..||. SQ.prdL2A (pure k))) (\ wkB b -> compileClauses ((wkB a ::: _A) : (b ::: _B) : map (first (wkB . wkA . wk)) ts) heads' SQ..||. pure (wkB (wkA k)))) (u ::: _A :+ _B) -> do (headsL, headsR) <- fold <$> for heads (\case From 497b67ade9054d6ece20d97519b166f55652bba8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 13:17:39 -0400 Subject: [PATCH 0932/1324] Use the lambda variable. --- src/Facet/Elab/Pattern.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 7e1afdb20..663960b28 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -36,15 +36,15 @@ instantiateHead p = p compileClauses :: (Has Empty sig m, SQ.Sequent term coterm command, Applicative i) => [i term ::: Type] -> [Clause term] -> m (i term) -compileClauses (ty:ts) heads = SQ.lamRA $ \ wk _v k -> case ty of +compileClauses (ty:ts) heads = SQ.lamRA $ \ wk v k -> case ty of (_ ::: Opaque) -> (match (_Wildcard.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k (_ ::: (_ :-> _)) -> (match (_Wildcard.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k (_ ::: One) -> (match (_Unit.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k - (u ::: _A :* _B) -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Wildcard.to (const [Wildcard, Wildcard])))) heads >>= \ heads' -> - SQ.letA (SQ.µRA (\ wk' k -> pure (wk' (wk u)) SQ..||. SQ.prdL1A (pure k))) (\ wkA a -> - SQ.letA (SQ.µRA (\ wk' k -> pure (wk' (wkA (wk u))) SQ..||. SQ.prdL2A (pure k))) (\ wkB b -> + (_ ::: _A :* _B) -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Wildcard.to (const [Wildcard, Wildcard])))) heads >>= \ heads' -> + SQ.letA (SQ.µRA (\ wk' k -> pure (wk' v) SQ..||. SQ.prdL1A (pure k))) (\ wkA a -> + SQ.letA (SQ.µRA (\ wk' k -> pure (wk' (wkA v)) SQ..||. SQ.prdL2A (pure k))) (\ wkB b -> compileClauses ((wkB a ::: _A) : (b ::: _B) : map (first (wkB . wkA . wk)) ts) heads' SQ..||. pure (wkB (wkA k)))) - (u ::: _A :+ _B) -> do + (_ ::: _A :+ _B) -> do (headsL, headsR) <- fold <$> for heads (\case Clause (p:ps) b -> case instantiateHead p of InL p -> pure ([Clause (p:ps) b], []) @@ -52,7 +52,7 @@ compileClauses (ty:ts) heads = SQ.lamRA $ \ wk _v k -> case ty of Wildcard -> pure ([Clause (Wildcard:ps) b], [Clause (Wildcard:ps) b]) _ -> empty _ -> empty) - pure (wk u) SQ..||. SQ.sumLA + pure v SQ..||. SQ.sumLA (SQ.µLA (\ wk' a -> compileClauses ((a ::: _A):map (first (wk' . wk)) ts) headsL SQ..||. pure (wk' k))) (SQ.µLA (\ wk' b -> compileClauses ((b ::: _B):map (first (wk' . wk)) ts) headsR SQ..||. pure (wk' k))) compileClauses [] heads From 65a79d5140fdd1a7d1ede23470e75a8291b9aa16 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 13:19:47 -0400 Subject: [PATCH 0933/1324] :fire: the context variables in favour of params. --- src/Facet/Elab/Pattern.hs | 26 ++++++++++++-------------- 1 file changed, 12 insertions(+), 14 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 663960b28..493e52444 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -8,7 +8,6 @@ module Facet.Elab.Pattern ) where import Control.Effect.Empty -import Data.Bifunctor (first) import Data.Foldable (fold) import Data.Monoid (First(..)) import Data.Traversable (for) @@ -16,7 +15,6 @@ import Facet.Name import qualified Facet.Sequent.Class as SQ import Facet.Sequent.Pattern import Facet.Sequent.Type -import Facet.Syntax ((:::)(..)) import Fresnel.Fold (Fold, Union(..), preview) import Fresnel.Getter (to) import Fresnel.Lens (Lens', lens) @@ -35,16 +33,16 @@ instantiateHead (Var _) = Wildcard -- FIXME: let-bind any variables first instantiateHead p = p -compileClauses :: (Has Empty sig m, SQ.Sequent term coterm command, Applicative i) => [i term ::: Type] -> [Clause term] -> m (i term) -compileClauses (ty:ts) heads = SQ.lamRA $ \ wk v k -> case ty of - (_ ::: Opaque) -> (match (_Wildcard.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k - (_ ::: (_ :-> _)) -> (match (_Wildcard.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k - (_ ::: One) -> (match (_Unit.to (const [])) heads >>= compileClauses (map (first wk) ts)) SQ..||. pure k - (_ ::: _A :* _B) -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Wildcard.to (const [Wildcard, Wildcard])))) heads >>= \ heads' -> - SQ.letA (SQ.µRA (\ wk' k -> pure (wk' v) SQ..||. SQ.prdL1A (pure k))) (\ wkA a -> - SQ.letA (SQ.µRA (\ wk' k -> pure (wk' (wkA v)) SQ..||. SQ.prdL2A (pure k))) (\ wkB b -> - compileClauses ((wkB a ::: _A) : (b ::: _B) : map (first (wkB . wkA . wk)) ts) heads' SQ..||. pure (wkB (wkA k)))) - (_ ::: _A :+ _B) -> do +compileClauses :: (Has Empty sig m, SQ.Sequent term coterm command, Applicative i) => [Type] -> [Clause term] -> m (i term) +compileClauses (ty:ts) heads = SQ.lamRA $ \ _wk v k -> case ty of + Opaque -> (match (_Wildcard.to (const [])) heads >>= compileClauses ts) SQ..||. pure k + _ :-> _ -> (match (_Wildcard.to (const [])) heads >>= compileClauses ts) SQ..||. pure k + One -> (match (_Unit.to (const [])) heads >>= compileClauses ts) SQ..||. pure k + _A :* _B -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Wildcard.to (const [Wildcard, Wildcard])))) heads >>= \ heads' -> + SQ.letA (SQ.µRA (\ wk' k -> pure (wk' v) SQ..||. SQ.prdL1A (pure k))) (\ wkA _ -> + SQ.letA (SQ.µRA (\ wk' k -> pure (wk' (wkA v)) SQ..||. SQ.prdL2A (pure k))) (\ wkB _ -> + compileClauses (_A:_B:ts) heads' SQ..||. pure (wkB (wkA k)))) + _A :+ _B -> do (headsL, headsR) <- fold <$> for heads (\case Clause (p:ps) b -> case instantiateHead p of InL p -> pure ([Clause (p:ps) b], []) @@ -53,8 +51,8 @@ compileClauses (ty:ts) heads = SQ.lamRA $ \ wk v k -> case ty of _ -> empty _ -> empty) pure v SQ..||. SQ.sumLA - (SQ.µLA (\ wk' a -> compileClauses ((a ::: _A):map (first (wk' . wk)) ts) headsL SQ..||. pure (wk' k))) - (SQ.µLA (\ wk' b -> compileClauses ((b ::: _B):map (first (wk' . wk)) ts) headsR SQ..||. pure (wk' k))) + (SQ.µLA (\ wk' _ -> compileClauses (_A:ts) headsL SQ..||. pure (wk' k))) + (SQ.µLA (\ wk' _ -> compileClauses (_B:ts) headsR SQ..||. pure (wk' k))) compileClauses [] heads | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) = pure (pure b) | otherwise = empty From 545b02005dbfb2825ae221ad0754cc5209bdbe4d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 13:25:40 -0400 Subject: [PATCH 0934/1324] Rename. --- src/Facet/Elab/Pattern.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 493e52444..0f190d8c2 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -39,8 +39,8 @@ compileClauses (ty:ts) heads = SQ.lamRA $ \ _wk v k -> case ty of _ :-> _ -> (match (_Wildcard.to (const [])) heads >>= compileClauses ts) SQ..||. pure k One -> (match (_Unit.to (const [])) heads >>= compileClauses ts) SQ..||. pure k _A :* _B -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Wildcard.to (const [Wildcard, Wildcard])))) heads >>= \ heads' -> - SQ.letA (SQ.µRA (\ wk' k -> pure (wk' v) SQ..||. SQ.prdL1A (pure k))) (\ wkA _ -> - SQ.letA (SQ.µRA (\ wk' k -> pure (wk' (wkA v)) SQ..||. SQ.prdL2A (pure k))) (\ wkB _ -> + SQ.letA (SQ.µRA (\ wk k -> pure (wk v) SQ..||. SQ.prdL1A (pure k))) (\ wkA _ -> + SQ.letA (SQ.µRA (\ wk k -> pure (wk (wkA v)) SQ..||. SQ.prdL2A (pure k))) (\ wkB _ -> compileClauses (_A:_B:ts) heads' SQ..||. pure (wkB (wkA k)))) _A :+ _B -> do (headsL, headsR) <- fold <$> for heads (\case @@ -51,8 +51,8 @@ compileClauses (ty:ts) heads = SQ.lamRA $ \ _wk v k -> case ty of _ -> empty _ -> empty) pure v SQ..||. SQ.sumLA - (SQ.µLA (\ wk' _ -> compileClauses (_A:ts) headsL SQ..||. pure (wk' k))) - (SQ.µLA (\ wk' _ -> compileClauses (_B:ts) headsR SQ..||. pure (wk' k))) + (SQ.µLA (\ wk _ -> compileClauses (_A:ts) headsL SQ..||. pure (wk k))) + (SQ.µLA (\ wk _ -> compileClauses (_B:ts) headsR SQ..||. pure (wk k))) compileClauses [] heads | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) = pure (pure b) | otherwise = empty From 9c34ba5a8439a4db76562d60f303d8dd6897b319 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 13:27:15 -0400 Subject: [PATCH 0935/1324] :fire: brackets. --- src/Facet/Sequent/Print.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index 1d085947c..f61ff76c9 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -27,7 +27,7 @@ instance Show Print where instance S.Sequent Print Print Print where var = var µR b = P.pretty "µ" <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) - lamR c = P.braces (fresh (\ u -> fresh (\ v -> P.brackets (anon u <> P.comma P.<+> anon v) P.<+> P.pretty "->" P.<+> c (anon u) (anon v)))) + lamR c = P.braces (fresh (\ u -> fresh (\ v -> anon u <> P.comma P.<+> anon v P.<+> P.pretty "->" P.<+> c (anon u) (anon v)))) sumR1 t = P.parens (P.pretty "inl" P.<+> t) sumR2 t = P.parens (P.pretty "inr" P.<+> t) unitR = P.parens mempty From 5d236688422c8f5e735b26fc093f3c59498705f2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 13:31:55 -0400 Subject: [PATCH 0936/1324] Dot. --- src/Facet/Sequent/Print.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index f61ff76c9..bb084251b 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -27,7 +27,7 @@ instance Show Print where instance S.Sequent Print Print Print where var = var µR b = P.pretty "µ" <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) - lamR c = P.braces (fresh (\ u -> fresh (\ v -> anon u <> P.comma P.<+> anon v P.<+> P.pretty "->" P.<+> c (anon u) (anon v)))) + lamR c = P.braces (fresh (\ u -> fresh (\ v -> anon u <> P.comma P.<+> anon v P.<+> P.pretty "." P.<+> c (anon u) (anon v)))) sumR1 t = P.parens (P.pretty "inl" P.<+> t) sumR2 t = P.parens (P.pretty "inr" P.<+> t) unitR = P.parens mempty From bda23a4fe4204237995d30243fc584e2f4e7487b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 13:34:45 -0400 Subject: [PATCH 0937/1324] Lambda prefix. --- src/Facet/Sequent/Print.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index bb084251b..f026133ce 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -27,7 +27,7 @@ instance Show Print where instance S.Sequent Print Print Print where var = var µR b = P.pretty "µ" <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) - lamR c = P.braces (fresh (\ u -> fresh (\ v -> anon u <> P.comma P.<+> anon v P.<+> P.pretty "." P.<+> c (anon u) (anon v)))) + lamR c = P.pretty "λ" <> P.braces (fresh (\ u -> fresh (\ v -> anon u <> P.comma P.<+> anon v P.<+> P.pretty "." P.<+> c (anon u) (anon v)))) sumR1 t = P.parens (P.pretty "inl" P.<+> t) sumR2 t = P.parens (P.pretty "inr" P.<+> t) unitR = P.parens mempty From 8b41a55cf438d35c70f8d12a2bdec56190a4d9a8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 13:38:26 -0400 Subject: [PATCH 0938/1324] Uncomment the Ctx stuff. --- src/Facet/Sequent/Class.hs | 36 +++++++++++++++++++----------------- 1 file changed, 19 insertions(+), 17 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 23732c83c..ee23cc8b1 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FunctionalDependencies #-} module Facet.Sequent.Class ( -- * Sequent abstraction @@ -17,15 +18,16 @@ module Facet.Sequent.Class , prdL2A , (.||.) , letA --- , Ctx(..) --- , Binding(..) --- , lookupCtx +, Ctx(..) +, Binding(..) +, lookupCtx ) where -import Control.Applicative (liftA2) +import Control.Applicative (liftA2, (<|>)) +import Control.Monad (guard) import Data.Text (Text) import Facet.Functor.Compose as C -import Facet.Name (Level) +import Facet.Name (Level, Name) import Facet.Syntax (Var, type (~>)) -- * Term abstraction @@ -141,18 +143,18 @@ letA :: (Applicative m, Applicative i, Sequent t c d) => m (i t) -> (forall j . letA t b = liftA2 let' <$> t <*> (runC <$> b weaken (liftCInner id)) --- data Ctx j t --- = Nil --- | forall i . Ctx i t :> Binding i j t +data Ctx j t + = Nil + | forall i . Ctx i t :> Binding i j t --- infixl 5 :> +infixl 5 :> --- data Binding i j t = Binding Name (i ~> j) (j t) +data Binding i j t = Binding Name (i ~> j) (j t) --- lookupCtx :: Name -> Ctx i t -> Maybe (i t) --- lookupCtx n = go id --- where --- go :: (i ~> j) -> Ctx i t -> Maybe (j t) --- go wk = \case --- Nil -> Nothing --- c :> Binding n' wk' t -> wk t <$ guard (n == n') <|> go (wk . wk') c +lookupCtx :: Name -> Ctx i t -> Maybe (i t) +lookupCtx n = go id + where + go :: (i ~> j) -> Ctx i t -> Maybe (j t) + go wk = \case + Nil -> Nothing + c :> Binding n' wk' t -> wk t <$ guard (n == n') <|> go (wk . wk') c From f1ecb8ca964c1f673e06eb4e41f6a500ccb9fb8c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 19:38:49 -0400 Subject: [PATCH 0939/1324] Define copatterns (this is a bit of a misnomer). --- src/Facet/Sequent/Pattern.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/src/Facet/Sequent/Pattern.hs b/src/Facet/Sequent/Pattern.hs index bc8a3cebc..819c218f7 100644 --- a/src/Facet/Sequent/Pattern.hs +++ b/src/Facet/Sequent/Pattern.hs @@ -1,12 +1,14 @@ module Facet.Sequent.Pattern -( Pattern(..) - -- * Prisms +( -- * Patterns + Pattern(..) , _Wildcard , _Var , _Unit , _InL , _InR , _Pair + -- * Copatterns +, Copattern(..) ) where import Control.Monad (ap) @@ -64,3 +66,8 @@ _Pair :: Prism' (Pattern a) (Pattern a, Pattern a) _Pair = prism' (uncurry Pair) (\case Pair p q -> Just (p, q) _ -> Nothing) + + +data Copattern a + = All (Maybe a) + | Comp (Pattern a) (Maybe a) From d3e3ef7d802a522cfb515d72ed7d9bb42f499712 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 19:39:20 -0400 Subject: [PATCH 0940/1324] Derive some instances. --- src/Facet/Sequent/Pattern.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Sequent/Pattern.hs b/src/Facet/Sequent/Pattern.hs index 819c218f7..ca61c4b27 100644 --- a/src/Facet/Sequent/Pattern.hs +++ b/src/Facet/Sequent/Pattern.hs @@ -71,3 +71,4 @@ _Pair = prism' (uncurry Pair) (\case data Copattern a = All (Maybe a) | Comp (Pattern a) (Maybe a) + deriving (Eq, Foldable, Functor, Ord, Show, Traversable) From f1122a47c544430704d8653abcbf29d0563f9254 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 19:44:08 -0400 Subject: [PATCH 0941/1324] Define a prism for all-effect copatterns. --- src/Facet/Sequent/Pattern.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Facet/Sequent/Pattern.hs b/src/Facet/Sequent/Pattern.hs index ca61c4b27..a904806e3 100644 --- a/src/Facet/Sequent/Pattern.hs +++ b/src/Facet/Sequent/Pattern.hs @@ -9,6 +9,7 @@ module Facet.Sequent.Pattern , _Pair -- * Copatterns , Copattern(..) +, _All ) where import Control.Monad (ap) @@ -72,3 +73,9 @@ data Copattern a = All (Maybe a) | Comp (Pattern a) (Maybe a) deriving (Eq, Foldable, Functor, Ord, Show, Traversable) + + +_All :: Prism' (Copattern a) (Maybe a) +_All = prism' All (\case + All v -> Just v + Comp{} -> Nothing) From 710484286011bf40285609b2620ebbadd762cfbd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 19:45:43 -0400 Subject: [PATCH 0942/1324] Define a prism for computation copatterns. --- src/Facet/Sequent/Pattern.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Sequent/Pattern.hs b/src/Facet/Sequent/Pattern.hs index a904806e3..77ab6b00d 100644 --- a/src/Facet/Sequent/Pattern.hs +++ b/src/Facet/Sequent/Pattern.hs @@ -10,6 +10,7 @@ module Facet.Sequent.Pattern -- * Copatterns , Copattern(..) , _All +, _Comp ) where import Control.Monad (ap) @@ -79,3 +80,8 @@ _All :: Prism' (Copattern a) (Maybe a) _All = prism' All (\case All v -> Just v Comp{} -> Nothing) + +_Comp :: Prism' (Copattern a) (Pattern a, Maybe a) +_Comp = prism' (uncurry Comp) (\case + Comp p k -> Just (p, k) + All{} -> Nothing) From 3011ff5861eb2c6a7e24a206bcfe7f0123a904ce Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 19:46:58 -0400 Subject: [PATCH 0943/1324] Rename Comp to Op. --- src/Facet/Sequent/Pattern.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Facet/Sequent/Pattern.hs b/src/Facet/Sequent/Pattern.hs index 77ab6b00d..d25fb799b 100644 --- a/src/Facet/Sequent/Pattern.hs +++ b/src/Facet/Sequent/Pattern.hs @@ -10,7 +10,7 @@ module Facet.Sequent.Pattern -- * Copatterns , Copattern(..) , _All -, _Comp +, _Op ) where import Control.Monad (ap) @@ -72,16 +72,16 @@ _Pair = prism' (uncurry Pair) (\case data Copattern a = All (Maybe a) - | Comp (Pattern a) (Maybe a) + | Op (Pattern a) (Maybe a) deriving (Eq, Foldable, Functor, Ord, Show, Traversable) _All :: Prism' (Copattern a) (Maybe a) _All = prism' All (\case - All v -> Just v - Comp{} -> Nothing) + All v -> Just v + Op{} -> Nothing) -_Comp :: Prism' (Copattern a) (Pattern a, Maybe a) -_Comp = prism' (uncurry Comp) (\case - Comp p k -> Just (p, k) - All{} -> Nothing) +_Op :: Prism' (Copattern a) (Pattern a, Maybe a) +_Op = prism' (uncurry Op) (\case + Op p k -> Just (p, k) + All{} -> Nothing) From 5b656f25cb3aa225dc1e8082ef78d67bac9a7171 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 19:50:29 -0400 Subject: [PATCH 0944/1324] Combine variable and wildcard patterns. --- src/Facet/Elab/Pattern.hs | 19 ++++++++++--------- src/Facet/Sequent/Pattern.hs | 25 +++++++++---------------- 2 files changed, 19 insertions(+), 25 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 0f190d8c2..dee63d9f6 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -18,6 +18,7 @@ import Facet.Sequent.Type import Fresnel.Fold (Fold, Union(..), preview) import Fresnel.Getter (to) import Fresnel.Lens (Lens', lens) +import Fresnel.Maybe (_Nothing) import Fresnel.Traversal (forOf, traversed) data Clause a = Clause { patterns :: [Pattern Name], body :: a } @@ -29,26 +30,26 @@ patterns_ = lens patterns (\ c patterns -> c{patterns}) -- Coverage judgement instantiateHead :: Pattern Name -> Pattern Name -instantiateHead (Var _) = Wildcard -- FIXME: let-bind any variables first -instantiateHead p = p +instantiateHead (Var (Just _)) = Var Nothing -- FIXME: let-bind any variables first +instantiateHead p = p compileClauses :: (Has Empty sig m, SQ.Sequent term coterm command, Applicative i) => [Type] -> [Clause term] -> m (i term) compileClauses (ty:ts) heads = SQ.lamRA $ \ _wk v k -> case ty of - Opaque -> (match (_Wildcard.to (const [])) heads >>= compileClauses ts) SQ..||. pure k - _ :-> _ -> (match (_Wildcard.to (const [])) heads >>= compileClauses ts) SQ..||. pure k + Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ts) SQ..||. pure k + _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ts) SQ..||. pure k One -> (match (_Unit.to (const [])) heads >>= compileClauses ts) SQ..||. pure k - _A :* _B -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Wildcard.to (const [Wildcard, Wildcard])))) heads >>= \ heads' -> + _A :* _B -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Var._Nothing.to (const [Var Nothing, Var Nothing])))) heads >>= \ heads' -> SQ.letA (SQ.µRA (\ wk k -> pure (wk v) SQ..||. SQ.prdL1A (pure k))) (\ wkA _ -> SQ.letA (SQ.µRA (\ wk k -> pure (wk (wkA v)) SQ..||. SQ.prdL2A (pure k))) (\ wkB _ -> compileClauses (_A:_B:ts) heads' SQ..||. pure (wkB (wkA k)))) _A :+ _B -> do (headsL, headsR) <- fold <$> for heads (\case Clause (p:ps) b -> case instantiateHead p of - InL p -> pure ([Clause (p:ps) b], []) - InR p -> pure ([], [Clause (p:ps) b]) - Wildcard -> pure ([Clause (Wildcard:ps) b], [Clause (Wildcard:ps) b]) - _ -> empty + InL p -> pure ([Clause (p:ps) b], []) + InR p -> pure ([], [Clause (p:ps) b]) + Var Nothing -> pure ([Clause (Var Nothing:ps) b], [Clause (Var Nothing:ps) b]) + _ -> empty _ -> empty) pure v SQ..||. SQ.sumLA (SQ.µLA (\ wk _ -> compileClauses (_A:ts) headsL SQ..||. pure (wk k))) diff --git a/src/Facet/Sequent/Pattern.hs b/src/Facet/Sequent/Pattern.hs index d25fb799b..953496400 100644 --- a/src/Facet/Sequent/Pattern.hs +++ b/src/Facet/Sequent/Pattern.hs @@ -1,7 +1,6 @@ module Facet.Sequent.Pattern ( -- * Patterns Pattern(..) -, _Wildcard , _Var , _Unit , _InL @@ -17,8 +16,7 @@ import Control.Monad (ap) import Fresnel.Prism (Prism', prism') data Pattern a - = Wildcard - | Var a + = Var (Maybe a) | Unit | InL (Pattern a) | InR (Pattern a) @@ -26,25 +24,20 @@ data Pattern a deriving (Eq, Foldable, Functor, Ord, Show, Traversable) instance Applicative Pattern where - pure = Var + pure = Var . Just (<*>) = ap instance Monad Pattern where m >>= f = case m of - Wildcard -> Wildcard - Var a -> f a - Unit -> Unit - InL p -> InL (p >>= f) - InR q -> InR (q >>= f) - Pair p q -> Pair (p >>= f) (q >>= f) + Var (Just a) -> f a + Var Nothing -> Var Nothing + Unit -> Unit + InL p -> InL (p >>= f) + InR q -> InR (q >>= f) + Pair p q -> Pair (p >>= f) (q >>= f) -_Wildcard :: Prism' (Pattern a) () -_Wildcard = prism' (const Wildcard) (\case - Wildcard -> Just () - _ -> Nothing) - -_Var :: Prism' (Pattern a) a +_Var :: Prism' (Pattern a) (Maybe a) _Var = prism' Var (\case Var a -> Just a _ -> Nothing) From d23e9e31332d1cc3827f4c62c576f3639bdd5a5d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 26 Mar 2022 21:07:16 -0400 Subject: [PATCH 0945/1324] Recur through function types. --- src/Facet/Elab/Pattern.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index dee63d9f6..dca68fa8c 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -34,15 +34,15 @@ instantiateHead (Var (Just _)) = Var Nothing -- FIXME: let-bind any variables fi instantiateHead p = p -compileClauses :: (Has Empty sig m, SQ.Sequent term coterm command, Applicative i) => [Type] -> [Clause term] -> m (i term) -compileClauses (ty:ts) heads = SQ.lamRA $ \ _wk v k -> case ty of - Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ts) SQ..||. pure k - _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ts) SQ..||. pure k - One -> (match (_Unit.to (const [])) heads >>= compileClauses ts) SQ..||. pure k +compileClauses :: (Has Empty sig m, SQ.Sequent term coterm command, Applicative i) => Type -> [Clause term] -> m (i term) +compileClauses (_A :-> _T) heads = SQ.lamRA $ \ _wk v k -> case _A of + Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses _T) SQ..||. pure k + _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses _T) SQ..||. pure k + One -> (match (_Unit.to (const [])) heads >>= compileClauses _T) SQ..||. pure k _A :* _B -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Var._Nothing.to (const [Var Nothing, Var Nothing])))) heads >>= \ heads' -> SQ.letA (SQ.µRA (\ wk k -> pure (wk v) SQ..||. SQ.prdL1A (pure k))) (\ wkA _ -> SQ.letA (SQ.µRA (\ wk k -> pure (wk (wkA v)) SQ..||. SQ.prdL2A (pure k))) (\ wkB _ -> - compileClauses (_A:_B:ts) heads' SQ..||. pure (wkB (wkA k)))) + compileClauses _T heads' SQ..||. pure (wkB (wkA k)))) _A :+ _B -> do (headsL, headsR) <- fold <$> for heads (\case Clause (p:ps) b -> case instantiateHead p of @@ -52,9 +52,9 @@ compileClauses (ty:ts) heads = SQ.lamRA $ \ _wk v k -> case ty of _ -> empty _ -> empty) pure v SQ..||. SQ.sumLA - (SQ.µLA (\ wk _ -> compileClauses (_A:ts) headsL SQ..||. pure (wk k))) - (SQ.µLA (\ wk _ -> compileClauses (_B:ts) headsR SQ..||. pure (wk k))) -compileClauses [] heads + (SQ.µLA (\ wk _ -> compileClauses _T headsL SQ..||. pure (wk k))) + (SQ.µLA (\ wk _ -> compileClauses _T headsR SQ..||. pure (wk k))) +compileClauses _T heads | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) = pure (pure b) | otherwise = empty From d92b82c46900fd8982c00f7876c0088f8980ab2e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 27 Mar 2022 01:59:09 -0400 Subject: [PATCH 0946/1324] Pass a context around. --- src/Facet/Elab/Pattern.hs | 28 +++++++++++++++++++--------- 1 file changed, 19 insertions(+), 9 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index dca68fa8c..b3add68a1 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -15,6 +15,7 @@ import Facet.Name import qualified Facet.Sequent.Class as SQ import Facet.Sequent.Pattern import Facet.Sequent.Type +import Facet.Syntax (type (~>)) import Fresnel.Fold (Fold, Union(..), preview) import Fresnel.Getter (to) import Fresnel.Lens (Lens', lens) @@ -34,15 +35,15 @@ instantiateHead (Var (Just _)) = Var Nothing -- FIXME: let-bind any variables fi instantiateHead p = p -compileClauses :: (Has Empty sig m, SQ.Sequent term coterm command, Applicative i) => Type -> [Clause term] -> m (i term) -compileClauses (_A :-> _T) heads = SQ.lamRA $ \ _wk v k -> case _A of - Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses _T) SQ..||. pure k - _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses _T) SQ..||. pure k - One -> (match (_Unit.to (const [])) heads >>= compileClauses _T) SQ..||. pure k +compileClauses :: (Has Empty sig m, SQ.Sequent term coterm command, Applicative i) => Ctx i term -> Type -> [Clause term] -> m (i term) +compileClauses ctx (_A :-> _T) heads = SQ.lamRA $ \ wk v k -> case _A of + Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses (skip ctx wk) _T) SQ..||. pure k + _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses (skip ctx wk) _T) SQ..||. pure k + One -> (match (_Unit.to (const [])) heads >>= compileClauses (skip ctx wk) _T) SQ..||. pure k _A :* _B -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Var._Nothing.to (const [Var Nothing, Var Nothing])))) heads >>= \ heads' -> SQ.letA (SQ.µRA (\ wk k -> pure (wk v) SQ..||. SQ.prdL1A (pure k))) (\ wkA _ -> SQ.letA (SQ.µRA (\ wk k -> pure (wk (wkA v)) SQ..||. SQ.prdL2A (pure k))) (\ wkB _ -> - compileClauses _T heads' SQ..||. pure (wkB (wkA k)))) + compileClauses (skip ctx (wkB . wkA . wk)) _T heads' SQ..||. pure (wkB (wkA k)))) _A :+ _B -> do (headsL, headsR) <- fold <$> for heads (\case Clause (p:ps) b -> case instantiateHead p of @@ -52,9 +53,9 @@ compileClauses (_A :-> _T) heads = SQ.lamRA $ \ _wk v k -> case _A of _ -> empty _ -> empty) pure v SQ..||. SQ.sumLA - (SQ.µLA (\ wk _ -> compileClauses _T headsL SQ..||. pure (wk k))) - (SQ.µLA (\ wk _ -> compileClauses _T headsR SQ..||. pure (wk k))) -compileClauses _T heads + (SQ.µLA (\ wk2 _ -> compileClauses (skip ctx (wk2 . wk)) _T headsL SQ..||. pure (wk2 k))) + (SQ.µLA (\ wk2 _ -> compileClauses (skip ctx (wk2 . wk)) _T headsR SQ..||. pure (wk2 k))) +compileClauses _ _T heads | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) = pure (pure b) | otherwise = empty @@ -62,3 +63,12 @@ match :: Has Empty sig m => Fold (Pattern Name) [Pattern Name] -> [Clause comman match o heads = forOf (traversed.patterns_) heads (\case p:ps | Just prefix <- preview o (instantiateHead p) -> pure (prefix <> ps) _ -> empty) + + +data Ctx j t + = Nil + | forall i . Bind (Ctx i t) (i ~> j) (j t) + +skip :: Ctx i t -> (i ~> j) -> Ctx j t +skip Nil _ = Nil +skip (Bind ctx wk1 t) wk2 = Bind ctx (wk2 . wk1) (wk2 t) From 2f5f86d4e0187520b22ad91497bc402a2f589ca5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 27 Mar 2022 01:59:47 -0400 Subject: [PATCH 0947/1324] Add types to contexts. --- src/Facet/Elab/Pattern.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index b3add68a1..9b3706c38 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -67,8 +67,8 @@ match o heads = forOf (traversed.patterns_) heads (\case data Ctx j t = Nil - | forall i . Bind (Ctx i t) (i ~> j) (j t) + | forall i . Bind (Ctx i t) (i ~> j) Type (j t) skip :: Ctx i t -> (i ~> j) -> Ctx j t -skip Nil _ = Nil -skip (Bind ctx wk1 t) wk2 = Bind ctx (wk2 . wk1) (wk2 t) +skip Nil _ = Nil +skip (Bind ctx wk1 ty tm) wk2 = Bind ctx (wk2 . wk1) ty (wk2 tm) From 5f670b651796e90dad198b94aee786f690012cae Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 27 Mar 2022 02:01:46 -0400 Subject: [PATCH 0948/1324] Spacing. --- src/Facet/Elab/Pattern.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 9b3706c38..1a9340efc 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -37,14 +37,14 @@ instantiateHead p = p compileClauses :: (Has Empty sig m, SQ.Sequent term coterm command, Applicative i) => Ctx i term -> Type -> [Clause term] -> m (i term) compileClauses ctx (_A :-> _T) heads = SQ.lamRA $ \ wk v k -> case _A of - Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses (skip ctx wk) _T) SQ..||. pure k - _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses (skip ctx wk) _T) SQ..||. pure k - One -> (match (_Unit.to (const [])) heads >>= compileClauses (skip ctx wk) _T) SQ..||. pure k - _A :* _B -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Var._Nothing.to (const [Var Nothing, Var Nothing])))) heads >>= \ heads' -> + Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses (skip ctx wk) _T) SQ..||. pure k + _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses (skip ctx wk) _T) SQ..||. pure k + One -> (match (_Unit.to (const [])) heads >>= compileClauses (skip ctx wk) _T) SQ..||. pure k + _A :* _B -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Var._Nothing.to (const [Var Nothing, Var Nothing])))) heads >>= \ heads' -> SQ.letA (SQ.µRA (\ wk k -> pure (wk v) SQ..||. SQ.prdL1A (pure k))) (\ wkA _ -> SQ.letA (SQ.µRA (\ wk k -> pure (wk (wkA v)) SQ..||. SQ.prdL2A (pure k))) (\ wkB _ -> compileClauses (skip ctx (wkB . wkA . wk)) _T heads' SQ..||. pure (wkB (wkA k)))) - _A :+ _B -> do + _A :+ _B -> do (headsL, headsR) <- fold <$> for heads (\case Clause (p:ps) b -> case instantiateHead p of InL p -> pure ([Clause (p:ps) b], []) From 7d9b52c189b81279a1a8fcd78faefa1e0a797a81 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 27 Mar 2022 11:24:08 -0400 Subject: [PATCH 0949/1324] Heading. --- src/Facet/Sequent/Expr.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 139324703..237b9a9ff 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -78,6 +78,8 @@ covar :: Index -> Coterm covar = Covar . Free +-- Interpreters + interpretTerm :: C.Sequent t c d => [t] -> [c] -> Term -> t interpretTerm _G _D = \case Var (Free n) -> _G `index` n From 0c5dbf59c5832eb07245b492e7e3850939637135 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Mar 2022 08:14:26 -0400 Subject: [PATCH 0950/1324] Define a bunch of smart constructors. --- src/Facet/Sequent/Expr.hs | 58 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 58 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 237b9a9ff..9c3e38d21 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -5,6 +5,17 @@ module Facet.Sequent.Expr , Coterm(..) -- * Commands , Command(..) + -- ** Smart constructors +, varA +, µRA +, lamRA +, covarA +, µLA +, sumLA +, prdL1A +, prdL2A +, (.||.) +, letA -- * Interpretation , interpretTerm , interpretCoterm @@ -78,6 +89,53 @@ covar :: Index -> Coterm covar = Covar . Free +-- Smart constructors + +varA :: Applicative m => Var Index -> m Term +varA = pure . Var + +µRA :: Functor m => m Command -> m Term +µRA = fmap MuR + +lamRA :: Functor m => m Command -> m Term +lamRA = fmap LamR + + +covarA :: Applicative m => Var Index -> m Coterm +covarA = pure . Covar + +µLA :: Functor m => m Command -> m Coterm +µLA = fmap MuL + +sumLA + :: Applicative m + => m Coterm + -> m Coterm + -> m Coterm +sumLA = liftA2 SumL + +prdL1A + :: Applicative m + => m Coterm + -> m Coterm +prdL1A = fmap PrdL1 + +prdL2A + :: Applicative m + => m Coterm + -> m Coterm +prdL2A = fmap PrdL2 + + +(.||.) :: Applicative m => m Term -> m Coterm -> m Command +(.||.) = liftA2 (:|:) + +infix 1 .||. + +letA :: Applicative m => m Term -> m Command -> m Command +letA = liftA2 Let + + -- Interpreters interpretTerm :: C.Sequent t c d => [t] -> [c] -> Term -> t From 7554770f94194b47da03d6766de99d4ffeff5309 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Mar 2022 08:14:42 -0400 Subject: [PATCH 0951/1324] Pattern elaboration produces expressions. --- src/Facet/Elab/Pattern.hs | 39 +++++++++++++++------------------------ 1 file changed, 15 insertions(+), 24 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 1a9340efc..c8df6bd49 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -12,10 +12,10 @@ import Data.Foldable (fold) import Data.Monoid (First(..)) import Data.Traversable (for) import Facet.Name -import qualified Facet.Sequent.Class as SQ +import qualified Facet.Sequent.Expr as X import Facet.Sequent.Pattern import Facet.Sequent.Type -import Facet.Syntax (type (~>)) +import Facet.Syntax (Var(..)) import Fresnel.Fold (Fold, Union(..), preview) import Fresnel.Getter (to) import Fresnel.Lens (Lens', lens) @@ -35,15 +35,15 @@ instantiateHead (Var (Just _)) = Var Nothing -- FIXME: let-bind any variables fi instantiateHead p = p -compileClauses :: (Has Empty sig m, SQ.Sequent term coterm command, Applicative i) => Ctx i term -> Type -> [Clause term] -> m (i term) -compileClauses ctx (_A :-> _T) heads = SQ.lamRA $ \ wk v k -> case _A of - Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses (skip ctx wk) _T) SQ..||. pure k - _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses (skip ctx wk) _T) SQ..||. pure k - One -> (match (_Unit.to (const [])) heads >>= compileClauses (skip ctx wk) _T) SQ..||. pure k +compileClauses :: Has Empty sig m => [X.Term] -> Type -> [Clause X.Term] -> m X.Term +compileClauses ctx (_A :-> _T) heads = X.lamRA $ case _A of + Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) + _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) + One -> (match (_Unit.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) _A :* _B -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Var._Nothing.to (const [Var Nothing, Var Nothing])))) heads >>= \ heads' -> - SQ.letA (SQ.µRA (\ wk k -> pure (wk v) SQ..||. SQ.prdL1A (pure k))) (\ wkA _ -> - SQ.letA (SQ.µRA (\ wk k -> pure (wk (wkA v)) SQ..||. SQ.prdL2A (pure k))) (\ wkB _ -> - compileClauses (skip ctx (wkB . wkA . wk)) _T heads' SQ..||. pure (wkB (wkA k)))) + X.letA (X.µRA (X.varA (Free 2) X..||. X.prdL1A (X.covarA (Free 0)))) ( + X.letA (X.µRA (X.varA (Free 3) X..||. X.prdL2A (X.covarA (Free 0)))) ( + compileClauses ctx _T heads' X..||. X.covarA (Free 2))) _A :+ _B -> do (headsL, headsR) <- fold <$> for heads (\case Clause (p:ps) b -> case instantiateHead p of @@ -52,23 +52,14 @@ compileClauses ctx (_A :-> _T) heads = SQ.lamRA $ \ wk v k -> case _A of Var Nothing -> pure ([Clause (Var Nothing:ps) b], [Clause (Var Nothing:ps) b]) _ -> empty _ -> empty) - pure v SQ..||. SQ.sumLA - (SQ.µLA (\ wk2 _ -> compileClauses (skip ctx (wk2 . wk)) _T headsL SQ..||. pure (wk2 k))) - (SQ.µLA (\ wk2 _ -> compileClauses (skip ctx (wk2 . wk)) _T headsR SQ..||. pure (wk2 k))) + X.varA (Free 1) X..||. X.sumLA + (X.µLA (compileClauses ctx _T headsL X..||. X.covarA (Free 0))) + (X.µLA (compileClauses ctx _T headsR X..||. X.covarA (Free 0))) compileClauses _ _T heads - | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) = pure (pure b) + | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) = pure b | otherwise = empty -match :: Has Empty sig m => Fold (Pattern Name) [Pattern Name] -> [Clause command] -> m [Clause command] +match :: Has Empty sig m => Fold (Pattern Name) [Pattern Name] -> [Clause X.Term] -> m [Clause X.Term] match o heads = forOf (traversed.patterns_) heads (\case p:ps | Just prefix <- preview o (instantiateHead p) -> pure (prefix <> ps) _ -> empty) - - -data Ctx j t - = Nil - | forall i . Bind (Ctx i t) (i ~> j) Type (j t) - -skip :: Ctx i t -> (i ~> j) -> Ctx j t -skip Nil _ = Nil -skip (Bind ctx wk1 ty tm) wk2 = Bind ctx (wk2 . wk1) ty (wk2 tm) From beef46b79f645f9dace6ce86dfdda50c23eb6e5a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Mar 2022 08:41:18 -0400 Subject: [PATCH 0952/1324] Throw ErrReason instead of Err. This makes errors far less useful, but allows us to do simple things like look a variable up without requiring the substitution &c. (We still need the static context for e.g. the multiplier.) --- src/Facet/Elab.hs | 93 ++++++++++++++++++++-------------------- src/Facet/Elab/Term.hs | 70 +++++++++++++++--------------- src/Facet/Elab/Type.hs | 24 +++++------ src/Facet/Notice/Elab.hs | 61 +++++++++++--------------- src/Facet/REPL.hs | 2 +- src/Facet/Unify.hs | 22 +++++----- 6 files changed, 130 insertions(+), 142 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 9e7053d1b..487ab67fd 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -16,7 +16,7 @@ module Facet.Elab , (||-) -- * Errors , pushSpan -, Err(..) +-- , Err(..) , ErrReason(..) , _FreeVariable , _AmbiguousName @@ -121,7 +121,7 @@ instantiate inst = go resolveWith - :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) + :: (Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (Throw ErrReason) sig m) => (forall sig m . Has (Choose :+: Empty) sig m => Name -> Module -> m (RName :=: d)) -> QName -> m (RName :=: d) @@ -130,10 +130,10 @@ resolveWith lookup n = asks (\ StaticContext{ module', graph } -> lookupWith loo [v] -> pure v ds -> ambiguousName n (map nm ds) -resolveC :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => QName -> m (RName :=: Maybe Term ::: Type) +resolveC :: (Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (Throw ErrReason) sig m) => QName -> m (RName :=: Maybe Term ::: Type) resolveC = resolveWith lookupC -resolveQ :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => QName -> m (RName :=: Def) +resolveQ :: (Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (Throw ErrReason) sig m) => QName -> m (RName :=: Def) resolveQ = resolveWith lookupD lookupInContext :: Has (Choose :+: Empty) sig m => QName -> Context -> m (LName Index, Either Kind (Quantity, Type)) @@ -153,7 +153,7 @@ lookupInSig (m :. n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':.:_) _) interfaceScope (_ :=: d) = case d of { DSubmodule (SInterface defs) _K -> pure defs ; _ -> empty } -(|-) :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Writer Usage) sig m) => (Quantity, Pattern (Name :==> Type)) -> m a -> m a +(|-) :: Has (Reader ElabContext :+: Reader StaticContext :+: Throw ErrReason :+: Writer Usage) sig m => (Quantity, Pattern (Name :==> Type)) -> m a -> m a (q, p) |- b = do sigma <- asks scale d <- depth @@ -198,14 +198,14 @@ pushSpan :: Has (Reader ElabContext) sig m => Span -> m a -> m a pushSpan = locally spans_ . flip (:>) -data Err = Err - { source :: Source - , reason :: ErrReason - , context :: Context - , subst :: Subst Type - , sig :: [Signature Type] - , callStack :: CallStack - } +-- data Err = Err +-- { source :: Source +-- , reason :: ErrReason +-- , context :: Context +-- , subst :: Subst Type +-- , sig :: [Signature Type] +-- , callStack :: CallStack +-- } -- FIXME: not all of these need contexts/metacontexts. data ErrReason @@ -249,61 +249,62 @@ _Occurs = prism' (uncurry Occurs) (\case Occurs v c -> Just (v, c) _ -> Nothing) -applySubst :: Context -> Subst Type -> ErrReason -> ErrReason -applySubst ctx subst r = case r of - FreeVariable{} -> r - AmbiguousName{} -> r - CouldNotSynthesize{} -> r - ResourceMismatch{} -> r - -- NB: not substituting in @r@ because we want to retain the cyclic occurrence (and finitely) - UnifyType r exp act -> UnifyType r (fmap roundtrip <$> exp) (roundtrip <$> act) - UnifyKind{} -> r - Hole n t -> Hole n (roundtrip t) - Invariant{} -> r - MissingInterface i -> MissingInterface (roundtrip <$> i) - where - roundtrip = apply subst (toEnv ctx) - - -err :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m) => ErrReason -> m a +-- applySubst :: Context -> Subst Type -> ErrReason -> ErrReason +-- applySubst ctx subst r = case r of +-- FreeVariable{} -> r +-- AmbiguousName{} -> r +-- CouldNotSynthesize{} -> r +-- ResourceMismatch{} -> r +-- -- NB: not substituting in @r@ because we want to retain the cyclic occurrence (and finitely) +-- UnifyType r exp act -> UnifyType r (fmap roundtrip <$> exp) (roundtrip <$> act) +-- UnifyKind{} -> r +-- Hole n t -> Hole n (roundtrip t) +-- Invariant{} -> r +-- MissingInterface i -> MissingInterface (roundtrip <$> i) +-- where +-- roundtrip = apply subst (toEnv ctx) + + +err :: Has (Throw ErrReason) sig m => ErrReason -> m a err = throwError <=< makeErr -makeErr :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m) => ErrReason -> m Err -makeErr reason = do - StaticContext{ source } <- ask - ElabContext{ context, sig, spans } <- ask - subst <- get - pure $ Err (maybe source (slice source) (peek spans)) (applySubst context subst reason) context subst sig GHC.Stack.callStack +makeErr :: Has (Throw ErrReason) sig m => ErrReason -> m ErrReason +makeErr = pure +-- makeErr reason = do +-- StaticContext{ source } <- ask +-- ElabContext{ context, sig, spans } <- ask +-- subst <- get +-- pure $ Err (maybe source (slice source) (peek spans)) (applySubst context subst reason) context subst sig GHC.Stack.callStack -mismatchTypes :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m) => Exp (Either String Type) -> Act Type -> m a +mismatchTypes :: Has (Throw ErrReason) sig m => Exp (Either String Type) -> Act Type -> m a mismatchTypes exp act = withFrozenCallStack $ err $ UnifyType Mismatch exp act -mismatchKinds :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m) => Exp (Either String Kind) -> Act Kind -> m a +mismatchKinds :: Has (Throw ErrReason) sig m => Exp (Either String Kind) -> Act Kind -> m a mismatchKinds exp act = withFrozenCallStack $ err $ UnifyKind exp act -couldNotUnifyKinds :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m) => Exp Kind -> Act Kind -> m a +couldNotUnifyKinds :: Has (Throw ErrReason) sig m => Exp Kind -> Act Kind -> m a couldNotUnifyKinds t1 t2 = withFrozenCallStack $ mismatchKinds (Right <$> t1) t2 -couldNotSynthesize :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m) => m a +couldNotSynthesize :: Has (Throw ErrReason) sig m => m a couldNotSynthesize = withFrozenCallStack $ err CouldNotSynthesize -resourceMismatch :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m) => Name -> Quantity -> Quantity -> m a +resourceMismatch :: Has (Throw ErrReason) sig m => Name -> Quantity -> Quantity -> m a resourceMismatch n exp act = withFrozenCallStack $ err $ ResourceMismatch n exp act -freeVariable :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m) => QName -> m a +freeVariable :: Has (Throw ErrReason) sig m => QName -> m a freeVariable n = withFrozenCallStack $ err $ FreeVariable n -ambiguousName :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m) => QName -> [RName] -> m a +ambiguousName :: Has (Throw ErrReason) sig m => QName -> [RName] -> m a ambiguousName n qs = withFrozenCallStack $ err $ AmbiguousName n qs -missingInterface :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m) => Interface Type -> m a +missingInterface :: Has (Throw ErrReason) sig m => Interface Type -> m a missingInterface i = withFrozenCallStack $ err $ MissingInterface i newtype ErrC m a = ErrC { runErr :: m a } deriving (Applicative, Functor, Monad) -instance Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err) sig m => Algebra (Throw ErrReason :+: sig) (ErrC m) where +instance Has (Throw ErrReason) sig m => Algebra (Throw ErrReason :+: sig) (ErrC m) where alg hdl sig ctx = case sig of L (Throw e) -> err e R other -> ErrC (alg (runErr . hdl) other ctx) @@ -333,7 +334,7 @@ warn reason = do assertMatch :: (Exp (Either String b) -> Act s -> Elab m a) -> Prism' s a -> String -> s -> Elab m a assertMatch mismatch pat exp _T = maybe (mismatch (Exp (Left exp)) (Act _T)) pure (_T ^? pat) -assertFunction :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Maybe Name, Quantity, Type, Type) +assertFunction :: Has (Throw ErrReason) sig m => Type -> Elab m (Maybe Name, Quantity, Type, Type) assertFunction = assertMatch mismatchTypes _Arrow "_ -> _" diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index fc0ee21e8..dcb84ae33 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -97,12 +97,12 @@ import GHC.Stack -- General combinators -switch :: (HasCallStack, Has (Throw Err) sig m) => Elab m (a :==> Type) -> Type <==: Elab m a +switch :: Has (Throw ErrReason) sig m => Elab m (a :==> Type) -> Type <==: Elab m a switch m = Check $ \ _Exp -> m >>= \case a :==> T.Comp req _Act -> require req >> unify (Exp _Exp) (Act _Act) $> a a :==> _Act -> unify (Exp _Exp) (Act _Act) $> a -as :: (HasCallStack, Has (Throw Err) sig m) => (Type <==: Elab m a) ::: Elab m (Type :==> Kind) -> Elab m (a :==> Type) +as :: Has (Throw ErrReason) sig m => (Type <==: Elab m a) ::: Elab m (Type :==> Kind) -> Elab m (a :==> Type) as (m ::: _T) = do _T' <- Type.switch _T <==: KType a <- check (m ::: _T') @@ -124,7 +124,7 @@ globalS (q ::: _T) = do -- FIXME: do we need to instantiate here to deal with rank-n applications? -- FIXME: effect ops not in the sig are reported as not in scope -- FIXME: effect ops in the sig are available whether or not they’re in scope -var :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (Term :==> Type) +var :: Has (Throw ErrReason) sig m => QName -> Elab m (Term :==> Type) var n = views context_ (lookupInContext n) >>= \case [(n', Right (q, _T))] -> use n' q $> (Var (Free n') :==> _T) _ -> resolveQ n >>= \case @@ -134,7 +134,7 @@ var n = views context_ (lookupInContext n) >>= \case -- FIXME: do we need to instantiate here to deal with rank-n applications? -- FIXME: effect ops not in the sig are reported as not in scope -- FIXME: effect ops in the sig are available whether or not they’re in scope -varS :: (HasCallStack, Has (Throw Err) sig m, SQ.Sequent t c d, Applicative i) => QName -> Elab m (i t :==> Type) +varS :: ( Has (Throw ErrReason) sig m, SQ.Sequent t c d, Applicative i) =>QName -> Elab m (i t :==> Type) varS n = views context_ (lookupInContext n) >>= \case [(n', Right (q, _T))] -> do use n' q @@ -145,37 +145,37 @@ varS n = views context_ (lookupInContext n) >>= \case _ :=: _ -> freeVariable n -hole :: (HasCallStack, Has (Throw Err) sig m) => Name -> Type <==: Elab m a +hole :: Has (Throw ErrReason) sig m => Name -> Type <==: Elab m a hole n = Check $ \ _T -> withFrozenCallStack $ err $ Hole n _T -tlam :: (HasCallStack, Has (Throw Err) sig m) => Type <==: Elab m Term -> Type <==: Elab m Term +tlam :: Has (Throw ErrReason) sig m => Type <==: Elab m Term -> Type <==: Elab m Term tlam b = Check $ \ _T -> do (n, _A, _B) <- assertQuantifier _T d <- depth n :==> _A ||- check (b ::: _B (T.free (LName (getUsed d) n))) -lam :: (HasCallStack, Has (Throw Err) sig m) => [(Bind m (Pattern (Name :==> Type)), Type <==: Elab m Term)] -> Type <==: Elab m Term +lam :: Has (Throw ErrReason) sig m => [(Bind m (Pattern (Name :==> Type)), Type <==: Elab m Term)] -> Type <==: Elab m Term lam cs = Check $ \ _T -> do (_, q, _A, _B) <- assertTacitFunction _T Lam <$> traverse (\ (p, b) -> bind (p ::: (q, _A)) (check (b ::: _B))) cs -lam1 :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Type)) -> Type <==: Elab m Term -> Type <==: Elab m Term +lam1 :: Has (Throw ErrReason) sig m => Bind m (Pattern (Name :==> Type)) -> Type <==: Elab m Term -> Type <==: Elab m Term lam1 p b = lam [(p, b)] -lamS :: (HasCallStack, Has (Throw Err) sig m, SQ.Sequent t c d, Applicative i) => (forall j . Applicative j => (i ~> j) -> (j t :@ Quantity :==> Type) -> (j c :@ Quantity :==> Type) -> (Type <==: Elab m (j d))) -> Type <==: Elab m (i t) +lamS :: (Has (Throw ErrReason) sig m, SQ.Sequent t c d, Applicative i) => (forall j . Applicative j => (i ~> j) -> (j t :@ Quantity :==> Type) -> (j c :@ Quantity :==> Type) -> (Type <==: Elab m (j d))) -> Type <==: Elab m (i t) lamS f = runC $ SQ.lamRA $ \ wk a k -> C $ Check $ \ _T -> do (_, q, _A, _B) <- assertTacitFunction _T check (f wk (a :@ q :==> _A) (k :@ q :==> _B) ::: _B) -app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> (HasCallStack => Elab m (a :==> Type)) -> (HasCallStack => Type <==: Elab m b) -> Elab m (c :==> Type) +app :: Has (Throw ErrReason) sig m => (a -> b -> c) -> (HasCallStack => Elab m (a :==> Type)) -> (HasCallStack => Type <==: Elab m b) -> Elab m (c :==> Type) app mk operator operand = do f' :==> _F <- operator (_, q, _A, _B) <- assertFunction _F a' <- censor @Usage (q ><<) $ check (operand ::: _A) pure $ mk f' a' :==> _B -appS :: (HasCallStack, Has (Throw Err) sig m, SQ.Sequent t c d, Applicative i) => (HasCallStack => Elab m (i t :==> Type)) -> (HasCallStack => Type <==: Elab m (i t)) -> Elab m (i t :==> Type) +appS :: (HasCallStack, Has (Throw ErrReason) sig m, SQ.Sequent t c d, Applicative i) => (HasCallStack => Elab m (i t :==> Type)) -> (HasCallStack => Type <==: Elab m (i t)) -> Elab m (i t :==> Type) appS f a = do f' :==> _F <- f (_, q, _A, _B) <- assertFunction _F @@ -190,18 +190,18 @@ stringS :: (SQ.Sequent t c d, Applicative i) => Text -> Elab m (i t :==> Type) stringS s = SQ.stringRA s ==> pure T.String -let' :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Type)) -> Elab m (Term :==> Type) -> Type <==: Elab m Term -> Type <==: Elab m Term +let' :: Has (Throw ErrReason) sig m => Bind m (Pattern (Name :==> Type)) -> Elab m (Term :==> Type) -> Type <==: Elab m Term -> Type <==: Elab m Term let' p a b = Check $ \ _B -> do a' :==> _A <- a (p', b') <- bind (p ::: (Many, _A)) (check (b ::: _B)) pure $ Let p' a' b' -comp :: Has (Throw Err) sig m => Type <==: Elab m Term -> Type <==: Elab m Term +comp :: Has (Throw ErrReason) sig m => Type <==: Elab m Term -> Type <==: Elab m Term comp b = Check $ \ _T -> do (sig, _B) <- assertComp _T StaticContext{ graph, module' } <- ask - let interfacePattern :: Has (Throw Err) sig m => Interface Type -> Elab m (RName :=: (Name :==> Type)) + let interfacePattern :: Has (Throw ErrReason) sig m => Interface Type -> Elab m (RName :=: (Name :==> Type)) interfacePattern (Interface n _) = maybe (freeVariable (toQ n)) (\ (n' :=: _T) -> pure ((n .:. n') :=: (n' :==> _T))) (listToMaybe (scopeToList . tm =<< unDInterface . def =<< lookupQ graph module' (toQ n))) p' <- traverse interfacePattern (interfaces sig) -- FIXME: can we apply quantities to dictionaries? what would they mean? @@ -221,14 +221,14 @@ varP n = Bind $ \ _A k -> k (PVar (n :==> wrap _A)) T.Comp sig _A -> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (T.Comp sig _A) _T -> _T -conP :: (HasCallStack, Has (Throw Err) sig m) => QName -> [Bind m (Pattern (Name :==> Type))] -> Bind m (Pattern (Name :==> Type)) +conP :: Has (Throw ErrReason) sig m => QName -> [Bind m (Pattern (Name :==> Type))] -> Bind m (Pattern (Name :==> Type)) conP n fs = Bind $ \ _A k -> do n' :=: _ ::: _T <- resolveC n _T' <- maybe (pure _T) (foldl' (\ _T _A -> do t <- _T ; (_, _, b) <- assertQuantifier t ; pure (b _A)) (pure _T) . snd) (unNeutral _A) fs' <- runBind (fieldsP fs) _T' (\ (fs, _T) -> fs <$ unify (Exp _A) (Act _T)) k $ PCon n' (fromList fs') -fieldsP :: (HasCallStack, Has (Throw Err) sig m) => [Bind m a] -> Bind m ([a], Type) +fieldsP :: Has (Throw ErrReason) sig m => [Bind m a] -> Bind m ([a], Type) fieldsP = foldr cons nil where cons p ps = Bind $ \ _A k -> do @@ -237,7 +237,7 @@ fieldsP = foldr cons nil nil = Bind $ \ _T k -> k ([], _T) -allP :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Name -> Bind m (Pattern (Name :==> Type)) +allP :: Has (Throw ErrReason :+: Write Warn) sig m => Name -> Bind m (Pattern (Name :==> Type)) allP n = Bind $ \ _A k -> do (sig, _T) <- assertComp _A k (PVar (n :==> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (T.Comp sig _T))) @@ -245,7 +245,7 @@ allP n = Bind $ \ _A k -> do -- Expression elaboration -synthExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Elab m (Term :==> Type) +synthExpr :: (HasCallStack, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.Expr -> Elab m (Term :==> Type) synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \case S.Var n -> var n S.App f a -> synthApp f a @@ -255,13 +255,13 @@ synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \cas S.Lam{} -> nope where nope = couldNotSynthesize - synthApp :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Expr -> Elab m (Term :==> Type) + synthApp :: Has (Throw ErrReason :+: Write Warn) sig m => S.Ann S.Expr -> S.Ann S.Expr -> Elab m (Term :==> Type) synthApp f a = app App (synthExpr f) (checkExpr a) - synthAs :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Type -> Elab m (Term :==> Type) + synthAs :: (HasCallStack, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Type -> Elab m (Term :==> Type) synthAs t _T = as (checkExpr t ::: do { _T :==> _K <- synthType _T ; (:==> _K) <$> evalTExpr _T }) -checkExpr :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.Expr -> Type <==: Elab m Term +checkExpr :: (HasCallStack, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.Expr -> Type <==: Elab m Term checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC expr $ \case S.Hole n -> hole n S.Lam cs -> checkLam cs @@ -270,17 +270,17 @@ checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC S.As{} -> switch (synthExpr expr) S.String{} -> switch (synthExpr expr) -checkLam :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => [S.Clause] -> Type <==: Elab m Term +checkLam :: (HasCallStack, Has (Throw ErrReason :+: Write Warn) sig m) => [S.Clause] -> Type <==: Elab m Term checkLam cs = lam (snd vs) where - vs :: Has (Throw Err :+: Write Warn) sig m => ([QName :=: (Type <==: Elab m Term)], [(Bind m (Pattern (Name :==> Type)), Type <==: Elab m Term)]) + vs :: Has (Throw ErrReason :+: Write Warn) sig m => ([QName :=: (Type <==: Elab m Term)], [(Bind m (Pattern (Name :==> Type)), Type <==: Elab m Term)]) vs = partitionEithers (map (\ (S.Clause (S.Ann _ _ p) b) -> case p of S.PVal p -> Right (bindPattern p, checkExpr b) S.PEff (S.Ann s _ (S.POp n fs k)) -> Left $ n :=: Check (\ _T -> pushSpan s (foldr (lam1 . bindPattern) (checkExpr b) (fromList fs:>k) <==: _T))) cs) -- FIXME: check for unique variable names -bindPattern :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => S.Ann S.ValPattern -> Bind m (Pattern (Name :==> Type)) +bindPattern :: (HasCallStack, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.ValPattern -> Bind m (Pattern (Name :==> Type)) bindPattern = withSpanB $ \case S.PWildcard -> wildcardP S.PVar n -> varP n @@ -295,7 +295,7 @@ abstractType body = \case KArrow (Just n) a b -> TX.ForAll n a <$> (n :==> a ||- abstractType body b) _ -> body -abstractTerm :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => (Snoc TX.Type -> Snoc Term -> Term) -> Type <==: Elab m Term +abstractTerm :: Has (Throw ErrReason :+: Write Warn) sig m => (Snoc TX.Type -> Snoc Term -> Term) -> Type <==: Elab m Term abstractTerm body = go Nil Nil where go ts fs = Check $ \case @@ -309,7 +309,7 @@ abstractTerm body = go Nil Nil d <- depth pure $ body (TX.Var . Free . Right . toIndexed d <$> ts) (fs <*> pure d) -patternForArgType :: (HasCallStack, Has (Throw Err :+: Write Warn) sig m) => Type -> Name -> Bind m (Pattern (Name :==> Type)) +patternForArgType :: Has (Throw ErrReason :+: Write Warn) sig m => Type -> Name -> Bind m (Pattern (Name :==> Type)) patternForArgType = \case T.Comp{} -> allP _ -> varP @@ -318,7 +318,7 @@ patternForArgType = \case -- Declarations elabDataDef - :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source :+: Throw Err :+: Write Warn) sig m) + :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source :+: Throw ErrReason :+: Write Warn) sig m) => [S.Ann (Name ::: S.Ann S.Type)] -> Kind <==: m [Name :=: Def] -- FIXME: check that all constructors return the datatype. @@ -330,7 +330,7 @@ elabDataDef constructors = Check $ \ _K -> do pure $ n :=: DTerm (Just con') c_T elabInterfaceDef - :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source :+: Throw Err :+: Write Warn) sig m) + :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source :+: Throw ErrReason :+: Write Warn) sig m) => [S.Ann (Name ::: S.Ann S.Type)] -> Kind <==: m [Name :=: Type] elabInterfaceDef constructors = Check $ \ _K -> do @@ -340,7 +340,7 @@ elabInterfaceDef constructors = Check $ \ _K -> do -- FIXME: add a parameter for the effect signature. elabTermDef - :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source :+: Throw Err :+: Write Warn) sig m) + :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source :+: Throw ErrReason :+: Write Warn) sig m) => S.Ann S.Expr -> Type <==: m Term elabTermDef expr@(S.Ann s _ _) = Check $ \ _T -> do @@ -358,7 +358,7 @@ elabTermDef expr@(S.Ann s _ _) = Check $ \ _T -> do -- Modules elabModule - :: (HasCallStack, Has (Reader Graph :+: Reader Source :+: Throw Err :+: Write Warn) sig m) + :: (HasCallStack, Has (Reader Graph :+: Reader Source :+: Throw ErrReason :+: Write Warn) sig m) => S.Ann S.Module -> m Module elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os (Scope mempty)) $ do @@ -397,15 +397,15 @@ letrec getter key projection initial final = do -- Errors -assertQuantifier :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Name, Kind, Type -> Type) +assertQuantifier :: Has (Throw ErrReason) sig m => Type -> Elab m (Name, Kind, Type -> Type) assertQuantifier = assertMatch mismatchTypes _ForAll "{_} -> _" -- | Expect a tacit (non-variable-binding) lamction type. -assertTacitFunction :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Maybe Name, Quantity, Type, Type) +assertTacitFunction :: Has (Throw ErrReason) sig m => Type -> Elab m (Maybe Name, Quantity, Type, Type) assertTacitFunction = assertMatch mismatchTypes _Arrow "_ -> _" -- | Expect a computation type with effects. -assertComp :: (HasCallStack, Has (Throw Err) sig m) => Type -> Elab m (Signature Type, Type) +assertComp :: Has (Throw ErrReason) sig m => Type -> Elab m (Signature Type, Type) assertComp = assertMatch mismatchTypes _Comp "[_] _" @@ -431,7 +431,7 @@ provide sig m = do env <- views context_ toEnv locally sig_ (mapSignature (apply subst env) sig :) m -require :: (HasCallStack, Has (Throw Err) sig m) => Signature Type -> Elab m () +require :: Has (Throw ErrReason) sig m => Signature Type -> Elab m () require req = do prv <- view sig_ for_ (interfaces req) $ \ i -> findMaybeA (findMaybeA (runUnifyMaybe . unifyInterface i) . interfaces) prv >>= \case @@ -450,7 +450,7 @@ check (m ::: _T) = case _T of _T -> m <==: _T -bind :: (HasCallStack, Has (Throw Err) sig m) => Bind m (Pattern (Name :==> Type)) ::: (Quantity, Type) -> Elab m b -> Elab m (Pattern Name, b) +bind :: (Has (Throw ErrReason) sig m) => Bind m (Pattern (Name :==> Type)) ::: (Quantity, Type) -> Elab m b -> Elab m (Pattern Name, b) bind (p ::: (q, _T)) m = runBind p _T (\ p' -> (proof <$> p',) <$> ((q, p') |- m)) newtype Bind m a = Bind { runBind :: forall x . Type -> (a -> Elab m x) -> Elab m x } diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 17fe05b0f..c6e7bd0d1 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -12,7 +12,6 @@ module Facet.Elab.Type import Control.Algebra import Control.Applicative (liftA2) import Control.Effect.Reader -import Control.Effect.State import Control.Effect.Throw import Control.Monad (unless) import Data.Foldable (foldl') @@ -26,21 +25,18 @@ import Facet.Module import Facet.Name import Facet.Semiring (Few(..), one, zero) import Facet.Snoc -import Facet.Subst import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) import qualified Facet.Type.Expr as TX -import Facet.Type.Norm -import GHC.Stack -tvar :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (TX.Type :==> Kind) +tvar :: Has (Throw ErrReason) sig m => QName -> Elab m (TX.Type :==> Kind) tvar n = views context_ (lookupInContext n) >>= \case [(n', Left _K)] -> pure (TX.Var (Free (Right n')) :==> _K) _ -> resolveQ n >>= \case q :=: DSubmodule _ _K -> pure $ TX.Var (Global q) :==> _K _ -> freeVariable n -ivar :: (HasCallStack, Has (Throw Err) sig m) => QName -> Elab m (RName :==> Kind) +ivar :: Has (Throw ErrReason) sig m => QName -> Elab m (RName :==> Kind) ivar n = resolveQ n >>= \case q :=: DSubmodule (SInterface _) _K -> pure $ q :==> _K _ -> freeVariable n @@ -50,19 +46,19 @@ _String :: Applicative m => m (TX.Type :==> Kind) _String = pure $ TX.String :==> KType -forAll :: (HasCallStack, Has (Throw Err) sig m) => Name ::: Kind -> Elab m (TX.Type :==> Kind) -> Elab m (TX.Type :==> Kind) +forAll :: Has (Throw ErrReason) sig m => Name ::: Kind -> Elab m (TX.Type :==> Kind) -> Elab m (TX.Type :==> Kind) forAll (n ::: t) b = do b' <- n :==> t ||- switch b <==: KType pure $ TX.ForAll n t b' :==> KType -arrow :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> Elab m (a :==> Kind) -> Elab m (b :==> Kind) -> Elab m (c :==> Kind) +arrow :: Has (Throw ErrReason) sig m => (a -> b -> c) -> Elab m (a :==> Kind) -> Elab m (b :==> Kind) -> Elab m (c :==> Kind) arrow mk a b = do a' <- switch a <==: KType b' <- switch b <==: KType pure $ mk a' b' :==> KType -app :: (HasCallStack, Has (Throw Err) sig m) => (a -> b -> c) -> Elab m (a :==> Kind) -> Elab m (b :==> Kind) -> Elab m (c :==> Kind) +app :: Has (Throw ErrReason) sig m => (a -> b -> c) -> Elab m (a :==> Kind) -> Elab m (b :==> Kind) -> Elab m (c :==> Kind) app mk f a = do f' :==> _F <- f (_, _A, _B) <- assertTypeConstructor _F @@ -71,7 +67,7 @@ app mk f a = do pure $ mk f' a' :==> _B -comp :: (HasCallStack, Has (Throw Err) sig m) => [Elab m (Interface TX.Type :==> Kind)] -> Elab m (TX.Type :==> Kind) -> Elab m (TX.Type :==> Kind) +comp :: Has (Throw ErrReason) sig m => [Elab m (Interface TX.Type :==> Kind)] -> Elab m (TX.Type :==> Kind) -> Elab m (TX.Type :==> Kind) comp s t = do s' <- traverse ((<==: KInterface) . switch) s -- FIXME: polarize types and check that this is a value type being returned @@ -79,7 +75,7 @@ comp s t = do pure $ TX.Comp (fromInterfaces s') t' :==> KType -synthType :: (HasCallStack, Has (Throw Err) sig m) => S.Ann S.Type -> Elab m (TX.Type :==> Kind) +synthType :: Has (Throw ErrReason) sig m => S.Ann S.Type -> Elab m (TX.Type :==> Kind) synthType (S.Ann s _ e) = pushSpan s $ case e of S.TVar n -> tvar n S.TString -> Facet.Elab.Type._String @@ -92,7 +88,7 @@ synthType (S.Ann s _ e) = pushSpan s $ case e of S.Zero -> zero S.One -> one -synthInterface :: (HasCallStack, Has (Throw Err) sig m) => S.Ann (S.Interface (S.Ann S.Type)) -> Elab m (Interface TX.Type :==> Kind) +synthInterface :: Has (Throw ErrReason) sig m => S.Ann (S.Interface (S.Ann S.Type)) -> Elab m (Interface TX.Type :==> Kind) synthInterface (S.Ann s _ (S.Interface h sp)) = pushSpan s $ do -- FIXME: check that the application actually result in an Interface h' :==> _ <- ivar h @@ -102,13 +98,13 @@ synthInterface (S.Ann s _ (S.Interface h sp)) = pushSpan s $ do -- Assertions -assertTypeConstructor :: (HasCallStack, Has (Throw Err) sig m) => Kind -> Elab m (Maybe Name, Kind, Kind) +assertTypeConstructor :: Has (Throw ErrReason) sig m => Kind -> Elab m (Maybe Name, Kind, Kind) assertTypeConstructor = assertMatch mismatchKinds _KArrow "_ -> _" -- Judgements -switch :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => m (a :==> Kind) -> Kind <==: m a +switch :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => m (a :==> Kind) -> Kind <==: m a switch m = Check $ \ _K -> do a :==> _KA <- m a <$ unless (_KA == _K) (couldNotUnifyKinds (Exp _K) (Act _KA)) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 30e07548e..0efe7c4ca 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -4,59 +4,50 @@ module Facet.Notice.Elab , rethrowElabWarnings ) where -import Data.Foldable (foldl') import Data.Semigroup (stimes) import qualified Facet.Carrier.Throw.Inject as L import qualified Facet.Carrier.Write.Inject as L -import Facet.Context as C import Facet.Elab as Elab import qualified Facet.Env as Env -import Facet.Functor.Synth -import Facet.Interface (interfaces) -import Facet.Name (LName(..)) import Facet.Notice as Notice hiding (level) -import Facet.Pattern import Facet.Pretty import Facet.Print as Print -import Facet.Semiring (Few(..), one, zero) -import Facet.Snoc +import Facet.Semiring (Few(..)) import Facet.Style -import Facet.Subst (metas) import Facet.Syntax hiding (ann) -import Facet.Type.Norm (apply, free, metavar) -import GHC.Stack +import Facet.Type.Norm (metavar) import Prelude hiding (print, unlines) import Silkscreen -- Elaboration -rethrowElabErrors :: Applicative m => Options Print -> L.ThrowC (Notice (Doc Style)) Err m a -> m a +rethrowElabErrors :: Applicative m => Options Print -> L.ThrowC (Notice (Doc Style)) ErrReason m a -> m a rethrowElabErrors opts = L.runThrow (pure . rethrow) where - rethrow Err{ source, reason, context, subst, sig, callStack } = Notice.Notice (Just Error) [source] (printErrReason opts printCtx reason) - [ nest 2 (pretty "Context" <\> concatWith (<\>) ctx) - , nest 2 (pretty "Metacontext" <\> concatWith (<\>) subst') - , nest 2 (pretty "Provided interfaces" <\> concatWith (<\>) sig') - , pretty (prettyCallStack callStack) - ] + rethrow reason = Notice.Notice (Just Error) [] (printErrReason opts mempty reason) [] + -- [ nest 2 (pretty "Context" <\> concatWith (<\>) ctx) + -- , nest 2 (pretty "Metacontext" <\> concatWith (<\>) subst') + -- , nest 2 (pretty "Provided interfaces" <\> concatWith (<\>) sig') + -- , pretty (prettyCallStack callStack) + -- ] where - (_, _, printCtx, ctx) = foldl' combine (0, Env.empty, Env.empty, Nil) (elems context) - subst' = map (\ (m :=: v) -> getPrint (Print.meta m <+> pretty '=' <+> maybe (pretty '?') (print opts printCtx) v)) (metas subst) - sig' = getPrint . print opts printCtx . fmap (apply subst (toEnv context)) <$> (interfaces =<< sig) - combine (d, env, prints, ctx) (C.Kind (n :==> _K)) = - ( succ d - , env Env.|> PVar (n :=: free (LName d n)) - , prints Env.|> PVar (n :=: intro n d) - , ctx :> getPrint (print opts prints (ann (intro n d ::: print opts prints _K))) ) - combine (d, env, prints, ctx) (C.Type m _ p) = - ( succ d - , env Env.|> ((\ (n :==> _T) -> n :=: free (LName d n)) <$> p) - , prints Env.|> ((\ (n :==> _) -> n :=: intro n d) <$> p) - , ctx :> getPrint (print opts prints ((\ (n :==> _T) -> ann (intro n d ::: mult m (print opts prints (apply subst env _T)))) <$> p)) ) - mult m - | m == zero = (pretty "0" <+>) - | m == one = (pretty "1" <+>) - | otherwise = id + -- (_, _, printCtx, ctx) = foldl' combine (0, Env.empty, Env.empty, Nil) (elems context) + -- subst' = map (\ (m :=: v) -> getPrint (Print.meta m <+> pretty '=' <+> maybe (pretty '?') (print opts printCtx) v)) (metas subst) + -- sig' = getPrint . print opts printCtx . fmap (apply subst (toEnv context)) <$> (interfaces =<< sig) + -- combine (d, env, prints, ctx) (C.Kind (n :==> _K)) = + -- ( succ d + -- , env Env.|> PVar (n :=: free (LName d n)) + -- , prints Env.|> PVar (n :=: intro n d) + -- , ctx :> getPrint (print opts prints (ann (intro n d ::: print opts prints _K))) ) + -- combine (d, env, prints, ctx) (C.Type m _ p) = + -- ( succ d + -- , env Env.|> ((\ (n :==> _T) -> n :=: free (LName d n)) <$> p) + -- , prints Env.|> ((\ (n :==> _) -> n :=: intro n d) <$> p) + -- , ctx :> getPrint (print opts prints ((\ (n :==> _T) -> ann (intro n d ::: mult m (print opts prints (apply subst env _T)))) <$> p)) ) + -- mult m + -- | m == zero = (pretty "0" <+>) + -- | m == one = (pretty "1" <+>) + -- | otherwise = id printErrReason :: Options Print -> Env.Env Print -> ErrReason -> Doc Style diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index 773588459..4847b18dc 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -243,7 +243,7 @@ prompt = do p <- liftIO $ fn line fmap (sourceFromString Nothing line) <$> getInputLine p -runElab :: Has (State (Options Print) :+: State REPL) sig m => I.WriteC (Notice.Notice (Doc Style)) Elab.Warn (I.ThrowC (Notice.Notice (Doc Style)) Elab.Err (ReaderC MName (ReaderC Module (ReaderC Graph m)))) a -> m a +runElab :: Has (State (Options Print) :+: State REPL) sig m => I.WriteC (Notice.Notice (Doc Style)) Elab.Warn (I.ThrowC (Notice.Notice (Doc Style)) Elab.ErrReason (ReaderC MName (ReaderC Module (ReaderC Graph m)))) a -> m a runElab m = do graph <- use (target_.modules_) localDefs <- use localDefs_ diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index c1238c202..f001e7e56 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -36,22 +36,22 @@ import GHC.Stack -- Unification -- FIXME: we don’t get good source references during unification -unify :: (HasCallStack, Has (Throw Err) sig m) => Exp Type -> Act Type -> Elab m Type +unify :: (HasCallStack, Has (Throw ErrReason) sig m) => Exp Type -> Act Type -> Elab m Type unify t1 t2 = runUnify t1 t2 (unifyType (getExp t1) (getAct t2)) -runUnify :: Has (Throw Err) sig m => Exp Type -> Act Type -> ThrowC Err (WithCallStack UnifyErrReason) (Elab m) a -> Elab m a +runUnify :: Has (Throw ErrReason) sig m => Exp Type -> Act Type -> ThrowC ErrReason (WithCallStack UnifyErrReason) (Elab m) a -> Elab m a runUnify t1 t2 = runThrow (withCallStack (\ r -> makeErr (UnifyType r (Right <$> t1) t2))) runUnifyMaybe :: Applicative m => ErrorC (WithCallStack UnifyErrReason) m a -> m (Maybe a) runUnifyMaybe = runError (const (pure Nothing)) (pure . Just) -mismatch :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => m a +mismatch :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => m a mismatch = withFrozenCallStack $ throwError $ WithCallStack GHC.Stack.callStack Mismatch -occurs :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Type -> m a +occurs :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Type -> m a occurs v t = withFrozenCallStack $ throwError $ WithCallStack GHC.Stack.callStack (Occurs v t) -unifyType :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Type -> Type -> m Type +unifyType :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Type -> Type -> m Type unifyType = curry $ \case (TN.Comp s1 t1, TN.Comp s2 t2) -> TN.Comp . fromInterfaces <$> unifySpine unifyInterface (interfaces s1) (interfaces s2) <*> unifyType t1 t2 (TN.Comp s1 t1, t2) -> TN.Comp s1 <$> unifyType t1 t2 @@ -70,19 +70,19 @@ unifyType = curry $ \case where mkForAll d n k b = TX.ForAll n k (runQuoter (succ d) (quote b)) -unifyKind :: Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m => Kind -> Kind -> m Kind +unifyKind :: Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m => Kind -> Kind -> m Kind unifyKind k1 k2 = if k1 == k2 then pure k2 else mismatch -unifyVar :: (Eq a, Eq b, HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Var (Either a b) -> Var (Either a b) -> m (Var (Either a b)) +unifyVar :: (Eq a, Eq b, HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Var (Either a b) -> Var (Either a b) -> m (Var (Either a b)) unifyVar v1 v2 = if v1 == v2 then pure v2 else mismatch -unifyInterface :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Interface Type -> Interface Type -> m (Interface Type) +unifyInterface :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Interface Type -> Interface Type -> m (Interface Type) unifyInterface (Interface h1 sp1) (Interface h2 sp2) = Interface h2 <$ unless (h1 == h2) mismatch <*> unifySpine unifyType sp1 sp2 -unifySpine :: (Traversable t, Zip t, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => (a -> b -> m c) -> t a -> t b -> m (t c) +unifySpine :: (Traversable t, Zip t, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => (a -> b -> m c) -> t a -> t b -> m (t c) unifySpine f sp1 sp2 = unless (length sp1 == length sp2) mismatch >> zipWithM f sp1 sp2 -flexFlex :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Meta -> m Type +flexFlex :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Meta -> m Type flexFlex v1 v2 | v1 == v2 = pure (metavar v2) | otherwise = gets (\ s -> (lookupMeta v1 s, lookupMeta v2 s)) >>= \case @@ -91,7 +91,7 @@ flexFlex v1 v2 (Nothing, Just t2) -> unifyType (metavar v1) t2 (Nothing, Nothing) -> solve v1 (metavar v2) -solve :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw Err :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Type -> m Type +solve :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Type -> m Type solve v t = do d <- depth if occursIn v (getUsed d) t then From 5c2c0ec84239353e24d62055d85066401e2ab29a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Mar 2022 08:45:23 -0400 Subject: [PATCH 0953/1324] :fire: the scale during variable lookup. We just assume it's one, since this is never used during type elaboration. --- src/Facet/Elab.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 487ab67fd..434fc0b24 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -153,13 +153,12 @@ lookupInSig (m :. n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':.:_) _) interfaceScope (_ :=: d) = case d of { DSubmodule (SInterface defs) _K -> pure defs ; _ -> empty } -(|-) :: Has (Reader ElabContext :+: Reader StaticContext :+: Throw ErrReason :+: Writer Usage) sig m => (Quantity, Pattern (Name :==> Type)) -> m a -> m a +(|-) :: Has (Reader ElabContext :+: Throw ErrReason :+: Writer Usage) sig m => (Quantity, Pattern (Name :==> Type)) -> m a -> m a (q, p) |- b = do - sigma <- asks scale d <- depth (u, a) <- censor (`Usage.withoutVars` Vars.singleton (getUsed d)) $ listen $ locally context_ (|> Type q id p) b for_ p $ \ (n :==> _T) -> do - let exp = sigma >< q + let exp = q act = Usage.lookup (LName (getUsed d) n) u unless (act `sat` exp) $ resourceMismatch n exp act From 8f6cf4aacac7aabfda83628486f6ee09827f4d52 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Mar 2022 08:46:15 -0400 Subject: [PATCH 0954/1324] :fire: the scale from static contexts. --- src/Facet/Elab.hs | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 434fc0b24..3789abca0 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -344,7 +344,6 @@ data StaticContext = StaticContext { graph :: Graph , module' :: Module , source :: Source - , scale :: Quantity } data ElabContext = ElabContext @@ -368,24 +367,24 @@ spans_ = lens spans (\ e spans -> e{ spans }) newtype Elab m a = Elab { runElab :: ReaderC ElabContext (ReaderC StaticContext (WriterC Usage (StateC (Subst Type) m))) a } deriving (Algebra (Reader ElabContext :+: Reader StaticContext :+: Writer Usage :+: State (Subst Type) :+: sig), Applicative, Functor, Monad) -elabWith :: Has (Reader Graph :+: Reader Module :+: Reader Source) sig m => Quantity -> (Subst Type -> a -> m b) -> Elab m a -> m b -elabWith scale k m = runState k mempty . runWriter (const pure) $ do +elabWith :: Has (Reader Graph :+: Reader Module :+: Reader Source) sig m => (Subst Type -> a -> m b) -> Elab m a -> m b +elabWith k m = runState k mempty . runWriter (const pure) $ do (graph, module', source) <- (,,) <$> ask <*> ask <*> ask - let stat = StaticContext{ graph, module', source, scale } + let stat = StaticContext{ graph, module', source } ctx = ElabContext{ context = Context.empty, sig = mempty, spans = Nil } runReader stat . runReader ctx . runElab $ m elabKind :: Has (Reader Graph :+: Reader Module :+: Reader Source) sig m => Elab m Kind -> m Kind -elabKind = elabWith zero (const pure) +elabKind = elabWith (const pure) elabType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m TX.Type -> m Type -elabType = elabWith zero (\ subst t -> pure (TN.eval subst Env.empty t)) +elabType = elabWith (\ subst t -> pure (TN.eval subst Env.empty t)) elabTerm :: Has (Reader Graph :+: Reader Module :+: Reader Source) sig m => Elab m Term -> m Term -elabTerm = elabWith one (const pure) +elabTerm = elabWith (const pure) elabSynthTerm :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (Term :==> Type) -> m (Term :==> Type) -elabSynthTerm = elabWith one (\ subst (e :==> _T) -> pure (e :==> TN.eval subst Env.empty (runQuoter 0 (quote _T)))) +elabSynthTerm = elabWith (\ subst (e :==> _T) -> pure (e :==> TN.eval subst Env.empty (runQuoter 0 (quote _T)))) elabSynthType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (TX.Type :==> Kind) -> m (Type :==> Kind) -elabSynthType = elabWith zero (\ subst (_T :==> _K) -> pure (TN.eval subst Env.empty _T :==> _K)) +elabSynthType = elabWith (\ subst (_T :==> _K) -> pure (TN.eval subst Env.empty _T :==> _K)) From aa96bc42b15eae2dacbebc14c3e5ef495099207b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Mar 2022 09:17:33 -0400 Subject: [PATCH 0955/1324] Define an optic for static contexts' modules. --- src/Facet/Elab.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 3789abca0..4ea85253e 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -41,6 +41,7 @@ module Facet.Elab , warn -- * Unification , StaticContext(..) +, module_ , ElabContext(..) , context_ , sig_ @@ -346,6 +347,9 @@ data StaticContext = StaticContext , source :: Source } +module_ :: Lens' StaticContext Module +module_ = lens module' (\ s module' -> s{ module' }) + data ElabContext = ElabContext { context :: Context , sig :: [Signature Type] From ac98a2fb6e8d2897b64900875058153dfcf03018 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Mar 2022 09:35:59 -0400 Subject: [PATCH 0956/1324] :fire: StaticContext. --- src/Facet/Elab.hs | 42 ++++++++++++++---------------------------- src/Facet/Elab/Term.hs | 31 ++++++++++++++++--------------- src/Facet/Elab/Type.hs | 9 +++++---- src/Facet/Unify.hs | 18 +++++++++--------- 4 files changed, 44 insertions(+), 56 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 4ea85253e..061065b9f 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -40,8 +40,6 @@ module Facet.Elab , WarnReason(..) , warn -- * Unification -, StaticContext(..) -, module_ , ElabContext(..) , context_ , sig_ @@ -122,19 +120,19 @@ instantiate inst = go resolveWith - :: (Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (Throw ErrReason) sig m) + :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => (forall sig m . Has (Choose :+: Empty) sig m => Name -> Module -> m (RName :=: d)) -> QName -> m (RName :=: d) -resolveWith lookup n = asks (\ StaticContext{ module', graph } -> lookupWith lookup graph module' n) >>= \case +resolveWith lookup n = ask >>= \ graph -> asks (\ module' -> lookupWith lookup graph module' n) >>= \case [] -> freeVariable n [v] -> pure v ds -> ambiguousName n (map nm ds) -resolveC :: (Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (Throw ErrReason) sig m) => QName -> m (RName :=: Maybe Term ::: Type) +resolveC :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (RName :=: Maybe Term ::: Type) resolveC = resolveWith lookupC -resolveQ :: (Has (Reader ElabContext) sig m, Has (Reader StaticContext) sig m, Has (Throw ErrReason) sig m) => QName -> m (RName :=: Def) +resolveQ :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (RName :=: Def) resolveQ = resolveWith lookupD lookupInContext :: Has (Choose :+: Empty) sig m => QName -> Context -> m (LName Index, Either Kind (Quantity, Type)) @@ -322,9 +320,9 @@ data WarnReason | RedundantVariable Name -warn :: Has (Write Warn) sig m => WarnReason -> Elab m () +warn :: (Has (Reader Source) sig m, Has (Write Warn) sig m) => WarnReason -> Elab m () warn reason = do - StaticContext{ source } <- ask + source <- ask ElabContext{ spans } <- ask write $ Warn (maybe source (slice source) (peek spans)) reason @@ -340,16 +338,6 @@ assertFunction = assertMatch mismatchTypes _Arrow "_ -> _" -- Unification --- | Context which doesn’t change during elaboration of a single term. -data StaticContext = StaticContext - { graph :: Graph - , module' :: Module - , source :: Source - } - -module_ :: Lens' StaticContext Module -module_ = lens module' (\ s module' -> s{ module' }) - data ElabContext = ElabContext { context :: Context , sig :: [Signature Type] @@ -368,23 +356,21 @@ spans_ = lens spans (\ e spans -> e{ spans }) -- Machinery -newtype Elab m a = Elab { runElab :: ReaderC ElabContext (ReaderC StaticContext (WriterC Usage (StateC (Subst Type) m))) a } - deriving (Algebra (Reader ElabContext :+: Reader StaticContext :+: Writer Usage :+: State (Subst Type) :+: sig), Applicative, Functor, Monad) +newtype Elab m a = Elab { runElab :: ReaderC ElabContext (WriterC Usage (StateC (Subst Type) m)) a } + deriving (Algebra (Reader ElabContext :+: Writer Usage :+: State (Subst Type) :+: sig), Applicative, Functor, Monad) -elabWith :: Has (Reader Graph :+: Reader Module :+: Reader Source) sig m => (Subst Type -> a -> m b) -> Elab m a -> m b +elabWith :: (Subst Type -> a -> m b) -> Elab m a -> m b elabWith k m = runState k mempty . runWriter (const pure) $ do - (graph, module', source) <- (,,) <$> ask <*> ask <*> ask - let stat = StaticContext{ graph, module', source } - ctx = ElabContext{ context = Context.empty, sig = mempty, spans = Nil } - runReader stat . runReader ctx . runElab $ m + let ctx = ElabContext{ context = Context.empty, sig = mempty, spans = Nil } + runReader ctx . runElab $ m -elabKind :: Has (Reader Graph :+: Reader Module :+: Reader Source) sig m => Elab m Kind -> m Kind +elabKind :: Applicative m => Elab m Kind -> m Kind elabKind = elabWith (const pure) -elabType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m TX.Type -> m Type +elabType :: (HasCallStack, Applicative m) => Elab m TX.Type -> m Type elabType = elabWith (\ subst t -> pure (TN.eval subst Env.empty t)) -elabTerm :: Has (Reader Graph :+: Reader Module :+: Reader Source) sig m => Elab m Term -> m Term +elabTerm :: Applicative m => Elab m Term -> m Term elabTerm = elabWith (const pure) elabSynthTerm :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (Term :==> Type) -> m (Term :==> Type) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index dcb84ae33..0719bd559 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -124,7 +124,7 @@ globalS (q ::: _T) = do -- FIXME: do we need to instantiate here to deal with rank-n applications? -- FIXME: effect ops not in the sig are reported as not in scope -- FIXME: effect ops in the sig are available whether or not they’re in scope -var :: Has (Throw ErrReason) sig m => QName -> Elab m (Term :==> Type) +var :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> Elab m (Term :==> Type) var n = views context_ (lookupInContext n) >>= \case [(n', Right (q, _T))] -> use n' q $> (Var (Free n') :==> _T) _ -> resolveQ n >>= \case @@ -134,7 +134,7 @@ var n = views context_ (lookupInContext n) >>= \case -- FIXME: do we need to instantiate here to deal with rank-n applications? -- FIXME: effect ops not in the sig are reported as not in scope -- FIXME: effect ops in the sig are available whether or not they’re in scope -varS :: ( Has (Throw ErrReason) sig m, SQ.Sequent t c d, Applicative i) =>QName -> Elab m (i t :==> Type) +varS :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m, SQ.Sequent t c d, Applicative i) =>QName -> Elab m (i t :==> Type) varS n = views context_ (lookupInContext n) >>= \case [(n', Right (q, _T))] -> do use n' q @@ -197,10 +197,11 @@ let' p a b = Check $ \ _B -> do pure $ Let p' a' b' -comp :: Has (Throw ErrReason) sig m => Type <==: Elab m Term -> Type <==: Elab m Term +comp :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => Type <==: Elab m Term -> Type <==: Elab m Term comp b = Check $ \ _T -> do (sig, _B) <- assertComp _T - StaticContext{ graph, module' } <- ask + graph <- ask + module' <- ask let interfacePattern :: Has (Throw ErrReason) sig m => Interface Type -> Elab m (RName :=: (Name :==> Type)) interfacePattern (Interface n _) = maybe (freeVariable (toQ n)) (\ (n' :=: _T) -> pure ((n .:. n') :=: (n' :==> _T))) (listToMaybe (scopeToList . tm =<< unDInterface . def =<< lookupQ graph module' (toQ n))) p' <- traverse interfacePattern (interfaces sig) @@ -221,7 +222,7 @@ varP n = Bind $ \ _A k -> k (PVar (n :==> wrap _A)) T.Comp sig _A -> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (T.Comp sig _A) _T -> _T -conP :: Has (Throw ErrReason) sig m => QName -> [Bind m (Pattern (Name :==> Type))] -> Bind m (Pattern (Name :==> Type)) +conP :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> [Bind m (Pattern (Name :==> Type))] -> Bind m (Pattern (Name :==> Type)) conP n fs = Bind $ \ _A k -> do n' :=: _ ::: _T <- resolveC n _T' <- maybe (pure _T) (foldl' (\ _T _A -> do t <- _T ; (_, _, b) <- assertQuantifier t ; pure (b _A)) (pure _T) . snd) (unNeutral _A) @@ -245,7 +246,7 @@ allP n = Bind $ \ _A k -> do -- Expression elaboration -synthExpr :: (HasCallStack, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.Expr -> Elab m (Term :==> Type) +synthExpr :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.Expr -> Elab m (Term :==> Type) synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \case S.Var n -> var n S.App f a -> synthApp f a @@ -255,13 +256,13 @@ synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \cas S.Lam{} -> nope where nope = couldNotSynthesize - synthApp :: Has (Throw ErrReason :+: Write Warn) sig m => S.Ann S.Expr -> S.Ann S.Expr -> Elab m (Term :==> Type) + synthApp :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Expr -> Elab m (Term :==> Type) synthApp f a = app App (synthExpr f) (checkExpr a) - synthAs :: (HasCallStack, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Type -> Elab m (Term :==> Type) + synthAs :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Type -> Elab m (Term :==> Type) synthAs t _T = as (checkExpr t ::: do { _T :==> _K <- synthType _T ; (:==> _K) <$> evalTExpr _T }) -checkExpr :: (HasCallStack, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.Expr -> Type <==: Elab m Term +checkExpr :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.Expr -> Type <==: Elab m Term checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC expr $ \case S.Hole n -> hole n S.Lam cs -> checkLam cs @@ -270,17 +271,17 @@ checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC S.As{} -> switch (synthExpr expr) S.String{} -> switch (synthExpr expr) -checkLam :: (HasCallStack, Has (Throw ErrReason :+: Write Warn) sig m) => [S.Clause] -> Type <==: Elab m Term +checkLam :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => [S.Clause] -> Type <==: Elab m Term checkLam cs = lam (snd vs) where - vs :: Has (Throw ErrReason :+: Write Warn) sig m => ([QName :=: (Type <==: Elab m Term)], [(Bind m (Pattern (Name :==> Type)), Type <==: Elab m Term)]) + vs :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => ([QName :=: (Type <==: Elab m Term)], [(Bind m (Pattern (Name :==> Type)), Type <==: Elab m Term)]) vs = partitionEithers (map (\ (S.Clause (S.Ann _ _ p) b) -> case p of S.PVal p -> Right (bindPattern p, checkExpr b) S.PEff (S.Ann s _ (S.POp n fs k)) -> Left $ n :=: Check (\ _T -> pushSpan s (foldr (lam1 . bindPattern) (checkExpr b) (fromList fs:>k) <==: _T))) cs) -- FIXME: check for unique variable names -bindPattern :: (HasCallStack, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.ValPattern -> Bind m (Pattern (Name :==> Type)) +bindPattern :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.ValPattern -> Bind m (Pattern (Name :==> Type)) bindPattern = withSpanB $ \case S.PWildcard -> wildcardP S.PVar n -> varP n @@ -318,7 +319,7 @@ patternForArgType = \case -- Declarations elabDataDef - :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source :+: Throw ErrReason :+: Write Warn) sig m) + :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => [S.Ann (Name ::: S.Ann S.Type)] -> Kind <==: m [Name :=: Def] -- FIXME: check that all constructors return the datatype. @@ -330,7 +331,7 @@ elabDataDef constructors = Check $ \ _K -> do pure $ n :=: DTerm (Just con') c_T elabInterfaceDef - :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source :+: Throw ErrReason :+: Write Warn) sig m) + :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => [S.Ann (Name ::: S.Ann S.Type)] -> Kind <==: m [Name :=: Type] elabInterfaceDef constructors = Check $ \ _K -> do @@ -340,7 +341,7 @@ elabInterfaceDef constructors = Check $ \ _K -> do -- FIXME: add a parameter for the effect signature. elabTermDef - :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source :+: Throw ErrReason :+: Write Warn) sig m) + :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.Expr -> Type <==: m Term elabTermDef expr@(S.Ann s _ _) = Check $ \ _T -> do diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index c6e7bd0d1..fad0cb9d6 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -18,6 +18,7 @@ import Data.Foldable (foldl') import Facet.Elab import Facet.Functor.Check import Facet.Functor.Synth +import Facet.Graph (Graph) import Facet.Interface import Facet.Kind import Facet.Lens (views) @@ -29,14 +30,14 @@ import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) import qualified Facet.Type.Expr as TX -tvar :: Has (Throw ErrReason) sig m => QName -> Elab m (TX.Type :==> Kind) +tvar :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> Elab m (TX.Type :==> Kind) tvar n = views context_ (lookupInContext n) >>= \case [(n', Left _K)] -> pure (TX.Var (Free (Right n')) :==> _K) _ -> resolveQ n >>= \case q :=: DSubmodule _ _K -> pure $ TX.Var (Global q) :==> _K _ -> freeVariable n -ivar :: Has (Throw ErrReason) sig m => QName -> Elab m (RName :==> Kind) +ivar :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> Elab m (RName :==> Kind) ivar n = resolveQ n >>= \case q :=: DSubmodule (SInterface _) _K -> pure $ q :==> _K _ -> freeVariable n @@ -75,7 +76,7 @@ comp s t = do pure $ TX.Comp (fromInterfaces s') t' :==> KType -synthType :: Has (Throw ErrReason) sig m => S.Ann S.Type -> Elab m (TX.Type :==> Kind) +synthType :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => S.Ann S.Type -> Elab m (TX.Type :==> Kind) synthType (S.Ann s _ e) = pushSpan s $ case e of S.TVar n -> tvar n S.TString -> Facet.Elab.Type._String @@ -88,7 +89,7 @@ synthType (S.Ann s _ e) = pushSpan s $ case e of S.Zero -> zero S.One -> one -synthInterface :: Has (Throw ErrReason) sig m => S.Ann (S.Interface (S.Ann S.Type)) -> Elab m (Interface TX.Type :==> Kind) +synthInterface :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => S.Ann (S.Interface (S.Ann S.Type)) -> Elab m (Interface TX.Type :==> Kind) synthInterface (S.Ann s _ (S.Interface h sp)) = pushSpan s $ do -- FIXME: check that the application actually result in an Interface h' :==> _ <- ivar h diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index f001e7e56..d8e4bfba5 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -45,13 +45,13 @@ runUnify t1 t2 = runThrow (withCallStack (\ r -> makeErr (UnifyType r (Right <$> runUnifyMaybe :: Applicative m => ErrorC (WithCallStack UnifyErrReason) m a -> m (Maybe a) runUnifyMaybe = runError (const (pure Nothing)) (pure . Just) -mismatch :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => m a +mismatch :: (HasCallStack, Has (Reader ElabContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => m a mismatch = withFrozenCallStack $ throwError $ WithCallStack GHC.Stack.callStack Mismatch -occurs :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Type -> m a +occurs :: (HasCallStack, Has (Reader ElabContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Type -> m a occurs v t = withFrozenCallStack $ throwError $ WithCallStack GHC.Stack.callStack (Occurs v t) -unifyType :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Type -> Type -> m Type +unifyType :: (HasCallStack, Has (Reader ElabContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Type -> Type -> m Type unifyType = curry $ \case (TN.Comp s1 t1, TN.Comp s2 t2) -> TN.Comp . fromInterfaces <$> unifySpine unifyInterface (interfaces s1) (interfaces s2) <*> unifyType t1 t2 (TN.Comp s1 t1, t2) -> TN.Comp s1 <$> unifyType t1 t2 @@ -70,19 +70,19 @@ unifyType = curry $ \case where mkForAll d n k b = TX.ForAll n k (runQuoter (succ d) (quote b)) -unifyKind :: Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m => Kind -> Kind -> m Kind +unifyKind :: Has (Reader ElabContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m => Kind -> Kind -> m Kind unifyKind k1 k2 = if k1 == k2 then pure k2 else mismatch -unifyVar :: (Eq a, Eq b, HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Var (Either a b) -> Var (Either a b) -> m (Var (Either a b)) +unifyVar :: (Eq a, Eq b, HasCallStack, Has (Reader ElabContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Var (Either a b) -> Var (Either a b) -> m (Var (Either a b)) unifyVar v1 v2 = if v1 == v2 then pure v2 else mismatch -unifyInterface :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Interface Type -> Interface Type -> m (Interface Type) +unifyInterface :: (HasCallStack, Has (Reader ElabContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Interface Type -> Interface Type -> m (Interface Type) unifyInterface (Interface h1 sp1) (Interface h2 sp2) = Interface h2 <$ unless (h1 == h2) mismatch <*> unifySpine unifyType sp1 sp2 -unifySpine :: (Traversable t, Zip t, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => (a -> b -> m c) -> t a -> t b -> m (t c) +unifySpine :: (Traversable t, Zip t, Has (Reader ElabContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => (a -> b -> m c) -> t a -> t b -> m (t c) unifySpine f sp1 sp2 = unless (length sp1 == length sp2) mismatch >> zipWithM f sp1 sp2 -flexFlex :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Meta -> m Type +flexFlex :: (HasCallStack, Has (Reader ElabContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Meta -> m Type flexFlex v1 v2 | v1 == v2 = pure (metavar v2) | otherwise = gets (\ s -> (lookupMeta v1 s, lookupMeta v2 s)) >>= \case @@ -91,7 +91,7 @@ flexFlex v1 v2 (Nothing, Just t2) -> unifyType (metavar v1) t2 (Nothing, Nothing) -> solve v1 (metavar v2) -solve :: (HasCallStack, Has (Reader ElabContext :+: Reader StaticContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Type -> m Type +solve :: (HasCallStack, Has (Reader ElabContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Type -> m Type solve v t = do d <- depth if occursIn v (getUsed d) t then From 8c8842c905177d5b272d838f068f54295ccf8715 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Mar 2022 11:08:28 -0400 Subject: [PATCH 0957/1324] Reintroduce Err. --- src/Facet/Elab.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 061065b9f..5f1697d92 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -16,7 +16,7 @@ module Facet.Elab , (||-) -- * Errors , pushSpan --- , Err(..) +, Err(..) , ErrReason(..) , _FreeVariable , _AmbiguousName @@ -196,14 +196,14 @@ pushSpan :: Has (Reader ElabContext) sig m => Span -> m a -> m a pushSpan = locally spans_ . flip (:>) --- data Err = Err --- { source :: Source --- , reason :: ErrReason --- , context :: Context --- , subst :: Subst Type --- , sig :: [Signature Type] --- , callStack :: CallStack --- } +data Err = Err + { source :: Source + , reason :: ErrReason + , context :: Context + , subst :: Subst Type + , sig :: [Signature Type] + , callStack :: CallStack + } -- FIXME: not all of these need contexts/metacontexts. data ErrReason From 401cf686dcf145d5c11172c32b40171fb29cf308 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Mar 2022 11:10:47 -0400 Subject: [PATCH 0958/1324] Rethrow Err from ErrC. --- src/Facet/Elab.hs | 36 ++++++++++++++++++++---------------- 1 file changed, 20 insertions(+), 16 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 5f1697d92..08f24bb5d 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -247,20 +247,20 @@ _Occurs = prism' (uncurry Occurs) (\case Occurs v c -> Just (v, c) _ -> Nothing) --- applySubst :: Context -> Subst Type -> ErrReason -> ErrReason --- applySubst ctx subst r = case r of --- FreeVariable{} -> r --- AmbiguousName{} -> r --- CouldNotSynthesize{} -> r --- ResourceMismatch{} -> r --- -- NB: not substituting in @r@ because we want to retain the cyclic occurrence (and finitely) --- UnifyType r exp act -> UnifyType r (fmap roundtrip <$> exp) (roundtrip <$> act) --- UnifyKind{} -> r --- Hole n t -> Hole n (roundtrip t) --- Invariant{} -> r --- MissingInterface i -> MissingInterface (roundtrip <$> i) --- where --- roundtrip = apply subst (toEnv ctx) +applySubst :: Context -> Subst Type -> ErrReason -> ErrReason +applySubst ctx subst r = case r of + FreeVariable{} -> r + AmbiguousName{} -> r + CouldNotSynthesize{} -> r + ResourceMismatch{} -> r + -- NB: not substituting in @r@ because we want to retain the cyclic occurrence (and finitely) + UnifyType r exp act -> UnifyType r (fmap roundtrip <$> exp) (roundtrip <$> act) + UnifyKind{} -> r + Hole n t -> Hole n (roundtrip t) + Invariant{} -> r + MissingInterface i -> MissingInterface (roundtrip <$> i) + where + roundtrip = apply subst (toEnv ctx) err :: Has (Throw ErrReason) sig m => ErrReason -> m a @@ -302,9 +302,13 @@ missingInterface i = withFrozenCallStack $ err $ MissingInterface i newtype ErrC m a = ErrC { runErr :: m a } deriving (Applicative, Functor, Monad) -instance Has (Throw ErrReason) sig m => Algebra (Throw ErrReason :+: sig) (ErrC m) where +instance (Has (Reader ElabContext) sig m, Has (Reader Source) sig m, Has (State (Subst Type)) sig m, Has (Throw Err) sig m) => Algebra (Throw ErrReason :+: sig) (ErrC m) where alg hdl sig ctx = case sig of - L (Throw e) -> err e + L (Throw reason) -> do + source <- ask + ElabContext{ context, sig, spans } <- ask + subst <- get + throwError $ Err (maybe source (slice source) (peek spans)) (applySubst context subst reason) context subst sig GHC.Stack.callStack R other -> ErrC (alg (runErr . hdl) other ctx) From 9c9328aafd12da8ff6ce103d6f38a145b0a1ba62 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Mar 2022 11:11:46 -0400 Subject: [PATCH 0959/1324] :fire: err & makeErr. --- src/Facet/Elab.hs | 29 ++++++++--------------------- src/Facet/Elab/Term.hs | 2 +- src/Facet/Unify.hs | 2 +- 3 files changed, 10 insertions(+), 23 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 08f24bb5d..e2f998f7f 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -24,8 +24,6 @@ module Facet.Elab , UnifyErrReason(..) , _Mismatch , _Occurs -, err -, makeErr , mismatchTypes , mismatchKinds , couldNotUnifyKinds @@ -63,7 +61,7 @@ import Control.Carrier.Reader import Control.Carrier.State.Church import Control.Carrier.Writer.Church import Control.Effect.Choose -import Control.Monad (unless, (<=<)) +import Control.Monad (unless) import Data.Foldable (for_) import Facet.Context hiding (empty) import qualified Facet.Context as Context (empty) @@ -263,40 +261,29 @@ applySubst ctx subst r = case r of roundtrip = apply subst (toEnv ctx) -err :: Has (Throw ErrReason) sig m => ErrReason -> m a -err = throwError <=< makeErr - -makeErr :: Has (Throw ErrReason) sig m => ErrReason -> m ErrReason -makeErr = pure --- makeErr reason = do --- StaticContext{ source } <- ask --- ElabContext{ context, sig, spans } <- ask --- subst <- get --- pure $ Err (maybe source (slice source) (peek spans)) (applySubst context subst reason) context subst sig GHC.Stack.callStack - mismatchTypes :: Has (Throw ErrReason) sig m => Exp (Either String Type) -> Act Type -> m a -mismatchTypes exp act = withFrozenCallStack $ err $ UnifyType Mismatch exp act +mismatchTypes exp act = withFrozenCallStack $ throwError $ UnifyType Mismatch exp act mismatchKinds :: Has (Throw ErrReason) sig m => Exp (Either String Kind) -> Act Kind -> m a -mismatchKinds exp act = withFrozenCallStack $ err $ UnifyKind exp act +mismatchKinds exp act = withFrozenCallStack $ throwError $ UnifyKind exp act couldNotUnifyKinds :: Has (Throw ErrReason) sig m => Exp Kind -> Act Kind -> m a couldNotUnifyKinds t1 t2 = withFrozenCallStack $ mismatchKinds (Right <$> t1) t2 couldNotSynthesize :: Has (Throw ErrReason) sig m => m a -couldNotSynthesize = withFrozenCallStack $ err CouldNotSynthesize +couldNotSynthesize = withFrozenCallStack $ throwError CouldNotSynthesize resourceMismatch :: Has (Throw ErrReason) sig m => Name -> Quantity -> Quantity -> m a -resourceMismatch n exp act = withFrozenCallStack $ err $ ResourceMismatch n exp act +resourceMismatch n exp act = withFrozenCallStack $ throwError $ ResourceMismatch n exp act freeVariable :: Has (Throw ErrReason) sig m => QName -> m a -freeVariable n = withFrozenCallStack $ err $ FreeVariable n +freeVariable n = withFrozenCallStack $ throwError $ FreeVariable n ambiguousName :: Has (Throw ErrReason) sig m => QName -> [RName] -> m a -ambiguousName n qs = withFrozenCallStack $ err $ AmbiguousName n qs +ambiguousName n qs = withFrozenCallStack $ throwError $ AmbiguousName n qs missingInterface :: Has (Throw ErrReason) sig m => Interface Type -> m a -missingInterface i = withFrozenCallStack $ err $ MissingInterface i +missingInterface i = withFrozenCallStack $ throwError $ MissingInterface i newtype ErrC m a = ErrC { runErr :: m a } diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 0719bd559..fb1279330 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -146,7 +146,7 @@ varS n = views context_ (lookupInContext n) >>= \case hole :: Has (Throw ErrReason) sig m => Name -> Type <==: Elab m a -hole n = Check $ \ _T -> withFrozenCallStack $ err $ Hole n _T +hole n = Check $ \ _T -> withFrozenCallStack $ throwError $ Hole n _T tlam :: Has (Throw ErrReason) sig m => Type <==: Elab m Term -> Type <==: Elab m Term diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index d8e4bfba5..3b95d239a 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -40,7 +40,7 @@ unify :: (HasCallStack, Has (Throw ErrReason) sig m) => Exp Type -> Act Type -> unify t1 t2 = runUnify t1 t2 (unifyType (getExp t1) (getAct t2)) runUnify :: Has (Throw ErrReason) sig m => Exp Type -> Act Type -> ThrowC ErrReason (WithCallStack UnifyErrReason) (Elab m) a -> Elab m a -runUnify t1 t2 = runThrow (withCallStack (\ r -> makeErr (UnifyType r (Right <$> t1) t2))) +runUnify t1 t2 = runThrow (withCallStack (\ r -> throwError (UnifyType r (Right <$> t1) t2))) runUnifyMaybe :: Applicative m => ErrorC (WithCallStack UnifyErrReason) m a -> m (Maybe a) runUnifyMaybe = runError (const (pure Nothing)) (pure . Just) From ce10aa78f8e9b415e18621df2ccbde6a7ae8cfad Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Mar 2022 11:29:12 -0400 Subject: [PATCH 0960/1324] Generalize assertMatch. --- src/Facet/Elab.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index e2f998f7f..5a5875077 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -33,6 +33,7 @@ module Facet.Elab , missingInterface , assertMatch , assertFunction +, ErrC(..) -- * Warnings , Warn(..) , WarnReason(..) @@ -320,7 +321,7 @@ warn reason = do -- Patterns -assertMatch :: (Exp (Either String b) -> Act s -> Elab m a) -> Prism' s a -> String -> s -> Elab m a +assertMatch :: Applicative m => (Exp (Either String b) -> Act s -> m a) -> Prism' s a -> String -> s -> m a assertMatch mismatch pat exp _T = maybe (mismatch (Exp (Left exp)) (Act _T)) pure (_T ^? pat) assertFunction :: Has (Throw ErrReason) sig m => Type -> Elab m (Maybe Name, Quantity, Type, Type) From cd6c75f4acd9270c6cd997386c3ccd9766afcaf8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Mar 2022 11:29:38 -0400 Subject: [PATCH 0961/1324] Correct a comment. --- src/Facet/Elab/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index fb1279330..e44e98d73 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -401,7 +401,7 @@ letrec getter key projection initial final = do assertQuantifier :: Has (Throw ErrReason) sig m => Type -> Elab m (Name, Kind, Type -> Type) assertQuantifier = assertMatch mismatchTypes _ForAll "{_} -> _" --- | Expect a tacit (non-variable-binding) lamction type. +-- | Expect a tacit (non-variable-binding) function type. assertTacitFunction :: Has (Throw ErrReason) sig m => Type -> Elab m (Maybe Name, Quantity, Type, Type) assertTacitFunction = assertMatch mismatchTypes _Arrow "_ -> _" From c9e4dde89c4d7f37076bfef650d0499e225aaeb9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Mar 2022 11:30:29 -0400 Subject: [PATCH 0962/1324] Generalize assertions. --- src/Facet/Elab.hs | 2 +- src/Facet/Elab/Term.hs | 6 +++--- src/Facet/Elab/Type.hs | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 5a5875077..57bf56778 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -324,7 +324,7 @@ warn reason = do assertMatch :: Applicative m => (Exp (Either String b) -> Act s -> m a) -> Prism' s a -> String -> s -> m a assertMatch mismatch pat exp _T = maybe (mismatch (Exp (Left exp)) (Act _T)) pure (_T ^? pat) -assertFunction :: Has (Throw ErrReason) sig m => Type -> Elab m (Maybe Name, Quantity, Type, Type) +assertFunction :: Has (Throw ErrReason) sig m => Type -> m (Maybe Name, Quantity, Type, Type) assertFunction = assertMatch mismatchTypes _Arrow "_ -> _" diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index e44e98d73..def43287f 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -398,15 +398,15 @@ letrec getter key projection initial final = do -- Errors -assertQuantifier :: Has (Throw ErrReason) sig m => Type -> Elab m (Name, Kind, Type -> Type) +assertQuantifier :: Has (Throw ErrReason) sig m => Type -> m (Name, Kind, Type -> Type) assertQuantifier = assertMatch mismatchTypes _ForAll "{_} -> _" -- | Expect a tacit (non-variable-binding) function type. -assertTacitFunction :: Has (Throw ErrReason) sig m => Type -> Elab m (Maybe Name, Quantity, Type, Type) +assertTacitFunction :: Has (Throw ErrReason) sig m => Type -> m (Maybe Name, Quantity, Type, Type) assertTacitFunction = assertMatch mismatchTypes _Arrow "_ -> _" -- | Expect a computation type with effects. -assertComp :: Has (Throw ErrReason) sig m => Type -> Elab m (Signature Type, Type) +assertComp :: Has (Throw ErrReason) sig m => Type -> m (Signature Type, Type) assertComp = assertMatch mismatchTypes _Comp "[_] _" diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index fad0cb9d6..2830e9a57 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -99,7 +99,7 @@ synthInterface (S.Ann s _ (S.Interface h sp)) = pushSpan s $ do -- Assertions -assertTypeConstructor :: Has (Throw ErrReason) sig m => Kind -> Elab m (Maybe Name, Kind, Kind) +assertTypeConstructor :: Has (Throw ErrReason) sig m => Kind -> m (Maybe Name, Kind, Kind) assertTypeConstructor = assertMatch mismatchKinds _KArrow "_ -> _" From 3c1575a2a14b123d64761d34f9f8253965af2a1b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Mar 2022 11:52:13 -0400 Subject: [PATCH 0963/1324] :fire: uses of Elab. --- src/Facet/Elab.hs | 2 +- src/Facet/Elab/Term.hs | 68 +++++++++++++++++++++--------------------- src/Facet/Elab/Type.hs | 16 +++++----- src/Facet/Unify.hs | 4 +-- 4 files changed, 45 insertions(+), 45 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 57bf56778..ce285d09e 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -108,7 +108,7 @@ meta :: Has (State (Subst Type)) sig m => Kind -> m Meta meta _T = state (declareMeta @Type) -instantiate :: Algebra sig m => (a -> TX.Type -> a) -> a ::: Type -> Elab m (a ::: Type) +instantiate :: Has (State (Subst Type)) sig m => (a -> TX.Type -> a) -> a ::: Type -> m (a ::: Type) instantiate inst = go where go (e ::: _T) = case _T of diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index def43287f..fa5850f74 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -97,12 +97,12 @@ import GHC.Stack -- General combinators -switch :: Has (Throw ErrReason) sig m => Elab m (a :==> Type) -> Type <==: Elab m a +switch :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => m (a :==> Type) -> Type <==: m a switch m = Check $ \ _Exp -> m >>= \case a :==> T.Comp req _Act -> require req >> unify (Exp _Exp) (Act _Act) $> a a :==> _Act -> unify (Exp _Exp) (Act _Act) $> a -as :: Has (Throw ErrReason) sig m => (Type <==: Elab m a) ::: Elab m (Type :==> Kind) -> Elab m (a :==> Type) +as :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m) => (Type <==: m a) ::: m (Type :==> Kind) -> m (a :==> Type) as (m ::: _T) = do _T' <- Type.switch _T <==: KType a <- check (m ::: _T') @@ -112,11 +112,11 @@ as (m ::: _T) = do -- Term combinators -- FIXME: we’re instantiating when inspecting types in the REPL. -global :: Algebra sig m => RName ::: Type -> Elab m (Term :==> Type) +global :: Has (State (Subst Type)) sig m => RName ::: Type -> m (Term :==> Type) global (q ::: _T) = (\ (v ::: _T) -> v :==> _T) <$> instantiate const (Var (Global q) ::: _T) -- FIXME: we’re instantiating when inspecting types in the REPL. -globalS :: (Algebra sig m, SQ.Sequent t c d, Applicative i) => RName ::: Type -> Elab m (i t :==> Type) +globalS :: (Has (State (Subst Type)) sig m, SQ.Sequent t c d, Applicative i) => RName ::: Type -> m (i t :==> Type) globalS (q ::: _T) = do v <- SQ.varA (Global q) (\ (v ::: _T) -> v :==> _T) <$> instantiate const (v ::: _T) @@ -124,7 +124,7 @@ globalS (q ::: _T) = do -- FIXME: do we need to instantiate here to deal with rank-n applications? -- FIXME: effect ops not in the sig are reported as not in scope -- FIXME: effect ops in the sig are available whether or not they’re in scope -var :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> Elab m (Term :==> Type) +var :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => QName -> m (Term :==> Type) var n = views context_ (lookupInContext n) >>= \case [(n', Right (q, _T))] -> use n' q $> (Var (Free n') :==> _T) _ -> resolveQ n >>= \case @@ -134,7 +134,7 @@ var n = views context_ (lookupInContext n) >>= \case -- FIXME: do we need to instantiate here to deal with rank-n applications? -- FIXME: effect ops not in the sig are reported as not in scope -- FIXME: effect ops in the sig are available whether or not they’re in scope -varS :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m, SQ.Sequent t c d, Applicative i) =>QName -> Elab m (i t :==> Type) +varS :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m, SQ.Sequent t c d, Applicative i) => QName -> m (i t :==> Type) varS n = views context_ (lookupInContext n) >>= \case [(n', Right (q, _T))] -> do use n' q @@ -145,37 +145,37 @@ varS n = views context_ (lookupInContext n) >>= \case _ :=: _ -> freeVariable n -hole :: Has (Throw ErrReason) sig m => Name -> Type <==: Elab m a +hole :: Has (Throw ErrReason) sig m => Name -> Type <==: m a hole n = Check $ \ _T -> withFrozenCallStack $ throwError $ Hole n _T -tlam :: Has (Throw ErrReason) sig m => Type <==: Elab m Term -> Type <==: Elab m Term +tlam :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m) => Type <==: m Term -> Type <==: m Term tlam b = Check $ \ _T -> do (n, _A, _B) <- assertQuantifier _T d <- depth n :==> _A ||- check (b ::: _B (T.free (LName (getUsed d) n))) -lam :: Has (Throw ErrReason) sig m => [(Bind m (Pattern (Name :==> Type)), Type <==: Elab m Term)] -> Type <==: Elab m Term +lam :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => [(Bind m (Pattern (Name :==> Type)), Type <==: m Term)] -> Type <==: m Term lam cs = Check $ \ _T -> do (_, q, _A, _B) <- assertTacitFunction _T Lam <$> traverse (\ (p, b) -> bind (p ::: (q, _A)) (check (b ::: _B))) cs -lam1 :: Has (Throw ErrReason) sig m => Bind m (Pattern (Name :==> Type)) -> Type <==: Elab m Term -> Type <==: Elab m Term +lam1 :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Bind m (Pattern (Name :==> Type)) -> Type <==: m Term -> Type <==: m Term lam1 p b = lam [(p, b)] -lamS :: (Has (Throw ErrReason) sig m, SQ.Sequent t c d, Applicative i) => (forall j . Applicative j => (i ~> j) -> (j t :@ Quantity :==> Type) -> (j c :@ Quantity :==> Type) -> (Type <==: Elab m (j d))) -> Type <==: Elab m (i t) +lamS :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, SQ.Sequent t c d, Applicative i) => (forall j . Applicative j => (i ~> j) -> (j t :@ Quantity :==> Type) -> (j c :@ Quantity :==> Type) -> (Type <==: m (j d))) -> Type <==: m (i t) lamS f = runC $ SQ.lamRA $ \ wk a k -> C $ Check $ \ _T -> do (_, q, _A, _B) <- assertTacitFunction _T check (f wk (a :@ q :==> _A) (k :@ q :==> _B) ::: _B) -app :: Has (Throw ErrReason) sig m => (a -> b -> c) -> (HasCallStack => Elab m (a :==> Type)) -> (HasCallStack => Type <==: Elab m b) -> Elab m (c :==> Type) +app :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => (a -> b -> c) -> (HasCallStack => m (a :==> Type)) -> (HasCallStack => Type <==: m b) -> m (c :==> Type) app mk operator operand = do f' :==> _F <- operator (_, q, _A, _B) <- assertFunction _F a' <- censor @Usage (q ><<) $ check (operand ::: _A) pure $ mk f' a' :==> _B -appS :: (HasCallStack, Has (Throw ErrReason) sig m, SQ.Sequent t c d, Applicative i) => (HasCallStack => Elab m (i t :==> Type)) -> (HasCallStack => Type <==: Elab m (i t)) -> Elab m (i t :==> Type) +appS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m, SQ.Sequent t c d, Applicative i) => (HasCallStack => m (i t :==> Type)) -> (HasCallStack => Type <==: m (i t)) -> m (i t :==> Type) appS f a = do f' :==> _F <- f (_, q, _A, _B) <- assertFunction _F @@ -183,26 +183,26 @@ appS f a = do (:==> _B) <$> SQ.µRA (\ wk k -> pure (wk f') SQ..||. SQ.lamLA (pure (wk a')) (pure k)) -string :: Text -> Elab m (Term :==> Type) +string :: Applicative m => Text -> m (Term :==> Type) string s = pure $ E.String s :==> T.String -stringS :: (SQ.Sequent t c d, Applicative i) => Text -> Elab m (i t :==> Type) +stringS :: (Applicative m, SQ.Sequent t c d, Applicative i) => Text -> m (i t :==> Type) stringS s = SQ.stringRA s ==> pure T.String -let' :: Has (Throw ErrReason) sig m => Bind m (Pattern (Name :==> Type)) -> Elab m (Term :==> Type) -> Type <==: Elab m Term -> Type <==: Elab m Term +let' :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Bind m (Pattern (Name :==> Type)) -> m (Term :==> Type) -> Type <==: m Term -> Type <==: m Term let' p a b = Check $ \ _B -> do a' :==> _A <- a (p', b') <- bind (p ::: (Many, _A)) (check (b ::: _B)) pure $ Let p' a' b' -comp :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => Type <==: Elab m Term -> Type <==: Elab m Term +comp :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Type <==: m Term -> Type <==: m Term comp b = Check $ \ _T -> do (sig, _B) <- assertComp _T graph <- ask module' <- ask - let interfacePattern :: Has (Throw ErrReason) sig m => Interface Type -> Elab m (RName :=: (Name :==> Type)) + let interfacePattern :: Has (Throw ErrReason) sig m => Interface Type -> m (RName :=: (Name :==> Type)) interfacePattern (Interface n _) = maybe (freeVariable (toQ n)) (\ (n' :=: _T) -> pure ((n .:. n') :=: (n' :==> _T))) (listToMaybe (scopeToList . tm =<< unDInterface . def =<< lookupQ graph module' (toQ n))) p' <- traverse interfacePattern (interfaces sig) -- FIXME: can we apply quantities to dictionaries? what would they mean? @@ -222,7 +222,7 @@ varP n = Bind $ \ _A k -> k (PVar (n :==> wrap _A)) T.Comp sig _A -> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (T.Comp sig _A) _T -> _T -conP :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> [Bind m (Pattern (Name :==> Type))] -> Bind m (Pattern (Name :==> Type)) +conP :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => QName -> [Bind m (Pattern (Name :==> Type))] -> Bind m (Pattern (Name :==> Type)) conP n fs = Bind $ \ _A k -> do n' :=: _ ::: _T <- resolveC n _T' <- maybe (pure _T) (foldl' (\ _T _A -> do t <- _T ; (_, _, b) <- assertQuantifier t ; pure (b _A)) (pure _T) . snd) (unNeutral _A) @@ -246,7 +246,7 @@ allP n = Bind $ \ _A k -> do -- Expression elaboration -synthExpr :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.Expr -> Elab m (Term :==> Type) +synthExpr :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => S.Ann S.Expr -> m (Term :==> Type) synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \case S.Var n -> var n S.App f a -> synthApp f a @@ -256,13 +256,13 @@ synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \cas S.Lam{} -> nope where nope = couldNotSynthesize - synthApp :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Expr -> Elab m (Term :==> Type) + synthApp :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => S.Ann S.Expr -> S.Ann S.Expr -> m (Term :==> Type) synthApp f a = app App (synthExpr f) (checkExpr a) - synthAs :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Type -> Elab m (Term :==> Type) + synthAs :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => S.Ann S.Expr -> S.Ann S.Type -> m (Term :==> Type) synthAs t _T = as (checkExpr t ::: do { _T :==> _K <- synthType _T ; (:==> _K) <$> evalTExpr _T }) -checkExpr :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.Expr -> Type <==: Elab m Term +checkExpr :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => S.Ann S.Expr -> Type <==: m Term checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC expr $ \case S.Hole n -> hole n S.Lam cs -> checkLam cs @@ -271,17 +271,17 @@ checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC S.As{} -> switch (synthExpr expr) S.String{} -> switch (synthExpr expr) -checkLam :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => [S.Clause] -> Type <==: Elab m Term +checkLam :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => [S.Clause] -> Type <==: m Term checkLam cs = lam (snd vs) where - vs :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => ([QName :=: (Type <==: Elab m Term)], [(Bind m (Pattern (Name :==> Type)), Type <==: Elab m Term)]) + vs :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => ([QName :=: (Type <==: m Term)], [(Bind m (Pattern (Name :==> Type)), Type <==: m Term)]) vs = partitionEithers (map (\ (S.Clause (S.Ann _ _ p) b) -> case p of S.PVal p -> Right (bindPattern p, checkExpr b) S.PEff (S.Ann s _ (S.POp n fs k)) -> Left $ n :=: Check (\ _T -> pushSpan s (foldr (lam1 . bindPattern) (checkExpr b) (fromList fs:>k) <==: _T))) cs) -- FIXME: check for unique variable names -bindPattern :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.ValPattern -> Bind m (Pattern (Name :==> Type)) +bindPattern :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => S.Ann S.ValPattern -> Bind m (Pattern (Name :==> Type)) bindPattern = withSpanB $ \case S.PWildcard -> wildcardP S.PVar n -> varP n @@ -296,7 +296,7 @@ abstractType body = \case KArrow (Just n) a b -> TX.ForAll n a <$> (n :==> a ||- abstractType body b) _ -> body -abstractTerm :: Has (Throw ErrReason :+: Write Warn) sig m => (Snoc TX.Type -> Snoc Term -> Term) -> Type <==: Elab m Term +abstractTerm :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => (Snoc TX.Type -> Snoc Term -> Term) -> Type <==: m Term abstractTerm body = go Nil Nil where go ts fs = Check $ \case @@ -417,22 +417,22 @@ runModule m = do mod <- get runReader mod m -withSpanB :: Algebra sig m => (a -> Bind m b) -> S.Ann a -> Bind m b +withSpanB :: Has (Reader ElabContext) sig m => (a -> Bind m b) -> S.Ann a -> Bind m b withSpanB k (S.Ann s _ a) = Bind (\ _A k' -> pushSpan s (runBind (k a) _A k')) -withSpanC :: Algebra sig m => S.Ann a -> (a -> Type <==: Elab m b) -> Type <==: Elab m b +withSpanC :: Has (Reader ElabContext) sig m => S.Ann a -> (a -> Type <==: m b) -> Type <==: m b withSpanC (S.Ann s _ a) k = Check (\ _T -> pushSpan s (k a <==: _T)) withSpan :: Has (Reader ElabContext) sig m => (a -> m b) -> S.Ann a -> m b withSpan k (S.Ann s _ a) = pushSpan s (k a) -provide :: Has (Reader ElabContext :+: State (Subst Type)) sig m => Signature Type -> m a -> m a +provide :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m) => Signature Type -> m a -> m a provide sig m = do subst <- get env <- views context_ toEnv locally sig_ (mapSignature (apply subst env) sig :) m -require :: Has (Throw ErrReason) sig m => Signature Type -> Elab m () +require :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Signature Type -> m () require req = do prv <- view sig_ for_ (interfaces req) $ \ i -> findMaybeA (findMaybeA (runUnifyMaybe . unifyInterface i) . interfaces) prv >>= \case @@ -445,14 +445,14 @@ findMaybeA p = getAp . fmap getFirst . foldMap (Ap . fmap First . p) -- Judgements -check :: Algebra sig m => ((Type <==: Elab m a) ::: Type) -> Elab m a +check :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m) => ((Type <==: m a) ::: Type) -> m a check (m ::: _T) = case _T of T.Comp sig _T -> provide sig $ m <==: _T _T -> m <==: _T -bind :: (Has (Throw ErrReason) sig m) => Bind m (Pattern (Name :==> Type)) ::: (Quantity, Type) -> Elab m b -> Elab m (Pattern Name, b) +bind :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Bind m (Pattern (Name :==> Type)) ::: (Quantity, Type) -> m b -> m (Pattern Name, b) bind (p ::: (q, _T)) m = runBind p _T (\ p' -> (proof <$> p',) <$> ((q, p') |- m)) -newtype Bind m a = Bind { runBind :: forall x . Type -> (a -> Elab m x) -> Elab m x } +newtype Bind m a = Bind { runBind :: forall x . Type -> (a -> m x) -> m x } deriving (Functor) diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 2830e9a57..81031fd93 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -30,14 +30,14 @@ import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) import qualified Facet.Type.Expr as TX -tvar :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> Elab m (TX.Type :==> Kind) +tvar :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (TX.Type :==> Kind) tvar n = views context_ (lookupInContext n) >>= \case [(n', Left _K)] -> pure (TX.Var (Free (Right n')) :==> _K) _ -> resolveQ n >>= \case q :=: DSubmodule _ _K -> pure $ TX.Var (Global q) :==> _K _ -> freeVariable n -ivar :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> Elab m (RName :==> Kind) +ivar :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (RName :==> Kind) ivar n = resolveQ n >>= \case q :=: DSubmodule (SInterface _) _K -> pure $ q :==> _K _ -> freeVariable n @@ -47,19 +47,19 @@ _String :: Applicative m => m (TX.Type :==> Kind) _String = pure $ TX.String :==> KType -forAll :: Has (Throw ErrReason) sig m => Name ::: Kind -> Elab m (TX.Type :==> Kind) -> Elab m (TX.Type :==> Kind) +forAll :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => Name ::: Kind -> m (TX.Type :==> Kind) -> m (TX.Type :==> Kind) forAll (n ::: t) b = do b' <- n :==> t ||- switch b <==: KType pure $ TX.ForAll n t b' :==> KType -arrow :: Has (Throw ErrReason) sig m => (a -> b -> c) -> Elab m (a :==> Kind) -> Elab m (b :==> Kind) -> Elab m (c :==> Kind) +arrow :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => (a -> b -> c) -> m (a :==> Kind) -> m (b :==> Kind) -> m (c :==> Kind) arrow mk a b = do a' <- switch a <==: KType b' <- switch b <==: KType pure $ mk a' b' :==> KType -app :: Has (Throw ErrReason) sig m => (a -> b -> c) -> Elab m (a :==> Kind) -> Elab m (b :==> Kind) -> Elab m (c :==> Kind) +app :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => (a -> b -> c) -> m (a :==> Kind) -> m (b :==> Kind) -> m (c :==> Kind) app mk f a = do f' :==> _F <- f (_, _A, _B) <- assertTypeConstructor _F @@ -68,7 +68,7 @@ app mk f a = do pure $ mk f' a' :==> _B -comp :: Has (Throw ErrReason) sig m => [Elab m (Interface TX.Type :==> Kind)] -> Elab m (TX.Type :==> Kind) -> Elab m (TX.Type :==> Kind) +comp :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => [m (Interface TX.Type :==> Kind)] -> m (TX.Type :==> Kind) -> m (TX.Type :==> Kind) comp s t = do s' <- traverse ((<==: KInterface) . switch) s -- FIXME: polarize types and check that this is a value type being returned @@ -76,7 +76,7 @@ comp s t = do pure $ TX.Comp (fromInterfaces s') t' :==> KType -synthType :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => S.Ann S.Type -> Elab m (TX.Type :==> Kind) +synthType :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => S.Ann S.Type -> m (TX.Type :==> Kind) synthType (S.Ann s _ e) = pushSpan s $ case e of S.TVar n -> tvar n S.TString -> Facet.Elab.Type._String @@ -89,7 +89,7 @@ synthType (S.Ann s _ e) = pushSpan s $ case e of S.Zero -> zero S.One -> one -synthInterface :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => S.Ann (S.Interface (S.Ann S.Type)) -> Elab m (Interface TX.Type :==> Kind) +synthInterface :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => S.Ann (S.Interface (S.Ann S.Type)) -> m (Interface TX.Type :==> Kind) synthInterface (S.Ann s _ (S.Interface h sp)) = pushSpan s $ do -- FIXME: check that the application actually result in an Interface h' :==> _ <- ivar h diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index 3b95d239a..29263b769 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -36,10 +36,10 @@ import GHC.Stack -- Unification -- FIXME: we don’t get good source references during unification -unify :: (HasCallStack, Has (Throw ErrReason) sig m) => Exp Type -> Act Type -> Elab m Type +unify :: (HasCallStack, Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Exp Type -> Act Type -> m Type unify t1 t2 = runUnify t1 t2 (unifyType (getExp t1) (getAct t2)) -runUnify :: Has (Throw ErrReason) sig m => Exp Type -> Act Type -> ThrowC ErrReason (WithCallStack UnifyErrReason) (Elab m) a -> Elab m a +runUnify :: Has (Throw ErrReason) sig m => Exp Type -> Act Type -> ThrowC ErrReason (WithCallStack UnifyErrReason) m a -> m a runUnify t1 t2 = runThrow (withCallStack (\ r -> throwError (UnifyType r (Right <$> t1) t2))) runUnifyMaybe :: Applicative m => ErrorC (WithCallStack UnifyErrReason) m a -> m (Maybe a) From 6215b021f389ad0346472c6a5dcf6654b99b17bc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Mar 2022 11:53:52 -0400 Subject: [PATCH 0964/1324] :fire: Elab. --- src/Facet/Elab.hs | 20 ++++++++------------ 1 file changed, 8 insertions(+), 12 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index ce285d09e..87e3b2660 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -43,7 +43,6 @@ module Facet.Elab , context_ , sig_ -- * Machinery -, Elab(..) , evalTExpr , depth , use @@ -312,7 +311,7 @@ data WarnReason | RedundantVariable Name -warn :: (Has (Reader Source) sig m, Has (Write Warn) sig m) => WarnReason -> Elab m () +warn :: (Has (Reader ElabContext) sig m, Has (Reader Source) sig m, Has (Write Warn) sig m) => WarnReason -> m () warn reason = do source <- ask ElabContext{ spans } <- ask @@ -348,25 +347,22 @@ spans_ = lens spans (\ e spans -> e{ spans }) -- Machinery -newtype Elab m a = Elab { runElab :: ReaderC ElabContext (WriterC Usage (StateC (Subst Type) m)) a } - deriving (Algebra (Reader ElabContext :+: Writer Usage :+: State (Subst Type) :+: sig), Applicative, Functor, Monad) - -elabWith :: (Subst Type -> a -> m b) -> Elab m a -> m b +elabWith :: (Subst Type -> a -> m b) -> ReaderC ElabContext (WriterC Usage (StateC (Subst Type) m)) a -> m b elabWith k m = runState k mempty . runWriter (const pure) $ do let ctx = ElabContext{ context = Context.empty, sig = mempty, spans = Nil } - runReader ctx . runElab $ m + runReader ctx m -elabKind :: Applicative m => Elab m Kind -> m Kind +elabKind :: Applicative m => ReaderC ElabContext (WriterC Usage (StateC (Subst Type) m)) Kind -> m Kind elabKind = elabWith (const pure) -elabType :: (HasCallStack, Applicative m) => Elab m TX.Type -> m Type +elabType :: (HasCallStack, Applicative m) => ReaderC ElabContext (WriterC Usage (StateC (Subst Type) m)) TX.Type -> m Type elabType = elabWith (\ subst t -> pure (TN.eval subst Env.empty t)) -elabTerm :: Applicative m => Elab m Term -> m Term +elabTerm :: Applicative m => ReaderC ElabContext (WriterC Usage (StateC (Subst Type) m)) Term -> m Term elabTerm = elabWith (const pure) -elabSynthTerm :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (Term :==> Type) -> m (Term :==> Type) +elabSynthTerm :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => ReaderC ElabContext (WriterC Usage (StateC (Subst Type) m)) (Term :==> Type) -> m (Term :==> Type) elabSynthTerm = elabWith (\ subst (e :==> _T) -> pure (e :==> TN.eval subst Env.empty (runQuoter 0 (quote _T)))) -elabSynthType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => Elab m (TX.Type :==> Kind) -> m (Type :==> Kind) +elabSynthType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => ReaderC ElabContext (WriterC Usage (StateC (Subst Type) m)) (TX.Type :==> Kind) -> m (Type :==> Kind) elabSynthType = elabWith (\ subst (_T :==> _K) -> pure (TN.eval subst Env.empty _T :==> _K)) From 91ba220d36786a6a48f38e4edceae99c936067ea Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 Mar 2022 12:20:05 -0400 Subject: [PATCH 0965/1324] Convert ErrReason back to Err. --- src/Facet/Elab/Term.hs | 18 ++++++------ src/Facet/Notice/Elab.hs | 62 +++++++++++++++++++++++----------------- src/Facet/REPL.hs | 8 +++--- 3 files changed, 49 insertions(+), 39 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index fa5850f74..ec217663e 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -319,33 +319,33 @@ patternForArgType = \case -- Declarations elabDataDef - :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason :+: Write Warn) sig m) + :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Reader Source) sig m, Has (Throw Err) sig m, Has (Write Warn) sig m) => [S.Ann (Name ::: S.Ann S.Type)] -> Kind <==: m [Name :=: Def] -- FIXME: check that all constructors return the datatype. elabDataDef constructors = Check $ \ _K -> do mname <- view name_ for constructors $ \ (S.Ann _ _ (n ::: t)) -> do - c_T <- elabType $ abstractType (Type.switch (synthType t) <==: KType) _K - con' <- elabTerm $ check (abstractTerm (const (Con (mname :.: n) . toList)) ::: c_T) + c_T <- elabType $ runErr $ abstractType (Type.switch (synthType t) <==: KType) _K + con' <- elabTerm $ runErr $ check (abstractTerm (const (Con (mname :.: n) . toList)) ::: c_T) pure $ n :=: DTerm (Just con') c_T elabInterfaceDef - :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason :+: Write Warn) sig m) + :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Reader Source) sig m, Has (Throw Err) sig m) => [S.Ann (Name ::: S.Ann S.Type)] -> Kind <==: m [Name :=: Type] elabInterfaceDef constructors = Check $ \ _K -> do for constructors $ \ (S.Ann _ _ (n ::: t)) -> do - _K' <- elabType $ abstractType (Type.switch (synthType t) <==: KType) _K + _K' <- elabType $ runErr $ abstractType (Type.switch (synthType t) <==: KType) _K pure $ n :=: _K' -- FIXME: add a parameter for the effect signature. elabTermDef - :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason :+: Write Warn) sig m) + :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Reader Source) sig m, Has (Throw Err) sig m, Has (Write Warn) sig m) => S.Ann S.Expr -> Type <==: m Term elabTermDef expr@(S.Ann s _ _) = Check $ \ _T -> do - elabTerm $ pushSpan s $ check (go (checkExpr expr) ::: _T) + elabTerm $ runErr $ pushSpan s $ check (go (checkExpr expr) ::: _T) where go k = Check $ \ _T -> case _T of T.ForAll{} -> check (tlam (go k) ::: _T) @@ -359,7 +359,7 @@ elabTermDef expr@(S.Ann s _ _) = Check $ \ _T -> do -- Modules elabModule - :: (HasCallStack, Has (Reader Graph :+: Reader Source :+: Throw ErrReason :+: Write Warn) sig m) + :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Source) sig m, Has (Throw Err) sig m, Has (Write Warn) sig m) => S.Ann S.Module -> m Module elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os (Scope mempty)) $ do @@ -381,7 +381,7 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os S.InterfaceDef os _K -> Nothing <$ elabScope dname _SInterface _K (elabInterfaceDef os) (pure . scopeFromList) S.TermDef t tele -> do - _T <- runModule $ elabType $ Type.switch (synthType tele) <==: KType + _T <- runModule $ elabType $ runErr $ Type.switch (synthType tele) <==: KType scope_.decls_.at dname .= Just (DTerm Nothing _T) pure (Just (dname, t, _T)) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 0efe7c4ca..b31b5250f 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -4,50 +4,60 @@ module Facet.Notice.Elab , rethrowElabWarnings ) where +import Data.Foldable (foldl') import Data.Semigroup (stimes) import qualified Facet.Carrier.Throw.Inject as L import qualified Facet.Carrier.Write.Inject as L +import Facet.Context (elems, toEnv) +import qualified Facet.Context as C import Facet.Elab as Elab import qualified Facet.Env as Env +import Facet.Functor.Synth +import Facet.Interface (interfaces) +import Facet.Name import Facet.Notice as Notice hiding (level) +import Facet.Pattern import Facet.Pretty import Facet.Print as Print -import Facet.Semiring (Few(..)) +import Facet.Semiring (Few(..), one, zero) +import Facet.Snoc import Facet.Style +import Facet.Subst (metas) import Facet.Syntax hiding (ann) -import Facet.Type.Norm (metavar) +import Facet.Type.Norm (apply, free, metavar) +import GHC.Stack (prettyCallStack) import Prelude hiding (print, unlines) import Silkscreen -- Elaboration -rethrowElabErrors :: Applicative m => Options Print -> L.ThrowC (Notice (Doc Style)) ErrReason m a -> m a +rethrowElabErrors :: Applicative m => Options Print -> L.ThrowC (Notice (Doc Style)) Err m a -> m a rethrowElabErrors opts = L.runThrow (pure . rethrow) where - rethrow reason = Notice.Notice (Just Error) [] (printErrReason opts mempty reason) [] - -- [ nest 2 (pretty "Context" <\> concatWith (<\>) ctx) - -- , nest 2 (pretty "Metacontext" <\> concatWith (<\>) subst') - -- , nest 2 (pretty "Provided interfaces" <\> concatWith (<\>) sig') - -- , pretty (prettyCallStack callStack) - -- ] + rethrow Err{ callStack, context, reason, sig, subst } = Notice.Notice (Just Error) [] (printErrReason opts mempty reason) + [ nest 2 (pretty "Context" <\> concatWith (<\>) ctx) + , nest 2 (pretty "Metacontext" <\> concatWith (<\>) subst') + , nest 2 (pretty "Provided interfaces" <\> concatWith (<\>) sig') + , pretty (prettyCallStack callStack) + ] where - -- (_, _, printCtx, ctx) = foldl' combine (0, Env.empty, Env.empty, Nil) (elems context) - -- subst' = map (\ (m :=: v) -> getPrint (Print.meta m <+> pretty '=' <+> maybe (pretty '?') (print opts printCtx) v)) (metas subst) - -- sig' = getPrint . print opts printCtx . fmap (apply subst (toEnv context)) <$> (interfaces =<< sig) - -- combine (d, env, prints, ctx) (C.Kind (n :==> _K)) = - -- ( succ d - -- , env Env.|> PVar (n :=: free (LName d n)) - -- , prints Env.|> PVar (n :=: intro n d) - -- , ctx :> getPrint (print opts prints (ann (intro n d ::: print opts prints _K))) ) - -- combine (d, env, prints, ctx) (C.Type m _ p) = - -- ( succ d - -- , env Env.|> ((\ (n :==> _T) -> n :=: free (LName d n)) <$> p) - -- , prints Env.|> ((\ (n :==> _) -> n :=: intro n d) <$> p) - -- , ctx :> getPrint (print opts prints ((\ (n :==> _T) -> ann (intro n d ::: mult m (print opts prints (apply subst env _T)))) <$> p)) ) - -- mult m - -- | m == zero = (pretty "0" <+>) - -- | m == one = (pretty "1" <+>) - -- | otherwise = id + (_, _, printCtx, ctx) = foldl' combine (0, Env.empty, Env.empty, Nil) (elems context) + subst' = map (\ (m :=: v) -> getPrint (Print.meta m <+> pretty '=' <+> maybe (pretty '?') (print opts printCtx) v)) (metas subst) + sig' = getPrint . print opts printCtx . fmap (apply subst (toEnv context)) <$> (interfaces =<< sig) + combine (d, env, prints, ctx) (C.Kind (n :==> _K)) = + ( succ d + , env Env.|> PVar (n :=: free (LName d n)) + , prints Env.|> PVar (n :=: intro n d) + , ctx :> getPrint (print opts prints (ann (intro n d ::: print opts prints _K))) ) + combine (d, env, prints, ctx) (C.Type m _ p) = + ( succ d + , env Env.|> ((\ (n :==> _T) -> n :=: free (LName d n)) <$> p) + , prints Env.|> ((\ (n :==> _) -> n :=: intro n d) <$> p) + , ctx :> getPrint (print opts prints ((\ (n :==> _T) -> ann (intro n d ::: mult m (print opts prints (apply subst env _T)))) <$> p)) ) + mult m + | m == zero = (pretty "0" <+>) + | m == one = (pretty "1" <+>) + | otherwise = id printErrReason :: Options Print -> Env.Env Print -> ErrReason -> Doc Style diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index 4847b18dc..f13314137 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -198,12 +198,12 @@ removeTarget targets = Action $ target_.targets_ %= (Set.\\ Set.fromList targets showType, showEval :: S.Ann S.Expr -> Action showType e = Action $ do - e :==> _T <- runElab $ Elab.elabSynthTerm (Elab.synthExpr e) + e :==> _T <- runElab $ Elab.elabSynthTerm (Elab.runErr (Elab.synthExpr e)) opts <- get outputDocLn (getPrint (ann (Print.print opts mempty e ::: Print.print opts mempty _T))) showEval e = Action $ do - e' :==> _T <- runElab $ Elab.elabSynthTerm $ locally Elab.sig_ (I.singleton (I.Interface (["Effect", "Console"]:.:U "Output") Nil) :) $ Elab.synthExpr e + e' :==> _T <- runElab $ Elab.elabSynthTerm $ Elab.runErr $ locally Elab.sig_ (I.singleton (I.Interface (["Effect", "Console"]:.:U "Output") Nil) :) $ Elab.synthExpr e e'' <- runElab $ runEvalMain e' opts <- get outputDocLn (getPrint (ann (Print.print opts mempty e'' ::: Print.print opts mempty _T))) @@ -221,7 +221,7 @@ runEvalMain e = runEval (runQuoter 0 . quote =<< runReader mempty (eval e)) pur showKind :: S.Ann S.Type -> Action showKind _T = Action $ do - _T :==> _K <- runElab $ Elab.elabSynthType (Elab.synthType _T) + _T :==> _K <- runElab $ Elab.elabSynthType (Elab.runErr (Elab.synthType _T)) opts <- get outputDocLn (getPrint (ann (Print.print opts mempty _T ::: Print.print opts mempty _K))) @@ -243,7 +243,7 @@ prompt = do p <- liftIO $ fn line fmap (sourceFromString Nothing line) <$> getInputLine p -runElab :: Has (State (Options Print) :+: State REPL) sig m => I.WriteC (Notice.Notice (Doc Style)) Elab.Warn (I.ThrowC (Notice.Notice (Doc Style)) Elab.ErrReason (ReaderC MName (ReaderC Module (ReaderC Graph m)))) a -> m a +runElab :: Has (State (Options Print) :+: State REPL) sig m => I.WriteC (Notice.Notice (Doc Style)) Elab.Warn (I.ThrowC (Notice.Notice (Doc Style)) Elab.Err (ReaderC MName (ReaderC Module (ReaderC Graph m)))) a -> m a runElab m = do graph <- use (target_.modules_) localDefs <- use localDefs_ From 0f540705729d1baa49d050f0855bf85fe40cec5a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 Mar 2022 19:57:55 -0400 Subject: [PATCH 0966/1324] Define a Column type for zipping n-ary sums. --- src/Facet/Elab/Pattern.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index c8df6bd49..579a0663c 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -10,6 +10,8 @@ module Facet.Elab.Pattern import Control.Effect.Empty import Data.Foldable (fold) import Data.Monoid (First(..)) +import Data.Semialign (alignWith) +import Data.These (these) import Data.Traversable (for) import Facet.Name import qualified Facet.Sequent.Expr as X @@ -63,3 +65,9 @@ match :: Has Empty sig m => Fold (Pattern Name) [Pattern Name] -> [Clause X.Term match o heads = forOf (traversed.patterns_) heads (\case p:ps | Just prefix <- preview o (instantiateHead p) -> pure (prefix <> ps) _ -> empty) + + +newtype Column a = Column { getColumn :: [[a]] } + +instance Semigroup a => Semigroup (Column a) where + as <> bs = Column (alignWith (these id id (<>)) (getColumn as) (getColumn bs)) From 0825adb02860c6ba720809db2472088381e96b22 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 Mar 2022 19:58:17 -0400 Subject: [PATCH 0967/1324] Export Column. --- src/Facet/Elab/Pattern.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 579a0663c..97dc5736c 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -5,6 +5,7 @@ module Facet.Elab.Pattern , patterns_ -- * Coverage judgement , compileClauses +, Column(..) ) where import Control.Effect.Empty From e399015afe0d5541fada3ac257441d443e4bd432 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 Mar 2022 19:58:31 -0400 Subject: [PATCH 0968/1324] Construct singleton columns. --- src/Facet/Elab/Pattern.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 97dc5736c..cf484a6cf 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -6,6 +6,8 @@ module Facet.Elab.Pattern -- * Coverage judgement , compileClauses , Column(..) +, RowIndex +, singleton ) where import Control.Effect.Empty @@ -72,3 +74,8 @@ newtype Column a = Column { getColumn :: [[a]] } instance Semigroup a => Semigroup (Column a) where as <> bs = Column (alignWith (these id id (<>)) (getColumn as) (getColumn bs)) + +type RowIndex = Int + +singleton :: RowIndex -> a -> Column a +singleton row a = Column (replicate (row - 1) [] <> [[a]]) From dc5752f6f89ee416468fc11963ef85b5434c0c27 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 Mar 2022 19:59:21 -0400 Subject: [PATCH 0969/1324] Construct columns from lists. --- src/Facet/Elab/Pattern.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index cf484a6cf..cce039dc6 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -8,6 +8,7 @@ module Facet.Elab.Pattern , Column(..) , RowIndex , singleton +, fromList ) where import Control.Effect.Empty @@ -79,3 +80,6 @@ type RowIndex = Int singleton :: RowIndex -> a -> Column a singleton row a = Column (replicate (row - 1) [] <> [[a]]) + +fromList :: [a] -> Column a +fromList = Column . map pure From d4378b1e60d7a2d6b23433814db151a1f6ff0f12 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 Mar 2022 20:00:47 -0400 Subject: [PATCH 0970/1324] :memo: the Column constructors. --- src/Facet/Elab/Pattern.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index cce039dc6..899650978 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -78,8 +78,10 @@ instance Semigroup a => Semigroup (Column a) where type RowIndex = Int +-- | Construct a sparse 'Column' from a single value. singleton :: RowIndex -> a -> Column a singleton row a = Column (replicate (row - 1) [] <> [[a]]) +-- | Construct a dense 'Column' from a list of values. fromList :: [a] -> Column a fromList = Column . map pure From f468624ce549a44147b9331ca93feeb33e44df9a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 Mar 2022 20:02:53 -0400 Subject: [PATCH 0971/1324] Column is sparse. --- src/Facet/Elab/Pattern.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 899650978..c09b36073 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -13,6 +13,7 @@ module Facet.Elab.Pattern import Control.Effect.Empty import Data.Foldable (fold) +import qualified Data.IntMap as IntMap import Data.Monoid (First(..)) import Data.Semialign (alignWith) import Data.These (these) @@ -71,7 +72,7 @@ match o heads = forOf (traversed.patterns_) heads (\case _ -> empty) -newtype Column a = Column { getColumn :: [[a]] } +newtype Column a = Column { getColumn :: IntMap.IntMap [a] } instance Semigroup a => Semigroup (Column a) where as <> bs = Column (alignWith (these id id (<>)) (getColumn as) (getColumn bs)) @@ -80,8 +81,8 @@ type RowIndex = Int -- | Construct a sparse 'Column' from a single value. singleton :: RowIndex -> a -> Column a -singleton row a = Column (replicate (row - 1) [] <> [[a]]) +singleton row a = Column (IntMap.singleton row [a]) -- | Construct a dense 'Column' from a list of values. fromList :: [a] -> Column a -fromList = Column . map pure +fromList = Column . IntMap.fromList . zipWith (\ a b -> (a, [b])) [0..] From 68efc495dce9898edb5edc66e4b3b1ba0d0a915f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 Mar 2022 20:03:59 -0400 Subject: [PATCH 0972/1324] Columns don't automatically hold monoids. --- src/Facet/Elab/Pattern.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index c09b36073..030e43107 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -72,7 +72,7 @@ match o heads = forOf (traversed.patterns_) heads (\case _ -> empty) -newtype Column a = Column { getColumn :: IntMap.IntMap [a] } +newtype Column a = Column { getColumn :: IntMap.IntMap a } instance Semigroup a => Semigroup (Column a) where as <> bs = Column (alignWith (these id id (<>)) (getColumn as) (getColumn bs)) @@ -81,8 +81,8 @@ type RowIndex = Int -- | Construct a sparse 'Column' from a single value. singleton :: RowIndex -> a -> Column a -singleton row a = Column (IntMap.singleton row [a]) +singleton row a = Column (IntMap.singleton row a) -- | Construct a dense 'Column' from a list of values. fromList :: [a] -> Column a -fromList = Column . IntMap.fromList . zipWith (\ a b -> (a, [b])) [0..] +fromList = Column . IntMap.fromList . zipWith (\ a b -> (a, b)) [0..] From 296b9cc5008aa9f0c0da7a7c11edcbfd92729239 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 Mar 2022 20:04:34 -0400 Subject: [PATCH 0973/1324] Simplify how we combine columns. --- src/Facet/Elab/Pattern.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 030e43107..d22d4fe9e 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -15,8 +15,6 @@ import Control.Effect.Empty import Data.Foldable (fold) import qualified Data.IntMap as IntMap import Data.Monoid (First(..)) -import Data.Semialign (alignWith) -import Data.These (these) import Data.Traversable (for) import Facet.Name import qualified Facet.Sequent.Expr as X @@ -75,7 +73,7 @@ match o heads = forOf (traversed.patterns_) heads (\case newtype Column a = Column { getColumn :: IntMap.IntMap a } instance Semigroup a => Semigroup (Column a) where - as <> bs = Column (alignWith (these id id (<>)) (getColumn as) (getColumn bs)) + as <> bs = Column (IntMap.unionWith (<>) (getColumn bs) (getColumn as)) type RowIndex = Int From f5d34a7fd5e3044f71621978e739396a03ce7e4e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 Mar 2022 20:06:13 -0400 Subject: [PATCH 0974/1324] Apparently the With functions are not left-biased. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index d22d4fe9e..e1faed68c 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -73,7 +73,7 @@ match o heads = forOf (traversed.patterns_) heads (\case newtype Column a = Column { getColumn :: IntMap.IntMap a } instance Semigroup a => Semigroup (Column a) where - as <> bs = Column (IntMap.unionWith (<>) (getColumn bs) (getColumn as)) + as <> bs = Column (IntMap.unionWith (<>) (getColumn as) (getColumn bs)) type RowIndex = Int From 61006eb19c724311f525d992e2265903c523b489 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 Mar 2022 07:19:16 -0400 Subject: [PATCH 0975/1324] Define an accessor for Column. --- src/Facet/Elab/Pattern.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index e1faed68c..92205651c 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -9,6 +9,7 @@ module Facet.Elab.Pattern , RowIndex , singleton , fromList +, at ) where import Control.Effect.Empty @@ -84,3 +85,6 @@ singleton row a = Column (IntMap.singleton row a) -- | Construct a dense 'Column' from a list of values. fromList :: [a] -> Column a fromList = Column . IntMap.fromList . zipWith (\ a b -> (a, b)) [0..] + +at :: Column a -> RowIndex -> a +at (Column m) i = m IntMap.! i From f9fc4003c6ab09f9d717aaac66039369a76f0800 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 Mar 2022 07:20:37 -0400 Subject: [PATCH 0976/1324] Define a Monoid instance for Column. --- src/Facet/Elab/Pattern.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 92205651c..98ae26385 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -76,6 +76,9 @@ newtype Column a = Column { getColumn :: IntMap.IntMap a } instance Semigroup a => Semigroup (Column a) where as <> bs = Column (IntMap.unionWith (<>) (getColumn as) (getColumn bs)) +instance Monoid a => Monoid (Column a) where + mempty = Column mempty + type RowIndex = Int -- | Construct a sparse 'Column' from a single value. From 3d19b0407ab0a2216ac591fdd6c7f316e5fcce5f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 Mar 2022 07:20:58 -0400 Subject: [PATCH 0977/1324] Compile sums into columns. --- src/Facet/Elab/Pattern.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 98ae26385..5cff2f927 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -51,16 +51,16 @@ compileClauses ctx (_A :-> _T) heads = X.lamRA $ case _A of X.letA (X.µRA (X.varA (Free 3) X..||. X.prdL2A (X.covarA (Free 0)))) ( compileClauses ctx _T heads' X..||. X.covarA (Free 2))) _A :+ _B -> do - (headsL, headsR) <- fold <$> for heads (\case + heads' <- fold <$> for heads (\case Clause (p:ps) b -> case instantiateHead p of - InL p -> pure ([Clause (p:ps) b], []) - InR p -> pure ([], [Clause (p:ps) b]) - Var Nothing -> pure ([Clause (Var Nothing:ps) b], [Clause (Var Nothing:ps) b]) + InL p -> pure (singleton 0 [Clause (p:ps) b]) + InR p -> pure (singleton 1 [Clause (p:ps) b]) + Var Nothing -> pure (fromList [[Clause (Var Nothing:ps) b], [Clause (Var Nothing:ps) b]]) _ -> empty _ -> empty) X.varA (Free 1) X..||. X.sumLA - (X.µLA (compileClauses ctx _T headsL X..||. X.covarA (Free 0))) - (X.µLA (compileClauses ctx _T headsR X..||. X.covarA (Free 0))) + (X.µLA (compileClauses ctx _T (heads' `at` 0) X..||. X.covarA (Free 0))) + (X.µLA (compileClauses ctx _T (heads' `at` 1) X..||. X.covarA (Free 0))) compileClauses _ _T heads | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) = pure b | otherwise = empty From 21d3da3958e164b75b4aaee5399ff33cd65b69dc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 Mar 2022 07:25:38 -0400 Subject: [PATCH 0978/1324] Recur through sum types' parameter types. This is wrong; it will create extra lambdas. We don't currently have a way to avoid that, and in the meantime this feels "less wrong" than what we were doing previously, in that fixing the former will automatically be correct. --- src/Facet/Elab/Pattern.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 5cff2f927..6fc138fed 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -59,8 +59,8 @@ compileClauses ctx (_A :-> _T) heads = X.lamRA $ case _A of _ -> empty _ -> empty) X.varA (Free 1) X..||. X.sumLA - (X.µLA (compileClauses ctx _T (heads' `at` 0) X..||. X.covarA (Free 0))) - (X.µLA (compileClauses ctx _T (heads' `at` 1) X..||. X.covarA (Free 0))) + (X.µLA (compileClauses ctx (_A :-> _T) (heads' `at` 0) X..||. X.covarA (Free 0))) + (X.µLA (compileClauses ctx (_B :-> _T) (heads' `at` 1) X..||. X.covarA (Free 0))) compileClauses _ _T heads | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) = pure b | otherwise = empty From 99eb00430b0ccb0aee89dad8d3c0192d84ba716e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 Mar 2022 08:58:05 -0400 Subject: [PATCH 0979/1324] FIXMEs. --- src/Facet/Elab/Pattern.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 6fc138fed..5b5ba2061 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -43,6 +43,8 @@ instantiateHead p = p compileClauses :: Has Empty sig m => [X.Term] -> Type -> [Clause X.Term] -> m X.Term compileClauses ctx (_A :-> _T) heads = X.lamRA $ case _A of + -- FIXME: look variables up in @ctx@ instead of hard-coding de Bruijn indices + -- FIXME: make gensyms practical à la /I Am Not a Number, I Am a Free Variable/ Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) One -> (match (_Unit.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) @@ -59,6 +61,8 @@ compileClauses ctx (_A :-> _T) heads = X.lamRA $ case _A of _ -> empty _ -> empty) X.varA (Free 1) X..||. X.sumLA + -- FIXME: n-ary sums + -- FIXME: don't create extra lambdas for the recursive calls (X.µLA (compileClauses ctx (_A :-> _T) (heads' `at` 0) X..||. X.covarA (Free 0))) (X.µLA (compileClauses ctx (_B :-> _T) (heads' `at` 1) X..||. X.covarA (Free 0))) compileClauses _ _T heads From 2db332f0756547a546add588b74a7b657e56055c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 Mar 2022 17:32:25 -0400 Subject: [PATCH 0980/1324] :fire: language extensions. --- src/Facet/Elab/Pattern.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 5b5ba2061..e6dc593f9 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE UndecidableInstances #-} module Facet.Elab.Pattern ( Clause(..) , patterns_ From 6bdae38afd73b964a81272cd36c1a6e3cee84f56 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 Mar 2022 17:59:26 -0400 Subject: [PATCH 0981/1324] Simplify sumLA. --- src/Facet/Sequent/Class.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index ee23cc8b1..4abd98bb8 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -113,7 +113,7 @@ sumLA => m (i c) -> m (i c) -> m (i c) -sumLA l r = liftA2 sumL <$> l <*> r +sumLA = liftA2 (liftA2 sumL) -- sumLA -- :: (Sequent t c d, Applicative i, Applicative m) From 3540a2ced1d0f3c98246b6f6a1f5cc8474306832 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 Mar 2022 18:14:08 -0400 Subject: [PATCH 0982/1324] Correct some docs. --- src/Facet/Name.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 567b54404..2d61ee9dc 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -130,7 +130,7 @@ instance DeBruijn lv ix => DeBruijn (LName lv) (LName ix) where toLeveled = fmap . toLeveled --- | Declaration names; a choice of expression, constructor, term, or operator names. +-- | Declaration names; a choice of textual or operator names. data Name = U Text | O Op From 8e9fb4aace9956e1183003bc76c589f1283dd44c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 Mar 2022 00:58:52 -0400 Subject: [PATCH 0983/1324] Define agency names. --- src/Facet/Name.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 2d61ee9dc..bfd15892f 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -21,6 +21,7 @@ module Facet.Name , formatOp , OpN(..) , formatOpN +, AName(..) ) where import Data.Foldable (foldl', foldr', toList) @@ -190,3 +191,10 @@ formatOpN (<+>) pretty place = \case PostfixN ee e -> foldr' (<+>) (comp e) (map comp ee) where comp e = place <+> pretty e InfixN (m NE.:|mm) -> place <+> foldr' comp (pretty m) mm <+> place where comp s e = pretty s <+> place <+> e OutfixN s mm e -> foldr' comp (pretty e) (s : mm) where comp s e = pretty s <+> place <+> e + + +-- | Agency-generated names à la /I Am Not a Number, I Am a Free Variable/. +data AName + = Root + | AName :// (Name, Int) + deriving (Eq, Ord, Show) From 4a94e79585271204a13b31f85076555639cff3b4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 Mar 2022 01:12:26 -0400 Subject: [PATCH 0984/1324] Compute the digits in an Int. --- src/Facet/Pretty.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Facet/Pretty.hs b/src/Facet/Pretty.hs index 2648fec4a..be70ccdff 100644 --- a/src/Facet/Pretty.hs +++ b/src/Facet/Pretty.hs @@ -14,6 +14,7 @@ module Facet.Pretty , lower , upper , varFrom +, digits -- * Columnar layout , tabulate2 -- * Rendering @@ -102,6 +103,14 @@ varFrom :: Printer p => String -> Int -> p varFrom alpha i = pretty (toAlpha alpha i) +digits :: Int -> [Int] +digits = go [] + where + go ds i + | abs i < 10 = i:ds + | otherwise = let (q, r) = i `quotRem` 10 in go (r:ds) q + + -- Columnar layout tabulate2 :: PP.Doc a -> [(PP.Doc a, PP.Doc a)] -> PP.Doc a From aadb69d610a4b7fc66cf7e33597b2a5c7a77cd82 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 Mar 2022 01:14:40 -0400 Subject: [PATCH 0985/1324] Format subscripts. --- src/Facet/Pretty.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Facet/Pretty.hs b/src/Facet/Pretty.hs index be70ccdff..b7f4da09f 100644 --- a/src/Facet/Pretty.hs +++ b/src/Facet/Pretty.hs @@ -14,6 +14,7 @@ module Facet.Pretty , lower , upper , varFrom +, subscript , digits -- * Columnar layout , tabulate2 @@ -103,6 +104,13 @@ varFrom :: Printer p => String -> Int -> p varFrom alpha i = pretty (toAlpha alpha i) +subscript :: Printer p => Int -> p +subscript i = sign <> foldMap (pretty . (subscripts !!) . abs) (digits i) + where + sign | i < 0 = pretty "₋" + | otherwise = mempty + subscripts = ['₀'..'₉'] + digits :: Int -> [Int] digits = go [] where From 627bf62bd273f97df177256cc860730d56cece21 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 Mar 2022 01:15:43 -0400 Subject: [PATCH 0986/1324] Pretty-print ANames. --- src/Facet/Name.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index bfd15892f..946a72405 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -31,6 +31,7 @@ import qualified Data.List.NonEmpty as NE import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as T +import Facet.Pretty (subscript) import Facet.Snoc import Facet.Snoc.NonEmpty import qualified Prettyprinter as P @@ -198,3 +199,9 @@ data AName = Root | AName :// (Name, Int) deriving (Eq, Ord, Show) + +instance P.Pretty AName where + pretty = \case + Root -> P.pretty '_' + Root :// (n, i) -> P.pretty n <> if i <= 0 then mempty else subscript i + parent :// (n, i) -> P.pretty parent <> "." <> P.pretty n <> if i <= 0 then mempty else subscript i From ae346a1e6c63ff744201a8f7815337abbb68b271 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 Mar 2022 01:44:54 -0400 Subject: [PATCH 0987/1324] Define a smart constructor for ANames. --- src/Facet/Name.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 946a72405..0828f9f76 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -22,6 +22,7 @@ module Facet.Name , OpN(..) , formatOpN , AName(..) +, (//) ) where import Data.Foldable (foldl', foldr', toList) @@ -205,3 +206,8 @@ instance P.Pretty AName where Root -> P.pretty '_' Root :// (n, i) -> P.pretty n <> if i <= 0 then mempty else subscript i parent :// (n, i) -> P.pretty parent <> "." <> P.pretty n <> if i <= 0 then mempty else subscript i + +(//) :: AName -> Name -> AName +parent // name = parent :// (name, 0) + +infixl 6 // From aa63867211526e2665bee60584c63e291a56a6ba Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 Mar 2022 01:46:10 -0400 Subject: [PATCH 0988/1324] Define a smart constructor for ANames at the root. --- src/Facet/Name.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 0828f9f76..90cdfd41b 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -23,6 +23,7 @@ module Facet.Name , formatOpN , AName(..) , (//) +, anm ) where import Data.Foldable (foldl', foldr', toList) @@ -211,3 +212,6 @@ instance P.Pretty AName where parent // name = parent :// (name, 0) infixl 6 // + +anm :: Name -> AName +anm = (Root //) From 940e62f681e6872c21165551300c2d0b7e635dbd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 Mar 2022 01:47:35 -0400 Subject: [PATCH 0989/1324] Give fixity & precedence for ://. --- src/Facet/Name.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 90cdfd41b..ae4085262 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -202,6 +202,8 @@ data AName | AName :// (Name, Int) deriving (Eq, Ord, Show) +infixl 6 :// + instance P.Pretty AName where pretty = \case Root -> P.pretty '_' From ec269bc6e8ecacdffd8cebe542842ec1026f4287 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 Mar 2022 01:49:10 -0400 Subject: [PATCH 0990/1324] Define a Semigroup instance for AName. --- src/Facet/Name.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index ae4085262..9ac97e17a 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -204,6 +204,10 @@ data AName infixl 6 :// +instance Semigroup AName where + xs <> Root = xs + xs <> (ys :// y) = (xs <> ys) :// y + instance P.Pretty AName where pretty = \case Root -> P.pretty '_' From 7b62e5522693eff16eea61ed0424eb8a983c7eb7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 Mar 2022 01:49:30 -0400 Subject: [PATCH 0991/1324] Define a Monoid instance for Root. --- src/Facet/Name.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 9ac97e17a..fb90a9399 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -208,6 +208,9 @@ instance Semigroup AName where xs <> Root = xs xs <> (ys :// y) = (xs <> ys) :// y +instance Monoid AName where + mempty = Root + instance P.Pretty AName where pretty = \case Root -> P.pretty '_' From f10d4979d0a5e776326a7032298c0ac62b1b47ea Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 Mar 2022 16:31:26 -0400 Subject: [PATCH 0992/1324] Formattting. --- src/Facet/Syntax.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 0b300fcaf..ef94b55ae 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -10,7 +10,8 @@ module Facet.Syntax , ty , _ty , (:=:)(..) -, nm, def +, nm +, def , (:@)(..) , qty -- * Variables From ed1c1c7b822709b4251885d44804a6ecac26b8cb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 Mar 2022 16:33:30 -0400 Subject: [PATCH 0993/1324] Define a module for an Agency effect. --- facet.cabal | 1 + src/Facet/Effect/Agency.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Effect/Agency.hs diff --git a/facet.cabal b/facet.cabal index 3d87f06bd..f8b49dd45 100644 --- a/facet.cabal +++ b/facet.cabal @@ -80,6 +80,7 @@ library Facet.Context Facet.Diff Facet.Driver + Facet.Effect.Agency Facet.Effect.CallStack Facet.Effect.Parser Facet.Effect.Profile diff --git a/src/Facet/Effect/Agency.hs b/src/Facet/Effect/Agency.hs new file mode 100644 index 000000000..741534ae4 --- /dev/null +++ b/src/Facet/Effect/Agency.hs @@ -0,0 +1,2 @@ +module Facet.Effect.Agency +() where From a6ff3c1745e794dacaddcb9e872da552c2be1163 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 Mar 2022 16:37:07 -0400 Subject: [PATCH 0994/1324] Define an Agency effect. --- src/Facet/Effect/Agency.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Facet/Effect/Agency.hs b/src/Facet/Effect/Agency.hs index 741534ae4..032285522 100644 --- a/src/Facet/Effect/Agency.hs +++ b/src/Facet/Effect/Agency.hs @@ -1,2 +1,7 @@ +{-# LANGUAGE GADTs #-} module Facet.Effect.Agency -() where +( Agency(..) +) where + +data Agency m k where + Scope :: String -> m a -> Agency m a From 970f331921e012260d8f5e6330a7524b59ab51f1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 Mar 2022 18:24:05 -0400 Subject: [PATCH 0995/1324] Define datatypes for roots and names. --- src/Facet/Effect/Agency.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/Facet/Effect/Agency.hs b/src/Facet/Effect/Agency.hs index 032285522..dfdb71edd 100644 --- a/src/Facet/Effect/Agency.hs +++ b/src/Facet/Effect/Agency.hs @@ -1,7 +1,15 @@ {-# LANGUAGE GADTs #-} module Facet.Effect.Agency -( Agency(..) +( Root(..) +, Name(..) +, Agency(..) ) where +data Root + = Root + | Name :// String + +data Name = Name Root String Int + data Agency m k where Scope :: String -> m a -> Agency m a From 2b8917b1b49a60f13caedb57fb738d99eeaf6c0b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 Mar 2022 22:00:30 -0400 Subject: [PATCH 0996/1324] Add an operation to compute fresh variable names. --- src/Facet/Effect/Agency.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Effect/Agency.hs b/src/Facet/Effect/Agency.hs index dfdb71edd..ab3cde408 100644 --- a/src/Facet/Effect/Agency.hs +++ b/src/Facet/Effect/Agency.hs @@ -13,3 +13,4 @@ data Name = Name Root String Int data Agency m k where Scope :: String -> m a -> Agency m a + Fresh :: String -> Agency m Name From 16bd451817c17c43a925ddc3906d31a677f10af1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 Mar 2022 22:31:26 -0400 Subject: [PATCH 0997/1324] Pass an AName around. --- src/Facet/Elab/Pattern.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index e6dc593f9..74df5e21b 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -39,17 +39,17 @@ instantiateHead (Var (Just _)) = Var Nothing -- FIXME: let-bind any variables fi instantiateHead p = p -compileClauses :: Has Empty sig m => [X.Term] -> Type -> [Clause X.Term] -> m X.Term -compileClauses ctx (_A :-> _T) heads = X.lamRA $ case _A of +compileClauses :: Has Empty sig m => AName -> [X.Term] -> Type -> [Clause X.Term] -> m X.Term +compileClauses root ctx (_A :-> _T) heads = X.lamRA $ case _A of -- FIXME: look variables up in @ctx@ instead of hard-coding de Bruijn indices -- FIXME: make gensyms practical à la /I Am Not a Number, I Am a Free Variable/ - Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) - _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) - One -> (match (_Unit.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) + Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses root ctx _T) X..||. X.covarA (Free 0) + _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses root ctx _T) X..||. X.covarA (Free 0) + One -> (match (_Unit.to (const [])) heads >>= compileClauses root ctx _T) X..||. X.covarA (Free 0) _A :* _B -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Var._Nothing.to (const [Var Nothing, Var Nothing])))) heads >>= \ heads' -> X.letA (X.µRA (X.varA (Free 2) X..||. X.prdL1A (X.covarA (Free 0)))) ( X.letA (X.µRA (X.varA (Free 3) X..||. X.prdL2A (X.covarA (Free 0)))) ( - compileClauses ctx _T heads' X..||. X.covarA (Free 2))) + compileClauses root ctx _T heads' X..||. X.covarA (Free 2))) _A :+ _B -> do heads' <- fold <$> for heads (\case Clause (p:ps) b -> case instantiateHead p of @@ -61,9 +61,9 @@ compileClauses ctx (_A :-> _T) heads = X.lamRA $ case _A of X.varA (Free 1) X..||. X.sumLA -- FIXME: n-ary sums -- FIXME: don't create extra lambdas for the recursive calls - (X.µLA (compileClauses ctx (_A :-> _T) (heads' `at` 0) X..||. X.covarA (Free 0))) - (X.µLA (compileClauses ctx (_B :-> _T) (heads' `at` 1) X..||. X.covarA (Free 0))) -compileClauses _ _T heads + (X.µLA (compileClauses root ctx (_A :-> _T) (heads' `at` 0) X..||. X.covarA (Free 0))) + (X.µLA (compileClauses root ctx (_B :-> _T) (heads' `at` 1) X..||. X.covarA (Free 0))) +compileClauses _ _ _T heads | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) = pure b | otherwise = empty From 239a00811224df25135a4c5f19b61efcefce26ad Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 31 Mar 2022 22:36:42 -0400 Subject: [PATCH 0998/1324] Add gensyms to Name. --- src/Facet/Driver.hs | 2 ++ src/Facet/Name.hs | 2 ++ 2 files changed, 4 insertions(+) diff --git a/src/Facet/Driver.hs b/src/Facet/Driver.hs index f58c42c09..eb5278a07 100644 --- a/src/Facet/Driver.hs +++ b/src/Facet/Driver.hs @@ -54,6 +54,7 @@ import Facet.Syntax as S import Fresnel.At (at) import Fresnel.Getter ((^.)) import Fresnel.Lens (Lens, Lens', lens) +import qualified Prettyprinter as P import Silkscreen import System.Directory (findFile) import qualified System.FilePath as FP @@ -170,6 +171,7 @@ resolveName searchPaths name = do unpack = \case U n -> TS.unpack n O o -> formatOp (\ a b -> a <> " " <> b) TS.unpack "_" o + G g -> show (P.pretty g) -- Errors diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index fb90a9399..7b2b90f3f 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -138,6 +138,7 @@ instance DeBruijn lv ix => DeBruijn (LName lv) (LName ix) where data Name = U Text | O Op + | G AName deriving (Eq, Ord, Show) instance IsString Name where @@ -147,6 +148,7 @@ instance P.Pretty Name where pretty = \case U n -> P.pretty n O o -> P.pretty o + G g -> P.pretty g -- | Associativity of an infix operator. From 5652bd9078fbfd4033f944a292150f1253c311f4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 08:32:40 -0400 Subject: [PATCH 0999/1324] :fire: a FIXME. --- src/Facet/Elab/Pattern.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 74df5e21b..0e160632e 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -42,7 +42,6 @@ instantiateHead p = p compileClauses :: Has Empty sig m => AName -> [X.Term] -> Type -> [Clause X.Term] -> m X.Term compileClauses root ctx (_A :-> _T) heads = X.lamRA $ case _A of -- FIXME: look variables up in @ctx@ instead of hard-coding de Bruijn indices - -- FIXME: make gensyms practical à la /I Am Not a Number, I Am a Free Variable/ Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses root ctx _T) X..||. X.covarA (Free 0) _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses root ctx _T) X..||. X.covarA (Free 0) One -> (match (_Unit.to (const [])) heads >>= compileClauses root ctx _T) X..||. X.covarA (Free 0) From 4c11d19f8019b41bb53af478189b608213c497c9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 08:43:31 -0400 Subject: [PATCH 1000/1324] Revert "Add gensyms to Name." This reverts commit 239a00811224df25135a4c5f19b61efcefce26ad. --- src/Facet/Driver.hs | 2 -- src/Facet/Name.hs | 2 -- 2 files changed, 4 deletions(-) diff --git a/src/Facet/Driver.hs b/src/Facet/Driver.hs index eb5278a07..f58c42c09 100644 --- a/src/Facet/Driver.hs +++ b/src/Facet/Driver.hs @@ -54,7 +54,6 @@ import Facet.Syntax as S import Fresnel.At (at) import Fresnel.Getter ((^.)) import Fresnel.Lens (Lens, Lens', lens) -import qualified Prettyprinter as P import Silkscreen import System.Directory (findFile) import qualified System.FilePath as FP @@ -171,7 +170,6 @@ resolveName searchPaths name = do unpack = \case U n -> TS.unpack n O o -> formatOp (\ a b -> a <> " " <> b) TS.unpack "_" o - G g -> show (P.pretty g) -- Errors diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 7b2b90f3f..fb90a9399 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -138,7 +138,6 @@ instance DeBruijn lv ix => DeBruijn (LName lv) (LName ix) where data Name = U Text | O Op - | G AName deriving (Eq, Ord, Show) instance IsString Name where @@ -148,7 +147,6 @@ instance P.Pretty Name where pretty = \case U n -> P.pretty n O o -> P.pretty o - G g -> P.pretty g -- | Associativity of an infix operator. From 45a767b026842eb623dc838f378dd10e210209ab Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 08:50:16 -0400 Subject: [PATCH 1001/1324] Restructure AName as a mutually recursive type. --- src/Facet/Name.hs | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index fb90a9399..87690cdc5 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -21,6 +21,7 @@ module Facet.Name , formatOp , OpN(..) , formatOpN +, Root(..) , AName(..) , (//) , anm @@ -196,29 +197,28 @@ formatOpN (<+>) pretty place = \case OutfixN s mm e -> foldr' comp (pretty e) (s : mm) where comp s e = pretty s <+> place <+> e --- | Agency-generated names à la /I Am Not a Number, I Am a Free Variable/. -data AName +data Root = Root - | AName :// (Name, Int) + | AName :// Text deriving (Eq, Ord, Show) -infixl 6 :// +instance P.Pretty Root where + pretty = \case + Root -> P.pretty '_' + parent :// n -> P.pretty parent <> "." <> P.pretty n -instance Semigroup AName where - xs <> Root = xs - xs <> (ys :// y) = (xs <> ys) :// y +-- | Agency-generated names à la /I Am Not a Number, I Am a Free Variable/. +data AName = AName Root Name Int + deriving (Eq, Ord, Show) -instance Monoid AName where - mempty = Root +infixl 6 :// instance P.Pretty AName where - pretty = \case - Root -> P.pretty '_' - Root :// (n, i) -> P.pretty n <> if i <= 0 then mempty else subscript i - parent :// (n, i) -> P.pretty parent <> "." <> P.pretty n <> if i <= 0 then mempty else subscript i + pretty (AName Root n i) = P.pretty n <> if i <= 0 then mempty else subscript i + pretty (AName parent n i) = P.pretty parent <> "." <> P.pretty n <> if i <= 0 then mempty else subscript i -(//) :: AName -> Name -> AName -parent // name = parent :// (name, 0) +(//) :: Root -> Name -> AName +parent // name = AName parent name 0 infixl 6 // From 92be69bcc29b07baeece5fb9153b896c4a6bf112 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 08:51:15 -0400 Subject: [PATCH 1002/1324] Rename AName to GName. --- src/Facet/Elab/Pattern.hs | 2 +- src/Facet/Name.hs | 18 +++++++++--------- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 0e160632e..a98b34b55 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -39,7 +39,7 @@ instantiateHead (Var (Just _)) = Var Nothing -- FIXME: let-bind any variables fi instantiateHead p = p -compileClauses :: Has Empty sig m => AName -> [X.Term] -> Type -> [Clause X.Term] -> m X.Term +compileClauses :: Has Empty sig m => GName -> [X.Term] -> Type -> [Clause X.Term] -> m X.Term compileClauses root ctx (_A :-> _T) heads = X.lamRA $ case _A of -- FIXME: look variables up in @ctx@ instead of hard-coding de Bruijn indices Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses root ctx _T) X..||. X.covarA (Free 0) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 87690cdc5..fa23553da 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -22,7 +22,7 @@ module Facet.Name , OpN(..) , formatOpN , Root(..) -, AName(..) +, GName(..) , (//) , anm ) where @@ -199,7 +199,7 @@ formatOpN (<+>) pretty place = \case data Root = Root - | AName :// Text + | GName :// Text deriving (Eq, Ord, Show) instance P.Pretty Root where @@ -208,19 +208,19 @@ instance P.Pretty Root where parent :// n -> P.pretty parent <> "." <> P.pretty n -- | Agency-generated names à la /I Am Not a Number, I Am a Free Variable/. -data AName = AName Root Name Int +data GName = GName Root Name Int deriving (Eq, Ord, Show) infixl 6 :// -instance P.Pretty AName where - pretty (AName Root n i) = P.pretty n <> if i <= 0 then mempty else subscript i - pretty (AName parent n i) = P.pretty parent <> "." <> P.pretty n <> if i <= 0 then mempty else subscript i +instance P.Pretty GName where + pretty (GName Root n i) = P.pretty n <> if i <= 0 then mempty else subscript i + pretty (GName parent n i) = P.pretty parent <> "." <> P.pretty n <> if i <= 0 then mempty else subscript i -(//) :: Root -> Name -> AName -parent // name = AName parent name 0 +(//) :: Root -> Name -> GName +parent // name = GName parent name 0 infixl 6 // -anm :: Name -> AName +anm :: Name -> GName anm = (Root //) From 45def4bbac27df9ebde882e50f1f1fa286af43b8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 08:51:46 -0400 Subject: [PATCH 1003/1324] compileClauses takes a Root. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index a98b34b55..a932a684c 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -39,7 +39,7 @@ instantiateHead (Var (Just _)) = Var Nothing -- FIXME: let-bind any variables fi instantiateHead p = p -compileClauses :: Has Empty sig m => GName -> [X.Term] -> Type -> [Clause X.Term] -> m X.Term +compileClauses :: Has Empty sig m => Root -> [X.Term] -> Type -> [Clause X.Term] -> m X.Term compileClauses root ctx (_A :-> _T) heads = X.lamRA $ case _A of -- FIXME: look variables up in @ctx@ instead of hard-coding de Bruijn indices Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses root ctx _T) X..||. X.covarA (Free 0) From 1891c1ad5ca7f8fefa3611bb9693975c7296643d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 08:55:56 -0400 Subject: [PATCH 1004/1324] Abbreviate a bunch of definitions. --- src/Facet/Sequent/Expr.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 9c3e38d21..516917c14 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -68,16 +68,16 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where sumR1 = fmap SumR1 sumR2 = fmap SumR2 unitR = pure UnitR - prdR l r = PrdR <$> l <*> r + prdR = liftA2 PrdR stringR = pure . StringR covar v = Quoter (\ d -> Covar (toIndexed d v)) µL b = MuL <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b - lamL a b = LamL <$> a <*> b - sumL l r = SumL <$> l <*> r + lamL = liftA2 LamL + sumL = liftA2 SumL unitL = pure UnitL - prdL1 b = PrdL1 <$> b - prdL2 b = PrdL2 <$> b + prdL1 = fmap PrdL1 + prdL2 = fmap PrdL2 (.|.) = liftA2 (:|:) let' t b = Let <$> t <*> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b From 089bca11f19f21161c3fbbcc54fe4dee322ef1cd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 09:03:13 -0400 Subject: [PATCH 1005/1324] Tacit. --- src/Facet/Sequent/Expr.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 516917c14..05e88e9d3 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -64,7 +64,7 @@ data Command instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where var v = Quoter (\ d -> Var (toIndexed d v)) µR b = MuR <$> binder (\ d' -> Quoter (\ d -> covar (toIndexed d d'))) b - lamR b = LamR <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) (\ t -> binder (\ d'' -> Quoter (\ d -> covar (toIndexed d d''))) (b t)) + lamR b = LamR <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) (binder (\ d'' -> Quoter (\ d -> covar (toIndexed d d''))) . b) sumR1 = fmap SumR1 sumR2 = fmap SumR2 unitR = pure UnitR From 945a05fd67a56ab6f433dba6233550b502ff5fad Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 20:20:13 -0400 Subject: [PATCH 1006/1324] Replace QName with a non-empty list of Names. --- src/Facet/Elab.hs | 6 +++--- src/Facet/Graph.hs | 4 ++-- src/Facet/Name.hs | 14 +++----------- src/Facet/Notice/Elab.hs | 9 ++++++--- src/Facet/Parser.hs | 7 ++++--- src/Facet/Print.hs | 7 ++++--- 6 files changed, 22 insertions(+), 25 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 87e3b2660..1b6b1bd76 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -78,7 +78,7 @@ import Facet.Pattern import Facet.Quote import Facet.Semiring import Facet.Snoc -import Facet.Snoc.NonEmpty (toSnoc) +import Facet.Snoc.NonEmpty (NonEmpty(..), toSnoc) import Facet.Source (Source, slice) import Facet.Span (Span(..)) import Facet.Subst @@ -134,14 +134,14 @@ resolveQ :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Read resolveQ = resolveWith lookupD lookupInContext :: Has (Choose :+: Empty) sig m => QName -> Context -> m (LName Index, Either Kind (Quantity, Type)) -lookupInContext (m:.n) +lookupInContext (m:|>n) | m == Nil = lookupIndex n | otherwise = const empty -- FIXME: probably we should instead look up the effect op globally, then check for membership in the sig -- FIXME: return the index in the sig; it’s vital for evaluation of polymorphic effects when there are multiple such lookupInSig :: Has (Choose :+: Empty) sig m => QName -> Module -> Graph -> [Signature Type] -> m (RName :=: Type) -lookupInSig (m :. n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':.:_) _) -> do +lookupInSig (m :|> n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':.:_) _) -> do guard (m == Nil || m == toSnoc m') defs <- interfaceScope =<< lookupQ graph mod (toQ q) _ :=: d <- lookupScope n defs diff --git a/src/Facet/Graph.hs b/src/Facet/Graph.hs index a24bb2dd3..854876c43 100644 --- a/src/Facet/Graph.hs +++ b/src/Facet/Graph.hs @@ -29,7 +29,7 @@ import qualified Data.Set as Set import Facet.Module import Facet.Name import Facet.Snoc -import Facet.Snoc.NonEmpty (fromSnoc, toSnoc) +import Facet.Snoc.NonEmpty (NonEmpty(..), fromSnoc, toSnoc) import Facet.Syntax import Fresnel.At import Fresnel.Iso @@ -59,7 +59,7 @@ lookupM :: Has (Choose :+: Empty) sig m => MName -> Graph -> m (Maybe FilePath, lookupM n = maybe empty pure . Map.lookup n . getGraph lookupWith :: Has (Choose :+: Empty) sig m => (Name -> Module -> m res) -> Graph -> Module -> QName -> m res -lookupWith lookup graph mod@Module{ name } (m:.n) +lookupWith lookup graph mod@Module{ name } (m:|>n) = guard (m == toSnoc name || m == Nil) *> lookup n mod <|> guard (m == Nil) *> foldMapC (maybe empty (lookup n) . snd) (getGraph graph) <|> guard (m /= Nil) *> (lookupM (fromSnoc m) graph >>= maybe empty pure . snd >>= lookup n) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index fa23553da..51d2b3100 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -10,7 +10,7 @@ module Facet.Name , __ , MName , prettyMName -, QName(..) +, QName , RName(..) , (.:.) , toQ @@ -35,7 +35,6 @@ import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as T import Facet.Pretty (subscript) -import Facet.Snoc import Facet.Snoc.NonEmpty import qualified Prettyprinter as P import Silkscreen @@ -94,14 +93,7 @@ showsModuleName c m n p = showParen (p > 9) $ foldl' (.) id (intersperse (showCh -- | Qualified names, consisting of a module name and declaration name. -data QName = Snoc Name :. Name - deriving (Eq, Ord) - -instance Show QName where - showsPrec p (m :. n) = showsModuleName ":." m n p - -instance P.Pretty QName where - pretty (m :. n) = foldr' (surround dot . pretty) (pretty n) m +type QName = NonEmpty Name -- | Resolved names. @@ -120,7 +112,7 @@ m :.: n .:. n' = (m |> n) :.: n' -- | Weaken an 'RName' to a 'QName'. This is primarily used for performing lookups in the graph starting from an 'RName' where the stronger structure is not required. toQ :: RName -> QName -toQ (m :.: n) = toSnoc m :. n +toQ (m :.: n) = m |> n -- | Local names, consisting of a 'Level' or 'Index' to a pattern in an 'Env' or 'Context' and a 'Name' bound by said pattern. diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index b31b5250f..fe2600932 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -4,7 +4,7 @@ module Facet.Notice.Elab , rethrowElabWarnings ) where -import Data.Foldable (foldl') +import Data.Foldable (foldl', foldr') import Data.Semigroup (stimes) import qualified Facet.Carrier.Throw.Inject as L import qualified Facet.Carrier.Write.Inject as L @@ -21,6 +21,7 @@ import Facet.Pretty import Facet.Print as Print import Facet.Semiring (Few(..), one, zero) import Facet.Snoc +import Facet.Snoc.NonEmpty import Facet.Style import Facet.Subst (metas) import Facet.Syntax hiding (ann) @@ -62,8 +63,8 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) printErrReason :: Options Print -> Env.Env Print -> ErrReason -> Doc Style printErrReason opts ctx = group . \case - FreeVariable n -> fillSep [reflow "variable not in scope:", pretty n] - AmbiguousName n qs -> fillSep [reflow "ambiguous name", pretty n] <\> nest 2 (reflow "alternatives:" <\> unlines (map pretty qs)) + FreeVariable n -> fillSep [reflow "variable not in scope:", qname n] + AmbiguousName n qs -> fillSep [reflow "ambiguous name", qname n] <\> nest 2 (reflow "alternatives:" <\> unlines (map pretty qs)) CouldNotSynthesize -> reflow "could not synthesize a type; try a type annotation" ResourceMismatch n e a -> fillSep [reflow "uses of variable", pretty n, reflow "didn’t match requirements"] <> hardline <> pretty "expected:" <+> prettyQ e @@ -97,6 +98,8 @@ printErrReason opts ctx = group . \case in fillSep [ reflow "found hole", pretty n, colon, _T' ] Invariant s -> reflow s MissingInterface i -> reflow "could not find required interface" <+> getPrint (print opts ctx i) + where + qname (m:|>n) = foldr' (surround dot . pretty) (pretty n) m rethrowElabWarnings :: L.WriteC (Notice (Doc Style)) Warn m a -> m a diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index bd5bdadf7..320007ccd 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -36,6 +36,7 @@ import Facet.Kind import qualified Facet.Name as N import Facet.Parser.Table as Op import Facet.Snoc +import Facet.Snoc.NonEmpty import Facet.Span import qualified Facet.Surface.Module as S import qualified Facet.Surface.Term.Expr as S @@ -205,7 +206,7 @@ signature = brackets (commaSep delta) "signature" where delta = anned $ S.Interface <$> head <*> (fromList <$> many type') head = mkHead <$> token (runUnspaced (sepByNonEmpty comp dot)) - mkHead cs = fromList (NE.init cs) N.:. NE.last cs + mkHead cs = fromList (NE.init cs) |> NE.last cs comp = ident tnameStyle @@ -238,7 +239,7 @@ clause = S.Clause <$> try (compPattern <* arrow) <*> expr "clause" evar :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Expr) evar = choice - [ token (anned (runUnspaced (S.Var <$> try ((N.:.) . fromList <$> many (comp <* dot) <*> ename)))) + [ token (anned (runUnspaced (S.Var <$> try ((|>) . fromList <$> many (comp <* dot) <*> ename)))) -- FIXME: would be better to commit once we see a placeholder, but try doesn’t really let us express that , try (anned (parens (S.Var <$> qname (N.O <$> oname)))) ] @@ -309,7 +310,7 @@ mname = token (runUnspaced (fromList <$> sepBy1 comp dot)) comp = ident tnameStyle qname :: (Has Parser sig p, TokenParsing p) => p N.Name -> p N.QName -qname name = token (runUnspaced (try (fmap N.toQ . (N.:.:) <$> mname <*> Unspaced name) <|> (Nil N.:.) <$> Unspaced name)) "name" +qname name = token (runUnspaced (try (fmap N.toQ . (N.:.:) <$> mname <*> Unspaced name) <|> (Nil :|>) <$> Unspaced name)) "name" reserved :: HashSet.HashSet String diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 5adadd10e..6e631d9f6 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -40,6 +40,7 @@ import Facet.Print.Options import Facet.Quote import Facet.Semiring (one, zero) import Facet.Snoc +import Facet.Snoc.NonEmpty (NonEmpty(..)) import Facet.Style import Facet.Syntax hiding (Ann(..)) import qualified Facet.Term.Expr as C @@ -123,7 +124,7 @@ intro n = name lower n . getLevel tintro n = name upper n . getLevel qvar :: (P.Level p ~ Precedence, PrecedencePrinter p) => QName -> p -qvar (_ :. n) = setPrec Var (pretty n) +qvar (_ :|> n) = setPrec Var (pretty n) lname :: LName Level -> Print lname (LName d n) = intro n d @@ -218,11 +219,11 @@ instance Printable a => Printable (Pattern a) where instance Printable C.Module where print opts env (C.Module mname is _ ds) = module_ mname - (qvar (fromList [U (T.pack "Kernel")]:.U (T.pack "Module"))) + (qvar (fromList [U (T.pack "Kernel")]:|>U (T.pack "Module"))) (map (\ (C.Import n) -> import' n) is) (map (def . fmap defBody) (C.scopeToList ds)) where - def (n :=: d) = ann (qvar (Nil:.n) ::: d) + def (n :=: d) = ann (qvar (Nil:|>n) ::: d) defBody = \case C.DTerm Nothing _T -> print opts env _T C.DTerm (Just b) _T -> defn (print opts env _T :=: print opts env b) From c62af2e9d74ba00666e43910541da65f15ec75f3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 20:24:00 -0400 Subject: [PATCH 1007/1324] Rename prettyMName to prettyQName. --- src/Facet/Driver.hs | 8 ++++---- src/Facet/Name.hs | 6 +++--- src/Facet/Notice/Elab.hs | 9 +++------ src/Facet/Print.hs | 4 ++-- src/Facet/REPL.hs | 4 ++-- 5 files changed, 14 insertions(+), 17 deletions(-) diff --git a/src/Facet/Driver.hs b/src/Facet/Driver.hs index f58c42c09..9fcadef7f 100644 --- a/src/Facet/Driver.hs +++ b/src/Facet/Driver.hs @@ -109,11 +109,11 @@ reloadModules = do let loaded = traverse (\ name -> graph ^. at name >>= snd) h case loaded of Just loaded -> (Just <$> do - outputDocLn $ annotate Progress (brackets (ratio (i :: Int) nModules)) <+> nest 2 (group (fillSep [ pretty "Loading", prettyMName name ])) + outputDocLn $ annotate Progress (brackets (ratio (i :: Int) nModules)) <+> nest 2 (group (fillSep [ pretty "Loading", prettyQName name ])) storeModule name (path (reference src)) =<< loadModule graph loaded) `catchError` \ err -> Nothing <$ outputDocLn (prettyNotice err) Nothing -> do - outputDocLn $ annotate Progress (brackets (ratio i nModules)) <+> nest 2 (group (fillSep [ pretty "Skipping", prettyMName name ])) + outputDocLn $ annotate Progress (brackets (ratio i nModules)) <+> nest 2 (group (fillSep [ pretty "Skipping", prettyQName name ])) pure Nothing let nSuccess = length (catMaybes results) status @@ -162,7 +162,7 @@ resolveName searchPaths name = do path <- liftIO $ findFile searchPaths namePath case path of Just path -> pure path - Nothing -> throwError @(Notice.Notice (Doc Style)) $ Notice.Notice (Just Notice.Error) [] (fillSep [pretty "module", squotes (prettyMName name), reflow "could not be found."]) $ case searchPaths of + Nothing -> throwError @(Notice.Notice (Doc Style)) $ Notice.Notice (Just Notice.Error) [] (fillSep [pretty "module", squotes (prettyQName name), reflow "could not be found."]) $ case searchPaths of [] -> [] _ -> [ nest 2 (reflow "search paths:" <\> concatWith (<\>) (map pretty searchPaths)) ] where @@ -183,4 +183,4 @@ ioErrorToNotice refs err = Notice.Notice (Just Notice.Error) refs (group (reflow rethrowGraphErrors :: Applicative m => [Source] -> I.ThrowC (Notice.Notice (Doc Style)) GraphErr m a -> m a rethrowGraphErrors refs = I.runThrow (pure . formatGraphErr) where - formatGraphErr (CyclicImport path) = Notice.Notice (Just Notice.Error) refs (reflow "cyclic import") (map prettyMName (toList path)) + formatGraphErr (CyclicImport path) = Notice.Notice (Just Notice.Error) refs (reflow "cyclic import") (map prettyQName (toList path)) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 51d2b3100..65c58917b 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -9,7 +9,7 @@ module Facet.Name , Meta(..) , __ , MName -, prettyMName +, prettyQName , QName , RName(..) , (.:.) @@ -84,8 +84,8 @@ __ = U T.empty type MName = NonEmpty Name -prettyMName :: Printer a => MName -> a -prettyMName (ns:|>n) = foldr' (surround dot . pretty) (pretty n) ns +prettyQName :: Printer a => MName -> a +prettyQName (ns:|>n) = foldr' (surround dot . pretty) (pretty n) ns showsModuleName :: (Foldable t, Show a, Show b) => String -> t a -> b -> Int -> ShowS showsModuleName c m n p = showParen (p > 9) $ foldl' (.) id (intersperse (showChar '.') (shows <$> toList m)) . showString c . showsPrec 10 n diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index fe2600932..293a70333 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -4,7 +4,7 @@ module Facet.Notice.Elab , rethrowElabWarnings ) where -import Data.Foldable (foldl', foldr') +import Data.Foldable (foldl') import Data.Semigroup (stimes) import qualified Facet.Carrier.Throw.Inject as L import qualified Facet.Carrier.Write.Inject as L @@ -21,7 +21,6 @@ import Facet.Pretty import Facet.Print as Print import Facet.Semiring (Few(..), one, zero) import Facet.Snoc -import Facet.Snoc.NonEmpty import Facet.Style import Facet.Subst (metas) import Facet.Syntax hiding (ann) @@ -63,8 +62,8 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) printErrReason :: Options Print -> Env.Env Print -> ErrReason -> Doc Style printErrReason opts ctx = group . \case - FreeVariable n -> fillSep [reflow "variable not in scope:", qname n] - AmbiguousName n qs -> fillSep [reflow "ambiguous name", qname n] <\> nest 2 (reflow "alternatives:" <\> unlines (map pretty qs)) + FreeVariable n -> fillSep [reflow "variable not in scope:", prettyQName n] + AmbiguousName n qs -> fillSep [reflow "ambiguous name", prettyQName n] <\> nest 2 (reflow "alternatives:" <\> unlines (map pretty qs)) CouldNotSynthesize -> reflow "could not synthesize a type; try a type annotation" ResourceMismatch n e a -> fillSep [reflow "uses of variable", pretty n, reflow "didn’t match requirements"] <> hardline <> pretty "expected:" <+> prettyQ e @@ -98,8 +97,6 @@ printErrReason opts ctx = group . \case in fillSep [ reflow "found hole", pretty n, colon, _T' ] Invariant s -> reflow s MissingInterface i -> reflow "could not find required interface" <+> getPrint (print opts ctx i) - where - qname (m:|>n) = foldr' (surround dot . pretty) (pretty n) m rethrowElabWarnings :: L.WriteC (Notice (Doc Style)) Warn m a -> m a diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 6e631d9f6..aee2694bd 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -232,8 +232,8 @@ instance Printable C.Module where C.SInterface os -> annotate Keyword (pretty "interface") <+> scope (print opts env) os C.SModule ds -> block (concatWith (surround hardline) (map ((hardline <>) . def . fmap defBody) (C.scopeToList ds))) scope with = block . group . concatWith (surround (hardline <> comma <> space)) . map (group . def . fmap with) . C.scopeToList - import' n = pretty "import" <+> braces (setPrec Var (prettyMName n)) - module_ n t is ds = ann (setPrec Var (prettyMName n) ::: t) concatWith (surround hardline) (is ++ map (hardline <>) ds) + import' n = pretty "import" <+> braces (setPrec Var (prettyQName n)) + module_ n t is ds = ann (setPrec Var (prettyQName n) ::: t) concatWith (surround hardline) (is ++ map (hardline <>) ds) defn (a :=: b) = group a <> hardline <> group b diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index f13314137..f19cf9061 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -173,9 +173,9 @@ showPaths = Action $ do unless (null searchPaths) $ outputDocLn $ nest 2 $ pretty ("search paths:" :: Text) <\> unlines (map pretty searchPaths) -showModules = Action $ uses (target_.modules_) (unlines . map (\ (name, (path, _)) -> prettyMName name <> maybe mempty ((space <>) . S.parens . pretty) path) . Map.toList . getGraph) >>= outputDocLn +showModules = Action $ uses (target_.modules_) (unlines . map (\ (name, (path, _)) -> prettyQName name <> maybe mempty ((space <>) . S.parens . pretty) path) . Map.toList . getGraph) >>= outputDocLn -showTargets = Action $ uses (target_.targets_) (unlines . map prettyMName . toList) >>= outputDocLn +showTargets = Action $ uses (target_.targets_) (unlines . map prettyQName . toList) >>= outputDocLn addPath, removePath :: FilePath -> Action From 508439ca381a6fa4bdda5825e700794798b8a1ae Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 20:25:39 -0400 Subject: [PATCH 1008/1324] Replace MName with QName. --- src/Facet/Driver.hs | 14 +++++++------- src/Facet/Graph.hs | 16 ++++++++-------- src/Facet/Lexer.hs | 2 +- src/Facet/Module.hs | 6 +++--- src/Facet/Name.hs | 7 ++----- src/Facet/Parser.hs | 10 +++++----- src/Facet/REPL.hs | 4 ++-- src/Facet/Surface/Module.hs | 4 ++-- 8 files changed, 30 insertions(+), 33 deletions(-) diff --git a/src/Facet/Driver.hs b/src/Facet/Driver.hs index 9fcadef7f..8a78456a2 100644 --- a/src/Facet/Driver.hs +++ b/src/Facet/Driver.hs @@ -62,14 +62,14 @@ import Text.Parser.Token (whiteSpace) data Target = Target { modules :: Graph - , targets :: Set.Set MName + , targets :: Set.Set QName , searchPaths :: Set.Set FilePath } modules_ :: Lens' Target Graph modules_ = lens modules (\ r modules -> r{ modules }) -targets_ :: Lens' Target (Set.Set MName) +targets_ :: Lens' Target (Set.Set QName) targets_ = lens targets (\ r targets -> r{ targets }) searchPaths_ :: Lens' Target (Set.Set FilePath) @@ -124,7 +124,7 @@ reloadModules = do ratio n d = pretty n <+> pretty "of" <+> pretty d data ModuleHeader a = ModuleHeader - { moduleName :: MName + { moduleName :: QName , source :: Source , imports :: [a] } @@ -133,10 +133,10 @@ data ModuleHeader a = ModuleHeader imports_ :: Lens (ModuleHeader a) (ModuleHeader b) [a] [b] imports_ = lens imports (\ h imports -> h{ imports }) -headerNode :: ModuleHeader MName -> Node (ModuleHeader MName) +headerNode :: ModuleHeader QName -> Node (ModuleHeader QName) headerNode h@(ModuleHeader n _ imports) = Node n imports h -loadModuleHeader :: (Has (Output :+: Throw (Notice.Notice (Doc Style))) sig m, MonadIO m) => [FilePath] -> Either FilePath MName -> m (ModuleHeader MName) +loadModuleHeader :: (Has (Output :+: Throw (Notice.Notice (Doc Style))) sig m, MonadIO m) => [FilePath] -> Either FilePath QName -> m (ModuleHeader QName) loadModuleHeader searchPaths target = do path <- case target of Left path -> pure path @@ -153,10 +153,10 @@ loadModule graph (ModuleHeader _ src imports) = do opts <- get rethrowElabWarnings . rethrowElabErrors opts . runReader graph . runReader src $ Elab.elabModule m -storeModule :: Has (State Target) sig m => MName -> Maybe FilePath -> Module -> m () +storeModule :: Has (State Target) sig m => QName -> Maybe FilePath -> Module -> m () storeModule name path m = modules_ .at name .= Just (path, Just m) -resolveName :: (Has (Throw (Notice.Notice (Doc Style))) sig m, MonadIO m) => [FilePath] -> MName -> m FilePath +resolveName :: (Has (Throw (Notice.Notice (Doc Style))) sig m, MonadIO m) => [FilePath] -> QName -> m FilePath resolveName searchPaths name = do let namePath = toPath name FP.<.> ".facet" path <- liftIO $ findFile searchPaths namePath diff --git a/src/Facet/Graph.hs b/src/Facet/Graph.hs index 854876c43..e2525c851 100644 --- a/src/Facet/Graph.hs +++ b/src/Facet/Graph.hs @@ -35,11 +35,11 @@ import Fresnel.At import Fresnel.Iso import Fresnel.Ixed -newtype Graph = Graph { getGraph :: Map.Map MName (Maybe FilePath, Maybe Module) } +newtype Graph = Graph { getGraph :: Map.Map QName (Maybe FilePath, Maybe Module) } deriving (Monoid, Semigroup) instance Ixed Graph where - type Index Graph = MName + type Index Graph = QName type IxValue Graph = (Maybe FilePath, Maybe Module) ix = ixAt @@ -49,13 +49,13 @@ instance At Graph where singleton :: Maybe FilePath -> Module -> Graph singleton p m@Module{ name } = Graph (Map.singleton name (p, Just m)) -restrict :: Graph -> Set.Set MName -> Graph +restrict :: Graph -> Set.Set QName -> Graph restrict (Graph g) s = Graph $ Map.restrictKeys g s insert :: Maybe FilePath -> Module -> Graph -> Graph insert p m@Module{ name } = Graph . Map.insert name (p, Just m) . getGraph -lookupM :: Has (Choose :+: Empty) sig m => MName -> Graph -> m (Maybe FilePath, Maybe Module) +lookupM :: Has (Choose :+: Empty) sig m => QName -> Graph -> m (Maybe FilePath, Maybe Module) lookupM n = maybe empty pure . Map.lookup n . getGraph lookupWith :: Has (Choose :+: Empty) sig m => (Name -> Module -> m res) -> Graph -> Module -> QName -> m res @@ -69,13 +69,13 @@ lookupQ = lookupWith lookupD -- FIXME: enrich this with source references for each -newtype GraphErr = CyclicImport (Snoc MName) +newtype GraphErr = CyclicImport (Snoc QName) -data Node a = Node MName [MName] a +data Node a = Node QName [QName] a -loadOrder :: Has (Throw GraphErr) sig m => (MName -> m (Node a)) -> [Node a] -> m [a] +loadOrder :: Has (Throw GraphErr) sig m => (QName -> m (Node a)) -> [Node a] -> m [a] loadOrder lookup modules = do - modules <- execWriter . evalState (Set.empty @MName) . runReader (Nil @MName) + modules <- execWriter . evalState (Set.empty @QName) . runReader (Nil @QName) $ for_ modules visit pure $ appEndo modules [] where diff --git a/src/Facet/Lexer.hs b/src/Facet/Lexer.hs index dd4b7de30..6571c9711 100644 --- a/src/Facet/Lexer.hs +++ b/src/Facet/Lexer.hs @@ -37,7 +37,7 @@ data TokenKind | RAngle | OpIdent String | QIdent QName - | MIdent MName + | MIdent QName | EIdent Name | TIdent Name | HIdent Name diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 5b381473f..5f4bbb247 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -53,7 +53,7 @@ import Fresnel.Review (review) -- FIXME: model operators and their associativities for parsing. data Module = Module - { name :: MName + { name :: QName -- FIXME: record source references to imports to contextualize ambiguous name errors. , imports :: [Import] -- FIXME: record source references to operators to contextualize parse errors. @@ -62,7 +62,7 @@ data Module = Module , scope :: Scope Def } -name_ :: Lens' Module MName +name_ :: Lens' Module QName name_ = lens (\ Module{ name } -> name) (\ Module{ imports, operators, scope } name -> Module{ name, imports, operators, scope }) imports_ :: Lens' Module [Import] @@ -120,7 +120,7 @@ lookupScope :: Has Empty sig m => Name -> Scope a -> m (Name :=: a) lookupScope n (Scope ds) = maybe empty (pure . (n :=:)) (lookup n (map (\ (n :=: a) -> (n, a)) ds)) -newtype Import = Import { name :: MName } +newtype Import = Import { name :: QName } data Submodule diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 65c58917b..c89acff90 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -8,7 +8,6 @@ module Facet.Name , Used(..) , Meta(..) , __ -, MName , prettyQName , QName , RName(..) @@ -82,9 +81,7 @@ __ :: Name __ = U T.empty -type MName = NonEmpty Name - -prettyQName :: Printer a => MName -> a +prettyQName :: Printer a => QName -> a prettyQName (ns:|>n) = foldr' (surround dot . pretty) (pretty n) ns showsModuleName :: (Foldable t, Show a, Show b) => String -> t a -> b -> Int -> ShowS @@ -97,7 +94,7 @@ type QName = NonEmpty Name -- | Resolved names. -data RName = MName :.: Name +data RName = QName :.: Name deriving (Eq, Ord) instance Show RName where diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index 320007ccd..c5adc5c34 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -60,7 +60,7 @@ whole :: TokenParsing p => p a -> p a whole p = whiteSpace *> p <* eof -makeOperator :: (N.MName, N.Op, N.Assoc) -> Operator (S.Ann S.Expr) +makeOperator :: (N.QName, N.Op, N.Assoc) -> Operator (S.Ann S.Expr) makeOperator (name, op, assoc) = (op, assoc, nary (N.toQ (name N.:.: N.O op))) where nary name es = foldl' (S.annBinary S.App) (S.Ann (S.ann (head es)) Nil (S.Var name)) es @@ -75,7 +75,7 @@ module' = anned $ do ops <- get @[Operator (S.Ann S.Expr)] pure $ S.Module name imports (map (\ (op, assoc, _) -> (op, assoc)) ops) decls -moduleHeader :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (N.MName, [S.Ann S.Import]) +moduleHeader :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (N.QName, [S.Ann S.Import]) moduleHeader = (,) <$ reserve dnameStyle "module" <*> mname <* colon <* symbol "Module" <*> many import' @@ -84,7 +84,7 @@ moduleHeader = (,) <$ reserve dnameStyle "module" <*> mname <* colon <* symbol " import' :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Import) import' = anned $ S.Import <$ reserve dnameStyle "import" <*> mname -decl :: (Has Parser sig p, Has (Reader N.MName) sig p, Has (State [Operator (S.Ann S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann (N.Name, S.Ann S.Def)) +decl :: (Has Parser sig p, Has (Reader N.QName) sig p, Has (State [Operator (S.Ann S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann (N.Name, S.Ann S.Def)) decl = choice [ termDecl , dataDecl @@ -94,7 +94,7 @@ decl = choice -- FIXME: operators aren’t available until after their declarations have been parsed. -- FIXME: parse operator declarations in datatypes. -- FIXME: parse operator declarations in interfaces. -termDecl :: (Has Parser sig p, Has (Reader N.MName) sig p, Has (State [Operator (S.Ann S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann (N.Name, S.Ann S.Def)) +termDecl :: (Has Parser sig p, Has (Reader N.QName) sig p, Has (State [Operator (S.Ann S.Expr)]) sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann (N.Name, S.Ann S.Def)) termDecl = anned $ do name <- dename case name of @@ -304,7 +304,7 @@ tname = ident tnameStyle dename :: (Monad p, TokenParsing p) => p N.Name dename = N.U <$> ident dnameStyle <|> N.O <$> oname -mname :: (Monad p, TokenParsing p) => p N.MName +mname :: (Monad p, TokenParsing p) => p N.QName mname = token (runUnspaced (fromList <$> sepBy1 comp dot)) where comp = ident tnameStyle diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index f19cf9061..aab5961df 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -185,7 +185,7 @@ addPath path = Action $ target_.searchPaths_ %= Set.insert path removePath path = Action $ target_.searchPaths_ %= Set.delete path -addTarget, removeTarget :: [MName] -> Action +addTarget, removeTarget :: [QName] -> Action addTarget targets = Action $ do target_.targets_ %= Set.union (Set.fromList targets) @@ -243,7 +243,7 @@ prompt = do p <- liftIO $ fn line fmap (sourceFromString Nothing line) <$> getInputLine p -runElab :: Has (State (Options Print) :+: State REPL) sig m => I.WriteC (Notice.Notice (Doc Style)) Elab.Warn (I.ThrowC (Notice.Notice (Doc Style)) Elab.Err (ReaderC MName (ReaderC Module (ReaderC Graph m)))) a -> m a +runElab :: Has (State (Options Print) :+: State REPL) sig m => I.WriteC (Notice.Notice (Doc Style)) Elab.Warn (I.ThrowC (Notice.Notice (Doc Style)) Elab.Err (ReaderC QName (ReaderC Module (ReaderC Graph m)))) a -> m a runElab m = do graph <- use (target_.modules_) localDefs <- use localDefs_ diff --git a/src/Facet/Surface/Module.hs b/src/Facet/Surface/Module.hs index ca9785494..8068cc3dc 100644 --- a/src/Facet/Surface/Module.hs +++ b/src/Facet/Surface/Module.hs @@ -25,7 +25,7 @@ data Def -- Modules data Module = Module - { name :: MName + { name :: QName , imports :: [Ann Import] -- FIXME: store source references for operators’ definitions, for error reporting , operators :: [(Op, Assoc)] @@ -34,5 +34,5 @@ data Module = Module deriving (Eq, Show) -newtype Import = Import { name :: MName } +newtype Import = Import { name :: QName } deriving (Eq, Show) From 0aeb8f7def1c873a197e01e3b87c53fa73ff25d9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 20:25:54 -0400 Subject: [PATCH 1009/1324] Rename showsModuleName to showsQName. --- src/Facet/Name.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index c89acff90..c67ffd204 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -84,8 +84,8 @@ __ = U T.empty prettyQName :: Printer a => QName -> a prettyQName (ns:|>n) = foldr' (surround dot . pretty) (pretty n) ns -showsModuleName :: (Foldable t, Show a, Show b) => String -> t a -> b -> Int -> ShowS -showsModuleName c m n p = showParen (p > 9) $ foldl' (.) id (intersperse (showChar '.') (shows <$> toList m)) . showString c . showsPrec 10 n +showsQName :: (Foldable t, Show a, Show b) => String -> t a -> b -> Int -> ShowS +showsQName c m n p = showParen (p > 9) $ foldl' (.) id (intersperse (showChar '.') (shows <$> toList m)) . showString c . showsPrec 10 n @@ -98,7 +98,7 @@ data RName = QName :.: Name deriving (Eq, Ord) instance Show RName where - showsPrec p (m :.: n) = showsModuleName ":.:" m n p + showsPrec p (m :.: n) = showsQName ":.:" m n p instance P.Pretty RName where pretty (m :.: n) = foldr' (surround dot . pretty) (pretty n) m From c28d22651d02c99ab3d6ebcc6045442ee3a7c7a6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 20:26:16 -0400 Subject: [PATCH 1010/1324] Move QName up. --- src/Facet/Name.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index c67ffd204..48b11d7f0 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -8,8 +8,8 @@ module Facet.Name , Used(..) , Meta(..) , __ -, prettyQName , QName +, prettyQName , RName(..) , (.:.) , toQ @@ -81,6 +81,9 @@ __ :: Name __ = U T.empty +-- | Qualified names, consisting of a module name and declaration name. +type QName = NonEmpty Name + prettyQName :: Printer a => QName -> a prettyQName (ns:|>n) = foldr' (surround dot . pretty) (pretty n) ns @@ -88,11 +91,6 @@ showsQName :: (Foldable t, Show a, Show b) => String -> t a -> b -> Int -> ShowS showsQName c m n p = showParen (p > 9) $ foldl' (.) id (intersperse (showChar '.') (shows <$> toList m)) . showString c . showsPrec 10 n - --- | Qualified names, consisting of a module name and declaration name. -type QName = NonEmpty Name - - -- | Resolved names. data RName = QName :.: Name deriving (Eq, Ord) From 0defd8304de1a5731b6dca63abf07ba553f8f885 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 20:29:40 -0400 Subject: [PATCH 1011/1324] :fire: T. --- src/Facet/Syntax.hs | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index ef94b55ae..00a61e70b 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE UndecidableInstances #-} module Facet.Syntax ( -- * Term containers @@ -22,8 +20,6 @@ module Facet.Syntax -- * Assertion data , Exp(..) , Act(..) - -- * Type-safe constructors -, T(..) -- * Natural transformations , type (~>) -- * Annotations @@ -41,7 +37,6 @@ import Data.Bifunctor import Data.Bitraversable import Data.Function (on) import Data.Functor.Classes -import Data.Kind (Type) import Data.Text (Text) import Facet.Name import Facet.Snoc @@ -191,13 +186,6 @@ newtype Act a = Act { getAct :: a } deriving (Functor) --- Type-safe constructors - -type T :: Type -> forall k . k -> Type - -newtype T a b = T { getT :: a } - - -- Natural transformations type i ~> j = forall x . i x -> j x From f5d10d052cdad38757733283b0515e41ce86dd6e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 20:32:12 -0400 Subject: [PATCH 1012/1324] Rename U to T. --- src/Facet/Driver.hs | 4 ++-- src/Facet/Elab/Term.hs | 4 ++-- src/Facet/Eval.hs | 2 +- src/Facet/Lexer.hs | 8 ++++---- src/Facet/Name.hs | 8 ++++---- src/Facet/Parser.hs | 2 +- src/Facet/Polarized.hs | 2 +- src/Facet/Print.hs | 2 +- src/Facet/REPL.hs | 2 +- test/Facet/Core/Type/Test.hs | 2 +- 10 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/Facet/Driver.hs b/src/Facet/Driver.hs index 8a78456a2..7ffc70c62 100644 --- a/src/Facet/Driver.hs +++ b/src/Facet/Driver.hs @@ -87,7 +87,7 @@ kernel :: Module kernel = Module kernelName [] [] $ Scope mempty -- FIXME: include things like Type and Interface where - kernelName = fromList [U (TS.pack "Kernel")] + kernelName = fromList [T (TS.pack "Kernel")] -- Module loading @@ -168,7 +168,7 @@ resolveName searchPaths name = do where toPath components = foldr1 (FP.) (unpack <$> components) unpack = \case - U n -> TS.unpack n + T n -> TS.unpack n O o -> formatOp (\ a b -> a <> " " <> b) TS.unpack "_" o diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index ec217663e..449a9bb83 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -219,7 +219,7 @@ varP :: Name -> Bind m (Pattern (Name :==> Type)) varP n = Bind $ \ _A k -> k (PVar (n :==> wrap _A)) where wrap = \case - T.Comp sig _A -> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (T.Comp sig _A) + T.Comp sig _A -> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: T "Unit")) Nil) (T.Comp sig _A) _T -> _T conP :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => QName -> [Bind m (Pattern (Name :==> Type))] -> Bind m (Pattern (Name :==> Type)) @@ -241,7 +241,7 @@ fieldsP = foldr cons nil allP :: Has (Throw ErrReason :+: Write Warn) sig m => Name -> Bind m (Pattern (Name :==> Type)) allP n = Bind $ \ _A k -> do (sig, _T) <- assertComp _A - k (PVar (n :==> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: U "Unit")) Nil) (T.Comp sig _T))) + k (PVar (n :==> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: T "Unit")) Nil) (T.Comp sig _T))) -- Expression elaboration diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 75e9541bb..77d054404 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -142,7 +142,7 @@ instance Monad m => Quote (Value m) (m Term) where VComp p b -> pure . pure $ Comp p b unit :: Value m -unit = VCon (NE.FromList ["Data", "Unit"] :.: U "unit") [] +unit = VCon (NE.FromList ["Data", "Unit"] :.: T "unit") [] -- Elimination diff --git a/src/Facet/Lexer.hs b/src/Facet/Lexer.hs index 6571c9711..057032bc3 100644 --- a/src/Facet/Lexer.hs +++ b/src/Facet/Lexer.hs @@ -64,11 +64,11 @@ kind_ = choice , RBracket <$ char ']' "]" , LAngle <$ char '<' "<" , RAngle <$ char '>' ">" - , QIdent <$> (fmap toQ . (:.:) <$> mname <* dot <*> choice [ U <$> ename, tname ]) + , QIdent <$> (fmap toQ . (:.:) <$> mname <* dot <*> choice [ T <$> ename, tname ]) , MIdent <$> mname - , EIdent . U <$> ename + , EIdent . T <$> ename , TIdent <$> tname - , HIdent . U <$> ident (char '?') nameChar "hole name" + , HIdent . T <$> ident (char '?') nameChar "hole name" ] where mname = fromList <$> sepBy1 tcomp dot "module name" @@ -77,7 +77,7 @@ kind_ = choice dot = char '.' "." ecomp = ident (choice [ lower, char '_' ]) nameChar tcomp :: CharParsing p => p Name - tcomp = U <$> ident (choice [ upper, char '_' ]) nameChar + tcomp = T <$> ident (choice [ upper, char '_' ]) nameChar ident :: CharParsing p => p Char -> p Char -> p Text ident i r = fmap pack . (:) <$> i <*> many r diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 48b11d7f0..ba48e7f0a 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -78,7 +78,7 @@ newtype Meta = Meta { getMeta :: Int } __ :: Name -__ = U T.empty +__ = T T.empty -- | Qualified names, consisting of a module name and declaration name. @@ -124,16 +124,16 @@ instance DeBruijn lv ix => DeBruijn (LName lv) (LName ix) where -- | Declaration names; a choice of textual or operator names. data Name - = U Text + = T Text | O Op deriving (Eq, Ord, Show) instance IsString Name where - fromString = U . fromString + fromString = T . fromString instance P.Pretty Name where pretty = \case - U n -> P.pretty n + T n -> P.pretty n O o -> P.pretty o diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index c5adc5c34..86d1ea064 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -302,7 +302,7 @@ tname :: (Monad p, TokenParsing p) => p N.Name tname = ident tnameStyle dename :: (Monad p, TokenParsing p) => p N.Name -dename = N.U <$> ident dnameStyle <|> N.O <$> oname +dename = N.T <$> ident dnameStyle <|> N.O <$> oname mname :: (Monad p, TokenParsing p) => p N.QName mname = token (runUnspaced (fromList <$> sepBy1 comp dot)) diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index c6aaf8d55..8f7f74c76 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -23,7 +23,7 @@ import Control.Applicative (liftA2) import Control.Carrier.Reader import Data.Foldable (foldl') import Data.Function (on) -import Facet.Name +import Facet.Name hiding (T) import Facet.Quote import Facet.Snoc diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index aee2694bd..d6eba8cd1 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -219,7 +219,7 @@ instance Printable a => Printable (Pattern a) where instance Printable C.Module where print opts env (C.Module mname is _ ds) = module_ mname - (qvar (fromList [U (T.pack "Kernel")]:|>U (T.pack "Module"))) + (qvar (fromList [T (T.pack "Kernel")]:|>T (T.pack "Module"))) (map (\ (C.Import n) -> import' n) is) (map (def . fmap defBody) (C.scopeToList ds)) where diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index aab5961df..ce8bc7113 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -203,7 +203,7 @@ showType e = Action $ do outputDocLn (getPrint (ann (Print.print opts mempty e ::: Print.print opts mempty _T))) showEval e = Action $ do - e' :==> _T <- runElab $ Elab.elabSynthTerm $ Elab.runErr $ locally Elab.sig_ (I.singleton (I.Interface (["Effect", "Console"]:.:U "Output") Nil) :) $ Elab.synthExpr e + e' :==> _T <- runElab $ Elab.elabSynthTerm $ Elab.runErr $ locally Elab.sig_ (I.singleton (I.Interface (["Effect", "Console"]:.:T "Output") Nil) :) $ Elab.synthExpr e e'' <- runElab $ runEvalMain e' opts <- get outputDocLn (getPrint (ann (Print.print opts mempty e'' ::: Print.print opts mempty _T))) diff --git a/test/Facet/Core/Type/Test.hs b/test/Facet/Core/Type/Test.hs index 689470336..958680f86 100644 --- a/test/Facet/Core/Type/Test.hs +++ b/test/Facet/Core/Type/Test.hs @@ -18,5 +18,5 @@ tests :: IO Bool tests = checkParallel $$(discover) prop_quotation_inverse = property $ do - let init = ForAll (U "A") KType (Arrow (Just (U "x")) Many (Var (Free (Right (LName 0 (U "A"))))) (Comp mempty (Var (Free (Right (LName 0 (U "A"))))))) + let init = ForAll (T "A") KType (Arrow (Just (T "x")) Many (Var (Free (Right (LName 0 (T "A"))))) (Comp mempty (Var (Free (Right (LName 0 (T "A"))))))) runQuoter 0 (quote (eval mempty empty init)) === init From 387661f765bafc67ca8e8d8da5a8d029d5cacc5b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 20:36:52 -0400 Subject: [PATCH 1013/1324] Simplify the lexer. --- src/Facet/Lexer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Lexer.hs b/src/Facet/Lexer.hs index 057032bc3..547361dfc 100644 --- a/src/Facet/Lexer.hs +++ b/src/Facet/Lexer.hs @@ -64,7 +64,7 @@ kind_ = choice , RBracket <$ char ']' "]" , LAngle <$ char '<' "<" , RAngle <$ char '>' ">" - , QIdent <$> (fmap toQ . (:.:) <$> mname <* dot <*> choice [ T <$> ename, tname ]) + , QIdent <$> mname , MIdent <$> mname , EIdent . T <$> ename , TIdent <$> tname From 2c9bf0e2399bbecbf4b781e6db89bf68f3101ec2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 20:38:15 -0400 Subject: [PATCH 1014/1324] Simplify the parser. --- src/Facet/Parser.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index 86d1ea064..6e62b62c0 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -61,7 +61,7 @@ whole p = whiteSpace *> p <* eof makeOperator :: (N.QName, N.Op, N.Assoc) -> Operator (S.Ann S.Expr) -makeOperator (name, op, assoc) = (op, assoc, nary (N.toQ (name N.:.: N.O op))) +makeOperator (name, op, assoc) = (op, assoc, nary (name |> N.O op)) where nary name es = foldl' (S.annBinary S.App) (S.Ann (S.ann (head es)) Nil (S.Var name)) es @@ -310,7 +310,7 @@ mname = token (runUnspaced (fromList <$> sepBy1 comp dot)) comp = ident tnameStyle qname :: (Has Parser sig p, TokenParsing p) => p N.Name -> p N.QName -qname name = token (runUnspaced (try (fmap N.toQ . (N.:.:) <$> mname <*> Unspaced name) <|> (Nil :|>) <$> Unspaced name)) "name" +qname name = token (runUnspaced (try ((|>) <$> mname <*> Unspaced name) <|> (Nil :|>) <$> Unspaced name)) "name" reserved :: HashSet.HashSet String From 85c5c4668a295f55e9fef2590e73a6dc11a8c30b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 20:49:34 -0400 Subject: [PATCH 1015/1324] Replace RName with QName. --- src/Facet/Elab.hs | 26 +++++++++--------- src/Facet/Elab/Term.hs | 14 +++++----- src/Facet/Elab/Type.hs | 2 +- src/Facet/Eval.hs | 56 +++++++++++++++++++------------------- src/Facet/Graph.hs | 2 +- src/Facet/Interface.hs | 2 +- src/Facet/Module.hs | 13 +++++---- src/Facet/Name.hs | 28 +------------------ src/Facet/Notice/Elab.hs | 2 +- src/Facet/Pattern.hs | 6 ++-- src/Facet/Print.hs | 18 ++++++------ src/Facet/Print/Options.hs | 13 +++++---- src/Facet/REPL.hs | 3 +- src/Facet/Sequent/Print.hs | 2 +- src/Facet/Syntax.hs | 2 +- src/Facet/Term/Expr.hs | 6 ++-- src/Facet/Term/Norm.hs | 6 ++-- src/Facet/Type/Norm.hs | 2 +- 18 files changed, 90 insertions(+), 113 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 1b6b1bd76..688d042d2 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -78,7 +78,7 @@ import Facet.Pattern import Facet.Quote import Facet.Semiring import Facet.Snoc -import Facet.Snoc.NonEmpty (NonEmpty(..), toSnoc) +import Facet.Snoc.NonEmpty (NonEmpty(..)) import Facet.Source (Source, slice) import Facet.Span (Span(..)) import Facet.Subst @@ -119,18 +119,18 @@ instantiate inst = go resolveWith :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) - => (forall sig m . Has (Choose :+: Empty) sig m => Name -> Module -> m (RName :=: d)) + => (forall sig m . Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: d)) -> QName - -> m (RName :=: d) + -> m (QName :=: d) resolveWith lookup n = ask >>= \ graph -> asks (\ module' -> lookupWith lookup graph module' n) >>= \case [] -> freeVariable n [v] -> pure v ds -> ambiguousName n (map nm ds) -resolveC :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (RName :=: Maybe Term ::: Type) +resolveC :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Maybe Term ::: Type) resolveC = resolveWith lookupC -resolveQ :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (RName :=: Def) +resolveQ :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Def) resolveQ = resolveWith lookupD lookupInContext :: Has (Choose :+: Empty) sig m => QName -> Context -> m (LName Index, Either Kind (Quantity, Type)) @@ -140,12 +140,12 @@ lookupInContext (m:|>n) -- FIXME: probably we should instead look up the effect op globally, then check for membership in the sig -- FIXME: return the index in the sig; it’s vital for evaluation of polymorphic effects when there are multiple such -lookupInSig :: Has (Choose :+: Empty) sig m => QName -> Module -> Graph -> [Signature Type] -> m (RName :=: Type) -lookupInSig (m :|> n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':.:_) _) -> do - guard (m == Nil || m == toSnoc m') - defs <- interfaceScope =<< lookupQ graph mod (toQ q) +lookupInSig :: Has (Choose :+: Empty) sig m => QName -> Module -> Graph -> [Signature Type] -> m (QName :=: Type) +lookupInSig (m :|> n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':|>_) _) -> do + guard (m == Nil || m == m') + defs <- interfaceScope =<< lookupQ graph mod q _ :=: d <- lookupScope n defs - pure $ m':.:n :=: d) . interfaces + pure $ m' :|> n :=: d) . interfaces where interfaceScope (_ :=: d) = case d of { DSubmodule (SInterface defs) _K -> pure defs ; _ -> empty } @@ -207,7 +207,7 @@ data Err = Err data ErrReason = FreeVariable QName -- FIXME: add source references for the imports, definition sites, and any re-exports. - | AmbiguousName QName [RName] + | AmbiguousName QName [QName] | CouldNotSynthesize | ResourceMismatch Name Quantity Quantity | UnifyType UnifyErrReason (Exp (Either String Type)) (Act Type) @@ -221,7 +221,7 @@ _FreeVariable = prism' FreeVariable (\case FreeVariable n -> Just n _ -> Nothing) -_AmbiguousName :: Prism' ErrReason (QName, [RName]) +_AmbiguousName :: Prism' ErrReason (QName, [QName]) _AmbiguousName = prism' (uncurry AmbiguousName) (\case AmbiguousName n ns -> Just (n, ns) _ -> Nothing) @@ -279,7 +279,7 @@ resourceMismatch n exp act = withFrozenCallStack $ throwError $ ResourceMismatch freeVariable :: Has (Throw ErrReason) sig m => QName -> m a freeVariable n = withFrozenCallStack $ throwError $ FreeVariable n -ambiguousName :: Has (Throw ErrReason) sig m => QName -> [RName] -> m a +ambiguousName :: Has (Throw ErrReason) sig m => QName -> [QName] -> m a ambiguousName n qs = withFrozenCallStack $ throwError $ AmbiguousName n qs missingInterface :: Has (Throw ErrReason) sig m => Interface Type -> m a diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 449a9bb83..4a31922ca 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -112,11 +112,11 @@ as (m ::: _T) = do -- Term combinators -- FIXME: we’re instantiating when inspecting types in the REPL. -global :: Has (State (Subst Type)) sig m => RName ::: Type -> m (Term :==> Type) +global :: Has (State (Subst Type)) sig m => QName ::: Type -> m (Term :==> Type) global (q ::: _T) = (\ (v ::: _T) -> v :==> _T) <$> instantiate const (Var (Global q) ::: _T) -- FIXME: we’re instantiating when inspecting types in the REPL. -globalS :: (Has (State (Subst Type)) sig m, SQ.Sequent t c d, Applicative i) => RName ::: Type -> m (i t :==> Type) +globalS :: (Has (State (Subst Type)) sig m, SQ.Sequent t c d, Applicative i) => QName ::: Type -> m (i t :==> Type) globalS (q ::: _T) = do v <- SQ.varA (Global q) (\ (v ::: _T) -> v :==> _T) <$> instantiate const (v ::: _T) @@ -202,8 +202,8 @@ comp b = Check $ \ _T -> do (sig, _B) <- assertComp _T graph <- ask module' <- ask - let interfacePattern :: Has (Throw ErrReason) sig m => Interface Type -> m (RName :=: (Name :==> Type)) - interfacePattern (Interface n _) = maybe (freeVariable (toQ n)) (\ (n' :=: _T) -> pure ((n .:. n') :=: (n' :==> _T))) (listToMaybe (scopeToList . tm =<< unDInterface . def =<< lookupQ graph module' (toQ n))) + let interfacePattern :: Has (Throw ErrReason) sig m => Interface Type -> m (QName :=: (Name :==> Type)) + interfacePattern (Interface n _) = maybe (freeVariable n) (\ (n' :=: _T) -> pure ((n |> n') :=: (n' :==> _T))) (listToMaybe (scopeToList . tm =<< unDInterface . def =<< lookupQ graph module' n)) p' <- traverse interfacePattern (interfaces sig) -- FIXME: can we apply quantities to dictionaries? what would they mean? b' <- (Many, PDict p') |- check (b ::: _B) @@ -219,7 +219,7 @@ varP :: Name -> Bind m (Pattern (Name :==> Type)) varP n = Bind $ \ _A k -> k (PVar (n :==> wrap _A)) where wrap = \case - T.Comp sig _A -> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: T "Unit")) Nil) (T.Comp sig _A) + T.Comp sig _A -> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] |> T "Unit")) Nil) (T.Comp sig _A) _T -> _T conP :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => QName -> [Bind m (Pattern (Name :==> Type))] -> Bind m (Pattern (Name :==> Type)) @@ -241,7 +241,7 @@ fieldsP = foldr cons nil allP :: Has (Throw ErrReason :+: Write Warn) sig m => Name -> Bind m (Pattern (Name :==> Type)) allP n = Bind $ \ _A k -> do (sig, _T) <- assertComp _A - k (PVar (n :==> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] :.: T "Unit")) Nil) (T.Comp sig _T))) + k (PVar (n :==> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] |> T "Unit")) Nil) (T.Comp sig _T))) -- Expression elaboration @@ -327,7 +327,7 @@ elabDataDef constructors = Check $ \ _K -> do mname <- view name_ for constructors $ \ (S.Ann _ _ (n ::: t)) -> do c_T <- elabType $ runErr $ abstractType (Type.switch (synthType t) <==: KType) _K - con' <- elabTerm $ runErr $ check (abstractTerm (const (Con (mname :.: n) . toList)) ::: c_T) + con' <- elabTerm $ runErr $ check (abstractTerm (const (Con (mname |> n) . toList)) ::: c_T) pure $ n :=: DTerm (Just con') c_T elabInterfaceDef diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 81031fd93..8782af08d 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -37,7 +37,7 @@ tvar n = views context_ (lookupInContext n) >>= \case q :=: DSubmodule _ _K -> pure $ TX.Var (Global q) :==> _K _ -> freeVariable n -ivar :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (RName :==> Kind) +ivar :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :==> Kind) ivar n = resolveQ n >>= \case q :=: DSubmodule (SInterface _) _K -> pure $ q :==> _K _ -> freeVariable n diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 77d054404..4682d77f4 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -27,26 +27,26 @@ module Facet.Eval , reader' ) where -import Control.Algebra -import Control.Carrier.Reader -import Control.Monad (ap, guard, liftM, (>=>)) -import Control.Monad.Trans.Class -import Data.Foldable -import Data.Function -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Facet.Env as Env -import Facet.Graph -import Facet.Module -import Facet.Name hiding (Op) -import Facet.Pattern -import Facet.Quote -import Facet.Semialign (zipWithM) -import Facet.Snoc.NonEmpty as NE hiding ((|>)) -import Facet.Syntax -import Facet.Term.Expr -import GHC.Stack (HasCallStack) -import Prelude hiding (zipWith) +import Control.Algebra +import Control.Carrier.Reader +import Control.Monad (ap, guard, liftM, (>=>)) +import Control.Monad.Trans.Class +import Data.Foldable +import Data.Function +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Facet.Env as Env +import Facet.Graph +import Facet.Module +import Facet.Name hiding (Op) +import Facet.Pattern +import Facet.Quote +import Facet.Semialign (zipWithM) +import qualified Facet.Snoc.NonEmpty as NE +import Facet.Syntax +import Facet.Term.Expr +import GHC.Stack (HasCallStack) +import Prelude hiding (zipWith) eval :: (HasCallStack, Has (Reader Graph :+: Reader Module) sig m, MonadFail m) => Term -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) eval = \case @@ -60,11 +60,11 @@ eval = \case Let p v b -> eval v >>= \ v' -> local (|> fromMaybe (error "eval: non-exhaustive pattern in let") (matchV id p v')) (eval b) Comp p b -> comp p b -global :: Has (Reader Graph :+: Reader Module) sig m => RName -> ReaderC (Env (Value (Eval m))) (Eval m) Term +global :: Has (Reader Graph :+: Reader Module) sig m => QName -> ReaderC (Env (Value (Eval m))) (Eval m) Term global n = do mod <- lift ask graph <- lift ask - case lookupQ graph mod (toQ n) of + case lookupQ graph mod n of [_ :=: DTerm (Just v) _] -> pure v -- FIXME: store values in the module graph _ -> error "throw a real error here" @@ -84,10 +84,10 @@ app f a = ask >>= \ envCallSite -> f >>= \case string :: Text -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) string = pure . VString -con :: RName -> [ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m))] -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) +con :: QName -> [ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m))] -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) con n fs = VCon n <$> sequenceA fs -comp :: [RName :=: Name] -> Term -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) +comp :: [QName :=: Name] -> Term -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) comp p b = pure $ VComp p b @@ -121,15 +121,15 @@ data Value m -- | Neutral; variables, only used during quotation = VVar (Var (LName Level)) -- | Value; data constructors. - | VCon RName [Value m] + | VCon QName [Value m] -- | Value; strings. | VString Text -- | Computation; lambdas. | VLam (Env (Value m)) [(Pattern Name, Term)] -- | Computation; continuations, used in effect handlers. | VCont (Value m -> m (Value m)) - | VDict [RName :=: Value m] - | VComp [RName :=: Name] Term + | VDict [QName :=: Value m] + | VComp [QName :=: Name] Term instance Monad m => Quote (Value m) (m Term) where quote = \case @@ -142,7 +142,7 @@ instance Monad m => Quote (Value m) (m Term) where VComp p b -> pure . pure $ Comp p b unit :: Value m -unit = VCon (NE.FromList ["Data", "Unit"] :.: T "unit") [] +unit = VCon (NE.FromList ["Data", "Unit"] NE.|> T "unit") [] -- Elimination diff --git a/src/Facet/Graph.hs b/src/Facet/Graph.hs index e2525c851..4010f8662 100644 --- a/src/Facet/Graph.hs +++ b/src/Facet/Graph.hs @@ -64,7 +64,7 @@ lookupWith lookup graph mod@Module{ name } (m:|>n) <|> guard (m == Nil) *> foldMapC (maybe empty (lookup n) . snd) (getGraph graph) <|> guard (m /= Nil) *> (lookupM (fromSnoc m) graph >>= maybe empty pure . snd >>= lookup n) -lookupQ :: Has (Choose :+: Empty) sig m => Graph -> Module -> QName -> m (RName :=: Def) +lookupQ :: Has (Choose :+: Empty) sig m => Graph -> Module -> QName -> m (QName :=: Def) lookupQ = lookupWith lookupD diff --git a/src/Facet/Interface.hs b/src/Facet/Interface.hs index c78af6d84..c901f194b 100644 --- a/src/Facet/Interface.hs +++ b/src/Facet/Interface.hs @@ -13,7 +13,7 @@ import qualified Data.Set as Set import Facet.Name import Facet.Snoc -data Interface a = Interface RName (Snoc a) +data Interface a = Interface QName (Snoc a) deriving (Eq, Foldable, Functor, Ord, Show, Traversable) newtype Signature a = Signature { getSignature :: Set.Set (Interface a) } diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 5f4bbb247..c86499aa2 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -39,6 +39,7 @@ import Data.Coerce import qualified Data.Map as Map import Facet.Kind import Facet.Name +import Facet.Snoc.NonEmpty ((|>)) import Facet.Syntax import Facet.Term.Expr import Facet.Type.Norm @@ -85,20 +86,20 @@ foldMapC f = getChoosing #. foldMap (Choosing #. f) {-# INLINE (#.) #-} -lookupC :: Has (Choose :+: Empty) sig m => Name -> Module -> m (RName :=: Maybe Term ::: Type) +lookupC :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Maybe Term ::: Type) lookupC n Module{ name, scope } = foldMapC matchDef (map def (decls scope)) where matchDef = matchTerm <=< lookupScope n . tm <=< unDData - matchTerm (n :=: d) = (name :.: n :=:) <$> unDTerm d + matchTerm (n :=: d) = (name |> n :=:) <$> unDTerm d -- | Look up effect operations. -lookupE :: Has (Choose :+: Empty) sig m => Name -> Module -> m (RName :=: Def) +lookupE :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Def) lookupE n Module{ name, scope } = foldMapC matchDef (map def (decls scope)) where - matchDef = fmap (bimap (name:.:) (DTerm Nothing)) . lookupScope n . tm <=< unDInterface + matchDef = fmap (bimap (name |>) (DTerm Nothing)) . lookupScope n . tm <=< unDInterface -lookupD :: Has Empty sig m => Name -> Module -> m (RName :=: Def) -lookupD n Module{ name, scope } = maybe empty (pure . first (name:.:)) (lookupScope n scope) +lookupD :: Has Empty sig m => Name -> Module -> m (QName :=: Def) +lookupD n Module{ name, scope } = maybe empty (pure . first (name |>)) (lookupScope n scope) newtype Scope a = Scope { decls :: [Name :=: a] } diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index ba48e7f0a..96c27016b 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -10,9 +10,6 @@ module Facet.Name , __ , QName , prettyQName -, RName(..) -, (.:.) -, toQ , LName(..) , Name(..) , Assoc(..) @@ -26,9 +23,8 @@ module Facet.Name , anm ) where -import Data.Foldable (foldl', foldr', toList) +import Data.Foldable (foldl', foldr') import Data.Functor.Classes (showsUnaryWith) -import Data.List (intersperse) import qualified Data.List.NonEmpty as NE import Data.String (IsString(..)) import Data.Text (Text) @@ -87,28 +83,6 @@ type QName = NonEmpty Name prettyQName :: Printer a => QName -> a prettyQName (ns:|>n) = foldr' (surround dot . pretty) (pretty n) ns -showsQName :: (Foldable t, Show a, Show b) => String -> t a -> b -> Int -> ShowS -showsQName c m n p = showParen (p > 9) $ foldl' (.) id (intersperse (showChar '.') (shows <$> toList m)) . showString c . showsPrec 10 n - - --- | Resolved names. -data RName = QName :.: Name - deriving (Eq, Ord) - -instance Show RName where - showsPrec p (m :.: n) = showsQName ":.:" m n p - -instance P.Pretty RName where - pretty (m :.: n) = foldr' (surround dot . pretty) (pretty n) m - --- | Append a 'Name' onto an 'RName'. -(.:.) :: RName -> Name -> RName -m :.: n .:. n' = (m |> n) :.: n' - --- | Weaken an 'RName' to a 'QName'. This is primarily used for performing lookups in the graph starting from an 'RName' where the stronger structure is not required. -toQ :: RName -> QName -toQ (m :.: n) = m |> n - -- | Local names, consisting of a 'Level' or 'Index' to a pattern in an 'Env' or 'Context' and a 'Name' bound by said pattern. data LName v = LName diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 293a70333..07d2a3dd9 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -63,7 +63,7 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) printErrReason :: Options Print -> Env.Env Print -> ErrReason -> Doc Style printErrReason opts ctx = group . \case FreeVariable n -> fillSep [reflow "variable not in scope:", prettyQName n] - AmbiguousName n qs -> fillSep [reflow "ambiguous name", prettyQName n] <\> nest 2 (reflow "alternatives:" <\> unlines (map pretty qs)) + AmbiguousName n qs -> fillSep [reflow "ambiguous name", prettyQName n] <\> nest 2 (reflow "alternatives:" <\> unlines (map prettyQName qs)) CouldNotSynthesize -> reflow "could not synthesize a type; try a type annotation" ResourceMismatch n e a -> fillSep [reflow "uses of variable", pretty n, reflow "didn’t match requirements"] <> hardline <> pretty "expected:" <+> prettyQ e diff --git a/src/Facet/Pattern.hs b/src/Facet/Pattern.hs index 703a69091..25365f353 100644 --- a/src/Facet/Pattern.hs +++ b/src/Facet/Pattern.hs @@ -17,8 +17,8 @@ import Fresnel.Prism (Prism', prism') data Pattern a = PWildcard | PVar a - | PCon RName [Pattern a] - | PDict [RName :=: a] + | PCon QName [Pattern a] + | PDict [QName :=: a] deriving (Eq, Foldable, Functor, Ord, Show, Traversable) _PWildcard :: Prism' (Pattern a) () @@ -31,7 +31,7 @@ _PVar = prism' PVar (\case PVar a -> Just a _ -> Nothing) -_PCon :: Prism' (Pattern a) (RName, [Pattern a]) +_PCon :: Prism' (Pattern a) (QName, [Pattern a]) _PCon = prism' (uncurry PCon) (\case PCon h sp -> Just (h, sp) _ -> Nothing) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index d6eba8cd1..2172b9e27 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -165,9 +165,9 @@ instance Printable a => Printable (Interface a) where print = print1 instance Printable TX.Type where - print opts@Options{ rname } = go + print opts@Options{ qname } = go where - qvar = group . setPrec Var . rname + qvar = group . setPrec Var . qname go env = \case TX.Var (Global n) -> qvar n TX.Var (Free (Right n)) -> fromMaybe (lname (toLeveled d n)) $ Env.lookup env n @@ -191,7 +191,7 @@ deriving via (Quoting TX.Type TN.Type) instance Printable TN.Type instance Printable C.Term where - print opts@Options{ rname } = go + print opts@Options{ qname } = go where go env = \case C.Var (Global n) -> qvar n @@ -200,12 +200,12 @@ instance Printable C.Term where C.App f a -> go env f $$ go env a C.Con n p -> qvar n $$* (group . go env <$> p) C.String s -> annotate Lit $ pretty (show s) - C.Dict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> rname n <+> equals <+> group (go env v)) os) <> flatAlt space line) + C.Dict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> qname n <+> equals <+> group (go env v)) os) <> flatAlt space line) C.Let p v b -> let p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (getUsed (level env)) p) in pretty "let" <+> braces (print opts env (def <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p') b C.Comp p b -> comp (clause env (PDict p, b)) where d = level env - qvar = group . setPrec Var . rname + qvar = group . setPrec Var . qname clause env (p, b) = print opts env (def <$> p') <+> arrow <+> go (env |> p') b where p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (getUsed (level env)) p) @@ -241,16 +241,16 @@ class Printable1 f where printWith :: (Options Print -> Env Print -> a -> Print) -> Options Print -> Env Print -> f a -> Print instance Printable1 Interface where - printWith with opts@Options{ rname } env (Interface h sp) = rname h $$* fmap (with opts env) sp + printWith with opts@Options{ qname } env (Interface h sp) = qname h $$* fmap (with opts env) sp instance Printable1 Pattern where - printWith with opts@Options{ rname } env = go + printWith with opts@Options{ qname } env = go where go = \case PWildcard -> pretty '_' PVar n -> with opts env n - PCon n ps -> parens (annotate Con (rname n) $$* map go (toList ps)) - PDict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> rname n <+> equals <+> group (with opts env v)) os) <> flatAlt space line) + PCon n ps -> parens (annotate Con (qname n) $$* map go (toList ps)) + PDict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> qname n <+> equals <+> group (with opts env v)) os) <> flatAlt space line) print1 :: (Printable1 f, Printable a) => Options Print -> Env Print -> f a -> Print diff --git a/src/Facet/Print/Options.hs b/src/Facet/Print/Options.hs index aa4bd9713..4d74420cf 100644 --- a/src/Facet/Print/Options.hs +++ b/src/Facet/Print/Options.hs @@ -10,31 +10,32 @@ module Facet.Print.Options ) where import Facet.Name +import Facet.Snoc.NonEmpty import Silkscreen -- Options -- FIXME: add an option to control whether shifts are printed data Options p = Options - { rname :: RName -> p + { qname :: QName -> p , instantiation :: p -> p -> p } verboseOptions :: Printer p => Options p verboseOptions = Options - { rname = qualified + { qname = qualified , instantiation = printInstantiation } quietOptions :: Printer p => Options p quietOptions = Options - { rname = unqualified + { qname = unqualified , instantiation = suppressInstantiation } -qualified, unqualified :: Printer p => RName -> p -qualified = pretty -unqualified (_:.:n) = pretty n +qualified, unqualified :: Printer p => QName -> p +qualified = prettyQName +unqualified (_:|>n) = pretty n printInstantiation :: Printer p => p -> p -> p printInstantiation = (<+>) diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index ce8bc7113..e12a0e136 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -49,6 +49,7 @@ import Facet.Print as Print hiding (meta) import Facet.Quote import Facet.REPL.Parser import Facet.Snoc +import Facet.Snoc.NonEmpty import Facet.Source (Source(..), sourceFromString) import Facet.Style as Style import qualified Facet.Surface.Term.Expr as S @@ -203,7 +204,7 @@ showType e = Action $ do outputDocLn (getPrint (ann (Print.print opts mempty e ::: Print.print opts mempty _T))) showEval e = Action $ do - e' :==> _T <- runElab $ Elab.elabSynthTerm $ Elab.runErr $ locally Elab.sig_ (I.singleton (I.Interface (["Effect", "Console"]:.:T "Output") Nil) :) $ Elab.synthExpr e + e' :==> _T <- runElab $ Elab.elabSynthTerm $ Elab.runErr $ locally Elab.sig_ (I.singleton (I.Interface (["Effect", "Console"]:|>T "Output") Nil) :) $ Elab.synthExpr e e'' <- runElab $ runEvalMain e' opts <- get outputDocLn (getPrint (ann (Print.print opts mempty e'' ::: Print.print opts mempty _T))) diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index f026133ce..d031316fb 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -60,7 +60,7 @@ anon = lower . getLevel . getUsed var :: Var Level -> Print var v = case v of Free l -> lower (getLevel l) - Global n -> P.pretty n + Global n -> prettyQName n commaSep :: [Print] -> Print commaSep = P.encloseSep mempty mempty (P.comma <> P.space) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 00a61e70b..b6d17240a 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -151,7 +151,7 @@ qty (_ :@ q) = q -- Variables data Var a - = Global RName -- ^ Global variables, considered equal by 'RName'. + = Global QName -- ^ Global variables, considered equal by 'QName'. | Free a deriving (Eq, Foldable, Functor, Ord, Show, Traversable) diff --git a/src/Facet/Term/Expr.hs b/src/Facet/Term/Expr.hs index ee9b73fce..cc23d6823 100644 --- a/src/Facet/Term/Expr.hs +++ b/src/Facet/Term/Expr.hs @@ -14,9 +14,9 @@ data Term = Var (Var (LName Index)) | Lam [(Pattern Name, Term)] | App Term Term - | Con RName [Term] + | Con QName [Term] | String Text - | Dict [RName :=: Term] + | Dict [QName :=: Term] | Let (Pattern Name) Term Term - | Comp [RName :=: Name] Term -- ^ NB: the first argument is a specialization of @'Pattern' 'Name'@ to the 'PDict' constructor + | Comp [QName :=: Name] Term -- ^ NB: the first argument is a specialization of @'Pattern' 'Name'@ to the 'PDict' constructor deriving (Eq, Ord, Show) diff --git a/src/Facet/Term/Norm.hs b/src/Facet/Term/Norm.hs index ff5fb2051..a0b68fd35 100644 --- a/src/Facet/Term/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -20,11 +20,11 @@ import qualified Facet.Term.Expr as X data Term = String Text - | Con RName [Term] + | Con QName [Term] | Lam [(Pattern Name, Pattern (Name :=: Term) -> Term)] | Ne (Var (LName Level)) (Snoc Term) - | Dict [RName :=: Term] - | Comp [RName :=: Name] (Pattern (Name :=: Term) -> Term) + | Dict [QName :=: Term] + | Comp [QName :=: Name] (Pattern (Name :=: Term) -> Term) deriving (Eq, Ord, Show) via Quoting X.Term Term instance Quote Term X.Term where diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index b77454518..6d410f400 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -83,7 +83,7 @@ _Comp :: Prism' Type (Signature Type, Type) _Comp = prism' (uncurry Comp) (\case{ Comp sig t -> Just (sig, t) ; _ -> Nothing }) -global :: RName -> Type +global :: QName -> Type global = var . Global free :: LName Level -> Type From 46fe423b12665b6deb64e9878c54367fd9ba8985 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 20:51:29 -0400 Subject: [PATCH 1016/1324] :fire: GName. --- src/Facet/Elab/Pattern.hs | 18 +++++++++--------- src/Facet/Name.hs | 34 ---------------------------------- 2 files changed, 9 insertions(+), 43 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index a932a684c..eb7bf2f59 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -39,16 +39,16 @@ instantiateHead (Var (Just _)) = Var Nothing -- FIXME: let-bind any variables fi instantiateHead p = p -compileClauses :: Has Empty sig m => Root -> [X.Term] -> Type -> [Clause X.Term] -> m X.Term -compileClauses root ctx (_A :-> _T) heads = X.lamRA $ case _A of +compileClauses :: Has Empty sig m => [X.Term] -> Type -> [Clause X.Term] -> m X.Term +compileClauses ctx (_A :-> _T) heads = X.lamRA $ case _A of -- FIXME: look variables up in @ctx@ instead of hard-coding de Bruijn indices - Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses root ctx _T) X..||. X.covarA (Free 0) - _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses root ctx _T) X..||. X.covarA (Free 0) - One -> (match (_Unit.to (const [])) heads >>= compileClauses root ctx _T) X..||. X.covarA (Free 0) + Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) + _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) + One -> (match (_Unit.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) _A :* _B -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Var._Nothing.to (const [Var Nothing, Var Nothing])))) heads >>= \ heads' -> X.letA (X.µRA (X.varA (Free 2) X..||. X.prdL1A (X.covarA (Free 0)))) ( X.letA (X.µRA (X.varA (Free 3) X..||. X.prdL2A (X.covarA (Free 0)))) ( - compileClauses root ctx _T heads' X..||. X.covarA (Free 2))) + compileClauses ctx _T heads' X..||. X.covarA (Free 2))) _A :+ _B -> do heads' <- fold <$> for heads (\case Clause (p:ps) b -> case instantiateHead p of @@ -60,9 +60,9 @@ compileClauses root ctx (_A :-> _T) heads = X.lamRA $ case _A of X.varA (Free 1) X..||. X.sumLA -- FIXME: n-ary sums -- FIXME: don't create extra lambdas for the recursive calls - (X.µLA (compileClauses root ctx (_A :-> _T) (heads' `at` 0) X..||. X.covarA (Free 0))) - (X.µLA (compileClauses root ctx (_B :-> _T) (heads' `at` 1) X..||. X.covarA (Free 0))) -compileClauses _ _ _T heads + (X.µLA (compileClauses ctx (_A :-> _T) (heads' `at` 0) X..||. X.covarA (Free 0))) + (X.µLA (compileClauses ctx (_B :-> _T) (heads' `at` 1) X..||. X.covarA (Free 0))) +compileClauses _ _T heads | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) = pure b | otherwise = empty diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 96c27016b..17eaf50b2 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -17,10 +17,6 @@ module Facet.Name , formatOp , OpN(..) , formatOpN -, Root(..) -, GName(..) -, (//) -, anm ) where import Data.Foldable (foldl', foldr') @@ -29,7 +25,6 @@ import qualified Data.List.NonEmpty as NE import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as T -import Facet.Pretty (subscript) import Facet.Snoc.NonEmpty import qualified Prettyprinter as P import Silkscreen @@ -156,32 +151,3 @@ formatOpN (<+>) pretty place = \case PostfixN ee e -> foldr' (<+>) (comp e) (map comp ee) where comp e = place <+> pretty e InfixN (m NE.:|mm) -> place <+> foldr' comp (pretty m) mm <+> place where comp s e = pretty s <+> place <+> e OutfixN s mm e -> foldr' comp (pretty e) (s : mm) where comp s e = pretty s <+> place <+> e - - -data Root - = Root - | GName :// Text - deriving (Eq, Ord, Show) - -instance P.Pretty Root where - pretty = \case - Root -> P.pretty '_' - parent :// n -> P.pretty parent <> "." <> P.pretty n - --- | Agency-generated names à la /I Am Not a Number, I Am a Free Variable/. -data GName = GName Root Name Int - deriving (Eq, Ord, Show) - -infixl 6 :// - -instance P.Pretty GName where - pretty (GName Root n i) = P.pretty n <> if i <= 0 then mempty else subscript i - pretty (GName parent n i) = P.pretty parent <> "." <> P.pretty n <> if i <= 0 then mempty else subscript i - -(//) :: Root -> Name -> GName -parent // name = GName parent name 0 - -infixl 6 // - -anm :: Name -> GName -anm = (Root //) From fb857f04955b5f67871ff0a5ab7aa4d98ab4d6f2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 20:51:50 -0400 Subject: [PATCH 1017/1324] :fire: Agency. --- facet.cabal | 1 - src/Facet/Effect/Agency.hs | 16 ---------------- 2 files changed, 17 deletions(-) delete mode 100644 src/Facet/Effect/Agency.hs diff --git a/facet.cabal b/facet.cabal index f8b49dd45..3d87f06bd 100644 --- a/facet.cabal +++ b/facet.cabal @@ -80,7 +80,6 @@ library Facet.Context Facet.Diff Facet.Driver - Facet.Effect.Agency Facet.Effect.CallStack Facet.Effect.Parser Facet.Effect.Profile diff --git a/src/Facet/Effect/Agency.hs b/src/Facet/Effect/Agency.hs deleted file mode 100644 index ab3cde408..000000000 --- a/src/Facet/Effect/Agency.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE GADTs #-} -module Facet.Effect.Agency -( Root(..) -, Name(..) -, Agency(..) -) where - -data Root - = Root - | Name :// String - -data Name = Name Root String Int - -data Agency m k where - Scope :: String -> m a -> Agency m a - Fresh :: String -> Agency m Name From a4e665c95c1148a6db92272478a46c81364e2466 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 20:53:09 -0400 Subject: [PATCH 1018/1324] Carry a level through pattern elaboration. --- src/Facet/Elab/Pattern.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index eb7bf2f59..baee98759 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -39,16 +39,16 @@ instantiateHead (Var (Just _)) = Var Nothing -- FIXME: let-bind any variables fi instantiateHead p = p -compileClauses :: Has Empty sig m => [X.Term] -> Type -> [Clause X.Term] -> m X.Term -compileClauses ctx (_A :-> _T) heads = X.lamRA $ case _A of +compileClauses :: Has Empty sig m => Level -> [X.Term] -> Type -> [Clause X.Term] -> m X.Term +compileClauses level ctx (_A :-> _T) heads = X.lamRA $ case _A of -- FIXME: look variables up in @ctx@ instead of hard-coding de Bruijn indices - Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) - _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) - One -> (match (_Unit.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) + Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses level ctx _T) X..||. X.covarA (Free 0) + _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses level ctx _T) X..||. X.covarA (Free 0) + One -> (match (_Unit.to (const [])) heads >>= compileClauses level ctx _T) X..||. X.covarA (Free 0) _A :* _B -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Var._Nothing.to (const [Var Nothing, Var Nothing])))) heads >>= \ heads' -> X.letA (X.µRA (X.varA (Free 2) X..||. X.prdL1A (X.covarA (Free 0)))) ( X.letA (X.µRA (X.varA (Free 3) X..||. X.prdL2A (X.covarA (Free 0)))) ( - compileClauses ctx _T heads' X..||. X.covarA (Free 2))) + compileClauses level ctx _T heads' X..||. X.covarA (Free 2))) _A :+ _B -> do heads' <- fold <$> for heads (\case Clause (p:ps) b -> case instantiateHead p of @@ -60,9 +60,9 @@ compileClauses ctx (_A :-> _T) heads = X.lamRA $ case _A of X.varA (Free 1) X..||. X.sumLA -- FIXME: n-ary sums -- FIXME: don't create extra lambdas for the recursive calls - (X.µLA (compileClauses ctx (_A :-> _T) (heads' `at` 0) X..||. X.covarA (Free 0))) - (X.µLA (compileClauses ctx (_B :-> _T) (heads' `at` 1) X..||. X.covarA (Free 0))) -compileClauses _ _T heads + (X.µLA (compileClauses level ctx (_A :-> _T) (heads' `at` 0) X..||. X.covarA (Free 0))) + (X.µLA (compileClauses level ctx (_B :-> _T) (heads' `at` 1) X..||. X.covarA (Free 0))) +compileClauses _ _ _T heads | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) = pure b | otherwise = empty From 303b4f1c6ca176685bc23964db329c1a05512c50 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 22:36:17 -0400 Subject: [PATCH 1019/1324] Define a HOAS-like helper to construct lambdas. --- src/Facet/Sequent/Expr.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 05e88e9d3..69793849c 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -9,6 +9,7 @@ module Facet.Sequent.Expr , varA , µRA , lamRA +, lamRA' , covarA , µLA , sumLA @@ -100,6 +101,9 @@ varA = pure . Var lamRA :: Functor m => m Command -> m Term lamRA = fmap LamR +lamRA' :: Functor m => Level -> (Term -> Coterm -> m Command) -> m Term +lamRA' level body = LamR <$> body (var (toIndexed (Used (succ level)) level)) (covar (toIndexed (Used (succ level)) (succ level))) + covarA :: Applicative m => Var Index -> m Coterm covarA = pure . Covar From d2bf8338ea2b3cbc8abbabe57bdec99db0456bc2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 22:42:32 -0400 Subject: [PATCH 1020/1324] :fire: Used. It was not clarifying anything. --- src/Facet/Context.hs | 6 +++--- src/Facet/Elab.hs | 6 +++--- src/Facet/Elab/Term.hs | 6 +++--- src/Facet/Env.hs | 4 ++-- src/Facet/Eval.hs | 2 +- src/Facet/Name.hs | 9 ++++----- src/Facet/Polarized.hs | 10 +++++----- src/Facet/Print.hs | 10 +++++----- src/Facet/Quote.hs | 10 +++++----- src/Facet/Sequent/Expr.hs | 2 +- src/Facet/Sequent/Norm.hs | 8 ++++---- src/Facet/Sequent/Print.hs | 10 +++++----- src/Facet/Term/Norm.hs | 2 +- src/Facet/Type/Norm.hs | 2 +- src/Facet/Unify.hs | 4 ++-- 15 files changed, 45 insertions(+), 46 deletions(-) diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index 649c4bcf8..c369f87bb 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -41,8 +41,8 @@ Context as |> a = Context (as S.:> a) infixl 5 |> -level :: Context -> Used -level (Context es) = Used (Level (length es)) +level :: Context -> Level +level (Context es) = Level (length es) (!) :: HasCallStack => Context -> Index -> Binding Context es' ! Index i' = withFrozenCallStack $ go es' i' @@ -71,4 +71,4 @@ toEnv c = Env.Env (S.fromList (zipWith toType (toList (elems c)) [0..pred (level Type _ _ p -> (\ b -> proof b :=: bind d (proof b)) <$> p Kind (n :==> _) -> PVar (n :=: bind d n) - bind d b = free (LName (getUsed d) b) + bind d b = free (LName d b) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 688d042d2..7c8a70a22 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -153,10 +153,10 @@ lookupInSig (m :|> n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':|>_) _ (|-) :: Has (Reader ElabContext :+: Throw ErrReason :+: Writer Usage) sig m => (Quantity, Pattern (Name :==> Type)) -> m a -> m a (q, p) |- b = do d <- depth - (u, a) <- censor (`Usage.withoutVars` Vars.singleton (getUsed d)) $ listen $ locally context_ (|> Type q id p) b + (u, a) <- censor (`Usage.withoutVars` Vars.singleton d) $ listen $ locally context_ (|> Type q id p) b for_ p $ \ (n :==> _T) -> do let exp = q - act = Usage.lookup (LName (getUsed d) n) u + act = Usage.lookup (LName d n) u unless (act `sat` exp) $ resourceMismatch n exp act pure a @@ -179,7 +179,7 @@ sat a b evalTExpr :: Has (Reader ElabContext :+: State (Subst Type)) sig m => TX.Type -> m Type evalTExpr texpr = TN.eval <$> get <*> views context_ toEnv <*> pure texpr -depth :: Has (Reader ElabContext) sig m => m Used +depth :: Has (Reader ElabContext) sig m => m Level depth = views context_ level use :: Has (Reader ElabContext :+: Writer Usage) sig m => LName Index -> Quantity -> m () diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 4a31922ca..1c2e25856 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -153,7 +153,7 @@ tlam :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Th tlam b = Check $ \ _T -> do (n, _A, _B) <- assertQuantifier _T d <- depth - n :==> _A ||- check (b ::: _B (T.free (LName (getUsed d) n))) + n :==> _A ||- check (b ::: _B (T.free (LName d n))) lam :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => [(Bind m (Pattern (Name :==> Type)), Type <==: m Term)] -> Type <==: m Term lam cs = Check $ \ _T -> do @@ -302,10 +302,10 @@ abstractTerm body = go Nil Nil go ts fs = Check $ \case T.ForAll n _T _B -> do d <- depth - check (tlam (go (ts :> LName (getUsed d) n) fs) ::: T.ForAll n _T _B) + check (tlam (go (ts :> LName d n) fs) ::: T.ForAll n _T _B) T.Arrow n q _A _B -> do d <- depth - check (lam [(patternForArgType _A (fromMaybe __ n), go ts (fs :> \ d' -> Var (Free (LName (toIndexed d' (getUsed d)) (fromMaybe __ n)))))] ::: T.Arrow n q _A _B) + check (lam [(patternForArgType _A (fromMaybe __ n), go ts (fs :> \ d' -> Var (Free (LName (toIndexed d' d) (fromMaybe __ n)))))] ::: T.Arrow n q _A _B) _T -> do d <- depth pure $ body (TX.Var . Free . Right . toIndexed d <$> ts) (fs <*> pure d) diff --git a/src/Facet/Env.hs b/src/Facet/Env.hs index 1420f600a..3d91fdaf7 100644 --- a/src/Facet/Env.hs +++ b/src/Facet/Env.hs @@ -36,5 +36,5 @@ lookup (Env vs) (LName i n) = find (\ (n' :=: v) -> v <$ guard (n == n')) (vs ! index :: HasCallStack => Env v -> LName Index -> v index env n = fromMaybe (error ("Env.index: name (" <> show n <> ") not found")) (lookup env n) -level :: Env v -> Used -level = Used . Level . length . bindings +level :: Env v -> Level +level = Level . length . bindings diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 4682d77f4..bce86861d 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -134,7 +134,7 @@ data Value m instance Monad m => Quote (Value m) (m Term) where quote = \case VLam _ cs -> pure . pure $ Lam cs - VCont k -> Quoter (\ d -> runQuoter (succ d) . quote =<< k (VVar (Free (LName (getUsed d) __)))) + VCont k -> Quoter (\ d -> runQuoter (succ d) . quote =<< k (VVar (Free (LName d __)))) VVar v -> Quoter (\ d -> pure (Var (toIndexed d v))) VCon n fs -> fmap (Con n) . sequenceA <$> traverse quote fs VString s -> pure . pure $ String s diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 17eaf50b2..4899db079 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -5,7 +5,6 @@ module Facet.Name ( Index(..) , Level(..) , DeBruijn(..) -, Used(..) , Meta(..) , __ , QName @@ -45,12 +44,12 @@ instance Show Level where class DeBruijn lv ix | lv -> ix, ix -> lv where - toIndexed :: Used -> lv -> ix - toLeveled :: Used -> ix -> lv + toIndexed :: Level -> lv -> ix + toLeveled :: Level -> ix -> lv instance DeBruijn Level Index where - toIndexed (Used (Level d)) (Level level) = Index $ d - level - 1 - toLeveled (Used (Level d)) (Index index) = Level $ d - index - 1 + toIndexed (Level d) (Level level) = Index $ d - level - 1 + toLeveled (Level d) (Index index) = Level $ d - index - 1 instance DeBruijn lv ix => DeBruijn (Either e lv) (Either e ix) where toIndexed = fmap . toIndexed diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs index 8f7f74c76..5a2681d87 100644 --- a/src/Facet/Polarized.hs +++ b/src/Facet/Polarized.hs @@ -58,7 +58,7 @@ instance Quote Type XType where Up t -> XUp <$> quote t Bot -> pure XBot a :-> b -> liftA2 (:->:) (quote a) (quote b) - ForAll k b -> XForAll k <$> quoteBinder (Quoter (TVar k . getUsed)) b + ForAll k b -> XForAll k <$> quoteBinder (Quoter (TVar k)) b Down t -> XDown <$> quote t One -> pure XOne a :>< b -> liftA2 (:><:) (quote a) (quote b) @@ -127,7 +127,7 @@ evalCoterm env kenv = go go = \case CApp a k -> App (evalTerm env kenv a) : go k CInst t k -> Inst t : go k - CRet i -> [Ret (toLeveled (Used (Level (length kenv))) i)] + CRet i -> [Ret (toLeveled (Level (length kenv)) i)] data Binding = V V @@ -154,14 +154,14 @@ instance Ord V where instance Show V where showsPrec p = showsPrec p . quoteV 0 0 -quoteV :: Used -> Used -> V -> Term +quoteV :: Level -> Level -> V -> Term quoteV lv lk = \case Ne l sp -> CMu (CVar (toIndexed lv l)) (foldr (\case App v -> CApp (quoteV lv lk v) Inst t -> CInst t Ret i -> const (CRet (toIndexed lk i))) (CRet (Index 0)) sp) - TLam k f -> CTLam k (quoteV (succ lv) lk (f (TVar k (getUsed lv)))) - Lam f -> CLam (quoteV (succ lv) lk (f (vvar (getUsed lv)))) + TLam k f -> CTLam k (quoteV (succ lv) lk (f (TVar k lv))) + Lam f -> CLam (quoteV (succ lv) lk (f (vvar lv))) vvar :: Level -> V diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 2172b9e27..4bc681239 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -159,7 +159,7 @@ instance Printable Kind where KType -> annotate Type $ pretty "Type" KInterface -> annotate Type $ pretty "Interface" KArrow Nothing a b -> print opts env a --> print opts env b - KArrow (Just n) a b -> parens (ann (intro n (getUsed (level env)) ::: print opts env a)) --> print opts env b + KArrow (Just n) a b -> parens (ann (intro n (level env) ::: print opts env a)) --> print opts env b instance Printable a => Printable (Interface a) where print = print1 @@ -172,9 +172,9 @@ instance Printable TX.Type where TX.Var (Global n) -> qvar n TX.Var (Free (Right n)) -> fromMaybe (lname (toLeveled d n)) $ Env.lookup env n TX.Var (Free (Left m)) -> meta m - TX.ForAll n t b -> braces (ann (intro n (getUsed d) ::: print opts env t)) --> go (env |> PVar (n :=: intro n (getUsed d))) b + TX.ForAll n t b -> braces (ann (intro n d ::: print opts env t)) --> go (env |> PVar (n :=: intro n d)) b TX.Arrow Nothing q a b -> mult q (go env a) --> go env b - TX.Arrow (Just n) q a b -> parens (ann (intro n (getUsed d) ::: mult q (go env a))) --> go env b + TX.Arrow (Just n) q a b -> parens (ann (intro n d ::: mult q (go env a))) --> go env b TX.Comp s t -> if s == mempty then go env t else sig s <+> go env t TX.App f a -> group (go env f) $$ group (go env a) TX.String -> annotate Type $ pretty "String" @@ -201,14 +201,14 @@ instance Printable C.Term where C.Con n p -> qvar n $$* (group . go env <$> p) C.String s -> annotate Lit $ pretty (show s) C.Dict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> qname n <+> equals <+> group (go env v)) os) <> flatAlt space line) - C.Let p v b -> let p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (getUsed (level env)) p) in pretty "let" <+> braces (print opts env (def <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p') b + C.Let p v b -> let p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) in pretty "let" <+> braces (print opts env (def <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p') b C.Comp p b -> comp (clause env (PDict p, b)) where d = level env qvar = group . setPrec Var . qname clause env (p, b) = print opts env (def <$> p') <+> arrow <+> go (env |> p') b where - p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (getUsed (level env)) p) + p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) deriving via (Quoting C.Term N.Term) instance Printable N.Term diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index 93c68a14b..a83110124 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -16,7 +16,7 @@ module Facet.Quote , binderN ) where -import Facet.Name (Level, Used(..)) +import Facet.Name (Level) -- Quotation @@ -75,10 +75,10 @@ instance (Quote v t, Show t) => Show (Quoting t v) where -- | 'Quoter' is used to construct first-order representations of syntax directly from higher-order APIs in final tagless style. -- -- This typically requires that quotation keep track of the current de Bruijn level, but this data is typically not recorded in ASTs. 'Quoter' instead constructs a function parameterized by the initial level, and thus passing around the current level as quoting proceeds in exactly the same manner as the reader monad. -newtype Quoter a = Quoter (Used -> a) +newtype Quoter a = Quoter (Level -> a) deriving (Applicative, Functor, Monad) -runQuoter :: Used -> Quoter a -> a +runQuoter :: Level -> Quoter a -> a runQuoter d (Quoter f) = f d -- | Build quoted first-order syntax from a higher-order representation. @@ -86,7 +86,7 @@ binder :: (Level -> Quoter a) -- ^ Constructor for variables in @a@. -> (Quoter a -> Quoter b) -- ^ The binder's scope, represented as a Haskell function mapping variables' values to complete terms. -> Quoter b -- ^ A 'Quoter' of the first-order term. -binder with f = Quoter (\ d -> runQuoter (d + 1) (f (with (getUsed d)))) +binder with f = Quoter (\ d -> runQuoter (d + 1) (f (with d))) -- | Build quoted first-order syntax from a higher-order representation taking multiple variables. binderN @@ -94,5 +94,5 @@ binderN -> (Level -> Quoter a) -- ^ Constructor for variables in @a@. -> ([Quoter a] -> Quoter b) -- ^ The binder's scope, represented as a Haskell function mapping lists of variables' values to complete terms. -> Quoter b -- ^ A 'Quoter' of the first-order term. -binderN n with f = Quoter (\ d -> runQuoter (d + n') (f (map (with . getUsed) [0..n']))) +binderN n with f = Quoter (\ d -> runQuoter (d + n') (f (map with [0..n']))) where n' = fromIntegral n diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 69793849c..50975e23b 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -102,7 +102,7 @@ lamRA :: Functor m => m Command -> m Term lamRA = fmap LamR lamRA' :: Functor m => Level -> (Term -> Coterm -> m Command) -> m Term -lamRA' level body = LamR <$> body (var (toIndexed (Used (succ level)) level)) (covar (toIndexed (Used (succ level)) (succ level))) +lamRA' level body = LamR <$> body (var (toIndexed (succ level) level)) (covar (toIndexed (succ level) (succ level))) covarA :: Applicative m => Var Index -> m Coterm diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index b12d24d4f..ff9c5dc86 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -72,16 +72,16 @@ instance Class.Sequent Term Coterm Command where instance Quote Term X.Term where quote = \case Var v -> Quoter (\ d -> X.Var (toIndexed d v)) - MuR b -> X.MuR <$> quoteBinder (Quoter (Covar . Free . getUsed)) b - LamR b -> X.LamR <$> Quoter (\ d -> runQuoter (d + 2) (quote (b (Var (Free (getUsed d))) (Covar (Free (getUsed (d + 1))))))) + MuR b -> X.MuR <$> quoteBinder (Quoter (Covar . Free)) b + LamR b -> X.LamR <$> Quoter (\ d -> runQuoter (d + 2) (quote (b (Var (Free d)) (Covar (Free (d + 1)))))) SumR1 t -> X.SumR1 <$> quote t SumR2 t -> X.SumR2 <$> quote t UnitR -> pure X.UnitR PrdR l r -> X.PrdR <$> quote l <*> quote r StringR t -> pure (X.StringR t) -var :: Used -> Term -var = Var . Free . getUsed +var :: Level -> Term +var = Var . Free instance Quote Coterm X.Coterm where diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index d031316fb..21b329c17 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -14,7 +14,7 @@ import qualified Prettyprinter as PP import qualified Silkscreen as P import qualified Silkscreen.Printer.Rainbow as P -newtype Print = Print { doc :: Options Print -> Used -> P.Rainbow (PP.Doc S.Style) } +newtype Print = Print { doc :: Options Print -> Level -> P.Rainbow (PP.Doc S.Style) } deriving (Monoid, P.Printer, Semigroup) getPrint :: Options Print -> Print -> PP.Doc S.Style @@ -45,17 +45,17 @@ instance S.Sequent Print Print Print where (.|.) = fmap (P.enclose P.langle P.rangle) . P.surround P.pipe let' v b = P.pretty "let" P.<+> withLevel anon P.<+> P.pretty '=' P.<+> v P.<+> P.pretty "in" P.<+> fresh (b . anon) -withLevel :: (Used -> Print) -> Print +withLevel :: (Level -> Print) -> Print withLevel f = Print (\ o d -> doc (f d) o d) incrLevel :: Print -> Print incrLevel p = Print (\ o -> doc p o . succ) -fresh :: (Used -> Print) -> Print +fresh :: (Level -> Print) -> Print fresh f = withLevel (incrLevel . f) -anon :: Used -> Print -anon = lower . getLevel . getUsed +anon :: Level -> Print +anon = lower . getLevel var :: Var Level -> Print var v = case v of diff --git a/src/Facet/Term/Norm.hs b/src/Facet/Term/Norm.hs index a0b68fd35..73a3f3fe0 100644 --- a/src/Facet/Term/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -37,7 +37,7 @@ instance Quote Term X.Term where Comp p b -> X.Comp p . snd <$> clause (PDict p) b where clause :: Traversable t => t Name -> (t (Name :=: Term) -> Term) -> Quoter (t Name, X.Term) - clause p b = Quoter (\ d -> let (d', p') = mapAccumL (\ d n -> (succ d, n :=: Ne (Free (LName (getUsed d) n)) Nil)) d p in (p, runQuoter d' (quote (b p')))) + clause p b = Quoter (\ d -> let (d', p') = mapAccumL (\ d n -> (succ d, n :=: Ne (Free (LName d n)) Nil)) d p in (p, runQuoter d' (quote (b p')))) norm :: Env Term -> X.Term -> Term norm env = \case diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 6d410f400..77a824308 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -61,7 +61,7 @@ instance C.Type Type where instance Quote Type TX.Type where quote = \case String -> pure TX.String - ForAll n t b -> Quoter (\ d -> TX.ForAll n t (runQuoter (succ d) (quote (b (free (LName (getUsed d) n)))))) + ForAll n t b -> Quoter (\ d -> TX.ForAll n t (runQuoter (succ d) (quote (b (free (LName d n)))))) Arrow n q a b -> TX.Arrow n q <$> quote a <*> quote b Comp s t -> TX.Comp <$> traverseSignature quote s <*> quote t Ne n sp -> foldl' (\ h t -> TX.App <$> h <*> quote t) (Quoter (\ d -> TX.Var (toIndexed d n))) sp diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index 29263b769..cbcb8f6e4 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -59,7 +59,7 @@ unifyType = curry $ \case (TN.Ne (Free (Left v1)) Nil, TN.Ne (Free (Left v2)) Nil) -> flexFlex v1 v2 (TN.Ne (Free (Left v1)) Nil, t2) -> solve v1 t2 (t1, TN.Ne (Free (Left v2)) Nil) -> solve v2 t1 - (TN.ForAll _ t1 b1, TN.ForAll n t2 b2) -> depth >>= \ d -> evalTExpr =<< mkForAll d n <$> unifyKind t1 t2 <*> (n :==> t2 ||- unifyType (b1 (free (LName (getUsed d) n))) (b2 (free (LName (getUsed d) n)))) + (TN.ForAll _ t1 b1, TN.ForAll n t2 b2) -> depth >>= \ d -> evalTExpr =<< mkForAll d n <$> unifyKind t1 t2 <*> (n :==> t2 ||- unifyType (b1 (free (LName d n))) (b2 (free (LName d n)))) (TN.ForAll{}, _) -> mismatch (TN.Arrow _ _ a1 b1, TN.Arrow n q a2 b2) -> TN.Arrow n q <$> unifyType a1 a2 <*> unifyType b1 b2 (TN.Arrow{}, _) -> mismatch @@ -94,7 +94,7 @@ flexFlex v1 v2 solve :: (HasCallStack, Has (Reader ElabContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Type -> m Type solve v t = do d <- depth - if occursIn v (getUsed d) t then + if occursIn v d t then occurs v t else gets (lookupMeta v) >>= \case From 71c064c9e33b314578963ba7315b3a146c3d7890 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 1 Apr 2022 22:44:34 -0400 Subject: [PATCH 1021/1324] Bind variables for generated lambdas. --- src/Facet/Elab/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index baee98759..5a1b9bfc2 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -40,7 +40,7 @@ instantiateHead p = p compileClauses :: Has Empty sig m => Level -> [X.Term] -> Type -> [Clause X.Term] -> m X.Term -compileClauses level ctx (_A :-> _T) heads = X.lamRA $ case _A of +compileClauses level ctx (_A :-> _T) heads = X.lamRA' level $ \ _v _k -> case _A of -- FIXME: look variables up in @ctx@ instead of hard-coding de Bruijn indices Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses level ctx _T) X..||. X.covarA (Free 0) _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses level ctx _T) X..||. X.covarA (Free 0) From 39c1939537ca3e5c2490113e037edbefc63ad827 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 2 Apr 2022 00:46:53 -0400 Subject: [PATCH 1022/1324] Define a quoter transformer. --- src/Facet/Quote.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index a83110124..ea9b006a1 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -14,8 +14,12 @@ module Facet.Quote , runQuoter , binder , binderN +, QuoterT(..) +, runQuoterT ) where +import Control.Algebra +import Control.Carrier.Reader import Facet.Name (Level) -- Quotation @@ -96,3 +100,10 @@ binderN -> Quoter b -- ^ A 'Quoter' of the first-order term. binderN n with f = Quoter (\ d -> runQuoter (d + n') (f (map with [0..n']))) where n' = fromIntegral n + + +newtype QuoterT m a = QuoterT (Level -> m a) + deriving (Algebra (Reader Level :+: sig), Applicative, Functor, Monad) via ReaderC Level m + +runQuoterT :: Level -> QuoterT m a -> m a +runQuoterT d (QuoterT f) = f d From b740a590c4d5c133ce6a531773a459914c576135 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 2 Apr 2022 00:47:11 -0400 Subject: [PATCH 1023/1324] Quote in QuoterT. --- src/Facet/Elab/Pattern.hs | 19 ++++++++++--------- src/Facet/Sequent/Expr.hs | 4 ++-- 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 5a1b9bfc2..a2202e70b 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -16,6 +16,7 @@ import qualified Data.IntMap as IntMap import Data.Monoid (First(..)) import Data.Traversable (for) import Facet.Name +import Facet.Quote import qualified Facet.Sequent.Expr as X import Facet.Sequent.Pattern import Facet.Sequent.Type @@ -39,16 +40,16 @@ instantiateHead (Var (Just _)) = Var Nothing -- FIXME: let-bind any variables fi instantiateHead p = p -compileClauses :: Has Empty sig m => Level -> [X.Term] -> Type -> [Clause X.Term] -> m X.Term -compileClauses level ctx (_A :-> _T) heads = X.lamRA' level $ \ _v _k -> case _A of +compileClauses :: Has Empty sig m => [X.Term] -> Type -> [Clause X.Term] -> QuoterT m X.Term +compileClauses ctx (_A :-> _T) heads = X.lamRA' $ \ _v _k -> case _A of -- FIXME: look variables up in @ctx@ instead of hard-coding de Bruijn indices - Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses level ctx _T) X..||. X.covarA (Free 0) - _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses level ctx _T) X..||. X.covarA (Free 0) - One -> (match (_Unit.to (const [])) heads >>= compileClauses level ctx _T) X..||. X.covarA (Free 0) + Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) + _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) + One -> (match (_Unit.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) _A :* _B -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Var._Nothing.to (const [Var Nothing, Var Nothing])))) heads >>= \ heads' -> X.letA (X.µRA (X.varA (Free 2) X..||. X.prdL1A (X.covarA (Free 0)))) ( X.letA (X.µRA (X.varA (Free 3) X..||. X.prdL2A (X.covarA (Free 0)))) ( - compileClauses level ctx _T heads' X..||. X.covarA (Free 2))) + compileClauses ctx _T heads' X..||. X.covarA (Free 2))) _A :+ _B -> do heads' <- fold <$> for heads (\case Clause (p:ps) b -> case instantiateHead p of @@ -60,9 +61,9 @@ compileClauses level ctx (_A :-> _T) heads = X.lamRA' level $ \ _v _k -> case _A X.varA (Free 1) X..||. X.sumLA -- FIXME: n-ary sums -- FIXME: don't create extra lambdas for the recursive calls - (X.µLA (compileClauses level ctx (_A :-> _T) (heads' `at` 0) X..||. X.covarA (Free 0))) - (X.µLA (compileClauses level ctx (_B :-> _T) (heads' `at` 1) X..||. X.covarA (Free 0))) -compileClauses _ _ _T heads + (X.µLA (compileClauses ctx (_A :-> _T) (heads' `at` 0) X..||. X.covarA (Free 0))) + (X.µLA (compileClauses ctx (_B :-> _T) (heads' `at` 1) X..||. X.covarA (Free 0))) +compileClauses _ _T heads | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) = pure b | otherwise = empty diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 50975e23b..f42c88da6 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -101,8 +101,8 @@ varA = pure . Var lamRA :: Functor m => m Command -> m Term lamRA = fmap LamR -lamRA' :: Functor m => Level -> (Term -> Coterm -> m Command) -> m Term -lamRA' level body = LamR <$> body (var (toIndexed (succ level) level)) (covar (toIndexed (succ level) (succ level))) +lamRA' :: Applicative m => (QuoterT m Term -> QuoterT m Coterm -> QuoterT m Command) -> QuoterT m Term +lamRA' body = LamR <$> body (QuoterT (\ level -> pure (var (toIndexed (succ level) level)))) (QuoterT (\ level -> pure (covar (toIndexed (succ level) (succ level))))) covarA :: Applicative m => Var Index -> m Coterm From 0d284314724c046366ff8b162c8a066e36021e34 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 2 Apr 2022 00:49:46 -0400 Subject: [PATCH 1024/1324] =?UTF-8?q?Define=20a=20faux-HOAS=20=C2=B5=CC=83?= =?UTF-8?q?=20abstraction=20helper.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Sequent/Expr.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index f42c88da6..08cb499bf 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -12,6 +12,7 @@ module Facet.Sequent.Expr , lamRA' , covarA , µLA +, µLA' , sumLA , prdL1A , prdL2A @@ -111,6 +112,9 @@ covarA = pure . Covar µLA :: Functor m => m Command -> m Coterm µLA = fmap MuL +µLA' :: Applicative m => (QuoterT m Term -> QuoterT m Command) -> QuoterT m Coterm +µLA' body = MuL <$> body (QuoterT (\ level -> pure (var (toIndexed (succ level) (succ level))))) + sumLA :: Applicative m => m Coterm From 795cd539b8c67993f49a7c3cae2f906400902f6b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 2 Apr 2022 11:01:45 -0400 Subject: [PATCH 1025/1324] Define binder for QuoterT. --- src/Facet/Quote.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Facet/Quote.hs b/src/Facet/Quote.hs index ea9b006a1..d99b7e273 100644 --- a/src/Facet/Quote.hs +++ b/src/Facet/Quote.hs @@ -16,6 +16,7 @@ module Facet.Quote , binderN , QuoterT(..) , runQuoterT +, binderT ) where import Control.Algebra @@ -107,3 +108,10 @@ newtype QuoterT m a = QuoterT (Level -> m a) runQuoterT :: Level -> QuoterT m a -> m a runQuoterT d (QuoterT f) = f d + +-- | Build quoted first-order syntax from a higher-order representation. +binderT + :: (Level -> QuoterT m a) -- ^ Constructor for variables in @a@. + -> (QuoterT m a -> QuoterT m b) -- ^ The binder's scope, represented as a Haskell function mapping variables' values to complete terms. + -> QuoterT m b -- ^ A 'Quoter' of the first-order term. +binderT with f = QuoterT (\ d -> runQuoterT (d + 1) (f (with d))) From d5b54de70e1f850e438a8df36dc0dabc75c7960e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 2 Apr 2022 11:21:19 -0400 Subject: [PATCH 1026/1324] Define a Sequent instance for QuoterT of Term. --- src/Facet/Elab/Pattern.hs | 3 ++- src/Facet/Sequent/Expr.hs | 29 +++++++++++++++++++++-------- 2 files changed, 23 insertions(+), 9 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index a2202e70b..a20a6c290 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -17,6 +17,7 @@ import Data.Monoid (First(..)) import Data.Traversable (for) import Facet.Name import Facet.Quote +import qualified Facet.Sequent.Class as C import qualified Facet.Sequent.Expr as X import Facet.Sequent.Pattern import Facet.Sequent.Type @@ -41,7 +42,7 @@ instantiateHead p = p compileClauses :: Has Empty sig m => [X.Term] -> Type -> [Clause X.Term] -> QuoterT m X.Term -compileClauses ctx (_A :-> _T) heads = X.lamRA' $ \ _v _k -> case _A of +compileClauses ctx (_A :-> _T) heads = C.lamR $ \ v k -> case _A of -- FIXME: look variables up in @ctx@ instead of hard-coding de Bruijn indices Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 08cb499bf..8c3bd45c1 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -9,10 +9,8 @@ module Facet.Sequent.Expr , varA , µRA , lamRA -, lamRA' , covarA , µLA -, µLA' , sumLA , prdL1A , prdL2A @@ -63,6 +61,27 @@ data Command | Let Term Command +instance Applicative m => C.Sequent (QuoterT m Term) (QuoterT m Coterm) (QuoterT m Command) where + var inner = QuoterT (\ outer -> pure (Var (toIndexed outer inner))) + µR body = MuR <$> binderT (C.covar . Free) body + lamR body = LamR <$> binderT (C.var . Free) (binderT (C.covar . Free) . body) + sumR1 = fmap SumR1 + sumR2 = fmap SumR2 + unitR = pure UnitR + prdR = liftA2 PrdR + stringR = pure . StringR + + covar inner = QuoterT (\ outer -> pure (Covar (toIndexed outer inner))) + µL body = MuL <$> binderT (C.var . Free) body + lamL = liftA2 LamL + sumL = liftA2 SumL + unitL = pure UnitL + prdL1 = fmap PrdL1 + prdL2 = fmap PrdL2 + + (.|.) = liftA2 (:|:) + let' t b = Let <$> t <*> binderT (C.var . Free) b + instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where var v = Quoter (\ d -> Var (toIndexed d v)) µR b = MuR <$> binder (\ d' -> Quoter (\ d -> covar (toIndexed d d'))) b @@ -102,9 +121,6 @@ varA = pure . Var lamRA :: Functor m => m Command -> m Term lamRA = fmap LamR -lamRA' :: Applicative m => (QuoterT m Term -> QuoterT m Coterm -> QuoterT m Command) -> QuoterT m Term -lamRA' body = LamR <$> body (QuoterT (\ level -> pure (var (toIndexed (succ level) level)))) (QuoterT (\ level -> pure (covar (toIndexed (succ level) (succ level))))) - covarA :: Applicative m => Var Index -> m Coterm covarA = pure . Covar @@ -112,9 +128,6 @@ covarA = pure . Covar µLA :: Functor m => m Command -> m Coterm µLA = fmap MuL -µLA' :: Applicative m => (QuoterT m Term -> QuoterT m Command) -> QuoterT m Coterm -µLA' body = MuL <$> body (QuoterT (\ level -> pure (var (toIndexed (succ level) (succ level))))) - sumLA :: Applicative m => m Coterm From 8dd461e0fce512c06de0d29f78043f2522505362 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 3 Apr 2022 09:23:50 -0400 Subject: [PATCH 1027/1324] Compile in HOAS. --- src/Facet/Elab/Pattern.hs | 33 +++++++++++----------- src/Facet/Sequent/Expr.hs | 58 --------------------------------------- 2 files changed, 17 insertions(+), 74 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index a20a6c290..b1e534f06 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -21,7 +21,6 @@ import qualified Facet.Sequent.Class as C import qualified Facet.Sequent.Expr as X import Facet.Sequent.Pattern import Facet.Sequent.Type -import Facet.Syntax (Var(..)) import Fresnel.Fold (Fold, Union(..), preview) import Fresnel.Getter (to) import Fresnel.Lens (Lens', lens) @@ -42,15 +41,20 @@ instantiateHead p = p compileClauses :: Has Empty sig m => [X.Term] -> Type -> [Clause X.Term] -> QuoterT m X.Term -compileClauses ctx (_A :-> _T) heads = C.lamR $ \ v k -> case _A of - -- FIXME: look variables up in @ctx@ instead of hard-coding de Bruijn indices - Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) - _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) - One -> (match (_Unit.to (const [])) heads >>= compileClauses ctx _T) X..||. X.covarA (Free 0) +compileClauses ctx (_A :-> _T) heads = C.lamR (compileClausesBody ctx _A _T heads) +compileClauses _ _T heads + | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) = pure b + | otherwise = empty + +compileClausesBody :: Has Empty sig m => [X.Term] -> Type -> Type -> [Clause X.Term] -> QuoterT m X.Term -> QuoterT m X.Coterm -> QuoterT m X.Command +compileClausesBody ctx _A _T heads v k = case _A of + Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) C..|. k + _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) C..|. k + One -> (match (_Unit.to (const [])) heads >>= compileClauses ctx _T) C..|. k _A :* _B -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Var._Nothing.to (const [Var Nothing, Var Nothing])))) heads >>= \ heads' -> - X.letA (X.µRA (X.varA (Free 2) X..||. X.prdL1A (X.covarA (Free 0)))) ( - X.letA (X.µRA (X.varA (Free 3) X..||. X.prdL2A (X.covarA (Free 0)))) ( - compileClauses ctx _T heads' X..||. X.covarA (Free 2))) + C.let' (C.µR (\ k -> v C..|. C.prdL1 k)) (\ _ -> + C.let' (C.µR (\ k -> v C..|. C.prdL2 k)) (\ _ -> + compileClauses ctx _T heads' C..|. k)) _A :+ _B -> do heads' <- fold <$> for heads (\case Clause (p:ps) b -> case instantiateHead p of @@ -59,14 +63,11 @@ compileClauses ctx (_A :-> _T) heads = C.lamR $ \ v k -> case _A of Var Nothing -> pure (fromList [[Clause (Var Nothing:ps) b], [Clause (Var Nothing:ps) b]]) _ -> empty _ -> empty) - X.varA (Free 1) X..||. X.sumLA + v C..|. C.sumL -- FIXME: n-ary sums - -- FIXME: don't create extra lambdas for the recursive calls - (X.µLA (compileClauses ctx (_A :-> _T) (heads' `at` 0) X..||. X.covarA (Free 0))) - (X.µLA (compileClauses ctx (_B :-> _T) (heads' `at` 1) X..||. X.covarA (Free 0))) -compileClauses _ _T heads - | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) = pure b - | otherwise = empty + (C.µL (\ v -> compileClausesBody ctx _A _T (heads' `at` 0) v k)) + (C.µL (\ v -> compileClausesBody ctx _B _T (heads' `at` 1) v k)) + match :: Has Empty sig m => Fold (Pattern Name) [Pattern Name] -> [Clause X.Term] -> m [Clause X.Term] match o heads = forOf (traversed.patterns_) heads (\case diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 8c3bd45c1..e4bf80bfe 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -5,17 +5,6 @@ module Facet.Sequent.Expr , Coterm(..) -- * Commands , Command(..) - -- ** Smart constructors -, varA -, µRA -, lamRA -, covarA -, µLA -, sumLA -, prdL1A -, prdL2A -, (.||.) -, letA -- * Interpretation , interpretTerm , interpretCoterm @@ -110,53 +99,6 @@ covar :: Index -> Coterm covar = Covar . Free --- Smart constructors - -varA :: Applicative m => Var Index -> m Term -varA = pure . Var - -µRA :: Functor m => m Command -> m Term -µRA = fmap MuR - -lamRA :: Functor m => m Command -> m Term -lamRA = fmap LamR - - -covarA :: Applicative m => Var Index -> m Coterm -covarA = pure . Covar - -µLA :: Functor m => m Command -> m Coterm -µLA = fmap MuL - -sumLA - :: Applicative m - => m Coterm - -> m Coterm - -> m Coterm -sumLA = liftA2 SumL - -prdL1A - :: Applicative m - => m Coterm - -> m Coterm -prdL1A = fmap PrdL1 - -prdL2A - :: Applicative m - => m Coterm - -> m Coterm -prdL2A = fmap PrdL2 - - -(.||.) :: Applicative m => m Term -> m Coterm -> m Command -(.||.) = liftA2 (:|:) - -infix 1 .||. - -letA :: Applicative m => m Term -> m Command -> m Command -letA = liftA2 Let - - -- Interpreters interpretTerm :: C.Sequent t c d => [t] -> [c] -> Term -> t From 9809132f3a526928038a5d8ad2fcfe69a6baf68f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 5 Apr 2022 06:39:13 -0400 Subject: [PATCH 1028/1324] Abstract out call stack handling. --- src/Facet/Elab/Term.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 1c2e25856..a164460ea 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -247,7 +247,7 @@ allP n = Bind $ \ _A k -> do -- Expression elaboration synthExpr :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => S.Ann S.Expr -> m (Term :==> Type) -synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \case +synthExpr = withCallStack (popCallStack GHC.Stack.callStack) $ withSpan $ \case S.Var n -> var n S.App f a -> synthApp f a S.As t _T -> synthAs t _T @@ -263,7 +263,7 @@ synthExpr = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \cas checkExpr :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => S.Ann S.Expr -> Type <==: m Term -checkExpr expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC expr $ \case +checkExpr expr = withCallStack (popCallStack GHC.Stack.callStack) $ withSpanC expr $ \case S.Hole n -> hole n S.Lam cs -> checkLam cs S.Var{} -> switch (synthExpr expr) @@ -426,6 +426,9 @@ withSpanC (S.Ann s _ a) k = Check (\ _T -> pushSpan s (k a <==: _T)) withSpan :: Has (Reader ElabContext) sig m => (a -> m b) -> S.Ann a -> m b withSpan k (S.Ann s _ a) = pushSpan s (k a) +withCallStack :: CallStack -> (HasCallStack => a) -> a +withCallStack cs with = let ?callStack = cs in with + provide :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m) => Signature Type -> m a -> m a provide sig m = do subst <- get From 65690ccfc4bfb55972ce3ad10c96af5f5377cad2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Apr 2022 09:01:04 -0400 Subject: [PATCH 1029/1324] Add bottom terms to sequents. --- src/Facet/Sequent/Class.hs | 1 + src/Facet/Sequent/Expr.hs | 4 ++++ src/Facet/Sequent/Norm.hs | 3 +++ 3 files changed, 8 insertions(+) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 4abd98bb8..20f217894 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -39,6 +39,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma lamR :: (term -> coterm -> command) -> term sumR1 :: term -> term sumR2 :: term -> term + bottomR :: command -> term unitR :: term prdR :: term -> term -> term stringR :: Text -> term diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index e4bf80bfe..60dd16b76 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -26,6 +26,7 @@ data Term | LamR Command | SumR1 Term | SumR2 Term + | BottomR Command | UnitR | PrdR Term Term | StringR Text @@ -56,6 +57,7 @@ instance Applicative m => C.Sequent (QuoterT m Term) (QuoterT m Coterm) (QuoterT lamR body = LamR <$> binderT (C.var . Free) (binderT (C.covar . Free) . body) sumR1 = fmap SumR1 sumR2 = fmap SumR2 + bottomR = fmap BottomR unitR = pure UnitR prdR = liftA2 PrdR stringR = pure . StringR @@ -77,6 +79,7 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where lamR b = LamR <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) (binder (\ d'' -> Quoter (\ d -> covar (toIndexed d d''))) . b) sumR1 = fmap SumR1 sumR2 = fmap SumR2 + bottomR = fmap BottomR unitR = pure UnitR prdR = liftA2 PrdR stringR = pure . StringR @@ -109,6 +112,7 @@ interpretTerm _G _D = \case LamR b -> C.lamR (\ a k -> interpretCommand (a:_G) (k:_D) b) SumR1 t -> C.sumR1 (interpretTerm _G _D t) SumR2 t -> C.sumR2 (interpretTerm _G _D t) + BottomR c -> C.bottomR (interpretCommand _G _D c) UnitR -> C.unitR PrdR l r -> C.prdR (interpretTerm _G _D l) (interpretTerm _G _D r) StringR s -> C.stringR s diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index ff9c5dc86..5ca00e5fa 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -23,6 +23,7 @@ data Term | LamR (Term -> Coterm -> Command) | SumR1 Term | SumR2 Term + | BottomR Command | UnitR | PrdR Term Term | StringR Text @@ -53,6 +54,7 @@ instance Class.Sequent Term Coterm Command where lamR = LamR sumR1 = SumR1 sumR2 = SumR2 + bottomR = BottomR unitR = UnitR prdR = PrdR stringR = StringR @@ -76,6 +78,7 @@ instance Quote Term X.Term where LamR b -> X.LamR <$> Quoter (\ d -> runQuoter (d + 2) (quote (b (Var (Free d)) (Covar (Free (d + 1)))))) SumR1 t -> X.SumR1 <$> quote t SumR2 t -> X.SumR2 <$> quote t + BottomR c -> X.BottomR <$> quote c UnitR -> pure X.UnitR PrdR l r -> X.PrdR <$> quote l <*> quote r StringR t -> pure (X.StringR t) From 41e0cfdbf1512853f583c304b7a9d9171e7f42b6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Apr 2022 09:06:20 -0400 Subject: [PATCH 1030/1324] Rename _ty to ty_. --- src/Facet/Syntax.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index b6d17240a..46a4bc759 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -6,7 +6,7 @@ module Facet.Syntax , tm , (:::)(..) , ty -, _ty +, ty_ , (:=:)(..) , nm , def @@ -93,8 +93,8 @@ instance HasTerm (:::) where ty :: a ::: b -> b ty (_ ::: b) = b -_ty :: Lens (s ::: t) (s ::: t') t t' -_ty = lens ty (\ (s ::: _) t' -> s ::: t') +ty_ :: Lens (s ::: t) (s ::: t') t t' +ty_ = lens ty (\ (s ::: _) t' -> s ::: t') data a :=: b = a :=: b From 2c8e273dbeb4a90ba7422c210db5ef1e9b238111 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Apr 2022 09:07:09 -0400 Subject: [PATCH 1031/1324] Define ty using the lens. --- src/Facet/Syntax.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 46a4bc759..bc0a07474 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -91,10 +91,10 @@ instance HasTerm (:::) where tm_ = lens (\ (a ::: _) -> a) (\ (_ ::: t) s' -> s' ::: t) ty :: a ::: b -> b -ty (_ ::: b) = b +ty = view ty_ ty_ :: Lens (s ::: t) (s ::: t') t t' -ty_ = lens ty (\ (s ::: _) t' -> s ::: t') +ty_ = lens (\ (_ ::: b) -> b) (\ (s ::: _) t' -> s ::: t') data a :=: b = a :=: b From 698c99b49513bb81fd207ca185c89e7bfc85d01f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Apr 2022 09:08:12 -0400 Subject: [PATCH 1032/1324] :fire: ty. --- src/Facet/Syntax.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index bc0a07474..0567a1f9d 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -5,7 +5,6 @@ module Facet.Syntax , HasTerm(..) , tm , (:::)(..) -, ty , ty_ , (:=:)(..) , nm @@ -85,14 +84,11 @@ instance Ord2 (:::) where liftCompare2 compareA compareB (a1 ::: b1) (a2 ::: b2) = compareA a1 a2 <> compareB b1 b2 instance IsPair (:::) where - pair_ = iso ((,) <$> tm <*> ty) (uncurry (:::)) + pair_ = iso ((,) <$> tm <*> view ty_) (uncurry (:::)) instance HasTerm (:::) where tm_ = lens (\ (a ::: _) -> a) (\ (_ ::: t) s' -> s' ::: t) -ty :: a ::: b -> b -ty = view ty_ - ty_ :: Lens (s ::: t) (s ::: t') t t' ty_ = lens (\ (_ ::: b) -> b) (\ (s ::: _) t' -> s ::: t') From 1d395ea66e451c6df9183a553cd7c8968be333a1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Apr 2022 09:10:41 -0400 Subject: [PATCH 1033/1324] :fire: tm. --- src/Facet/Elab/Term.hs | 7 ++++--- src/Facet/Module.hs | 4 ++-- src/Facet/Syntax.hs | 9 +++------ 3 files changed, 9 insertions(+), 11 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index a164460ea..67b993b83 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -88,6 +88,7 @@ import Facet.Type.Norm as T hiding (global) import Facet.Unify import Facet.Usage hiding (restrict) import Fresnel.At as At +import Fresnel.Getter as Getter (view) import Fresnel.Ixed import Fresnel.Prism (Prism') import Fresnel.Review (review) @@ -203,7 +204,7 @@ comp b = Check $ \ _T -> do graph <- ask module' <- ask let interfacePattern :: Has (Throw ErrReason) sig m => Interface Type -> m (QName :=: (Name :==> Type)) - interfacePattern (Interface n _) = maybe (freeVariable n) (\ (n' :=: _T) -> pure ((n |> n') :=: (n' :==> _T))) (listToMaybe (scopeToList . tm =<< unDInterface . def =<< lookupQ graph module' n)) + interfacePattern (Interface n _) = maybe (freeVariable n) (\ (n' :=: _T) -> pure ((n |> n') :=: (n' :==> _T))) (listToMaybe (scopeToList . Getter.view tm_ =<< unDInterface . def =<< lookupQ graph module' n)) p' <- traverse interfacePattern (interfaces sig) -- FIXME: can we apply quantities to dictionaries? what would they mean? b' <- (Many, PDict p') |- check (b ::: _B) @@ -324,7 +325,7 @@ elabDataDef -> Kind <==: m [Name :=: Def] -- FIXME: check that all constructors return the datatype. elabDataDef constructors = Check $ \ _K -> do - mname <- view name_ + mname <- Lens.view name_ for constructors $ \ (S.Ann _ _ (n ::: t)) -> do c_T <- elabType $ runErr $ abstractType (Type.switch (synthType t) <==: KType) _K con' <- elabTerm $ runErr $ check (abstractTerm (const (Con (mname |> n) . toList)) ::: c_T) @@ -437,7 +438,7 @@ provide sig m = do require :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Signature Type -> m () require req = do - prv <- view sig_ + prv <- Lens.view sig_ for_ (interfaces req) $ \ i -> findMaybeA (findMaybeA (runUnifyMaybe . unifyInterface i) . interfaces) prv >>= \case Nothing -> missingInterface i Just _ -> pure () diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index c86499aa2..f6b1d4c09 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -89,14 +89,14 @@ foldMapC f = getChoosing #. foldMap (Choosing #. f) lookupC :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Maybe Term ::: Type) lookupC n Module{ name, scope } = foldMapC matchDef (map def (decls scope)) where - matchDef = matchTerm <=< lookupScope n . tm <=< unDData + matchDef = matchTerm <=< lookupScope n . view tm_ <=< unDData matchTerm (n :=: d) = (name |> n :=:) <$> unDTerm d -- | Look up effect operations. lookupE :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Def) lookupE n Module{ name, scope } = foldMapC matchDef (map def (decls scope)) where - matchDef = fmap (bimap (name |>) (DTerm Nothing)) . lookupScope n . tm <=< unDInterface + matchDef = fmap (bimap (name |>) (DTerm Nothing)) . lookupScope n . view tm_ <=< unDInterface lookupD :: Has Empty sig m => Name -> Module -> m (QName :=: Def) lookupD n Module{ name, scope } = maybe empty (pure . first (name |>)) (lookupScope n scope) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 0567a1f9d..c586bb3eb 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -3,7 +3,7 @@ module Facet.Syntax ( -- * Term containers IsPair(..) , HasTerm(..) -, tm +-- , tm , (:::)(..) , ty_ , (:=:)(..) @@ -53,9 +53,6 @@ class IsPair p where class HasTerm p where tm_ :: Lens (p s t) (p s' t) s s' -tm :: HasTerm p => a `p` b -> a -tm = view tm_ - data a ::: b = a ::: b deriving (Eq, Foldable, Functor, Ord, Show, Traversable) @@ -84,7 +81,7 @@ instance Ord2 (:::) where liftCompare2 compareA compareB (a1 ::: b1) (a2 ::: b2) = compareA a1 a2 <> compareB b1 b2 instance IsPair (:::) where - pair_ = iso ((,) <$> tm <*> view ty_) (uncurry (:::)) + pair_ = iso ((,) <$> view tm_ <*> view ty_) (uncurry (:::)) instance HasTerm (:::) where tm_ = lens (\ (a ::: _) -> a) (\ (_ ::: t) s' -> s' ::: t) @@ -135,7 +132,7 @@ instance Bitraversable (:@) where bitraverse f g (a :@ b) = (:@) <$> f a <*> g b instance IsPair (:@) where - pair_ = iso ((,) <$> tm <*> qty) (uncurry (:@)) + pair_ = iso ((,) <$> view tm_ <*> qty) (uncurry (:@)) instance HasTerm (:@) where tm_ = lens (\ (a :@ _) -> a) (\ (_ :@ t) s' -> s' :@ t) From dff96c2938fda9a7d2a520635aa0063d22e7de41 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Apr 2022 09:12:25 -0400 Subject: [PATCH 1034/1324] Define a lens for definition names. --- src/Facet/Syntax.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index c586bb3eb..f0454e9ba 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -8,6 +8,7 @@ module Facet.Syntax , ty_ , (:=:)(..) , nm +, nm_ , def , (:@)(..) , qty @@ -113,6 +114,9 @@ instance HasTerm (:=:) where nm :: a :=: b -> a nm (a :=: _) = a +nm_ :: Lens (a :=: b) (a' :=: b) a a' +nm_ = lens (\ (a :=: _) -> a) (\ (_ :=: b) a -> a :=: b) + def :: a :=: b -> b def (_ :=: b) = b From cc5aea4a1dce13b60346295a9fe3034fc870a825 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Apr 2022 09:13:07 -0400 Subject: [PATCH 1035/1324] Define a lens for definitions. --- src/Facet/Syntax.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index f0454e9ba..5ee2ba571 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -10,6 +10,7 @@ module Facet.Syntax , nm , nm_ , def +, def_ , (:@)(..) , qty -- * Variables @@ -120,6 +121,9 @@ nm_ = lens (\ (a :=: _) -> a) (\ (_ :=: b) a -> a :=: b) def :: a :=: b -> b def (_ :=: b) = b +def_ :: Lens (a :=: b) (a :=: b') b b' +def_ = lens (\ (_ :=: b) -> b) (\ (a :=: _) b -> a :=: b) + data a :@ b = a :@ b deriving (Eq, Foldable, Functor, Ord, Show, Traversable) From 53878f0c0476084b71ddb511639a7c8443b5da18 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Apr 2022 09:14:26 -0400 Subject: [PATCH 1036/1324] :fire: nm. --- src/Facet/Elab.hs | 5 +++-- src/Facet/Syntax.hs | 6 +----- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 7c8a70a22..ecc665f56 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -71,7 +71,7 @@ import Facet.Functor.Synth import Facet.Graph as Graph import Facet.Interface import Facet.Kind -import Facet.Lens hiding (use) +import Facet.Lens hiding (use, view) import Facet.Module import Facet.Name hiding (L, R) import Facet.Pattern @@ -89,6 +89,7 @@ import Facet.Type.Norm as TN import Facet.Usage as Usage import Facet.Vars as Vars import Fresnel.Fold ((^?)) +import Fresnel.Getter (view) import Fresnel.Lens (Lens', lens) import Fresnel.Prism (Prism', prism') import GHC.Stack @@ -125,7 +126,7 @@ resolveWith resolveWith lookup n = ask >>= \ graph -> asks (\ module' -> lookupWith lookup graph module' n) >>= \case [] -> freeVariable n [v] -> pure v - ds -> ambiguousName n (map nm ds) + ds -> ambiguousName n (map (view nm_) ds) resolveC :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Maybe Term ::: Type) resolveC = resolveWith lookupC diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 5ee2ba571..cc2734929 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -7,7 +7,6 @@ module Facet.Syntax , (:::)(..) , ty_ , (:=:)(..) -, nm , nm_ , def , def_ @@ -107,14 +106,11 @@ instance Bitraversable (:=:) where bitraverse f g (a :=: b) = (:=:) <$> f a <*> g b instance IsPair (:=:) where - pair_ = iso ((,) <$> nm <*> def) (uncurry (:=:)) + pair_ = iso ((,) <$> view nm_ <*> def) (uncurry (:=:)) instance HasTerm (:=:) where tm_ = lens (\ (a :=: _) -> a) (\ (_ :=: t) s' -> s' :=: t) -nm :: a :=: b -> a -nm (a :=: _) = a - nm_ :: Lens (a :=: b) (a' :=: b) a a' nm_ = lens (\ (a :=: _) -> a) (\ (_ :=: b) a -> a :=: b) From cca1a8c491422bb001825e1e5131a003bc989c2c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Apr 2022 09:15:44 -0400 Subject: [PATCH 1037/1324] :fire: def. --- src/Facet/Elab/Term.hs | 2 +- src/Facet/Module.hs | 4 ++-- src/Facet/Print.hs | 5 +++-- src/Facet/Syntax.hs | 6 +----- 4 files changed, 7 insertions(+), 10 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 67b993b83..ba8c1402a 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -204,7 +204,7 @@ comp b = Check $ \ _T -> do graph <- ask module' <- ask let interfacePattern :: Has (Throw ErrReason) sig m => Interface Type -> m (QName :=: (Name :==> Type)) - interfacePattern (Interface n _) = maybe (freeVariable n) (\ (n' :=: _T) -> pure ((n |> n') :=: (n' :==> _T))) (listToMaybe (scopeToList . Getter.view tm_ =<< unDInterface . def =<< lookupQ graph module' n)) + interfacePattern (Interface n _) = maybe (freeVariable n) (\ (n' :=: _T) -> pure ((n |> n') :=: (n' :==> _T))) (listToMaybe (scopeToList . Getter.view tm_ =<< unDInterface . Getter.view def_ =<< lookupQ graph module' n)) p' <- traverse interfacePattern (interfaces sig) -- FIXME: can we apply quantities to dictionaries? what would they mean? b' <- (Many, PDict p') |- check (b ::: _B) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index f6b1d4c09..fa8633f77 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -87,14 +87,14 @@ foldMapC f = getChoosing #. foldMap (Choosing #. f) lookupC :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Maybe Term ::: Type) -lookupC n Module{ name, scope } = foldMapC matchDef (map def (decls scope)) +lookupC n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) where matchDef = matchTerm <=< lookupScope n . view tm_ <=< unDData matchTerm (n :=: d) = (name |> n :=:) <$> unDTerm d -- | Look up effect operations. lookupE :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Def) -lookupE n Module{ name, scope } = foldMapC matchDef (map def (decls scope)) +lookupE n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) where matchDef = fmap (bimap (name |>) (DTerm Nothing)) . lookupScope n . view tm_ <=< unDInterface diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 4bc681239..53b2f87da 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -47,6 +47,7 @@ import qualified Facet.Term.Expr as C import qualified Facet.Term.Norm as N import qualified Facet.Type.Expr as TX import qualified Facet.Type.Norm as TN +import Fresnel.Getter (view) import Prelude hiding (print) import qualified Prettyprinter as PP import Silkscreen as P @@ -201,12 +202,12 @@ instance Printable C.Term where C.Con n p -> qvar n $$* (group . go env <$> p) C.String s -> annotate Lit $ pretty (show s) C.Dict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> qname n <+> equals <+> group (go env v)) os) <> flatAlt space line) - C.Let p v b -> let p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) in pretty "let" <+> braces (print opts env (def <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p') b + C.Let p v b -> let p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) in pretty "let" <+> braces (print opts env (view def_ <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p') b C.Comp p b -> comp (clause env (PDict p, b)) where d = level env qvar = group . setPrec Var . qname - clause env (p, b) = print opts env (def <$> p') <+> arrow <+> go (env |> p') b + clause env (p, b) = print opts env (view def_ <$> p') <+> arrow <+> go (env |> p') b where p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index cc2734929..220068daf 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -8,7 +8,6 @@ module Facet.Syntax , ty_ , (:=:)(..) , nm_ -, def , def_ , (:@)(..) , qty @@ -106,7 +105,7 @@ instance Bitraversable (:=:) where bitraverse f g (a :=: b) = (:=:) <$> f a <*> g b instance IsPair (:=:) where - pair_ = iso ((,) <$> view nm_ <*> def) (uncurry (:=:)) + pair_ = iso ((,) <$> view nm_ <*> view def_) (uncurry (:=:)) instance HasTerm (:=:) where tm_ = lens (\ (a :=: _) -> a) (\ (_ :=: t) s' -> s' :=: t) @@ -114,9 +113,6 @@ instance HasTerm (:=:) where nm_ :: Lens (a :=: b) (a' :=: b) a a' nm_ = lens (\ (a :=: _) -> a) (\ (_ :=: b) a -> a :=: b) -def :: a :=: b -> b -def (_ :=: b) = b - def_ :: Lens (a :=: b) (a :=: b') b b' def_ = lens (\ (_ :=: b) -> b) (\ (a :=: _) b -> a :=: b) From 97bfa0d3c04e46656c3e6eba6b460935175091c2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Apr 2022 09:17:04 -0400 Subject: [PATCH 1038/1324] Define a lens for quantities. --- src/Facet/Syntax.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 220068daf..dd59d53a4 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -11,6 +11,7 @@ module Facet.Syntax , def_ , (:@)(..) , qty +, qty_ -- * Variables , Var(..) -- * Decomposition @@ -140,6 +141,9 @@ instance HasTerm (:@) where qty :: p :@ q -> q qty (_ :@ q) = q +qty_ :: Lens (p :@ q) (p :@ q') q q' +qty_ = lens (\ (_ :@ q) -> q) (\ (p :@ _) q -> p :@ q) + -- Variables From 083df8bf0637fb314d01090768495046c7b3910c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Apr 2022 09:17:52 -0400 Subject: [PATCH 1039/1324] :fire: qty. --- src/Facet/Syntax.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index dd59d53a4..578ec8c48 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -10,7 +10,6 @@ module Facet.Syntax , nm_ , def_ , (:@)(..) -, qty , qty_ -- * Variables , Var(..) @@ -133,14 +132,11 @@ instance Bitraversable (:@) where bitraverse f g (a :@ b) = (:@) <$> f a <*> g b instance IsPair (:@) where - pair_ = iso ((,) <$> view tm_ <*> qty) (uncurry (:@)) + pair_ = iso ((,) <$> view tm_ <*> view qty_) (uncurry (:@)) instance HasTerm (:@) where tm_ = lens (\ (a :@ _) -> a) (\ (_ :@ t) s' -> s' :@ t) -qty :: p :@ q -> q -qty (_ :@ q) = q - qty_ :: Lens (p :@ q) (p :@ q') q q' qty_ = lens (\ (_ :@ q) -> q) (\ (p :@ _) q -> p :@ q) From 95ada84deaccecadc32edf7bd1d9583d943381b9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 9 Apr 2022 09:19:09 -0400 Subject: [PATCH 1040/1324] Print bottom terms. --- src/Facet/Sequent/Print.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index 21b329c17..c67abf3e9 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -30,6 +30,7 @@ instance S.Sequent Print Print Print where lamR c = P.pretty "λ" <> P.braces (fresh (\ u -> fresh (\ v -> anon u <> P.comma P.<+> anon v P.<+> P.pretty "." P.<+> c (anon u) (anon v)))) sumR1 t = P.parens (P.pretty "inl" P.<+> t) sumR2 t = P.parens (P.pretty "inr" P.<+> t) + bottomR c = P.pretty "µ" <> P.braces (P.brackets mempty P.<+> P.dot P.<+> c) unitR = P.parens mempty prdR l r = P.tupled [l, r] stringR = P.pretty . show From b39368494f09209701db02c2a3b7e10812e6c781 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 11 Apr 2022 08:40:04 -0400 Subject: [PATCH 1041/1324] Define a selector for Check. --- src/Facet/Functor/Check.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Functor/Check.hs b/src/Facet/Functor/Check.hs index 64085978e..1f0a24212 100644 --- a/src/Facet/Functor/Check.hs +++ b/src/Facet/Functor/Check.hs @@ -8,7 +8,7 @@ import Data.Profunctor -- Check judgement -newtype b <==: a = Check (b -> a) +newtype b <==: a = Check { runCheck :: b -> a } deriving (Applicative, Functor, Monad, Profunctor) infixl 2 <==: From 65ca88059be2c7649b4fda09fda384791ff32f4d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 12 Apr 2022 17:15:29 -0400 Subject: [PATCH 1042/1324] Define a module for elaborating to a sequent. --- facet.cabal | 1 + src/Facet/Elab/Sequent.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Elab/Sequent.hs diff --git a/facet.cabal b/facet.cabal index 3d87f06bd..d06ceda72 100644 --- a/facet.cabal +++ b/facet.cabal @@ -89,6 +89,7 @@ library Facet.Effect.Write Facet.Elab Facet.Elab.Pattern + Facet.Elab.Sequent Facet.Elab.Term Facet.Elab.Type Facet.Env diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs new file mode 100644 index 000000000..f16f30ef6 --- /dev/null +++ b/src/Facet/Elab/Sequent.hs @@ -0,0 +1,2 @@ +module Facet.Elab.Sequent +() where From 5701ed9be204e30bd23335dda876d467ea292323 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 12 Apr 2022 17:21:10 -0400 Subject: [PATCH 1043/1324] Move the variable elaborators into their own module. --- src/Facet/Elab/Sequent.hs | 43 ++++++++++++++++++++++++++++++++++++++- src/Facet/Elab/Term.hs | 22 +------------------- 2 files changed, 43 insertions(+), 22 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index f16f30ef6..74668a10b 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -1,2 +1,43 @@ module Facet.Elab.Sequent -() where +( -- * Variables + globalS +, varS +) where + +import Control.Effect.Reader +import Control.Effect.State +import Control.Effect.Throw +import Control.Effect.Writer +import Facet.Context (level) +import Facet.Elab (ElabContext, ErrReason, context_, freeVariable, instantiate, lookupInContext, resolveQ, use) +import Facet.Functor.Synth +import Facet.Graph +import Facet.Lens as Lens (views) +import Facet.Module +import Facet.Name +import Facet.Sequent.Class as SQ +import Facet.Subst +import Facet.Syntax hiding (context_) +import Facet.Type.Norm +import Facet.Usage + +-- Variables + +-- FIXME: we’re instantiating when inspecting types in the REPL. +globalS :: (Has (State (Subst Type)) sig m, SQ.Sequent t c d, Applicative i) => QName ::: Type -> m (i t :==> Type) +globalS (q ::: _T) = do + v <- SQ.varA (Global q) + (\ (v ::: _T) -> v :==> _T) <$> instantiate const (v ::: _T) + +-- FIXME: do we need to instantiate here to deal with rank-n applications? +-- FIXME: effect ops not in the sig are reported as not in scope +-- FIXME: effect ops in the sig are available whether or not they’re in scope +varS :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m, SQ.Sequent t c d, Applicative i) => QName -> m (i t :==> Type) +varS n = views context_ (lookupInContext n) >>= \case + [(n', Right (q, _T))] -> do + use n' q + d <- views context_ level + SQ.varA (Free (toLeveled d (ident n'))) ==> pure _T + _ -> resolveQ n >>= \case + n :=: DTerm _ _T -> globalS (n ::: _T) + _ :=: _ -> freeVariable n diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index ba8c1402a..e7e397a90 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -7,9 +7,7 @@ module Facet.Elab.Term , as -- * Term combinators , global -, globalS , var -, varS , tlam , lam , lamS @@ -57,7 +55,7 @@ import Data.Monoid (Ap(..), First(..)) import qualified Data.Set as Set import Data.Text (Text) import Data.Traversable (for, mapAccumL) -import Facet.Context (level, toEnv) +import Facet.Context (toEnv) import Facet.Effect.Write import Facet.Elab import Facet.Elab.Type hiding (switch) @@ -116,11 +114,6 @@ as (m ::: _T) = do global :: Has (State (Subst Type)) sig m => QName ::: Type -> m (Term :==> Type) global (q ::: _T) = (\ (v ::: _T) -> v :==> _T) <$> instantiate const (Var (Global q) ::: _T) --- FIXME: we’re instantiating when inspecting types in the REPL. -globalS :: (Has (State (Subst Type)) sig m, SQ.Sequent t c d, Applicative i) => QName ::: Type -> m (i t :==> Type) -globalS (q ::: _T) = do - v <- SQ.varA (Global q) - (\ (v ::: _T) -> v :==> _T) <$> instantiate const (v ::: _T) -- FIXME: do we need to instantiate here to deal with rank-n applications? -- FIXME: effect ops not in the sig are reported as not in scope @@ -132,19 +125,6 @@ var n = views context_ (lookupInContext n) >>= \case n :=: DTerm _ _T -> global (n ::: _T) _ :=: _ -> freeVariable n --- FIXME: do we need to instantiate here to deal with rank-n applications? --- FIXME: effect ops not in the sig are reported as not in scope --- FIXME: effect ops in the sig are available whether or not they’re in scope -varS :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m, SQ.Sequent t c d, Applicative i) => QName -> m (i t :==> Type) -varS n = views context_ (lookupInContext n) >>= \case - [(n', Right (q, _T))] -> do - use n' q - d <- views context_ level - SQ.varA (Free (toLeveled d (ident n'))) ==> pure _T - _ -> resolveQ n >>= \case - n :=: DTerm _ _T -> globalS (n ::: _T) - _ :=: _ -> freeVariable n - hole :: Has (Throw ErrReason) sig m => Name -> Type <==: m a hole n = Check $ \ _T -> withFrozenCallStack $ throwError $ Hole n _T From 8a7efaf98c0be52e9c731c8bd1b1f23f1a80a5b5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 12 Apr 2022 17:28:18 -0400 Subject: [PATCH 1044/1324] Move the lambda constructor into its own module. --- src/Facet/Elab/Sequent.hs | 36 ++++++++++++++++++++++++++++++++++-- src/Facet/Elab/Term.hs | 8 +------- 2 files changed, 35 insertions(+), 9 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 74668a10b..b90b34bbc 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -2,6 +2,12 @@ module Facet.Elab.Sequent ( -- * Variables globalS , varS + -- * Constructors +, lamS + -- * Assertions +, assertTacitFunction + -- * Judgements +, check ) where import Control.Effect.Reader @@ -9,7 +15,9 @@ import Control.Effect.State import Control.Effect.Throw import Control.Effect.Writer import Facet.Context (level) -import Facet.Elab (ElabContext, ErrReason, context_, freeVariable, instantiate, lookupInContext, resolveQ, use) +import Facet.Elab (ElabContext, ErrReason, assertMatch, context_, freeVariable, instantiate, lookupInContext, mismatchTypes, resolveQ, use) +import Facet.Functor.Check +import Facet.Functor.Compose import Facet.Functor.Synth import Facet.Graph import Facet.Lens as Lens (views) @@ -18,7 +26,7 @@ import Facet.Name import Facet.Sequent.Class as SQ import Facet.Subst import Facet.Syntax hiding (context_) -import Facet.Type.Norm +import Facet.Type.Norm as T import Facet.Usage -- Variables @@ -41,3 +49,27 @@ varS n = views context_ (lookupInContext n) >>= \case _ -> resolveQ n >>= \case n :=: DTerm _ _T -> globalS (n ::: _T) _ :=: _ -> freeVariable n + + +-- Constructors + +lamS + :: (Has (Throw ErrReason) sig m, SQ.Sequent t c d, Applicative i) + => (forall j . Applicative j => (i ~> j) -> j t :@ Quantity :==> Type -> j c :@ Quantity :==> Type -> Type <==: m (j d)) + -> Type <==: m (i t) +lamS f = runC $ SQ.lamRA $ \ wk a k -> C $ Check $ \ _T -> do + (_, q, _A, _B) <- assertTacitFunction _T + check (f wk (a :@ q :==> _A) (k :@ q :==> _B) ::: _B) + + +-- Assertions + +-- | Expect a tacit (non-variable-binding) function type. +assertTacitFunction :: Has (Throw ErrReason) sig m => Type -> m (Maybe Name, Quantity, Type, Type) +assertTacitFunction = assertMatch mismatchTypes _Arrow "_ -> _" + + +-- Judgements + +check :: (Type <==: m a) ::: Type -> m a +check (m ::: _T) = m <==: _T diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index e7e397a90..8a0b7daa2 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -10,7 +10,6 @@ module Facet.Elab.Term , var , tlam , lam -, lamS , app , appS , string @@ -61,7 +60,7 @@ import Facet.Elab import Facet.Elab.Type hiding (switch) import qualified Facet.Elab.Type as Type import Facet.Functor.Check -import Facet.Functor.Compose hiding (Clause) + import Facet.Functor.Synth import Facet.Graph import Facet.Interface @@ -144,11 +143,6 @@ lam cs = Check $ \ _T -> do lam1 :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Bind m (Pattern (Name :==> Type)) -> Type <==: m Term -> Type <==: m Term lam1 p b = lam [(p, b)] -lamS :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, SQ.Sequent t c d, Applicative i) => (forall j . Applicative j => (i ~> j) -> (j t :@ Quantity :==> Type) -> (j c :@ Quantity :==> Type) -> (Type <==: m (j d))) -> Type <==: m (i t) -lamS f = runC $ SQ.lamRA $ \ wk a k -> C $ Check $ \ _T -> do - (_, q, _A, _B) <- assertTacitFunction _T - check (f wk (a :@ q :==> _A) (k :@ q :==> _B) ::: _B) - app :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => (a -> b -> c) -> (HasCallStack => m (a :==> Type)) -> (HasCallStack => Type <==: m b) -> m (c :==> Type) app mk operator operand = do f' :==> _F <- operator From 7c3784731e564494799603cff0f586f493034a40 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 12 Apr 2022 17:29:08 -0400 Subject: [PATCH 1045/1324] Move stringS. --- src/Facet/Elab/Sequent.hs | 5 +++++ src/Facet/Elab/Term.hs | 4 ---- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index b90b34bbc..7b46c3c18 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -4,6 +4,7 @@ module Facet.Elab.Sequent , varS -- * Constructors , lamS +, stringS -- * Assertions , assertTacitFunction -- * Judgements @@ -14,6 +15,7 @@ import Control.Effect.Reader import Control.Effect.State import Control.Effect.Throw import Control.Effect.Writer +import Data.Text (Text) import Facet.Context (level) import Facet.Elab (ElabContext, ErrReason, assertMatch, context_, freeVariable, instantiate, lookupInContext, mismatchTypes, resolveQ, use) import Facet.Functor.Check @@ -61,6 +63,9 @@ lamS f = runC $ SQ.lamRA $ \ wk a k -> C $ Check $ \ _T -> do (_, q, _A, _B) <- assertTacitFunction _T check (f wk (a :@ q :==> _A) (k :@ q :==> _B) ::: _B) +stringS :: (Applicative m, SQ.Sequent t c d, Applicative i) => Text -> m (i t :==> Type) +stringS s = SQ.stringRA s ==> pure T.String + -- Assertions diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 8a0b7daa2..8037b321b 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -13,7 +13,6 @@ module Facet.Elab.Term , app , appS , string -, stringS , let' , comp -- * Pattern combinators @@ -161,9 +160,6 @@ appS f a = do string :: Applicative m => Text -> m (Term :==> Type) string s = pure $ E.String s :==> T.String -stringS :: (Applicative m, SQ.Sequent t c d, Applicative i) => Text -> m (i t :==> Type) -stringS s = SQ.stringRA s ==> pure T.String - let' :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Bind m (Pattern (Name :==> Type)) -> m (Term :==> Type) -> Type <==: m Term -> Type <==: m Term let' p a b = Check $ \ _B -> do From 927ceb440d7938fb1da8d38b23e42c03b28ed75e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 12 Apr 2022 17:31:00 -0400 Subject: [PATCH 1046/1324] Move appS. --- src/Facet/Elab/Sequent.hs | 16 +++++++++++++++- src/Facet/Elab/Term.hs | 9 --------- 2 files changed, 15 insertions(+), 10 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 7b46c3c18..f5c597053 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -5,6 +5,8 @@ module Facet.Elab.Sequent -- * Constructors , lamS , stringS + -- * Eliminators +, appS -- * Assertions , assertTacitFunction -- * Judgements @@ -17,7 +19,7 @@ import Control.Effect.Throw import Control.Effect.Writer import Data.Text (Text) import Facet.Context (level) -import Facet.Elab (ElabContext, ErrReason, assertMatch, context_, freeVariable, instantiate, lookupInContext, mismatchTypes, resolveQ, use) +import Facet.Elab (ElabContext, ErrReason, assertFunction, assertMatch, context_, freeVariable, instantiate, lookupInContext, mismatchTypes, resolveQ, use) import Facet.Functor.Check import Facet.Functor.Compose import Facet.Functor.Synth @@ -25,11 +27,13 @@ import Facet.Graph import Facet.Lens as Lens (views) import Facet.Module import Facet.Name +import Facet.Semiring import Facet.Sequent.Class as SQ import Facet.Subst import Facet.Syntax hiding (context_) import Facet.Type.Norm as T import Facet.Usage +import GHC.Stack (HasCallStack) -- Variables @@ -67,6 +71,16 @@ stringS :: (Applicative m, SQ.Sequent t c d, Applicative i) => Text -> m (i t := stringS s = SQ.stringRA s ==> pure T.String +-- Eliminators + +appS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m, SQ.Sequent t c d, Applicative i) => (HasCallStack => m (i t :==> Type)) -> (HasCallStack => Type <==: m (i t)) -> m (i t :==> Type) +appS f a = do + f' :==> _F <- f + (_, q, _A, _B) <- assertFunction _F + a' <- censor @Usage (q ><<) $ check (a ::: _A) + (:==> _B) <$> SQ.µRA (\ wk k -> pure (wk f') SQ..||. SQ.lamLA (pure (wk a')) (pure k)) + + -- Assertions -- | Expect a tacit (non-variable-binding) function type. diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 8037b321b..0662a1b53 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -11,7 +11,6 @@ module Facet.Elab.Term , tlam , lam , app -, appS , string , let' , comp @@ -69,7 +68,6 @@ import Facet.Module as Module import Facet.Name import Facet.Pattern import Facet.Semiring (Few(..), (><<)) -import qualified Facet.Sequent.Class as SQ import Facet.Snoc import Facet.Snoc.NonEmpty as NE import Facet.Source (Source) @@ -149,13 +147,6 @@ app mk operator operand = do a' <- censor @Usage (q ><<) $ check (operand ::: _A) pure $ mk f' a' :==> _B -appS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m, SQ.Sequent t c d, Applicative i) => (HasCallStack => m (i t :==> Type)) -> (HasCallStack => Type <==: m (i t)) -> m (i t :==> Type) -appS f a = do - f' :==> _F <- f - (_, q, _A, _B) <- assertFunction _F - a' <- censor @Usage (q ><<) $ check (a ::: _A) - (:==> _B) <$> SQ.µRA (\ wk k -> pure (wk f') SQ..||. SQ.lamLA (pure (wk a')) (pure k)) - string :: Applicative m => Text -> m (Term :==> Type) string s = pure $ E.String s :==> T.String From 25293d7555185071d2bc7533aedffaa572bce491 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 12 Apr 2022 17:45:55 -0400 Subject: [PATCH 1047/1324] Apply unifications locally. --- src/Facet/Elab/Term.hs | 34 +++++++++++++++------------------- src/Facet/Unify.hs | 6 +++--- 2 files changed, 18 insertions(+), 22 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 0662a1b53..05497e6b9 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -52,7 +52,6 @@ import Data.Monoid (Ap(..), First(..)) import qualified Data.Set as Set import Data.Text (Text) import Data.Traversable (for, mapAccumL) -import Facet.Context (toEnv) import Facet.Effect.Write import Facet.Elab import Facet.Elab.Type hiding (switch) @@ -92,12 +91,12 @@ import GHC.Stack -- General combinators -switch :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => m (a :==> Type) -> Type <==: m a +switch :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => m (a :==> Type) -> Type <==: m a switch m = Check $ \ _Exp -> m >>= \case a :==> T.Comp req _Act -> require req >> unify (Exp _Exp) (Act _Act) $> a a :==> _Act -> unify (Exp _Exp) (Act _Act) $> a -as :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m) => (Type <==: m a) ::: m (Type :==> Kind) -> m (a :==> Type) +as :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => (Type <==: m a) ::: m (Type :==> Kind) -> m (a :==> Type) as (m ::: _T) = do _T' <- Type.switch _T <==: KType a <- check (m ::: _T') @@ -126,21 +125,21 @@ hole :: Has (Throw ErrReason) sig m => Name -> Type <==: m a hole n = Check $ \ _T -> withFrozenCallStack $ throwError $ Hole n _T -tlam :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m) => Type <==: m Term -> Type <==: m Term +tlam :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => Type <==: m Term -> Type <==: m Term tlam b = Check $ \ _T -> do (n, _A, _B) <- assertQuantifier _T d <- depth n :==> _A ||- check (b ::: _B (T.free (LName d n))) -lam :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => [(Bind m (Pattern (Name :==> Type)), Type <==: m Term)] -> Type <==: m Term +lam :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => [(Bind m (Pattern (Name :==> Type)), Type <==: m Term)] -> Type <==: m Term lam cs = Check $ \ _T -> do (_, q, _A, _B) <- assertTacitFunction _T Lam <$> traverse (\ (p, b) -> bind (p ::: (q, _A)) (check (b ::: _B))) cs -lam1 :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Bind m (Pattern (Name :==> Type)) -> Type <==: m Term -> Type <==: m Term +lam1 :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Bind m (Pattern (Name :==> Type)) -> Type <==: m Term -> Type <==: m Term lam1 p b = lam [(p, b)] -app :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => (a -> b -> c) -> (HasCallStack => m (a :==> Type)) -> (HasCallStack => Type <==: m b) -> m (c :==> Type) +app :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => (a -> b -> c) -> (HasCallStack => m (a :==> Type)) -> (HasCallStack => Type <==: m b) -> m (c :==> Type) app mk operator operand = do f' :==> _F <- operator (_, q, _A, _B) <- assertFunction _F @@ -152,14 +151,14 @@ string :: Applicative m => Text -> m (Term :==> Type) string s = pure $ E.String s :==> T.String -let' :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Bind m (Pattern (Name :==> Type)) -> m (Term :==> Type) -> Type <==: m Term -> Type <==: m Term +let' :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Bind m (Pattern (Name :==> Type)) -> m (Term :==> Type) -> Type <==: m Term -> Type <==: m Term let' p a b = Check $ \ _B -> do a' :==> _A <- a (p', b') <- bind (p ::: (Many, _A)) (check (b ::: _B)) pure $ Let p' a' b' -comp :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Type <==: m Term -> Type <==: m Term +comp :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Type <==: m Term -> Type <==: m Term comp b = Check $ \ _T -> do (sig, _B) <- assertComp _T graph <- ask @@ -184,7 +183,7 @@ varP n = Bind $ \ _A k -> k (PVar (n :==> wrap _A)) T.Comp sig _A -> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] |> T "Unit")) Nil) (T.Comp sig _A) _T -> _T -conP :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => QName -> [Bind m (Pattern (Name :==> Type))] -> Bind m (Pattern (Name :==> Type)) +conP :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => QName -> [Bind m (Pattern (Name :==> Type))] -> Bind m (Pattern (Name :==> Type)) conP n fs = Bind $ \ _A k -> do n' :=: _ ::: _T <- resolveC n _T' <- maybe (pure _T) (foldl' (\ _T _A -> do t <- _T ; (_, _, b) <- assertQuantifier t ; pure (b _A)) (pure _T) . snd) (unNeutral _A) @@ -258,7 +257,7 @@ abstractType body = \case KArrow (Just n) a b -> TX.ForAll n a <$> (n :==> a ||- abstractType body b) _ -> body -abstractTerm :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => (Snoc TX.Type -> Snoc Term -> Term) -> Type <==: m Term +abstractTerm :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => (Snoc TX.Type -> Snoc Term -> Term) -> Type <==: m Term abstractTerm body = go Nil Nil where go ts fs = Check $ \case @@ -391,16 +390,13 @@ withSpan k (S.Ann s _ a) = pushSpan s (k a) withCallStack :: CallStack -> (HasCallStack => a) -> a withCallStack cs with = let ?callStack = cs in with -provide :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m) => Signature Type -> m a -> m a -provide sig m = do - subst <- get - env <- views context_ toEnv - locally sig_ (mapSignature (apply subst env) sig :) m +provide :: Has (Reader ElabContext) sig m => Signature Type -> m a -> m a +provide sig m = locally sig_ (sig :) m -require :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Signature Type -> m () +require :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Signature Type -> m () require req = do prv <- Lens.view sig_ - for_ (interfaces req) $ \ i -> findMaybeA (findMaybeA (runUnifyMaybe . unifyInterface i) . interfaces) prv >>= \case + for_ (interfaces req) $ \ i -> findMaybeA (findMaybeA (runUnifyMaybe . runState (const pure) (mempty :: Subst Type) . unifyInterface i) . interfaces) prv >>= \case Nothing -> missingInterface i Just _ -> pure () @@ -410,7 +406,7 @@ findMaybeA p = getAp . fmap getFirst . foldMap (Ap . fmap First . p) -- Judgements -check :: (Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m) => ((Type <==: m a) ::: Type) -> m a +check :: Has (Reader ElabContext) sig m => ((Type <==: m a) ::: Type) -> m a check (m ::: _T) = case _T of T.Comp sig _T -> provide sig $ m <==: _T _T -> m <==: _T diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index cbcb8f6e4..b83d23a20 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -12,8 +12,8 @@ module Facet.Unify import Control.Carrier.Empty.Church import Control.Carrier.Error.Church +import Control.Carrier.State.Church import Control.Effect.Reader -import Control.Effect.State import Control.Effect.Sum import Control.Effect.Writer import Control.Monad (unless) @@ -36,8 +36,8 @@ import GHC.Stack -- Unification -- FIXME: we don’t get good source references during unification -unify :: (HasCallStack, Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Exp Type -> Act Type -> m Type -unify t1 t2 = runUnify t1 t2 (unifyType (getExp t1) (getAct t2)) +unify :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Exp Type -> Act Type -> m Type +unify t1 t2 = runUnify t1 t2 (runState (const pure) (mempty :: Subst Type) (unifyType (getExp t1) (getAct t2))) runUnify :: Has (Throw ErrReason) sig m => Exp Type -> Act Type -> ThrowC ErrReason (WithCallStack UnifyErrReason) m a -> m a runUnify t1 t2 = runThrow (withCallStack (\ r -> throwError (UnifyType r (Right <$> t1) t2))) From 1e681dd8c7d86026c6211caabc6d168adcb0b68c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 12 Apr 2022 20:43:12 -0400 Subject: [PATCH 1048/1324] Move withSpan & withSpanC. --- src/Facet/Elab.hs | 11 +++++++++++ src/Facet/Elab/Term.hs | 6 ------ 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index ecc665f56..867f7dd67 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -16,6 +16,8 @@ module Facet.Elab , (||-) -- * Errors , pushSpan +, withSpanC +, withSpan , Err(..) , ErrReason(..) , _FreeVariable @@ -67,6 +69,7 @@ import Facet.Context hiding (empty) import qualified Facet.Context as Context (empty) import Facet.Effect.Write import qualified Facet.Env as Env +import Facet.Functor.Check import Facet.Functor.Synth import Facet.Graph as Graph import Facet.Interface @@ -83,6 +86,7 @@ import Facet.Source (Source, slice) import Facet.Span (Span(..)) import Facet.Subst import Facet.Syntax hiding (context_) +import qualified Facet.Syntax as S import Facet.Term.Expr as E import qualified Facet.Type.Expr as TX import Facet.Type.Norm as TN @@ -194,6 +198,13 @@ use n q = do pushSpan :: Has (Reader ElabContext) sig m => Span -> m a -> m a pushSpan = locally spans_ . flip (:>) +withSpanC :: Has (Reader ElabContext) sig m => S.Ann a -> (a -> Type <==: m b) -> Type <==: m b +withSpanC (S.Ann s _ a) k = Check (\ _T -> pushSpan s (k a <==: _T)) + +withSpan :: Has (Reader ElabContext) sig m => (a -> m b) -> S.Ann a -> m b +withSpan k (S.Ann s _ a) = pushSpan s (k a) + + data Err = Err { source :: Source diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 05497e6b9..b22872972 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -381,12 +381,6 @@ runModule m = do withSpanB :: Has (Reader ElabContext) sig m => (a -> Bind m b) -> S.Ann a -> Bind m b withSpanB k (S.Ann s _ a) = Bind (\ _A k' -> pushSpan s (runBind (k a) _A k')) -withSpanC :: Has (Reader ElabContext) sig m => S.Ann a -> (a -> Type <==: m b) -> Type <==: m b -withSpanC (S.Ann s _ a) k = Check (\ _T -> pushSpan s (k a <==: _T)) - -withSpan :: Has (Reader ElabContext) sig m => (a -> m b) -> S.Ann a -> m b -withSpan k (S.Ann s _ a) = pushSpan s (k a) - withCallStack :: CallStack -> (HasCallStack => a) -> a withCallStack cs with = let ?callStack = cs in with From 9e718d8eb5ccbd68ee8bc6837201529240891388 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 13 Apr 2022 09:01:40 -0400 Subject: [PATCH 1049/1324] Simplify unification constraints. --- src/Facet/Unify.hs | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index b83d23a20..aa90812d0 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -14,7 +14,6 @@ import Control.Carrier.Empty.Church import Control.Carrier.Error.Church import Control.Carrier.State.Church import Control.Effect.Reader -import Control.Effect.Sum import Control.Effect.Writer import Control.Monad (unless) import Facet.Carrier.Throw.Inject @@ -45,13 +44,13 @@ runUnify t1 t2 = runThrow (withCallStack (\ r -> throwError (UnifyType r (Right runUnifyMaybe :: Applicative m => ErrorC (WithCallStack UnifyErrReason) m a -> m (Maybe a) runUnifyMaybe = runError (const (pure Nothing)) (pure . Just) -mismatch :: (HasCallStack, Has (Reader ElabContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => m a +mismatch :: (HasCallStack, Has (Throw (WithCallStack UnifyErrReason)) sig m) => m a mismatch = withFrozenCallStack $ throwError $ WithCallStack GHC.Stack.callStack Mismatch -occurs :: (HasCallStack, Has (Reader ElabContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Type -> m a +occurs :: (HasCallStack, Has (Throw (WithCallStack UnifyErrReason)) sig m) => Meta -> Type -> m a occurs v t = withFrozenCallStack $ throwError $ WithCallStack GHC.Stack.callStack (Occurs v t) -unifyType :: (HasCallStack, Has (Reader ElabContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Type -> Type -> m Type +unifyType :: (HasCallStack, Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Throw (WithCallStack UnifyErrReason)) sig m, Has (Writer Usage) sig m) => Type -> Type -> m Type unifyType = curry $ \case (TN.Comp s1 t1, TN.Comp s2 t2) -> TN.Comp . fromInterfaces <$> unifySpine unifyInterface (interfaces s1) (interfaces s2) <*> unifyType t1 t2 (TN.Comp s1 t1, t2) -> TN.Comp s1 <$> unifyType t1 t2 @@ -70,19 +69,19 @@ unifyType = curry $ \case where mkForAll d n k b = TX.ForAll n k (runQuoter (succ d) (quote b)) -unifyKind :: Has (Reader ElabContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m => Kind -> Kind -> m Kind +unifyKind :: (Has (Throw (WithCallStack UnifyErrReason)) sig m) => Kind -> Kind -> m Kind unifyKind k1 k2 = if k1 == k2 then pure k2 else mismatch -unifyVar :: (Eq a, Eq b, HasCallStack, Has (Reader ElabContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Var (Either a b) -> Var (Either a b) -> m (Var (Either a b)) +unifyVar :: (Eq a, Eq b, HasCallStack, Has (Throw (WithCallStack UnifyErrReason)) sig m) => Var (Either a b) -> Var (Either a b) -> m (Var (Either a b)) unifyVar v1 v2 = if v1 == v2 then pure v2 else mismatch -unifyInterface :: (HasCallStack, Has (Reader ElabContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Interface Type -> Interface Type -> m (Interface Type) +unifyInterface :: (HasCallStack, Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Throw (WithCallStack UnifyErrReason)) sig m, Has (Writer Usage) sig m) => Interface Type -> Interface Type -> m (Interface Type) unifyInterface (Interface h1 sp1) (Interface h2 sp2) = Interface h2 <$ unless (h1 == h2) mismatch <*> unifySpine unifyType sp1 sp2 -unifySpine :: (Traversable t, Zip t, Has (Reader ElabContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => (a -> b -> m c) -> t a -> t b -> m (t c) +unifySpine :: (Traversable t, Zip t, Has (Throw (WithCallStack UnifyErrReason)) sig m) => (a -> b -> m c) -> t a -> t b -> m (t c) unifySpine f sp1 sp2 = unless (length sp1 == length sp2) mismatch >> zipWithM f sp1 sp2 -flexFlex :: (HasCallStack, Has (Reader ElabContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Meta -> m Type +flexFlex :: (HasCallStack, Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Throw (WithCallStack UnifyErrReason)) sig m, Has (Writer Usage) sig m) => Meta -> Meta -> m Type flexFlex v1 v2 | v1 == v2 = pure (metavar v2) | otherwise = gets (\ s -> (lookupMeta v1 s, lookupMeta v2 s)) >>= \case @@ -91,7 +90,7 @@ flexFlex v1 v2 (Nothing, Just t2) -> unifyType (metavar v1) t2 (Nothing, Nothing) -> solve v1 (metavar v2) -solve :: (HasCallStack, Has (Reader ElabContext :+: State (Subst Type) :+: Throw ErrReason :+: Throw (WithCallStack UnifyErrReason) :+: Writer Usage) sig m) => Meta -> Type -> m Type +solve :: (HasCallStack, Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Throw (WithCallStack UnifyErrReason)) sig m, Has (Writer Usage) sig m) => Meta -> Type -> m Type solve v t = do d <- depth if occursIn v d t then From 12dff6f37fb0e7daa5e8dc2503657b61fd2e4057 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 13 Apr 2022 09:16:19 -0400 Subject: [PATCH 1050/1324] Define bidirectional elaboration to sequents. --- src/Facet/Elab/Sequent.hs | 105 ++++++++++++++++++++++++++++++-------- 1 file changed, 84 insertions(+), 21 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index f5c597053..6f3bc97a1 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ImplicitParams #-} module Facet.Elab.Sequent ( -- * Variables globalS @@ -7,33 +8,42 @@ module Facet.Elab.Sequent , stringS -- * Eliminators , appS + -- * Elaboration +, synthExprS +, checkExprS -- * Assertions , assertTacitFunction -- * Judgements , check ) where -import Control.Effect.Reader -import Control.Effect.State -import Control.Effect.Throw -import Control.Effect.Writer -import Data.Text (Text) -import Facet.Context (level) -import Facet.Elab (ElabContext, ErrReason, assertFunction, assertMatch, context_, freeVariable, instantiate, lookupInContext, mismatchTypes, resolveQ, use) -import Facet.Functor.Check -import Facet.Functor.Compose -import Facet.Functor.Synth -import Facet.Graph -import Facet.Lens as Lens (views) -import Facet.Module -import Facet.Name -import Facet.Semiring -import Facet.Sequent.Class as SQ -import Facet.Subst -import Facet.Syntax hiding (context_) -import Facet.Type.Norm as T -import Facet.Usage -import GHC.Stack (HasCallStack) +import Control.Effect.Reader +import Control.Effect.State +import Control.Effect.Throw +import Control.Effect.Writer +import Data.Text (Text) +import Facet.Context (level) +import Facet.Effect.Write +import Facet.Elab +import qualified Facet.Elab.Type as Type +import Facet.Functor.Check +import Facet.Functor.Compose +import Facet.Functor.Synth +import Facet.Graph +import Facet.Kind +import Facet.Lens as Lens (views) +import Facet.Module +import Facet.Name +import Facet.Semiring +import Facet.Sequent.Class as SQ +import Facet.Subst +import qualified Facet.Surface.Term.Expr as S +import qualified Facet.Surface.Type.Expr as S +import Facet.Syntax as S hiding (context_) +import Facet.Type.Norm as T +import Facet.Unify +import Facet.Usage +import GHC.Stack (HasCallStack, callStack, popCallStack, withFrozenCallStack) -- Variables @@ -56,6 +66,9 @@ varS n = views context_ (lookupInContext n) >>= \case n :=: DTerm _ _T -> globalS (n ::: _T) _ :=: _ -> freeVariable n +hole :: Has (Throw ErrReason) sig m => Name -> Type <==: m a +hole n = Check $ \ _T -> withFrozenCallStack $ throwError $ Hole n _T + -- Constructors @@ -81,6 +94,56 @@ appS f a = do (:==> _B) <$> SQ.µRA (\ wk k -> pure (wk f') SQ..||. SQ.lamLA (pure (wk a')) (pure k)) +-- General combinators + +switch :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => m (a :==> Type) -> Type <==: m a +switch m = Check $ \ _Exp -> do + a :==> _Act <- m + a <$ unify (Exp _Exp) (Act _Act) + +as :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => (Type <==: m a) ::: m (Type :==> Kind) -> m (a :==> Type) +as (m ::: _T) = do + _T' <- Type.switch _T <==: KType + a <- check (m ::: _T') + pure $ a :==> _T' + + +-- Elaboration + +synthExprS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, Has (Writer Usage) sig m, SQ.Sequent t c d, Applicative i) => S.Ann S.Expr -> m (i t :==> Type) +synthExprS = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \case + S.Var n -> varS n + S.App f a -> synthApp f a + S.As t _T -> synthAs t _T + S.String s -> stringS s + S.Hole{} -> nope + S.Lam{} -> nope + where + nope = couldNotSynthesize + +synthApp :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, Has (Writer Usage) sig m, SQ.Sequent t c d, Applicative i) => S.Ann S.Expr -> S.Ann S.Expr -> m (i t :==> Type) +synthApp f a = appS (synthExprS f) (checkExprS a) + +synthAs :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, Has (Writer Usage) sig m, SQ.Sequent t c d, Applicative i) => S.Ann S.Expr -> S.Ann S.Type -> m (i t :==> Type) +synthAs t _T = as (checkExprS t ::: do { _T :==> _K <- Type.synthType _T ; (:==> _K) <$> evalTExpr _T }) + + +checkExprS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, Has (Writer Usage) sig m, SQ.Sequent t c d, Applicative i) => S.Ann S.Expr -> Type <==: m (i t) +checkExprS expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC expr $ \case + S.Hole n -> hole n + S.Lam cs -> checkLamS (Check (\ _T -> map (\ (S.Clause (S.Ann _ _ p) b) -> (p, check (checkExprS b ::: _T))) cs)) + S.Var{} -> switch (synthExprS expr) + S.App{} -> switch (synthExprS expr) + S.As{} -> switch (synthExprS expr) + S.String{} -> switch (synthExprS expr) + +checkLamS + :: Has (Throw ErrReason) sig m + => Type <==: [(S.Pattern, m (i t))] + -> Type <==: m (i t) +checkLamS _ = Check (\ _T -> mismatchTypes (Exp (Left "unimplemented")) (Act _T)) + + -- Assertions -- | Expect a tacit (non-variable-binding) function type. From 14637f306fe0151354ebf6ed77c1d7bbf283929e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 13 Apr 2022 15:29:28 -0400 Subject: [PATCH 1051/1324] N-ary sums. --- src/Facet/Sequent/Class.hs | 10 ++++------ src/Facet/Sequent/Expr.hs | 20 ++++++++------------ src/Facet/Sequent/Norm.hs | 13 +++++-------- src/Facet/Sequent/Print.hs | 5 ++--- 4 files changed, 19 insertions(+), 29 deletions(-) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index 20f217894..b14bcd4d5 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -37,8 +37,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma var :: Var Level -> term µR :: (coterm -> command) -> term lamR :: (term -> coterm -> command) -> term - sumR1 :: term -> term - sumR2 :: term -> term + sumR :: Int -> term -> term bottomR :: command -> term unitR :: term prdR :: term -> term -> term @@ -48,7 +47,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma covar :: Var Level -> coterm µL :: (term -> command) -> coterm lamL :: term -> coterm -> coterm - sumL :: coterm -> coterm -> coterm + sumL :: [coterm] -> coterm unitL :: coterm prdL1 :: coterm -> coterm prdL2 :: coterm -> coterm @@ -111,10 +110,9 @@ infixr 9 .$$. sumLA :: (Sequent t c d, Applicative i, Applicative m) - => m (i c) - -> m (i c) + => m (i [c]) -> m (i c) -sumLA = liftA2 (liftA2 sumL) +sumLA = fmap (fmap sumL) -- sumLA -- :: (Sequent t c d, Applicative i, Applicative m) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 60dd16b76..3dcc897a8 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -24,8 +24,7 @@ data Term = Var (Var Index) | MuR Command | LamR Command - | SumR1 Term - | SumR2 Term + | SumR Int Term | BottomR Command | UnitR | PrdR Term Term @@ -38,7 +37,7 @@ data Coterm = Covar (Var Index) | MuL Command | LamL Term Coterm - | SumL Coterm Coterm + | SumL [Coterm] | UnitL | PrdL1 Coterm | PrdL2 Coterm @@ -55,8 +54,7 @@ instance Applicative m => C.Sequent (QuoterT m Term) (QuoterT m Coterm) (QuoterT var inner = QuoterT (\ outer -> pure (Var (toIndexed outer inner))) µR body = MuR <$> binderT (C.covar . Free) body lamR body = LamR <$> binderT (C.var . Free) (binderT (C.covar . Free) . body) - sumR1 = fmap SumR1 - sumR2 = fmap SumR2 + sumR = fmap . SumR bottomR = fmap BottomR unitR = pure UnitR prdR = liftA2 PrdR @@ -65,7 +63,7 @@ instance Applicative m => C.Sequent (QuoterT m Term) (QuoterT m Coterm) (QuoterT covar inner = QuoterT (\ outer -> pure (Covar (toIndexed outer inner))) µL body = MuL <$> binderT (C.var . Free) body lamL = liftA2 LamL - sumL = liftA2 SumL + sumL = fmap SumL . sequenceA unitL = pure UnitL prdL1 = fmap PrdL1 prdL2 = fmap PrdL2 @@ -77,8 +75,7 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where var v = Quoter (\ d -> Var (toIndexed d v)) µR b = MuR <$> binder (\ d' -> Quoter (\ d -> covar (toIndexed d d'))) b lamR b = LamR <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) (binder (\ d'' -> Quoter (\ d -> covar (toIndexed d d''))) . b) - sumR1 = fmap SumR1 - sumR2 = fmap SumR2 + sumR = fmap . SumR bottomR = fmap BottomR unitR = pure UnitR prdR = liftA2 PrdR @@ -87,7 +84,7 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where covar v = Quoter (\ d -> Covar (toIndexed d v)) µL b = MuL <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b lamL = liftA2 LamL - sumL = liftA2 SumL + sumL = fmap SumL . sequenceA unitL = pure UnitL prdL1 = fmap PrdL1 prdL2 = fmap PrdL2 @@ -110,8 +107,7 @@ interpretTerm _G _D = \case Var (Global n) -> C.var (Global n) MuR b -> C.µR (\ k -> interpretCommand _G (k:_D) b) LamR b -> C.lamR (\ a k -> interpretCommand (a:_G) (k:_D) b) - SumR1 t -> C.sumR1 (interpretTerm _G _D t) - SumR2 t -> C.sumR2 (interpretTerm _G _D t) + SumR i t -> C.sumR i (interpretTerm _G _D t) BottomR c -> C.bottomR (interpretCommand _G _D c) UnitR -> C.unitR PrdR l r -> C.prdR (interpretTerm _G _D l) (interpretTerm _G _D r) @@ -123,7 +119,7 @@ interpretCoterm _G _D = \case Covar (Global n) -> C.covar (Global n) MuL b -> C.µL (\ t -> interpretCommand (t:_G) _D b) LamL a k -> C.lamL (interpretTerm _G _D a) (interpretCoterm _G _D k) - SumL l r -> C.sumL (interpretCoterm _G _D l) (interpretCoterm _G _D r) + SumL cs -> C.sumL (interpretCoterm _G _D <$> cs) UnitL -> C.unitL PrdL1 c -> C.prdL1 (interpretCoterm _G _D c) PrdL2 c -> C.prdL2 (interpretCoterm _G _D c) diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index 5ca00e5fa..051195735 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -21,8 +21,7 @@ data Term = Var (Var Level) | MuR (Coterm -> Command) | LamR (Term -> Coterm -> Command) - | SumR1 Term - | SumR2 Term + | SumR Int Term | BottomR Command | UnitR | PrdR Term Term @@ -35,7 +34,7 @@ data Coterm = Covar (Var Level) | MuL (Term -> Command) | LamL Term Coterm - | SumL Coterm Coterm + | SumL [Coterm] | UnitL | PrdL1 Coterm | PrdL2 Coterm @@ -52,8 +51,7 @@ instance Class.Sequent Term Coterm Command where var = Var µR = MuR lamR = LamR - sumR1 = SumR1 - sumR2 = SumR2 + sumR = SumR bottomR = BottomR unitR = UnitR prdR = PrdR @@ -76,8 +74,7 @@ instance Quote Term X.Term where Var v -> Quoter (\ d -> X.Var (toIndexed d v)) MuR b -> X.MuR <$> quoteBinder (Quoter (Covar . Free)) b LamR b -> X.LamR <$> Quoter (\ d -> runQuoter (d + 2) (quote (b (Var (Free d)) (Covar (Free (d + 1)))))) - SumR1 t -> X.SumR1 <$> quote t - SumR2 t -> X.SumR2 <$> quote t + SumR i t -> X.SumR i <$> quote t BottomR c -> X.BottomR <$> quote c UnitR -> pure X.UnitR PrdR l r -> X.PrdR <$> quote l <*> quote r @@ -92,7 +89,7 @@ instance Quote Coterm X.Coterm where Covar v -> Quoter (\ d -> X.Covar (toIndexed d v)) MuL b -> X.MuL <$> quoteBinder (Quoter var) b LamL a b -> liftA2 X.LamL (quote a) (quote b) - SumL l r -> X.SumL <$> quote l <*> quote r + SumL cs -> X.SumL <$> traverse quote cs UnitL -> pure X.UnitL PrdL1 k -> X.PrdL1 <$> quote k PrdL2 k -> X.PrdL2 <$> quote k diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index c67abf3e9..be78fade3 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -28,8 +28,7 @@ instance S.Sequent Print Print Print where var = var µR b = P.pretty "µ" <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) lamR c = P.pretty "λ" <> P.braces (fresh (\ u -> fresh (\ v -> anon u <> P.comma P.<+> anon v P.<+> P.pretty "." P.<+> c (anon u) (anon v)))) - sumR1 t = P.parens (P.pretty "inl" P.<+> t) - sumR2 t = P.parens (P.pretty "inr" P.<+> t) + sumR i t = P.parens (P.pretty "in" <> subscript i P.<+> t) bottomR c = P.pretty "µ" <> P.braces (P.brackets mempty P.<+> P.dot P.<+> c) unitR = P.parens mempty prdR l r = P.tupled [l, r] @@ -38,7 +37,7 @@ instance S.Sequent Print Print Print where covar = var µL b = µ̃ <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) lamL a k = a P.<+> P.dot P.<+> k - sumL l r = P.pretty "case" <> P.braces (commaSep [l, r]) + sumL cs = P.pretty "case" <> P.braces (commaSep (map (\ (i, c) -> P.pretty "in" <> subscript i P.<+> P.pretty "->" P.<+> c) (zip [0..] cs))) unitL = P.pretty "_" prdL1 k = P.parens (µ̃ <> P.braces (P.pretty "πl" P.<+> k)) prdL2 k = P.parens (µ̃ <> P.braces (P.pretty "πr" P.<+> k)) From 4faf3e4aa8c70075e6539e19f5450b443c143d88 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 13 Apr 2022 18:19:50 -0400 Subject: [PATCH 1052/1324] :fire: the un-Def functions. --- src/Facet/Elab/Term.hs | 3 ++- src/Facet/Module.hs | 18 +++--------------- 2 files changed, 5 insertions(+), 16 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index b22872972..0ff98b07c 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -81,6 +81,7 @@ import Facet.Type.Norm as T hiding (global) import Facet.Unify import Facet.Usage hiding (restrict) import Fresnel.At as At +import Fresnel.Fold (preview) import Fresnel.Getter as Getter (view) import Fresnel.Ixed import Fresnel.Prism (Prism') @@ -164,7 +165,7 @@ comp b = Check $ \ _T -> do graph <- ask module' <- ask let interfacePattern :: Has (Throw ErrReason) sig m => Interface Type -> m (QName :=: (Name :==> Type)) - interfacePattern (Interface n _) = maybe (freeVariable n) (\ (n' :=: _T) -> pure ((n |> n') :=: (n' :==> _T))) (listToMaybe (scopeToList . Getter.view tm_ =<< unDInterface . Getter.view def_ =<< lookupQ graph module' n)) + interfacePattern (Interface n _) = maybe (freeVariable n) (\ (n' :=: _T) -> pure ((n |> n') :=: (n' :==> _T))) (listToMaybe (scopeToList . Getter.view tm_ =<< maybe [] pure . preview _DInterface . Getter.view def_ =<< lookupQ graph module' n)) p' <- traverse interfacePattern (interfaces sig) -- FIXME: can we apply quantities to dictionaries? what would they mean? b' <- (Many, PDict p') |- check (b ::: _B) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index fa8633f77..4c4bac4c1 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -20,9 +20,6 @@ module Facet.Module , _SInterface , _SModule , Def(..) -, unDTerm -, unDData -, unDInterface , _DSubmodule , _DData , _DInterface @@ -89,14 +86,14 @@ foldMapC f = getChoosing #. foldMap (Choosing #. f) lookupC :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Maybe Term ::: Type) lookupC n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) where - matchDef = matchTerm <=< lookupScope n . view tm_ <=< unDData - matchTerm (n :=: d) = (name |> n :=:) <$> unDTerm d + matchDef = matchTerm <=< lookupScope n . view tm_ <=< maybe empty pure . preview _DData + matchTerm (n :=: d) = (name |> n :=:) <$> maybe empty pure (preview _DTerm d) -- | Look up effect operations. lookupE :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Def) lookupE n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) where - matchDef = fmap (bimap (name |>) (DTerm Nothing)) . lookupScope n . view tm_ <=< unDInterface + matchDef = fmap (bimap (name |>) (DTerm Nothing)) . lookupScope n . view tm_ <=< maybe empty pure . preview _DInterface lookupD :: Has Empty sig m => Name -> Module -> m (QName :=: Def) lookupD n Module{ name, scope } = maybe empty (pure . first (name |>)) (lookupScope n scope) @@ -149,15 +146,6 @@ data Def = DTerm (Maybe Term) Type | DSubmodule Submodule Kind -unDTerm :: Has Empty sig m => Def -> m (Maybe Term ::: Type) -unDTerm = maybe empty pure . preview _DTerm - -unDData :: Has Empty sig m => Def -> m (Scope Def ::: Kind) -unDData = maybe empty pure . preview _DData - -unDInterface :: Has Empty sig m => Def -> m (Scope Type ::: Kind) -unDInterface = maybe empty pure . preview _DInterface - _DTerm :: Prism' Def (Maybe Term ::: Type) _DTerm = prism' (\ (t ::: _T) -> DTerm t _T) (\case DTerm t _T -> Just (t ::: _T) From dfdc24ea9a44455a0a410d3d58b9fbea2493c26e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 13 Apr 2022 18:20:34 -0400 Subject: [PATCH 1053/1324] Fix pattern elaboration. --- src/Facet/Elab/Pattern.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index b1e534f06..8bcbb7639 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -64,9 +64,8 @@ compileClausesBody ctx _A _T heads v k = case _A of _ -> empty _ -> empty) v C..|. C.sumL - -- FIXME: n-ary sums - (C.µL (\ v -> compileClausesBody ctx _A _T (heads' `at` 0) v k)) - (C.µL (\ v -> compileClausesBody ctx _B _T (heads' `at` 1) v k)) + [ C.µL (\ v -> compileClausesBody ctx _A _T (heads' `at` 0) v k) + , C.µL (\ v -> compileClausesBody ctx _B _T (heads' `at` 1) v k) ] match :: Has Empty sig m => Fold (Pattern Name) [Pattern Name] -> [Clause X.Term] -> m [Clause X.Term] From bf542955a76843708dd42e742bfece0e7edb027a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 13 Apr 2022 18:29:13 -0400 Subject: [PATCH 1054/1324] Get the first element using fresnel. --- src/Facet/Elab/Pattern.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 8bcbb7639..97d2b04d3 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -13,7 +13,6 @@ module Facet.Elab.Pattern import Control.Effect.Empty import Data.Foldable (fold) import qualified Data.IntMap as IntMap -import Data.Monoid (First(..)) import Data.Traversable (for) import Facet.Name import Facet.Quote @@ -21,7 +20,7 @@ import qualified Facet.Sequent.Class as C import qualified Facet.Sequent.Expr as X import Facet.Sequent.Pattern import Facet.Sequent.Type -import Fresnel.Fold (Fold, Union(..), preview) +import Fresnel.Fold (Fold, Union(..), folded, preview) import Fresnel.Getter (to) import Fresnel.Lens (Lens', lens) import Fresnel.Maybe (_Nothing) @@ -43,8 +42,8 @@ instantiateHead p = p compileClauses :: Has Empty sig m => [X.Term] -> Type -> [Clause X.Term] -> QuoterT m X.Term compileClauses ctx (_A :-> _T) heads = C.lamR (compileClausesBody ctx _A _T heads) compileClauses _ _T heads - | Just (Clause [] b) <- getFirst (foldMap (First . Just) heads) = pure b - | otherwise = empty + | Just (Clause [] b) <- preview folded heads = pure b + | otherwise = empty compileClausesBody :: Has Empty sig m => [X.Term] -> Type -> Type -> [Clause X.Term] -> QuoterT m X.Term -> QuoterT m X.Coterm -> QuoterT m X.Command compileClausesBody ctx _A _T heads v k = case _A of From 03c5101230b30aa8eb4a93a208e6f30c446dfe09 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 13 Apr 2022 18:42:45 -0400 Subject: [PATCH 1055/1324] Tacit. --- src/Facet/Module.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 4c4bac4c1..76d410662 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -115,7 +115,7 @@ scopeToList :: Scope a -> [Name :=: a] scopeToList = view toList_ lookupScope :: Has Empty sig m => Name -> Scope a -> m (Name :=: a) -lookupScope n (Scope ds) = maybe empty (pure . (n :=:)) (lookup n (map (\ (n :=: a) -> (n, a)) ds)) +lookupScope n = maybe empty (pure . (n :=:)) . lookup n . map (\ (n :=: a) -> (n, a)) . decls newtype Import = Import { name :: QName } From 9872938076510e435d1c4a818df5f5f8f10bee8b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 13 Apr 2022 18:45:09 -0400 Subject: [PATCH 1056/1324] Don't return the key from lookupScope. --- src/Facet/Elab.hs | 2 +- src/Facet/Module.hs | 12 ++++++------ 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 867f7dd67..77201407b 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -149,7 +149,7 @@ lookupInSig :: Has (Choose :+: Empty) sig m => QName -> Module -> Graph -> [Sign lookupInSig (m :|> n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':|>_) _) -> do guard (m == Nil || m == m') defs <- interfaceScope =<< lookupQ graph mod q - _ :=: d <- lookupScope n defs + d <- lookupScope n defs pure $ m' :|> n :=: d) . interfaces where interfaceScope (_ :=: d) = case d of { DSubmodule (SInterface defs) _K -> pure defs ; _ -> empty } diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 76d410662..4287a9529 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -30,7 +30,7 @@ import Control.Algebra import Control.Effect.Choose import Control.Effect.Empty import Control.Monad ((<=<)) -import Data.Bifunctor (Bifunctor(bimap), first) +import Data.Bifunctor (first) import Data.Bitraversable import Data.Coerce import qualified Data.Map as Map @@ -87,16 +87,16 @@ lookupC :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Maybe lookupC n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) where matchDef = matchTerm <=< lookupScope n . view tm_ <=< maybe empty pure . preview _DData - matchTerm (n :=: d) = (name |> n :=:) <$> maybe empty pure (preview _DTerm d) + matchTerm d = (name |> n :=:) <$> maybe empty pure (preview _DTerm d) -- | Look up effect operations. lookupE :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Def) lookupE n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) where - matchDef = fmap (bimap (name |>) (DTerm Nothing)) . lookupScope n . view tm_ <=< maybe empty pure . preview _DInterface + matchDef = fmap ((name |> n :=:) . DTerm Nothing) . lookupScope n . view tm_ <=< maybe empty pure . preview _DInterface lookupD :: Has Empty sig m => Name -> Module -> m (QName :=: Def) -lookupD n Module{ name, scope } = maybe empty (pure . first (name |>)) (lookupScope n scope) +lookupD n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (lookupScope n scope) newtype Scope a = Scope { decls :: [Name :=: a] } @@ -114,8 +114,8 @@ scopeFromList = review toList_ scopeToList :: Scope a -> [Name :=: a] scopeToList = view toList_ -lookupScope :: Has Empty sig m => Name -> Scope a -> m (Name :=: a) -lookupScope n = maybe empty (pure . (n :=:)) . lookup n . map (\ (n :=: a) -> (n, a)) . decls +lookupScope :: Has Empty sig m => Name -> Scope a -> m a +lookupScope n = maybe empty pure . lookup n . map (\ (n :=: a) -> (n, a)) . decls newtype Import = Import { name :: QName } From 347cdd021f2629b4b9126b9a1ccf2048cc46833c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 13 Apr 2022 18:55:51 -0400 Subject: [PATCH 1057/1324] Define an Ixed instance for Scope. --- src/Facet/Module.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 4287a9529..f2a5946e4 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} module Facet.Module ( -- * Modules Module(..) @@ -43,7 +44,9 @@ import Facet.Type.Norm import Fresnel.Fold (preview) import Fresnel.Getter (view) import Fresnel.Iso (Iso, coerced, fmapping, iso) +import Fresnel.Ixed import Fresnel.Lens (Lens', lens) +import Fresnel.Optional (optional') import Fresnel.Prism import Fresnel.Review (review) @@ -102,6 +105,16 @@ lookupD n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (lookupSc newtype Scope a = Scope { decls :: [Name :=: a] } deriving (Monoid, Semigroup) +instance Ixed (Scope a) where + type Index (Scope a) = Name + type IxValue (Scope a) = a + ix n = optional' (lookupScope n) (\ (Scope ds) d' -> Scope (replace (\ (n' :=: _) -> (n' :=: d') <$ guard (n == n')) ds)) + where + replace _ [] = [] + replace f (v:vs) = case f v of + Nothing -> v:replace f vs + Just v' -> v':vs + decls_ :: Iso (Scope a) (Scope b) (Map.Map Name a) (Map.Map Name b) decls_ = toList_.fmapping pair_.iso Map.fromList Map.toList From 02c56b05d83cfd9673778ab5b4e213e63b1fb789 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 07:42:35 -0400 Subject: [PATCH 1058/1324] Extract elabScope. --- src/Facet/Elab/Term.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 0ff98b07c..3c5732405 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -332,9 +332,6 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os -- FIXME: maybe figure out the graph for mutual recursion? -- FIXME: check for redundant naming - let elabScope :: (Has (State Module) sig m, Monoid a) => Name -> Prism' Submodule a -> Kind -> Kind <==: ReaderC Module m b -> (b -> m a) -> m () - elabScope dname p _K elab ret = letrec (scope_.decls_) dname (_DSubmodule.tm_.p) (DSubmodule (review p mempty) _K) (runModule (elab <==: _K) >>= ret) - -- elaborate all the types first es <- for ds $ \ (S.Ann _ _ (dname, S.Ann _ _ def)) -> case def of S.DataDef cs _K -> Nothing <$ elabScope dname _SData _K (elabDataDef cs) (\ cs -> do @@ -352,6 +349,9 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os t' <- runModule $ elabTermDef t <==: _T scope_.decls_.ix dname .= DTerm (Just t') _T +elabScope :: (Has (State Module) sig m, Monoid a) => Name -> Prism' Submodule a -> Kind -> Kind <==: ReaderC Module m b -> (b -> m a) -> m () +elabScope dname p _K elab ret = letrec (scope_.decls_) dname (_DSubmodule.tm_.p) (DSubmodule (review p mempty) _K) (runModule (elab <==: _K) >>= ret) + letrec :: (Has (State s) sig m, At a) => Setter' s a -> At.Index a -> Traversal' (IxValue a) b -> IxValue a -> m b -> m () letrec getter key projection initial final = do getter.at key .= Just initial From cc0e3d28a08fc13cd4fbd3e27e450cb57b92c986 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 07:42:49 -0400 Subject: [PATCH 1059/1324] Rename. --- src/Facet/Elab/Term.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 3c5732405..2b4747c50 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -353,9 +353,9 @@ elabScope :: (Has (State Module) sig m, Monoid a) => Name -> Prism' Submodule a elabScope dname p _K elab ret = letrec (scope_.decls_) dname (_DSubmodule.tm_.p) (DSubmodule (review p mempty) _K) (runModule (elab <==: _K) >>= ret) letrec :: (Has (State s) sig m, At a) => Setter' s a -> At.Index a -> Traversal' (IxValue a) b -> IxValue a -> m b -> m () -letrec getter key projection initial final = do - getter.at key .= Just initial - getter.ix key.projection <~ final +letrec setter key projection initial final = do + setter.at key .= Just initial + setter.ix key.projection <~ final -- Errors From 31c37da79ccf30996f38ec8bf4858aadceafa445 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 07:44:48 -0400 Subject: [PATCH 1060/1324] :fire: do. --- src/Facet/Elab/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 2b4747c50..78857f4d4 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -334,7 +334,7 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os -- elaborate all the types first es <- for ds $ \ (S.Ann _ _ (dname, S.Ann _ _ def)) -> case def of - S.DataDef cs _K -> Nothing <$ elabScope dname _SData _K (elabDataDef cs) (\ cs -> do + S.DataDef cs _K -> Nothing <$ elabScope dname _SData _K (elabDataDef cs) (\ cs -> scopeFromList cs <$ for_ cs (\ (dname :=: decl) -> scope_.decls_.at dname .= Just decl)) S.InterfaceDef os _K -> Nothing <$ elabScope dname _SInterface _K (elabInterfaceDef os) (pure . scopeFromList) From bf4b8da55bc2cbb208d475a7bb46dac94c5b0911 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 07:48:19 -0400 Subject: [PATCH 1061/1324] :fire: scopeToList/scopeFromList. --- src/Facet/Elab/Term.hs | 6 +++--- src/Facet/Module.hs | 8 -------- src/Facet/Print.hs | 6 +++--- 3 files changed, 6 insertions(+), 14 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 78857f4d4..bae6515b2 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -165,7 +165,7 @@ comp b = Check $ \ _T -> do graph <- ask module' <- ask let interfacePattern :: Has (Throw ErrReason) sig m => Interface Type -> m (QName :=: (Name :==> Type)) - interfacePattern (Interface n _) = maybe (freeVariable n) (\ (n' :=: _T) -> pure ((n |> n') :=: (n' :==> _T))) (listToMaybe (scopeToList . Getter.view tm_ =<< maybe [] pure . preview _DInterface . Getter.view def_ =<< lookupQ graph module' n)) + interfacePattern (Interface n _) = maybe (freeVariable n) (\ (n' :=: _T) -> pure ((n |> n') :=: (n' :==> _T))) (listToMaybe (Getter.view (tm_.toList_) =<< maybe [] pure . preview _DInterface . Getter.view def_ =<< lookupQ graph module' n)) p' <- traverse interfacePattern (interfaces sig) -- FIXME: can we apply quantities to dictionaries? what would they mean? b' <- (Many, PDict p') |- check (b ::: _B) @@ -335,9 +335,9 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os -- elaborate all the types first es <- for ds $ \ (S.Ann _ _ (dname, S.Ann _ _ def)) -> case def of S.DataDef cs _K -> Nothing <$ elabScope dname _SData _K (elabDataDef cs) (\ cs -> - scopeFromList cs <$ for_ cs (\ (dname :=: decl) -> scope_.decls_.at dname .= Just decl)) + review toList_ cs <$ for_ cs (\ (dname :=: decl) -> scope_.decls_.at dname .= Just decl)) - S.InterfaceDef os _K -> Nothing <$ elabScope dname _SInterface _K (elabInterfaceDef os) (pure . scopeFromList) + S.InterfaceDef os _K -> Nothing <$ elabScope dname _SInterface _K (elabInterfaceDef os) (pure . review toList_) S.TermDef t tele -> do _T <- runModule $ elabType $ runErr $ Type.switch (synthType tele) <==: KType diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index f2a5946e4..53a8e3191 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -12,8 +12,6 @@ module Facet.Module , Scope(..) , decls_ , toList_ -, scopeFromList -, scopeToList , lookupScope , Import(..) , Submodule(..) @@ -121,12 +119,6 @@ decls_ = toList_.fmapping pair_.iso Map.fromList Map.toList toList_ :: Iso (Scope a) (Scope b) [Name :=: a] [Name :=: b] toList_ = coerced -scopeFromList :: [Name :=: a] -> Scope a -scopeFromList = review toList_ - -scopeToList :: Scope a -> [Name :=: a] -scopeToList = view toList_ - lookupScope :: Has Empty sig m => Name -> Scope a -> m a lookupScope n = maybe empty pure . lookup n . map (\ (n :=: a) -> (n, a)) . decls diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 53b2f87da..f80f50e74 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -222,7 +222,7 @@ instance Printable C.Module where mname (qvar (fromList [T (T.pack "Kernel")]:|>T (T.pack "Module"))) (map (\ (C.Import n) -> import' n) is) - (map (def . fmap defBody) (C.scopeToList ds)) + (map (def . fmap defBody) (view C.toList_ ds)) where def (n :=: d) = ann (qvar (Nil:|>n) ::: d) defBody = \case @@ -231,8 +231,8 @@ instance Printable C.Module where C.DSubmodule s _K -> case s of C.SData cs -> annotate Keyword (pretty "data") <+> scope defBody cs C.SInterface os -> annotate Keyword (pretty "interface") <+> scope (print opts env) os - C.SModule ds -> block (concatWith (surround hardline) (map ((hardline <>) . def . fmap defBody) (C.scopeToList ds))) - scope with = block . group . concatWith (surround (hardline <> comma <> space)) . map (group . def . fmap with) . C.scopeToList + C.SModule ds -> block (concatWith (surround hardline) (map ((hardline <>) . def . fmap defBody) (view C.toList_ ds))) + scope with = block . group . concatWith (surround (hardline <> comma <> space)) . map (group . def . fmap with) . view C.toList_ import' n = pretty "import" <+> braces (setPrec Var (prettyQName n)) module_ n t is ds = ann (setPrec Var (prettyQName n) ::: t) concatWith (surround hardline) (is ++ map (hardline <>) ds) defn (a :=: b) = group a <> hardline <> group b From c4776dbab2e42cb6148f0d4bf423042dbe331bd0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 08:05:40 -0400 Subject: [PATCH 1062/1324] :fire: lookupScope. --- src/Facet/Elab.hs | 3 ++- src/Facet/Module.hs | 13 +++++-------- 2 files changed, 7 insertions(+), 9 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 77201407b..9e097b71e 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -94,6 +94,7 @@ import Facet.Usage as Usage import Facet.Vars as Vars import Fresnel.Fold ((^?)) import Fresnel.Getter (view) +import Fresnel.Ixed (ix) import Fresnel.Lens (Lens', lens) import Fresnel.Prism (Prism', prism') import GHC.Stack @@ -149,7 +150,7 @@ lookupInSig :: Has (Choose :+: Empty) sig m => QName -> Module -> Graph -> [Sign lookupInSig (m :|> n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':|>_) _) -> do guard (m == Nil || m == m') defs <- interfaceScope =<< lookupQ graph mod q - d <- lookupScope n defs + d <- maybe empty pure (defs ^? ix n) pure $ m' :|> n :=: d) . interfaces where interfaceScope (_ :=: d) = case d of { DSubmodule (SInterface defs) _K -> pure defs ; _ -> empty } diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 53a8e3191..65323c474 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -12,7 +12,6 @@ module Facet.Module , Scope(..) , decls_ , toList_ -, lookupScope , Import(..) , Submodule(..) , _SData @@ -87,17 +86,17 @@ foldMapC f = getChoosing #. foldMap (Choosing #. f) lookupC :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Maybe Term ::: Type) lookupC n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) where - matchDef = matchTerm <=< lookupScope n . view tm_ <=< maybe empty pure . preview _DData + matchDef = matchTerm <=< maybe empty pure . preview (ix n) . view tm_ <=< maybe empty pure . preview _DData matchTerm d = (name |> n :=:) <$> maybe empty pure (preview _DTerm d) -- | Look up effect operations. lookupE :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Def) lookupE n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) where - matchDef = fmap ((name |> n :=:) . DTerm Nothing) . lookupScope n . view tm_ <=< maybe empty pure . preview _DInterface + matchDef = fmap ((name |> n :=:) . DTerm Nothing) . maybe empty pure . preview (ix n) . view tm_ <=< maybe empty pure . preview _DInterface lookupD :: Has Empty sig m => Name -> Module -> m (QName :=: Def) -lookupD n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (lookupScope n scope) +lookupD n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (preview (ix n) scope) newtype Scope a = Scope { decls :: [Name :=: a] } @@ -106,8 +105,9 @@ newtype Scope a = Scope { decls :: [Name :=: a] } instance Ixed (Scope a) where type Index (Scope a) = Name type IxValue (Scope a) = a - ix n = optional' (lookupScope n) (\ (Scope ds) d' -> Scope (replace (\ (n' :=: _) -> (n' :=: d') <$ guard (n == n')) ds)) + ix n = optional' prj (\ (Scope ds) d' -> Scope (replace (\ (n' :=: _) -> (n' :=: d') <$ guard (n == n')) ds)) where + prj = maybe empty pure . lookup n . map (\ (n :=: a) -> (n, a)) . decls replace _ [] = [] replace f (v:vs) = case f v of Nothing -> v:replace f vs @@ -119,9 +119,6 @@ decls_ = toList_.fmapping pair_.iso Map.fromList Map.toList toList_ :: Iso (Scope a) (Scope b) [Name :=: a] [Name :=: b] toList_ = coerced -lookupScope :: Has Empty sig m => Name -> Scope a -> m a -lookupScope n = maybe empty pure . lookup n . map (\ (n :=: a) -> (n, a)) . decls - newtype Import = Import { name :: QName } From 5bc18ba10b06977edc997c557b764d61d76e170a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 08:07:40 -0400 Subject: [PATCH 1063/1324] Compose some optics. --- src/Facet/Module.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 65323c474..0430298a6 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -86,14 +86,14 @@ foldMapC f = getChoosing #. foldMap (Choosing #. f) lookupC :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Maybe Term ::: Type) lookupC n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) where - matchDef = matchTerm <=< maybe empty pure . preview (ix n) . view tm_ <=< maybe empty pure . preview _DData + matchDef = matchTerm <=< maybe empty pure . preview (tm_.ix n) <=< maybe empty pure . preview _DData matchTerm d = (name |> n :=:) <$> maybe empty pure (preview _DTerm d) -- | Look up effect operations. lookupE :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Def) lookupE n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) where - matchDef = fmap ((name |> n :=:) . DTerm Nothing) . maybe empty pure . preview (ix n) . view tm_ <=< maybe empty pure . preview _DInterface + matchDef = fmap ((name |> n :=:) . DTerm Nothing) . maybe empty pure . preview (tm_.ix n) <=< maybe empty pure . preview _DInterface lookupD :: Has Empty sig m => Name -> Module -> m (QName :=: Def) lookupD n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (preview (ix n) scope) From ae622b5100981dc61887a374ae79613ec5ef92b8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 08:08:47 -0400 Subject: [PATCH 1064/1324] Compose further. --- src/Facet/Module.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 0430298a6..e952f7a09 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -86,14 +86,14 @@ foldMapC f = getChoosing #. foldMap (Choosing #. f) lookupC :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Maybe Term ::: Type) lookupC n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) where - matchDef = matchTerm <=< maybe empty pure . preview (tm_.ix n) <=< maybe empty pure . preview _DData + matchDef = matchTerm <=< maybe empty pure . preview (_DData.tm_.ix n) matchTerm d = (name |> n :=:) <$> maybe empty pure (preview _DTerm d) -- | Look up effect operations. lookupE :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Def) lookupE n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) where - matchDef = fmap ((name |> n :=:) . DTerm Nothing) . maybe empty pure . preview (tm_.ix n) <=< maybe empty pure . preview _DInterface + matchDef = fmap ((name |> n :=:) . DTerm Nothing) . maybe empty pure . preview (_DInterface.tm_.ix n) lookupD :: Has Empty sig m => Name -> Module -> m (QName :=: Def) lookupD n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (preview (ix n) scope) From b4214a0fa9b1a13e4e5b3493a504c48b7fc1d78b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 08:09:22 -0400 Subject: [PATCH 1065/1324] Tacit. --- src/Facet/Module.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index e952f7a09..59ecfab12 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -87,7 +87,7 @@ lookupC :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Maybe lookupC n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) where matchDef = matchTerm <=< maybe empty pure . preview (_DData.tm_.ix n) - matchTerm d = (name |> n :=:) <$> maybe empty pure (preview _DTerm d) + matchTerm = fmap (name |> n :=:) . maybe empty pure . preview _DTerm -- | Look up effect operations. lookupE :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Def) From 84dd9d54d547b46a37957d54d24827df4e3a323d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 08:11:16 -0400 Subject: [PATCH 1066/1324] Compose. --- src/Facet/Module.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 59ecfab12..eda694350 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -86,14 +86,13 @@ foldMapC f = getChoosing #. foldMap (Choosing #. f) lookupC :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Maybe Term ::: Type) lookupC n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) where - matchDef = matchTerm <=< maybe empty pure . preview (_DData.tm_.ix n) - matchTerm = fmap (name |> n :=:) . maybe empty pure . preview _DTerm + matchDef = maybe empty (pure . (name |> n :=:)) . preview (_DData.tm_.ix n._DTerm) -- | Look up effect operations. lookupE :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Def) lookupE n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) where - matchDef = fmap ((name |> n :=:) . DTerm Nothing) . maybe empty pure . preview (_DInterface.tm_.ix n) + matchDef = maybe empty (pure . ((name |> n :=:) . DTerm Nothing)) . preview (_DInterface.tm_.ix n) lookupD :: Has Empty sig m => Name -> Module -> m (QName :=: Def) lookupD n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (preview (ix n) scope) From 55330848fe824041aee9e5b41791a72b3ae413d3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 08:21:23 -0400 Subject: [PATCH 1067/1324] Scopes are Functors. --- src/Facet/Module.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index eda694350..49f74eb62 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -99,7 +99,7 @@ lookupD n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (preview newtype Scope a = Scope { decls :: [Name :=: a] } - deriving (Monoid, Semigroup) + deriving (Functor, Monoid, Semigroup) instance Ixed (Scope a) where type Index (Scope a) = Name From 92c41cdd616646c7e2039c14cb1b0715dca45e82 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 08:22:03 -0400 Subject: [PATCH 1068/1324] Data declarations hold types. --- src/Facet/Elab.hs | 2 +- src/Facet/Elab/Term.hs | 8 ++++---- src/Facet/Module.hs | 10 +++++----- src/Facet/Print.hs | 2 +- 4 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 9e097b71e..ca2e8a199 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -133,7 +133,7 @@ resolveWith lookup n = ask >>= \ graph -> asks (\ module' -> lookupWith lookup g [v] -> pure v ds -> ambiguousName n (map (view nm_) ds) -resolveC :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Maybe Term ::: Type) +resolveC :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Type) resolveC = resolveWith lookupC resolveQ :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Def) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index bae6515b2..97b71cbdf 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -186,7 +186,7 @@ varP n = Bind $ \ _A k -> k (PVar (n :==> wrap _A)) conP :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => QName -> [Bind m (Pattern (Name :==> Type))] -> Bind m (Pattern (Name :==> Type)) conP n fs = Bind $ \ _A k -> do - n' :=: _ ::: _T <- resolveC n + n' :=: _T <- resolveC n _T' <- maybe (pure _T) (foldl' (\ _T _A -> do t <- _T ; (_, _, b) <- assertQuantifier t ; pure (b _A)) (pure _T) . snd) (unNeutral _A) fs' <- runBind (fieldsP fs) _T' (\ (fs, _T) -> fs <$ unify (Exp _A) (Act _T)) k $ PCon n' (fromList fs') @@ -283,14 +283,14 @@ patternForArgType = \case elabDataDef :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Reader Source) sig m, Has (Throw Err) sig m, Has (Write Warn) sig m) => [S.Ann (Name ::: S.Ann S.Type)] - -> Kind <==: m [Name :=: Def] + -> Kind <==: m [Name :=: Term ::: Type] -- FIXME: check that all constructors return the datatype. elabDataDef constructors = Check $ \ _K -> do mname <- Lens.view name_ for constructors $ \ (S.Ann _ _ (n ::: t)) -> do c_T <- elabType $ runErr $ abstractType (Type.switch (synthType t) <==: KType) _K con' <- elabTerm $ runErr $ check (abstractTerm (const (Con (mname |> n) . toList)) ::: c_T) - pure $ n :=: DTerm (Just con') c_T + pure $ n :=: con' ::: c_T elabInterfaceDef :: (HasCallStack, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Reader Source) sig m, Has (Throw Err) sig m) @@ -335,7 +335,7 @@ elabModule (S.Ann _ _ (S.Module mname is os ds)) = execState (Module mname [] os -- elaborate all the types first es <- for ds $ \ (S.Ann _ _ (dname, S.Ann _ _ def)) -> case def of S.DataDef cs _K -> Nothing <$ elabScope dname _SData _K (elabDataDef cs) (\ cs -> - review toList_ cs <$ for_ cs (\ (dname :=: decl) -> scope_.decls_.at dname .= Just decl)) + fmap (Getter.view ty_) (review toList_ cs) <$ for_ cs (\ (dname :=: tm ::: ty) -> scope_.decls_.at dname .= Just (DTerm (Just tm) ty))) S.InterfaceDef os _K -> Nothing <$ elabScope dname _SInterface _K (elabInterfaceDef os) (pure . review toList_) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 49f74eb62..8d92a628e 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -83,10 +83,10 @@ foldMapC f = getChoosing #. foldMap (Choosing #. f) {-# INLINE (#.) #-} -lookupC :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Maybe Term ::: Type) +lookupC :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Type) lookupC n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) where - matchDef = maybe empty (pure . (name |> n :=:)) . preview (_DData.tm_.ix n._DTerm) + matchDef = maybe empty (pure . (name |> n :=:)) . preview (_DData.tm_.ix n) -- | Look up effect operations. lookupE :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Def) @@ -123,11 +123,11 @@ newtype Import = Import { name :: QName } data Submodule - = SData (Scope Def) + = SData (Scope Type) | SInterface (Scope Type) | SModule (Scope Def) -_SData :: Prism' Submodule (Scope Def) +_SData :: Prism' Submodule (Scope Type) _SData = prism' SData (\case SData cs -> Just cs _ -> Nothing) @@ -157,7 +157,7 @@ _DSubmodule = prism' (\ (s ::: _K) -> DSubmodule s _K) (\case DSubmodule s _K -> Just (s ::: _K) _ -> Nothing) -_DData :: Prism' Def (Scope Def ::: Kind) +_DData :: Prism' Def (Scope Type ::: Kind) _DData = onFst _DSubmodule _SData _DInterface :: Prism' Def (Scope Type ::: Kind) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index f80f50e74..18167d47f 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -229,7 +229,7 @@ instance Printable C.Module where C.DTerm Nothing _T -> print opts env _T C.DTerm (Just b) _T -> defn (print opts env _T :=: print opts env b) C.DSubmodule s _K -> case s of - C.SData cs -> annotate Keyword (pretty "data") <+> scope defBody cs + C.SData cs -> annotate Keyword (pretty "data") <+> scope (print opts env) cs C.SInterface os -> annotate Keyword (pretty "interface") <+> scope (print opts env) os C.SModule ds -> block (concatWith (surround hardline) (map ((hardline <>) . def . fmap defBody) (view C.toList_ ds))) scope with = block . group . concatWith (surround (hardline <> comma <> space)) . map (group . def . fmap with) . view C.toList_ From edaaec29855fc77a4d9f22e705618e13a2cf482d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 09:19:42 -0400 Subject: [PATCH 1069/1324] Simplify _DData. --- src/Facet/Module.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 8d92a628e..96db79d7a 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -43,7 +43,7 @@ import Fresnel.Getter (view) import Fresnel.Iso (Iso, coerced, fmapping, iso) import Fresnel.Ixed import Fresnel.Lens (Lens', lens) -import Fresnel.Optional (optional') +import Fresnel.Optional (Optional', optional') import Fresnel.Prism import Fresnel.Review (review) @@ -86,7 +86,7 @@ foldMapC f = getChoosing #. foldMap (Choosing #. f) lookupC :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Type) lookupC n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) where - matchDef = maybe empty (pure . (name |> n :=:)) . preview (_DData.tm_.ix n) + matchDef = maybe empty (pure . (name |> n :=:)) . preview (_DData.ix n) -- | Look up effect operations. lookupE :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Def) @@ -157,8 +157,8 @@ _DSubmodule = prism' (\ (s ::: _K) -> DSubmodule s _K) (\case DSubmodule s _K -> Just (s ::: _K) _ -> Nothing) -_DData :: Prism' Def (Scope Type ::: Kind) -_DData = onFst _DSubmodule _SData +_DData :: Optional' Def (Scope Type) +_DData = _DSubmodule.tm_._SData _DInterface :: Prism' Def (Scope Type ::: Kind) _DInterface = onFst _DSubmodule _SInterface From 1a2ad45f5865b83e4d7ef77b05d432486b6def34 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 09:23:53 -0400 Subject: [PATCH 1070/1324] Simplify _DInterface. --- src/Facet/Elab/Term.hs | 2 +- src/Facet/Module.hs | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 97b71cbdf..372f2b534 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -165,7 +165,7 @@ comp b = Check $ \ _T -> do graph <- ask module' <- ask let interfacePattern :: Has (Throw ErrReason) sig m => Interface Type -> m (QName :=: (Name :==> Type)) - interfacePattern (Interface n _) = maybe (freeVariable n) (\ (n' :=: _T) -> pure ((n |> n') :=: (n' :==> _T))) (listToMaybe (Getter.view (tm_.toList_) =<< maybe [] pure . preview _DInterface . Getter.view def_ =<< lookupQ graph module' n)) + interfacePattern (Interface n _) = maybe (freeVariable n) (\ (n' :=: _T) -> pure ((n |> n') :=: (n' :==> _T))) (listToMaybe (maybe [] (Getter.view toList_) . preview (def_._DInterface) =<< lookupQ graph module' n)) p' <- traverse interfacePattern (interfaces sig) -- FIXME: can we apply quantities to dictionaries? what would they mean? b' <- (Many, PDict p') |- check (b ::: _B) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 96db79d7a..79fbb8350 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -92,7 +92,7 @@ lookupC n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scop lookupE :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Def) lookupE n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) where - matchDef = maybe empty (pure . ((name |> n :=:) . DTerm Nothing)) . preview (_DInterface.tm_.ix n) + matchDef = maybe empty (pure . ((name |> n :=:) . DTerm Nothing)) . preview (_DInterface.ix n) lookupD :: Has Empty sig m => Name -> Module -> m (QName :=: Def) lookupD n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (preview (ix n) scope) @@ -160,8 +160,8 @@ _DSubmodule = prism' (\ (s ::: _K) -> DSubmodule s _K) (\case _DData :: Optional' Def (Scope Type) _DData = _DSubmodule.tm_._SData -_DInterface :: Prism' Def (Scope Type ::: Kind) -_DInterface = onFst _DSubmodule _SInterface +_DInterface :: Optional' Def (Scope Type) +_DInterface = _DSubmodule.tm_._SInterface _DModule :: Prism' Def (Scope Def ::: Kind) _DModule = onFst _DSubmodule _SModule From b416c24a0a117fe23f999a2aa5168cdecacd8a1c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 09:24:22 -0400 Subject: [PATCH 1071/1324] Simplify _DModule. --- src/Facet/Module.hs | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 79fbb8350..5c933a7aa 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -27,9 +27,6 @@ module Facet.Module import Control.Algebra import Control.Effect.Choose import Control.Effect.Empty -import Control.Monad ((<=<)) -import Data.Bifunctor (first) -import Data.Bitraversable import Data.Coerce import qualified Data.Map as Map import Facet.Kind @@ -45,7 +42,6 @@ import Fresnel.Ixed import Fresnel.Lens (Lens', lens) import Fresnel.Optional (Optional', optional') import Fresnel.Prism -import Fresnel.Review (review) -- Modules @@ -163,8 +159,5 @@ _DData = _DSubmodule.tm_._SData _DInterface :: Optional' Def (Scope Type) _DInterface = _DSubmodule.tm_._SInterface -_DModule :: Prism' Def (Scope Def ::: Kind) -_DModule = onFst _DSubmodule _SModule - -onFst :: Bitraversable f => Prism' s (f a c) -> Prism' a b -> Prism' s (f b c) -onFst p q = prism' (review p . first (review q)) (bitraverse (preview q) pure <=< preview p) +_DModule :: Optional' Def (Scope Def) +_DModule = _DSubmodule.tm_._SModule From 63898ea130e7487d3b1f8b3401dfb0fde8dcffe6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 15:15:20 -0400 Subject: [PATCH 1072/1324] :fire: Clause. --- src/Facet/Functor/Compose.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index 6059b856d..ef3702aa6 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -9,7 +9,6 @@ module Facet.Functor.Compose , weaken -- * Binding syntax , binder -, Clause(..) ) where import Control.Applicative (Alternative(..)) @@ -51,5 +50,3 @@ weaken = C . fmap pure binder :: (Functor m, Applicative i) => ((c -> d) -> e) -> (forall j . Applicative j => (forall x . i x -> j x) -> j c -> m (j d)) -> m (i e) binder f c = fmap f . runC <$> c weaken (liftCInner id) - -newtype Clause m i a b = Clause { runClause :: forall j . Applicative j => (forall x . i x -> j x) -> j a -> m (j b) } From ded3593afa7b6adfd6e27c345d586e2d21e26f8d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 15:15:34 -0400 Subject: [PATCH 1073/1324] Define a Clause datatype. --- src/Facet/Elab/Sequent.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 6f3bc97a1..25058de5e 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -34,6 +34,7 @@ import Facet.Kind import Facet.Lens as Lens (views) import Facet.Module import Facet.Name +import Facet.Pattern import Facet.Semiring import Facet.Sequent.Class as SQ import Facet.Subst @@ -144,6 +145,9 @@ checkLamS checkLamS _ = Check (\ _T -> mismatchTypes (Exp (Left "unimplemented")) (Act _T)) +data Clause a = Clause (Pattern Name) a + + -- Assertions -- | Expect a tacit (non-variable-binding) function type. From 9a920acdcb3011ff66d4e404ca5c1e287cac79fa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 15:17:15 -0400 Subject: [PATCH 1074/1324] Rename resolveQ to resolveD. --- src/Facet/Elab.hs | 6 +++--- src/Facet/Elab/Sequent.hs | 2 +- src/Facet/Elab/Term.hs | 2 +- src/Facet/Elab/Type.hs | 4 ++-- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index ca2e8a199..996830c01 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -8,7 +8,7 @@ module Facet.Elab ( -- * General lookupInContext , lookupInSig -, resolveQ +, resolveD , resolveC , meta , instantiate @@ -136,8 +136,8 @@ resolveWith lookup n = ask >>= \ graph -> asks (\ module' -> lookupWith lookup g resolveC :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Type) resolveC = resolveWith lookupC -resolveQ :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Def) -resolveQ = resolveWith lookupD +resolveD :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Def) +resolveD = resolveWith lookupD lookupInContext :: Has (Choose :+: Empty) sig m => QName -> Context -> m (LName Index, Either Kind (Quantity, Type)) lookupInContext (m:|>n) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 25058de5e..a1812c3f1 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -63,7 +63,7 @@ varS n = views context_ (lookupInContext n) >>= \case use n' q d <- views context_ level SQ.varA (Free (toLeveled d (ident n'))) ==> pure _T - _ -> resolveQ n >>= \case + _ -> resolveD n >>= \case n :=: DTerm _ _T -> globalS (n ::: _T) _ :=: _ -> freeVariable n diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 372f2b534..eed1ac419 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -117,7 +117,7 @@ global (q ::: _T) = (\ (v ::: _T) -> v :==> _T) <$> instantiate const (Var (Glob var :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => QName -> m (Term :==> Type) var n = views context_ (lookupInContext n) >>= \case [(n', Right (q, _T))] -> use n' q $> (Var (Free n') :==> _T) - _ -> resolveQ n >>= \case + _ -> resolveD n >>= \case n :=: DTerm _ _T -> global (n ::: _T) _ :=: _ -> freeVariable n diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 8782af08d..c0ecb4f52 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -33,12 +33,12 @@ import qualified Facet.Type.Expr as TX tvar :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (TX.Type :==> Kind) tvar n = views context_ (lookupInContext n) >>= \case [(n', Left _K)] -> pure (TX.Var (Free (Right n')) :==> _K) - _ -> resolveQ n >>= \case + _ -> resolveD n >>= \case q :=: DSubmodule _ _K -> pure $ TX.Var (Global q) :==> _K _ -> freeVariable n ivar :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :==> Kind) -ivar n = resolveQ n >>= \case +ivar n = resolveD n >>= \case q :=: DSubmodule (SInterface _) _K -> pure $ q :==> _K _ -> freeVariable n From f00c750cfd6184a806903a3ae7c6a45406d573ab Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 15:18:19 -0400 Subject: [PATCH 1075/1324] Rename lookupC to lookupConstructor. --- src/Facet/Elab.hs | 2 +- src/Facet/Module.hs | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 996830c01..f81be78cb 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -134,7 +134,7 @@ resolveWith lookup n = ask >>= \ graph -> asks (\ module' -> lookupWith lookup g ds -> ambiguousName n (map (view nm_) ds) resolveC :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Type) -resolveC = resolveWith lookupC +resolveC = resolveWith lookupConstructor resolveD :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Def) resolveD = resolveWith lookupD diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 5c933a7aa..06d6d3bb0 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -6,7 +6,7 @@ module Facet.Module , imports_ , scope_ , foldMapC -, lookupC +, lookupConstructor , lookupE , lookupD , Scope(..) @@ -79,8 +79,8 @@ foldMapC f = getChoosing #. foldMap (Choosing #. f) {-# INLINE (#.) #-} -lookupC :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Type) -lookupC n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) +lookupConstructor :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Type) +lookupConstructor n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) where matchDef = maybe empty (pure . (name |> n :=:)) . preview (_DData.ix n) From 805ff2b65ce54154d23de01311bd442c75866291 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 15:18:53 -0400 Subject: [PATCH 1076/1324] Rename lookupE to lookupOperation. --- src/Facet/Module.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 06d6d3bb0..b9c00cfae 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -7,7 +7,7 @@ module Facet.Module , scope_ , foldMapC , lookupConstructor -, lookupE +, lookupOperation , lookupD , Scope(..) , decls_ @@ -85,8 +85,8 @@ lookupConstructor n Module{ name, scope } = foldMapC matchDef (map (view def_) ( matchDef = maybe empty (pure . (name |> n :=:)) . preview (_DData.ix n) -- | Look up effect operations. -lookupE :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Def) -lookupE n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) +lookupOperation :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Def) +lookupOperation n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) where matchDef = maybe empty (pure . ((name |> n :=:) . DTerm Nothing)) . preview (_DInterface.ix n) From 612a7018897875988cafbc12e18079380027d1a8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 15:19:36 -0400 Subject: [PATCH 1077/1324] Rename lookupD to lookupDef. --- src/Facet/Elab.hs | 2 +- src/Facet/Graph.hs | 2 +- src/Facet/Module.hs | 6 +++--- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index f81be78cb..fcbbec193 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -137,7 +137,7 @@ resolveC :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Read resolveC = resolveWith lookupConstructor resolveD :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Def) -resolveD = resolveWith lookupD +resolveD = resolveWith lookupDef lookupInContext :: Has (Choose :+: Empty) sig m => QName -> Context -> m (LName Index, Either Kind (Quantity, Type)) lookupInContext (m:|>n) diff --git a/src/Facet/Graph.hs b/src/Facet/Graph.hs index 4010f8662..9f40832c0 100644 --- a/src/Facet/Graph.hs +++ b/src/Facet/Graph.hs @@ -65,7 +65,7 @@ lookupWith lookup graph mod@Module{ name } (m:|>n) <|> guard (m /= Nil) *> (lookupM (fromSnoc m) graph >>= maybe empty pure . snd >>= lookup n) lookupQ :: Has (Choose :+: Empty) sig m => Graph -> Module -> QName -> m (QName :=: Def) -lookupQ = lookupWith lookupD +lookupQ = lookupWith lookupDef -- FIXME: enrich this with source references for each diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index b9c00cfae..499711e55 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -8,7 +8,7 @@ module Facet.Module , foldMapC , lookupConstructor , lookupOperation -, lookupD +, lookupDef , Scope(..) , decls_ , toList_ @@ -90,8 +90,8 @@ lookupOperation n Module{ name, scope } = foldMapC matchDef (map (view def_) (de where matchDef = maybe empty (pure . ((name |> n :=:) . DTerm Nothing)) . preview (_DInterface.ix n) -lookupD :: Has Empty sig m => Name -> Module -> m (QName :=: Def) -lookupD n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (preview (ix n) scope) +lookupDef :: Has Empty sig m => Name -> Module -> m (QName :=: Def) +lookupDef n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (preview (ix n) scope) newtype Scope a = Scope { decls :: [Name :=: a] } From 1390eff3d8c64946df5fcbaf23cdd3200e813b3b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 15:48:58 -0400 Subject: [PATCH 1078/1324] Define a foldMapOfC combinator. --- src/Facet/Module.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 499711e55..4a5702824 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -35,7 +35,7 @@ import Facet.Snoc.NonEmpty ((|>)) import Facet.Syntax import Facet.Term.Expr import Facet.Type.Norm -import Fresnel.Fold (preview) +import Fresnel.Fold (Fold, foldMapOf, preview) import Fresnel.Getter (view) import Fresnel.Iso (Iso, coerced, fmapping, iso) import Fresnel.Ixed @@ -70,6 +70,10 @@ foldMapC :: (Foldable t, Has (Choose :+: Empty) sig m) => (a -> m b) -> t a -> m foldMapC f = getChoosing #. foldMap (Choosing #. f) {-# INLINE foldMapC #-} +foldMapOfC :: (Has Choose sig m, Has Empty sig m) => Fold s a -> (a -> m b) -> (s -> m b) +foldMapOfC o f = getChoosing #. foldMapOf o (Choosing #. f) +{-# INLINE foldMapOfC #-} + -- | Compose a function operationally equivalent to 'id' on the left. -- From b31813964dd85a4dabdd6edfbf41d63ed903b718 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 15:54:56 -0400 Subject: [PATCH 1079/1324] Compose optics. --- src/Facet/Module.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 4a5702824..9b9438806 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -35,7 +35,7 @@ import Facet.Snoc.NonEmpty ((|>)) import Facet.Syntax import Facet.Term.Expr import Facet.Type.Norm -import Fresnel.Fold (Fold, foldMapOf, preview) +import Fresnel.Fold (Fold, foldMapOf, folded, preview) import Fresnel.Getter (view) import Fresnel.Iso (Iso, coerced, fmapping, iso) import Fresnel.Ixed @@ -84,15 +84,15 @@ foldMapOfC o f = getChoosing #. foldMapOf o (Choosing #. f) lookupConstructor :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Type) -lookupConstructor n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) +lookupConstructor n Module{ name, scope } = foldMapOfC (toList_.folded.def_._DData) matchDef scope where - matchDef = maybe empty (pure . (name |> n :=:)) . preview (_DData.ix n) + matchDef = maybe empty (pure . (name |> n :=:)) . preview (ix n) -- | Look up effect operations. lookupOperation :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Def) -lookupOperation n Module{ name, scope } = foldMapC matchDef (map (view def_) (decls scope)) +lookupOperation n Module{ name, scope } = foldMapOfC (toList_.folded.def_._DInterface) matchDef scope where - matchDef = maybe empty (pure . ((name |> n :=:) . DTerm Nothing)) . preview (_DInterface.ix n) + matchDef = maybe empty (pure . ((name |> n :=:) . DTerm Nothing)) . preview (ix n) lookupDef :: Has Empty sig m => Name -> Module -> m (QName :=: Def) lookupDef n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (preview (ix n) scope) From 5b1083aae9f14677040cbd705e1666a546fc91d3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 15:55:57 -0400 Subject: [PATCH 1080/1324] Simplify lookupOperation. --- src/Facet/Module.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 9b9438806..792086f0f 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -36,7 +36,6 @@ import Facet.Syntax import Facet.Term.Expr import Facet.Type.Norm import Fresnel.Fold (Fold, foldMapOf, folded, preview) -import Fresnel.Getter (view) import Fresnel.Iso (Iso, coerced, fmapping, iso) import Fresnel.Ixed import Fresnel.Lens (Lens', lens) @@ -89,10 +88,10 @@ lookupConstructor n Module{ name, scope } = foldMapOfC (toList_.folded.def_._DDa matchDef = maybe empty (pure . (name |> n :=:)) . preview (ix n) -- | Look up effect operations. -lookupOperation :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Def) +lookupOperation :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Type) lookupOperation n Module{ name, scope } = foldMapOfC (toList_.folded.def_._DInterface) matchDef scope where - matchDef = maybe empty (pure . ((name |> n :=:) . DTerm Nothing)) . preview (ix n) + matchDef = maybe empty (pure . (name |> n :=:)) . preview (ix n) lookupDef :: Has Empty sig m => Name -> Module -> m (QName :=: Def) lookupDef n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (preview (ix n) scope) From ce91172acb912004d362f350ea277fb50e0fd422 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 16:01:16 -0400 Subject: [PATCH 1081/1324] Compose. --- src/Facet/Module.hs | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 792086f0f..4f3cf62f8 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -83,15 +83,11 @@ foldMapOfC o f = getChoosing #. foldMapOf o (Choosing #. f) lookupConstructor :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Type) -lookupConstructor n Module{ name, scope } = foldMapOfC (toList_.folded.def_._DData) matchDef scope - where - matchDef = maybe empty (pure . (name |> n :=:)) . preview (ix n) +lookupConstructor n Module{ name, scope } = foldMapOfC (toList_.folded.def_._DData.ix n) (pure . (name |> n :=:)) scope -- | Look up effect operations. lookupOperation :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Type) -lookupOperation n Module{ name, scope } = foldMapOfC (toList_.folded.def_._DInterface) matchDef scope - where - matchDef = maybe empty (pure . (name |> n :=:)) . preview (ix n) +lookupOperation n Module{ name, scope } = foldMapOfC (toList_.folded.def_._DInterface.ix n) (pure . (name |> n :=:)) scope lookupDef :: Has Empty sig m => Name -> Module -> m (QName :=: Def) lookupDef n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (preview (ix n) scope) From 286f44a074380484b754ccbbe1632c4e02444691 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 17:32:16 -0400 Subject: [PATCH 1082/1324] Avoid choice. --- src/Facet/Module.hs | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 4f3cf62f8..8c3d54465 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -35,7 +35,7 @@ import Facet.Snoc.NonEmpty ((|>)) import Facet.Syntax import Facet.Term.Expr import Facet.Type.Norm -import Fresnel.Fold (Fold, foldMapOf, folded, preview) +import Fresnel.Fold (folded, preview, (^?)) import Fresnel.Iso (Iso, coerced, fmapping, iso) import Fresnel.Ixed import Fresnel.Lens (Lens', lens) @@ -69,10 +69,6 @@ foldMapC :: (Foldable t, Has (Choose :+: Empty) sig m) => (a -> m b) -> t a -> m foldMapC f = getChoosing #. foldMap (Choosing #. f) {-# INLINE foldMapC #-} -foldMapOfC :: (Has Choose sig m, Has Empty sig m) => Fold s a -> (a -> m b) -> (s -> m b) -foldMapOfC o f = getChoosing #. foldMapOf o (Choosing #. f) -{-# INLINE foldMapOfC #-} - -- | Compose a function operationally equivalent to 'id' on the left. -- @@ -82,12 +78,12 @@ foldMapOfC o f = getChoosing #. foldMapOf o (Choosing #. f) {-# INLINE (#.) #-} -lookupConstructor :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Type) -lookupConstructor n Module{ name, scope } = foldMapOfC (toList_.folded.def_._DData.ix n) (pure . (name |> n :=:)) scope +lookupConstructor :: Has Empty sig m => Name -> Module -> m (QName :=: Type) +lookupConstructor n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (scope ^? toList_.folded.def_._DData.ix n) -- | Look up effect operations. -lookupOperation :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Type) -lookupOperation n Module{ name, scope } = foldMapOfC (toList_.folded.def_._DInterface.ix n) (pure . (name |> n :=:)) scope +lookupOperation :: Has Empty sig m => Name -> Module -> m (QName :=: Type) +lookupOperation n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (scope ^? toList_.folded.def_._DInterface.ix n) lookupDef :: Has Empty sig m => Name -> Module -> m (QName :=: Def) lookupDef n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (preview (ix n) scope) From e90dfb15039f699d4c0e3c97b299ee4629b6cdd2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 17:33:40 -0400 Subject: [PATCH 1083/1324] :fire: preview. --- src/Facet/Module.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 8c3d54465..637700c9e 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -35,7 +35,7 @@ import Facet.Snoc.NonEmpty ((|>)) import Facet.Syntax import Facet.Term.Expr import Facet.Type.Norm -import Fresnel.Fold (folded, preview, (^?)) +import Fresnel.Fold (folded, (^?)) import Fresnel.Iso (Iso, coerced, fmapping, iso) import Fresnel.Ixed import Fresnel.Lens (Lens', lens) @@ -78,15 +78,15 @@ foldMapC f = getChoosing #. foldMap (Choosing #. f) {-# INLINE (#.) #-} -lookupConstructor :: Has Empty sig m => Name -> Module -> m (QName :=: Type) +lookupConstructor :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Type) lookupConstructor n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (scope ^? toList_.folded.def_._DData.ix n) -- | Look up effect operations. -lookupOperation :: Has Empty sig m => Name -> Module -> m (QName :=: Type) +lookupOperation :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Type) lookupOperation n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (scope ^? toList_.folded.def_._DInterface.ix n) lookupDef :: Has Empty sig m => Name -> Module -> m (QName :=: Def) -lookupDef n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (preview (ix n) scope) +lookupDef n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (scope ^? ix n) newtype Scope a = Scope { decls :: [Name :=: a] } From 84cfce071c344c47cd58b4bb176c8711a81ce771 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 17:55:39 -0400 Subject: [PATCH 1084/1324] :fire: some redundant constraints. --- src/Facet/Elab.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index fcbbec193..d404ecc2d 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -124,7 +124,7 @@ instantiate inst = go resolveWith - :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) + :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => (forall sig m . Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: d)) -> QName -> m (QName :=: d) @@ -133,10 +133,10 @@ resolveWith lookup n = ask >>= \ graph -> asks (\ module' -> lookupWith lookup g [v] -> pure v ds -> ambiguousName n (map (view nm_) ds) -resolveC :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Type) +resolveC :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Type) resolveC = resolveWith lookupConstructor -resolveD :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Def) +resolveD :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Def) resolveD = resolveWith lookupDef lookupInContext :: Has (Choose :+: Empty) sig m => QName -> Context -> m (LName Index, Either Kind (Quantity, Type)) From 0b8cda3bfdce30954a55ad9a2882fe1d544e337c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 18:05:36 -0400 Subject: [PATCH 1085/1324] Remove the alternatives from ambiguous name errors for now. --- src/Facet/Elab.hs | 18 +++++++++--------- src/Facet/Notice/Elab.hs | 2 +- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index d404ecc2d..ba2c5324c 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -93,7 +93,6 @@ import Facet.Type.Norm as TN import Facet.Usage as Usage import Facet.Vars as Vars import Fresnel.Fold ((^?)) -import Fresnel.Getter (view) import Fresnel.Ixed (ix) import Fresnel.Lens (Lens', lens) import Fresnel.Prism (Prism', prism') @@ -131,7 +130,7 @@ resolveWith resolveWith lookup n = ask >>= \ graph -> asks (\ module' -> lookupWith lookup graph module' n) >>= \case [] -> freeVariable n [v] -> pure v - ds -> ambiguousName n (map (view nm_) ds) + _ -> ambiguousName n resolveC :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Type) resolveC = resolveWith lookupConstructor @@ -220,7 +219,7 @@ data Err = Err data ErrReason = FreeVariable QName -- FIXME: add source references for the imports, definition sites, and any re-exports. - | AmbiguousName QName [QName] + | AmbiguousName QName | CouldNotSynthesize | ResourceMismatch Name Quantity Quantity | UnifyType UnifyErrReason (Exp (Either String Type)) (Act Type) @@ -234,10 +233,10 @@ _FreeVariable = prism' FreeVariable (\case FreeVariable n -> Just n _ -> Nothing) -_AmbiguousName :: Prism' ErrReason (QName, [QName]) -_AmbiguousName = prism' (uncurry AmbiguousName) (\case - AmbiguousName n ns -> Just (n, ns) - _ -> Nothing) +_AmbiguousName :: Prism' ErrReason QName +_AmbiguousName = prism' AmbiguousName (\case + AmbiguousName n -> Just n + _ -> Nothing) _UnifyType :: Prism' ErrReason (UnifyErrReason, Exp (Either String Type), Act Type) _UnifyType = prism' (\ (r, x, a) -> UnifyType r x a) (\case @@ -292,8 +291,9 @@ resourceMismatch n exp act = withFrozenCallStack $ throwError $ ResourceMismatch freeVariable :: Has (Throw ErrReason) sig m => QName -> m a freeVariable n = withFrozenCallStack $ throwError $ FreeVariable n -ambiguousName :: Has (Throw ErrReason) sig m => QName -> [QName] -> m a -ambiguousName n qs = withFrozenCallStack $ throwError $ AmbiguousName n qs +-- FIXME: get references for the resolved names +ambiguousName :: Has (Throw ErrReason) sig m => QName -> m a +ambiguousName n = withFrozenCallStack $ throwError $ AmbiguousName n missingInterface :: Has (Throw ErrReason) sig m => Interface Type -> m a missingInterface i = withFrozenCallStack $ throwError $ MissingInterface i diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 07d2a3dd9..e86ba1321 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -63,7 +63,7 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) printErrReason :: Options Print -> Env.Env Print -> ErrReason -> Doc Style printErrReason opts ctx = group . \case FreeVariable n -> fillSep [reflow "variable not in scope:", prettyQName n] - AmbiguousName n qs -> fillSep [reflow "ambiguous name", prettyQName n] <\> nest 2 (reflow "alternatives:" <\> unlines (map prettyQName qs)) + AmbiguousName n -> fillSep [reflow "ambiguous name", prettyQName n] -- <\> nest 2 (reflow "alternatives:" <\> unlines (map prettyQName qs)) CouldNotSynthesize -> reflow "could not synthesize a type; try a type annotation" ResourceMismatch n e a -> fillSep [reflow "uses of variable", pretty n, reflow "didn’t match requirements"] <> hardline <> pretty "expected:" <+> prettyQ e From 80a657fb4ffe2f62d84e9535299b03b0b2c3927a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 18:05:55 -0400 Subject: [PATCH 1086/1324] Generalize resolveWith. --- src/Facet/Elab.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index ba2c5324c..281caf436 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -124,9 +124,9 @@ instantiate inst = go resolveWith :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) - => (forall sig m . Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: d)) + => (forall sig m . Has (Choose :+: Empty) sig m => Name -> Module -> m d) -> QName - -> m (QName :=: d) + -> m d resolveWith lookup n = ask >>= \ graph -> asks (\ module' -> lookupWith lookup graph module' n) >>= \case [] -> freeVariable n [v] -> pure v From c6844fdc6b7c912cdd465594aa2344b403eb2dba Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 18:09:35 -0400 Subject: [PATCH 1087/1324] resolveD doesn't return the name. --- src/Facet/Elab.hs | 4 ++-- src/Facet/Elab/Sequent.hs | 4 ++-- src/Facet/Elab/Term.hs | 6 +++--- src/Facet/Elab/Type.hs | 8 ++++---- src/Facet/Eval.hs | 4 ++-- src/Facet/Graph.hs | 3 +-- src/Facet/Module.hs | 6 +++--- 7 files changed, 17 insertions(+), 18 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 281caf436..3cfdeb585 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -135,7 +135,7 @@ resolveWith lookup n = ask >>= \ graph -> asks (\ module' -> lookupWith lookup g resolveC :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Type) resolveC = resolveWith lookupConstructor -resolveD :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Def) +resolveD :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m Def resolveD = resolveWith lookupDef lookupInContext :: Has (Choose :+: Empty) sig m => QName -> Context -> m (LName Index, Either Kind (Quantity, Type)) @@ -152,7 +152,7 @@ lookupInSig (m :|> n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':|>_) _ d <- maybe empty pure (defs ^? ix n) pure $ m' :|> n :=: d) . interfaces where - interfaceScope (_ :=: d) = case d of { DSubmodule (SInterface defs) _K -> pure defs ; _ -> empty } + interfaceScope = \case { DSubmodule (SInterface defs) _K -> pure defs ; _ -> empty } (|-) :: Has (Reader ElabContext :+: Throw ErrReason :+: Writer Usage) sig m => (Quantity, Pattern (Name :==> Type)) -> m a -> m a diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index a1812c3f1..e82e77341 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -64,8 +64,8 @@ varS n = views context_ (lookupInContext n) >>= \case d <- views context_ level SQ.varA (Free (toLeveled d (ident n'))) ==> pure _T _ -> resolveD n >>= \case - n :=: DTerm _ _T -> globalS (n ::: _T) - _ :=: _ -> freeVariable n + DTerm _ _T -> globalS (n ::: _T) + _ -> freeVariable n hole :: Has (Throw ErrReason) sig m => Name -> Type <==: m a hole n = Check $ \ _T -> withFrozenCallStack $ throwError $ Hole n _T diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index eed1ac419..85cc060b6 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -118,8 +118,8 @@ var :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Mo var n = views context_ (lookupInContext n) >>= \case [(n', Right (q, _T))] -> use n' q $> (Var (Free n') :==> _T) _ -> resolveD n >>= \case - n :=: DTerm _ _T -> global (n ::: _T) - _ :=: _ -> freeVariable n + DTerm _ _T -> global (n ::: _T) + _ -> freeVariable n hole :: Has (Throw ErrReason) sig m => Name -> Type <==: m a @@ -165,7 +165,7 @@ comp b = Check $ \ _T -> do graph <- ask module' <- ask let interfacePattern :: Has (Throw ErrReason) sig m => Interface Type -> m (QName :=: (Name :==> Type)) - interfacePattern (Interface n _) = maybe (freeVariable n) (\ (n' :=: _T) -> pure ((n |> n') :=: (n' :==> _T))) (listToMaybe (maybe [] (Getter.view toList_) . preview (def_._DInterface) =<< lookupQ graph module' n)) + interfacePattern (Interface n _) = maybe (freeVariable n) (\ (n' :=: _T) -> pure ((n |> n') :=: (n' :==> _T))) (listToMaybe (maybe [] (Getter.view toList_) . preview _DInterface =<< lookupQ graph module' n)) p' <- traverse interfacePattern (interfaces sig) -- FIXME: can we apply quantities to dictionaries? what would they mean? b' <- (Many, PDict p') |- check (b ::: _B) diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index c0ecb4f52..962af599f 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -34,13 +34,13 @@ tvar :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader M tvar n = views context_ (lookupInContext n) >>= \case [(n', Left _K)] -> pure (TX.Var (Free (Right n')) :==> _K) _ -> resolveD n >>= \case - q :=: DSubmodule _ _K -> pure $ TX.Var (Global q) :==> _K - _ -> freeVariable n + DSubmodule _ _K -> pure $ TX.Var (Global n) :==> _K + _ -> freeVariable n ivar :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :==> Kind) ivar n = resolveD n >>= \case - q :=: DSubmodule (SInterface _) _K -> pure $ q :==> _K - _ -> freeVariable n + DSubmodule (SInterface _) _K -> pure $ n :==> _K + _ -> freeVariable n _String :: Applicative m => m (TX.Type :==> Kind) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index bce86861d..c14f4e21c 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -65,8 +65,8 @@ global n = do mod <- lift ask graph <- lift ask case lookupQ graph mod n of - [_ :=: DTerm (Just v) _] -> pure v -- FIXME: store values in the module graph - _ -> error "throw a real error here" + [DTerm (Just v) _] -> pure v -- FIXME: store values in the module graph + _ -> error "throw a real error here" var :: (HasCallStack, Algebra sig m) => LName Index -> ReaderC (Env (Value m)) m (Value m) var n = asks (`index` n) diff --git a/src/Facet/Graph.hs b/src/Facet/Graph.hs index 9f40832c0..3b180c547 100644 --- a/src/Facet/Graph.hs +++ b/src/Facet/Graph.hs @@ -30,7 +30,6 @@ import Facet.Module import Facet.Name import Facet.Snoc import Facet.Snoc.NonEmpty (NonEmpty(..), fromSnoc, toSnoc) -import Facet.Syntax import Fresnel.At import Fresnel.Iso import Fresnel.Ixed @@ -64,7 +63,7 @@ lookupWith lookup graph mod@Module{ name } (m:|>n) <|> guard (m == Nil) *> foldMapC (maybe empty (lookup n) . snd) (getGraph graph) <|> guard (m /= Nil) *> (lookupM (fromSnoc m) graph >>= maybe empty pure . snd >>= lookup n) -lookupQ :: Has (Choose :+: Empty) sig m => Graph -> Module -> QName -> m (QName :=: Def) +lookupQ :: Has (Choose :+: Empty) sig m => Graph -> Module -> QName -> m Def lookupQ = lookupWith lookupDef diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 637700c9e..357e155e2 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -35,7 +35,7 @@ import Facet.Snoc.NonEmpty ((|>)) import Facet.Syntax import Facet.Term.Expr import Facet.Type.Norm -import Fresnel.Fold (folded, (^?)) +import Fresnel.Fold (folded, preview, (^?)) import Fresnel.Iso (Iso, coerced, fmapping, iso) import Fresnel.Ixed import Fresnel.Lens (Lens', lens) @@ -85,8 +85,8 @@ lookupConstructor n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) lookupOperation :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Type) lookupOperation n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (scope ^? toList_.folded.def_._DInterface.ix n) -lookupDef :: Has Empty sig m => Name -> Module -> m (QName :=: Def) -lookupDef n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (scope ^? ix n) +lookupDef :: Has Empty sig m => Name -> Module -> m Def +lookupDef n = maybe empty pure . preview (scope_.ix n) newtype Scope a = Scope { decls :: [Name :=: a] } From c6ad1de52f07cbde199466258e978252a4f5bf5b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Apr 2022 21:01:51 -0400 Subject: [PATCH 1088/1324] Rename resolveD to resolveDef. --- src/Facet/Elab.hs | 6 +++--- src/Facet/Elab/Sequent.hs | 2 +- src/Facet/Elab/Term.hs | 2 +- src/Facet/Elab/Type.hs | 4 ++-- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 3cfdeb585..ed3c44b29 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -8,7 +8,7 @@ module Facet.Elab ( -- * General lookupInContext , lookupInSig -, resolveD +, resolveDef , resolveC , meta , instantiate @@ -135,8 +135,8 @@ resolveWith lookup n = ask >>= \ graph -> asks (\ module' -> lookupWith lookup g resolveC :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Type) resolveC = resolveWith lookupConstructor -resolveD :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m Def -resolveD = resolveWith lookupDef +resolveDef :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m Def +resolveDef = resolveWith lookupDef lookupInContext :: Has (Choose :+: Empty) sig m => QName -> Context -> m (LName Index, Either Kind (Quantity, Type)) lookupInContext (m:|>n) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index e82e77341..5d4184322 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -63,7 +63,7 @@ varS n = views context_ (lookupInContext n) >>= \case use n' q d <- views context_ level SQ.varA (Free (toLeveled d (ident n'))) ==> pure _T - _ -> resolveD n >>= \case + _ -> resolveDef n >>= \case DTerm _ _T -> globalS (n ::: _T) _ -> freeVariable n diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 85cc060b6..5fdcb39eb 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -117,7 +117,7 @@ global (q ::: _T) = (\ (v ::: _T) -> v :==> _T) <$> instantiate const (Var (Glob var :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => QName -> m (Term :==> Type) var n = views context_ (lookupInContext n) >>= \case [(n', Right (q, _T))] -> use n' q $> (Var (Free n') :==> _T) - _ -> resolveD n >>= \case + _ -> resolveDef n >>= \case DTerm _ _T -> global (n ::: _T) _ -> freeVariable n diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 962af599f..8939216db 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -33,12 +33,12 @@ import qualified Facet.Type.Expr as TX tvar :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (TX.Type :==> Kind) tvar n = views context_ (lookupInContext n) >>= \case [(n', Left _K)] -> pure (TX.Var (Free (Right n')) :==> _K) - _ -> resolveD n >>= \case + _ -> resolveDef n >>= \case DSubmodule _ _K -> pure $ TX.Var (Global n) :==> _K _ -> freeVariable n ivar :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :==> Kind) -ivar n = resolveD n >>= \case +ivar n = resolveDef n >>= \case DSubmodule (SInterface _) _K -> pure $ n :==> _K _ -> freeVariable n From 8f53491c0e699b17e1e86a28ab217f912f52cc2d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 15 Apr 2022 00:48:44 -0400 Subject: [PATCH 1089/1324] FIXME. --- src/Facet/Elab/Sequent.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 5d4184322..f7147cbbf 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -145,6 +145,7 @@ checkLamS checkLamS _ = Check (\ _T -> mismatchTypes (Exp (Left "unimplemented")) (Act _T)) +-- FIXME: multiple patterns per clause data Clause a = Clause (Pattern Name) a From 1d79a03277e1e25915bd0be4ae36bb324c859971 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 15 Apr 2022 12:27:31 -0400 Subject: [PATCH 1090/1324] Define a module for pattern matrix columns. --- facet.cabal | 1 + src/Facet/Pattern/Column.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Pattern/Column.hs diff --git a/facet.cabal b/facet.cabal index d06ceda72..3126676d7 100644 --- a/facet.cabal +++ b/facet.cabal @@ -112,6 +112,7 @@ library Facet.Parser Facet.Parser.Table Facet.Pattern + Facet.Pattern.Column Facet.Polarized Facet.Pretty Facet.Print diff --git a/src/Facet/Pattern/Column.hs b/src/Facet/Pattern/Column.hs new file mode 100644 index 000000000..c10647441 --- /dev/null +++ b/src/Facet/Pattern/Column.hs @@ -0,0 +1,2 @@ +module Facet.Pattern.Column +() where From 9515658dfee2c83b0fca4d5ca7cd5420aa2ba989 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 15 Apr 2022 12:28:03 -0400 Subject: [PATCH 1091/1324] Define columns. --- src/Facet/Pattern/Column.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Facet/Pattern/Column.hs b/src/Facet/Pattern/Column.hs index c10647441..f01ba8d0c 100644 --- a/src/Facet/Pattern/Column.hs +++ b/src/Facet/Pattern/Column.hs @@ -1,2 +1,7 @@ module Facet.Pattern.Column -() where +( Column(..) +) where + +import qualified Data.IntMap as IntMap + +newtype Column a = Column { getColumn :: IntMap.IntMap a } From c292f07886bf3f9bc42d0bb1a23bf624a7ef40a4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 15 Apr 2022 12:28:37 -0400 Subject: [PATCH 1092/1324] Define an iso for columns' contents. --- src/Facet/Pattern/Column.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Pattern/Column.hs b/src/Facet/Pattern/Column.hs index f01ba8d0c..e16d4a56b 100644 --- a/src/Facet/Pattern/Column.hs +++ b/src/Facet/Pattern/Column.hs @@ -1,7 +1,13 @@ module Facet.Pattern.Column ( Column(..) +, column_ ) where import qualified Data.IntMap as IntMap +import Fresnel.Iso (Iso, coerced) newtype Column a = Column { getColumn :: IntMap.IntMap a } + +column_ :: Iso (Column a) (Column b) (IntMap.IntMap a) (IntMap.IntMap b) +column_ = coerced +{-# INLINE column_ #-} From e53d9b4be38bbbbad2c68993a52e872fdd32f23e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 15 Apr 2022 12:28:58 -0400 Subject: [PATCH 1093/1324] Define a Semigroup instance for Column. --- src/Facet/Pattern/Column.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Pattern/Column.hs b/src/Facet/Pattern/Column.hs index e16d4a56b..5d4c3acc4 100644 --- a/src/Facet/Pattern/Column.hs +++ b/src/Facet/Pattern/Column.hs @@ -11,3 +11,6 @@ newtype Column a = Column { getColumn :: IntMap.IntMap a } column_ :: Iso (Column a) (Column b) (IntMap.IntMap a) (IntMap.IntMap b) column_ = coerced {-# INLINE column_ #-} + +instance Semigroup a => Semigroup (Column a) where + as <> bs = Column (IntMap.unionWith (<>) (getColumn as) (getColumn bs)) From 570fcd6a7ab816bb774674be88e8aee3a50adef4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 15 Apr 2022 12:29:13 -0400 Subject: [PATCH 1094/1324] Derive a Monoid instance for Column. --- src/Facet/Pattern/Column.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Pattern/Column.hs b/src/Facet/Pattern/Column.hs index 5d4c3acc4..60648b16f 100644 --- a/src/Facet/Pattern/Column.hs +++ b/src/Facet/Pattern/Column.hs @@ -7,6 +7,7 @@ import qualified Data.IntMap as IntMap import Fresnel.Iso (Iso, coerced) newtype Column a = Column { getColumn :: IntMap.IntMap a } + deriving (Monoid) column_ :: Iso (Column a) (Column b) (IntMap.IntMap a) (IntMap.IntMap b) column_ = coerced From 4945a6d4813ae85f4b879e5db12ff18590df1ac9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 15 Apr 2022 12:29:48 -0400 Subject: [PATCH 1095/1324] Define a type synonym for row indices. --- src/Facet/Pattern/Column.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Pattern/Column.hs b/src/Facet/Pattern/Column.hs index 60648b16f..8f80c460f 100644 --- a/src/Facet/Pattern/Column.hs +++ b/src/Facet/Pattern/Column.hs @@ -1,6 +1,7 @@ module Facet.Pattern.Column ( Column(..) , column_ +, RowIndex ) where import qualified Data.IntMap as IntMap @@ -15,3 +16,5 @@ column_ = coerced instance Semigroup a => Semigroup (Column a) where as <> bs = Column (IntMap.unionWith (<>) (getColumn as) (getColumn bs)) + +type RowIndex = Int From dbac1eb02a19935f30fa41f29d1e18a9db4947f1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 15 Apr 2022 12:30:16 -0400 Subject: [PATCH 1096/1324] Define an Ixed instance for Column. --- src/Facet/Pattern/Column.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Facet/Pattern/Column.hs b/src/Facet/Pattern/Column.hs index 8f80c460f..92e779043 100644 --- a/src/Facet/Pattern/Column.hs +++ b/src/Facet/Pattern/Column.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} module Facet.Pattern.Column ( Column(..) , column_ @@ -6,6 +7,7 @@ module Facet.Pattern.Column import qualified Data.IntMap as IntMap import Fresnel.Iso (Iso, coerced) +import Fresnel.Ixed newtype Column a = Column { getColumn :: IntMap.IntMap a } deriving (Monoid) @@ -18,3 +20,8 @@ instance Semigroup a => Semigroup (Column a) where as <> bs = Column (IntMap.unionWith (<>) (getColumn as) (getColumn bs)) type RowIndex = Int + +instance Ixed (Column a) where + type Index (Column a) = RowIndex + type IxValue (Column a) = a + ix i = column_.ix i From f313cdd379c14a6233541d3c05edc79df486cc72 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 15 Apr 2022 12:30:44 -0400 Subject: [PATCH 1097/1324] Define an At instance for Column. --- src/Facet/Pattern/Column.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Pattern/Column.hs b/src/Facet/Pattern/Column.hs index 92e779043..603be63d2 100644 --- a/src/Facet/Pattern/Column.hs +++ b/src/Facet/Pattern/Column.hs @@ -6,6 +6,7 @@ module Facet.Pattern.Column ) where import qualified Data.IntMap as IntMap +import Fresnel.At import Fresnel.Iso (Iso, coerced) import Fresnel.Ixed @@ -25,3 +26,6 @@ instance Ixed (Column a) where type Index (Column a) = RowIndex type IxValue (Column a) = a ix i = column_.ix i + +instance At (Column a) where + at i = column_.at i From 243f16f8d97c9ee570cec1162c233598f2f7fa58 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 15 Apr 2022 12:31:25 -0400 Subject: [PATCH 1098/1324] Define a singleton constructor for Column. --- src/Facet/Pattern/Column.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/Facet/Pattern/Column.hs b/src/Facet/Pattern/Column.hs index 603be63d2..54e98f3db 100644 --- a/src/Facet/Pattern/Column.hs +++ b/src/Facet/Pattern/Column.hs @@ -3,6 +3,8 @@ module Facet.Pattern.Column ( Column(..) , column_ , RowIndex + -- * Constructors +, singleton ) where import qualified Data.IntMap as IntMap @@ -29,3 +31,11 @@ instance Ixed (Column a) where instance At (Column a) where at i = column_.at i + + +-- Constructors + +-- | Construct a sparse 'Column' from a single value. +singleton :: RowIndex -> a -> Column a +singleton row a = Column (IntMap.singleton row a) +{-# INLINE singleton #-} From aa2d3d7e34e98473a2dcdf33a485f4a2f49265ac Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 15 Apr 2022 12:31:49 -0400 Subject: [PATCH 1099/1324] Define a dense constructor for Column. --- src/Facet/Pattern/Column.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Pattern/Column.hs b/src/Facet/Pattern/Column.hs index 54e98f3db..51566ade2 100644 --- a/src/Facet/Pattern/Column.hs +++ b/src/Facet/Pattern/Column.hs @@ -5,6 +5,7 @@ module Facet.Pattern.Column , RowIndex -- * Constructors , singleton +, fromList ) where import qualified Data.IntMap as IntMap @@ -39,3 +40,7 @@ instance At (Column a) where singleton :: RowIndex -> a -> Column a singleton row a = Column (IntMap.singleton row a) {-# INLINE singleton #-} + +-- | Construct a dense 'Column' from a list of values. +fromList :: [a] -> Column a +fromList = Column . IntMap.fromList . zipWith (\ a b -> (a, b)) [0..] From 355e6b29d1ea9eeb533f94de4de907c7cd8a01f0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 15 Apr 2022 12:33:36 -0400 Subject: [PATCH 1100/1324] Use the new Column definition in pattern elaboration. --- src/Facet/Elab/Pattern.hs | 37 ++++++------------------------------- 1 file changed, 6 insertions(+), 31 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 97d2b04d3..31e3dc0f9 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -3,25 +3,22 @@ module Facet.Elab.Pattern , patterns_ -- * Coverage judgement , compileClauses -, Column(..) -, RowIndex -, singleton -, fromList -, at ) where import Control.Effect.Empty import Data.Foldable (fold) -import qualified Data.IntMap as IntMap +import Data.Maybe (fromJust) import Data.Traversable (for) import Facet.Name +import Facet.Pattern.Column import Facet.Quote import qualified Facet.Sequent.Class as C import qualified Facet.Sequent.Expr as X import Facet.Sequent.Pattern import Facet.Sequent.Type -import Fresnel.Fold (Fold, Union(..), folded, preview) +import Fresnel.Fold (Fold, Union(..), folded, preview, (^?)) import Fresnel.Getter (to) +import Fresnel.Ixed import Fresnel.Lens (Lens', lens) import Fresnel.Maybe (_Nothing) import Fresnel.Traversal (forOf, traversed) @@ -63,33 +60,11 @@ compileClausesBody ctx _A _T heads v k = case _A of _ -> empty _ -> empty) v C..|. C.sumL - [ C.µL (\ v -> compileClausesBody ctx _A _T (heads' `at` 0) v k) - , C.µL (\ v -> compileClausesBody ctx _B _T (heads' `at` 1) v k) ] + [ C.µL (\ v -> compileClausesBody ctx _A _T (fromJust (heads' ^? ix 0)) v k) + , C.µL (\ v -> compileClausesBody ctx _B _T (fromJust (heads' ^? ix 1)) v k) ] match :: Has Empty sig m => Fold (Pattern Name) [Pattern Name] -> [Clause X.Term] -> m [Clause X.Term] match o heads = forOf (traversed.patterns_) heads (\case p:ps | Just prefix <- preview o (instantiateHead p) -> pure (prefix <> ps) _ -> empty) - - -newtype Column a = Column { getColumn :: IntMap.IntMap a } - -instance Semigroup a => Semigroup (Column a) where - as <> bs = Column (IntMap.unionWith (<>) (getColumn as) (getColumn bs)) - -instance Monoid a => Monoid (Column a) where - mempty = Column mempty - -type RowIndex = Int - --- | Construct a sparse 'Column' from a single value. -singleton :: RowIndex -> a -> Column a -singleton row a = Column (IntMap.singleton row a) - --- | Construct a dense 'Column' from a list of values. -fromList :: [a] -> Column a -fromList = Column . IntMap.fromList . zipWith (\ a b -> (a, b)) [0..] - -at :: Column a -> RowIndex -> a -at (Column m) i = m IntMap.! i From a8874670741fffcfa2170418c3f22a63ce477e52 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 16 Apr 2022 09:47:54 -0400 Subject: [PATCH 1101/1324] Multiple patterns. --- src/Facet/Elab/Sequent.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index f7147cbbf..10494faea 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -145,8 +145,7 @@ checkLamS checkLamS _ = Check (\ _T -> mismatchTypes (Exp (Left "unimplemented")) (Act _T)) --- FIXME: multiple patterns per clause -data Clause a = Clause (Pattern Name) a +data Clause a = Clause [Pattern Name] a -- Assertions From 06c984d7b1f1560a2b83bfdd1f96b075092a0157 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 16 Apr 2022 13:06:01 -0400 Subject: [PATCH 1102/1324] Load some more files. --- .ghci.repl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.ghci.repl b/.ghci.repl index 77ad1e2f7..b2dafd42a 100644 --- a/.ghci.repl +++ b/.ghci.repl @@ -39,7 +39,7 @@ :seti -Wno-type-defaults :set -Wno-unused-packages -:load Facet.CLI test/Test.hs +:load Facet.CLI Facet.Elab.Pattern Facet.Elab.Sequent test/Test.hs import Facet.Parser import Facet.Print From 215ecd4037af085e13d9d2001d1efcbf3c1e7634 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 17 Apr 2022 08:19:11 -0400 Subject: [PATCH 1103/1324] Define a module for scopes. --- facet.cabal | 1 + src/Facet/Scope.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/Scope.hs diff --git a/facet.cabal b/facet.cabal index 3126676d7..7b5d08d3e 100644 --- a/facet.cabal +++ b/facet.cabal @@ -121,6 +121,7 @@ library Facet.REPL Facet.REPL.Parser Facet.Run + Facet.Scope Facet.Semialign Facet.Semiring Facet.Sequent.Class diff --git a/src/Facet/Scope.hs b/src/Facet/Scope.hs new file mode 100644 index 000000000..634d3d81d --- /dev/null +++ b/src/Facet/Scope.hs @@ -0,0 +1,2 @@ +module Facet.Scope +() where From 13191ba3985f5bf012662d941c3eeeb240f672c2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 17 Apr 2022 08:24:09 -0400 Subject: [PATCH 1104/1324] Move Scope into its own module. --- src/Facet/Driver.hs | 1 + src/Facet/Elab/Term.hs | 1 + src/Facet/Module.hs | 57 ++++++++++++------------------------------ src/Facet/Print.hs | 1 + src/Facet/Scope.hs | 34 ++++++++++++++++++++++++- 5 files changed, 52 insertions(+), 42 deletions(-) diff --git a/src/Facet/Driver.hs b/src/Facet/Driver.hs index 7ffc70c62..ac82c7f74 100644 --- a/src/Facet/Driver.hs +++ b/src/Facet/Driver.hs @@ -45,6 +45,7 @@ import Facet.Notice.Parser (rethrowParseErrors) import Facet.Parser import Facet.Pretty import Facet.Print (Options, Print) +import Facet.Scope import Facet.Snoc import Facet.Source import Facet.Source.Reference diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 5fdcb39eb..66e7734f8 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -66,6 +66,7 @@ import Facet.Lens as Lens (locally, view, views, (.=), (<~)) import Facet.Module as Module import Facet.Name import Facet.Pattern +import Facet.Scope import Facet.Semiring (Few(..), (><<)) import Facet.Snoc import Facet.Snoc.NonEmpty as NE diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 357e155e2..f6e6258f8 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -9,9 +9,6 @@ module Facet.Module , lookupConstructor , lookupOperation , lookupDef -, Scope(..) -, decls_ -, toList_ , Import(..) , Submodule(..) , _SData @@ -24,23 +21,22 @@ module Facet.Module , _DModule ) where -import Control.Algebra -import Control.Effect.Choose -import Control.Effect.Empty -import Data.Coerce -import qualified Data.Map as Map -import Facet.Kind -import Facet.Name -import Facet.Snoc.NonEmpty ((|>)) -import Facet.Syntax -import Facet.Term.Expr -import Facet.Type.Norm -import Fresnel.Fold (folded, preview, (^?)) -import Fresnel.Iso (Iso, coerced, fmapping, iso) -import Fresnel.Ixed -import Fresnel.Lens (Lens', lens) -import Fresnel.Optional (Optional', optional') -import Fresnel.Prism +import Control.Algebra +import Control.Effect.Choose +import Control.Effect.Empty +import Data.Coerce +import Facet.Kind +import Facet.Name +import Facet.Scope +import Facet.Snoc.NonEmpty ((|>)) +import Facet.Syntax +import Facet.Term.Expr +import Facet.Type.Norm +import Fresnel.Fold (folded, preview, (^?)) +import Fresnel.Ixed +import Fresnel.Lens (Lens', lens) +import Fresnel.Optional (Optional') +import Fresnel.Prism -- Modules @@ -89,27 +85,6 @@ lookupDef :: Has Empty sig m => Name -> Module -> m Def lookupDef n = maybe empty pure . preview (scope_.ix n) -newtype Scope a = Scope { decls :: [Name :=: a] } - deriving (Functor, Monoid, Semigroup) - -instance Ixed (Scope a) where - type Index (Scope a) = Name - type IxValue (Scope a) = a - ix n = optional' prj (\ (Scope ds) d' -> Scope (replace (\ (n' :=: _) -> (n' :=: d') <$ guard (n == n')) ds)) - where - prj = maybe empty pure . lookup n . map (\ (n :=: a) -> (n, a)) . decls - replace _ [] = [] - replace f (v:vs) = case f v of - Nothing -> v:replace f vs - Just v' -> v':vs - -decls_ :: Iso (Scope a) (Scope b) (Map.Map Name a) (Map.Map Name b) -decls_ = toList_.fmapping pair_.iso Map.fromList Map.toList - -toList_ :: Iso (Scope a) (Scope b) [Name :=: a] [Name :=: b] -toList_ = coerced - - newtype Import = Import { name :: QName } diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 18167d47f..3e64fba1e 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -38,6 +38,7 @@ import Facet.Pattern import Facet.Pretty (lower, upper) import Facet.Print.Options import Facet.Quote +import qualified Facet.Scope as C import Facet.Semiring (one, zero) import Facet.Snoc import Facet.Snoc.NonEmpty (NonEmpty(..)) diff --git a/src/Facet/Scope.hs b/src/Facet/Scope.hs index 634d3d81d..0145b0fd1 100644 --- a/src/Facet/Scope.hs +++ b/src/Facet/Scope.hs @@ -1,2 +1,34 @@ +{-# LANGUAGE TypeFamilies #-} module Facet.Scope -() where +( Scope(..) +, decls_ +, toList_ +) where + +import Control.Monad (guard) +import qualified Data.Map as Map +import Facet.Name +import Facet.Syntax +import Fresnel.Iso +import Fresnel.Ixed +import Fresnel.Optional (optional') + +newtype Scope a = Scope { decls :: [Name :=: a] } + deriving (Functor, Monoid, Semigroup) + +instance Ixed (Scope a) where + type Index (Scope a) = Name + type IxValue (Scope a) = a + ix n = optional' prj (\ (Scope ds) d' -> Scope (replace (\ (n' :=: _) -> (n' :=: d') <$ guard (n == n')) ds)) + where + prj = lookup n . map (\ (n :=: a) -> (n, a)) . decls + replace _ [] = [] + replace f (v:vs) = case f v of + Nothing -> v:replace f vs + Just v' -> v':vs + +decls_ :: Iso (Scope a) (Scope b) (Map.Map Name a) (Map.Map Name b) +decls_ = toList_.fmapping pair_.iso Map.fromList Map.toList + +toList_ :: Iso (Scope a) (Scope b) [Name :=: a] [Name :=: b] +toList_ = coerced From f96987bfee7eb13f231f40df9f5d77a39606bbb6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 17 Apr 2022 08:28:46 -0400 Subject: [PATCH 1105/1324] Lookup constructor indices by name. --- src/Facet/Scope.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Facet/Scope.hs b/src/Facet/Scope.hs index 0145b0fd1..b96842f11 100644 --- a/src/Facet/Scope.hs +++ b/src/Facet/Scope.hs @@ -3,9 +3,12 @@ module Facet.Scope ( Scope(..) , decls_ , toList_ + -- * Eliminators +, lookupIndex ) where import Control.Monad (guard) +import Data.List (findIndex) import qualified Data.Map as Map import Facet.Name import Facet.Syntax @@ -32,3 +35,9 @@ decls_ = toList_.fmapping pair_.iso Map.fromList Map.toList toList_ :: Iso (Scope a) (Scope b) [Name :=: a] [Name :=: b] toList_ = coerced + + +-- Eliminators + +lookupIndex :: Name -> Scope a -> Maybe Int +lookupIndex n = findIndex (\ (n' :=: _) -> n == n') . decls From 967e184f425c9a231f91c03b26f282b93cf7df5e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 17 Apr 2022 16:41:48 -0400 Subject: [PATCH 1106/1324] Define a Show instance for Column. --- src/Facet/Pattern/Column.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Pattern/Column.hs b/src/Facet/Pattern/Column.hs index 51566ade2..c01eeb58b 100644 --- a/src/Facet/Pattern/Column.hs +++ b/src/Facet/Pattern/Column.hs @@ -8,6 +8,7 @@ module Facet.Pattern.Column , fromList ) where +import Data.Functor.Classes (showsUnaryWith) import qualified Data.IntMap as IntMap import Fresnel.At import Fresnel.Iso (Iso, coerced) @@ -33,6 +34,9 @@ instance Ixed (Column a) where instance At (Column a) where at i = column_.at i +instance Show a => Show (Column a) where + showsPrec p (Column rows) = showsUnaryWith showsPrec "Column" p (IntMap.toList rows) + -- Constructors From 3989108e26389b44a9291494291b34c0a374ba9b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 17 Apr 2022 21:24:36 -0400 Subject: [PATCH 1107/1324] Derive a Show instance for Clause. --- src/Facet/Elab/Sequent.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 10494faea..cb3ceba5a 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -146,6 +146,7 @@ checkLamS _ = Check (\ _T -> mismatchTypes (Exp (Left "unimplemented")) (Act _T) data Clause a = Clause [Pattern Name] a + deriving (Show) -- Assertions From 80a36b6e66696fa28a515df852584428d9b224ef Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 17 Apr 2022 21:25:09 -0400 Subject: [PATCH 1108/1324] Export Clause. --- src/Facet/Elab/Sequent.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index cb3ceba5a..a6ce2a9ca 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -11,6 +11,7 @@ module Facet.Elab.Sequent -- * Elaboration , synthExprS , checkExprS +, Clause(..) -- * Assertions , assertTacitFunction -- * Judgements From e9717b7fbeb5bed4c47ac311eeaa17e43466eb97 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 17 Apr 2022 21:26:35 -0400 Subject: [PATCH 1109/1324] Define partitioning by constructors. --- src/Facet/Elab/Sequent.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index a6ce2a9ca..c714be05b 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -12,6 +12,7 @@ module Facet.Elab.Sequent , synthExprS , checkExprS , Clause(..) +, partitionBy -- * Assertions , assertTacitFunction -- * Judgements @@ -22,7 +23,9 @@ import Control.Effect.Reader import Control.Effect.State import Control.Effect.Throw import Control.Effect.Writer +import Data.Foldable (fold) import Data.Text (Text) +import Data.Traversable (for) import Facet.Context (level) import Facet.Effect.Write import Facet.Elab @@ -36,8 +39,11 @@ import Facet.Lens as Lens (views) import Facet.Module import Facet.Name import Facet.Pattern +import qualified Facet.Pattern.Column as Col +import qualified Facet.Scope as Scope import Facet.Semiring import Facet.Sequent.Class as SQ +import Facet.Snoc.NonEmpty import Facet.Subst import qualified Facet.Surface.Term.Expr as S import qualified Facet.Surface.Type.Expr as S @@ -45,6 +51,7 @@ import Facet.Syntax as S hiding (context_) import Facet.Type.Norm as T import Facet.Unify import Facet.Usage +import Fresnel.Getter (view) import GHC.Stack (HasCallStack, callStack, popCallStack, withFrozenCallStack) -- Variables @@ -149,6 +156,17 @@ checkLamS _ = Check (\ _T -> mismatchTypes (Exp (Left "unimplemented")) (Act _T) data Clause a = Clause [Pattern Name] a deriving (Show) +partitionBy :: [Clause a] -> Scope.Scope Type -> Maybe (Col.Column [Clause a]) +partitionBy clauses ctors = fold <$> for clauses (\case + Clause (p:ps) b -> case p of + PWildcard -> pure (Col.fromList ([Clause (PWildcard:ps) b] <$ view Scope.toList_ ctors)) + PVar n -> pure (Col.fromList ([Clause (PVar n :ps) b] <$ view Scope.toList_ ctors)) + PCon (_:|>n) fs -> case Scope.lookupIndex n ctors of + Nothing -> Nothing + Just ix -> pure (Col.singleton ix [Clause (fs <> ps) b]) + _ -> Nothing + _ -> Nothing) + -- Assertions From 67da56d0364567cdf3e64de7032a9727b42f196d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 18 Apr 2022 08:10:59 -0400 Subject: [PATCH 1110/1324] :fire: comp elaboration. It's unused anyway. --- src/Facet/Elab/Term.hs | 17 +---------------- 1 file changed, 1 insertion(+), 16 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 66e7734f8..b55020a69 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -13,7 +13,6 @@ module Facet.Elab.Term , app , string , let' -, comp -- * Pattern combinators , wildcardP , varP @@ -47,7 +46,7 @@ import Data.Bifunctor (first) import Data.Either (partitionEithers) import Data.Foldable import Data.Functor -import Data.Maybe (catMaybes, fromMaybe, listToMaybe) +import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid (Ap(..), First(..)) import qualified Data.Set as Set import Data.Text (Text) @@ -82,7 +81,6 @@ import Facet.Type.Norm as T hiding (global) import Facet.Unify import Facet.Usage hiding (restrict) import Fresnel.At as At -import Fresnel.Fold (preview) import Fresnel.Getter as Getter (view) import Fresnel.Ixed import Fresnel.Prism (Prism') @@ -160,19 +158,6 @@ let' p a b = Check $ \ _B -> do pure $ Let p' a' b' -comp :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Type <==: m Term -> Type <==: m Term -comp b = Check $ \ _T -> do - (sig, _B) <- assertComp _T - graph <- ask - module' <- ask - let interfacePattern :: Has (Throw ErrReason) sig m => Interface Type -> m (QName :=: (Name :==> Type)) - interfacePattern (Interface n _) = maybe (freeVariable n) (\ (n' :=: _T) -> pure ((n |> n') :=: (n' :==> _T))) (listToMaybe (maybe [] (Getter.view toList_) . preview _DInterface =<< lookupQ graph module' n)) - p' <- traverse interfacePattern (interfaces sig) - -- FIXME: can we apply quantities to dictionaries? what would they mean? - b' <- (Many, PDict p') |- check (b ::: _B) - pure $ E.Comp (map (fmap proof) p') b' - - -- Pattern combinators wildcardP :: Bind m (Pattern (Name :==> Type)) From 130e7e5a8d26daf6a95d5acd5b5e8c4c526931be Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 19 Apr 2022 09:15:37 -0400 Subject: [PATCH 1111/1324] Extract value patterns into a new type. --- src/Facet/Context.hs | 3 ++- src/Facet/Elab/Sequent.hs | 6 +++--- src/Facet/Elab/Term.hs | 8 ++++---- src/Facet/Eval.hs | 16 ++++++++-------- src/Facet/Notice/Elab.hs | 4 ++-- src/Facet/Pattern.hs | 17 +++++++++++++---- src/Facet/Print.hs | 12 ++++++------ src/Facet/Term/Norm.hs | 14 +++++++------- src/Facet/Type/Norm.hs | 3 ++- 9 files changed, 47 insertions(+), 36 deletions(-) diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index c369f87bb..5c644e3ea 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -23,6 +23,7 @@ import qualified Facet.Snoc as S import Facet.Syntax import Facet.Type.Norm import Facet.Usage +import Fresnel.Review (review) import GHC.Stack import Prelude hiding (lookup) @@ -69,6 +70,6 @@ toEnv c = Env.Env (S.fromList (zipWith toType (toList (elems c)) [0..pred (level where toType b d = case b of Type _ _ p -> (\ b -> proof b :=: bind d (proof b)) <$> p - Kind (n :==> _) -> PVar (n :=: bind d n) + Kind (n :==> _) -> review _PVar (n :=: bind d n) bind d b = free (LName d b) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index c714be05b..11d64d310 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -158,9 +158,9 @@ data Clause a = Clause [Pattern Name] a partitionBy :: [Clause a] -> Scope.Scope Type -> Maybe (Col.Column [Clause a]) partitionBy clauses ctors = fold <$> for clauses (\case - Clause (p:ps) b -> case p of - PWildcard -> pure (Col.fromList ([Clause (PWildcard:ps) b] <$ view Scope.toList_ ctors)) - PVar n -> pure (Col.fromList ([Clause (PVar n :ps) b] <$ view Scope.toList_ ctors)) + Clause (PVal p:ps) b -> case p of + PWildcard -> pure (Col.fromList ([Clause (PVal PWildcard:ps) b] <$ view Scope.toList_ ctors)) + PVar n -> pure (Col.fromList ([Clause (PVal (PVar n) :ps) b] <$ view Scope.toList_ ctors)) PCon (_:|>n) fs -> case Scope.lookupIndex n ctors of Nothing -> Nothing Just ix -> pure (Col.singleton ix [Clause (fs <> ps) b]) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index b55020a69..8791daadc 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -161,10 +161,10 @@ let' p a b = Check $ \ _B -> do -- Pattern combinators wildcardP :: Bind m (Pattern (Name :==> Type)) -wildcardP = Bind $ \ _T k -> k PWildcard +wildcardP = Bind $ \ _T k -> k (PVal PWildcard) varP :: Name -> Bind m (Pattern (Name :==> Type)) -varP n = Bind $ \ _A k -> k (PVar (n :==> wrap _A)) +varP n = Bind $ \ _A k -> k (PVal (PVar (n :==> wrap _A))) where wrap = \case T.Comp sig _A -> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] |> T "Unit")) Nil) (T.Comp sig _A) @@ -175,7 +175,7 @@ conP n fs = Bind $ \ _A k -> do n' :=: _T <- resolveC n _T' <- maybe (pure _T) (foldl' (\ _T _A -> do t <- _T ; (_, _, b) <- assertQuantifier t ; pure (b _A)) (pure _T) . snd) (unNeutral _A) fs' <- runBind (fieldsP fs) _T' (\ (fs, _T) -> fs <$ unify (Exp _A) (Act _T)) - k $ PCon n' (fromList fs') + k $ PVal (PCon n' (fromList fs')) fieldsP :: Has (Throw ErrReason) sig m => [Bind m a] -> Bind m ([a], Type) fieldsP = foldr cons nil @@ -189,7 +189,7 @@ fieldsP = foldr cons nil allP :: Has (Throw ErrReason :+: Write Warn) sig m => Name -> Bind m (Pattern (Name :==> Type)) allP n = Bind $ \ _A k -> do (sig, _T) <- assertComp _A - k (PVar (n :==> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] |> T "Unit")) Nil) (T.Comp sig _T))) + k (PVal (PVar (n :==> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] |> T "Unit")) Nil) (T.Comp sig _T)))) -- Expression elaboration diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index c14f4e21c..c62cbaac8 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -149,14 +149,14 @@ unit = VCon (NE.FromList ["Data", "Unit"] NE.|> T "unit") [] matchV :: (Pattern (Name :=: Value m) -> a) -> Pattern Name -> Value m -> Maybe a matchV k p s = case p of - PWildcard -> pure (k PWildcard) - PVar n -> pure (k (PVar (n :=: s))) - PCon n ps - | VCon n' fs <- s -> k . PCon n' <$ guard (n == n') <*> zipWithM (matchV id) ps fs - PCon{} -> Nothing - PDict ps - | VDict os <- s -> k . PDict <$> zipWithM (\ (n1 :=: p) (n2 :=: o) -> (n1 :=: (p :=: o)) <$ guard (n1 == n2)) ps os - PDict{} -> Nothing + PVal PWildcard -> pure (k (PVal PWildcard)) + PVal (PVar n) -> pure (k (PVal (PVar (n :=: s)))) + PVal (PCon n ps) + | VCon n' fs <- s -> k . PVal . PCon n' <$ guard (n == n') <*> zipWithM (matchV id) ps fs + PVal PCon{} -> Nothing + PVal (PDict ps) + | VDict os <- s -> k . PVal . PDict <$> zipWithM (\ (n1 :=: p) (n2 :=: o) -> (n1 :=: (p :=: o)) <$ guard (n1 == n2)) ps os + PVal PDict{} -> Nothing -- Quotation diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index e86ba1321..5ee2ffeef 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -46,8 +46,8 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) sig' = getPrint . print opts printCtx . fmap (apply subst (toEnv context)) <$> (interfaces =<< sig) combine (d, env, prints, ctx) (C.Kind (n :==> _K)) = ( succ d - , env Env.|> PVar (n :=: free (LName d n)) - , prints Env.|> PVar (n :=: intro n d) + , env Env.|> PVal (PVar (n :=: free (LName d n))) + , prints Env.|> PVal (PVar (n :=: intro n d)) , ctx :> getPrint (print opts prints (ann (intro n d ::: print opts prints _K))) ) combine (d, env, prints, ctx) (C.Type m _ p) = ( succ d diff --git a/src/Facet/Pattern.hs b/src/Facet/Pattern.hs index 25365f353..886694849 100644 --- a/src/Facet/Pattern.hs +++ b/src/Facet/Pattern.hs @@ -1,6 +1,7 @@ module Facet.Pattern ( -- * Patterns Pattern(..) +, ValPattern(..) , _PWildcard , _PVar , _PCon @@ -10,11 +11,19 @@ module Facet.Pattern import Data.Traversable (mapAccumL) import Facet.Name import Facet.Syntax -import Fresnel.Prism (Prism', prism') +import Fresnel.Prism (Prism, Prism', prism, prism') -- Patterns data Pattern a + = PVal (ValPattern a) + deriving (Eq, Foldable, Functor, Ord, Show, Traversable) + +_PVal :: Prism (Pattern a) (Pattern b) (ValPattern a) (ValPattern b) +_PVal = prism PVal (\case + PVal p -> Right p) + +data ValPattern a = PWildcard | PVar a | PCon QName [Pattern a] @@ -22,17 +31,17 @@ data Pattern a deriving (Eq, Foldable, Functor, Ord, Show, Traversable) _PWildcard :: Prism' (Pattern a) () -_PWildcard = prism' (const PWildcard) (\case +_PWildcard = _PVal.prism' (const PWildcard) (\case PWildcard -> Just () _ -> Nothing) _PVar :: Prism' (Pattern a) a -_PVar = prism' PVar (\case +_PVar = _PVal.prism' PVar (\case PVar a -> Just a _ -> Nothing) _PCon :: Prism' (Pattern a) (QName, [Pattern a]) -_PCon = prism' (uncurry PCon) (\case +_PCon = _PVal.prism' (uncurry PCon) (\case PCon h sp -> Just (h, sp) _ -> Nothing) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 3e64fba1e..40aee2744 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -174,7 +174,7 @@ instance Printable TX.Type where TX.Var (Global n) -> qvar n TX.Var (Free (Right n)) -> fromMaybe (lname (toLeveled d n)) $ Env.lookup env n TX.Var (Free (Left m)) -> meta m - TX.ForAll n t b -> braces (ann (intro n d ::: print opts env t)) --> go (env |> PVar (n :=: intro n d)) b + TX.ForAll n t b -> braces (ann (intro n d ::: print opts env t)) --> go (env |> PVal (PVar (n :=: intro n d))) b TX.Arrow Nothing q a b -> mult q (go env a) --> go env b TX.Arrow (Just n) q a b -> parens (ann (intro n d ::: mult q (go env a))) --> go env b TX.Comp s t -> if s == mempty then go env t else sig s <+> go env t @@ -204,7 +204,7 @@ instance Printable C.Term where C.String s -> annotate Lit $ pretty (show s) C.Dict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> qname n <+> equals <+> group (go env v)) os) <> flatAlt space line) C.Let p v b -> let p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) in pretty "let" <+> braces (print opts env (view def_ <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p') b - C.Comp p b -> comp (clause env (PDict p, b)) + C.Comp p b -> comp (clause env (PVal (PDict p), b)) where d = level env qvar = group . setPrec Var . qname @@ -249,10 +249,10 @@ instance Printable1 Pattern where printWith with opts@Options{ qname } env = go where go = \case - PWildcard -> pretty '_' - PVar n -> with opts env n - PCon n ps -> parens (annotate Con (qname n) $$* map go (toList ps)) - PDict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> qname n <+> equals <+> group (with opts env v)) os) <> flatAlt space line) + PVal PWildcard -> pretty '_' + PVal (PVar n) -> with opts env n + PVal (PCon n ps) -> parens (annotate Con (qname n) $$* map go (toList ps)) + PVal (PDict os) -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> qname n <+> equals <+> group (with opts env v)) os) <> flatAlt space line) print1 :: (Printable1 f, Printable a) => Options Print -> Env Print -> f a -> Print diff --git a/src/Facet/Term/Norm.hs b/src/Facet/Term/Norm.hs index 73a3f3fe0..48d706206 100644 --- a/src/Facet/Term/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -34,7 +34,7 @@ instance Quote Term X.Term where Lam cs -> X.Lam <$> traverse (uncurry clause) cs Ne v sp -> foldl' (\ h t -> X.App <$> h <*> quote t) (Quoter (\ d -> X.Var (toIndexed d v))) sp Dict os -> X.Dict <$> traverse (traverse quote) os - Comp p b -> X.Comp p . snd <$> clause (PDict p) b + Comp p b -> X.Comp p . snd <$> clause (PVal (PDict p)) b where clause :: Traversable t => t Name -> (t (Name :=: Term) -> Term) -> Quoter (t Name, X.Term) clause p b = Quoter (\ d -> let (d', p') = mapAccumL (\ d n -> (succ d, n :=: Ne (Free (LName d n)) Nil)) d p in (p, runQuoter d' (quote (b p')))) @@ -61,13 +61,13 @@ napp f a = case f of match :: Term -> Pattern Name -> Maybe (Pattern (Name :=: Term)) match s = \case - PWildcard -> Just PWildcard - PVar n -> Just (PVar (n :=: s)) - PCon n ps -> case s of - Con n' fs -> PCon n' <$ guard (n == n') <*> zipWithM match fs ps + PVal PWildcard -> Just (PVal PWildcard) + PVal (PVar n) -> Just (PVal (PVar (n :=: s))) + PVal (PCon n ps) -> case s of + Con n' fs -> PVal . PCon n' <$ guard (n == n') <*> zipWithM match fs ps _ -> Nothing - PDict ps -> case s of - Dict os -> PDict <$> zipWithM (\ (n1 :=: o) (n2 :=: p) -> (n1 :=: (p :=: o)) <$ guard (n1 == n2)) os ps + PVal (PDict ps) -> case s of + Dict os -> PVal . PDict <$> zipWithM (\ (n1 :=: o) (n2 :=: p) -> (n1 :=: (p :=: o)) <$ guard (n1 == n2)) os ps _ -> Nothing -- ninst :: Term -> T.Type -> Term diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 77a824308..c3a5e5567 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -36,6 +36,7 @@ import qualified Facet.Type.Class as C import qualified Facet.Type.Expr as TX import Facet.Usage hiding (singleton) import Fresnel.Prism (Prism', prism') +import Fresnel.Review (review) import GHC.Stack import Prelude hiding (lookup) @@ -140,7 +141,7 @@ eval subst = go where TX.Var (Global n) -> global n TX.Var (Free (Right n)) -> index env n TX.Var (Free (Left m)) -> fromMaybe (metavar m) (lookupMeta m subst) - TX.ForAll n t b -> ForAll n t (\ _T -> go (env |> PVar (n :=: _T)) b) + TX.ForAll n t b -> ForAll n t (\ _T -> go (env |> review _PVar (n :=: _T)) b) TX.Arrow n q a b -> Arrow n q (go env a) (go env b) TX.Comp s t -> Comp (mapSignature (go env) s) (go env t) TX.App f a -> go env f $$ go env a From 7b79a656ca6edf3744177c440a741e1865a33e4a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 19 Apr 2022 09:20:30 -0400 Subject: [PATCH 1112/1324] :fire: Comp. --- src/Facet/Eval.hs | 6 ------ src/Facet/Print.hs | 1 - src/Facet/Term/Expr.hs | 1 - src/Facet/Term/Norm.hs | 3 --- 4 files changed, 11 deletions(-) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index c62cbaac8..58a342e5e 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -58,7 +58,6 @@ eval = \case String s -> string s Dict os -> VDict <$> traverse (traverse eval) os Let p v b -> eval v >>= \ v' -> local (|> fromMaybe (error "eval: non-exhaustive pattern in let") (matchV id p v')) (eval b) - Comp p b -> comp p b global :: Has (Reader Graph :+: Reader Module) sig m => QName -> ReaderC (Env (Value (Eval m))) (Eval m) Term global n = do @@ -87,9 +86,6 @@ string = pure . VString con :: QName -> [ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m))] -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) con n fs = VCon n <$> sequenceA fs -comp :: [QName :=: Name] -> Term -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) -comp p b = pure $ VComp p b - -- Machinery @@ -129,7 +125,6 @@ data Value m -- | Computation; continuations, used in effect handlers. | VCont (Value m -> m (Value m)) | VDict [QName :=: Value m] - | VComp [QName :=: Name] Term instance Monad m => Quote (Value m) (m Term) where quote = \case @@ -139,7 +134,6 @@ instance Monad m => Quote (Value m) (m Term) where VCon n fs -> fmap (Con n) . sequenceA <$> traverse quote fs VString s -> pure . pure $ String s VDict os -> fmap Dict . traverse sequenceA <$> traverse (traverse quote) os - VComp p b -> pure . pure $ Comp p b unit :: Value m unit = VCon (NE.FromList ["Data", "Unit"] NE.|> T "unit") [] diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 40aee2744..f5e51a298 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -204,7 +204,6 @@ instance Printable C.Term where C.String s -> annotate Lit $ pretty (show s) C.Dict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> qname n <+> equals <+> group (go env v)) os) <> flatAlt space line) C.Let p v b -> let p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) in pretty "let" <+> braces (print opts env (view def_ <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p') b - C.Comp p b -> comp (clause env (PVal (PDict p), b)) where d = level env qvar = group . setPrec Var . qname diff --git a/src/Facet/Term/Expr.hs b/src/Facet/Term/Expr.hs index cc23d6823..22a4e331b 100644 --- a/src/Facet/Term/Expr.hs +++ b/src/Facet/Term/Expr.hs @@ -18,5 +18,4 @@ data Term | String Text | Dict [QName :=: Term] | Let (Pattern Name) Term Term - | Comp [QName :=: Name] Term -- ^ NB: the first argument is a specialization of @'Pattern' 'Name'@ to the 'PDict' constructor deriving (Eq, Ord, Show) diff --git a/src/Facet/Term/Norm.hs b/src/Facet/Term/Norm.hs index 48d706206..a13d6ac76 100644 --- a/src/Facet/Term/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -24,7 +24,6 @@ data Term | Lam [(Pattern Name, Pattern (Name :=: Term) -> Term)] | Ne (Var (LName Level)) (Snoc Term) | Dict [QName :=: Term] - | Comp [QName :=: Name] (Pattern (Name :=: Term) -> Term) deriving (Eq, Ord, Show) via Quoting X.Term Term instance Quote Term X.Term where @@ -34,7 +33,6 @@ instance Quote Term X.Term where Lam cs -> X.Lam <$> traverse (uncurry clause) cs Ne v sp -> foldl' (\ h t -> X.App <$> h <*> quote t) (Quoter (\ d -> X.Var (toIndexed d v))) sp Dict os -> X.Dict <$> traverse (traverse quote) os - Comp p b -> X.Comp p . snd <$> clause (PVal (PDict p)) b where clause :: Traversable t => t Name -> (t (Name :=: Term) -> Term) -> Quoter (t Name, X.Term) clause p b = Quoter (\ d -> let (d', p') = mapAccumL (\ d n -> (succ d, n :=: Ne (Free (LName d n)) Nil)) d p in (p, runQuoter d' (quote (b p')))) @@ -48,7 +46,6 @@ norm env = \case X.Lam cs -> Lam (map (\ (p, b) -> (p, \ p' -> norm (env |> p') b)) cs) X.Dict os -> Dict (map (fmap (norm env)) os) X.Let p v b -> norm (env |> fromMaybe (error "norm: non-exhaustive pattern in let") (match (norm env v) p)) b - X.Comp p b -> Comp p (\ p' -> norm (env |> p') b) napp :: Term -> Term -> Term From f2cb5e310fa279f33d06db7e9fc0bb3019a79b46 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 19 Apr 2022 09:48:10 -0400 Subject: [PATCH 1113/1324] :fire: Dict. --- src/Facet/Elab/Sequent.hs | 1 - src/Facet/Eval.hs | 6 ------ src/Facet/Pattern.hs | 2 -- src/Facet/Print.hs | 2 -- src/Facet/Term/Expr.hs | 1 - src/Facet/Term/Norm.hs | 6 ------ 6 files changed, 18 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 11d64d310..b98edb2d6 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -164,7 +164,6 @@ partitionBy clauses ctors = fold <$> for clauses (\case PCon (_:|>n) fs -> case Scope.lookupIndex n ctors of Nothing -> Nothing Just ix -> pure (Col.singleton ix [Clause (fs <> ps) b]) - _ -> Nothing _ -> Nothing) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 58a342e5e..bca216062 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -56,7 +56,6 @@ eval = \case App f a -> app (eval f) a Con n fs -> con n (eval <$> fs) String s -> string s - Dict os -> VDict <$> traverse (traverse eval) os Let p v b -> eval v >>= \ v' -> local (|> fromMaybe (error "eval: non-exhaustive pattern in let") (matchV id p v')) (eval b) global :: Has (Reader Graph :+: Reader Module) sig m => QName -> ReaderC (Env (Value (Eval m))) (Eval m) Term @@ -124,7 +123,6 @@ data Value m | VLam (Env (Value m)) [(Pattern Name, Term)] -- | Computation; continuations, used in effect handlers. | VCont (Value m -> m (Value m)) - | VDict [QName :=: Value m] instance Monad m => Quote (Value m) (m Term) where quote = \case @@ -133,7 +131,6 @@ instance Monad m => Quote (Value m) (m Term) where VVar v -> Quoter (\ d -> pure (Var (toIndexed d v))) VCon n fs -> fmap (Con n) . sequenceA <$> traverse quote fs VString s -> pure . pure $ String s - VDict os -> fmap Dict . traverse sequenceA <$> traverse (traverse quote) os unit :: Value m unit = VCon (NE.FromList ["Data", "Unit"] NE.|> T "unit") [] @@ -148,9 +145,6 @@ matchV k p s = case p of PVal (PCon n ps) | VCon n' fs <- s -> k . PVal . PCon n' <$ guard (n == n') <*> zipWithM (matchV id) ps fs PVal PCon{} -> Nothing - PVal (PDict ps) - | VDict os <- s -> k . PVal . PDict <$> zipWithM (\ (n1 :=: p) (n2 :=: o) -> (n1 :=: (p :=: o)) <$ guard (n1 == n2)) ps os - PVal PDict{} -> Nothing -- Quotation diff --git a/src/Facet/Pattern.hs b/src/Facet/Pattern.hs index 886694849..e8017f279 100644 --- a/src/Facet/Pattern.hs +++ b/src/Facet/Pattern.hs @@ -10,7 +10,6 @@ module Facet.Pattern import Data.Traversable (mapAccumL) import Facet.Name -import Facet.Syntax import Fresnel.Prism (Prism, Prism', prism, prism') -- Patterns @@ -27,7 +26,6 @@ data ValPattern a = PWildcard | PVar a | PCon QName [Pattern a] - | PDict [QName :=: a] deriving (Eq, Foldable, Functor, Ord, Show, Traversable) _PWildcard :: Prism' (Pattern a) () diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index f5e51a298..717848e54 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -202,7 +202,6 @@ instance Printable C.Term where C.App f a -> go env f $$ go env a C.Con n p -> qvar n $$* (group . go env <$> p) C.String s -> annotate Lit $ pretty (show s) - C.Dict os -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> qname n <+> equals <+> group (go env v)) os) <> flatAlt space line) C.Let p v b -> let p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) in pretty "let" <+> braces (print opts env (view def_ <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p') b where d = level env @@ -251,7 +250,6 @@ instance Printable1 Pattern where PVal PWildcard -> pretty '_' PVal (PVar n) -> with opts env n PVal (PCon n ps) -> parens (annotate Con (qname n) $$* map go (toList ps)) - PVal (PDict os) -> brackets (flatAlt space line <> commaSep (map (\ (n :=: v) -> qname n <+> equals <+> group (with opts env v)) os) <> flatAlt space line) print1 :: (Printable1 f, Printable a) => Options Print -> Env Print -> f a -> Print diff --git a/src/Facet/Term/Expr.hs b/src/Facet/Term/Expr.hs index 22a4e331b..4b51c83d3 100644 --- a/src/Facet/Term/Expr.hs +++ b/src/Facet/Term/Expr.hs @@ -16,6 +16,5 @@ data Term | App Term Term | Con QName [Term] | String Text - | Dict [QName :=: Term] | Let (Pattern Name) Term Term deriving (Eq, Ord, Show) diff --git a/src/Facet/Term/Norm.hs b/src/Facet/Term/Norm.hs index a13d6ac76..94558bc54 100644 --- a/src/Facet/Term/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -23,7 +23,6 @@ data Term | Con QName [Term] | Lam [(Pattern Name, Pattern (Name :=: Term) -> Term)] | Ne (Var (LName Level)) (Snoc Term) - | Dict [QName :=: Term] deriving (Eq, Ord, Show) via Quoting X.Term Term instance Quote Term X.Term where @@ -32,7 +31,6 @@ instance Quote Term X.Term where Con n sp -> X.Con n <$> traverse quote sp Lam cs -> X.Lam <$> traverse (uncurry clause) cs Ne v sp -> foldl' (\ h t -> X.App <$> h <*> quote t) (Quoter (\ d -> X.Var (toIndexed d v))) sp - Dict os -> X.Dict <$> traverse (traverse quote) os where clause :: Traversable t => t Name -> (t (Name :=: Term) -> Term) -> Quoter (t Name, X.Term) clause p b = Quoter (\ d -> let (d', p') = mapAccumL (\ d n -> (succ d, n :=: Ne (Free (LName d n)) Nil)) d p in (p, runQuoter d' (quote (b p')))) @@ -44,7 +42,6 @@ norm env = \case X.Con n sp -> Con n (norm env <$> sp) X.App f a -> norm env f `napp` norm env a X.Lam cs -> Lam (map (\ (p, b) -> (p, \ p' -> norm (env |> p') b)) cs) - X.Dict os -> Dict (map (fmap (norm env)) os) X.Let p v b -> norm (env |> fromMaybe (error "norm: non-exhaustive pattern in let") (match (norm env v) p)) b @@ -63,9 +60,6 @@ match s = \case PVal (PCon n ps) -> case s of Con n' fs -> PVal . PCon n' <$ guard (n == n') <*> zipWithM match fs ps _ -> Nothing - PVal (PDict ps) -> case s of - Dict os -> PVal . PDict <$> zipWithM (\ (n1 :=: o) (n2 :=: p) -> (n1 :=: (p :=: o)) <$ guard (n1 == n2)) os ps - _ -> Nothing -- ninst :: Term -> T.Type -> Term -- ninst f t = case f of From 078ec98866ef59d97a4c1befc4d2e70b1c47c2b6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 19 Apr 2022 09:56:15 -0400 Subject: [PATCH 1114/1324] Define effect patterns. --- src/Facet/Pattern.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Pattern.hs b/src/Facet/Pattern.hs index e8017f279..b05f75204 100644 --- a/src/Facet/Pattern.hs +++ b/src/Facet/Pattern.hs @@ -5,6 +5,7 @@ module Facet.Pattern , _PWildcard , _PVar , _PCon +, EffPattern(..) , fill ) where @@ -44,5 +45,8 @@ _PCon = _PVal.prism' (uncurry PCon) (\case _ -> Nothing) +data EffPattern a = POp QName [ValPattern a] (ValPattern a) + + fill :: Traversable t => (b -> (b, c)) -> b -> t a -> (b, t c) fill f = mapAccumL (const . f) From cf66e50d7429bf9aa77d8e952e219dbed0f43fdd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 19 Apr 2022 09:56:54 -0400 Subject: [PATCH 1115/1324] Derive. --- src/Facet/Pattern.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Pattern.hs b/src/Facet/Pattern.hs index b05f75204..86930dade 100644 --- a/src/Facet/Pattern.hs +++ b/src/Facet/Pattern.hs @@ -46,7 +46,7 @@ _PCon = _PVal.prism' (uncurry PCon) (\case data EffPattern a = POp QName [ValPattern a] (ValPattern a) - + deriving (Eq, Foldable, Functor, Ord, Show, Traversable) fill :: Traversable t => (b -> (b, c)) -> b -> t a -> (b, t c) fill f = mapAccumL (const . f) From ab78f4c4236ebac8ad43fa735af8e06ff0fe75d9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 19 Apr 2022 21:00:35 -0400 Subject: [PATCH 1116/1324] Add effect patterns back in. --- src/Facet/Elab/Sequent.hs | 2 +- src/Facet/Elab/Term.hs | 23 +++++++++++++---------- src/Facet/Eval.hs | 15 ++++++++++----- src/Facet/Pattern.hs | 14 ++++++++------ src/Facet/Print.hs | 18 +++++++++++++----- src/Facet/Term/Norm.hs | 14 +++++++++----- 6 files changed, 54 insertions(+), 32 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index b98edb2d6..f365b9c0b 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -163,7 +163,7 @@ partitionBy clauses ctors = fold <$> for clauses (\case PVar n -> pure (Col.fromList ([Clause (PVal (PVar n) :ps) b] <$ view Scope.toList_ ctors)) PCon (_:|>n) fs -> case Scope.lookupIndex n ctors of Nothing -> Nothing - Just ix -> pure (Col.singleton ix [Clause (fs <> ps) b]) + Just ix -> pure (Col.singleton ix [Clause (map PVal fs <> ps) b]) _ -> Nothing) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 8791daadc..d3c54f096 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -160,22 +160,22 @@ let' p a b = Check $ \ _B -> do -- Pattern combinators -wildcardP :: Bind m (Pattern (Name :==> Type)) -wildcardP = Bind $ \ _T k -> k (PVal PWildcard) +wildcardP :: Bind m (ValPattern (Name :==> Type)) +wildcardP = Bind $ \ _T k -> k PWildcard -varP :: Name -> Bind m (Pattern (Name :==> Type)) -varP n = Bind $ \ _A k -> k (PVal (PVar (n :==> wrap _A))) +varP :: Name -> Bind m (ValPattern (Name :==> Type)) +varP n = Bind $ \ _A k -> k (PVar (n :==> wrap _A)) where wrap = \case T.Comp sig _A -> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] |> T "Unit")) Nil) (T.Comp sig _A) _T -> _T -conP :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => QName -> [Bind m (Pattern (Name :==> Type))] -> Bind m (Pattern (Name :==> Type)) +conP :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => QName -> [Bind m (ValPattern (Name :==> Type))] -> Bind m (ValPattern (Name :==> Type)) conP n fs = Bind $ \ _A k -> do n' :=: _T <- resolveC n _T' <- maybe (pure _T) (foldl' (\ _T _A -> do t <- _T ; (_, _, b) <- assertQuantifier t ; pure (b _A)) (pure _T) . snd) (unNeutral _A) fs' <- runBind (fieldsP fs) _T' (\ (fs, _T) -> fs <$ unify (Exp _A) (Act _T)) - k $ PVal (PCon n' (fromList fs')) + k $ PCon n' (fromList fs') fieldsP :: Has (Throw ErrReason) sig m => [Bind m a] -> Bind m ([a], Type) fieldsP = foldr cons nil @@ -230,10 +230,13 @@ checkLam cs = lam (snd vs) -- FIXME: check for unique variable names bindPattern :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => S.Ann S.ValPattern -> Bind m (Pattern (Name :==> Type)) -bindPattern = withSpanB $ \case +bindPattern p = PVal <$> bindValPattern p + +bindValPattern :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => S.Ann S.ValPattern -> Bind m (ValPattern (Name :==> Type)) +bindValPattern = withSpanB $ \case S.PWildcard -> wildcardP S.PVar n -> varP n - S.PCon n ps -> conP n (map bindPattern ps) + S.PCon n ps -> conP n (map bindValPattern ps) -- | Elaborate a type abstracted over a kind’s parameters. @@ -261,7 +264,7 @@ abstractTerm body = go Nil Nil patternForArgType :: Has (Throw ErrReason :+: Write Warn) sig m => Type -> Name -> Bind m (Pattern (Name :==> Type)) patternForArgType = \case T.Comp{} -> allP - _ -> varP + _ -> fmap PVal . varP -- Declarations @@ -297,7 +300,7 @@ elabTermDef expr@(S.Ann s _ _) = Check $ \ _T -> do where go k = Check $ \ _T -> case _T of T.ForAll{} -> check (tlam (go k) ::: _T) - T.Arrow (Just n) q _A _B -> check (lam [(varP n, go k)] ::: T.Arrow Nothing q _A _B) + T.Arrow (Just n) q _A _B -> check (lam [(PVal <$> varP n, go k)] ::: T.Arrow Nothing q _A _B) -- FIXME: this doesn’t do what we want for tacit definitions, i.e. where _T is itself a telescope. -- FIXME: eta-expanding here doesn’t help either because it doesn’t change the way elaboration of the surface term occurs. -- we’ve exhausted the named parameters; the rest is up to the body. diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index bca216062..2c36fa856 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -140,11 +140,16 @@ unit = VCon (NE.FromList ["Data", "Unit"] NE.|> T "unit") [] matchV :: (Pattern (Name :=: Value m) -> a) -> Pattern Name -> Value m -> Maybe a matchV k p s = case p of - PVal PWildcard -> pure (k (PVal PWildcard)) - PVal (PVar n) -> pure (k (PVal (PVar (n :=: s)))) - PVal (PCon n ps) - | VCon n' fs <- s -> k . PVal . PCon n' <$ guard (n == n') <*> zipWithM (matchV id) ps fs - PVal PCon{} -> Nothing + PVal p -> val (k . PVal) p s + PEff _ -> Nothing + where + val :: (ValPattern (Name :=: Value m) -> a) -> ValPattern Name -> Value m -> Maybe a + val k p s = case p of + PWildcard -> pure (k PWildcard) + PVar n -> pure (k (PVar (n :=: s))) + PCon n ps + | VCon n' fs <- s -> k . PCon n' <$ guard (n == n') <*> zipWithM (val id) ps fs + PCon{} -> Nothing -- Quotation diff --git a/src/Facet/Pattern.hs b/src/Facet/Pattern.hs index 86930dade..c370630bb 100644 --- a/src/Facet/Pattern.hs +++ b/src/Facet/Pattern.hs @@ -11,22 +11,24 @@ module Facet.Pattern import Data.Traversable (mapAccumL) import Facet.Name -import Fresnel.Prism (Prism, Prism', prism, prism') +import Fresnel.Prism (Prism', prism') -- Patterns data Pattern a = PVal (ValPattern a) + | PEff (EffPattern a) deriving (Eq, Foldable, Functor, Ord, Show, Traversable) -_PVal :: Prism (Pattern a) (Pattern b) (ValPattern a) (ValPattern b) -_PVal = prism PVal (\case - PVal p -> Right p) +_PVal :: Prism' (Pattern a) (ValPattern a) +_PVal = prism' PVal (\case + PVal p -> Just p + _ -> Nothing) data ValPattern a = PWildcard | PVar a - | PCon QName [Pattern a] + | PCon QName [ValPattern a] deriving (Eq, Foldable, Functor, Ord, Show, Traversable) _PWildcard :: Prism' (Pattern a) () @@ -39,7 +41,7 @@ _PVar = _PVal.prism' PVar (\case PVar a -> Just a _ -> Nothing) -_PCon :: Prism' (Pattern a) (QName, [Pattern a]) +_PCon :: Prism' (Pattern a) (QName, [ValPattern a]) _PCon = _PVal.prism' (uncurry PCon) (\case PCon h sp -> Just (h, sp) _ -> Nothing) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 717848e54..3bcada3d2 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -25,7 +25,7 @@ module Facet.Print , print1 ) where -import Data.Foldable (foldl', toList) +import Data.Foldable (foldl') import Data.Maybe (fromMaybe) import qualified Data.Text as T import Data.Traversable (mapAccumL) @@ -243,13 +243,21 @@ class Printable1 f where instance Printable1 Interface where printWith with opts@Options{ qname } env (Interface h sp) = qname h $$* fmap (with opts env) sp -instance Printable1 Pattern where +instance Printable1 ValPattern where printWith with opts@Options{ qname } env = go where go = \case - PVal PWildcard -> pretty '_' - PVal (PVar n) -> with opts env n - PVal (PCon n ps) -> parens (annotate Con (qname n) $$* map go (toList ps)) + PWildcard -> pretty '_' + PVar n -> with opts env n + PCon n ps -> parens (annotate Con (qname n) $$* map go ps) + +instance Printable1 EffPattern where + printWith with opts@Options{ qname } env (POp n ps k) = brackets (qname n $$* map (printWith with opts env) ps <+> pretty ';' <+> printWith with opts env k) + +instance Printable1 Pattern where + printWith with opts env = \case + PVal p -> printWith with opts env p + PEff p -> printWith with opts env p print1 :: (Printable1 f, Printable a) => Options Print -> Env Print -> f a -> Print diff --git a/src/Facet/Term/Norm.hs b/src/Facet/Term/Norm.hs index 94558bc54..9f9e438d3 100644 --- a/src/Facet/Term/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -55,11 +55,15 @@ napp f a = case f of match :: Term -> Pattern Name -> Maybe (Pattern (Name :=: Term)) match s = \case - PVal PWildcard -> Just (PVal PWildcard) - PVal (PVar n) -> Just (PVal (PVar (n :=: s))) - PVal (PCon n ps) -> case s of - Con n' fs -> PVal . PCon n' <$ guard (n == n') <*> zipWithM match fs ps - _ -> Nothing + PVal p -> PVal <$> val s p + PEff _ -> Nothing + where + val s = \case + PWildcard -> Just PWildcard + PVar n -> Just (PVar (n :=: s)) + PCon n ps -> case s of + Con n' fs -> PCon n' <$ guard (n == n') <*> zipWithM val fs ps + _ -> Nothing -- ninst :: Term -> T.Type -> Term -- ninst f t = case f of From 54429f9ca638412305a5a421e89a485d97b890b3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 19 Apr 2022 21:03:30 -0400 Subject: [PATCH 1117/1324] Add fields for Clause. --- src/Facet/Elab/Sequent.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index f365b9c0b..90f37a269 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -153,7 +153,10 @@ checkLamS checkLamS _ = Check (\ _T -> mismatchTypes (Exp (Left "unimplemented")) (Act _T)) -data Clause a = Clause [Pattern Name] a +data Clause a = Clause + { patterns :: [Pattern Name] + , body :: a + } deriving (Show) partitionBy :: [Clause a] -> Scope.Scope Type -> Maybe (Col.Column [Clause a]) From be9a177de7bfe4e7a49bd596e37b658415b1efe5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 19 Apr 2022 21:06:24 -0400 Subject: [PATCH 1118/1324] Lenses. --- src/Facet/Elab/Sequent.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 90f37a269..9b169b7bf 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -12,6 +12,8 @@ module Facet.Elab.Sequent , synthExprS , checkExprS , Clause(..) +, patterns_ +, body_ , partitionBy -- * Assertions , assertTacitFunction @@ -52,6 +54,7 @@ import Facet.Type.Norm as T import Facet.Unify import Facet.Usage import Fresnel.Getter (view) +import Fresnel.Lens (Lens, Lens', lens) import GHC.Stack (HasCallStack, callStack, popCallStack, withFrozenCallStack) -- Variables @@ -159,6 +162,13 @@ data Clause a = Clause } deriving (Show) +patterns_ :: Lens' (Clause a) [Pattern Name] +patterns_ = lens patterns (\ c patterns -> c{ patterns }) + +body_ :: Lens (Clause a) (Clause b) a b +body_ = lens body (\ c body -> c{ body }) + + partitionBy :: [Clause a] -> Scope.Scope Type -> Maybe (Col.Column [Clause a]) partitionBy clauses ctors = fold <$> for clauses (\case Clause (PVal p:ps) b -> case p of From 733cd332668309928dffa2eac165501d76d7386d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 19 Apr 2022 21:33:57 -0400 Subject: [PATCH 1119/1324] Pass clauses to checkLamS. --- src/Facet/Elab/Sequent.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 9b169b7bf..b67e3dd41 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -143,15 +143,21 @@ synthAs t _T = as (checkExprS t ::: do { _T :==> _K <- Type.synthType _T ; (:==> checkExprS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, Has (Writer Usage) sig m, SQ.Sequent t c d, Applicative i) => S.Ann S.Expr -> Type <==: m (i t) checkExprS expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC expr $ \case S.Hole n -> hole n - S.Lam cs -> checkLamS (Check (\ _T -> map (\ (S.Clause (S.Ann _ _ p) b) -> (p, check (checkExprS b ::: _T))) cs)) + S.Lam cs -> checkLamS (Check (\ _T -> map (\ (S.Clause (S.Ann _ _ p) b) -> Clause [pattern p] (check (checkExprS b ::: _T))) cs)) S.Var{} -> switch (synthExprS expr) S.App{} -> switch (synthExprS expr) S.As{} -> switch (synthExprS expr) S.String{} -> switch (synthExprS expr) + where + pattern (S.PVal (Ann _ _ p)) = PVal (valPattern p) + pattern (S.PEff (Ann _ _ (S.POp n fs (Ann _ _ k)))) = PEff (POp n (map (valPattern . out) fs) (valPattern k)) + valPattern (S.PWildcard) = PWildcard + valPattern (S.PVar n) = PVar n + valPattern (S.PCon n fs) = PCon n (map (valPattern . out) fs) checkLamS :: Has (Throw ErrReason) sig m - => Type <==: [(S.Pattern, m (i t))] + => Type <==: [Clause (m (i t))] -> Type <==: m (i t) checkLamS _ = Check (\ _T -> mismatchTypes (Exp (Left "unimplemented")) (Act _T)) From f8761547544b70f7f798cc5f719cc71729c633fd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Apr 2022 07:36:53 -0400 Subject: [PATCH 1120/1324] Define an assertion for matching types. --- src/Facet/Elab.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index ed3c44b29..d45c3b7d1 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -34,6 +34,7 @@ module Facet.Elab , freeVariable , missingInterface , assertMatch +, assertTypesMatch , assertFunction , ErrC(..) -- * Warnings @@ -336,6 +337,9 @@ warn reason = do assertMatch :: Applicative m => (Exp (Either String b) -> Act s -> m a) -> Prism' s a -> String -> s -> m a assertMatch mismatch pat exp _T = maybe (mismatch (Exp (Left exp)) (Act _T)) pure (_T ^? pat) +assertTypesMatch :: Has (Throw ErrReason) sig m => Prism' Type a -> String -> Type -> m a +assertTypesMatch pat exp _T = maybe (mismatchTypes (Exp (Left exp)) (Act _T)) pure (_T ^? pat) + assertFunction :: Has (Throw ErrReason) sig m => Type -> m (Maybe Name, Quantity, Type, Type) assertFunction = assertMatch mismatchTypes _Arrow "_ -> _" From 7a3d76fd3f350386b249b0300514e8042edca0c5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Apr 2022 07:38:19 -0400 Subject: [PATCH 1121/1324] Use assertTypesMatch. --- src/Facet/Elab.hs | 2 +- src/Facet/Elab/Sequent.hs | 2 +- src/Facet/Elab/Term.hs | 6 +++--- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index d45c3b7d1..7ec1aafd0 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -341,7 +341,7 @@ assertTypesMatch :: Has (Throw ErrReason) sig m => Prism' Type a -> String -> Ty assertTypesMatch pat exp _T = maybe (mismatchTypes (Exp (Left exp)) (Act _T)) pure (_T ^? pat) assertFunction :: Has (Throw ErrReason) sig m => Type -> m (Maybe Name, Quantity, Type, Type) -assertFunction = assertMatch mismatchTypes _Arrow "_ -> _" +assertFunction = assertTypesMatch _Arrow "_ -> _" -- Unification diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index b67e3dd41..4c27e7732 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -190,7 +190,7 @@ partitionBy clauses ctors = fold <$> for clauses (\case -- | Expect a tacit (non-variable-binding) function type. assertTacitFunction :: Has (Throw ErrReason) sig m => Type -> m (Maybe Name, Quantity, Type, Type) -assertTacitFunction = assertMatch mismatchTypes _Arrow "_ -> _" +assertTacitFunction = assertTypesMatch _Arrow "_ -> _" -- Judgements diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index d3c54f096..416bb9828 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -350,15 +350,15 @@ letrec setter key projection initial final = do -- Errors assertQuantifier :: Has (Throw ErrReason) sig m => Type -> m (Name, Kind, Type -> Type) -assertQuantifier = assertMatch mismatchTypes _ForAll "{_} -> _" +assertQuantifier = assertTypesMatch _ForAll "{_} -> _" -- | Expect a tacit (non-variable-binding) function type. assertTacitFunction :: Has (Throw ErrReason) sig m => Type -> m (Maybe Name, Quantity, Type, Type) -assertTacitFunction = assertMatch mismatchTypes _Arrow "_ -> _" +assertTacitFunction = assertTypesMatch _Arrow "_ -> _" -- | Expect a computation type with effects. assertComp :: Has (Throw ErrReason) sig m => Type -> m (Signature Type, Type) -assertComp = assertMatch mismatchTypes _Comp "[_] _" +assertComp = assertTypesMatch _Comp "[_] _" -- Elaboration From 704a210e4e40f20a35e2ddfe624e8d51f7515c00 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Apr 2022 07:50:51 -0400 Subject: [PATCH 1122/1324] Rename Opaque to String. --- src/Facet/Elab/Pattern.hs | 2 +- src/Facet/Sequent/Type.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 31e3dc0f9..106371159 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -44,7 +44,7 @@ compileClauses _ _T heads compileClausesBody :: Has Empty sig m => [X.Term] -> Type -> Type -> [Clause X.Term] -> QuoterT m X.Term -> QuoterT m X.Coterm -> QuoterT m X.Command compileClausesBody ctx _A _T heads v k = case _A of - Opaque -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) C..|. k + String -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) C..|. k _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) C..|. k One -> (match (_Unit.to (const [])) heads >>= compileClauses ctx _T) C..|. k _A :* _B -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Var._Nothing.to (const [Var Nothing, Var Nothing])))) heads >>= \ heads' -> diff --git a/src/Facet/Sequent/Type.hs b/src/Facet/Sequent/Type.hs index 06e9c8a2d..e965e863f 100644 --- a/src/Facet/Sequent/Type.hs +++ b/src/Facet/Sequent/Type.hs @@ -3,7 +3,7 @@ module Facet.Sequent.Type ) where data Type - = Opaque + = String | One | Type :+ Type | Type :* Type From 5a947fcbe683bbb7a65ae4cdedc66ffda46988a2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Apr 2022 07:52:47 -0400 Subject: [PATCH 1123/1324] Rename :-> to Arrow and add fields. --- src/Facet/Elab/Pattern.hs | 4 ++-- src/Facet/Sequent/Type.hs | 6 ++++-- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 106371159..b9d4b9335 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -37,7 +37,7 @@ instantiateHead p = p compileClauses :: Has Empty sig m => [X.Term] -> Type -> [Clause X.Term] -> QuoterT m X.Term -compileClauses ctx (_A :-> _T) heads = C.lamR (compileClausesBody ctx _A _T heads) +compileClauses ctx (Arrow Nothing _ _A _T) heads = C.lamR (compileClausesBody ctx _A _T heads) compileClauses _ _T heads | Just (Clause [] b) <- preview folded heads = pure b | otherwise = empty @@ -45,7 +45,7 @@ compileClauses _ _T heads compileClausesBody :: Has Empty sig m => [X.Term] -> Type -> Type -> [Clause X.Term] -> QuoterT m X.Term -> QuoterT m X.Coterm -> QuoterT m X.Command compileClausesBody ctx _A _T heads v k = case _A of String -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) C..|. k - _ :-> _ -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) C..|. k + Arrow{} -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) C..|. k One -> (match (_Unit.to (const [])) heads >>= compileClauses ctx _T) C..|. k _A :* _B -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Var._Nothing.to (const [Var Nothing, Var Nothing])))) heads >>= \ heads' -> C.let' (C.µR (\ k -> v C..|. C.prdL1 k)) (\ _ -> diff --git a/src/Facet/Sequent/Type.hs b/src/Facet/Sequent/Type.hs index e965e863f..7c490bf1f 100644 --- a/src/Facet/Sequent/Type.hs +++ b/src/Facet/Sequent/Type.hs @@ -2,14 +2,16 @@ module Facet.Sequent.Type ( Type(..) ) where +import Facet.Name (Name) +import Facet.Usage (Quantity) + data Type = String | One | Type :+ Type | Type :* Type - | Type :-> Type + | Arrow (Maybe Name) Quantity Type Type deriving (Eq, Ord, Show) infixl 6 :+ infixl 7 :* -infixr 1 :-> From 2a0bc24e0e18b8127c3d38e8021a2335033df402 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Apr 2022 08:02:16 -0400 Subject: [PATCH 1124/1324] :fire: some instances. --- src/Facet/Sequent/Type.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Facet/Sequent/Type.hs b/src/Facet/Sequent/Type.hs index 7c490bf1f..832d1520f 100644 --- a/src/Facet/Sequent/Type.hs +++ b/src/Facet/Sequent/Type.hs @@ -11,7 +11,6 @@ data Type | Type :+ Type | Type :* Type | Arrow (Maybe Name) Quantity Type Type - deriving (Eq, Ord, Show) infixl 6 :+ infixl 7 :* From 914c04400966977c6301eec6829f577752e15ac3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Apr 2022 08:02:54 -0400 Subject: [PATCH 1125/1324] Add quantifiers. --- src/Facet/Elab/Pattern.hs | 1 + src/Facet/Sequent/Type.hs | 2 ++ 2 files changed, 3 insertions(+) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index b9d4b9335..e7973a190 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -45,6 +45,7 @@ compileClauses _ _T heads compileClausesBody :: Has Empty sig m => [X.Term] -> Type -> Type -> [Clause X.Term] -> QuoterT m X.Term -> QuoterT m X.Coterm -> QuoterT m X.Command compileClausesBody ctx _A _T heads v k = case _A of String -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) C..|. k + ForAll{} -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) C..|. k Arrow{} -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) C..|. k One -> (match (_Unit.to (const [])) heads >>= compileClauses ctx _T) C..|. k _A :* _B -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Var._Nothing.to (const [Var Nothing, Var Nothing])))) heads >>= \ heads' -> diff --git a/src/Facet/Sequent/Type.hs b/src/Facet/Sequent/Type.hs index 832d1520f..f1b8cd36c 100644 --- a/src/Facet/Sequent/Type.hs +++ b/src/Facet/Sequent/Type.hs @@ -2,6 +2,7 @@ module Facet.Sequent.Type ( Type(..) ) where +import Facet.Kind (Kind) import Facet.Name (Name) import Facet.Usage (Quantity) @@ -10,6 +11,7 @@ data Type | One | Type :+ Type | Type :* Type + | ForAll Name Kind (Type -> Type) | Arrow (Maybe Name) Quantity Type Type infixl 6 :+ From 6fe7641921c4eb64a99759aa7c4bc3f95584629d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 22 Apr 2022 09:52:00 -0400 Subject: [PATCH 1126/1324] :fire: unit types & patterns. --- src/Facet/Elab/Pattern.hs | 1 - src/Facet/Sequent/Pattern.hs | 8 -------- src/Facet/Sequent/Type.hs | 1 - 3 files changed, 10 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index e7973a190..df4b5ddc7 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -47,7 +47,6 @@ compileClausesBody ctx _A _T heads v k = case _A of String -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) C..|. k ForAll{} -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) C..|. k Arrow{} -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) C..|. k - One -> (match (_Unit.to (const [])) heads >>= compileClauses ctx _T) C..|. k _A :* _B -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Var._Nothing.to (const [Var Nothing, Var Nothing])))) heads >>= \ heads' -> C.let' (C.µR (\ k -> v C..|. C.prdL1 k)) (\ _ -> C.let' (C.µR (\ k -> v C..|. C.prdL2 k)) (\ _ -> diff --git a/src/Facet/Sequent/Pattern.hs b/src/Facet/Sequent/Pattern.hs index 953496400..afc4a22b2 100644 --- a/src/Facet/Sequent/Pattern.hs +++ b/src/Facet/Sequent/Pattern.hs @@ -2,7 +2,6 @@ module Facet.Sequent.Pattern ( -- * Patterns Pattern(..) , _Var -, _Unit , _InL , _InR , _Pair @@ -17,7 +16,6 @@ import Fresnel.Prism (Prism', prism') data Pattern a = Var (Maybe a) - | Unit | InL (Pattern a) | InR (Pattern a) | Pair (Pattern a) (Pattern a) @@ -31,7 +29,6 @@ instance Monad Pattern where m >>= f = case m of Var (Just a) -> f a Var Nothing -> Var Nothing - Unit -> Unit InL p -> InL (p >>= f) InR q -> InR (q >>= f) Pair p q -> Pair (p >>= f) (q >>= f) @@ -42,11 +39,6 @@ _Var = prism' Var (\case Var a -> Just a _ -> Nothing) -_Unit :: Prism' (Pattern a) () -_Unit = prism' (const Unit) (\case - Unit -> Just () - _ -> Nothing) - _InL :: Prism' (Pattern a) (Pattern a) _InL = prism' InL (\case InL p -> Just p diff --git a/src/Facet/Sequent/Type.hs b/src/Facet/Sequent/Type.hs index f1b8cd36c..e76b1971b 100644 --- a/src/Facet/Sequent/Type.hs +++ b/src/Facet/Sequent/Type.hs @@ -8,7 +8,6 @@ import Facet.Usage (Quantity) data Type = String - | One | Type :+ Type | Type :* Type | ForAll Name Kind (Type -> Type) From edb8edbf3b47b47643bd5737279a24b61d3b61bb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 23 Apr 2022 22:05:17 -0400 Subject: [PATCH 1127/1324] Derive a Foldable instance for .. --- src/Facet/Functor/Compose.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index ef3702aa6..68c82d158 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -18,7 +18,7 @@ import Data.Functor.Identity (Identity(..)) -- Composition functor newtype (i . j) a = C { runC :: i (j a) } - deriving (Functor) + deriving (Foldable, Functor) instance (Applicative i, Applicative j) => Applicative (i . j) where pure = liftCInner . pure From 21301ad1ec449fd52d97f7eff380e9fbb26168ad Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 23 Apr 2022 22:05:40 -0400 Subject: [PATCH 1128/1324] Derive a Traversable instance for .. --- src/Facet/Functor/Compose.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Functor/Compose.hs b/src/Facet/Functor/Compose.hs index 68c82d158..2985c2840 100644 --- a/src/Facet/Functor/Compose.hs +++ b/src/Facet/Functor/Compose.hs @@ -18,7 +18,7 @@ import Data.Functor.Identity (Identity(..)) -- Composition functor newtype (i . j) a = C { runC :: i (j a) } - deriving (Foldable, Functor) + deriving (Foldable, Functor, Traversable) instance (Applicative i, Applicative j) => Applicative (i . j) where pure = liftCInner . pure From 7e81d40b7d42e10367d9c8996c1bf569df2dcec3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 23 Apr 2022 22:19:53 -0400 Subject: [PATCH 1129/1324] Split Sequent into separate classes. --- src/Facet/Elab/Sequent.hs | 18 ++++++++--------- src/Facet/Sequent/Class.hs | 41 +++++++++++++++++++------------------- src/Facet/Sequent/Expr.hs | 14 ++++++++----- src/Facet/Sequent/Norm.hs | 4 +++- src/Facet/Sequent/Print.hs | 4 +++- 5 files changed, 45 insertions(+), 36 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 4c27e7732..6bca8a44a 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -60,7 +60,7 @@ import GHC.Stack (HasCallStack, callStack, popCallStack, withFrozenCal -- Variables -- FIXME: we’re instantiating when inspecting types in the REPL. -globalS :: (Has (State (Subst Type)) sig m, SQ.Sequent t c d, Applicative i) => QName ::: Type -> m (i t :==> Type) +globalS :: (Has (State (Subst Type)) sig m, SQ.Term t c d, Applicative i) => QName ::: Type -> m (i t :==> Type) globalS (q ::: _T) = do v <- SQ.varA (Global q) (\ (v ::: _T) -> v :==> _T) <$> instantiate const (v ::: _T) @@ -68,7 +68,7 @@ globalS (q ::: _T) = do -- FIXME: do we need to instantiate here to deal with rank-n applications? -- FIXME: effect ops not in the sig are reported as not in scope -- FIXME: effect ops in the sig are available whether or not they’re in scope -varS :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m, SQ.Sequent t c d, Applicative i) => QName -> m (i t :==> Type) +varS :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m, SQ.Term t c d, Applicative i) => QName -> m (i t :==> Type) varS n = views context_ (lookupInContext n) >>= \case [(n', Right (q, _T))] -> do use n' q @@ -85,20 +85,20 @@ hole n = Check $ \ _T -> withFrozenCallStack $ throwError $ Hole n _T -- Constructors lamS - :: (Has (Throw ErrReason) sig m, SQ.Sequent t c d, Applicative i) + :: (Has (Throw ErrReason) sig m, SQ.Term t c d, Applicative i) => (forall j . Applicative j => (i ~> j) -> j t :@ Quantity :==> Type -> j c :@ Quantity :==> Type -> Type <==: m (j d)) -> Type <==: m (i t) lamS f = runC $ SQ.lamRA $ \ wk a k -> C $ Check $ \ _T -> do (_, q, _A, _B) <- assertTacitFunction _T check (f wk (a :@ q :==> _A) (k :@ q :==> _B) ::: _B) -stringS :: (Applicative m, SQ.Sequent t c d, Applicative i) => Text -> m (i t :==> Type) +stringS :: (Applicative m, SQ.Term t c d, Applicative i) => Text -> m (i t :==> Type) stringS s = SQ.stringRA s ==> pure T.String -- Eliminators -appS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m, SQ.Sequent t c d, Applicative i) => (HasCallStack => m (i t :==> Type)) -> (HasCallStack => Type <==: m (i t)) -> m (i t :==> Type) +appS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m, SQ.Term t c d, SQ.Coterm t c d, SQ.Command t c d, Applicative i) => (HasCallStack => m (i t :==> Type)) -> (HasCallStack => Type <==: m (i t)) -> m (i t :==> Type) appS f a = do f' :==> _F <- f (_, q, _A, _B) <- assertFunction _F @@ -122,7 +122,7 @@ as (m ::: _T) = do -- Elaboration -synthExprS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, Has (Writer Usage) sig m, SQ.Sequent t c d, Applicative i) => S.Ann S.Expr -> m (i t :==> Type) +synthExprS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, Has (Writer Usage) sig m, SQ.Term t c d, SQ.Coterm t c d, SQ.Command t c d, Applicative i) => S.Ann S.Expr -> m (i t :==> Type) synthExprS = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \case S.Var n -> varS n S.App f a -> synthApp f a @@ -133,14 +133,14 @@ synthExprS = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \ca where nope = couldNotSynthesize -synthApp :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, Has (Writer Usage) sig m, SQ.Sequent t c d, Applicative i) => S.Ann S.Expr -> S.Ann S.Expr -> m (i t :==> Type) +synthApp :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, Has (Writer Usage) sig m, SQ.Term t c d, SQ.Coterm t c d, SQ.Command t c d, Applicative i) => S.Ann S.Expr -> S.Ann S.Expr -> m (i t :==> Type) synthApp f a = appS (synthExprS f) (checkExprS a) -synthAs :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, Has (Writer Usage) sig m, SQ.Sequent t c d, Applicative i) => S.Ann S.Expr -> S.Ann S.Type -> m (i t :==> Type) +synthAs :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, Has (Writer Usage) sig m, SQ.Term t c d, SQ.Coterm t c d, SQ.Command t c d, Applicative i) => S.Ann S.Expr -> S.Ann S.Type -> m (i t :==> Type) synthAs t _T = as (checkExprS t ::: do { _T :==> _K <- Type.synthType _T ; (:==> _K) <$> evalTExpr _T }) -checkExprS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, Has (Writer Usage) sig m, SQ.Sequent t c d, Applicative i) => S.Ann S.Expr -> Type <==: m (i t) +checkExprS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, Has (Writer Usage) sig m, SQ.Term t c d, SQ.Coterm t c d, SQ.Command t c d, Applicative i) => S.Ann S.Expr -> Type <==: m (i t) checkExprS expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC expr $ \case S.Hole n -> hole n S.Lam cs -> checkLamS (Check (\ _T -> map (\ (S.Clause (S.Ann _ _ p) b) -> Clause [pattern p] (check (checkExprS b ::: _T))) cs)) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs index b14bcd4d5..94eedbd2b 100644 --- a/src/Facet/Sequent/Class.hs +++ b/src/Facet/Sequent/Class.hs @@ -2,7 +2,9 @@ {-# LANGUAGE FunctionalDependencies #-} module Facet.Sequent.Class ( -- * Sequent abstraction - Sequent(..) + Term(..) +, Coterm(..) +, Command(..) , (.$.) -- * Effectful abstractions , varA @@ -32,8 +34,7 @@ import Facet.Syntax (Var, type (~>)) -- * Term abstraction -class Sequent term coterm command | coterm -> term command, term -> coterm command, command -> term coterm where - -- Terms +class Term term coterm command | coterm -> term command, term -> coterm command, command -> term coterm where var :: Var Level -> term µR :: (coterm -> command) -> term lamR :: (term -> coterm -> command) -> term @@ -43,7 +44,7 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma prdR :: term -> term -> term stringR :: Text -> term - -- Coterms +class Coterm term coterm command | coterm -> term command, term -> coterm command, command -> term coterm where covar :: Var Level -> coterm µL :: (term -> command) -> coterm lamL :: term -> coterm -> coterm @@ -52,13 +53,13 @@ class Sequent term coterm command | coterm -> term command, term -> coterm comma prdL1 :: coterm -> coterm prdL2 :: coterm -> coterm - -- Commands +class Command term coterm command | coterm -> term command, term -> coterm command, command -> term coterm where (.|.) :: term -> coterm -> command let' :: term -> (term -> command) -> command infix 1 .|. -(.$.) :: Sequent term coterm command => term -> coterm -> coterm +(.$.) :: Coterm term coterm command => term -> coterm -> coterm (.$.) = lamL infixr 9 .$. @@ -66,41 +67,41 @@ infixr 9 .$. -- * Effectful abstractions -varA :: (Sequent t c d, Applicative i, Applicative m) => Var Level -> m (i t) +varA :: (Term t c d, Applicative i, Applicative m) => Var Level -> m (i t) varA v = pure (pure (var v)) µRA - :: (Sequent t c d, Applicative i, Applicative m) + :: (Term t c d, Applicative i, Applicative m) => (forall j . Applicative j => (i ~> j) -> j c -> m (j d)) -> m (i t) µRA = binder µR -lamRA :: (Sequent t c d, Applicative i, Applicative m) => (forall j . Applicative j => (i ~> j) -> j t -> j c -> m (j d)) -> m (i t) +lamRA :: (Term t c d, Applicative i, Applicative m) => (forall j . Applicative j => (i ~> j) -> j t -> j c -> m (j d)) -> m (i t) lamRA f = inner (\ wk v -> f wk (fst <$> v) (snd <$> v)) where inner = binder (lamR . curry) -stringRA :: (Sequent t c d, Applicative i, Applicative m) => Text -> m (i t) +stringRA :: (Term t c d, Applicative i, Applicative m) => Text -> m (i t) stringRA = pure . pure . stringR -covarA :: (Sequent t c d, Applicative i, Applicative m) => Var Level -> m (i c) +covarA :: (Coterm t c d, Applicative i, Applicative m) => Var Level -> m (i c) covarA v = pure (pure (covar v)) µLA - :: (Sequent t c d, Applicative i, Applicative m) + :: (Coterm t c d, Applicative i, Applicative m) => (forall j . Applicative j => (i ~> j) -> j t -> m (j d)) -> m (i c) µLA = binder µL lamLA - :: (Sequent t c d, Applicative i, Applicative m) + :: (Coterm t c d, Applicative i, Applicative m) => m (i t) -> m (i c) -> m (i c) lamLA = liftA2 (liftA2 lamL) (.$$.) - :: (Sequent t c d, Applicative i, Applicative m) + :: (Coterm t c d, Applicative i, Applicative m) => m (i t) -> m (i c) -> m (i c) @@ -109,36 +110,36 @@ lamLA = liftA2 (liftA2 lamL) infixr 9 .$$. sumLA - :: (Sequent t c d, Applicative i, Applicative m) + :: (Coterm t c d, Applicative i, Applicative m) => m (i [c]) -> m (i c) sumLA = fmap (fmap sumL) -- sumLA --- :: (Sequent t c d, Applicative i, Applicative m) +-- :: (Coterm t c d, Applicative i, Applicative m) -- => [C.Clause m i t d] -- -> m (i c) -- sumLA cs = runC (sumL <$> traverse (\ (C.Clause c) -> C (binder id c)) cs) prdL1A - :: (Sequent t c d, Applicative i, Applicative m) + :: (Coterm t c d, Applicative i, Applicative m) => m (i c) -> m (i c) prdL1A = fmap (fmap prdL1) prdL2A - :: (Sequent t c d, Applicative i, Applicative m) + :: (Coterm t c d, Applicative i, Applicative m) => m (i c) -> m (i c) prdL2A = fmap (fmap prdL2) -(.||.) :: (Applicative m, Applicative i, Sequent t c d) => m (i t) -> m (i c) -> m (i d) +(.||.) :: (Applicative m, Applicative i, Command t c d) => m (i t) -> m (i c) -> m (i d) (.||.) = liftA2 (liftA2 (.|.)) infix 1 .||. -letA :: (Applicative m, Applicative i, Sequent t c d) => m (i t) -> (forall j . Applicative j => (i ~> j) -> j t -> m (j d)) -> m (i d) +letA :: (Applicative m, Applicative i, Command t c d) => m (i t) -> (forall j . Applicative j => (i ~> j) -> j t -> m (j d)) -> m (i d) letA t b = liftA2 let' <$> t <*> (runC <$> b weaken (liftCInner id)) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 3dcc897a8..c178dce20 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -50,7 +50,7 @@ data Command | Let Term Command -instance Applicative m => C.Sequent (QuoterT m Term) (QuoterT m Coterm) (QuoterT m Command) where +instance Applicative m => C.Term (QuoterT m Term) (QuoterT m Coterm) (QuoterT m Command) where var inner = QuoterT (\ outer -> pure (Var (toIndexed outer inner))) µR body = MuR <$> binderT (C.covar . Free) body lamR body = LamR <$> binderT (C.var . Free) (binderT (C.covar . Free) . body) @@ -60,6 +60,7 @@ instance Applicative m => C.Sequent (QuoterT m Term) (QuoterT m Coterm) (QuoterT prdR = liftA2 PrdR stringR = pure . StringR +instance Applicative m => C.Coterm (QuoterT m Term) (QuoterT m Coterm) (QuoterT m Command) where covar inner = QuoterT (\ outer -> pure (Covar (toIndexed outer inner))) µL body = MuL <$> binderT (C.var . Free) body lamL = liftA2 LamL @@ -68,10 +69,11 @@ instance Applicative m => C.Sequent (QuoterT m Term) (QuoterT m Coterm) (QuoterT prdL1 = fmap PrdL1 prdL2 = fmap PrdL2 +instance Applicative m => C.Command (QuoterT m Term) (QuoterT m Coterm) (QuoterT m Command) where (.|.) = liftA2 (:|:) let' t b = Let <$> t <*> binderT (C.var . Free) b -instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where +instance C.Term (Quoter Term) (Quoter Coterm) (Quoter Command) where var v = Quoter (\ d -> Var (toIndexed d v)) µR b = MuR <$> binder (\ d' -> Quoter (\ d -> covar (toIndexed d d'))) b lamR b = LamR <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) (binder (\ d'' -> Quoter (\ d -> covar (toIndexed d d''))) . b) @@ -81,6 +83,7 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where prdR = liftA2 PrdR stringR = pure . StringR +instance C.Coterm (Quoter Term) (Quoter Coterm) (Quoter Command) where covar v = Quoter (\ d -> Covar (toIndexed d v)) µL b = MuL <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b lamL = liftA2 LamL @@ -89,6 +92,7 @@ instance C.Sequent (Quoter Term) (Quoter Coterm) (Quoter Command) where prdL1 = fmap PrdL1 prdL2 = fmap PrdL2 +instance C.Command (Quoter Term) (Quoter Coterm) (Quoter Command) where (.|.) = liftA2 (:|:) let' t b = Let <$> t <*> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b @@ -101,7 +105,7 @@ covar = Covar . Free -- Interpreters -interpretTerm :: C.Sequent t c d => [t] -> [c] -> Term -> t +interpretTerm :: (C.Term t c d, C.Coterm t c d, C.Command t c d) => [t] -> [c] -> Term -> t interpretTerm _G _D = \case Var (Free n) -> _G `index` n Var (Global n) -> C.var (Global n) @@ -113,7 +117,7 @@ interpretTerm _G _D = \case PrdR l r -> C.prdR (interpretTerm _G _D l) (interpretTerm _G _D r) StringR s -> C.stringR s -interpretCoterm :: C.Sequent t c d => [t] -> [c] -> Coterm -> c +interpretCoterm :: (C.Term t c d, C.Coterm t c d, C.Command t c d) => [t] -> [c] -> Coterm -> c interpretCoterm _G _D = \case Covar (Free n) -> _D `index` n Covar (Global n) -> C.covar (Global n) @@ -124,7 +128,7 @@ interpretCoterm _G _D = \case PrdL1 c -> C.prdL1 (interpretCoterm _G _D c) PrdL2 c -> C.prdL2 (interpretCoterm _G _D c) -interpretCommand :: C.Sequent t c d => [t] -> [c] -> Command -> d +interpretCommand :: (C.Term t c d, C.Coterm t c d, C.Command t c d) => [t] -> [c] -> Command -> d interpretCommand _G _D (t :|: c) = interpretTerm _G _D t C..|. interpretCoterm _G _D c interpretCommand _G _D (Let t b) = C.let' (interpretTerm _G _D t) (\ t -> interpretCommand (t:_G) _D b) diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs index 051195735..f21c19d1d 100644 --- a/src/Facet/Sequent/Norm.hs +++ b/src/Facet/Sequent/Norm.hs @@ -47,7 +47,7 @@ data Command | Let Term (Term -> Command) -instance Class.Sequent Term Coterm Command where +instance Class.Term Term Coterm Command where var = Var µR = MuR lamR = LamR @@ -57,6 +57,7 @@ instance Class.Sequent Term Coterm Command where prdR = PrdR stringR = StringR +instance Class.Coterm Term Coterm Command where covar = Covar µL = MuL lamL = LamL @@ -65,6 +66,7 @@ instance Class.Sequent Term Coterm Command where prdL1 = PrdL1 prdL2 = PrdL2 +instance Class.Command Term Coterm Command where (.|.) = (:|:) let' = Let diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs index be78fade3..9bb7036e2 100644 --- a/src/Facet/Sequent/Print.hs +++ b/src/Facet/Sequent/Print.hs @@ -24,7 +24,7 @@ instance Show Print where showsPrec p = showsPrec p . getPrint quietOptions -instance S.Sequent Print Print Print where +instance S.Term Print Print Print where var = var µR b = P.pretty "µ" <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) lamR c = P.pretty "λ" <> P.braces (fresh (\ u -> fresh (\ v -> anon u <> P.comma P.<+> anon v P.<+> P.pretty "." P.<+> c (anon u) (anon v)))) @@ -34,6 +34,7 @@ instance S.Sequent Print Print Print where prdR l r = P.tupled [l, r] stringR = P.pretty . show +instance S.Coterm Print Print Print where covar = var µL b = µ̃ <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) lamL a k = a P.<+> P.dot P.<+> k @@ -42,6 +43,7 @@ instance S.Sequent Print Print Print where prdL1 k = P.parens (µ̃ <> P.braces (P.pretty "πl" P.<+> k)) prdL2 k = P.parens (µ̃ <> P.braces (P.pretty "πr" P.<+> k)) +instance S.Command Print Print Print where (.|.) = fmap (P.enclose P.langle P.rangle) . P.surround P.pipe let' v b = P.pretty "let" P.<+> withLevel anon P.<+> P.pretty '=' P.<+> v P.<+> P.pretty "in" P.<+> fresh (b . anon) From 9a0d869a108cb45fb619c88b19ac2c11d3828ff7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 23 Apr 2022 23:56:56 -0400 Subject: [PATCH 1130/1324] :fire: weakening in Context. --- src/Facet/Context.hs | 6 +++--- src/Facet/Elab.hs | 2 +- src/Facet/Notice/Elab.hs | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index 5c644e3ea..d6e0f9ea0 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -30,7 +30,7 @@ import Prelude hiding (lookup) newtype Context = Context { elems :: S.Snoc Binding } data Binding - = forall i j . Type Quantity (i ~> j) (Pattern (Name :==> Type)) + = Type Quantity (Pattern (Name :==> Type)) | Kind (Name :==> Kind) @@ -58,7 +58,7 @@ lookupIndex n = go (Index 0) . elems where go _ S.Nil = E.empty go i (cs S.:> b) = case b of - Type q _ p + Type q p | Just (n' :==> t) <- find ((== n) . proof) p -> pure (LName i n', Right (q, t)) Kind (n' :==> k) | n == n' -> pure (LName i n', Left k) @@ -69,7 +69,7 @@ toEnv :: Context -> Env.Env Type toEnv c = Env.Env (S.fromList (zipWith toType (toList (elems c)) [0..pred (level c)])) where toType b d = case b of - Type _ _ p -> (\ b -> proof b :=: bind d (proof b)) <$> p + Type _ p -> (\ b -> proof b :=: bind d (proof b)) <$> p Kind (n :==> _) -> review _PVar (n :=: bind d n) bind d b = free (LName d b) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 7ec1aafd0..3dfb2bfe9 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -159,7 +159,7 @@ lookupInSig (m :|> n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':|>_) _ (|-) :: Has (Reader ElabContext :+: Throw ErrReason :+: Writer Usage) sig m => (Quantity, Pattern (Name :==> Type)) -> m a -> m a (q, p) |- b = do d <- depth - (u, a) <- censor (`Usage.withoutVars` Vars.singleton d) $ listen $ locally context_ (|> Type q id p) b + (u, a) <- censor (`Usage.withoutVars` Vars.singleton d) $ listen $ locally context_ (|> Type q p) b for_ p $ \ (n :==> _T) -> do let exp = q act = Usage.lookup (LName d n) u diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 5ee2ffeef..f920fe5fb 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -49,7 +49,7 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) , env Env.|> PVal (PVar (n :=: free (LName d n))) , prints Env.|> PVal (PVar (n :=: intro n d)) , ctx :> getPrint (print opts prints (ann (intro n d ::: print opts prints _K))) ) - combine (d, env, prints, ctx) (C.Type m _ p) = + combine (d, env, prints, ctx) (C.Type m p) = ( succ d , env Env.|> ((\ (n :==> _T) -> n :=: free (LName d n)) <$> p) , prints Env.|> ((\ (n :==> _) -> n :=: intro n d) <$> p) From cacd03cec148e8cbff7a20ccf6e704afd01563e9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 23 Apr 2022 23:59:42 -0400 Subject: [PATCH 1131/1324] :fire: Quantity from Context. --- src/Facet/Context.hs | 9 +++++---- src/Facet/Elab.hs | 2 +- src/Facet/Notice/Elab.hs | 10 +++------- 3 files changed, 9 insertions(+), 12 deletions(-) diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index d6e0f9ea0..f5a47125c 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -19,6 +19,7 @@ import Facet.Functor.Synth import Facet.Kind (Kind) import Facet.Name import Facet.Pattern +import Facet.Semiring import qualified Facet.Snoc as S import Facet.Syntax import Facet.Type.Norm @@ -30,7 +31,7 @@ import Prelude hiding (lookup) newtype Context = Context { elems :: S.Snoc Binding } data Binding - = Type Quantity (Pattern (Name :==> Type)) + = Type (Pattern (Name :==> Type)) | Kind (Name :==> Kind) @@ -58,8 +59,8 @@ lookupIndex n = go (Index 0) . elems where go _ S.Nil = E.empty go i (cs S.:> b) = case b of - Type q p - | Just (n' :==> t) <- find ((== n) . proof) p -> pure (LName i n', Right (q, t)) + Type p + | Just (n' :==> t) <- find ((== n) . proof) p -> pure (LName i n', Right (Many, t)) Kind (n' :==> k) | n == n' -> pure (LName i n', Left k) _ -> go (succ i) cs @@ -69,7 +70,7 @@ toEnv :: Context -> Env.Env Type toEnv c = Env.Env (S.fromList (zipWith toType (toList (elems c)) [0..pred (level c)])) where toType b d = case b of - Type _ p -> (\ b -> proof b :=: bind d (proof b)) <$> p + Type p -> (\ b -> proof b :=: bind d (proof b)) <$> p Kind (n :==> _) -> review _PVar (n :=: bind d n) bind d b = free (LName d b) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 3dfb2bfe9..8fc21b54c 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -159,7 +159,7 @@ lookupInSig (m :|> n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':|>_) _ (|-) :: Has (Reader ElabContext :+: Throw ErrReason :+: Writer Usage) sig m => (Quantity, Pattern (Name :==> Type)) -> m a -> m a (q, p) |- b = do d <- depth - (u, a) <- censor (`Usage.withoutVars` Vars.singleton d) $ listen $ locally context_ (|> Type q p) b + (u, a) <- censor (`Usage.withoutVars` Vars.singleton d) $ listen $ locally context_ (|> Type p) b for_ p $ \ (n :==> _T) -> do let exp = q act = Usage.lookup (LName d n) u diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index f920fe5fb..1316d5ccc 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -19,7 +19,7 @@ import Facet.Notice as Notice hiding (level) import Facet.Pattern import Facet.Pretty import Facet.Print as Print -import Facet.Semiring (Few(..), one, zero) +import Facet.Semiring (Few(..)) import Facet.Snoc import Facet.Style import Facet.Subst (metas) @@ -49,15 +49,11 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) , env Env.|> PVal (PVar (n :=: free (LName d n))) , prints Env.|> PVal (PVar (n :=: intro n d)) , ctx :> getPrint (print opts prints (ann (intro n d ::: print opts prints _K))) ) - combine (d, env, prints, ctx) (C.Type m p) = + combine (d, env, prints, ctx) (C.Type p) = ( succ d , env Env.|> ((\ (n :==> _T) -> n :=: free (LName d n)) <$> p) , prints Env.|> ((\ (n :==> _) -> n :=: intro n d) <$> p) - , ctx :> getPrint (print opts prints ((\ (n :==> _T) -> ann (intro n d ::: mult m (print opts prints (apply subst env _T)))) <$> p)) ) - mult m - | m == zero = (pretty "0" <+>) - | m == one = (pretty "1" <+>) - | otherwise = id + , ctx :> getPrint (print opts prints ((\ (n :==> _T) -> ann (intro n d ::: print opts prints (apply subst env _T))) <$> p)) ) printErrReason :: Options Print -> Env.Env Print -> ErrReason -> Doc Style From 612949b872b971588aca74c7f9f6a4ed02a3ac3a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 00:08:30 -0400 Subject: [PATCH 1132/1324] :fire: quantities from lookups. --- src/Facet/Context.hs | 5 ++--- src/Facet/Elab.hs | 2 +- src/Facet/Elab/Sequent.hs | 5 ++--- src/Facet/Elab/Term.hs | 6 +++--- 4 files changed, 8 insertions(+), 10 deletions(-) diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index f5a47125c..af0f3f8a4 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -19,7 +19,6 @@ import Facet.Functor.Synth import Facet.Kind (Kind) import Facet.Name import Facet.Pattern -import Facet.Semiring import qualified Facet.Snoc as S import Facet.Syntax import Facet.Type.Norm @@ -54,13 +53,13 @@ Context es' ! Index i' = withFrozenCallStack $ go es' i' | otherwise = go es (i - 1) go _ _ = error $ "Facet.Context.!: index (" <> show i' <> ") out of bounds (" <> show (length es') <> ")" -lookupIndex :: E.Has E.Empty sig m => Name -> Context -> m (LName Index, Either Kind (Quantity, Type)) +lookupIndex :: E.Has E.Empty sig m => Name -> Context -> m (LName Index, Either Kind Type) lookupIndex n = go (Index 0) . elems where go _ S.Nil = E.empty go i (cs S.:> b) = case b of Type p - | Just (n' :==> t) <- find ((== n) . proof) p -> pure (LName i n', Right (Many, t)) + | Just (n' :==> t) <- find ((== n) . proof) p -> pure (LName i n', Right t) Kind (n' :==> k) | n == n' -> pure (LName i n', Left k) _ -> go (succ i) cs diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 8fc21b54c..f5faa4ff7 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -139,7 +139,7 @@ resolveC = resolveWith lookupConstructor resolveDef :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m Def resolveDef = resolveWith lookupDef -lookupInContext :: Has (Choose :+: Empty) sig m => QName -> Context -> m (LName Index, Either Kind (Quantity, Type)) +lookupInContext :: Has (Choose :+: Empty) sig m => QName -> Context -> m (LName Index, Either Kind Type) lookupInContext (m:|>n) | m == Nil = lookupIndex n | otherwise = const empty diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 6bca8a44a..b251d893f 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -68,10 +68,9 @@ globalS (q ::: _T) = do -- FIXME: do we need to instantiate here to deal with rank-n applications? -- FIXME: effect ops not in the sig are reported as not in scope -- FIXME: effect ops in the sig are available whether or not they’re in scope -varS :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m, SQ.Term t c d, Applicative i) => QName -> m (i t :==> Type) +varS :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, SQ.Term t c d, Applicative i) => QName -> m (i t :==> Type) varS n = views context_ (lookupInContext n) >>= \case - [(n', Right (q, _T))] -> do - use n' q + [(n', Right _T)] -> do d <- views context_ level SQ.varA (Free (toLeveled d (ident n'))) ==> pure _T _ -> resolveDef n >>= \case diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 416bb9828..0fc1e4259 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -113,10 +113,10 @@ global (q ::: _T) = (\ (v ::: _T) -> v :==> _T) <$> instantiate const (Var (Glob -- FIXME: do we need to instantiate here to deal with rank-n applications? -- FIXME: effect ops not in the sig are reported as not in scope -- FIXME: effect ops in the sig are available whether or not they’re in scope -var :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => QName -> m (Term :==> Type) +var :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m) => QName -> m (Term :==> Type) var n = views context_ (lookupInContext n) >>= \case - [(n', Right (q, _T))] -> use n' q $> (Var (Free n') :==> _T) - _ -> resolveDef n >>= \case + [(n', Right _T)] -> pure (Var (Free n') :==> _T) + _ -> resolveDef n >>= \case DTerm _ _T -> global (n ::: _T) _ -> freeVariable n From 7847fb22749c2aa4bc90be51f909b7825d93b938 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 00:13:02 -0400 Subject: [PATCH 1133/1324] :fire: usage from unification. --- src/Facet/Elab/Sequent.hs | 2 +- src/Facet/Elab/Term.hs | 6 +++--- src/Facet/Unify.hs | 12 +++++------- 3 files changed, 9 insertions(+), 11 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index b251d893f..a509b4bc9 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -107,7 +107,7 @@ appS f a = do -- General combinators -switch :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => m (a :==> Type) -> Type <==: m a +switch :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => m (a :==> Type) -> Type <==: m a switch m = Check $ \ _Exp -> do a :==> _Act <- m a <$ unify (Exp _Exp) (Act _Act) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 0fc1e4259..9a54fd4c0 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -91,7 +91,7 @@ import GHC.Stack -- General combinators -switch :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => m (a :==> Type) -> Type <==: m a +switch :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => m (a :==> Type) -> Type <==: m a switch m = Check $ \ _Exp -> m >>= \case a :==> T.Comp req _Act -> require req >> unify (Exp _Exp) (Act _Act) $> a a :==> _Act -> unify (Exp _Exp) (Act _Act) $> a @@ -170,7 +170,7 @@ varP n = Bind $ \ _A k -> k (PVar (n :==> wrap _A)) T.Comp sig _A -> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] |> T "Unit")) Nil) (T.Comp sig _A) _T -> _T -conP :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => QName -> [Bind m (ValPattern (Name :==> Type))] -> Bind m (ValPattern (Name :==> Type)) +conP :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> [Bind m (ValPattern (Name :==> Type))] -> Bind m (ValPattern (Name :==> Type)) conP n fs = Bind $ \ _A k -> do n' :=: _T <- resolveC n _T' <- maybe (pure _T) (foldl' (\ _T _A -> do t <- _T ; (_, _, b) <- assertQuantifier t ; pure (b _A)) (pure _T) . snd) (unNeutral _A) @@ -377,7 +377,7 @@ withCallStack cs with = let ?callStack = cs in with provide :: Has (Reader ElabContext) sig m => Signature Type -> m a -> m a provide sig m = locally sig_ (sig :) m -require :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Signature Type -> m () +require :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => Signature Type -> m () require req = do prv <- Lens.view sig_ for_ (interfaces req) $ \ i -> findMaybeA (findMaybeA (runUnifyMaybe . runState (const pure) (mempty :: Subst Type) . unifyInterface i) . interfaces) prv >>= \case diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index aa90812d0..0cdb6d1d7 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -14,7 +14,6 @@ import Control.Carrier.Empty.Church import Control.Carrier.Error.Church import Control.Carrier.State.Church import Control.Effect.Reader -import Control.Effect.Writer import Control.Monad (unless) import Facet.Carrier.Throw.Inject import Facet.Elab @@ -29,13 +28,12 @@ import Facet.Subst import Facet.Syntax import qualified Facet.Type.Expr as TX import Facet.Type.Norm as TN -import Facet.Usage import GHC.Stack -- Unification -- FIXME: we don’t get good source references during unification -unify :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Exp Type -> Act Type -> m Type +unify :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => Exp Type -> Act Type -> m Type unify t1 t2 = runUnify t1 t2 (runState (const pure) (mempty :: Subst Type) (unifyType (getExp t1) (getAct t2))) runUnify :: Has (Throw ErrReason) sig m => Exp Type -> Act Type -> ThrowC ErrReason (WithCallStack UnifyErrReason) m a -> m a @@ -50,7 +48,7 @@ mismatch = withFrozenCallStack $ throwError $ WithCallStack GHC.Stack.callStac occurs :: (HasCallStack, Has (Throw (WithCallStack UnifyErrReason)) sig m) => Meta -> Type -> m a occurs v t = withFrozenCallStack $ throwError $ WithCallStack GHC.Stack.callStack (Occurs v t) -unifyType :: (HasCallStack, Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Throw (WithCallStack UnifyErrReason)) sig m, Has (Writer Usage) sig m) => Type -> Type -> m Type +unifyType :: (HasCallStack, Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Throw (WithCallStack UnifyErrReason)) sig m) => Type -> Type -> m Type unifyType = curry $ \case (TN.Comp s1 t1, TN.Comp s2 t2) -> TN.Comp . fromInterfaces <$> unifySpine unifyInterface (interfaces s1) (interfaces s2) <*> unifyType t1 t2 (TN.Comp s1 t1, t2) -> TN.Comp s1 <$> unifyType t1 t2 @@ -75,13 +73,13 @@ unifyKind k1 k2 = if k1 == k2 then pure k2 else mismatch unifyVar :: (Eq a, Eq b, HasCallStack, Has (Throw (WithCallStack UnifyErrReason)) sig m) => Var (Either a b) -> Var (Either a b) -> m (Var (Either a b)) unifyVar v1 v2 = if v1 == v2 then pure v2 else mismatch -unifyInterface :: (HasCallStack, Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Throw (WithCallStack UnifyErrReason)) sig m, Has (Writer Usage) sig m) => Interface Type -> Interface Type -> m (Interface Type) +unifyInterface :: (HasCallStack, Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Throw (WithCallStack UnifyErrReason)) sig m) => Interface Type -> Interface Type -> m (Interface Type) unifyInterface (Interface h1 sp1) (Interface h2 sp2) = Interface h2 <$ unless (h1 == h2) mismatch <*> unifySpine unifyType sp1 sp2 unifySpine :: (Traversable t, Zip t, Has (Throw (WithCallStack UnifyErrReason)) sig m) => (a -> b -> m c) -> t a -> t b -> m (t c) unifySpine f sp1 sp2 = unless (length sp1 == length sp2) mismatch >> zipWithM f sp1 sp2 -flexFlex :: (HasCallStack, Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Throw (WithCallStack UnifyErrReason)) sig m, Has (Writer Usage) sig m) => Meta -> Meta -> m Type +flexFlex :: (HasCallStack, Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Throw (WithCallStack UnifyErrReason)) sig m) => Meta -> Meta -> m Type flexFlex v1 v2 | v1 == v2 = pure (metavar v2) | otherwise = gets (\ s -> (lookupMeta v1 s, lookupMeta v2 s)) >>= \case @@ -90,7 +88,7 @@ flexFlex v1 v2 (Nothing, Just t2) -> unifyType (metavar v1) t2 (Nothing, Nothing) -> solve v1 (metavar v2) -solve :: (HasCallStack, Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Throw (WithCallStack UnifyErrReason)) sig m, Has (Writer Usage) sig m) => Meta -> Type -> m Type +solve :: (HasCallStack, Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Throw (WithCallStack UnifyErrReason)) sig m) => Meta -> Type -> m Type solve v t = do d <- depth if occursIn v d t then From 629808567190418b1ade5b5ca2649389c47381df Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 00:17:43 -0400 Subject: [PATCH 1134/1324] :fire: a bunch of usages. --- src/Facet/Elab/Sequent.hs | 16 +++++++--------- src/Facet/Elab/Term.hs | 14 +++++++------- 2 files changed, 14 insertions(+), 16 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index a509b4bc9..bfa46c938 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -24,7 +24,6 @@ module Facet.Elab.Sequent import Control.Effect.Reader import Control.Effect.State import Control.Effect.Throw -import Control.Effect.Writer import Data.Foldable (fold) import Data.Text (Text) import Data.Traversable (for) @@ -43,7 +42,6 @@ import Facet.Name import Facet.Pattern import qualified Facet.Pattern.Column as Col import qualified Facet.Scope as Scope -import Facet.Semiring import Facet.Sequent.Class as SQ import Facet.Snoc.NonEmpty import Facet.Subst @@ -97,11 +95,11 @@ stringS s = SQ.stringRA s ==> pure T.String -- Eliminators -appS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m, SQ.Term t c d, SQ.Coterm t c d, SQ.Command t c d, Applicative i) => (HasCallStack => m (i t :==> Type)) -> (HasCallStack => Type <==: m (i t)) -> m (i t :==> Type) +appS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, SQ.Term t c d, SQ.Coterm t c d, SQ.Command t c d, Applicative i) => (HasCallStack => m (i t :==> Type)) -> (HasCallStack => Type <==: m (i t)) -> m (i t :==> Type) appS f a = do f' :==> _F <- f - (_, q, _A, _B) <- assertFunction _F - a' <- censor @Usage (q ><<) $ check (a ::: _A) + (_, _, _A, _B) <- assertFunction _F + a' <- check (a ::: _A) (:==> _B) <$> SQ.µRA (\ wk k -> pure (wk f') SQ..||. SQ.lamLA (pure (wk a')) (pure k)) @@ -121,7 +119,7 @@ as (m ::: _T) = do -- Elaboration -synthExprS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, Has (Writer Usage) sig m, SQ.Term t c d, SQ.Coterm t c d, SQ.Command t c d, Applicative i) => S.Ann S.Expr -> m (i t :==> Type) +synthExprS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, SQ.Term t c d, SQ.Coterm t c d, SQ.Command t c d, Applicative i) => S.Ann S.Expr -> m (i t :==> Type) synthExprS = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \case S.Var n -> varS n S.App f a -> synthApp f a @@ -132,14 +130,14 @@ synthExprS = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \ca where nope = couldNotSynthesize -synthApp :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, Has (Writer Usage) sig m, SQ.Term t c d, SQ.Coterm t c d, SQ.Command t c d, Applicative i) => S.Ann S.Expr -> S.Ann S.Expr -> m (i t :==> Type) +synthApp :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, SQ.Term t c d, SQ.Coterm t c d, SQ.Command t c d, Applicative i) => S.Ann S.Expr -> S.Ann S.Expr -> m (i t :==> Type) synthApp f a = appS (synthExprS f) (checkExprS a) -synthAs :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, Has (Writer Usage) sig m, SQ.Term t c d, SQ.Coterm t c d, SQ.Command t c d, Applicative i) => S.Ann S.Expr -> S.Ann S.Type -> m (i t :==> Type) +synthAs :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, SQ.Term t c d, SQ.Coterm t c d, SQ.Command t c d, Applicative i) => S.Ann S.Expr -> S.Ann S.Type -> m (i t :==> Type) synthAs t _T = as (checkExprS t ::: do { _T :==> _K <- Type.synthType _T ; (:==> _K) <$> evalTExpr _T }) -checkExprS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, Has (Writer Usage) sig m, SQ.Term t c d, SQ.Coterm t c d, SQ.Command t c d, Applicative i) => S.Ann S.Expr -> Type <==: m (i t) +checkExprS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, SQ.Term t c d, SQ.Coterm t c d, SQ.Command t c d, Applicative i) => S.Ann S.Expr -> Type <==: m (i t) checkExprS expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC expr $ \case S.Hole n -> hole n S.Lam cs -> checkLamS (Check (\ _T -> map (\ (S.Clause (S.Ann _ _ p) b) -> Clause [pattern p] (check (checkExprS b ::: _T))) cs)) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 9a54fd4c0..3278c25b4 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -40,7 +40,6 @@ module Facet.Elab.Term import Control.Algebra import Control.Carrier.Reader import Control.Carrier.State.Church -import Control.Carrier.Writer.Church import Control.Effect.Throw import Data.Bifunctor (first) import Data.Either (partitionEithers) @@ -57,6 +56,7 @@ import Facet.Elab.Type hiding (switch) import qualified Facet.Elab.Type as Type import Facet.Functor.Check +import Control.Effect.Writer import Facet.Functor.Synth import Facet.Graph import Facet.Interface @@ -66,7 +66,7 @@ import Facet.Module as Module import Facet.Name import Facet.Pattern import Facet.Scope -import Facet.Semiring (Few(..), (><<)) +import Facet.Semiring (Few(..)) import Facet.Snoc import Facet.Snoc.NonEmpty as NE import Facet.Source (Source) @@ -139,11 +139,11 @@ lam cs = Check $ \ _T -> do lam1 :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Bind m (Pattern (Name :==> Type)) -> Type <==: m Term -> Type <==: m Term lam1 p b = lam [(p, b)] -app :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => (a -> b -> c) -> (HasCallStack => m (a :==> Type)) -> (HasCallStack => Type <==: m b) -> m (c :==> Type) +app :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => (a -> b -> c) -> (HasCallStack => m (a :==> Type)) -> (HasCallStack => Type <==: m b) -> m (c :==> Type) app mk operator operand = do f' :==> _F <- operator - (_, q, _A, _B) <- assertFunction _F - a' <- censor @Usage (q ><<) $ check (operand ::: _A) + (_, _, _A, _B) <- assertFunction _F + a' <- check (operand ::: _A) pure $ mk f' a' :==> _B @@ -229,10 +229,10 @@ checkLam cs = lam (snd vs) -- FIXME: check for unique variable names -bindPattern :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => S.Ann S.ValPattern -> Bind m (Pattern (Name :==> Type)) +bindPattern :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.ValPattern -> Bind m (Pattern (Name :==> Type)) bindPattern p = PVal <$> bindValPattern p -bindValPattern :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => S.Ann S.ValPattern -> Bind m (ValPattern (Name :==> Type)) +bindValPattern :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.ValPattern -> Bind m (ValPattern (Name :==> Type)) bindValPattern = withSpanB $ \case S.PWildcard -> wildcardP S.PVar n -> varP n From 70cff13aa56edc5ed238dfc4bbbd4f929500b2cb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 00:18:51 -0400 Subject: [PATCH 1135/1324] :fire: quantities on bound variables. --- src/Facet/Elab.hs | 6 +++--- src/Facet/Elab/Term.hs | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index f5faa4ff7..1383cacaf 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -156,12 +156,12 @@ lookupInSig (m :|> n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':|>_) _ interfaceScope = \case { DSubmodule (SInterface defs) _K -> pure defs ; _ -> empty } -(|-) :: Has (Reader ElabContext :+: Throw ErrReason :+: Writer Usage) sig m => (Quantity, Pattern (Name :==> Type)) -> m a -> m a -(q, p) |- b = do +(|-) :: Has (Reader ElabContext :+: Throw ErrReason :+: Writer Usage) sig m => Pattern (Name :==> Type) -> m a -> m a +p |- b = do d <- depth (u, a) <- censor (`Usage.withoutVars` Vars.singleton d) $ listen $ locally context_ (|> Type p) b for_ p $ \ (n :==> _T) -> do - let exp = q + let exp = Many act = Usage.lookup (LName d n) u unless (act `sat` exp) $ resourceMismatch n exp act diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 3278c25b4..06abf6549 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -397,7 +397,7 @@ check (m ::: _T) = case _T of bind :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Bind m (Pattern (Name :==> Type)) ::: (Quantity, Type) -> m b -> m (Pattern Name, b) -bind (p ::: (q, _T)) m = runBind p _T (\ p' -> (proof <$> p',) <$> ((q, p') |- m)) +bind (p ::: (_, _T)) m = runBind p _T (\ p' -> (proof <$> p',) <$> (p' |- m)) newtype Bind m a = Bind { runBind :: forall x . Type -> (a -> m x) -> m x } deriving (Functor) From 3c7f5a7091224b8a7aae23c81f6a64391de6b344 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 00:19:48 -0400 Subject: [PATCH 1136/1324] :fire: quantities on bind. --- src/Facet/Elab/Term.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 06abf6549..4bf2d1be5 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -133,8 +133,8 @@ tlam b = Check $ \ _T -> do lam :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => [(Bind m (Pattern (Name :==> Type)), Type <==: m Term)] -> Type <==: m Term lam cs = Check $ \ _T -> do - (_, q, _A, _B) <- assertTacitFunction _T - Lam <$> traverse (\ (p, b) -> bind (p ::: (q, _A)) (check (b ::: _B))) cs + (_, _, _A, _B) <- assertTacitFunction _T + Lam <$> traverse (\ (p, b) -> bind (p ::: _A) (check (b ::: _B))) cs lam1 :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Bind m (Pattern (Name :==> Type)) -> Type <==: m Term -> Type <==: m Term lam1 p b = lam [(p, b)] @@ -154,7 +154,7 @@ string s = pure $ E.String s :==> T.String let' :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Bind m (Pattern (Name :==> Type)) -> m (Term :==> Type) -> Type <==: m Term -> Type <==: m Term let' p a b = Check $ \ _B -> do a' :==> _A <- a - (p', b') <- bind (p ::: (Many, _A)) (check (b ::: _B)) + (p', b') <- bind (p ::: _A) (check (b ::: _B)) pure $ Let p' a' b' @@ -396,8 +396,8 @@ check (m ::: _T) = case _T of _T -> m <==: _T -bind :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Bind m (Pattern (Name :==> Type)) ::: (Quantity, Type) -> m b -> m (Pattern Name, b) -bind (p ::: (_, _T)) m = runBind p _T (\ p' -> (proof <$> p',) <$> (p' |- m)) +bind :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Bind m (Pattern (Name :==> Type)) ::: Type -> m b -> m (Pattern Name, b) +bind (p ::: _T) m = runBind p _T (\ p' -> (proof <$> p',) <$> (p' |- m)) newtype Bind m a = Bind { runBind :: forall x . Type -> (a -> m x) -> m x } deriving (Functor) From 6568f7a8cd094ad4a27ac60d7ae2d01249bd9c74 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 00:23:18 -0400 Subject: [PATCH 1137/1324] :fire: usages. --- src/Facet/Elab.hs | 23 ++--------------------- src/Facet/Elab/Term.hs | 23 +++++++++++------------ 2 files changed, 13 insertions(+), 33 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 1383cacaf..5b8e7c863 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -64,8 +64,6 @@ import Control.Carrier.Reader import Control.Carrier.State.Church import Control.Carrier.Writer.Church import Control.Effect.Choose -import Control.Monad (unless) -import Data.Foldable (for_) import Facet.Context hiding (empty) import qualified Facet.Context as Context (empty) import Facet.Effect.Write @@ -80,7 +78,6 @@ import Facet.Module import Facet.Name hiding (L, R) import Facet.Pattern import Facet.Quote -import Facet.Semiring import Facet.Snoc import Facet.Snoc.NonEmpty (NonEmpty(..)) import Facet.Source (Source, slice) @@ -92,7 +89,6 @@ import Facet.Term.Expr as E import qualified Facet.Type.Expr as TX import Facet.Type.Norm as TN import Facet.Usage as Usage -import Facet.Vars as Vars import Fresnel.Fold ((^?)) import Fresnel.Ixed (ix) import Fresnel.Lens (Lens', lens) @@ -156,16 +152,8 @@ lookupInSig (m :|> n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':|>_) _ interfaceScope = \case { DSubmodule (SInterface defs) _K -> pure defs ; _ -> empty } -(|-) :: Has (Reader ElabContext :+: Throw ErrReason :+: Writer Usage) sig m => Pattern (Name :==> Type) -> m a -> m a -p |- b = do - d <- depth - (u, a) <- censor (`Usage.withoutVars` Vars.singleton d) $ listen $ locally context_ (|> Type p) b - for_ p $ \ (n :==> _T) -> do - let exp = Many - act = Usage.lookup (LName d n) u - unless (act `sat` exp) - $ resourceMismatch n exp act - pure a +(|-) :: Has (Reader ElabContext) sig m => Pattern (Name :==> Type) -> m a -> m a +p |- b = locally context_ (|> Type p) b infix 1 |- @@ -174,13 +162,6 @@ k ||- b = locally context_ (|> Kind k) b infix 1 ||- --- | Test whether the first quantity suffices to satisfy a requirement of the second. -sat :: Quantity -> Quantity -> Bool -sat a b - | b == zero = a == b - | b == one = a == b - | otherwise = True - evalTExpr :: Has (Reader ElabContext :+: State (Subst Type)) sig m => TX.Type -> m Type evalTExpr texpr = TN.eval <$> get <*> views context_ toEnv <*> pure texpr diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 4bf2d1be5..8f04013d2 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -56,7 +56,6 @@ import Facet.Elab.Type hiding (switch) import qualified Facet.Elab.Type as Type import Facet.Functor.Check -import Control.Effect.Writer import Facet.Functor.Synth import Facet.Graph import Facet.Interface @@ -131,12 +130,12 @@ tlam b = Check $ \ _T -> do d <- depth n :==> _A ||- check (b ::: _B (T.free (LName d n))) -lam :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => [(Bind m (Pattern (Name :==> Type)), Type <==: m Term)] -> Type <==: m Term +lam :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => [(Bind m (Pattern (Name :==> Type)), Type <==: m Term)] -> Type <==: m Term lam cs = Check $ \ _T -> do (_, _, _A, _B) <- assertTacitFunction _T Lam <$> traverse (\ (p, b) -> bind (p ::: _A) (check (b ::: _B))) cs -lam1 :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Bind m (Pattern (Name :==> Type)) -> Type <==: m Term -> Type <==: m Term +lam1 :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => Bind m (Pattern (Name :==> Type)) -> Type <==: m Term -> Type <==: m Term lam1 p b = lam [(p, b)] app :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => (a -> b -> c) -> (HasCallStack => m (a :==> Type)) -> (HasCallStack => Type <==: m b) -> m (c :==> Type) @@ -151,7 +150,7 @@ string :: Applicative m => Text -> m (Term :==> Type) string s = pure $ E.String s :==> T.String -let' :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Bind m (Pattern (Name :==> Type)) -> m (Term :==> Type) -> Type <==: m Term -> Type <==: m Term +let' :: Has (Reader ElabContext) sig m => Bind m (Pattern (Name :==> Type)) -> m (Term :==> Type) -> Type <==: m Term -> Type <==: m Term let' p a b = Check $ \ _B -> do a' :==> _A <- a (p', b') <- bind (p ::: _A) (check (b ::: _B)) @@ -194,7 +193,7 @@ allP n = Bind $ \ _A k -> do -- Expression elaboration -synthExpr :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => S.Ann S.Expr -> m (Term :==> Type) +synthExpr :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.Expr -> m (Term :==> Type) synthExpr = withCallStack (popCallStack GHC.Stack.callStack) $ withSpan $ \case S.Var n -> var n S.App f a -> synthApp f a @@ -204,13 +203,13 @@ synthExpr = withCallStack (popCallStack GHC.Stack.callStack) $ withSpan $ \case S.Lam{} -> nope where nope = couldNotSynthesize - synthApp :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => S.Ann S.Expr -> S.Ann S.Expr -> m (Term :==> Type) + synthApp :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Expr -> m (Term :==> Type) synthApp f a = app App (synthExpr f) (checkExpr a) - synthAs :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => S.Ann S.Expr -> S.Ann S.Type -> m (Term :==> Type) + synthAs :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Type -> m (Term :==> Type) synthAs t _T = as (checkExpr t ::: do { _T :==> _K <- synthType _T ; (:==> _K) <$> evalTExpr _T }) -checkExpr :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => S.Ann S.Expr -> Type <==: m Term +checkExpr :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => S.Ann S.Expr -> Type <==: m Term checkExpr expr = withCallStack (popCallStack GHC.Stack.callStack) $ withSpanC expr $ \case S.Hole n -> hole n S.Lam cs -> checkLam cs @@ -219,10 +218,10 @@ checkExpr expr = withCallStack (popCallStack GHC.Stack.callStack) $ withSpanC ex S.As{} -> switch (synthExpr expr) S.String{} -> switch (synthExpr expr) -checkLam :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => [S.Clause] -> Type <==: m Term +checkLam :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => [S.Clause] -> Type <==: m Term checkLam cs = lam (snd vs) where - vs :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => ([QName :=: (Type <==: m Term)], [(Bind m (Pattern (Name :==> Type)), Type <==: m Term)]) + vs :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => ([QName :=: (Type <==: m Term)], [(Bind m (Pattern (Name :==> Type)), Type <==: m Term)]) vs = partitionEithers (map (\ (S.Clause (S.Ann _ _ p) b) -> case p of S.PVal p -> Right (bindPattern p, checkExpr b) S.PEff (S.Ann s _ (S.POp n fs k)) -> Left $ n :=: Check (\ _T -> pushSpan s (foldr (lam1 . bindPattern) (checkExpr b) (fromList fs:>k) <==: _T))) cs) @@ -247,7 +246,7 @@ abstractType body = \case KArrow (Just n) a b -> TX.ForAll n a <$> (n :==> a ||- abstractType body b) _ -> body -abstractTerm :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason :+: Write Warn) sig m, Has (Writer Usage) sig m) => (Snoc TX.Type -> Snoc Term -> Term) -> Type <==: m Term +abstractTerm :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason :+: Write Warn) sig m) => (Snoc TX.Type -> Snoc Term -> Term) -> Type <==: m Term abstractTerm body = go Nil Nil where go ts fs = Check $ \case @@ -396,7 +395,7 @@ check (m ::: _T) = case _T of _T -> m <==: _T -bind :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, Has (Writer Usage) sig m) => Bind m (Pattern (Name :==> Type)) ::: Type -> m b -> m (Pattern Name, b) +bind :: Has (Reader ElabContext) sig m => Bind m (Pattern (Name :==> Type)) ::: Type -> m b -> m (Pattern Name, b) bind (p ::: _T) m = runBind p _T (\ p' -> (proof <$> p',) <$> (p' |- m)) newtype Bind m a = Bind { runBind :: forall x . Type -> (a -> m x) -> m x } From aff9757dcd8cb32a91d64cfea59d7b568ed4b741 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 00:24:09 -0400 Subject: [PATCH 1138/1324] :fire: use. --- src/Facet/Elab.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 5b8e7c863..80c79f0a3 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -48,7 +48,6 @@ module Facet.Elab -- * Machinery , evalTExpr , depth -, use , elabWith , elabKind , elabType @@ -169,11 +168,6 @@ evalTExpr texpr = TN.eval <$> get <*> views context_ toEnv <*> pure texpr depth :: Has (Reader ElabContext) sig m => m Level depth = views context_ level -use :: Has (Reader ElabContext :+: Writer Usage) sig m => LName Index -> Quantity -> m () -use n q = do - d <- depth - tell (Usage.singleton (toLeveled d n) q) - -- Errors From 85f5f486caaf20850890183c581d43b0649f5d54 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 00:25:27 -0400 Subject: [PATCH 1139/1324] :fire: usage carriers. --- src/Facet/Elab.hs | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 80c79f0a3..bf807a31b 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -61,7 +61,6 @@ import Control.Carrier.Empty.Church import Control.Carrier.Error.Church import Control.Carrier.Reader import Control.Carrier.State.Church -import Control.Carrier.Writer.Church import Control.Effect.Choose import Facet.Context hiding (empty) import qualified Facet.Context as Context (empty) @@ -87,7 +86,6 @@ import qualified Facet.Syntax as S import Facet.Term.Expr as E import qualified Facet.Type.Expr as TX import Facet.Type.Norm as TN -import Facet.Usage as Usage import Fresnel.Fold ((^?)) import Fresnel.Ixed (ix) import Fresnel.Lens (Lens', lens) @@ -339,22 +337,22 @@ spans_ = lens spans (\ e spans -> e{ spans }) -- Machinery -elabWith :: (Subst Type -> a -> m b) -> ReaderC ElabContext (WriterC Usage (StateC (Subst Type) m)) a -> m b -elabWith k m = runState k mempty . runWriter (const pure) $ do +elabWith :: (Subst Type -> a -> m b) -> ReaderC ElabContext (StateC (Subst Type) m) a -> m b +elabWith k m = runState k mempty $ do let ctx = ElabContext{ context = Context.empty, sig = mempty, spans = Nil } runReader ctx m -elabKind :: Applicative m => ReaderC ElabContext (WriterC Usage (StateC (Subst Type) m)) Kind -> m Kind +elabKind :: Applicative m => ReaderC ElabContext (StateC (Subst Type) m) Kind -> m Kind elabKind = elabWith (const pure) -elabType :: (HasCallStack, Applicative m) => ReaderC ElabContext (WriterC Usage (StateC (Subst Type) m)) TX.Type -> m Type +elabType :: (HasCallStack, Applicative m) => ReaderC ElabContext (StateC (Subst Type) m) TX.Type -> m Type elabType = elabWith (\ subst t -> pure (TN.eval subst Env.empty t)) -elabTerm :: Applicative m => ReaderC ElabContext (WriterC Usage (StateC (Subst Type) m)) Term -> m Term +elabTerm :: Applicative m => ReaderC ElabContext (StateC (Subst Type) m) Term -> m Term elabTerm = elabWith (const pure) -elabSynthTerm :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => ReaderC ElabContext (WriterC Usage (StateC (Subst Type) m)) (Term :==> Type) -> m (Term :==> Type) +elabSynthTerm :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => ReaderC ElabContext (StateC (Subst Type) m) (Term :==> Type) -> m (Term :==> Type) elabSynthTerm = elabWith (\ subst (e :==> _T) -> pure (e :==> TN.eval subst Env.empty (runQuoter 0 (quote _T)))) -elabSynthType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => ReaderC ElabContext (WriterC Usage (StateC (Subst Type) m)) (TX.Type :==> Kind) -> m (Type :==> Kind) +elabSynthType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => ReaderC ElabContext (StateC (Subst Type) m) (TX.Type :==> Kind) -> m (Type :==> Kind) elabSynthType = elabWith (\ subst (_T :==> _K) -> pure (TN.eval subst Env.empty _T :==> _K)) From 652324259cbd312d9fc91ca72b9cdc381e371ff0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 00:32:58 -0400 Subject: [PATCH 1140/1324] :fire: quantities. --- src/Facet/Elab.hs | 2 +- src/Facet/Elab/Sequent.hs | 11 +++++------ src/Facet/Elab/Term.hs | 24 +++++++++++------------- src/Facet/Elab/Type.hs | 17 ++++++----------- src/Facet/Parser.hs | 7 ++----- src/Facet/Print.hs | 11 +++-------- src/Facet/Surface/Type/Class.hs | 3 +-- src/Facet/Surface/Type/Expr.hs | 7 +------ src/Facet/Type/Class.hs | 3 +-- src/Facet/Type/Expr.hs | 5 ++--- src/Facet/Type/Norm.hs | 29 ++++++++++++++--------------- src/Facet/Unify.hs | 2 +- test/Facet/Core/Type/Test.hs | 3 +-- 13 files changed, 49 insertions(+), 75 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index bf807a31b..ed666a0c5 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -313,7 +313,7 @@ assertMatch mismatch pat exp _T = maybe (mismatch (Exp (Left exp)) (Act _T)) pur assertTypesMatch :: Has (Throw ErrReason) sig m => Prism' Type a -> String -> Type -> m a assertTypesMatch pat exp _T = maybe (mismatchTypes (Exp (Left exp)) (Act _T)) pure (_T ^? pat) -assertFunction :: Has (Throw ErrReason) sig m => Type -> m (Maybe Name, Quantity, Type, Type) +assertFunction :: Has (Throw ErrReason) sig m => Type -> m (Maybe Name, Type, Type) assertFunction = assertTypesMatch _Arrow "_ -> _" diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index bfa46c938..b63cebe5b 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -50,7 +50,6 @@ import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) import Facet.Type.Norm as T import Facet.Unify -import Facet.Usage import Fresnel.Getter (view) import Fresnel.Lens (Lens, Lens', lens) import GHC.Stack (HasCallStack, callStack, popCallStack, withFrozenCallStack) @@ -83,11 +82,11 @@ hole n = Check $ \ _T -> withFrozenCallStack $ throwError $ Hole n _T lamS :: (Has (Throw ErrReason) sig m, SQ.Term t c d, Applicative i) - => (forall j . Applicative j => (i ~> j) -> j t :@ Quantity :==> Type -> j c :@ Quantity :==> Type -> Type <==: m (j d)) + => (forall j . Applicative j => (i ~> j) -> j t :==> Type -> j c :==> Type -> Type <==: m (j d)) -> Type <==: m (i t) lamS f = runC $ SQ.lamRA $ \ wk a k -> C $ Check $ \ _T -> do - (_, q, _A, _B) <- assertTacitFunction _T - check (f wk (a :@ q :==> _A) (k :@ q :==> _B) ::: _B) + (_, _A, _B) <- assertTacitFunction _T + check (f wk (a :==> _A) (k :==> _B) ::: _B) stringS :: (Applicative m, SQ.Term t c d, Applicative i) => Text -> m (i t :==> Type) stringS s = SQ.stringRA s ==> pure T.String @@ -98,7 +97,7 @@ stringS s = SQ.stringRA s ==> pure T.String appS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, SQ.Term t c d, SQ.Coterm t c d, SQ.Command t c d, Applicative i) => (HasCallStack => m (i t :==> Type)) -> (HasCallStack => Type <==: m (i t)) -> m (i t :==> Type) appS f a = do f' :==> _F <- f - (_, _, _A, _B) <- assertFunction _F + (_, _A, _B) <- assertFunction _F a' <- check (a ::: _A) (:==> _B) <$> SQ.µRA (\ wk k -> pure (wk f') SQ..||. SQ.lamLA (pure (wk a')) (pure k)) @@ -186,7 +185,7 @@ partitionBy clauses ctors = fold <$> for clauses (\case -- Assertions -- | Expect a tacit (non-variable-binding) function type. -assertTacitFunction :: Has (Throw ErrReason) sig m => Type -> m (Maybe Name, Quantity, Type, Type) +assertTacitFunction :: Has (Throw ErrReason) sig m => Type -> m (Maybe Name, Type, Type) assertTacitFunction = assertTypesMatch _Arrow "_ -> _" diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 8f04013d2..2cac024a7 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -65,7 +65,6 @@ import Facet.Module as Module import Facet.Name import Facet.Pattern import Facet.Scope -import Facet.Semiring (Few(..)) import Facet.Snoc import Facet.Snoc.NonEmpty as NE import Facet.Source (Source) @@ -78,7 +77,6 @@ import Facet.Term.Expr as E import qualified Facet.Type.Expr as TX import Facet.Type.Norm as T hiding (global) import Facet.Unify -import Facet.Usage hiding (restrict) import Fresnel.At as At import Fresnel.Getter as Getter (view) import Fresnel.Ixed @@ -132,7 +130,7 @@ tlam b = Check $ \ _T -> do lam :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => [(Bind m (Pattern (Name :==> Type)), Type <==: m Term)] -> Type <==: m Term lam cs = Check $ \ _T -> do - (_, _, _A, _B) <- assertTacitFunction _T + (_, _A, _B) <- assertTacitFunction _T Lam <$> traverse (\ (p, b) -> bind (p ::: _A) (check (b ::: _B))) cs lam1 :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => Bind m (Pattern (Name :==> Type)) -> Type <==: m Term -> Type <==: m Term @@ -141,7 +139,7 @@ lam1 p b = lam [(p, b)] app :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => (a -> b -> c) -> (HasCallStack => m (a :==> Type)) -> (HasCallStack => Type <==: m b) -> m (c :==> Type) app mk operator operand = do f' :==> _F <- operator - (_, _, _A, _B) <- assertFunction _F + (_, _A, _B) <- assertFunction _F a' <- check (operand ::: _A) pure $ mk f' a' :==> _B @@ -166,7 +164,7 @@ varP :: Name -> Bind m (ValPattern (Name :==> Type)) varP n = Bind $ \ _A k -> k (PVar (n :==> wrap _A)) where wrap = \case - T.Comp sig _A -> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] |> T "Unit")) Nil) (T.Comp sig _A) + T.Comp sig _A -> T.Arrow Nothing (T.Ne (Global (NE.FromList ["Data", "Unit"] |> T "Unit")) Nil) (T.Comp sig _A) _T -> _T conP :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> [Bind m (ValPattern (Name :==> Type))] -> Bind m (ValPattern (Name :==> Type)) @@ -180,7 +178,7 @@ fieldsP :: Has (Throw ErrReason) sig m => [Bind m a] -> Bind m ([a], Type) fieldsP = foldr cons nil where cons p ps = Bind $ \ _A k -> do - (_, _, _A', _A'') <- assertFunction _A + (_, _A', _A'') <- assertFunction _A runBind p _A' $ \ p' -> runBind ps _A'' (k . first (p' :)) nil = Bind $ \ _T k -> k ([], _T) @@ -188,7 +186,7 @@ fieldsP = foldr cons nil allP :: Has (Throw ErrReason :+: Write Warn) sig m => Name -> Bind m (Pattern (Name :==> Type)) allP n = Bind $ \ _A k -> do (sig, _T) <- assertComp _A - k (PVal (PVar (n :==> T.Arrow Nothing Many (T.Ne (Global (NE.FromList ["Data", "Unit"] |> T "Unit")) Nil) (T.Comp sig _T)))) + k (PVal (PVar (n :==> T.Arrow Nothing (T.Ne (Global (NE.FromList ["Data", "Unit"] |> T "Unit")) Nil) (T.Comp sig _T)))) -- Expression elaboration @@ -253,9 +251,9 @@ abstractTerm body = go Nil Nil T.ForAll n _T _B -> do d <- depth check (tlam (go (ts :> LName d n) fs) ::: T.ForAll n _T _B) - T.Arrow n q _A _B -> do + T.Arrow n _A _B -> do d <- depth - check (lam [(patternForArgType _A (fromMaybe __ n), go ts (fs :> \ d' -> Var (Free (LName (toIndexed d' d) (fromMaybe __ n)))))] ::: T.Arrow n q _A _B) + check (lam [(patternForArgType _A (fromMaybe __ n), go ts (fs :> \ d' -> Var (Free (LName (toIndexed d' d) (fromMaybe __ n)))))] ::: T.Arrow n _A _B) _T -> do d <- depth pure $ body (TX.Var . Free . Right . toIndexed d <$> ts) (fs <*> pure d) @@ -298,12 +296,12 @@ elabTermDef expr@(S.Ann s _ _) = Check $ \ _T -> do elabTerm $ runErr $ pushSpan s $ check (go (checkExpr expr) ::: _T) where go k = Check $ \ _T -> case _T of - T.ForAll{} -> check (tlam (go k) ::: _T) - T.Arrow (Just n) q _A _B -> check (lam [(PVal <$> varP n, go k)] ::: T.Arrow Nothing q _A _B) + T.ForAll{} -> check (tlam (go k) ::: _T) + T.Arrow (Just n) _A _B -> check (lam [(PVal <$> varP n, go k)] ::: T.Arrow Nothing _A _B) -- FIXME: this doesn’t do what we want for tacit definitions, i.e. where _T is itself a telescope. -- FIXME: eta-expanding here doesn’t help either because it doesn’t change the way elaboration of the surface term occurs. -- we’ve exhausted the named parameters; the rest is up to the body. - _ -> check (k ::: _T) + _ -> check (k ::: _T) -- Modules @@ -352,7 +350,7 @@ assertQuantifier :: Has (Throw ErrReason) sig m => Type -> m (Name, Kind, Type - assertQuantifier = assertTypesMatch _ForAll "{_} -> _" -- | Expect a tacit (non-variable-binding) function type. -assertTacitFunction :: Has (Throw ErrReason) sig m => Type -> m (Maybe Name, Quantity, Type, Type) +assertTacitFunction :: Has (Throw ErrReason) sig m => Type -> m (Maybe Name, Type, Type) assertTacitFunction = assertTypesMatch _Arrow "_ -> _" -- | Expect a computation type with effects. diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index 8939216db..e793fec81 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -24,7 +24,6 @@ import Facet.Kind import Facet.Lens (views) import Facet.Module import Facet.Name -import Facet.Semiring (Few(..), one, zero) import Facet.Snoc import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) @@ -78,16 +77,12 @@ comp s t = do synthType :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => S.Ann S.Type -> m (TX.Type :==> Kind) synthType (S.Ann s _ e) = pushSpan s $ case e of - S.TVar n -> tvar n - S.TString -> Facet.Elab.Type._String - S.TForAll n t b -> forAll (n ::: t) (synthType b) - S.TArrow n q a b -> arrow (TX.Arrow n (maybe Many interpretMul q)) (synthType a) (synthType b) - S.TComp s t -> comp (map synthInterface s) (synthType t) - S.TApp f a -> app TX.App (synthType f) (synthType a) - where - interpretMul = \case - S.Zero -> zero - S.One -> one + S.TVar n -> tvar n + S.TString -> Facet.Elab.Type._String + S.TForAll n t b -> forAll (n ::: t) (synthType b) + S.TArrow n a b -> arrow (TX.Arrow n) (synthType a) (synthType b) + S.TComp s t -> comp (map synthInterface s) (synthType t) + S.TApp f a -> app TX.App (synthType f) (synthType a) synthInterface :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => S.Ann (S.Interface (S.Ann S.Type)) -> m (Interface TX.Type :==> Kind) synthInterface (S.Ann s _ (S.Interface h sp)) = pushSpan s $ do diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index 6e62b62c0..038c58d43 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -178,13 +178,10 @@ forAll k = make <$> anned (try (((,,) <$ lbrace <*> commaSep1 ((,) <$> position make (S.Ann s cs (ns, t, b)) = S.Ann s cs (S.out (foldr (\ (p, n) b -> S.Ann (Span p (end s)) Nil (S.TForAll n t b)) b ns)) bindArrow :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p N.Name -> p (S.Ann S.Type) -> p (S.Ann S.Type) -bindArrow name k = anned (try (S.TArrow . Just <$ lparen <*> (name <|> N.__ <$ wildcard) <* colon) <*> optional mul <*> type' <* rparen <* arrow <*> k) +bindArrow name k = anned (try (S.TArrow . Just <$ lparen <*> (name <|> N.__ <$ wildcard) <* colon) <*> type' <* rparen <* arrow <*> k) functionType :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Type) -> p (S.Ann S.Type) -> p (S.Ann S.Type) -functionType self next = anned (try (S.TArrow Nothing <$> optional mul <*> next <* arrow) <*> self) <|> next - -mul :: TokenParsing p => p S.Mul -mul = choice [ S.Zero <$ token (char '0'), S.One <$ token (char '1') ] +functionType self next = anned (try (S.TArrow Nothing <$> next <* arrow) <*> self) <|> next retType :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Type) -> p (S.Ann S.Type) -> p (S.Ann S.Type) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 3bcada3d2..8506c62f9 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -39,7 +39,6 @@ import Facet.Pretty (lower, upper) import Facet.Print.Options import Facet.Quote import qualified Facet.Scope as C -import Facet.Semiring (one, zero) import Facet.Snoc import Facet.Snoc.NonEmpty (NonEmpty(..)) import Facet.Style @@ -174,9 +173,9 @@ instance Printable TX.Type where TX.Var (Global n) -> qvar n TX.Var (Free (Right n)) -> fromMaybe (lname (toLeveled d n)) $ Env.lookup env n TX.Var (Free (Left m)) -> meta m - TX.ForAll n t b -> braces (ann (intro n d ::: print opts env t)) --> go (env |> PVal (PVar (n :=: intro n d))) b - TX.Arrow Nothing q a b -> mult q (go env a) --> go env b - TX.Arrow (Just n) q a b -> parens (ann (intro n d ::: mult q (go env a))) --> go env b + TX.ForAll n t b -> braces (ann (intro n d ::: print opts env t)) --> go (env |> PVal (PVar (n :=: intro n d))) b + TX.Arrow Nothing a b -> go env a --> go env b + TX.Arrow (Just n) a b -> parens (ann (intro n d ::: go env a)) --> go env b TX.Comp s t -> if s == mempty then go env t else sig s <+> go env t TX.App f a -> group (go env f) $$ group (go env a) TX.String -> annotate Type $ pretty "String" @@ -184,10 +183,6 @@ instance Printable TX.Type where d = level env sig s = brackets (commaSep (map (interface env) (interfaces s))) interface = printWith print opts - mult q = if - | q == zero -> (pretty '0' <+>) - | q == one -> (pretty '1' <+>) - | otherwise -> id deriving via (Quoting TX.Type TN.Type) instance Printable TN.Type diff --git a/src/Facet/Surface/Type/Class.hs b/src/Facet/Surface/Type/Class.hs index 90d1384e0..2cb2bdefa 100644 --- a/src/Facet/Surface/Type/Class.hs +++ b/src/Facet/Surface/Type/Class.hs @@ -8,7 +8,6 @@ import Facet.Functor.Compose import Facet.Kind import Facet.Name import Facet.Snoc -import Facet.Surface.Type.Expr (Mul) import Facet.Syntax (type (~>)) -- FIXME: interface for annotating types/terms @@ -16,7 +15,7 @@ class Type r where var :: QName -> r string :: r forAll :: Name -> Kind -> (r -> r) -> r - arrow :: Maybe Name -> Maybe Mul -> r -> r -> r + arrow :: Maybe Name -> r -> r -> r comp :: [r] -> r -> r tapp :: r -> r -> r diff --git a/src/Facet/Surface/Type/Expr.hs b/src/Facet/Surface/Type/Expr.hs index c07a20c0d..9bb1aeeaa 100644 --- a/src/Facet/Surface/Type/Expr.hs +++ b/src/Facet/Surface/Type/Expr.hs @@ -1,7 +1,6 @@ module Facet.Surface.Type.Expr ( Type(..) , Interface(..) -, Mul(..) ) where import Facet.Kind @@ -15,7 +14,7 @@ data Type = TVar QName | TString | TForAll Name Kind (Ann Type) - | TArrow (Maybe Name) (Maybe Mul) (Ann Type) (Ann Type) + | TArrow (Maybe Name) (Ann Type) (Ann Type) | TComp [Ann (Interface (Ann Type))] (Ann Type) | TApp (Ann Type) (Ann Type) deriving (Eq, Show) @@ -23,7 +22,3 @@ data Type data Interface a = Interface QName (Snoc a) deriving (Eq, Show) - - -data Mul = Zero | One - deriving (Bounded, Enum, Eq, Ord, Show) diff --git a/src/Facet/Type/Class.hs b/src/Facet/Type/Class.hs index c2598abcf..61e6ccdd4 100644 --- a/src/Facet/Type/Class.hs +++ b/src/Facet/Type/Class.hs @@ -10,14 +10,13 @@ import Facet.Interface (Signature) import Facet.Kind (Kind) import Facet.Name (LName, Level, Meta, Name) import Facet.Syntax (Var, type (~>)) -import Facet.Usage (Quantity) -- Types class Type r where string :: r forAll :: Name -> Kind -> (r -> r) -> r - arrow :: Maybe Name -> Quantity -> r -> r -> r + arrow :: Maybe Name -> r -> r -> r var :: Var (Either Meta (LName Level)) -> r ($$) :: r -> r -> r infixl 9 $$ diff --git a/src/Facet/Type/Expr.hs b/src/Facet/Type/Expr.hs index 2f8e65e7c..20e3ffb75 100644 --- a/src/Facet/Type/Expr.hs +++ b/src/Facet/Type/Expr.hs @@ -9,13 +9,12 @@ import Facet.Name import Facet.Quote import Facet.Syntax import qualified Facet.Type.Class as C -import Facet.Usage data Type = String | Var (Var (Either Meta (LName Index))) | ForAll Name Kind Type - | Arrow (Maybe Name) Quantity Type Type + | Arrow (Maybe Name) Type Type | Comp (Signature Type) Type | App Type Type deriving (Eq, Ord, Show) @@ -23,7 +22,7 @@ data Type instance C.Type (Quoter Type) where string = pure String forAll n k b = ForAll n k <$> binder (\ d' -> Quoter (\ d -> lvar n (toIndexed d d'))) b - arrow n q = liftA2 (Arrow n q) + arrow n = liftA2 (Arrow n) var v = Quoter (\ d -> Var (toIndexed d v)) ($$) = liftA2 App sig |- t = Comp <$> sequenceSignature sig <*> t diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index c3a5e5567..d508ba5e2 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -34,7 +34,6 @@ import Facet.Subst import Facet.Syntax import qualified Facet.Type.Class as C import qualified Facet.Type.Expr as TX -import Facet.Usage hiding (singleton) import Fresnel.Prism (Prism', prism') import Fresnel.Review (review) import GHC.Stack @@ -45,7 +44,7 @@ import Prelude hiding (lookup) data Type = String | ForAll Name Kind (Type -> Type) - | Arrow (Maybe Name) Quantity Type Type + | Arrow (Maybe Name) Type Type | Ne (Var (Either Meta (LName Level))) (Snoc Type) | Comp (Signature Type) Type deriving (Eq, Ord, Show) via Quoting TX.Type Type @@ -61,11 +60,11 @@ instance C.Type Type where instance Quote Type TX.Type where quote = \case - String -> pure TX.String - ForAll n t b -> Quoter (\ d -> TX.ForAll n t (runQuoter (succ d) (quote (b (free (LName d n)))))) - Arrow n q a b -> TX.Arrow n q <$> quote a <*> quote b - Comp s t -> TX.Comp <$> traverseSignature quote s <*> quote t - Ne n sp -> foldl' (\ h t -> TX.App <$> h <*> quote t) (Quoter (\ d -> TX.Var (toIndexed d n))) sp + String -> pure TX.String + ForAll n t b -> Quoter (\ d -> TX.ForAll n t (runQuoter (succ d) (quote (b (free (LName d n)))))) + Arrow n a b -> TX.Arrow n <$> quote a <*> quote b + Comp s t -> TX.Comp <$> traverseSignature quote s <*> quote t + Ne n sp -> foldl' (\ h t -> TX.App <$> h <*> quote t) (Quoter (\ d -> TX.Var (toIndexed d n))) sp _String :: Prism' Type () @@ -74,8 +73,8 @@ _String = prism' (const String) (\case{ String -> Just () ; _ -> Nothing }) _ForAll :: Prism' Type (Name, Kind, Type -> Type) _ForAll = prism' (\ (n, k, b) -> ForAll n k b) (\case{ ForAll n k b -> Just (n, k, b) ; _ -> Nothing }) -_Arrow :: Prism' Type (Maybe Name, Quantity, Type, Type) -_Arrow = prism' (\ (n, q, a, b) -> Arrow n q a b) (\case{ Arrow n q a b -> Just (n, q, a, b) ; _ -> Nothing }) +_Arrow :: Prism' Type (Maybe Name, Type, Type) +_Arrow = prism' (\ (n, a, b) -> Arrow n a b) (\case{ Arrow n a b -> Just (n, a, b) ; _ -> Nothing }) _Ne :: Prism' Type (Var (Either Meta (LName Level)), Snoc Type) _Ne = prism' (uncurry Ne) (\case{ Ne c ts -> Just (c, ts) ; _ -> Nothing }) @@ -113,11 +112,11 @@ occursIn :: Meta -> Level -> Type -> Bool occursIn p = go where go d = \case - ForAll n _ b -> go (succ d) (b (free (LName d n))) - Arrow _ _ a b -> go d a || go d b - Comp s t -> any (go d) s || go d t - Ne h sp -> any (either (== p) (const False)) h || any (go d) sp - String -> False + ForAll n _ b -> go (succ d) (b (free (LName d n))) + Arrow _ a b -> go d a || go d b + Comp s t -> any (go d) s || go d t + Ne h sp -> any (either (== p) (const False)) h || any (go d) sp + String -> False -- Elimination @@ -142,7 +141,7 @@ eval subst = go where TX.Var (Free (Right n)) -> index env n TX.Var (Free (Left m)) -> fromMaybe (metavar m) (lookupMeta m subst) TX.ForAll n t b -> ForAll n t (\ _T -> go (env |> review _PVar (n :=: _T)) b) - TX.Arrow n q a b -> Arrow n q (go env a) (go env b) + TX.Arrow n a b -> Arrow n (go env a) (go env b) TX.Comp s t -> Comp (mapSignature (go env) s) (go env t) TX.App f a -> go env f $$ go env a diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index 0cdb6d1d7..aef88fea8 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -58,7 +58,7 @@ unifyType = curry $ \case (t1, TN.Ne (Free (Left v2)) Nil) -> solve v2 t1 (TN.ForAll _ t1 b1, TN.ForAll n t2 b2) -> depth >>= \ d -> evalTExpr =<< mkForAll d n <$> unifyKind t1 t2 <*> (n :==> t2 ||- unifyType (b1 (free (LName d n))) (b2 (free (LName d n)))) (TN.ForAll{}, _) -> mismatch - (TN.Arrow _ _ a1 b1, TN.Arrow n q a2 b2) -> TN.Arrow n q <$> unifyType a1 a2 <*> unifyType b1 b2 + (TN.Arrow _ a1 b1, TN.Arrow n a2 b2) -> TN.Arrow n <$> unifyType a1 a2 <*> unifyType b1 b2 (TN.Arrow{}, _) -> mismatch (TN.Ne v1 sp1, TN.Ne v2 sp2) -> TN.Ne <$> unifyVar v1 v2 <*> unifySpine unifyType sp1 sp2 (TN.Ne{}, _) -> mismatch diff --git a/test/Facet/Core/Type/Test.hs b/test/Facet/Core/Type/Test.hs index 958680f86..b874b48e5 100644 --- a/test/Facet/Core/Type/Test.hs +++ b/test/Facet/Core/Type/Test.hs @@ -8,7 +8,6 @@ import Facet.Env import Facet.Kind import Facet.Name import Facet.Quote -import Facet.Semiring import Facet.Syntax import Facet.Type.Expr import Facet.Type.Norm (eval) @@ -18,5 +17,5 @@ tests :: IO Bool tests = checkParallel $$(discover) prop_quotation_inverse = property $ do - let init = ForAll (T "A") KType (Arrow (Just (T "x")) Many (Var (Free (Right (LName 0 (T "A"))))) (Comp mempty (Var (Free (Right (LName 0 (T "A"))))))) + let init = ForAll (T "A") KType (Arrow (Just (T "x")) (Var (Free (Right (LName 0 (T "A"))))) (Comp mempty (Var (Free (Right (LName 0 (T "A"))))))) runQuoter 0 (quote (eval mempty empty init)) === init From d35c27c6ef9e4e329750792dff69af9176e10bed Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 00:36:50 -0400 Subject: [PATCH 1141/1324] :fire: resource mismatch errors. --- src/Facet/Elab.hs | 6 ------ src/Facet/Notice/Elab.hs | 9 --------- 2 files changed, 15 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index ed666a0c5..62df23090 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -30,7 +30,6 @@ module Facet.Elab , mismatchKinds , couldNotUnifyKinds , couldNotSynthesize -, resourceMismatch , freeVariable , missingInterface , assertMatch @@ -195,7 +194,6 @@ data ErrReason -- FIXME: add source references for the imports, definition sites, and any re-exports. | AmbiguousName QName | CouldNotSynthesize - | ResourceMismatch Name Quantity Quantity | UnifyType UnifyErrReason (Exp (Either String Type)) (Act Type) | UnifyKind (Exp (Either String Kind)) (Act Kind) | Hole Name Type @@ -236,7 +234,6 @@ applySubst ctx subst r = case r of FreeVariable{} -> r AmbiguousName{} -> r CouldNotSynthesize{} -> r - ResourceMismatch{} -> r -- NB: not substituting in @r@ because we want to retain the cyclic occurrence (and finitely) UnifyType r exp act -> UnifyType r (fmap roundtrip <$> exp) (roundtrip <$> act) UnifyKind{} -> r @@ -259,9 +256,6 @@ couldNotUnifyKinds t1 t2 = withFrozenCallStack $ mismatchKinds (Right <$> t1) t2 couldNotSynthesize :: Has (Throw ErrReason) sig m => m a couldNotSynthesize = withFrozenCallStack $ throwError CouldNotSynthesize -resourceMismatch :: Has (Throw ErrReason) sig m => Name -> Quantity -> Quantity -> m a -resourceMismatch n exp act = withFrozenCallStack $ throwError $ ResourceMismatch n exp act - freeVariable :: Has (Throw ErrReason) sig m => QName -> m a freeVariable n = withFrozenCallStack $ throwError $ FreeVariable n diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 1316d5ccc..03f27d331 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -19,7 +19,6 @@ import Facet.Notice as Notice hiding (level) import Facet.Pattern import Facet.Pretty import Facet.Print as Print -import Facet.Semiring (Few(..)) import Facet.Snoc import Facet.Style import Facet.Subst (metas) @@ -61,14 +60,6 @@ printErrReason opts ctx = group . \case FreeVariable n -> fillSep [reflow "variable not in scope:", prettyQName n] AmbiguousName n -> fillSep [reflow "ambiguous name", prettyQName n] -- <\> nest 2 (reflow "alternatives:" <\> unlines (map prettyQName qs)) CouldNotSynthesize -> reflow "could not synthesize a type; try a type annotation" - ResourceMismatch n e a -> fillSep [reflow "uses of variable", pretty n, reflow "didn’t match requirements"] - <> hardline <> pretty "expected:" <+> prettyQ e - <> hardline <> pretty " actual:" <+> prettyQ a - where - prettyQ = \case - Zero -> pretty "0" - One -> pretty "1" - Many -> pretty "arbitrarily many" UnifyType r (Exp exp) (Act act) -> reason r <> hardline <> pretty "expected:" <> align exp' <> hardline <> pretty " actual:" <> align act' From 0f80e7ac71184d503855d9d508f7ab2452f7df6f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 00:38:12 -0400 Subject: [PATCH 1142/1324] :fire: quantities from sequent types. --- src/Facet/Elab/Pattern.hs | 2 +- src/Facet/Sequent/Type.hs | 3 +-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index df4b5ddc7..9a701843c 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -37,7 +37,7 @@ instantiateHead p = p compileClauses :: Has Empty sig m => [X.Term] -> Type -> [Clause X.Term] -> QuoterT m X.Term -compileClauses ctx (Arrow Nothing _ _A _T) heads = C.lamR (compileClausesBody ctx _A _T heads) +compileClauses ctx (Arrow Nothing _A _T) heads = C.lamR (compileClausesBody ctx _A _T heads) compileClauses _ _T heads | Just (Clause [] b) <- preview folded heads = pure b | otherwise = empty diff --git a/src/Facet/Sequent/Type.hs b/src/Facet/Sequent/Type.hs index e76b1971b..d94951c53 100644 --- a/src/Facet/Sequent/Type.hs +++ b/src/Facet/Sequent/Type.hs @@ -4,14 +4,13 @@ module Facet.Sequent.Type import Facet.Kind (Kind) import Facet.Name (Name) -import Facet.Usage (Quantity) data Type = String | Type :+ Type | Type :* Type | ForAll Name Kind (Type -> Type) - | Arrow (Maybe Name) Quantity Type Type + | Arrow (Maybe Name) Type Type infixl 6 :+ infixl 7 :* From 3b76f70ecc60c41336779e0b78e9bc58ec0aa973 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 00:39:47 -0400 Subject: [PATCH 1143/1324] :fire: the re-export of Quantity. --- src/Facet/Context.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index af0f3f8a4..44ae3de86 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -1,8 +1,7 @@ {-# LANGUAGE ExistentialQuantification #-} module Facet.Context ( -- * Contexts - Quantity -, Context(..) + Context(..) , Binding(..) , empty , (|>) @@ -22,7 +21,6 @@ import Facet.Pattern import qualified Facet.Snoc as S import Facet.Syntax import Facet.Type.Norm -import Facet.Usage import Fresnel.Review (review) import GHC.Stack import Prelude hiding (lookup) From 6e8777b190432c69affc18faed8637a5f083e4e4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 00:40:08 -0400 Subject: [PATCH 1144/1324] :fire: Facet.Usage. --- facet.cabal | 1 - src/Facet/Usage.hs | 48 ---------------------------------------------- 2 files changed, 49 deletions(-) delete mode 100644 src/Facet/Usage.hs diff --git a/facet.cabal b/facet.cabal index 7b5d08d3e..b6e848fb7 100644 --- a/facet.cabal +++ b/facet.cabal @@ -150,7 +150,6 @@ library Facet.Type.Expr Facet.Type.Norm Facet.Unify - Facet.Usage Facet.Vars other-modules: Paths_facet diff --git a/src/Facet/Usage.hs b/src/Facet/Usage.hs deleted file mode 100644 index 58c16382d..000000000 --- a/src/Facet/Usage.hs +++ /dev/null @@ -1,48 +0,0 @@ -module Facet.Usage -( -- * Quantities - Quantity - -- * Usage -, Usage(..) -, singleton -, lookup -, restrict -, withoutVars -) where - -import qualified Data.IntMap as IntMap -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Facet.Name -import Facet.Semiring -import qualified Facet.Vars as Vars -import Prelude hiding (lookup) - --- Quantities - -type Quantity = Few - - --- Usage - -newtype Usage = Usage (IntMap.IntMap (Map.Map Name Quantity)) - -instance Semigroup Usage where - Usage a <> Usage b = Usage (IntMap.unionWith (<>) a b) - -instance Monoid Usage where - mempty = Usage mempty - -instance LeftModule Quantity Usage where - q ><< Usage a = Usage (fmap (q ><) <$> a) - -singleton :: LName Level -> Quantity -> Usage -singleton (LName (Level i) n) q = Usage (IntMap.singleton i (Map.singleton n q)) - -lookup :: LName Level -> Usage -> Quantity -lookup (LName (Level i) n) (Usage a) = fromMaybe zero (Map.lookup n =<< IntMap.lookup i a) - -restrict :: Usage -> Vars.Vars -> Usage -restrict (Usage u) (Vars.Vars v) = Usage (u `IntMap.restrictKeys` v) - -withoutVars :: Usage -> Vars.Vars -> Usage -withoutVars (Usage u) (Vars.Vars v) = Usage (u `IntMap.withoutKeys` v) From bca0c673709955b2adc956bc20cdaafa6ae7622c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 00:40:54 -0400 Subject: [PATCH 1145/1324] :fire: the LeftModule instance for Snoc. --- src/Facet/Snoc.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Facet/Snoc.hs b/src/Facet/Snoc.hs index 384c58522..fbef86817 100644 --- a/src/Facet/Snoc.hs +++ b/src/Facet/Snoc.hs @@ -15,7 +15,6 @@ import Data.Foldable (foldl', foldr') import Data.Functor.Classes import Data.Semialign import Data.These -import Facet.Semiring import GHC.Exts import GHC.Stack @@ -36,9 +35,6 @@ instance Semigroup (Snoc a) where instance Monoid (Snoc a) where mempty = Nil -instance Semiring r => LeftModule r (Snoc r) where - (><<) = scaleDefault - instance Semialign Snoc where align Nil Nil = Nil align Nil bs = That <$> bs From 5e038a8d0173ad330631725b8a3e711d524e6429 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 00:41:32 -0400 Subject: [PATCH 1146/1324] :fire: Facet.Semiring. --- facet.cabal | 1 - src/Facet/Semiring.hs | 170 ------------------------------------------ 2 files changed, 171 deletions(-) delete mode 100644 src/Facet/Semiring.hs diff --git a/facet.cabal b/facet.cabal index b6e848fb7..e658dd4c6 100644 --- a/facet.cabal +++ b/facet.cabal @@ -123,7 +123,6 @@ library Facet.Run Facet.Scope Facet.Semialign - Facet.Semiring Facet.Sequent.Class Facet.Sequent.Expr Facet.Sequent.Norm diff --git a/src/Facet/Semiring.hs b/src/Facet/Semiring.hs deleted file mode 100644 index f10ad75b2..000000000 --- a/src/Facet/Semiring.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} -module Facet.Semiring -( -- * Semiring classes - Semiring(..) -, Unital(..) -, zero - -- * Module classes -, LeftModule(..) -, scaleDefault - -- * Semiring datatypes -, Few(..) -, Tropical(..) -) where - --- Semiring classes - --- | Semirings extend 'Semigroup's with an '><' (multiplication) operation satisfying: --- --- Associativity: --- --- @ --- a >< (b >< c) ≡ (a >< b) >< c --- @ --- --- Left-distributivity: --- --- @ --- a >< (b <> c) ≡ (a >< b) <> (a >< c) --- @ --- --- Right-distributivity: --- --- @ --- (a <> b) >< c ≡ (a >< c) <> (b >< c) --- @ --- --- Contrary to many presentations, we do not require '<>' (addition) to be commutative, or for the type to be a 'Monoid'. However, if it /is/ a 'Monoid', then we additionally require '><' to satisfy: --- --- Left-annihilation: --- --- @ --- zero >< a ≡ zero --- @ --- --- Right-annihilation: --- --- @ --- a >< zero ≡ zero --- @ --- --- where 'zero' is a synonym for 'mempty', defined below. -class Semigroup s => Semiring s where - (><) :: s -> s -> s - infixr 7 >< - -instance Semiring () where - _ >< _ = () - -instance (Semiring a, Semiring b) => Semiring (a, b) where - (a1, b1) >< (a2, b2) = (a1 >< a2, b1 >< b2) - -instance (Semiring a, Semiring b, Semiring c) => Semiring (a, b, c) where - (a1, b1, c1) >< (a2, b2, c2) = (a1 >< a2, b1 >< b2, c1 >< c2) - - --- | Unital semirings extend 'Semiring's with a multiplicative unit, 'one', satisfyiing: --- --- Left-identity: --- --- @ --- one >< a ≡ a --- @ --- --- Right-identity: --- --- @ --- a >< one ≡ a --- @ -class (Monoid s, Semiring s) => Unital s where - one :: s - -instance Unital () where - one = () - -instance (Unital a, Unital b) => Unital (a, b) where - one = (one, one) - -instance (Unital a, Unital b, Unital c) => Unital (a, b, c) where - one = (one, one, one) - - -zero :: Unital s => s -zero = mempty - - --- Module classes - --- | A left /R/-module /M/ (for a 'Semiring' /R/) is a 'Semigroup' extended with a '><<' (scalar multiplication) operation satisfying: --- --- Left-distributivity of ><< over <> (on /M/): --- --- @ --- r ><< (m <> n) ≡ r ><< m <> r ><< n --- @ --- --- Left-distributivity of <> (on /R/) over ><<: --- --- @ --- (r <> s) ><< m ≡ r ><< m <> s ><< m --- @ --- --- Associativity: --- --- @ --- (r >< s) ><< m ≡ r ><< (s ><< m) --- @ -class (Semiring r, Semigroup m) => LeftModule r m | m -> r where - (><<) :: r -> m -> m - infixr 7 ><< - -scaleDefault :: (Semiring r, Functor f) => r -> f r -> f r -scaleDefault = fmap . (><) - -instance Semiring r => LeftModule r (Maybe r) where - (><<) = scaleDefault - - --- Semiring datatypes - -data Few - = Zero - | One - | Many - deriving (Bounded, Enum, Eq, Ord, Show) - -instance Semigroup Few where - Zero <> b = b - a <> Zero = a - _ <> _ = Many - -instance Monoid Few where - mempty = Zero - -instance Semiring Few where - Zero >< _ = Zero - _ >< Zero = Zero - a >< b = max a b - -instance Unital Few where - one = One - - -data Tropical a - = Finite a - | Infinity - deriving (Eq, Ord, Show) - -instance Ord a => Semigroup (Tropical a) where - (<>) = min - -instance Ord a => Monoid (Tropical a) where - mempty = Infinity - -instance (Num a, Ord a) => Semiring (Tropical a) where - Infinity >< _ = Infinity - _ >< Infinity = Infinity - Finite a >< Finite b = Finite (a + b) - -instance (Num a, Ord a) => Unital (Tropical a) where - one = Finite 0 From ba7f343eaf85a2c86f32d25610173dc60bbe514e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 00:46:49 -0400 Subject: [PATCH 1147/1324] Define type contexts. --- src/Facet/Context.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index 44ae3de86..ed6c3f8ab 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -9,6 +9,8 @@ module Facet.Context , (!) , lookupIndex , toEnv + -- * Type contexts +, TypeContext(..) ) where import qualified Control.Effect.Empty as E @@ -71,3 +73,6 @@ toEnv c = Env.Env (S.fromList (zipWith toType (toList (elems c)) [0..pred (level Kind (n :==> _) -> review _PVar (n :=: bind d n) bind d b = free (LName d b) + + +newtype TypeContext = TypeContext { getTypeContext :: S.Snoc (Name :==> Kind) } From 934d8e94c24618296ffb51d5fee437579a26fa32 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 00:54:35 -0400 Subject: [PATCH 1148/1324] Define a module for TypeContext. --- facet.cabal | 1 + src/Facet/TypeContext.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Facet/TypeContext.hs diff --git a/facet.cabal b/facet.cabal index e658dd4c6..1347f308e 100644 --- a/facet.cabal +++ b/facet.cabal @@ -148,6 +148,7 @@ library Facet.Type.Class Facet.Type.Expr Facet.Type.Norm + Facet.TypeContext Facet.Unify Facet.Vars other-modules: diff --git a/src/Facet/TypeContext.hs b/src/Facet/TypeContext.hs new file mode 100644 index 000000000..cd1e1583a --- /dev/null +++ b/src/Facet/TypeContext.hs @@ -0,0 +1,2 @@ +module Facet.TypeContext +() where From b7c39cc9c69a50945cd7929c3b92f4a77b4d7917 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 00:56:35 -0400 Subject: [PATCH 1149/1324] Move TypeContext into its own module. --- src/Facet/Context.hs | 5 ----- src/Facet/TypeContext.hs | 11 ++++++++++- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index ed6c3f8ab..44ae3de86 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -9,8 +9,6 @@ module Facet.Context , (!) , lookupIndex , toEnv - -- * Type contexts -, TypeContext(..) ) where import qualified Control.Effect.Empty as E @@ -73,6 +71,3 @@ toEnv c = Env.Env (S.fromList (zipWith toType (toList (elems c)) [0..pred (level Kind (n :==> _) -> review _PVar (n :=: bind d n) bind d b = free (LName d b) - - -newtype TypeContext = TypeContext { getTypeContext :: S.Snoc (Name :==> Kind) } diff --git a/src/Facet/TypeContext.hs b/src/Facet/TypeContext.hs index cd1e1583a..70ff884ff 100644 --- a/src/Facet/TypeContext.hs +++ b/src/Facet/TypeContext.hs @@ -1,2 +1,11 @@ module Facet.TypeContext -() where +( -- * Type contexts + TypeContext(..) +) where + +import Facet.Functor.Synth +import Facet.Kind +import Facet.Name +import qualified Facet.Snoc as S + +newtype TypeContext = TypeContext { getTypeContext :: S.Snoc (Name :==> Kind) } From a5fafd97acf0fe4b6a0b86128293d1599e31a721 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 00:57:17 -0400 Subject: [PATCH 1150/1324] Define the empty type context. --- src/Facet/TypeContext.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/TypeContext.hs b/src/Facet/TypeContext.hs index 70ff884ff..ac7e5a48c 100644 --- a/src/Facet/TypeContext.hs +++ b/src/Facet/TypeContext.hs @@ -1,6 +1,7 @@ module Facet.TypeContext ( -- * Type contexts TypeContext(..) +, empty ) where import Facet.Functor.Synth @@ -9,3 +10,6 @@ import Facet.Name import qualified Facet.Snoc as S newtype TypeContext = TypeContext { getTypeContext :: S.Snoc (Name :==> Kind) } + +empty :: TypeContext +empty = TypeContext S.Nil From 6570a4e913b36c2115302bd45bb2ac96e29939f3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 00:59:11 -0400 Subject: [PATCH 1151/1324] ElabContext carries a type context. --- src/Facet/Elab.hs | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 62df23090..b6d796a38 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -43,6 +43,7 @@ module Facet.Elab -- * Unification , ElabContext(..) , context_ +, typeContext_ , sig_ -- * Machinery , evalTExpr @@ -85,6 +86,7 @@ import qualified Facet.Syntax as S import Facet.Term.Expr as E import qualified Facet.Type.Expr as TX import Facet.Type.Norm as TN +import qualified Facet.TypeContext as TypeContext import Fresnel.Fold ((^?)) import Fresnel.Ixed (ix) import Fresnel.Lens (Lens', lens) @@ -314,16 +316,20 @@ assertFunction = assertTypesMatch _Arrow "_ -> _" -- Unification data ElabContext = ElabContext - { context :: Context - , sig :: [Signature Type] - , spans :: Snoc Span + { context :: Context + , typeContext :: TypeContext.TypeContext + , sig :: [Signature Type] + , spans :: Snoc Span } context_ :: Lens' ElabContext Context -context_ = lens (\ ElabContext{ context } -> context) (\ ElabContext{ sig, spans } context -> ElabContext{ context, sig, spans }) +context_ = lens (\ ElabContext{ context } -> context) (\ ElabContext{ typeContext, sig, spans } context -> ElabContext{ context, typeContext, sig, spans }) + +typeContext_ :: Lens' ElabContext TypeContext.TypeContext +typeContext_ = lens (\ ElabContext{ typeContext } -> typeContext) (\ ElabContext{ context, sig, spans } typeContext -> ElabContext{ context, typeContext, sig, spans }) sig_ :: Lens' ElabContext [Signature Type] -sig_ = lens (\ ElabContext{ sig } -> sig) (\ ElabContext{ context, spans } sig -> ElabContext{ context, sig, spans }) +sig_ = lens (\ ElabContext{ sig } -> sig) (\ ElabContext{ context, typeContext, spans } sig -> ElabContext{ context, typeContext, sig, spans }) spans_ :: Lens' ElabContext (Snoc Span) spans_ = lens spans (\ e spans -> e{ spans }) @@ -333,7 +339,7 @@ spans_ = lens spans (\ e spans -> e{ spans }) elabWith :: (Subst Type -> a -> m b) -> ReaderC ElabContext (StateC (Subst Type) m) a -> m b elabWith k m = runState k mempty $ do - let ctx = ElabContext{ context = Context.empty, sig = mempty, spans = Nil } + let ctx = ElabContext{ context = Context.empty, typeContext = TypeContext.empty, sig = mempty, spans = Nil } runReader ctx m elabKind :: Applicative m => ReaderC ElabContext (StateC (Subst Type) m) Kind -> m Kind From 2e9bff6f4c59029fd1717f820bcecf5fe8162d50 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 08:02:32 -0400 Subject: [PATCH 1152/1324] Separate type and term contexts. --- src/Facet/Context.hs | 28 ++++++++-------------------- src/Facet/Elab.hs | 12 +++++++++--- src/Facet/Elab/Sequent.hs | 2 +- src/Facet/Elab/Term.hs | 4 ++-- src/Facet/Elab/Type.hs | 6 +++--- src/Facet/Notice/Elab.hs | 14 ++++++-------- src/Facet/TypeContext.hs | 14 ++++++++++++++ 7 files changed, 43 insertions(+), 37 deletions(-) diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index 44ae3de86..b633e8dd9 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -2,7 +2,6 @@ module Facet.Context ( -- * Contexts Context(..) -, Binding(..) , empty , (|>) , level @@ -15,27 +14,21 @@ import qualified Control.Effect.Empty as E import Data.Foldable (find, toList) import qualified Facet.Env as Env import Facet.Functor.Synth -import Facet.Kind (Kind) import Facet.Name import Facet.Pattern import qualified Facet.Snoc as S import Facet.Syntax import Facet.Type.Norm -import Fresnel.Review (review) import GHC.Stack import Prelude hiding (lookup) -newtype Context = Context { elems :: S.Snoc Binding } - -data Binding - = Type (Pattern (Name :==> Type)) - | Kind (Name :==> Kind) +newtype Context = Context { elems :: S.Snoc (Pattern (Name :==> Type)) } empty :: Context empty = Context S.Nil -(|>) :: Context -> Binding -> Context +(|>) :: Context -> Pattern (Name :==> Type) -> Context Context as |> a = Context (as S.:> a) infixl 5 |> @@ -43,7 +36,7 @@ infixl 5 |> level :: Context -> Level level (Context es) = Level (length es) -(!) :: HasCallStack => Context -> Index -> Binding +(!) :: HasCallStack => Context -> Index -> Pattern (Name :==> Type) Context es' ! Index i' = withFrozenCallStack $ go es' i' where go (es S.:> e) i @@ -51,23 +44,18 @@ Context es' ! Index i' = withFrozenCallStack $ go es' i' | otherwise = go es (i - 1) go _ _ = error $ "Facet.Context.!: index (" <> show i' <> ") out of bounds (" <> show (length es') <> ")" -lookupIndex :: E.Has E.Empty sig m => Name -> Context -> m (LName Index, Either Kind Type) +lookupIndex :: E.Has E.Empty sig m => Name -> Context -> m (LName Index, Type) lookupIndex n = go (Index 0) . elems where go _ S.Nil = E.empty - go i (cs S.:> b) = case b of - Type p - | Just (n' :==> t) <- find ((== n) . proof) p -> pure (LName i n', Right t) - Kind (n' :==> k) - | n == n' -> pure (LName i n', Left k) - _ -> go (succ i) cs + go i (cs S.:> p) = case find ((== n) . proof) p of + Just (n' :==> t) -> pure (LName i n', t) + _ -> go (succ i) cs toEnv :: Context -> Env.Env Type toEnv c = Env.Env (S.fromList (zipWith toType (toList (elems c)) [0..pred (level c)])) where - toType b d = case b of - Type p -> (\ b -> proof b :=: bind d (proof b)) <$> p - Kind (n :==> _) -> review _PVar (n :=: bind d n) + toType p d = (\ b -> proof b :=: bind d (proof b)) <$> p bind d b = free (LName d b) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index b6d796a38..b0840e88e 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -7,6 +7,7 @@ module Facet.Elab ( -- * General lookupInContext +, lookupInTypeContext , lookupInSig , resolveDef , resolveC @@ -133,11 +134,16 @@ resolveC = resolveWith lookupConstructor resolveDef :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m Def resolveDef = resolveWith lookupDef -lookupInContext :: Has (Choose :+: Empty) sig m => QName -> Context -> m (LName Index, Either Kind Type) +lookupInContext :: Has (Choose :+: Empty) sig m => QName -> Context -> m (LName Index, Type) lookupInContext (m:|>n) | m == Nil = lookupIndex n | otherwise = const empty +lookupInTypeContext :: Has (Choose :+: Empty) sig m => QName -> TypeContext.TypeContext -> m (LName Index, Kind) +lookupInTypeContext (m:|>n) + | m == Nil = TypeContext.lookupIndex n + | otherwise = const empty + -- FIXME: probably we should instead look up the effect op globally, then check for membership in the sig -- FIXME: return the index in the sig; it’s vital for evaluation of polymorphic effects when there are multiple such lookupInSig :: Has (Choose :+: Empty) sig m => QName -> Module -> Graph -> [Signature Type] -> m (QName :=: Type) @@ -151,12 +157,12 @@ lookupInSig (m :|> n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':|>_) _ (|-) :: Has (Reader ElabContext) sig m => Pattern (Name :==> Type) -> m a -> m a -p |- b = locally context_ (|> Type p) b +p |- b = locally context_ (|> p) b infix 1 |- (||-) :: Has (Reader ElabContext) sig m => (Name :==> Kind) -> m a -> m a -k ||- b = locally context_ (|> Kind k) b +k ||- b = locally typeContext_ (TypeContext.|> k) b infix 1 ||- diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index b63cebe5b..cea584e37 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -67,7 +67,7 @@ globalS (q ::: _T) = do -- FIXME: effect ops in the sig are available whether or not they’re in scope varS :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, SQ.Term t c d, Applicative i) => QName -> m (i t :==> Type) varS n = views context_ (lookupInContext n) >>= \case - [(n', Right _T)] -> do + [(n', _T)] -> do d <- views context_ level SQ.varA (Free (toLeveled d (ident n'))) ==> pure _T _ -> resolveDef n >>= \case diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 2cac024a7..c57ebe6fa 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -112,8 +112,8 @@ global (q ::: _T) = (\ (v ::: _T) -> v :==> _T) <$> instantiate const (Var (Glob -- FIXME: effect ops in the sig are available whether or not they’re in scope var :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m) => QName -> m (Term :==> Type) var n = views context_ (lookupInContext n) >>= \case - [(n', Right _T)] -> pure (Var (Free n') :==> _T) - _ -> resolveDef n >>= \case + [(n', _T)] -> pure (Var (Free n') :==> _T) + _ -> resolveDef n >>= \case DTerm _ _T -> global (n ::: _T) _ -> freeVariable n diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index e793fec81..ec37f8558 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -30,9 +30,9 @@ import Facet.Syntax as S hiding (context_) import qualified Facet.Type.Expr as TX tvar :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (TX.Type :==> Kind) -tvar n = views context_ (lookupInContext n) >>= \case - [(n', Left _K)] -> pure (TX.Var (Free (Right n')) :==> _K) - _ -> resolveDef n >>= \case +tvar n = views typeContext_ (lookupInTypeContext n) >>= \case + [(n', _K)] -> pure (TX.Var (Free (Right n')) :==> _K) + _ -> resolveDef n >>= \case DSubmodule _ _K -> pure $ TX.Var (Global n) :==> _K _ -> freeVariable n diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 03f27d331..9f4588cd5 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -9,14 +9,12 @@ import Data.Semigroup (stimes) import qualified Facet.Carrier.Throw.Inject as L import qualified Facet.Carrier.Write.Inject as L import Facet.Context (elems, toEnv) -import qualified Facet.Context as C import Facet.Elab as Elab import qualified Facet.Env as Env import Facet.Functor.Synth import Facet.Interface (interfaces) import Facet.Name import Facet.Notice as Notice hiding (level) -import Facet.Pattern import Facet.Pretty import Facet.Print as Print import Facet.Snoc @@ -43,12 +41,12 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) (_, _, printCtx, ctx) = foldl' combine (0, Env.empty, Env.empty, Nil) (elems context) subst' = map (\ (m :=: v) -> getPrint (Print.meta m <+> pretty '=' <+> maybe (pretty '?') (print opts printCtx) v)) (metas subst) sig' = getPrint . print opts printCtx . fmap (apply subst (toEnv context)) <$> (interfaces =<< sig) - combine (d, env, prints, ctx) (C.Kind (n :==> _K)) = - ( succ d - , env Env.|> PVal (PVar (n :=: free (LName d n))) - , prints Env.|> PVal (PVar (n :=: intro n d)) - , ctx :> getPrint (print opts prints (ann (intro n d ::: print opts prints _K))) ) - combine (d, env, prints, ctx) (C.Type p) = + -- combine (d, env, prints, ctx) (n :==> _K) = + -- ( succ d + -- , env Env.|> PVal (PVar (n :=: free (LName d n))) + -- , prints Env.|> PVal (PVar (n :=: intro n d)) + -- , ctx :> getPrint (print opts prints (ann (intro n d ::: print opts prints _K))) ) + combine (d, env, prints, ctx) p = ( succ d , env Env.|> ((\ (n :==> _T) -> n :=: free (LName d n)) <$> p) , prints Env.|> ((\ (n :==> _) -> n :=: intro n d) <$> p) diff --git a/src/Facet/TypeContext.hs b/src/Facet/TypeContext.hs index ac7e5a48c..07c9182ae 100644 --- a/src/Facet/TypeContext.hs +++ b/src/Facet/TypeContext.hs @@ -2,8 +2,11 @@ module Facet.TypeContext ( -- * Type contexts TypeContext(..) , empty +, (|>) +, lookupIndex ) where +import qualified Control.Effect.Empty as E import Facet.Functor.Synth import Facet.Kind import Facet.Name @@ -13,3 +16,14 @@ newtype TypeContext = TypeContext { getTypeContext :: S.Snoc (Name :==> Kind) } empty :: TypeContext empty = TypeContext S.Nil + +(|>) :: TypeContext -> Name :==> Kind -> TypeContext +TypeContext as |> a = TypeContext (as S.:> a) + +lookupIndex :: E.Has E.Empty sig m => Name -> TypeContext -> m (LName Index, Kind) +lookupIndex n = go (Index 0) . getTypeContext + where + go _ S.Nil = E.empty + go i (cs S.:> (n' :==> _K)) + | n == n' = pure (LName i n', _K) + | otherwise = go (succ i) cs From 465575db9d4f5f56fb8eea861b5464652bb66877 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 08:21:58 -0400 Subject: [PATCH 1153/1324] Fix an error for non-qualified names. --- src/Facet/Parser.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index 038c58d43..fd23be39b 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -236,7 +236,7 @@ clause = S.Clause <$> try (compPattern <* arrow) <*> expr "clause" evar :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Expr) evar = choice - [ token (anned (runUnspaced (S.Var <$> try ((|>) . fromList <$> many (comp <* dot) <*> ename)))) + [ token (anned (runUnspaced (S.Var <$> try (fromSnoc <$> ((:>) . fromList <$> many (comp <* dot) <*> ename))))) -- FIXME: would be better to commit once we see a placeholder, but try doesn’t really let us express that , try (anned (parens (S.Var <$> qname (N.O <$> oname)))) ] From 9c2f0b9c24c0f90b6a768b67cbcac8ad5b4fad1e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 11:07:01 -0400 Subject: [PATCH 1154/1324] Build first-order sequent terms. --- src/Facet/Elab/Sequent.hs | 48 ++++++++++++++++++--------------------- 1 file changed, 22 insertions(+), 26 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index cea584e37..8c9a5d64b 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -27,12 +27,10 @@ import Control.Effect.Throw import Data.Foldable (fold) import Data.Text (Text) import Data.Traversable (for) -import Facet.Context (level) import Facet.Effect.Write import Facet.Elab import qualified Facet.Elab.Type as Type import Facet.Functor.Check -import Facet.Functor.Compose import Facet.Functor.Synth import Facet.Graph import Facet.Kind @@ -42,7 +40,7 @@ import Facet.Name import Facet.Pattern import qualified Facet.Pattern.Column as Col import qualified Facet.Scope as Scope -import Facet.Sequent.Class as SQ +import Facet.Sequent.Expr as SQ import Facet.Snoc.NonEmpty import Facet.Subst import qualified Facet.Surface.Term.Expr as S @@ -57,20 +55,18 @@ import GHC.Stack (HasCallStack, callStack, popCallStack, withFrozenCal -- Variables -- FIXME: we’re instantiating when inspecting types in the REPL. -globalS :: (Has (State (Subst Type)) sig m, SQ.Term t c d, Applicative i) => QName ::: Type -> m (i t :==> Type) +globalS :: Has (State (Subst Type)) sig m => QName ::: Type -> m (SQ.Term :==> Type) globalS (q ::: _T) = do - v <- SQ.varA (Global q) + let v = SQ.Var (Global q) (\ (v ::: _T) -> v :==> _T) <$> instantiate const (v ::: _T) -- FIXME: do we need to instantiate here to deal with rank-n applications? -- FIXME: effect ops not in the sig are reported as not in scope -- FIXME: effect ops in the sig are available whether or not they’re in scope -varS :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, SQ.Term t c d, Applicative i) => QName -> m (i t :==> Type) +varS :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m) => QName -> m (SQ.Term :==> Type) varS n = views context_ (lookupInContext n) >>= \case - [(n', _T)] -> do - d <- views context_ level - SQ.varA (Free (toLeveled d (ident n'))) ==> pure _T - _ -> resolveDef n >>= \case + [(n', _T)] -> pure $ SQ.Var (Free (ident n')) :==> _T + _ -> resolveDef n >>= \case DTerm _ _T -> globalS (n ::: _T) _ -> freeVariable n @@ -81,25 +77,25 @@ hole n = Check $ \ _T -> withFrozenCallStack $ throwError $ Hole n _T -- Constructors lamS - :: (Has (Throw ErrReason) sig m, SQ.Term t c d, Applicative i) - => (forall j . Applicative j => (i ~> j) -> j t :==> Type -> j c :==> Type -> Type <==: m (j d)) - -> Type <==: m (i t) -lamS f = runC $ SQ.lamRA $ \ wk a k -> C $ Check $ \ _T -> do + :: Has (Throw ErrReason) sig m + => Type <==: m SQ.Command + -> Type <==: m SQ.Term +lamS b = Check $ \ _T -> do (_, _A, _B) <- assertTacitFunction _T - check (f wk (a :==> _A) (k :==> _B) ::: _B) + SQ.LamR <$> check (b ::: _B) -stringS :: (Applicative m, SQ.Term t c d, Applicative i) => Text -> m (i t :==> Type) -stringS s = SQ.stringRA s ==> pure T.String +stringS :: Applicative m => Text -> m (SQ.Term :==> Type) +stringS s = pure $ SQ.StringR s :==> T.String -- Eliminators -appS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m, SQ.Term t c d, SQ.Coterm t c d, SQ.Command t c d, Applicative i) => (HasCallStack => m (i t :==> Type)) -> (HasCallStack => Type <==: m (i t)) -> m (i t :==> Type) +appS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => (HasCallStack => m (SQ.Term :==> Type)) -> (HasCallStack => Type <==: m SQ.Term) -> m (SQ.Term :==> Type) appS f a = do f' :==> _F <- f (_, _A, _B) <- assertFunction _F a' <- check (a ::: _A) - (:==> _B) <$> SQ.µRA (\ wk k -> pure (wk f') SQ..||. SQ.lamLA (pure (wk a')) (pure k)) + pure $ SQ.MuR (f' SQ.:|: SQ.LamL a' (SQ.Covar (Free (Index 0)))) :==> _B -- General combinators @@ -118,7 +114,7 @@ as (m ::: _T) = do -- Elaboration -synthExprS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, SQ.Term t c d, SQ.Coterm t c d, SQ.Command t c d, Applicative i) => S.Ann S.Expr -> m (i t :==> Type) +synthExprS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m) => S.Ann S.Expr -> m (SQ.Term :==> Type) synthExprS = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \case S.Var n -> varS n S.App f a -> synthApp f a @@ -129,14 +125,14 @@ synthExprS = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \ca where nope = couldNotSynthesize -synthApp :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, SQ.Term t c d, SQ.Coterm t c d, SQ.Command t c d, Applicative i) => S.Ann S.Expr -> S.Ann S.Expr -> m (i t :==> Type) +synthApp :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Expr -> m (SQ.Term :==> Type) synthApp f a = appS (synthExprS f) (checkExprS a) -synthAs :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, SQ.Term t c d, SQ.Coterm t c d, SQ.Command t c d, Applicative i) => S.Ann S.Expr -> S.Ann S.Type -> m (i t :==> Type) +synthAs :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Type -> m (SQ.Term :==> Type) synthAs t _T = as (checkExprS t ::: do { _T :==> _K <- Type.synthType _T ; (:==> _K) <$> evalTExpr _T }) -checkExprS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m, SQ.Term t c d, SQ.Coterm t c d, SQ.Command t c d, Applicative i) => S.Ann S.Expr -> Type <==: m (i t) +checkExprS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m) => S.Ann S.Expr -> Type <==: m SQ.Term checkExprS expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC expr $ \case S.Hole n -> hole n S.Lam cs -> checkLamS (Check (\ _T -> map (\ (S.Clause (S.Ann _ _ p) b) -> Clause [pattern p] (check (checkExprS b ::: _T))) cs)) @@ -153,8 +149,8 @@ checkExprS expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC checkLamS :: Has (Throw ErrReason) sig m - => Type <==: [Clause (m (i t))] - -> Type <==: m (i t) + => Type <==: [Clause (m SQ.Term)] + -> Type <==: m SQ.Term checkLamS _ = Check (\ _T -> mismatchTypes (Exp (Left "unimplemented")) (Act _T)) @@ -186,7 +182,7 @@ partitionBy clauses ctors = fold <$> for clauses (\case -- | Expect a tacit (non-variable-binding) function type. assertTacitFunction :: Has (Throw ErrReason) sig m => Type -> m (Maybe Name, Type, Type) -assertTacitFunction = assertTypesMatch _Arrow "_ -> _" +assertTacitFunction = assertTypesMatch _Arrow "_ -> _" -- FIXME: this binds non-tacit functions -- Judgements From 316fde876236bea8537d01aefb2e702f9c87c535 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 11:19:13 -0400 Subject: [PATCH 1155/1324] :fire: the pattern elaboration contexts. --- src/Facet/Elab/Pattern.hs | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs index 9a701843c..0db6fb43b 100644 --- a/src/Facet/Elab/Pattern.hs +++ b/src/Facet/Elab/Pattern.hs @@ -36,21 +36,21 @@ instantiateHead (Var (Just _)) = Var Nothing -- FIXME: let-bind any variables fi instantiateHead p = p -compileClauses :: Has Empty sig m => [X.Term] -> Type -> [Clause X.Term] -> QuoterT m X.Term -compileClauses ctx (Arrow Nothing _A _T) heads = C.lamR (compileClausesBody ctx _A _T heads) -compileClauses _ _T heads +compileClauses :: Has Empty sig m => Type -> [Clause X.Term] -> QuoterT m X.Term +compileClauses (Arrow Nothing _A _T) heads = C.lamR (compileClausesBody _A _T heads) +compileClauses _T heads | Just (Clause [] b) <- preview folded heads = pure b | otherwise = empty -compileClausesBody :: Has Empty sig m => [X.Term] -> Type -> Type -> [Clause X.Term] -> QuoterT m X.Term -> QuoterT m X.Coterm -> QuoterT m X.Command -compileClausesBody ctx _A _T heads v k = case _A of - String -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) C..|. k - ForAll{} -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) C..|. k - Arrow{} -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses ctx _T) C..|. k +compileClausesBody :: Has Empty sig m => Type -> Type -> [Clause X.Term] -> QuoterT m X.Term -> QuoterT m X.Coterm -> QuoterT m X.Command +compileClausesBody _A _T heads v k = case _A of + String -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses _T) C..|. k + ForAll{} -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses _T) C..|. k + Arrow{} -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses _T) C..|. k _A :* _B -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Var._Nothing.to (const [Var Nothing, Var Nothing])))) heads >>= \ heads' -> C.let' (C.µR (\ k -> v C..|. C.prdL1 k)) (\ _ -> C.let' (C.µR (\ k -> v C..|. C.prdL2 k)) (\ _ -> - compileClauses ctx _T heads' C..|. k)) + compileClauses _T heads' C..|. k)) _A :+ _B -> do heads' <- fold <$> for heads (\case Clause (p:ps) b -> case instantiateHead p of @@ -60,8 +60,8 @@ compileClausesBody ctx _A _T heads v k = case _A of _ -> empty _ -> empty) v C..|. C.sumL - [ C.µL (\ v -> compileClausesBody ctx _A _T (fromJust (heads' ^? ix 0)) v k) - , C.µL (\ v -> compileClausesBody ctx _B _T (fromJust (heads' ^? ix 1)) v k) ] + [ C.µL (\ v -> compileClausesBody _A _T (fromJust (heads' ^? ix 0)) v k) + , C.µL (\ v -> compileClausesBody _B _T (fromJust (heads' ^? ix 1)) v k) ] match :: Has Empty sig m => Fold (Pattern Name) [Pattern Name] -> [Clause X.Term] -> m [Clause X.Term] From bcac6c795b5057bcceaebb76cdc6902bc2893e0c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 11:26:15 -0400 Subject: [PATCH 1156/1324] :fire: polarized syntax. --- facet.cabal | 1 - src/Facet/Polarized.hs | 198 ----------------------------------------- 2 files changed, 199 deletions(-) delete mode 100644 src/Facet/Polarized.hs diff --git a/facet.cabal b/facet.cabal index 1347f308e..39805f640 100644 --- a/facet.cabal +++ b/facet.cabal @@ -113,7 +113,6 @@ library Facet.Parser.Table Facet.Pattern Facet.Pattern.Column - Facet.Polarized Facet.Pretty Facet.Print Facet.Print.Options diff --git a/src/Facet/Polarized.hs b/src/Facet/Polarized.hs deleted file mode 100644 index 5a2681d87..000000000 --- a/src/Facet/Polarized.hs +++ /dev/null @@ -1,198 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE UndecidableInstances #-} -module Facet.Polarized -( Kind(..) -, Type(..) -, XType(..) -, Expr(..) -, Term(..) -, evalTerm -, Binding(..) -, fromV -, V(..) -, vvar -, velim -, K(..) -, Elab(..) -, Eval(..) -, Eval1(..) -, eval1 -) where - -import Control.Applicative (liftA2) -import Control.Carrier.Reader -import Data.Foldable (foldl') -import Data.Function (on) -import Facet.Name hiding (T) -import Facet.Quote -import Facet.Snoc - -data Kind - = Type - | Kind :=> Kind - deriving (Eq, Ord, Show) - -infixr 2 :=> - -data Type - = TVar Kind Level - -- negative - | Up Type - | Bot - | Type :-> Type - | ForAll Kind (Type -> Type) - -- positive - | Down Type - | One - | Type :>< Type - | Type :>- Type - deriving (Eq, Ord, Show) via Quoting XType Type - -infixr 2 :-> -infixr 7 :>< -infixl 2 :>- - -instance Quote Type XType where - quote = \case - TVar k d' -> Quoter (\ d -> XTVar k (toIndexed d d')) - Up t -> XUp <$> quote t - Bot -> pure XBot - a :-> b -> liftA2 (:->:) (quote a) (quote b) - ForAll k b -> XForAll k <$> quoteBinder (Quoter (TVar k)) b - Down t -> XDown <$> quote t - One -> pure XOne - a :>< b -> liftA2 (:><:) (quote a) (quote b) - b :>- a -> liftA2 (:>-:) (quote b) (quote a) - - -data XType - = XTVar Kind Index - -- negative - | XUp XType - | XBot - | XType :->: XType - | XForAll Kind XType - -- positive - | XDown XType - | XOne - | XType :><: XType - | XType :>-: XType - deriving (Eq, Ord, Show) - -infixr 2 :->: -infixr 7 :><: -infixl 2 :>-: - -instance Eval XType Type Type where - eval env = \case - XTVar _ i -> env ! getIndex i - XUp t -> Up (eval env t) - XBot -> Bot - a :->: b -> eval env a :-> eval env b - XForAll k b -> ForAll k (\ _A -> eval (env :> _A) b) - XDown t -> Down (eval env t) - XOne -> One - a :><: b -> eval env a :>< eval env b - b :>-: a -> eval env b :>- eval env a - - -data Expr - = XVar String - | XLam String Expr - | XApp Expr Expr - -data Term - = CVar Index - | CTLam Kind Term - | CLam Term - | CMu Term Coterm - deriving (Eq, Ord, Show) - -data Coterm - = CApp Term Coterm - | CInst Type Coterm - | CRet Index - deriving (Eq, Ord, Show) - -evalTerm :: Snoc Binding -> Snoc K -> Term -> V -evalTerm env kenv = \case - CVar i -> fromV (env ! getIndex i) - CTLam k b -> TLam k (\ _T -> evalTerm (env :> T _T) kenv b) - CLam b -> Lam (\ a -> evalTerm (env :> V a) kenv b) - CMu v k -> foldl' velim (evalTerm env kenv v) (evalCoterm env (kenv :> Ret (Level (length kenv))) k) - -evalCoterm :: Snoc Binding -> Snoc K -> Coterm -> [K] -evalCoterm env kenv = go - where - go = \case - CApp a k -> App (evalTerm env kenv a) : go k - CInst t k -> Inst t : go k - CRet i -> [Ret (toLeveled (Level (length kenv)) i)] - -data Binding - = V V - | T Type - -fromV :: Binding -> V -fromV = \case - V v -> v - T _ -> error "fromV: type binding" - - -data V - = Ne Level (Snoc K) - -- negative - | TLam Kind (Type -> V) - | Lam (V -> V) - -instance Eq V where - (==) = (==) `on` quoteV 0 0 - -instance Ord V where - compare = compare `on` quoteV 0 0 - -instance Show V where - showsPrec p = showsPrec p . quoteV 0 0 - -quoteV :: Level -> Level -> V -> Term -quoteV lv lk = \case - Ne l sp -> CMu (CVar (toIndexed lv l)) (foldr (\case - App v -> CApp (quoteV lv lk v) - Inst t -> CInst t - Ret i -> const (CRet (toIndexed lk i))) (CRet (Index 0)) sp) - TLam k f -> CTLam k (quoteV (succ lv) lk (f (TVar k lv))) - Lam f -> CLam (quoteV (succ lv) lk (f (vvar lv))) - - -vvar :: Level -> V -vvar l = Ne l Nil - -velim :: V -> K -> V -velim = curry $ \case - (Ne v sp, k) -> Ne v (sp :> k) - (Lam f, App a) -> f a - (Lam{}, k) -> error $ "cannot eliminate Lam with " <> show k - (TLam _ f, Inst t) -> f t - (TLam{}, k) -> error $ "cannot eliminate TLam with " <> show k - - -data K - = App V - | Inst Type - | Ret Level - deriving (Eq, Ord, Show) - - -newtype Elab a = Elab { elab :: [(String, Type)] -> Maybe a } - deriving (Functor) - deriving (Applicative) via ReaderC [(String, Type)] Maybe - - -class Eval t e v | t -> e v where - eval :: Snoc e -> t -> v - -class Eval1 t v | t -> v where - liftEvalWith :: (Snoc e -> s -> u) -> Snoc e -> t s -> v u - -eval1 :: (Eval s e u, Eval1 t v) => Snoc e -> t s -> v u -eval1 = liftEvalWith eval From cc08fadaa50657535caf4a1fcda6dc82100bb703 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 11:29:18 -0400 Subject: [PATCH 1157/1324] Add the type context to errors. --- src/Facet/Elab.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index b0840e88e..a9397e7ad 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -188,12 +188,13 @@ withSpan k (S.Ann s _ a) = pushSpan s (k a) data Err = Err - { source :: Source - , reason :: ErrReason - , context :: Context - , subst :: Subst Type - , sig :: [Signature Type] - , callStack :: CallStack + { source :: Source + , reason :: ErrReason + , context :: Context + , typeContext :: TypeContext.TypeContext + , subst :: Subst Type + , sig :: [Signature Type] + , callStack :: CallStack } -- FIXME: not all of these need contexts/metacontexts. @@ -282,9 +283,9 @@ instance (Has (Reader ElabContext) sig m, Has (Reader Source) sig m, Has (State alg hdl sig ctx = case sig of L (Throw reason) -> do source <- ask - ElabContext{ context, sig, spans } <- ask + ElabContext{ context, typeContext, sig, spans } <- ask subst <- get - throwError $ Err (maybe source (slice source) (peek spans)) (applySubst context subst reason) context subst sig GHC.Stack.callStack + throwError $ Err (maybe source (slice source) (peek spans)) (applySubst context subst reason) context typeContext subst sig GHC.Stack.callStack R other -> ErrC (alg (runErr . hdl) other ctx) From 6748bc1b14da86bef7348eea57674b4b89fa720d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 11:32:43 -0400 Subject: [PATCH 1158/1324] Print type contexts. --- src/Facet/Notice/Elab.hs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 9f4588cd5..4b37acad3 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -15,6 +15,7 @@ import Facet.Functor.Synth import Facet.Interface (interfaces) import Facet.Name import Facet.Notice as Notice hiding (level) +import Facet.Pattern import Facet.Pretty import Facet.Print as Print import Facet.Snoc @@ -22,6 +23,7 @@ import Facet.Style import Facet.Subst (metas) import Facet.Syntax hiding (ann) import Facet.Type.Norm (apply, free, metavar) +import Facet.TypeContext (getTypeContext) import GHC.Stack (prettyCallStack) import Prelude hiding (print, unlines) import Silkscreen @@ -31,21 +33,23 @@ import Silkscreen rethrowElabErrors :: Applicative m => Options Print -> L.ThrowC (Notice (Doc Style)) Err m a -> m a rethrowElabErrors opts = L.runThrow (pure . rethrow) where - rethrow Err{ callStack, context, reason, sig, subst } = Notice.Notice (Just Error) [] (printErrReason opts mempty reason) + rethrow Err{ callStack, context, typeContext, reason, sig, subst } = Notice.Notice (Just Error) [] (printErrReason opts mempty reason) [ nest 2 (pretty "Context" <\> concatWith (<\>) ctx) + , nest 2 (pretty "Type context" <\> concatWith (<\>) tyCtx) , nest 2 (pretty "Metacontext" <\> concatWith (<\>) subst') , nest 2 (pretty "Provided interfaces" <\> concatWith (<\>) sig') , pretty (prettyCallStack callStack) ] where (_, _, printCtx, ctx) = foldl' combine (0, Env.empty, Env.empty, Nil) (elems context) + (_, _, _, tyCtx) = foldl' combineTyCtx (0, Env.empty, Env.empty, Nil) (getTypeContext typeContext) subst' = map (\ (m :=: v) -> getPrint (Print.meta m <+> pretty '=' <+> maybe (pretty '?') (print opts printCtx) v)) (metas subst) sig' = getPrint . print opts printCtx . fmap (apply subst (toEnv context)) <$> (interfaces =<< sig) - -- combine (d, env, prints, ctx) (n :==> _K) = - -- ( succ d - -- , env Env.|> PVal (PVar (n :=: free (LName d n))) - -- , prints Env.|> PVal (PVar (n :=: intro n d)) - -- , ctx :> getPrint (print opts prints (ann (intro n d ::: print opts prints _K))) ) + combineTyCtx (d, env, prints, ctx) (n :==> _K) = + ( succ d + , env Env.|> PVal (PVar (n :=: free (LName d n))) + , prints Env.|> PVal (PVar (n :=: intro n d)) + , ctx :> getPrint (print opts prints (ann (intro n d ::: print opts prints _K))) ) combine (d, env, prints, ctx) p = ( succ d , env Env.|> ((\ (n :==> _T) -> n :=: free (LName d n)) <$> p) From 339b121f37aac86fe156c722c25e3159f7ca24c1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 24 Apr 2022 13:34:31 -0400 Subject: [PATCH 1159/1324] :fire: the HOAS sequent stuff. --- .ghci.repl | 2 +- facet.cabal | 4 - src/Facet/Elab/Pattern.hs | 70 ---------------- src/Facet/Sequent/Class.hs | 160 ------------------------------------- src/Facet/Sequent/Expr.hs | 99 +---------------------- src/Facet/Sequent/Norm.hs | 102 ----------------------- src/Facet/Sequent/Print.hs | 71 ---------------- 7 files changed, 4 insertions(+), 504 deletions(-) delete mode 100644 src/Facet/Elab/Pattern.hs delete mode 100644 src/Facet/Sequent/Class.hs delete mode 100644 src/Facet/Sequent/Norm.hs delete mode 100644 src/Facet/Sequent/Print.hs diff --git a/.ghci.repl b/.ghci.repl index b2dafd42a..44b777e11 100644 --- a/.ghci.repl +++ b/.ghci.repl @@ -39,7 +39,7 @@ :seti -Wno-type-defaults :set -Wno-unused-packages -:load Facet.CLI Facet.Elab.Pattern Facet.Elab.Sequent test/Test.hs +:load Facet.CLI Facet.Elab.Sequent test/Test.hs import Facet.Parser import Facet.Print diff --git a/facet.cabal b/facet.cabal index 39805f640..b15b4dd6d 100644 --- a/facet.cabal +++ b/facet.cabal @@ -88,7 +88,6 @@ library Facet.Effect.Time.System Facet.Effect.Write Facet.Elab - Facet.Elab.Pattern Facet.Elab.Sequent Facet.Elab.Term Facet.Elab.Type @@ -122,11 +121,8 @@ library Facet.Run Facet.Scope Facet.Semialign - Facet.Sequent.Class Facet.Sequent.Expr - Facet.Sequent.Norm Facet.Sequent.Pattern - Facet.Sequent.Print Facet.Sequent.Type Facet.Snoc Facet.Snoc.NonEmpty diff --git a/src/Facet/Elab/Pattern.hs b/src/Facet/Elab/Pattern.hs deleted file mode 100644 index 0db6fb43b..000000000 --- a/src/Facet/Elab/Pattern.hs +++ /dev/null @@ -1,70 +0,0 @@ -module Facet.Elab.Pattern -( Clause(..) -, patterns_ - -- * Coverage judgement -, compileClauses -) where - -import Control.Effect.Empty -import Data.Foldable (fold) -import Data.Maybe (fromJust) -import Data.Traversable (for) -import Facet.Name -import Facet.Pattern.Column -import Facet.Quote -import qualified Facet.Sequent.Class as C -import qualified Facet.Sequent.Expr as X -import Facet.Sequent.Pattern -import Facet.Sequent.Type -import Fresnel.Fold (Fold, Union(..), folded, preview, (^?)) -import Fresnel.Getter (to) -import Fresnel.Ixed -import Fresnel.Lens (Lens', lens) -import Fresnel.Maybe (_Nothing) -import Fresnel.Traversal (forOf, traversed) - -data Clause a = Clause { patterns :: [Pattern Name], body :: a } - -patterns_ :: Lens' (Clause a) [Pattern Name] -patterns_ = lens patterns (\ c patterns -> c{patterns}) - - --- Coverage judgement - -instantiateHead :: Pattern Name -> Pattern Name -instantiateHead (Var (Just _)) = Var Nothing -- FIXME: let-bind any variables first -instantiateHead p = p - - -compileClauses :: Has Empty sig m => Type -> [Clause X.Term] -> QuoterT m X.Term -compileClauses (Arrow Nothing _A _T) heads = C.lamR (compileClausesBody _A _T heads) -compileClauses _T heads - | Just (Clause [] b) <- preview folded heads = pure b - | otherwise = empty - -compileClausesBody :: Has Empty sig m => Type -> Type -> [Clause X.Term] -> QuoterT m X.Term -> QuoterT m X.Coterm -> QuoterT m X.Command -compileClausesBody _A _T heads v k = case _A of - String -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses _T) C..|. k - ForAll{} -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses _T) C..|. k - Arrow{} -> (match (_Var._Nothing.to (const [])) heads >>= compileClauses _T) C..|. k - _A :* _B -> match (getUnion (Union (_Pair.to (\ (p, q) -> [p, q])) <> Union (_Var._Nothing.to (const [Var Nothing, Var Nothing])))) heads >>= \ heads' -> - C.let' (C.µR (\ k -> v C..|. C.prdL1 k)) (\ _ -> - C.let' (C.µR (\ k -> v C..|. C.prdL2 k)) (\ _ -> - compileClauses _T heads' C..|. k)) - _A :+ _B -> do - heads' <- fold <$> for heads (\case - Clause (p:ps) b -> case instantiateHead p of - InL p -> pure (singleton 0 [Clause (p:ps) b]) - InR p -> pure (singleton 1 [Clause (p:ps) b]) - Var Nothing -> pure (fromList [[Clause (Var Nothing:ps) b], [Clause (Var Nothing:ps) b]]) - _ -> empty - _ -> empty) - v C..|. C.sumL - [ C.µL (\ v -> compileClausesBody _A _T (fromJust (heads' ^? ix 0)) v k) - , C.µL (\ v -> compileClausesBody _B _T (fromJust (heads' ^? ix 1)) v k) ] - - -match :: Has Empty sig m => Fold (Pattern Name) [Pattern Name] -> [Clause X.Term] -> m [Clause X.Term] -match o heads = forOf (traversed.patterns_) heads (\case - p:ps | Just prefix <- preview o (instantiateHead p) -> pure (prefix <> ps) - _ -> empty) diff --git a/src/Facet/Sequent/Class.hs b/src/Facet/Sequent/Class.hs deleted file mode 100644 index 94eedbd2b..000000000 --- a/src/Facet/Sequent/Class.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FunctionalDependencies #-} -module Facet.Sequent.Class -( -- * Sequent abstraction - Term(..) -, Coterm(..) -, Command(..) -, (.$.) - -- * Effectful abstractions -, varA -, µRA -, lamRA -, (.$$.) -, stringRA -, covarA -, µLA -, lamLA -, sumLA -, prdL1A -, prdL2A -, (.||.) -, letA -, Ctx(..) -, Binding(..) -, lookupCtx -) where - -import Control.Applicative (liftA2, (<|>)) -import Control.Monad (guard) -import Data.Text (Text) -import Facet.Functor.Compose as C -import Facet.Name (Level, Name) -import Facet.Syntax (Var, type (~>)) - --- * Term abstraction - -class Term term coterm command | coterm -> term command, term -> coterm command, command -> term coterm where - var :: Var Level -> term - µR :: (coterm -> command) -> term - lamR :: (term -> coterm -> command) -> term - sumR :: Int -> term -> term - bottomR :: command -> term - unitR :: term - prdR :: term -> term -> term - stringR :: Text -> term - -class Coterm term coterm command | coterm -> term command, term -> coterm command, command -> term coterm where - covar :: Var Level -> coterm - µL :: (term -> command) -> coterm - lamL :: term -> coterm -> coterm - sumL :: [coterm] -> coterm - unitL :: coterm - prdL1 :: coterm -> coterm - prdL2 :: coterm -> coterm - -class Command term coterm command | coterm -> term command, term -> coterm command, command -> term coterm where - (.|.) :: term -> coterm -> command - let' :: term -> (term -> command) -> command - - infix 1 .|. - -(.$.) :: Coterm term coterm command => term -> coterm -> coterm -(.$.) = lamL - -infixr 9 .$. - - --- * Effectful abstractions - -varA :: (Term t c d, Applicative i, Applicative m) => Var Level -> m (i t) -varA v = pure (pure (var v)) - -µRA - :: (Term t c d, Applicative i, Applicative m) - => (forall j . Applicative j => (i ~> j) -> j c -> m (j d)) - -> m (i t) -µRA = binder µR - -lamRA :: (Term t c d, Applicative i, Applicative m) => (forall j . Applicative j => (i ~> j) -> j t -> j c -> m (j d)) -> m (i t) -lamRA f = inner (\ wk v -> f wk (fst <$> v) (snd <$> v)) where - inner = binder (lamR . curry) - -stringRA :: (Term t c d, Applicative i, Applicative m) => Text -> m (i t) -stringRA = pure . pure . stringR - - -covarA :: (Coterm t c d, Applicative i, Applicative m) => Var Level -> m (i c) -covarA v = pure (pure (covar v)) - -µLA - :: (Coterm t c d, Applicative i, Applicative m) - => (forall j . Applicative j => (i ~> j) -> j t -> m (j d)) - -> m (i c) -µLA = binder µL - -lamLA - :: (Coterm t c d, Applicative i, Applicative m) - => m (i t) - -> m (i c) - -> m (i c) -lamLA = liftA2 (liftA2 lamL) - -(.$$.) - :: (Coterm t c d, Applicative i, Applicative m) - => m (i t) - -> m (i c) - -> m (i c) -(.$$.) = lamLA - -infixr 9 .$$. - -sumLA - :: (Coterm t c d, Applicative i, Applicative m) - => m (i [c]) - -> m (i c) -sumLA = fmap (fmap sumL) - --- sumLA --- :: (Coterm t c d, Applicative i, Applicative m) --- => [C.Clause m i t d] --- -> m (i c) --- sumLA cs = runC (sumL <$> traverse (\ (C.Clause c) -> C (binder id c)) cs) - -prdL1A - :: (Coterm t c d, Applicative i, Applicative m) - => m (i c) - -> m (i c) -prdL1A = fmap (fmap prdL1) - -prdL2A - :: (Coterm t c d, Applicative i, Applicative m) - => m (i c) - -> m (i c) -prdL2A = fmap (fmap prdL2) - - -(.||.) :: (Applicative m, Applicative i, Command t c d) => m (i t) -> m (i c) -> m (i d) -(.||.) = liftA2 (liftA2 (.|.)) - -infix 1 .||. - -letA :: (Applicative m, Applicative i, Command t c d) => m (i t) -> (forall j . Applicative j => (i ~> j) -> j t -> m (j d)) -> m (i d) -letA t b = liftA2 let' <$> t <*> (runC <$> b weaken (liftCInner id)) - - -data Ctx j t - = Nil - | forall i . Ctx i t :> Binding i j t - -infixl 5 :> - -data Binding i j t = Binding Name (i ~> j) (j t) - -lookupCtx :: Name -> Ctx i t -> Maybe (i t) -lookupCtx n = go id - where - go :: (i ~> j) -> Ctx i t -> Maybe (j t) - go wk = \case - Nil -> Nothing - c :> Binding n' wk' t -> wk t <$ guard (n == n') <|> go (wk . wk') c diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index c178dce20..ff95c55ad 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -5,18 +5,11 @@ module Facet.Sequent.Expr , Coterm(..) -- * Commands , Command(..) - -- * Interpretation -, interpretTerm -, interpretCoterm -, interpretCommand ) where -import Control.Applicative (liftA2) -import Data.Text (Text) -import Facet.Name -import Facet.Quote -import qualified Facet.Sequent.Class as C -import Facet.Syntax +import Data.Text (Text) +import Facet.Name +import Facet.Syntax -- Terms @@ -48,89 +41,3 @@ data Coterm data Command = Term :|: Coterm | Let Term Command - - -instance Applicative m => C.Term (QuoterT m Term) (QuoterT m Coterm) (QuoterT m Command) where - var inner = QuoterT (\ outer -> pure (Var (toIndexed outer inner))) - µR body = MuR <$> binderT (C.covar . Free) body - lamR body = LamR <$> binderT (C.var . Free) (binderT (C.covar . Free) . body) - sumR = fmap . SumR - bottomR = fmap BottomR - unitR = pure UnitR - prdR = liftA2 PrdR - stringR = pure . StringR - -instance Applicative m => C.Coterm (QuoterT m Term) (QuoterT m Coterm) (QuoterT m Command) where - covar inner = QuoterT (\ outer -> pure (Covar (toIndexed outer inner))) - µL body = MuL <$> binderT (C.var . Free) body - lamL = liftA2 LamL - sumL = fmap SumL . sequenceA - unitL = pure UnitL - prdL1 = fmap PrdL1 - prdL2 = fmap PrdL2 - -instance Applicative m => C.Command (QuoterT m Term) (QuoterT m Coterm) (QuoterT m Command) where - (.|.) = liftA2 (:|:) - let' t b = Let <$> t <*> binderT (C.var . Free) b - -instance C.Term (Quoter Term) (Quoter Coterm) (Quoter Command) where - var v = Quoter (\ d -> Var (toIndexed d v)) - µR b = MuR <$> binder (\ d' -> Quoter (\ d -> covar (toIndexed d d'))) b - lamR b = LamR <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) (binder (\ d'' -> Quoter (\ d -> covar (toIndexed d d''))) . b) - sumR = fmap . SumR - bottomR = fmap BottomR - unitR = pure UnitR - prdR = liftA2 PrdR - stringR = pure . StringR - -instance C.Coterm (Quoter Term) (Quoter Coterm) (Quoter Command) where - covar v = Quoter (\ d -> Covar (toIndexed d v)) - µL b = MuL <$> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b - lamL = liftA2 LamL - sumL = fmap SumL . sequenceA - unitL = pure UnitL - prdL1 = fmap PrdL1 - prdL2 = fmap PrdL2 - -instance C.Command (Quoter Term) (Quoter Coterm) (Quoter Command) where - (.|.) = liftA2 (:|:) - let' t b = Let <$> t <*> binder (\ d' -> Quoter (\ d -> var (toIndexed d d'))) b - -var :: Index -> Term -var = Var . Free - -covar :: Index -> Coterm -covar = Covar . Free - - --- Interpreters - -interpretTerm :: (C.Term t c d, C.Coterm t c d, C.Command t c d) => [t] -> [c] -> Term -> t -interpretTerm _G _D = \case - Var (Free n) -> _G `index` n - Var (Global n) -> C.var (Global n) - MuR b -> C.µR (\ k -> interpretCommand _G (k:_D) b) - LamR b -> C.lamR (\ a k -> interpretCommand (a:_G) (k:_D) b) - SumR i t -> C.sumR i (interpretTerm _G _D t) - BottomR c -> C.bottomR (interpretCommand _G _D c) - UnitR -> C.unitR - PrdR l r -> C.prdR (interpretTerm _G _D l) (interpretTerm _G _D r) - StringR s -> C.stringR s - -interpretCoterm :: (C.Term t c d, C.Coterm t c d, C.Command t c d) => [t] -> [c] -> Coterm -> c -interpretCoterm _G _D = \case - Covar (Free n) -> _D `index` n - Covar (Global n) -> C.covar (Global n) - MuL b -> C.µL (\ t -> interpretCommand (t:_G) _D b) - LamL a k -> C.lamL (interpretTerm _G _D a) (interpretCoterm _G _D k) - SumL cs -> C.sumL (interpretCoterm _G _D <$> cs) - UnitL -> C.unitL - PrdL1 c -> C.prdL1 (interpretCoterm _G _D c) - PrdL2 c -> C.prdL2 (interpretCoterm _G _D c) - -interpretCommand :: (C.Term t c d, C.Coterm t c d, C.Command t c d) => [t] -> [c] -> Command -> d -interpretCommand _G _D (t :|: c) = interpretTerm _G _D t C..|. interpretCoterm _G _D c -interpretCommand _G _D (Let t b) = C.let' (interpretTerm _G _D t) (\ t -> interpretCommand (t:_G) _D b) - -index :: [a] -> Index -> a -index as (Index i) = as !! i diff --git a/src/Facet/Sequent/Norm.hs b/src/Facet/Sequent/Norm.hs deleted file mode 100644 index f21c19d1d..000000000 --- a/src/Facet/Sequent/Norm.hs +++ /dev/null @@ -1,102 +0,0 @@ -module Facet.Sequent.Norm -( -- * Terms - Term(..) - -- * Coterms -, Coterm(..) - -- * Commands -, Command(..) -) where - -import Control.Applicative (liftA2) -import Data.Text (Text) -import Facet.Name -import Facet.Quote -import qualified Facet.Sequent.Class as Class -import qualified Facet.Sequent.Expr as X -import Facet.Syntax - --- Terms - -data Term - = Var (Var Level) - | MuR (Coterm -> Command) - | LamR (Term -> Coterm -> Command) - | SumR Int Term - | BottomR Command - | UnitR - | PrdR Term Term - | StringR Text - - --- Coterms - -data Coterm - = Covar (Var Level) - | MuL (Term -> Command) - | LamL Term Coterm - | SumL [Coterm] - | UnitL - | PrdL1 Coterm - | PrdL2 Coterm - - --- Commands - -data Command - = Term :|: Coterm - | Let Term (Term -> Command) - - -instance Class.Term Term Coterm Command where - var = Var - µR = MuR - lamR = LamR - sumR = SumR - bottomR = BottomR - unitR = UnitR - prdR = PrdR - stringR = StringR - -instance Class.Coterm Term Coterm Command where - covar = Covar - µL = MuL - lamL = LamL - sumL = SumL - unitL = UnitL - prdL1 = PrdL1 - prdL2 = PrdL2 - -instance Class.Command Term Coterm Command where - (.|.) = (:|:) - let' = Let - - -instance Quote Term X.Term where - quote = \case - Var v -> Quoter (\ d -> X.Var (toIndexed d v)) - MuR b -> X.MuR <$> quoteBinder (Quoter (Covar . Free)) b - LamR b -> X.LamR <$> Quoter (\ d -> runQuoter (d + 2) (quote (b (Var (Free d)) (Covar (Free (d + 1)))))) - SumR i t -> X.SumR i <$> quote t - BottomR c -> X.BottomR <$> quote c - UnitR -> pure X.UnitR - PrdR l r -> X.PrdR <$> quote l <*> quote r - StringR t -> pure (X.StringR t) - -var :: Level -> Term -var = Var . Free - - -instance Quote Coterm X.Coterm where - quote = \case - Covar v -> Quoter (\ d -> X.Covar (toIndexed d v)) - MuL b -> X.MuL <$> quoteBinder (Quoter var) b - LamL a b -> liftA2 X.LamL (quote a) (quote b) - SumL cs -> X.SumL <$> traverse quote cs - UnitL -> pure X.UnitL - PrdL1 k -> X.PrdL1 <$> quote k - PrdL2 k -> X.PrdL2 <$> quote k - - -instance Quote Command X.Command where - quote (t :|: c) = liftA2 (X.:|:) (quote t) (quote c) - quote (Let t b) = X.Let <$> quote t <*> quoteBinder (Quoter var) b diff --git a/src/Facet/Sequent/Print.hs b/src/Facet/Sequent/Print.hs deleted file mode 100644 index 9bb7036e2..000000000 --- a/src/Facet/Sequent/Print.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UndecidableInstances #-} -module Facet.Sequent.Print -( Print(..) -) where - -import Facet.Name -import Facet.Pretty -import Facet.Print.Options -import qualified Facet.Sequent.Class as S -import qualified Facet.Style as S -import Facet.Syntax -import qualified Prettyprinter as PP -import qualified Silkscreen as P -import qualified Silkscreen.Printer.Rainbow as P - -newtype Print = Print { doc :: Options Print -> Level -> P.Rainbow (PP.Doc S.Style) } - deriving (Monoid, P.Printer, Semigroup) - -getPrint :: Options Print -> Print -> PP.Doc S.Style -getPrint o p = P.runRainbow (P.annotate . S.Nest) 0 (doc (P.group p) o 0) - -instance Show Print where - showsPrec p = showsPrec p . getPrint quietOptions - - -instance S.Term Print Print Print where - var = var - µR b = P.pretty "µ" <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) - lamR c = P.pretty "λ" <> P.braces (fresh (\ u -> fresh (\ v -> anon u <> P.comma P.<+> anon v P.<+> P.pretty "." P.<+> c (anon u) (anon v)))) - sumR i t = P.parens (P.pretty "in" <> subscript i P.<+> t) - bottomR c = P.pretty "µ" <> P.braces (P.brackets mempty P.<+> P.dot P.<+> c) - unitR = P.parens mempty - prdR l r = P.tupled [l, r] - stringR = P.pretty . show - -instance S.Coterm Print Print Print where - covar = var - µL b = µ̃ <> P.braces (fresh (\ v -> anon v P.<+> P.dot P.<+> b (anon v))) - lamL a k = a P.<+> P.dot P.<+> k - sumL cs = P.pretty "case" <> P.braces (commaSep (map (\ (i, c) -> P.pretty "in" <> subscript i P.<+> P.pretty "->" P.<+> c) (zip [0..] cs))) - unitL = P.pretty "_" - prdL1 k = P.parens (µ̃ <> P.braces (P.pretty "πl" P.<+> k)) - prdL2 k = P.parens (µ̃ <> P.braces (P.pretty "πr" P.<+> k)) - -instance S.Command Print Print Print where - (.|.) = fmap (P.enclose P.langle P.rangle) . P.surround P.pipe - let' v b = P.pretty "let" P.<+> withLevel anon P.<+> P.pretty '=' P.<+> v P.<+> P.pretty "in" P.<+> fresh (b . anon) - -withLevel :: (Level -> Print) -> Print -withLevel f = Print (\ o d -> doc (f d) o d) - -incrLevel :: Print -> Print -incrLevel p = Print (\ o -> doc p o . succ) - -fresh :: (Level -> Print) -> Print -fresh f = withLevel (incrLevel . f) - -anon :: Level -> Print -anon = lower . getLevel - -var :: Var Level -> Print -var v = case v of - Free l -> lower (getLevel l) - Global n -> prettyQName n - -commaSep :: [Print] -> Print -commaSep = P.encloseSep mempty mempty (P.comma <> P.space) - -µ̃ :: Print -µ̃ = P.pretty "µ̃" From a198ff0124a873c9add538168d7bac9f78508810 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 08:34:05 -0400 Subject: [PATCH 1160/1324] Represent Context with Env. --- src/Facet/Context.hs | 31 +++++++++++++++++-------------- src/Facet/Notice/Elab.hs | 8 ++++---- 2 files changed, 21 insertions(+), 18 deletions(-) diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index b633e8dd9..1accb2b9b 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -11,7 +11,7 @@ module Facet.Context ) where import qualified Control.Effect.Empty as E -import Data.Foldable (find, toList) +import Data.Foldable (find) import qualified Facet.Env as Env import Facet.Functor.Synth import Facet.Name @@ -22,14 +22,14 @@ import Facet.Type.Norm import GHC.Stack import Prelude hiding (lookup) -newtype Context = Context { elems :: S.Snoc (Pattern (Name :==> Type)) } +newtype Context = Context { elems :: Env.Env Type } empty :: Context -empty = Context S.Nil +empty = Context Env.empty (|>) :: Context -> Pattern (Name :==> Type) -> Context -Context as |> a = Context (as S.:> a) +Context as |> a = Context (as Env.|> fmap toEquation a) infixl 5 |> @@ -37,25 +37,28 @@ level :: Context -> Level level (Context es) = Level (length es) (!) :: HasCallStack => Context -> Index -> Pattern (Name :==> Type) -Context es' ! Index i' = withFrozenCallStack $ go es' i' +Context (Env.Env es') ! Index i' = withFrozenCallStack $ go es' i' where go (es S.:> e) i - | i == 0 = e + | i == 0 = fromEquation <$> e | otherwise = go es (i - 1) go _ _ = error $ "Facet.Context.!: index (" <> show i' <> ") out of bounds (" <> show (length es') <> ")" lookupIndex :: E.Has E.Empty sig m => Name -> Context -> m (LName Index, Type) -lookupIndex n = go (Index 0) . elems +lookupIndex n = go (Index 0) . Env.bindings . elems where go _ S.Nil = E.empty - go i (cs S.:> p) = case find ((== n) . proof) p of - Just (n' :==> t) -> pure (LName i n', t) - _ -> go (succ i) cs + go i (cs S.:> p) = case find (\ (n' :=: _) -> n' == n) p of + Just (n' :=: t) -> pure (LName i n', t) + _ -> go (succ i) cs toEnv :: Context -> Env.Env Type -toEnv c = Env.Env (S.fromList (zipWith toType (toList (elems c)) [0..pred (level c)])) - where - toType p d = (\ b -> proof b :=: bind d (proof b)) <$> p +toEnv = elems + + +toEquation :: a :==> b -> a :=: b +toEquation (a :==> b) = a :=: b - bind d b = free (LName d b) +fromEquation :: a :=: b -> a :==> b +fromEquation (a :=: b) = a :==> b diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 4b37acad3..c342a9c21 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -41,7 +41,7 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) , pretty (prettyCallStack callStack) ] where - (_, _, printCtx, ctx) = foldl' combine (0, Env.empty, Env.empty, Nil) (elems context) + (_, _, printCtx, ctx) = foldl' combine (0, Env.empty, Env.empty, Nil) (Env.bindings (elems context)) (_, _, _, tyCtx) = foldl' combineTyCtx (0, Env.empty, Env.empty, Nil) (getTypeContext typeContext) subst' = map (\ (m :=: v) -> getPrint (Print.meta m <+> pretty '=' <+> maybe (pretty '?') (print opts printCtx) v)) (metas subst) sig' = getPrint . print opts printCtx . fmap (apply subst (toEnv context)) <$> (interfaces =<< sig) @@ -52,9 +52,9 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) , ctx :> getPrint (print opts prints (ann (intro n d ::: print opts prints _K))) ) combine (d, env, prints, ctx) p = ( succ d - , env Env.|> ((\ (n :==> _T) -> n :=: free (LName d n)) <$> p) - , prints Env.|> ((\ (n :==> _) -> n :=: intro n d) <$> p) - , ctx :> getPrint (print opts prints ((\ (n :==> _T) -> ann (intro n d ::: print opts prints (apply subst env _T))) <$> p)) ) + , env Env.|> ((\ (n :=: _T) -> n :=: free (LName d n)) <$> p) + , prints Env.|> ((\ (n :=: _) -> n :=: intro n d) <$> p) + , ctx :> getPrint (print opts prints ((\ (n :=: _T) -> ann (intro n d ::: print opts prints (apply subst env _T))) <$> p)) ) printErrReason :: Options Print -> Env.Env Print -> ErrReason -> Doc Style From d4cbcf423cc2124946fb238e846327952a061548 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 11:02:57 -0400 Subject: [PATCH 1161/1324] Spacing. --- src/Facet/Pattern.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Pattern.hs b/src/Facet/Pattern.hs index c370630bb..c3141b04e 100644 --- a/src/Facet/Pattern.hs +++ b/src/Facet/Pattern.hs @@ -50,5 +50,6 @@ _PCon = _PVal.prism' (uncurry PCon) (\case data EffPattern a = POp QName [ValPattern a] (ValPattern a) deriving (Eq, Foldable, Functor, Ord, Show, Traversable) + fill :: Traversable t => (b -> (b, c)) -> b -> t a -> (b, t c) fill f = mapAccumL (const . f) From 0e67cfdbd77afe1c3e518cdaa7a08113cd7f5804 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 11:03:04 -0400 Subject: [PATCH 1162/1324] :memo: fill. --- src/Facet/Pattern.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Pattern.hs b/src/Facet/Pattern.hs index c3141b04e..7fa0df93e 100644 --- a/src/Facet/Pattern.hs +++ b/src/Facet/Pattern.hs @@ -51,5 +51,6 @@ data EffPattern a = POp QName [ValPattern a] (ValPattern a) deriving (Eq, Foldable, Functor, Ord, Show, Traversable) +-- | Fill a container with values computed sequentially from left to right. fill :: Traversable t => (b -> (b, c)) -> b -> t a -> (b, t c) fill f = mapAccumL (const . f) From ebe396f34ec4de10ce2b1da5bf0891b61ec86d23 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 11:03:53 -0400 Subject: [PATCH 1163/1324] Define a function to map & accumulate by iterating levels. --- src/Facet/Pattern.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Pattern.hs b/src/Facet/Pattern.hs index 7fa0df93e..f3b528d8a 100644 --- a/src/Facet/Pattern.hs +++ b/src/Facet/Pattern.hs @@ -7,6 +7,7 @@ module Facet.Pattern , _PCon , EffPattern(..) , fill +, mapAccumLevels ) where import Data.Traversable (mapAccumL) @@ -54,3 +55,6 @@ data EffPattern a = POp QName [ValPattern a] (ValPattern a) -- | Fill a container with values computed sequentially from left to right. fill :: Traversable t => (b -> (b, c)) -> b -> t a -> (b, t c) fill f = mapAccumL (const . f) + +mapAccumLevels :: Traversable t => (Level -> a -> b) -> Level -> (t a -> (Level, t b)) +mapAccumLevels f = mapAccumL (\ d a -> (succ d, f d a)) From 18a41a183f7693593db155b88657d90514201c64 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 11:05:47 -0400 Subject: [PATCH 1164/1324] Map accum from levels. --- src/Facet/Print.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 8506c62f9..367439d07 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -28,7 +28,6 @@ module Facet.Print import Data.Foldable (foldl') import Data.Maybe (fromMaybe) import qualified Data.Text as T -import Data.Traversable (mapAccumL) import Facet.Env as Env import Facet.Interface import Facet.Kind @@ -197,13 +196,13 @@ instance Printable C.Term where C.App f a -> go env f $$ go env a C.Con n p -> qvar n $$* (group . go env <$> p) C.String s -> annotate Lit $ pretty (show s) - C.Let p v b -> let p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) in pretty "let" <+> braces (print opts env (view def_ <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p') b + C.Let p v b -> let p' = snd (mapAccumLevels (\ d n -> n :=: local n d) (level env) p) in pretty "let" <+> braces (print opts env (view def_ <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p') b where d = level env qvar = group . setPrec Var . qname clause env (p, b) = print opts env (view def_ <$> p') <+> arrow <+> go (env |> p') b where - p' = snd (mapAccumL (\ d n -> (succ d, n :=: local n d)) (level env) p) + p' = snd (mapAccumLevels (\ d n -> n :=: local n d) (level env) p) deriving via (Quoting C.Term N.Term) instance Printable N.Term From d50d66275e51f962004058608d7075553b5637e2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 11:06:35 -0400 Subject: [PATCH 1165/1324] Map accum from levels. --- src/Facet/Term/Norm.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Facet/Term/Norm.hs b/src/Facet/Term/Norm.hs index 9f9e438d3..a0ff0ae1e 100644 --- a/src/Facet/Term/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -8,7 +8,6 @@ import Data.Foldable (foldl') import Data.Maybe (fromMaybe) import Data.Monoid import Data.Text (Text) -import Data.Traversable (mapAccumL) import Facet.Env import Facet.Name import Facet.Pattern @@ -33,7 +32,7 @@ instance Quote Term X.Term where Ne v sp -> foldl' (\ h t -> X.App <$> h <*> quote t) (Quoter (\ d -> X.Var (toIndexed d v))) sp where clause :: Traversable t => t Name -> (t (Name :=: Term) -> Term) -> Quoter (t Name, X.Term) - clause p b = Quoter (\ d -> let (d', p') = mapAccumL (\ d n -> (succ d, n :=: Ne (Free (LName d n)) Nil)) d p in (p, runQuoter d' (quote (b p')))) + clause p b = Quoter (\ d -> let (d', p') = mapAccumLevels (\ d n -> n :=: Ne (Free (LName d n)) Nil) d p in (p, runQuoter d' (quote (b p')))) norm :: Env Term -> X.Term -> Term norm env = \case From 4654462f6c00aa964d05eab8a9fcebffd0e42e21 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 14:41:59 -0400 Subject: [PATCH 1166/1324] Define scopes for commands. --- src/Facet/Sequent/Expr.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index ff95c55ad..80c979208 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -5,6 +5,8 @@ module Facet.Sequent.Expr , Coterm(..) -- * Commands , Command(..) + -- * Scopes +, Scope(..) ) where import Data.Text (Text) @@ -41,3 +43,8 @@ data Coterm data Command = Term :|: Coterm | Let Term Command + + +-- Scopes + +newtype Scope = Scope Command From ccb66098a4aeef328961dcd14e9dd10f1ff628df Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 14:45:02 -0400 Subject: [PATCH 1167/1324] Rename Scope to ScopeLR. This accommodates both contexts. --- src/Facet/Sequent/Expr.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 80c979208..642c1b49e 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -6,7 +6,7 @@ module Facet.Sequent.Expr -- * Commands , Command(..) -- * Scopes -, Scope(..) +, ScopeLR(..) ) where import Data.Text (Text) @@ -47,4 +47,4 @@ data Command -- Scopes -newtype Scope = Scope Command +newtype ScopeLR = ScopeLR Command From c034e7f313edeef9983a921a2f253aa4fd9972f7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 14:45:22 -0400 Subject: [PATCH 1168/1324] Define an eliminator for ScopeLR. --- src/Facet/Sequent/Expr.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 642c1b49e..c1a1761e9 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -47,4 +47,4 @@ data Command -- Scopes -newtype ScopeLR = ScopeLR Command +newtype ScopeLR = ScopeLR { getScopeLR :: Command } From c66755c304e482391f930f542e59d704cf0025dd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 14:45:39 -0400 Subject: [PATCH 1169/1324] Only export ScopeLR-the-type. --- src/Facet/Sequent/Expr.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index c1a1761e9..5bab0979e 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -6,7 +6,7 @@ module Facet.Sequent.Expr -- * Commands , Command(..) -- * Scopes -, ScopeLR(..) +, ScopeLR ) where import Data.Text (Text) From f10a38ceac8d4f00ed46ea987c628468a67446cf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 14:47:51 -0400 Subject: [PATCH 1170/1324] Define a class for binding in the left context. --- src/Facet/Sequent/Expr.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 5bab0979e..48c5fa0d3 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -7,6 +7,7 @@ module Facet.Sequent.Expr , Command(..) -- * Scopes , ScopeLR +, BinderL(..) ) where import Data.Text (Text) @@ -48,3 +49,7 @@ data Command -- Scopes newtype ScopeLR = ScopeLR { getScopeLR :: Command } + +class BinderL scope where + abstractL :: Name -> Command -> scope + instantiateL :: Command -> scope -> Command From 2784f8a36b0f409db1bc2d76bb00d889feda75ee Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 14:48:38 -0400 Subject: [PATCH 1171/1324] Define a class for binding in the right context. --- src/Facet/Sequent/Expr.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 48c5fa0d3..8b325cd33 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -8,6 +8,7 @@ module Facet.Sequent.Expr -- * Scopes , ScopeLR , BinderL(..) +, BinderR(..) ) where import Data.Text (Text) @@ -53,3 +54,7 @@ newtype ScopeLR = ScopeLR { getScopeLR :: Command } class BinderL scope where abstractL :: Name -> Command -> scope instantiateL :: Command -> scope -> Command + +class BinderR scope where + abstractR :: Name -> Command -> scope + instantiateR :: Command -> scope -> Command From 86631c655f7dc5a996e10ce36926958d3a3a43c5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 19:25:47 -0400 Subject: [PATCH 1172/1324] Avoid using LNames in types. --- src/Facet/Elab.hs | 19 +++++++++---------- src/Facet/Elab/Term.hs | 4 ++-- src/Facet/Notice/Elab.hs | 15 +++++++-------- src/Facet/Print.hs | 2 +- src/Facet/Type/Class.hs | 6 +++--- src/Facet/Type/Expr.hs | 8 ++------ src/Facet/Type/Norm.hs | 30 ++++++++++++++---------------- src/Facet/TypeContext.hs | 4 ++-- src/Facet/Unify.hs | 2 +- test/Facet/Core/Type/Test.hs | 6 +++--- 10 files changed, 44 insertions(+), 52 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index a9397e7ad..f1439939c 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -66,7 +66,6 @@ import Control.Effect.Choose import Facet.Context hiding (empty) import qualified Facet.Context as Context (empty) import Facet.Effect.Write -import qualified Facet.Env as Env import Facet.Functor.Check import Facet.Functor.Synth import Facet.Graph as Graph @@ -139,7 +138,7 @@ lookupInContext (m:|>n) | m == Nil = lookupIndex n | otherwise = const empty -lookupInTypeContext :: Has (Choose :+: Empty) sig m => QName -> TypeContext.TypeContext -> m (LName Index, Kind) +lookupInTypeContext :: Has (Choose :+: Empty) sig m => QName -> TypeContext.TypeContext -> m (Index, Kind) lookupInTypeContext (m:|>n) | m == Nil = TypeContext.lookupIndex n | otherwise = const empty @@ -168,7 +167,7 @@ infix 1 ||- evalTExpr :: Has (Reader ElabContext :+: State (Subst Type)) sig m => TX.Type -> m Type -evalTExpr texpr = TN.eval <$> get <*> views context_ toEnv <*> pure texpr +evalTExpr texpr = TN.eval <$> get <*> pure Nil <*> pure texpr depth :: Has (Reader ElabContext) sig m => m Level depth = views context_ level @@ -238,8 +237,8 @@ _Occurs = prism' (uncurry Occurs) (\case Occurs v c -> Just (v, c) _ -> Nothing) -applySubst :: Context -> Subst Type -> ErrReason -> ErrReason -applySubst ctx subst r = case r of +applySubst :: Subst Type -> ErrReason -> ErrReason +applySubst subst r = case r of FreeVariable{} -> r AmbiguousName{} -> r CouldNotSynthesize{} -> r @@ -250,7 +249,7 @@ applySubst ctx subst r = case r of Invariant{} -> r MissingInterface i -> MissingInterface (roundtrip <$> i) where - roundtrip = apply subst (toEnv ctx) + roundtrip = apply subst Nil mismatchTypes :: Has (Throw ErrReason) sig m => Exp (Either String Type) -> Act Type -> m a @@ -285,7 +284,7 @@ instance (Has (Reader ElabContext) sig m, Has (Reader Source) sig m, Has (State source <- ask ElabContext{ context, typeContext, sig, spans } <- ask subst <- get - throwError $ Err (maybe source (slice source) (peek spans)) (applySubst context subst reason) context typeContext subst sig GHC.Stack.callStack + throwError $ Err (maybe source (slice source) (peek spans)) (applySubst subst reason) context typeContext subst sig GHC.Stack.callStack R other -> ErrC (alg (runErr . hdl) other ctx) @@ -353,13 +352,13 @@ elabKind :: Applicative m => ReaderC ElabContext (StateC (Subst Type) m) Kind -> elabKind = elabWith (const pure) elabType :: (HasCallStack, Applicative m) => ReaderC ElabContext (StateC (Subst Type) m) TX.Type -> m Type -elabType = elabWith (\ subst t -> pure (TN.eval subst Env.empty t)) +elabType = elabWith (\ subst t -> pure (TN.eval subst Nil t)) elabTerm :: Applicative m => ReaderC ElabContext (StateC (Subst Type) m) Term -> m Term elabTerm = elabWith (const pure) elabSynthTerm :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => ReaderC ElabContext (StateC (Subst Type) m) (Term :==> Type) -> m (Term :==> Type) -elabSynthTerm = elabWith (\ subst (e :==> _T) -> pure (e :==> TN.eval subst Env.empty (runQuoter 0 (quote _T)))) +elabSynthTerm = elabWith (\ subst (e :==> _T) -> pure (e :==> TN.eval subst Nil (runQuoter 0 (quote _T)))) elabSynthType :: (HasCallStack, Has (Reader Graph :+: Reader Module :+: Reader Source) sig m) => ReaderC ElabContext (StateC (Subst Type) m) (TX.Type :==> Kind) -> m (Type :==> Kind) -elabSynthType = elabWith (\ subst (_T :==> _K) -> pure (TN.eval subst Env.empty _T :==> _K)) +elabSynthType = elabWith (\ subst (_T :==> _K) -> pure (TN.eval subst Nil _T :==> _K)) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index c57ebe6fa..cf8ee8aa2 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -126,7 +126,7 @@ tlam :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => Type <= tlam b = Check $ \ _T -> do (n, _A, _B) <- assertQuantifier _T d <- depth - n :==> _A ||- check (b ::: _B (T.free (LName d n))) + n :==> _A ||- check (b ::: _B (T.free d)) lam :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => [(Bind m (Pattern (Name :==> Type)), Type <==: m Term)] -> Type <==: m Term lam cs = Check $ \ _T -> do @@ -250,7 +250,7 @@ abstractTerm body = go Nil Nil go ts fs = Check $ \case T.ForAll n _T _B -> do d <- depth - check (tlam (go (ts :> LName d n) fs) ::: T.ForAll n _T _B) + check (tlam (go (ts :> d) fs) ::: T.ForAll n _T _B) T.Arrow n _A _B -> do d <- depth check (lam [(patternForArgType _A (fromMaybe __ n), go ts (fs :> \ d' -> Var (Free (LName (toIndexed d' d) (fromMaybe __ n)))))] ::: T.Arrow n _A _B) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index c342a9c21..5bbed216a 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -8,7 +8,7 @@ import Data.Foldable (foldl') import Data.Semigroup (stimes) import qualified Facet.Carrier.Throw.Inject as L import qualified Facet.Carrier.Write.Inject as L -import Facet.Context (elems, toEnv) +import Facet.Context (elems) import Facet.Elab as Elab import qualified Facet.Env as Env import Facet.Functor.Synth @@ -41,20 +41,19 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) , pretty (prettyCallStack callStack) ] where - (_, _, printCtx, ctx) = foldl' combine (0, Env.empty, Env.empty, Nil) (Env.bindings (elems context)) - (_, _, _, tyCtx) = foldl' combineTyCtx (0, Env.empty, Env.empty, Nil) (getTypeContext typeContext) + (_, printCtx, ctx) = foldl' combine (0, Env.empty, Nil) (Env.bindings (elems context)) + (_, _, _, tyCtx) = foldl' combineTyCtx (0, Nil, Env.empty, Nil) (getTypeContext typeContext) subst' = map (\ (m :=: v) -> getPrint (Print.meta m <+> pretty '=' <+> maybe (pretty '?') (print opts printCtx) v)) (metas subst) - sig' = getPrint . print opts printCtx . fmap (apply subst (toEnv context)) <$> (interfaces =<< sig) + sig' = getPrint . print opts printCtx . fmap (apply subst Nil) <$> (interfaces =<< sig) combineTyCtx (d, env, prints, ctx) (n :==> _K) = ( succ d - , env Env.|> PVal (PVar (n :=: free (LName d n))) + , env :> (n :=: free d) , prints Env.|> PVal (PVar (n :=: intro n d)) , ctx :> getPrint (print opts prints (ann (intro n d ::: print opts prints _K))) ) - combine (d, env, prints, ctx) p = + combine (d, prints, ctx) p = ( succ d - , env Env.|> ((\ (n :=: _T) -> n :=: free (LName d n)) <$> p) , prints Env.|> ((\ (n :=: _) -> n :=: intro n d) <$> p) - , ctx :> getPrint (print opts prints ((\ (n :=: _T) -> ann (intro n d ::: print opts prints (apply subst env _T))) <$> p)) ) + , ctx :> getPrint (print opts prints ((\ (n :=: _T) -> ann (intro n d ::: print opts prints (apply subst Nil _T))) <$> p)) ) printErrReason :: Options Print -> Env.Env Print -> ErrReason -> Doc Style diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 367439d07..c77bde5dc 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -170,7 +170,7 @@ instance Printable TX.Type where qvar = group . setPrec Var . qname go env = \case TX.Var (Global n) -> qvar n - TX.Var (Free (Right n)) -> fromMaybe (lname (toLeveled d n)) $ Env.lookup env n + TX.Var (Free (Right n)) -> fromMaybe (intro __ (toLeveled d n)) $ Env.lookup env (LName n __) TX.Var (Free (Left m)) -> meta m TX.ForAll n t b -> braces (ann (intro n d ::: print opts env t)) --> go (env |> PVal (PVar (n :=: intro n d))) b TX.Arrow Nothing a b -> go env a --> go env b diff --git a/src/Facet/Type/Class.hs b/src/Facet/Type/Class.hs index 61e6ccdd4..195616ae1 100644 --- a/src/Facet/Type/Class.hs +++ b/src/Facet/Type/Class.hs @@ -8,7 +8,7 @@ import Data.Foldable (foldl') import Facet.Functor.Compose import Facet.Interface (Signature) import Facet.Kind (Kind) -import Facet.Name (LName, Level, Meta, Name) +import Facet.Name (Level, Meta, Name) import Facet.Syntax (Var, type (~>)) -- Types @@ -17,10 +17,10 @@ class Type r where string :: r forAll :: Name -> Kind -> (r -> r) -> r arrow :: Maybe Name -> r -> r -> r - var :: Var (Either Meta (LName Level)) -> r + var :: Var (Either Meta Level) -> r ($$) :: r -> r -> r infixl 9 $$ - ($$$) :: Foldable t => Var (Either Meta (LName Level)) -> t r -> r + ($$$) :: Foldable t => Var (Either Meta Level) -> t r -> r h $$$ sp = foldl' ($$) (var h) sp infixl 9 $$$ (|-) :: Signature r -> r -> r diff --git a/src/Facet/Type/Expr.hs b/src/Facet/Type/Expr.hs index 20e3ffb75..ff62f9a59 100644 --- a/src/Facet/Type/Expr.hs +++ b/src/Facet/Type/Expr.hs @@ -12,7 +12,7 @@ import qualified Facet.Type.Class as C data Type = String - | Var (Var (Either Meta (LName Index))) + | Var (Var (Either Meta Index)) | ForAll Name Kind Type | Arrow (Maybe Name) Type Type | Comp (Signature Type) Type @@ -21,12 +21,8 @@ data Type instance C.Type (Quoter Type) where string = pure String - forAll n k b = ForAll n k <$> binder (\ d' -> Quoter (\ d -> lvar n (toIndexed d d'))) b + forAll n k b = ForAll n k <$> binder (\ d' -> Quoter (\ d -> Var (Free (Right (toIndexed d d'))))) b arrow n = liftA2 (Arrow n) var v = Quoter (\ d -> Var (toIndexed d v)) ($$) = liftA2 App sig |- t = Comp <$> sequenceSignature sig <*> t - - -lvar :: Name -> Index -> Type -lvar n i = Var (Free (Right (LName i n))) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index d508ba5e2..cc9d8b43d 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -23,19 +23,17 @@ module Facet.Type.Norm import Control.Effect.Empty import Data.Foldable (foldl') import Data.Maybe (fromMaybe) -import Facet.Env hiding (empty) import Facet.Interface import Facet.Kind import Facet.Name -import Facet.Pattern import Facet.Quote import Facet.Snoc import Facet.Subst import Facet.Syntax import qualified Facet.Type.Class as C import qualified Facet.Type.Expr as TX +import Fresnel.Getter ((^.)) import Fresnel.Prism (Prism', prism') -import Fresnel.Review (review) import GHC.Stack import Prelude hiding (lookup) @@ -45,7 +43,7 @@ data Type = String | ForAll Name Kind (Type -> Type) | Arrow (Maybe Name) Type Type - | Ne (Var (Either Meta (LName Level))) (Snoc Type) + | Ne (Var (Either Meta Level)) (Snoc Type) | Comp (Signature Type) Type deriving (Eq, Ord, Show) via Quoting TX.Type Type @@ -61,7 +59,7 @@ instance C.Type Type where instance Quote Type TX.Type where quote = \case String -> pure TX.String - ForAll n t b -> Quoter (\ d -> TX.ForAll n t (runQuoter (succ d) (quote (b (free (LName d n)))))) + ForAll n t b -> Quoter (\ d -> TX.ForAll n t (runQuoter (succ d) (quote (b (free d))))) Arrow n a b -> TX.Arrow n <$> quote a <*> quote b Comp s t -> TX.Comp <$> traverseSignature quote s <*> quote t Ne n sp -> foldl' (\ h t -> TX.App <$> h <*> quote t) (Quoter (\ d -> TX.Var (toIndexed d n))) sp @@ -76,7 +74,7 @@ _ForAll = prism' (\ (n, k, b) -> ForAll n k b) (\case{ ForAll n k b -> Just (n, _Arrow :: Prism' Type (Maybe Name, Type, Type) _Arrow = prism' (\ (n, a, b) -> Arrow n a b) (\case{ Arrow n a b -> Just (n, a, b) ; _ -> Nothing }) -_Ne :: Prism' Type (Var (Either Meta (LName Level)), Snoc Type) +_Ne :: Prism' Type (Var (Either Meta Level), Snoc Type) _Ne = prism' (uncurry Ne) (\case{ Ne c ts -> Just (c, ts) ; _ -> Nothing }) _Comp :: Prism' Type (Signature Type, Type) @@ -86,18 +84,18 @@ _Comp = prism' (uncurry Comp) (\case{ Comp sig t -> Just (sig, t) ; _ -> Nothing global :: QName -> Type global = var . Global -free :: LName Level -> Type +free :: Level -> Type free = var . Free . Right metavar :: Meta -> Type metavar = var . Free . Left -var :: Var (Either Meta (LName Level)) -> Type +var :: Var (Either Meta Level) -> Type var v = Ne v Nil -unNeutral :: Has Empty sig m => Type -> m (Var (Either Meta (LName Level)), Snoc Type) +unNeutral :: Has Empty sig m => Type -> m (Var (Either Meta Level), Snoc Type) unNeutral = \case Ne h sp -> pure (h, sp) _ -> empty @@ -112,7 +110,7 @@ occursIn :: Meta -> Level -> Type -> Bool occursIn p = go where go d = \case - ForAll n _ b -> go (succ d) (b (free (LName d n))) + ForAll _ _ b -> go (succ d) (b (free d)) Arrow _ a b -> go d a || go d b Comp s t -> any (go d) s || go d t Ne h sp -> any (either (== p) (const False)) h || any (go d) sp @@ -133,17 +131,17 @@ infixl 9 $$, $$* -- Quotation -eval :: HasCallStack => Subst Type -> Env Type -> TX.Type -> Type +eval :: HasCallStack => Subst Type -> Snoc (Name :=: Type) -> TX.Type -> Type eval subst = go where go env = \case TX.String -> String TX.Var (Global n) -> global n - TX.Var (Free (Right n)) -> index env n + TX.Var (Free (Right n)) -> (env ! getIndex n) ^. def_ TX.Var (Free (Left m)) -> fromMaybe (metavar m) (lookupMeta m subst) - TX.ForAll n t b -> ForAll n t (\ _T -> go (env |> review _PVar (n :=: _T)) b) + TX.ForAll n t b -> ForAll n t (\ _T -> go (env :> (n :=: _T)) b) TX.Arrow n a b -> Arrow n (go env a) (go env b) TX.Comp s t -> Comp (mapSignature (go env) s) (go env t) - TX.App f a -> go env f $$ go env a + TX.App f a -> go env f $$ go env a -apply :: HasCallStack => Subst Type -> Env Type -> Type -> Type -apply subst env = eval subst env . runQuoter (level env) . quote +apply :: HasCallStack => Subst Type -> Snoc (Name :=: Type) -> Type -> Type +apply subst env = eval subst env . runQuoter (Level (length env)) . quote diff --git a/src/Facet/TypeContext.hs b/src/Facet/TypeContext.hs index 07c9182ae..8c45dc551 100644 --- a/src/Facet/TypeContext.hs +++ b/src/Facet/TypeContext.hs @@ -20,10 +20,10 @@ empty = TypeContext S.Nil (|>) :: TypeContext -> Name :==> Kind -> TypeContext TypeContext as |> a = TypeContext (as S.:> a) -lookupIndex :: E.Has E.Empty sig m => Name -> TypeContext -> m (LName Index, Kind) +lookupIndex :: E.Has E.Empty sig m => Name -> TypeContext -> m (Index, Kind) lookupIndex n = go (Index 0) . getTypeContext where go _ S.Nil = E.empty go i (cs S.:> (n' :==> _K)) - | n == n' = pure (LName i n', _K) + | n == n' = pure (i, _K) | otherwise = go (succ i) cs diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index aef88fea8..48b7bec80 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -56,7 +56,7 @@ unifyType = curry $ \case (TN.Ne (Free (Left v1)) Nil, TN.Ne (Free (Left v2)) Nil) -> flexFlex v1 v2 (TN.Ne (Free (Left v1)) Nil, t2) -> solve v1 t2 (t1, TN.Ne (Free (Left v2)) Nil) -> solve v2 t1 - (TN.ForAll _ t1 b1, TN.ForAll n t2 b2) -> depth >>= \ d -> evalTExpr =<< mkForAll d n <$> unifyKind t1 t2 <*> (n :==> t2 ||- unifyType (b1 (free (LName d n))) (b2 (free (LName d n)))) + (TN.ForAll _ t1 b1, TN.ForAll n t2 b2) -> depth >>= \ d -> evalTExpr =<< mkForAll d n <$> unifyKind t1 t2 <*> (n :==> t2 ||- unifyType (b1 (free d)) (b2 (free d))) (TN.ForAll{}, _) -> mismatch (TN.Arrow _ a1 b1, TN.Arrow n a2 b2) -> TN.Arrow n <$> unifyType a1 a2 <*> unifyType b1 b2 (TN.Arrow{}, _) -> mismatch diff --git a/test/Facet/Core/Type/Test.hs b/test/Facet/Core/Type/Test.hs index b874b48e5..b949dd234 100644 --- a/test/Facet/Core/Type/Test.hs +++ b/test/Facet/Core/Type/Test.hs @@ -4,10 +4,10 @@ module Facet.Core.Type.Test ( tests ) where -import Facet.Env import Facet.Kind import Facet.Name import Facet.Quote +import Facet.Snoc import Facet.Syntax import Facet.Type.Expr import Facet.Type.Norm (eval) @@ -17,5 +17,5 @@ tests :: IO Bool tests = checkParallel $$(discover) prop_quotation_inverse = property $ do - let init = ForAll (T "A") KType (Arrow (Just (T "x")) (Var (Free (Right (LName 0 (T "A"))))) (Comp mempty (Var (Free (Right (LName 0 (T "A"))))))) - runQuoter 0 (quote (eval mempty empty init)) === init + let init = ForAll (T "A") KType (Arrow (Just (T "x")) (Var (Free (Right 0))) (Comp mempty (Var (Free (Right 0))))) + runQuoter 0 (quote (eval mempty Nil init)) === init From 798df818ca2fa24ea8d0dbd258915f0b5c839eb0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 21:01:54 -0400 Subject: [PATCH 1173/1324] Lift Printable to 2-functors. --- src/Facet/Print.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index c77bde5dc..b6e2d4ff9 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -23,6 +23,7 @@ module Facet.Print , Printable(..) , Printable1(..) , print1 +, Printable2(..) ) where import Data.Foldable (foldl') @@ -256,3 +257,10 @@ instance Printable1 Pattern where print1 :: (Printable1 f, Printable a) => Options Print -> Env Print -> f a -> Print print1 = printWith print + + +class Printable2 p where + printWith2 + :: (Options Print -> Env Print -> a -> Print) + -> (Options Print -> Env Print -> b -> Print) + -> (Options Print -> Env Print -> p a b -> Print) From 5666060ce0c2f1773d98150e4407b913d9ca9555 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 21:02:06 -0400 Subject: [PATCH 1174/1324] Define a Printable2 instance for pairs. --- src/Facet/Print.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index b6e2d4ff9..6c03a5076 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -264,3 +264,7 @@ class Printable2 p where :: (Options Print -> Env Print -> a -> Print) -> (Options Print -> Env Print -> b -> Print) -> (Options Print -> Env Print -> p a b -> Print) + + +instance Printable2 (,) where + printWith2 f g opts env (a, b) = tupled [f opts env a, g opts env b] From 1108fbde6f0fa65ef588c6128d0afe8a9ab6afed Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 21:02:15 -0400 Subject: [PATCH 1175/1324] Define a Printable2 instance for Either. --- src/Facet/Print.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 6c03a5076..ef74e82ed 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -268,3 +268,6 @@ class Printable2 p where instance Printable2 (,) where printWith2 f g opts env (a, b) = tupled [f opts env a, g opts env b] + +instance Printable2 Either where + printWith2 f g opts env = either (f opts env) (g opts env) From 7d182f32ea2881a7e6e36502565c2e567e56443e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 21:03:16 -0400 Subject: [PATCH 1176/1324] Lift print through Printable2. --- src/Facet/Print.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index ef74e82ed..d93577e7a 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -271,3 +271,7 @@ instance Printable2 (,) where instance Printable2 Either where printWith2 f g opts env = either (f opts env) (g opts env) + + +print2 :: (Printable2 p, Printable a, Printable b) => Options Print -> Env Print -> p a b -> Print +print2 = printWith2 print print From 13dbf1ae2cdab0aea84d16bb8e23dc469a9c1f44 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 21:05:23 -0400 Subject: [PATCH 1177/1324] Define a Printable2 instance for :=:. --- src/Facet/Print.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index d93577e7a..a25c7b119 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -272,6 +272,9 @@ instance Printable2 (,) where instance Printable2 Either where printWith2 f g opts env = either (f opts env) (g opts env) +instance Printable2 (:=:) where + printWith2 f g opts env (a :=: b) = f opts env a <+> pretty '=' <+> g opts env b + print2 :: (Printable2 p, Printable a, Printable b) => Options Print -> Env Print -> p a b -> Print print2 = printWith2 print print From a7f3e4d2213651b6f62ca4b9e4926e4e9599df5e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 21:06:08 -0400 Subject: [PATCH 1178/1324] Define a Printable instance for :=:. --- src/Facet/Print.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index a25c7b119..e20a53237 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -232,6 +232,10 @@ instance Printable C.Module where defn (a :=: b) = group a <> hardline <> group b +instance (Printable a, Printable b) => Printable (a :=: b) where + print = print2 + + class Printable1 f where printWith :: (Options Print -> Env Print -> a -> Print) -> Options Print -> Env Print -> f a -> Print From b8f2d60c5dcc36f3b2496852b66f7ddb03b2adfb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 21:07:59 -0400 Subject: [PATCH 1179/1324] Define a Printable instance for Name. --- src/Facet/Print.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index e20a53237..dfde9c726 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -235,6 +235,9 @@ instance Printable C.Module where instance (Printable a, Printable b) => Printable (a :=: b) where print = print2 +instance Printable Name where + print Options{ qname } _ = qname . (Nil :|>) + class Printable1 f where printWith :: (Options Print -> Env Print -> a -> Print) -> Options Print -> Env Print -> f a -> Print From 828e92ff6b872ed471b5c2874772b17756a5626a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 21:45:28 -0400 Subject: [PATCH 1180/1324] Don't use patterns in contexts. --- src/Facet/Context.hs | 18 +++++++--------- src/Facet/Elab.hs | 9 ++++---- src/Facet/Elab/Sequent.hs | 8 +++---- src/Facet/Elab/Term.hs | 18 ++++++++-------- src/Facet/Elab/Type.hs | 4 ++-- src/Facet/Env.hs | 42 +++++++++++++++++++++--------------- src/Facet/Eval.hs | 24 ++++++++++----------- src/Facet/Notice/Elab.hs | 18 ++++++++++------ src/Facet/Print.hs | 38 ++++++++++++++++---------------- src/Facet/Syntax.hs | 4 ++-- src/Facet/Term/Expr.hs | 2 +- src/Facet/Term/Norm.hs | 8 +++---- src/Facet/Type/Expr.hs | 2 +- src/Facet/Type/Norm.hs | 32 +++++++++++++-------------- src/Facet/Unify.hs | 28 ++++++++++++------------ test/Facet/Core/Type/Test.hs | 2 +- 16 files changed, 132 insertions(+), 125 deletions(-) diff --git a/src/Facet/Context.hs b/src/Facet/Context.hs index 1accb2b9b..56875e309 100644 --- a/src/Facet/Context.hs +++ b/src/Facet/Context.hs @@ -11,11 +11,9 @@ module Facet.Context ) where import qualified Control.Effect.Empty as E -import Data.Foldable (find) import qualified Facet.Env as Env import Facet.Functor.Synth import Facet.Name -import Facet.Pattern import qualified Facet.Snoc as S import Facet.Syntax import Facet.Type.Norm @@ -28,29 +26,29 @@ newtype Context = Context { elems :: Env.Env Type } empty :: Context empty = Context Env.empty -(|>) :: Context -> Pattern (Name :==> Type) -> Context -Context as |> a = Context (as Env.|> fmap toEquation a) +(|>) :: Context -> Name :==> Type -> Context +Context as |> a = Context (as Env.|> toEquation a) infixl 5 |> level :: Context -> Level level (Context es) = Level (length es) -(!) :: HasCallStack => Context -> Index -> Pattern (Name :==> Type) +(!) :: HasCallStack => Context -> Index -> Name :==> Type Context (Env.Env es') ! Index i' = withFrozenCallStack $ go es' i' where go (es S.:> e) i - | i == 0 = fromEquation <$> e + | i == 0 = fromEquation e | otherwise = go es (i - 1) go _ _ = error $ "Facet.Context.!: index (" <> show i' <> ") out of bounds (" <> show (length es') <> ")" -lookupIndex :: E.Has E.Empty sig m => Name -> Context -> m (LName Index, Type) +lookupIndex :: E.Has E.Empty sig m => Name -> Context -> m (Index, Type) lookupIndex n = go (Index 0) . Env.bindings . elems where go _ S.Nil = E.empty - go i (cs S.:> p) = case find (\ (n' :=: _) -> n' == n) p of - Just (n' :=: t) -> pure (LName i n', t) - _ -> go (succ i) cs + go i (cs S.:> (n' :=: t)) + | n == n' = pure (i, t) + | otherwise = go (succ i) cs toEnv :: Context -> Env.Env Type diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index f1439939c..22c133123 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -74,7 +74,6 @@ import Facet.Kind import Facet.Lens hiding (use, view) import Facet.Module import Facet.Name hiding (L, R) -import Facet.Pattern import Facet.Quote import Facet.Snoc import Facet.Snoc.NonEmpty (NonEmpty(..)) @@ -113,7 +112,7 @@ instantiate inst = go go (e ::: _T) = case _T of TN.ForAll _ _T _B -> do m <- meta _T - go (inst e (TX.Var (Free (Left m))) ::: _B (metavar m)) + go (inst e (TX.Var (Bound (Left m))) ::: _B (metavar m)) _ -> pure $ e ::: _T @@ -133,7 +132,7 @@ resolveC = resolveWith lookupConstructor resolveDef :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m Def resolveDef = resolveWith lookupDef -lookupInContext :: Has (Choose :+: Empty) sig m => QName -> Context -> m (LName Index, Type) +lookupInContext :: Has (Choose :+: Empty) sig m => QName -> Context -> m (Index, Type) lookupInContext (m:|>n) | m == Nil = lookupIndex n | otherwise = const empty @@ -155,12 +154,12 @@ lookupInSig (m :|> n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':|>_) _ interfaceScope = \case { DSubmodule (SInterface defs) _K -> pure defs ; _ -> empty } -(|-) :: Has (Reader ElabContext) sig m => Pattern (Name :==> Type) -> m a -> m a +(|-) :: Has (Reader ElabContext) sig m => Name :==> Type -> m a -> m a p |- b = locally context_ (|> p) b infix 1 |- -(||-) :: Has (Reader ElabContext) sig m => (Name :==> Kind) -> m a -> m a +(||-) :: Has (Reader ElabContext) sig m => Name :==> Kind -> m a -> m a k ||- b = locally typeContext_ (TypeContext.|> k) b infix 1 ||- diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 8c9a5d64b..d1fff6909 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -57,7 +57,7 @@ import GHC.Stack (HasCallStack, callStack, popCallStack, withFrozenCal -- FIXME: we’re instantiating when inspecting types in the REPL. globalS :: Has (State (Subst Type)) sig m => QName ::: Type -> m (SQ.Term :==> Type) globalS (q ::: _T) = do - let v = SQ.Var (Global q) + let v = SQ.Var (Free q) (\ (v ::: _T) -> v :==> _T) <$> instantiate const (v ::: _T) -- FIXME: do we need to instantiate here to deal with rank-n applications? @@ -65,8 +65,8 @@ globalS (q ::: _T) = do -- FIXME: effect ops in the sig are available whether or not they’re in scope varS :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m) => QName -> m (SQ.Term :==> Type) varS n = views context_ (lookupInContext n) >>= \case - [(n', _T)] -> pure $ SQ.Var (Free (ident n')) :==> _T - _ -> resolveDef n >>= \case + [(i, _T)] -> pure $ SQ.Var (Bound i) :==> _T + _ -> resolveDef n >>= \case DTerm _ _T -> globalS (n ::: _T) _ -> freeVariable n @@ -95,7 +95,7 @@ appS f a = do f' :==> _F <- f (_, _A, _B) <- assertFunction _F a' <- check (a ::: _A) - pure $ SQ.MuR (f' SQ.:|: SQ.LamL a' (SQ.Covar (Free (Index 0)))) :==> _B + pure $ SQ.MuR (f' SQ.:|: SQ.LamL a' (SQ.Covar (Bound (Index 0)))) :==> _B -- General combinators diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index cf8ee8aa2..54dfcc59e 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -75,7 +75,7 @@ import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) import Facet.Term.Expr as E import qualified Facet.Type.Expr as TX -import Facet.Type.Norm as T hiding (global) +import Facet.Type.Norm as T import Facet.Unify import Fresnel.At as At import Fresnel.Getter as Getter (view) @@ -104,7 +104,7 @@ as (m ::: _T) = do -- FIXME: we’re instantiating when inspecting types in the REPL. global :: Has (State (Subst Type)) sig m => QName ::: Type -> m (Term :==> Type) -global (q ::: _T) = (\ (v ::: _T) -> v :==> _T) <$> instantiate const (Var (Global q) ::: _T) +global (q ::: _T) = (\ (v ::: _T) -> v :==> _T) <$> instantiate const (Var (Free q) ::: _T) -- FIXME: do we need to instantiate here to deal with rank-n applications? @@ -112,7 +112,7 @@ global (q ::: _T) = (\ (v ::: _T) -> v :==> _T) <$> instantiate const (Var (Glob -- FIXME: effect ops in the sig are available whether or not they’re in scope var :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m) => QName -> m (Term :==> Type) var n = views context_ (lookupInContext n) >>= \case - [(n', _T)] -> pure (Var (Free n') :==> _T) + [(n', _T)] -> pure (Var (Bound n') :==> _T) _ -> resolveDef n >>= \case DTerm _ _T -> global (n ::: _T) _ -> freeVariable n @@ -126,7 +126,7 @@ tlam :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => Type <= tlam b = Check $ \ _T -> do (n, _A, _B) <- assertQuantifier _T d <- depth - n :==> _A ||- check (b ::: _B (T.free d)) + n :==> _A ||- check (b ::: _B (T.bound d)) lam :: (Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => [(Bind m (Pattern (Name :==> Type)), Type <==: m Term)] -> Type <==: m Term lam cs = Check $ \ _T -> do @@ -164,7 +164,7 @@ varP :: Name -> Bind m (ValPattern (Name :==> Type)) varP n = Bind $ \ _A k -> k (PVar (n :==> wrap _A)) where wrap = \case - T.Comp sig _A -> T.Arrow Nothing (T.Ne (Global (NE.FromList ["Data", "Unit"] |> T "Unit")) Nil) (T.Comp sig _A) + T.Comp sig _A -> T.Arrow Nothing (T.Ne (Free (NE.FromList ["Data", "Unit"] |> T "Unit")) Nil) (T.Comp sig _A) _T -> _T conP :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> [Bind m (ValPattern (Name :==> Type))] -> Bind m (ValPattern (Name :==> Type)) @@ -186,7 +186,7 @@ fieldsP = foldr cons nil allP :: Has (Throw ErrReason :+: Write Warn) sig m => Name -> Bind m (Pattern (Name :==> Type)) allP n = Bind $ \ _A k -> do (sig, _T) <- assertComp _A - k (PVal (PVar (n :==> T.Arrow Nothing (T.Ne (Global (NE.FromList ["Data", "Unit"] |> T "Unit")) Nil) (T.Comp sig _T)))) + k (PVal (PVar (n :==> T.Arrow Nothing (T.Ne (Free (NE.FromList ["Data", "Unit"] |> T "Unit")) Nil) (T.Comp sig _T)))) -- Expression elaboration @@ -253,10 +253,10 @@ abstractTerm body = go Nil Nil check (tlam (go (ts :> d) fs) ::: T.ForAll n _T _B) T.Arrow n _A _B -> do d <- depth - check (lam [(patternForArgType _A (fromMaybe __ n), go ts (fs :> \ d' -> Var (Free (LName (toIndexed d' d) (fromMaybe __ n)))))] ::: T.Arrow n _A _B) + check (lam [(patternForArgType _A (fromMaybe __ n), go ts (fs :> \ d' -> Var (Bound (toIndexed d' d))))] ::: T.Arrow n _A _B) _T -> do d <- depth - pure $ body (TX.Var . Free . Right . toIndexed d <$> ts) (fs <*> pure d) + pure $ body (TX.Var . Bound . Right . toIndexed d <$> ts) (fs <*> pure d) patternForArgType :: Has (Throw ErrReason :+: Write Warn) sig m => Type -> Name -> Bind m (Pattern (Name :==> Type)) patternForArgType = \case @@ -394,7 +394,7 @@ check (m ::: _T) = case _T of bind :: Has (Reader ElabContext) sig m => Bind m (Pattern (Name :==> Type)) ::: Type -> m b -> m (Pattern Name, b) -bind (p ::: _T) m = runBind p _T (\ p' -> (proof <$> p',) <$> (p' |- m)) +bind (p ::: _T) m = runBind p _T (\ p' -> (proof <$> p',) <$> foldr (|-) m p') newtype Bind m a = Bind { runBind :: forall x . Type -> (a -> m x) -> m x } deriving (Functor) diff --git a/src/Facet/Elab/Type.hs b/src/Facet/Elab/Type.hs index ec37f8558..d798783d9 100644 --- a/src/Facet/Elab/Type.hs +++ b/src/Facet/Elab/Type.hs @@ -31,9 +31,9 @@ import qualified Facet.Type.Expr as TX tvar :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (TX.Type :==> Kind) tvar n = views typeContext_ (lookupInTypeContext n) >>= \case - [(n', _K)] -> pure (TX.Var (Free (Right n')) :==> _K) + [(n', _K)] -> pure (TX.Var (Bound (Right n')) :==> _K) _ -> resolveDef n >>= \case - DSubmodule _ _K -> pure $ TX.Var (Global n) :==> _K + DSubmodule _ _K -> pure $ TX.Var (Free n) :==> _K _ -> freeVariable n ivar :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :==> Kind) diff --git a/src/Facet/Env.hs b/src/Facet/Env.hs index 3d91fdaf7..906dd71fb 100644 --- a/src/Facet/Env.hs +++ b/src/Facet/Env.hs @@ -5,36 +5,44 @@ module Facet.Env , lookup , index , level +, (!) +, (!?) ) where -import Control.Applicative ((<|>)) -import Control.Monad (guard) -import Data.Maybe (fromMaybe) -import Facet.Name -import Facet.Pattern -import Facet.Snoc -import Facet.Syntax -import GHC.Stack -import Prelude hiding (lookup) - -newtype Env v = Env { bindings :: Snoc (Pattern (Name :=: v)) } +import Control.Applicative ((<|>)) +import Control.Monad (guard) +import Data.Maybe (fromMaybe) +import Facet.Name +import qualified Facet.Snoc as S +import Facet.Syntax +import Fresnel.Getter (view) +import GHC.Stack +import Prelude hiding (lookup) + +newtype Env v = Env { bindings :: S.Snoc (Name :=: v) } deriving (Foldable, Functor, Monoid, Semigroup, Traversable) empty :: Env v -empty = Env Nil +empty = Env S.Nil -(|>) :: Env v -> Pattern (Name :=: v) -> Env v -Env vs |> v = Env (vs :> v) +(|>) :: Env v -> Name :=: v -> Env v +Env vs |> v = Env (vs S.:> v) infixl 5 |> -lookup :: Env v -> LName Index -> Maybe v -lookup (Env vs) (LName i n) = find (\ (n' :=: v) -> v <$ guard (n == n')) (vs ! getIndex i) +lookup :: Env v -> Name -> Maybe v +lookup (Env vs) n = find (\ (n' :=: v) -> v <$ guard (n == n')) vs where find f = foldr ((<|>) . f) Nothing -index :: HasCallStack => Env v -> LName Index -> v +index :: HasCallStack => Env v -> Name -> v index env n = fromMaybe (error ("Env.index: name (" <> show n <> ") not found")) (lookup env n) level :: Env v -> Level level = Level . length . bindings + +(!) :: HasCallStack => Env v -> Index -> v +Env env ! i = view def_ (env S.! getIndex i) + +(!?) :: Env v -> Index -> Maybe v +Env env !? i = view def_ <$> (env S.!? getIndex i) diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 2c36fa856..3a524eb28 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -50,13 +50,13 @@ import Prelude hiding (zipWith) eval :: (HasCallStack, Has (Reader Graph :+: Reader Module) sig m, MonadFail m) => Term -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) eval = \case - Var (Global n) -> global n >>= eval - Var (Free n) -> var n - Lam cs -> lam cs - App f a -> app (eval f) a - Con n fs -> con n (eval <$> fs) - String s -> string s - Let p v b -> eval v >>= \ v' -> local (|> fromMaybe (error "eval: non-exhaustive pattern in let") (matchV id p v')) (eval b) + Var (Free n) -> global n >>= eval + Var (Bound n) -> var n + Lam cs -> lam cs + App f a -> app (eval f) a + Con n fs -> con n (eval <$> fs) + String s -> string s + Let p v b -> eval v >>= \ v' -> local (flip (foldl' (|>)) (fromMaybe (error "eval: non-exhaustive pattern in let") (matchV id p v'))) (eval b) global :: Has (Reader Graph :+: Reader Module) sig m => QName -> ReaderC (Env (Value (Eval m))) (Eval m) Term global n = do @@ -66,8 +66,8 @@ global n = do [DTerm (Just v) _] -> pure v -- FIXME: store values in the module graph _ -> error "throw a real error here" -var :: (HasCallStack, Algebra sig m) => LName Index -> ReaderC (Env (Value m)) m (Value m) -var n = asks (`index` n) +var :: (HasCallStack, Algebra sig m) => Index -> ReaderC (Env (Value m)) m (Value m) +var n = asks (Env.! n) lam :: Algebra sig m => [(Pattern Name, Term)] -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) lam cs = asks (`VLam` cs) @@ -75,7 +75,7 @@ lam cs = asks (`VLam` cs) app :: (HasCallStack, Has (Reader Graph :+: Reader Module) sig m, MonadFail m) => ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) -> Term -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) app f a = ask >>= \ envCallSite -> f >>= \case VLam env cs -> lift (k a) where - k = foldl' (\ vs (p, b) -> runReader envCallSite . eval >=> fromMaybe (vs a) . matchV (\ vs -> runReader (env |> vs) (eval b)) p) (const (fail "non-exhaustive patterns in lambda")) cs + k = foldl' (\ vs (p, b) -> runReader envCallSite . eval >=> fromMaybe (vs a) . matchV (\ vs -> runReader (foldl' (|>) env vs) (eval b)) p) (const (fail "non-exhaustive patterns in lambda")) cs VCont k -> lift (k =<< runReader envCallSite (eval a)) _ -> fail "expected lambda/continuation" @@ -114,7 +114,7 @@ instance Algebra sig m => Algebra sig (Eval m) where data Value m -- | Neutral; variables, only used during quotation - = VVar (Var (LName Level)) + = VVar (Var Level) -- | Value; data constructors. | VCon QName [Value m] -- | Value; strings. @@ -127,7 +127,7 @@ data Value m instance Monad m => Quote (Value m) (m Term) where quote = \case VLam _ cs -> pure . pure $ Lam cs - VCont k -> Quoter (\ d -> runQuoter (succ d) . quote =<< k (VVar (Free (LName d __)))) + VCont k -> Quoter (\ d -> runQuoter (succ d) . quote =<< k (VVar (Bound d))) VVar v -> Quoter (\ d -> pure (Var (toIndexed d v))) VCon n fs -> fmap (Con n) . sequenceA <$> traverse quote fs VString s -> pure . pure $ String s diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 5bbed216a..1daf18817 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -15,14 +15,13 @@ import Facet.Functor.Synth import Facet.Interface (interfaces) import Facet.Name import Facet.Notice as Notice hiding (level) -import Facet.Pattern import Facet.Pretty import Facet.Print as Print import Facet.Snoc import Facet.Style import Facet.Subst (metas) import Facet.Syntax hiding (ann) -import Facet.Type.Norm (apply, free, metavar) +import Facet.Type.Norm (Type, apply, bound, metavar) import Facet.TypeContext (getTypeContext) import GHC.Stack (prettyCallStack) import Prelude hiding (print, unlines) @@ -45,15 +44,20 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) (_, _, _, tyCtx) = foldl' combineTyCtx (0, Nil, Env.empty, Nil) (getTypeContext typeContext) subst' = map (\ (m :=: v) -> getPrint (Print.meta m <+> pretty '=' <+> maybe (pretty '?') (print opts printCtx) v)) (metas subst) sig' = getPrint . print opts printCtx . fmap (apply subst Nil) <$> (interfaces =<< sig) + combineTyCtx + :: Printable k + => (Facet.Name.Level, Snoc (Name :=: Type), Env.Env Print, Snoc (Doc Style)) + -> Name :==> k + -> (Facet.Name.Level, Snoc (Name :=: Type), Env.Env Print, Snoc (Doc Style)) combineTyCtx (d, env, prints, ctx) (n :==> _K) = ( succ d - , env :> (n :=: free d) - , prints Env.|> PVal (PVar (n :=: intro n d)) + , env :> (n :=: bound d) + , prints Env.|> (n :=: intro n d) , ctx :> getPrint (print opts prints (ann (intro n d ::: print opts prints _K))) ) - combine (d, prints, ctx) p = + combine (d, prints, ctx) (n :=: _T) = ( succ d - , prints Env.|> ((\ (n :=: _) -> n :=: intro n d) <$> p) - , ctx :> getPrint (print opts prints ((\ (n :=: _T) -> ann (intro n d ::: print opts prints (apply subst Nil _T))) <$> p)) ) + , prints Env.|> (n :=: intro n d) + , ctx :> getPrint (print opts prints (n :=: ann (intro n d ::: print opts prints (apply subst Nil _T)))) ) printErrReason :: Options Print -> Env.Env Print -> ErrReason -> Doc Style diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index dfde9c726..e08817f96 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -24,6 +24,7 @@ module Facet.Print , Printable1(..) , print1 , Printable2(..) +, print2 ) where import Data.Foldable (foldl') @@ -127,9 +128,6 @@ tintro n = name upper n . getLevel qvar :: (P.Level p ~ Precedence, PrecedencePrinter p) => QName -> p qvar (_ :|> n) = setPrec Var (pretty n) -lname :: LName Level -> Print -lname (LName d n) = intro n d - meta :: Meta -> Print meta (Meta m) = setPrec Var $ annotate (Name m) $ pretty '?' <> upper m @@ -170,15 +168,15 @@ instance Printable TX.Type where where qvar = group . setPrec Var . qname go env = \case - TX.Var (Global n) -> qvar n - TX.Var (Free (Right n)) -> fromMaybe (intro __ (toLeveled d n)) $ Env.lookup env (LName n __) - TX.Var (Free (Left m)) -> meta m - TX.ForAll n t b -> braces (ann (intro n d ::: print opts env t)) --> go (env |> PVal (PVar (n :=: intro n d))) b - TX.Arrow Nothing a b -> go env a --> go env b - TX.Arrow (Just n) a b -> parens (ann (intro n d ::: go env a)) --> go env b - TX.Comp s t -> if s == mempty then go env t else sig s <+> go env t - TX.App f a -> group (go env f) $$ group (go env a) - TX.String -> annotate Type $ pretty "String" + TX.Var (Free n) -> qvar n + TX.Var (Bound (Right n)) -> fromMaybe (intro __ (toLeveled d n)) $ env Env.!? n + TX.Var (Bound (Left m)) -> meta m + TX.ForAll n t b -> braces (ann (intro n d ::: print opts env t)) --> go (env |> (n :=: intro n d)) b + TX.Arrow Nothing a b -> go env a --> go env b + TX.Arrow (Just n) a b -> parens (ann (intro n d ::: go env a)) --> go env b + TX.Comp s t -> if s == mempty then go env t else sig s <+> go env t + TX.App f a -> group (go env f) $$ group (go env a) + TX.String -> annotate Type $ pretty "String" where d = level env sig s = brackets (commaSep (map (interface env) (interfaces s))) @@ -191,17 +189,17 @@ instance Printable C.Term where print opts@Options{ qname } = go where go env = \case - C.Var (Global n) -> qvar n - C.Var (Free n) -> fromMaybe (lname (toLeveled d n)) $ Env.lookup env n - C.Lam cs -> comp (commaSep (map (clause env) cs)) - C.App f a -> go env f $$ go env a - C.Con n p -> qvar n $$* (group . go env <$> p) - C.String s -> annotate Lit $ pretty (show s) - C.Let p v b -> let p' = snd (mapAccumLevels (\ d n -> n :=: local n d) (level env) p) in pretty "let" <+> braces (print opts env (view def_ <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (env |> p') b + C.Var (Free n) -> qvar n + C.Var (Bound n) -> fromMaybe (intro __ (toLeveled d n)) $ env Env.!? n + C.Lam cs -> comp (commaSep (map (clause env) cs)) + C.App f a -> go env f $$ go env a + C.Con n p -> qvar n $$* (group . go env <$> p) + C.String s -> annotate Lit $ pretty (show s) + C.Let p v b -> let p' = snd (mapAccumLevels (\ d n -> n :=: local n d) (level env) p) in pretty "let" <+> braces (print opts env (view def_ <$> p') equals <+> group (go env v)) <+> pretty "in" <+> go (foldl' (|>) env p') b where d = level env qvar = group . setPrec Var . qname - clause env (p, b) = print opts env (view def_ <$> p') <+> arrow <+> go (env |> p') b + clause env (p, b) = print opts env (view def_ <$> p') <+> arrow <+> go (foldl' (|>) env p') b where p' = snd (mapAccumLevels (\ d n -> n :=: local n d) (level env) p) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 578ec8c48..44357f8fe 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -144,8 +144,8 @@ qty_ = lens (\ (_ :@ q) -> q) (\ (p :@ _) q -> p :@ q) -- Variables data Var a - = Global QName -- ^ Global variables, considered equal by 'QName'. - | Free a + = Bound a + | Free QName -- ^ Free variables (both local and global), considered equal by 'QName'. Unary names are locals, n>1-ary names are globals. deriving (Eq, Foldable, Functor, Ord, Show, Traversable) instance DeBruijn lv ix => DeBruijn (Var lv) (Var ix) where diff --git a/src/Facet/Term/Expr.hs b/src/Facet/Term/Expr.hs index 4b51c83d3..3b878317d 100644 --- a/src/Facet/Term/Expr.hs +++ b/src/Facet/Term/Expr.hs @@ -11,7 +11,7 @@ import Facet.Syntax -- Term expressions data Term - = Var (Var (LName Index)) + = Var (Var Index) | Lam [(Pattern Name, Term)] | App Term Term | Con QName [Term] diff --git a/src/Facet/Term/Norm.hs b/src/Facet/Term/Norm.hs index a0ff0ae1e..66db7bdc3 100644 --- a/src/Facet/Term/Norm.hs +++ b/src/Facet/Term/Norm.hs @@ -21,7 +21,7 @@ data Term = String Text | Con QName [Term] | Lam [(Pattern Name, Pattern (Name :=: Term) -> Term)] - | Ne (Var (LName Level)) (Snoc Term) + | Ne (Var Level) (Snoc Term) deriving (Eq, Ord, Show) via Quoting X.Term Term instance Quote Term X.Term where @@ -32,7 +32,7 @@ instance Quote Term X.Term where Ne v sp -> foldl' (\ h t -> X.App <$> h <*> quote t) (Quoter (\ d -> X.Var (toIndexed d v))) sp where clause :: Traversable t => t Name -> (t (Name :=: Term) -> Term) -> Quoter (t Name, X.Term) - clause p b = Quoter (\ d -> let (d', p') = mapAccumLevels (\ d n -> n :=: Ne (Free (LName d n)) Nil) d p in (p, runQuoter d' (quote (b p')))) + clause p b = Quoter (\ d -> let (d', p') = mapAccumLevels (\ d n -> n :=: Ne (Bound d) Nil) d p in (p, runQuoter d' (quote (b p')))) norm :: Env Term -> X.Term -> Term norm env = \case @@ -40,8 +40,8 @@ norm env = \case X.Var v -> Ne (toLeveled (level env) v) Nil X.Con n sp -> Con n (norm env <$> sp) X.App f a -> norm env f `napp` norm env a - X.Lam cs -> Lam (map (\ (p, b) -> (p, \ p' -> norm (env |> p') b)) cs) - X.Let p v b -> norm (env |> fromMaybe (error "norm: non-exhaustive pattern in let") (match (norm env v) p)) b + X.Lam cs -> Lam (map (\ (p, b) -> (p, \ p' -> norm (foldl' (|>) env p') b)) cs) + X.Let p v b -> norm (foldl' (|>) env (fromMaybe (error "norm: non-exhaustive pattern in let") (match (norm env v) p))) b napp :: Term -> Term -> Term diff --git a/src/Facet/Type/Expr.hs b/src/Facet/Type/Expr.hs index ff62f9a59..cee794c21 100644 --- a/src/Facet/Type/Expr.hs +++ b/src/Facet/Type/Expr.hs @@ -21,7 +21,7 @@ data Type instance C.Type (Quoter Type) where string = pure String - forAll n k b = ForAll n k <$> binder (\ d' -> Quoter (\ d -> Var (Free (Right (toIndexed d d'))))) b + forAll n k b = ForAll n k <$> binder (\ d' -> Quoter (\ d -> Var (Bound (Right (toIndexed d d'))))) b arrow n = liftA2 (Arrow n) var v = Quoter (\ d -> Var (toIndexed d v)) ($$) = liftA2 App diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index cc9d8b43d..b37c4f3ce 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -6,7 +6,7 @@ module Facet.Type.Norm , _Arrow , _Ne , _Comp -, global +, bound , free , metavar , unNeutral @@ -59,7 +59,7 @@ instance C.Type Type where instance Quote Type TX.Type where quote = \case String -> pure TX.String - ForAll n t b -> Quoter (\ d -> TX.ForAll n t (runQuoter (succ d) (quote (b (free d))))) + ForAll n t b -> Quoter (\ d -> TX.ForAll n t (runQuoter (succ d) (quote (b (bound d))))) Arrow n a b -> TX.Arrow n <$> quote a <*> quote b Comp s t -> TX.Comp <$> traverseSignature quote s <*> quote t Ne n sp -> foldl' (\ h t -> TX.App <$> h <*> quote t) (Quoter (\ d -> TX.Var (toIndexed d n))) sp @@ -81,14 +81,14 @@ _Comp :: Prism' Type (Signature Type, Type) _Comp = prism' (uncurry Comp) (\case{ Comp sig t -> Just (sig, t) ; _ -> Nothing }) -global :: QName -> Type -global = var . Global +bound :: Level -> Type +bound = var . Bound . Right -free :: Level -> Type -free = var . Free . Right +free :: QName -> Type +free = var . Free metavar :: Meta -> Type -metavar = var . Free . Left +metavar = var . Bound . Left var :: Var (Either Meta Level) -> Type @@ -110,7 +110,7 @@ occursIn :: Meta -> Level -> Type -> Bool occursIn p = go where go d = \case - ForAll _ _ b -> go (succ d) (b (free d)) + ForAll _ _ b -> go (succ d) (b (bound d)) Arrow _ a b -> go d a || go d b Comp s t -> any (go d) s || go d t Ne h sp -> any (either (== p) (const False)) h || any (go d) sp @@ -134,14 +134,14 @@ infixl 9 $$, $$* eval :: HasCallStack => Subst Type -> Snoc (Name :=: Type) -> TX.Type -> Type eval subst = go where go env = \case - TX.String -> String - TX.Var (Global n) -> global n - TX.Var (Free (Right n)) -> (env ! getIndex n) ^. def_ - TX.Var (Free (Left m)) -> fromMaybe (metavar m) (lookupMeta m subst) - TX.ForAll n t b -> ForAll n t (\ _T -> go (env :> (n :=: _T)) b) - TX.Arrow n a b -> Arrow n (go env a) (go env b) - TX.Comp s t -> Comp (mapSignature (go env) s) (go env t) - TX.App f a -> go env f $$ go env a + TX.String -> String + TX.Var (Free n) -> free n + TX.Var (Bound (Right n)) -> (env ! getIndex n) ^. def_ + TX.Var (Bound (Left m)) -> fromMaybe (metavar m) (lookupMeta m subst) + TX.ForAll n t b -> ForAll n t (\ _T -> go (env :> (n :=: _T)) b) + TX.Arrow n a b -> Arrow n (go env a) (go env b) + TX.Comp s t -> Comp (mapSignature (go env) s) (go env t) + TX.App f a -> go env f $$ go env a apply :: HasCallStack => Subst Type -> Snoc (Name :=: Type) -> Type -> Type apply subst env = eval subst env . runQuoter (Level (length env)) . quote diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index 48b7bec80..ed3b6e342 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -50,20 +50,20 @@ occurs v t = withFrozenCallStack $ throwError $ WithCallStack GHC.Stack.callStac unifyType :: (HasCallStack, Has (Reader ElabContext) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Throw (WithCallStack UnifyErrReason)) sig m) => Type -> Type -> m Type unifyType = curry $ \case - (TN.Comp s1 t1, TN.Comp s2 t2) -> TN.Comp . fromInterfaces <$> unifySpine unifyInterface (interfaces s1) (interfaces s2) <*> unifyType t1 t2 - (TN.Comp s1 t1, t2) -> TN.Comp s1 <$> unifyType t1 t2 - (t1, TN.Comp s2 t2) -> TN.Comp s2 <$> unifyType t1 t2 - (TN.Ne (Free (Left v1)) Nil, TN.Ne (Free (Left v2)) Nil) -> flexFlex v1 v2 - (TN.Ne (Free (Left v1)) Nil, t2) -> solve v1 t2 - (t1, TN.Ne (Free (Left v2)) Nil) -> solve v2 t1 - (TN.ForAll _ t1 b1, TN.ForAll n t2 b2) -> depth >>= \ d -> evalTExpr =<< mkForAll d n <$> unifyKind t1 t2 <*> (n :==> t2 ||- unifyType (b1 (free d)) (b2 (free d))) - (TN.ForAll{}, _) -> mismatch - (TN.Arrow _ a1 b1, TN.Arrow n a2 b2) -> TN.Arrow n <$> unifyType a1 a2 <*> unifyType b1 b2 - (TN.Arrow{}, _) -> mismatch - (TN.Ne v1 sp1, TN.Ne v2 sp2) -> TN.Ne <$> unifyVar v1 v2 <*> unifySpine unifyType sp1 sp2 - (TN.Ne{}, _) -> mismatch - (TN.String, TN.String) -> pure TN.String - (TN.String, _) -> mismatch + (TN.Comp s1 t1, TN.Comp s2 t2) -> TN.Comp . fromInterfaces <$> unifySpine unifyInterface (interfaces s1) (interfaces s2) <*> unifyType t1 t2 + (TN.Comp s1 t1, t2) -> TN.Comp s1 <$> unifyType t1 t2 + (t1, TN.Comp s2 t2) -> TN.Comp s2 <$> unifyType t1 t2 + (TN.Ne (Bound (Left v1)) Nil, TN.Ne (Bound (Left v2)) Nil) -> flexFlex v1 v2 + (TN.Ne (Bound (Left v1)) Nil, t2) -> solve v1 t2 + (t1, TN.Ne (Bound (Left v2)) Nil) -> solve v2 t1 + (TN.ForAll _ t1 b1, TN.ForAll n t2 b2) -> depth >>= \ d -> evalTExpr =<< mkForAll d n <$> unifyKind t1 t2 <*> (n :==> t2 ||- unifyType (b1 (bound d)) (b2 (bound d))) + (TN.ForAll{}, _) -> mismatch + (TN.Arrow _ a1 b1, TN.Arrow n a2 b2) -> TN.Arrow n <$> unifyType a1 a2 <*> unifyType b1 b2 + (TN.Arrow{}, _) -> mismatch + (TN.Ne v1 sp1, TN.Ne v2 sp2) -> TN.Ne <$> unifyVar v1 v2 <*> unifySpine unifyType sp1 sp2 + (TN.Ne{}, _) -> mismatch + (TN.String, TN.String) -> pure TN.String + (TN.String, _) -> mismatch where mkForAll d n k b = TX.ForAll n k (runQuoter (succ d) (quote b)) diff --git a/test/Facet/Core/Type/Test.hs b/test/Facet/Core/Type/Test.hs index b949dd234..454ef5ec5 100644 --- a/test/Facet/Core/Type/Test.hs +++ b/test/Facet/Core/Type/Test.hs @@ -17,5 +17,5 @@ tests :: IO Bool tests = checkParallel $$(discover) prop_quotation_inverse = property $ do - let init = ForAll (T "A") KType (Arrow (Just (T "x")) (Var (Free (Right 0))) (Comp mempty (Var (Free (Right 0))))) + let init = ForAll (T "A") KType (Arrow (Just (T "x")) (Var (Bound (Right 0))) (Comp mempty (Var (Bound (Right 0))))) runQuoter 0 (quote (eval mempty Nil init)) === init From f2c82f554c93d27e97c69e589fdb9b33f8324ca6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 23:24:33 -0400 Subject: [PATCH 1181/1324] Correct the instantiation types. --- src/Facet/Sequent/Expr.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 8b325cd33..cb5de8778 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -53,8 +53,8 @@ newtype ScopeLR = ScopeLR { getScopeLR :: Command } class BinderL scope where abstractL :: Name -> Command -> scope - instantiateL :: Command -> scope -> Command + instantiateL :: Coterm -> scope -> Command class BinderR scope where abstractR :: Name -> Command -> scope - instantiateR :: Command -> scope -> Command + instantiateR :: Term -> scope -> Command From 9047b5dec2f5aec7fc0a467f847624054f81b495 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 23:27:01 -0400 Subject: [PATCH 1182/1324] Define left and right scopes parameterized by the command. --- src/Facet/Sequent/Expr.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index cb5de8778..fbe71a3b3 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -7,6 +7,8 @@ module Facet.Sequent.Expr , Command(..) -- * Scopes , ScopeLR +, ScopeL +, ScopeR , BinderL(..) , BinderR(..) ) where @@ -51,6 +53,10 @@ data Command newtype ScopeLR = ScopeLR { getScopeLR :: Command } +newtype ScopeL a = ScopeL { getScopeL :: a } + +newtype ScopeR a = ScopeR { getScopeR :: a } + class BinderL scope where abstractL :: Name -> Command -> scope instantiateL :: Coterm -> scope -> Command From 3a4798e9b425d0f2fd8e2762bc60842679f1a20e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 23:29:29 -0400 Subject: [PATCH 1183/1324] Abstract over two variables at once. --- src/Facet/Sequent/Expr.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index fbe71a3b3..ec65f9f15 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -9,6 +9,7 @@ module Facet.Sequent.Expr , ScopeLR , ScopeL , ScopeR +, BinderLR(..) , BinderL(..) , BinderR(..) ) where @@ -57,6 +58,10 @@ newtype ScopeL a = ScopeL { getScopeL :: a } newtype ScopeR a = ScopeR { getScopeR :: a } +class BinderLR scope where + abstractLR :: Name -> Name -> Command -> scope + instantiateLR :: Term -> Coterm -> scope -> Command + class BinderL scope where abstractL :: Name -> Command -> scope instantiateL :: Coterm -> scope -> Command From a781170f21c05b237a4876476f29b09ad0da7166 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 25 Apr 2022 23:30:02 -0400 Subject: [PATCH 1184/1324] Specialize ScopeL/R to Command. --- src/Facet/Sequent/Expr.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index ec65f9f15..65d660ec4 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -54,9 +54,9 @@ data Command newtype ScopeLR = ScopeLR { getScopeLR :: Command } -newtype ScopeL a = ScopeL { getScopeL :: a } +newtype ScopeL = ScopeL { getScopeL :: Command } -newtype ScopeR a = ScopeR { getScopeR :: a } +newtype ScopeR = ScopeR { getScopeR :: Command } class BinderLR scope where abstractLR :: Name -> Name -> Command -> scope From 2fbdb28ce3f6063a7bfd09ac08e4ecf123a67b2d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 07:16:10 -0400 Subject: [PATCH 1185/1324] Define abstraction and instantiation over both sides of sequents. --- src/Facet/Sequent/Expr.hs | 84 ++++++++++++++++++++++++++++----------- 1 file changed, 61 insertions(+), 23 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 65d660ec4..238a9f3e3 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -6,16 +6,15 @@ module Facet.Sequent.Expr -- * Commands , Command(..) -- * Scopes -, ScopeLR -, ScopeL -, ScopeR -, BinderLR(..) -, BinderL(..) -, BinderR(..) +, Scope +, abstractLR +, instantiateLR ) where import Data.Text (Text) import Facet.Name +import Facet.Snoc +import Facet.Snoc.NonEmpty import Facet.Syntax -- Terms @@ -52,20 +51,59 @@ data Command -- Scopes -newtype ScopeLR = ScopeLR { getScopeLR :: Command } - -newtype ScopeL = ScopeL { getScopeL :: Command } - -newtype ScopeR = ScopeR { getScopeR :: Command } - -class BinderLR scope where - abstractLR :: Name -> Name -> Command -> scope - instantiateLR :: Term -> Coterm -> scope -> Command - -class BinderL scope where - abstractL :: Name -> Command -> scope - instantiateL :: Coterm -> scope -> Command - -class BinderR scope where - abstractR :: Name -> Command -> scope - instantiateR :: Term -> scope -> Command +newtype Scope = Scope { getScope :: Command } + +abstractLR :: Name -> Name -> (Command -> Scope) +abstractLR t c = Scope . replace freeR boundR freeL boundL where + freeR outer name + | name == t = Var (Bound outer) + | otherwise = Var (Free (Nil:|>name)) + freeL outer name + | name == c = Covar (Bound outer) + | otherwise = Covar (Free (Nil:|>name)) + boundR _ inner = Var (Bound inner) + boundL _ inner = Covar (Bound inner) + +instantiateLR :: Term -> Coterm -> (Scope -> Command) +instantiateLR t c = replace freeR boundR freeL boundL . getScope where + freeR _ name = Var (Free (Nil:|>name)) + freeL _ name = Covar (Free (Nil:|>name)) + boundR outer inner + | outer == inner = t + | otherwise = Var (Bound inner) + boundL outer inner + | outer == inner = c + | otherwise = Covar (Bound inner) + +replaceTerm :: Index -> Index -> (Index -> Name -> Term) -> (Index -> Index -> Term) -> (Index -> Name -> Coterm) -> (Index -> Index -> Coterm) -> (Term -> Term) +replaceTerm outerL outerR freeR boundR freeL boundL within = case within of + Var (Free (Nil:|>n)) -> freeR outerR n + Var (Free _) -> within + Var (Bound inner) -> boundR outerR inner + MuR b -> MuR (replaceCommand (succ outerL) outerR freeR boundR freeL boundL b) + LamR b -> LamR (replaceCommand (succ outerL) (succ outerR) freeR boundR freeL boundL b) + SumR i a -> SumR i (replaceTerm outerL outerR freeR boundR freeL boundL a) + BottomR b -> BottomR (replaceCommand outerL outerR freeR boundR freeL boundL b) + UnitR -> within + PrdR a b -> PrdR (replaceTerm outerL outerR freeR boundR freeL boundL a) (replaceTerm outerL outerR freeR boundR freeL boundL b) + StringR _ -> within + +replaceCoterm :: Index -> Index -> (Index -> Name -> Term) -> (Index -> Index -> Term) -> (Index -> Name -> Coterm) -> (Index -> Index -> Coterm) -> (Coterm -> Coterm) +replaceCoterm outerL outerR freeR boundR freeL boundL within = case within of + Covar (Free (Nil:|>n)) -> freeL outerL n + Covar (Free _) -> within + Covar (Bound inner) -> boundL outerL inner + MuL b -> MuL (replaceCommand outerL (succ outerR) freeR boundR freeL boundL b) + LamL a k -> LamL (replaceTerm outerL outerR freeR boundR freeL boundL a) (replaceCoterm outerL outerR freeR boundR freeL boundL k) + SumL cs -> SumL (map (replaceCoterm outerL outerR freeR boundR freeL boundL) cs) + UnitL -> within + PrdL1 k -> PrdL1 (replaceCoterm outerL outerR freeR boundR freeL boundL k) + PrdL2 k -> PrdL2 (replaceCoterm outerL outerR freeR boundR freeL boundL k) + +replaceCommand :: Index -> Index -> (Index -> Name -> Term) -> (Index -> Index -> Term) -> (Index -> Name -> Coterm) -> (Index -> Index -> Coterm) -> (Command -> Command) +replaceCommand outerL outerR freeR boundR freeL boundL = \case + t :|: c -> replaceTerm outerL outerR freeR boundR freeL boundL t :|: replaceCoterm outerL outerR freeR boundR freeL boundL c + Let t b -> Let (replaceTerm outerL outerR freeR boundR freeL boundL t) (replaceCommand outerL (succ outerR) freeR boundR freeL boundL b) + +replace :: (Index -> Name -> Term) -> (Index -> Index -> Term) -> (Index -> Name -> Coterm) -> (Index -> Index -> Coterm) -> (Command -> Command) +replace freeR boundR freeL boundL = replaceCommand 0 0 freeR boundR freeL boundL From 423b2c8f450fb24f988e08f11e70e1662c0487d8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 07:17:29 -0400 Subject: [PATCH 1186/1324] replace takes pairs of higher-order functions. --- src/Facet/Sequent/Expr.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 238a9f3e3..f3b682a36 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -54,7 +54,7 @@ data Command newtype Scope = Scope { getScope :: Command } abstractLR :: Name -> Name -> (Command -> Scope) -abstractLR t c = Scope . replace freeR boundR freeL boundL where +abstractLR t c = Scope . replace (freeR, boundR) (freeL, boundL) where freeR outer name | name == t = Var (Bound outer) | otherwise = Var (Free (Nil:|>name)) @@ -65,7 +65,7 @@ abstractLR t c = Scope . replace freeR boundR freeL boundL where boundL _ inner = Covar (Bound inner) instantiateLR :: Term -> Coterm -> (Scope -> Command) -instantiateLR t c = replace freeR boundR freeL boundL . getScope where +instantiateLR t c = replace (freeR, boundR) (freeL, boundL) . getScope where freeR _ name = Var (Free (Nil:|>name)) freeL _ name = Covar (Free (Nil:|>name)) boundR outer inner @@ -105,5 +105,5 @@ replaceCommand outerL outerR freeR boundR freeL boundL = \case t :|: c -> replaceTerm outerL outerR freeR boundR freeL boundL t :|: replaceCoterm outerL outerR freeR boundR freeL boundL c Let t b -> Let (replaceTerm outerL outerR freeR boundR freeL boundL t) (replaceCommand outerL (succ outerR) freeR boundR freeL boundL b) -replace :: (Index -> Name -> Term) -> (Index -> Index -> Term) -> (Index -> Name -> Coterm) -> (Index -> Index -> Coterm) -> (Command -> Command) -replace freeR boundR freeL boundL = replaceCommand 0 0 freeR boundR freeL boundL +replace :: (Index -> Name -> Term, Index -> Index -> Term) -> (Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Command -> Command) +replace (freeR, boundR) (freeL, boundL) = replaceCommand 0 0 freeR boundR freeL boundL From f568fe9aca1fff42b346ae3f1fc78d1b42c07526 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 07:19:47 -0400 Subject: [PATCH 1187/1324] Take the left index with the left functions. --- src/Facet/Sequent/Expr.hs | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index f3b682a36..7b3ae3765 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -75,35 +75,35 @@ instantiateLR t c = replace (freeR, boundR) (freeL, boundL) . getScope where | outer == inner = c | otherwise = Covar (Bound inner) -replaceTerm :: Index -> Index -> (Index -> Name -> Term) -> (Index -> Index -> Term) -> (Index -> Name -> Coterm) -> (Index -> Index -> Coterm) -> (Term -> Term) -replaceTerm outerL outerR freeR boundR freeL boundL within = case within of +replaceTerm :: Index -> (Index -> Name -> Term) -> (Index -> Index -> Term) -> Index -> (Index -> Name -> Coterm) -> (Index -> Index -> Coterm) -> (Term -> Term) +replaceTerm outerR freeR boundR outerL freeL boundL within = case within of Var (Free (Nil:|>n)) -> freeR outerR n Var (Free _) -> within Var (Bound inner) -> boundR outerR inner - MuR b -> MuR (replaceCommand (succ outerL) outerR freeR boundR freeL boundL b) - LamR b -> LamR (replaceCommand (succ outerL) (succ outerR) freeR boundR freeL boundL b) - SumR i a -> SumR i (replaceTerm outerL outerR freeR boundR freeL boundL a) - BottomR b -> BottomR (replaceCommand outerL outerR freeR boundR freeL boundL b) + MuR b -> MuR (replaceCommand outerR freeR boundR (succ outerL) freeL boundL b) + LamR b -> LamR (replaceCommand (succ outerR) freeR boundR (succ outerL) freeL boundL b) + SumR i a -> SumR i (replaceTerm outerR freeR boundR outerL freeL boundL a) + BottomR b -> BottomR (replaceCommand outerR freeR boundR outerL freeL boundL b) UnitR -> within - PrdR a b -> PrdR (replaceTerm outerL outerR freeR boundR freeL boundL a) (replaceTerm outerL outerR freeR boundR freeL boundL b) + PrdR a b -> PrdR (replaceTerm outerR freeR boundR outerL freeL boundL a) (replaceTerm outerR freeR boundR outerL freeL boundL b) StringR _ -> within -replaceCoterm :: Index -> Index -> (Index -> Name -> Term) -> (Index -> Index -> Term) -> (Index -> Name -> Coterm) -> (Index -> Index -> Coterm) -> (Coterm -> Coterm) -replaceCoterm outerL outerR freeR boundR freeL boundL within = case within of +replaceCoterm :: Index -> (Index -> Name -> Term) -> (Index -> Index -> Term) -> Index -> (Index -> Name -> Coterm) -> (Index -> Index -> Coterm) -> (Coterm -> Coterm) +replaceCoterm outerR freeR boundR outerL freeL boundL within = case within of Covar (Free (Nil:|>n)) -> freeL outerL n Covar (Free _) -> within Covar (Bound inner) -> boundL outerL inner - MuL b -> MuL (replaceCommand outerL (succ outerR) freeR boundR freeL boundL b) - LamL a k -> LamL (replaceTerm outerL outerR freeR boundR freeL boundL a) (replaceCoterm outerL outerR freeR boundR freeL boundL k) - SumL cs -> SumL (map (replaceCoterm outerL outerR freeR boundR freeL boundL) cs) + MuL b -> MuL (replaceCommand (succ outerR) freeR boundR outerL freeL boundL b) + LamL a k -> LamL (replaceTerm outerR freeR boundR outerL freeL boundL a) (replaceCoterm outerR freeR boundR outerL freeL boundL k) + SumL cs -> SumL (map (replaceCoterm outerR freeR boundR outerL freeL boundL) cs) UnitL -> within - PrdL1 k -> PrdL1 (replaceCoterm outerL outerR freeR boundR freeL boundL k) - PrdL2 k -> PrdL2 (replaceCoterm outerL outerR freeR boundR freeL boundL k) + PrdL1 k -> PrdL1 (replaceCoterm outerR freeR boundR outerL freeL boundL k) + PrdL2 k -> PrdL2 (replaceCoterm outerR freeR boundR outerL freeL boundL k) -replaceCommand :: Index -> Index -> (Index -> Name -> Term) -> (Index -> Index -> Term) -> (Index -> Name -> Coterm) -> (Index -> Index -> Coterm) -> (Command -> Command) -replaceCommand outerL outerR freeR boundR freeL boundL = \case - t :|: c -> replaceTerm outerL outerR freeR boundR freeL boundL t :|: replaceCoterm outerL outerR freeR boundR freeL boundL c - Let t b -> Let (replaceTerm outerL outerR freeR boundR freeL boundL t) (replaceCommand outerL (succ outerR) freeR boundR freeL boundL b) +replaceCommand :: Index -> (Index -> Name -> Term) -> (Index -> Index -> Term) -> Index -> (Index -> Name -> Coterm) -> (Index -> Index -> Coterm) -> (Command -> Command) +replaceCommand outerR freeR boundR outerL freeL boundL = \case + t :|: c -> replaceTerm outerR freeR boundR outerL freeL boundL t :|: replaceCoterm outerR freeR boundR outerL freeL boundL c + Let t b -> Let (replaceTerm outerR freeR boundR outerL freeL boundL t) (replaceCommand (succ outerR) freeR boundR outerL freeL boundL b) replace :: (Index -> Name -> Term, Index -> Index -> Term) -> (Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Command -> Command) -replace (freeR, boundR) (freeL, boundL) = replaceCommand 0 0 freeR boundR freeL boundL +replace (freeR, boundR) (freeL, boundL) = replaceCommand 0 freeR boundR 0 freeL boundL From 63cdf478f98a016edfa3bf1bedf12961259b73ec Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 07:22:52 -0400 Subject: [PATCH 1188/1324] Replacement takes triples. --- src/Facet/Sequent/Expr.hs | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 7b3ae3765..195078d50 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -75,35 +75,35 @@ instantiateLR t c = replace (freeR, boundR) (freeL, boundL) . getScope where | outer == inner = c | otherwise = Covar (Bound inner) -replaceTerm :: Index -> (Index -> Name -> Term) -> (Index -> Index -> Term) -> Index -> (Index -> Name -> Coterm) -> (Index -> Index -> Coterm) -> (Term -> Term) -replaceTerm outerR freeR boundR outerL freeL boundL within = case within of +replaceTerm :: (Index, Index -> Name -> Term, Index -> Index -> Term) -> (Index, Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Term -> Term) +replaceTerm (outerR, freeR, boundR) (outerL, freeL, boundL) within = case within of Var (Free (Nil:|>n)) -> freeR outerR n Var (Free _) -> within Var (Bound inner) -> boundR outerR inner - MuR b -> MuR (replaceCommand outerR freeR boundR (succ outerL) freeL boundL b) - LamR b -> LamR (replaceCommand (succ outerR) freeR boundR (succ outerL) freeL boundL b) - SumR i a -> SumR i (replaceTerm outerR freeR boundR outerL freeL boundL a) - BottomR b -> BottomR (replaceCommand outerR freeR boundR outerL freeL boundL b) + MuR b -> MuR (replaceCommand (outerR, freeR, boundR) (succ outerL, freeL, boundL) b) + LamR b -> LamR (replaceCommand (succ outerR, freeR, boundR) (succ outerL, freeL, boundL) b) + SumR i a -> SumR i (replaceTerm (outerR, freeR, boundR) (outerL, freeL, boundL) a) + BottomR b -> BottomR (replaceCommand (outerR, freeR, boundR) (outerL, freeL, boundL) b) UnitR -> within - PrdR a b -> PrdR (replaceTerm outerR freeR boundR outerL freeL boundL a) (replaceTerm outerR freeR boundR outerL freeL boundL b) + PrdR a b -> PrdR (replaceTerm (outerR, freeR, boundR) (outerL, freeL, boundL) a) (replaceTerm (outerR, freeR, boundR) (outerL, freeL, boundL) b) StringR _ -> within -replaceCoterm :: Index -> (Index -> Name -> Term) -> (Index -> Index -> Term) -> Index -> (Index -> Name -> Coterm) -> (Index -> Index -> Coterm) -> (Coterm -> Coterm) -replaceCoterm outerR freeR boundR outerL freeL boundL within = case within of +replaceCoterm :: (Index, Index -> Name -> Term, Index -> Index -> Term) -> (Index, Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Coterm -> Coterm) +replaceCoterm (outerR, freeR, boundR) (outerL, freeL, boundL) within = case within of Covar (Free (Nil:|>n)) -> freeL outerL n Covar (Free _) -> within Covar (Bound inner) -> boundL outerL inner - MuL b -> MuL (replaceCommand (succ outerR) freeR boundR outerL freeL boundL b) - LamL a k -> LamL (replaceTerm outerR freeR boundR outerL freeL boundL a) (replaceCoterm outerR freeR boundR outerL freeL boundL k) - SumL cs -> SumL (map (replaceCoterm outerR freeR boundR outerL freeL boundL) cs) + MuL b -> MuL (replaceCommand (succ outerR, freeR, boundR) (outerL, freeL, boundL) b) + LamL a k -> LamL (replaceTerm (outerR, freeR, boundR) (outerL, freeL, boundL) a) (replaceCoterm (outerR, freeR, boundR) (outerL, freeL, boundL) k) + SumL cs -> SumL (map (replaceCoterm (outerR, freeR, boundR) (outerL, freeL, boundL)) cs) UnitL -> within - PrdL1 k -> PrdL1 (replaceCoterm outerR freeR boundR outerL freeL boundL k) - PrdL2 k -> PrdL2 (replaceCoterm outerR freeR boundR outerL freeL boundL k) + PrdL1 k -> PrdL1 (replaceCoterm (outerR, freeR, boundR) (outerL, freeL, boundL) k) + PrdL2 k -> PrdL2 (replaceCoterm (outerR, freeR, boundR) (outerL, freeL, boundL) k) -replaceCommand :: Index -> (Index -> Name -> Term) -> (Index -> Index -> Term) -> Index -> (Index -> Name -> Coterm) -> (Index -> Index -> Coterm) -> (Command -> Command) -replaceCommand outerR freeR boundR outerL freeL boundL = \case - t :|: c -> replaceTerm outerR freeR boundR outerL freeL boundL t :|: replaceCoterm outerR freeR boundR outerL freeL boundL c - Let t b -> Let (replaceTerm outerR freeR boundR outerL freeL boundL t) (replaceCommand (succ outerR) freeR boundR outerL freeL boundL b) +replaceCommand :: (Index, Index -> Name -> Term, Index -> Index -> Term) -> (Index, Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Command -> Command) +replaceCommand (outerR, freeR, boundR) (outerL, freeL, boundL) = \case + t :|: c -> replaceTerm (outerR, freeR, boundR) (outerL, freeL, boundL) t :|: replaceCoterm (outerR, freeR, boundR) (outerL, freeL, boundL) c + Let t b -> Let (replaceTerm (outerR, freeR, boundR) (outerL, freeL, boundL) t) (replaceCommand (succ outerR, freeR, boundR) (outerL, freeL, boundL) b) replace :: (Index -> Name -> Term, Index -> Index -> Term) -> (Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Command -> Command) -replace (freeR, boundR) (freeL, boundL) = replaceCommand 0 freeR boundR 0 freeL boundL +replace (freeR, boundR) (freeL, boundL) = replaceCommand (0, freeR, boundR) (0, freeL, boundL) From ba3ed9a1d04d13722db283837f1a7a3c8b75f258 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 07:25:23 -0400 Subject: [PATCH 1189/1324] Flip replacement. --- src/Facet/Sequent/Expr.hs | 44 +++++++++++++++++++-------------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 195078d50..86a66404f 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -54,7 +54,7 @@ data Command newtype Scope = Scope { getScope :: Command } abstractLR :: Name -> Name -> (Command -> Scope) -abstractLR t c = Scope . replace (freeR, boundR) (freeL, boundL) where +abstractLR t c = Scope . replace (freeL, boundL) (freeR, boundR) where freeR outer name | name == t = Var (Bound outer) | otherwise = Var (Free (Nil:|>name)) @@ -65,7 +65,7 @@ abstractLR t c = Scope . replace (freeR, boundR) (freeL, boundL) where boundL _ inner = Covar (Bound inner) instantiateLR :: Term -> Coterm -> (Scope -> Command) -instantiateLR t c = replace (freeR, boundR) (freeL, boundL) . getScope where +instantiateLR t c = replace (freeL, boundL) (freeR, boundR) . getScope where freeR _ name = Var (Free (Nil:|>name)) freeL _ name = Covar (Free (Nil:|>name)) boundR outer inner @@ -75,35 +75,35 @@ instantiateLR t c = replace (freeR, boundR) (freeL, boundL) . getScope where | outer == inner = c | otherwise = Covar (Bound inner) -replaceTerm :: (Index, Index -> Name -> Term, Index -> Index -> Term) -> (Index, Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Term -> Term) -replaceTerm (outerR, freeR, boundR) (outerL, freeL, boundL) within = case within of +replaceTerm :: (Index, Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Index, Index -> Name -> Term, Index -> Index -> Term) -> (Term -> Term) +replaceTerm (outerL, freeL, boundL) (outerR, freeR, boundR) within = case within of Var (Free (Nil:|>n)) -> freeR outerR n Var (Free _) -> within Var (Bound inner) -> boundR outerR inner - MuR b -> MuR (replaceCommand (outerR, freeR, boundR) (succ outerL, freeL, boundL) b) - LamR b -> LamR (replaceCommand (succ outerR, freeR, boundR) (succ outerL, freeL, boundL) b) - SumR i a -> SumR i (replaceTerm (outerR, freeR, boundR) (outerL, freeL, boundL) a) - BottomR b -> BottomR (replaceCommand (outerR, freeR, boundR) (outerL, freeL, boundL) b) + MuR b -> MuR (replaceCommand (succ outerL, freeL, boundL) (outerR, freeR, boundR) b) + LamR b -> LamR (replaceCommand (succ outerL, freeL, boundL) (succ outerR, freeR, boundR) b) + SumR i a -> SumR i (replaceTerm (outerL, freeL, boundL) (outerR, freeR, boundR) a) + BottomR b -> BottomR (replaceCommand (outerL, freeL, boundL) (outerR, freeR, boundR) b) UnitR -> within - PrdR a b -> PrdR (replaceTerm (outerR, freeR, boundR) (outerL, freeL, boundL) a) (replaceTerm (outerR, freeR, boundR) (outerL, freeL, boundL) b) + PrdR a b -> PrdR (replaceTerm (outerL, freeL, boundL) (outerR, freeR, boundR) a) (replaceTerm (outerL, freeL, boundL) (outerR, freeR, boundR) b) StringR _ -> within -replaceCoterm :: (Index, Index -> Name -> Term, Index -> Index -> Term) -> (Index, Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Coterm -> Coterm) -replaceCoterm (outerR, freeR, boundR) (outerL, freeL, boundL) within = case within of +replaceCoterm :: (Index, Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Index, Index -> Name -> Term, Index -> Index -> Term) -> (Coterm -> Coterm) +replaceCoterm (outerL, freeL, boundL) (outerR, freeR, boundR) within = case within of Covar (Free (Nil:|>n)) -> freeL outerL n Covar (Free _) -> within Covar (Bound inner) -> boundL outerL inner - MuL b -> MuL (replaceCommand (succ outerR, freeR, boundR) (outerL, freeL, boundL) b) - LamL a k -> LamL (replaceTerm (outerR, freeR, boundR) (outerL, freeL, boundL) a) (replaceCoterm (outerR, freeR, boundR) (outerL, freeL, boundL) k) - SumL cs -> SumL (map (replaceCoterm (outerR, freeR, boundR) (outerL, freeL, boundL)) cs) + MuL b -> MuL (replaceCommand (outerL, freeL, boundL) (succ outerR, freeR, boundR) b) + LamL a k -> LamL (replaceTerm (outerL, freeL, boundL) (outerR, freeR, boundR) a) (replaceCoterm (outerL, freeL, boundL) (outerR, freeR, boundR) k) + SumL cs -> SumL (map (replaceCoterm (outerL, freeL, boundL) (outerR, freeR, boundR)) cs) UnitL -> within - PrdL1 k -> PrdL1 (replaceCoterm (outerR, freeR, boundR) (outerL, freeL, boundL) k) - PrdL2 k -> PrdL2 (replaceCoterm (outerR, freeR, boundR) (outerL, freeL, boundL) k) + PrdL1 k -> PrdL1 (replaceCoterm (outerL, freeL, boundL) (outerR, freeR, boundR) k) + PrdL2 k -> PrdL2 (replaceCoterm (outerL, freeL, boundL) (outerR, freeR, boundR) k) -replaceCommand :: (Index, Index -> Name -> Term, Index -> Index -> Term) -> (Index, Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Command -> Command) -replaceCommand (outerR, freeR, boundR) (outerL, freeL, boundL) = \case - t :|: c -> replaceTerm (outerR, freeR, boundR) (outerL, freeL, boundL) t :|: replaceCoterm (outerR, freeR, boundR) (outerL, freeL, boundL) c - Let t b -> Let (replaceTerm (outerR, freeR, boundR) (outerL, freeL, boundL) t) (replaceCommand (succ outerR, freeR, boundR) (outerL, freeL, boundL) b) +replaceCommand :: (Index, Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Index, Index -> Name -> Term, Index -> Index -> Term) -> (Command -> Command) +replaceCommand (outerL, freeL, boundL) (outerR, freeR, boundR) = \case + t :|: c -> replaceTerm (outerL, freeL, boundL) (outerR, freeR, boundR) t :|: replaceCoterm (outerL, freeL, boundL) (outerR, freeR, boundR) c + Let t b -> Let (replaceTerm (outerL, freeL, boundL) (outerR, freeR, boundR) t) (replaceCommand (outerL, freeL, boundL) (succ outerR, freeR, boundR) b) -replace :: (Index -> Name -> Term, Index -> Index -> Term) -> (Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Command -> Command) -replace (freeR, boundR) (freeL, boundL) = replaceCommand (0, freeR, boundR) (0, freeL, boundL) +replace :: (Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Index -> Name -> Term, Index -> Index -> Term) -> (Command -> Command) +replace (freeL, boundL) (freeR, boundR) = replaceCommand (0, freeL, boundL) (0, freeR, boundR) From 9c25a50bf85f8ee3f14d575e2fdbffd95e7fa960 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 07:25:53 -0400 Subject: [PATCH 1190/1324] :fire: replace. --- src/Facet/Sequent/Expr.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 86a66404f..55dd59d49 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -54,7 +54,7 @@ data Command newtype Scope = Scope { getScope :: Command } abstractLR :: Name -> Name -> (Command -> Scope) -abstractLR t c = Scope . replace (freeL, boundL) (freeR, boundR) where +abstractLR t c = Scope . replaceCommand (0, freeL, boundL) (0, freeR, boundR) where freeR outer name | name == t = Var (Bound outer) | otherwise = Var (Free (Nil:|>name)) @@ -65,7 +65,7 @@ abstractLR t c = Scope . replace (freeL, boundL) (freeR, boundR) where boundL _ inner = Covar (Bound inner) instantiateLR :: Term -> Coterm -> (Scope -> Command) -instantiateLR t c = replace (freeL, boundL) (freeR, boundR) . getScope where +instantiateLR t c = replaceCommand (0, freeL, boundL) (0, freeR, boundR) . getScope where freeR _ name = Var (Free (Nil:|>name)) freeL _ name = Covar (Free (Nil:|>name)) boundR outer inner @@ -104,6 +104,3 @@ replaceCommand :: (Index, Index -> Name -> Coterm, Index -> Index -> Coterm) -> replaceCommand (outerL, freeL, boundL) (outerR, freeR, boundR) = \case t :|: c -> replaceTerm (outerL, freeL, boundL) (outerR, freeR, boundR) t :|: replaceCoterm (outerL, freeL, boundL) (outerR, freeR, boundR) c Let t b -> Let (replaceTerm (outerL, freeL, boundL) (outerR, freeR, boundR) t) (replaceCommand (outerL, freeL, boundL) (succ outerR, freeR, boundR) b) - -replace :: (Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Index -> Name -> Term, Index -> Index -> Term) -> (Command -> Command) -replace (freeL, boundL) (freeR, boundR) = replaceCommand (0, freeL, boundL) (0, freeR, boundR) From b727ac58cf1945dc5540d3f9354674188dd25ff7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 07:27:21 -0400 Subject: [PATCH 1191/1324] Define a type of replacements. --- src/Facet/Sequent/Expr.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 55dd59d49..555c05f5f 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -75,6 +75,12 @@ instantiateLR t c = replaceCommand (0, freeL, boundL) (0, freeR, boundR) . getSc | outer == inner = c | otherwise = Covar (Bound inner) +data Replacer t = Replacer + { outer :: Index + , free :: Index -> Name -> t + , bound :: Index -> Index -> t + } + replaceTerm :: (Index, Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Index, Index -> Name -> Term, Index -> Index -> Term) -> (Term -> Term) replaceTerm (outerL, freeL, boundL) (outerR, freeR, boundR) within = case within of Var (Free (Nil:|>n)) -> freeR outerR n From 93a09b36dc31b7c50ab4af5076ea0de2f52ea884 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 07:28:49 -0400 Subject: [PATCH 1192/1324] Define a lens for a replacer's index. --- src/Facet/Sequent/Expr.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 555c05f5f..7e4f37536 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -16,6 +16,7 @@ import Facet.Name import Facet.Snoc import Facet.Snoc.NonEmpty import Facet.Syntax +import Fresnel.Lens (Lens', lens) -- Terms @@ -81,6 +82,9 @@ data Replacer t = Replacer , bound :: Index -> Index -> t } +outer_ :: Lens' (Replacer t) Index +outer_ = lens outer (\ Replacer{ free, bound } outer -> Replacer{ outer, free, bound }) + replaceTerm :: (Index, Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Index, Index -> Name -> Term, Index -> Index -> Term) -> (Term -> Term) replaceTerm (outerL, freeL, boundL) (outerR, freeR, boundR) within = case within of Var (Free (Nil:|>n)) -> freeR outerR n From 4272cd7d8d9c74e38ea25a6836c0c6f7d8b89148 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 07:30:57 -0400 Subject: [PATCH 1193/1324] Define a helper for free constructions. --- src/Facet/Sequent/Expr.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 7e4f37536..1eb7725d1 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -85,6 +85,9 @@ data Replacer t = Replacer outer_ :: Lens' (Replacer t) Index outer_ = lens outer (\ Replacer{ free, bound } outer -> Replacer{ outer, free, bound }) +free' :: Replacer t -> Name -> t +free' Replacer{ outer, free } = free outer + replaceTerm :: (Index, Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Index, Index -> Name -> Term, Index -> Index -> Term) -> (Term -> Term) replaceTerm (outerL, freeL, boundL) (outerR, freeR, boundR) within = case within of Var (Free (Nil:|>n)) -> freeR outerR n From 83b61f4f94e5c37b415abe76543f7faf7095d447 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 07:31:25 -0400 Subject: [PATCH 1194/1324] Define a helper for bound constructions. --- src/Facet/Sequent/Expr.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 1eb7725d1..8e04b67f8 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -88,6 +88,9 @@ outer_ = lens outer (\ Replacer{ free, bound } outer -> Replacer{ outer, free, b free' :: Replacer t -> Name -> t free' Replacer{ outer, free } = free outer +bound' :: Replacer t -> Index -> t +bound' Replacer{ outer, bound } = bound outer + replaceTerm :: (Index, Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Index, Index -> Name -> Term, Index -> Index -> Term) -> (Term -> Term) replaceTerm (outerL, freeL, boundL) (outerR, freeR, boundR) within = case within of Var (Free (Nil:|>n)) -> freeR outerR n From 7612051f1ba60e57060815d4cc987fc53a965a99 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 07:35:04 -0400 Subject: [PATCH 1195/1324] Replace using Replacers. --- src/Facet/Sequent/Expr.hs | 50 ++++++++++++++++++++------------------- 1 file changed, 26 insertions(+), 24 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 8e04b67f8..203567448 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -11,12 +11,14 @@ module Facet.Sequent.Expr , instantiateLR ) where +import Data.Function ((&)) import Data.Text (Text) import Facet.Name import Facet.Snoc import Facet.Snoc.NonEmpty import Facet.Syntax import Fresnel.Lens (Lens', lens) +import Fresnel.Setter ((%~)) -- Terms @@ -55,7 +57,7 @@ data Command newtype Scope = Scope { getScope :: Command } abstractLR :: Name -> Name -> (Command -> Scope) -abstractLR t c = Scope . replaceCommand (0, freeL, boundL) (0, freeR, boundR) where +abstractLR t c = Scope . replaceCommand (Replacer 0 freeL boundL) (Replacer 0 freeR boundR) where freeR outer name | name == t = Var (Bound outer) | otherwise = Var (Free (Nil:|>name)) @@ -66,7 +68,7 @@ abstractLR t c = Scope . replaceCommand (0, freeL, boundL) (0, freeR, boundR) wh boundL _ inner = Covar (Bound inner) instantiateLR :: Term -> Coterm -> (Scope -> Command) -instantiateLR t c = replaceCommand (0, freeL, boundL) (0, freeR, boundR) . getScope where +instantiateLR t c = replaceCommand (Replacer 0 freeL boundL) (Replacer 0 freeR boundR) . getScope where freeR _ name = Var (Free (Nil:|>name)) freeL _ name = Covar (Free (Nil:|>name)) boundR outer inner @@ -91,32 +93,32 @@ free' Replacer{ outer, free } = free outer bound' :: Replacer t -> Index -> t bound' Replacer{ outer, bound } = bound outer -replaceTerm :: (Index, Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Index, Index -> Name -> Term, Index -> Index -> Term) -> (Term -> Term) -replaceTerm (outerL, freeL, boundL) (outerR, freeR, boundR) within = case within of - Var (Free (Nil:|>n)) -> freeR outerR n +replaceTerm :: Replacer Coterm -> Replacer Term -> (Term -> Term) +replaceTerm l r within = case within of + Var (Free (Nil:|>n)) -> free' r n Var (Free _) -> within - Var (Bound inner) -> boundR outerR inner - MuR b -> MuR (replaceCommand (succ outerL, freeL, boundL) (outerR, freeR, boundR) b) - LamR b -> LamR (replaceCommand (succ outerL, freeL, boundL) (succ outerR, freeR, boundR) b) - SumR i a -> SumR i (replaceTerm (outerL, freeL, boundL) (outerR, freeR, boundR) a) - BottomR b -> BottomR (replaceCommand (outerL, freeL, boundL) (outerR, freeR, boundR) b) + Var (Bound inner) -> bound' r inner + MuR b -> MuR (replaceCommand (l & outer_ %~ succ) r b) + LamR b -> LamR (replaceCommand (l & outer_ %~ succ) (r & outer_ %~ succ) b) + SumR i a -> SumR i (replaceTerm l r a) + BottomR b -> BottomR (replaceCommand l r b) UnitR -> within - PrdR a b -> PrdR (replaceTerm (outerL, freeL, boundL) (outerR, freeR, boundR) a) (replaceTerm (outerL, freeL, boundL) (outerR, freeR, boundR) b) + PrdR a b -> PrdR (replaceTerm l r a) (replaceTerm l r b) StringR _ -> within -replaceCoterm :: (Index, Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Index, Index -> Name -> Term, Index -> Index -> Term) -> (Coterm -> Coterm) -replaceCoterm (outerL, freeL, boundL) (outerR, freeR, boundR) within = case within of - Covar (Free (Nil:|>n)) -> freeL outerL n +replaceCoterm :: Replacer Coterm -> Replacer Term -> (Coterm -> Coterm) +replaceCoterm l r within = case within of + Covar (Free (Nil:|>n)) -> free' l n Covar (Free _) -> within - Covar (Bound inner) -> boundL outerL inner - MuL b -> MuL (replaceCommand (outerL, freeL, boundL) (succ outerR, freeR, boundR) b) - LamL a k -> LamL (replaceTerm (outerL, freeL, boundL) (outerR, freeR, boundR) a) (replaceCoterm (outerL, freeL, boundL) (outerR, freeR, boundR) k) - SumL cs -> SumL (map (replaceCoterm (outerL, freeL, boundL) (outerR, freeR, boundR)) cs) + Covar (Bound inner) -> bound' l inner + MuL b -> MuL (replaceCommand l (r & outer_ %~ succ) b) + LamL a k -> LamL (replaceTerm l r a) (replaceCoterm l r k) + SumL cs -> SumL (map (replaceCoterm l r) cs) UnitL -> within - PrdL1 k -> PrdL1 (replaceCoterm (outerL, freeL, boundL) (outerR, freeR, boundR) k) - PrdL2 k -> PrdL2 (replaceCoterm (outerL, freeL, boundL) (outerR, freeR, boundR) k) + PrdL1 k -> PrdL1 (replaceCoterm l r k) + PrdL2 k -> PrdL2 (replaceCoterm l r k) -replaceCommand :: (Index, Index -> Name -> Coterm, Index -> Index -> Coterm) -> (Index, Index -> Name -> Term, Index -> Index -> Term) -> (Command -> Command) -replaceCommand (outerL, freeL, boundL) (outerR, freeR, boundR) = \case - t :|: c -> replaceTerm (outerL, freeL, boundL) (outerR, freeR, boundR) t :|: replaceCoterm (outerL, freeL, boundL) (outerR, freeR, boundR) c - Let t b -> Let (replaceTerm (outerL, freeL, boundL) (outerR, freeR, boundR) t) (replaceCommand (outerL, freeL, boundL) (succ outerR, freeR, boundR) b) +replaceCommand :: Replacer Coterm -> Replacer Term -> (Command -> Command) +replaceCommand l r = \case + t :|: c -> replaceTerm l r t :|: replaceCoterm l r c + Let t b -> Let (replaceTerm l r t) (replaceCommand l (r & outer_ %~ succ) b) From ded46dbefc5f2f62cf35b66d0a6fd48582960f35 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 07:40:11 -0400 Subject: [PATCH 1196/1324] Replacers are optional. --- src/Facet/Sequent/Expr.hs | 27 ++++++++++++++------------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 203567448..32a7955e9 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -18,6 +18,7 @@ import Facet.Snoc import Facet.Snoc.NonEmpty import Facet.Syntax import Fresnel.Lens (Lens', lens) +import Fresnel.Maybe import Fresnel.Setter ((%~)) -- Terms @@ -57,7 +58,7 @@ data Command newtype Scope = Scope { getScope :: Command } abstractLR :: Name -> Name -> (Command -> Scope) -abstractLR t c = Scope . replaceCommand (Replacer 0 freeL boundL) (Replacer 0 freeR boundR) where +abstractLR t c = Scope . replaceCommand (Just (Replacer 0 freeL boundL)) (Just (Replacer 0 freeR boundR)) where freeR outer name | name == t = Var (Bound outer) | otherwise = Var (Free (Nil:|>name)) @@ -68,7 +69,7 @@ abstractLR t c = Scope . replaceCommand (Replacer 0 freeL boundL) (Replacer 0 fr boundL _ inner = Covar (Bound inner) instantiateLR :: Term -> Coterm -> (Scope -> Command) -instantiateLR t c = replaceCommand (Replacer 0 freeL boundL) (Replacer 0 freeR boundR) . getScope where +instantiateLR t c = replaceCommand (Just (Replacer 0 freeL boundL)) (Just (Replacer 0 freeR boundR)) . getScope where freeR _ name = Var (Free (Nil:|>name)) freeL _ name = Covar (Free (Nil:|>name)) boundR outer inner @@ -93,32 +94,32 @@ free' Replacer{ outer, free } = free outer bound' :: Replacer t -> Index -> t bound' Replacer{ outer, bound } = bound outer -replaceTerm :: Replacer Coterm -> Replacer Term -> (Term -> Term) +replaceTerm :: Maybe (Replacer Coterm) -> Maybe (Replacer Term) -> (Term -> Term) replaceTerm l r within = case within of - Var (Free (Nil:|>n)) -> free' r n + Var (Free (Nil:|>n)) -> maybe (const within) free' r n Var (Free _) -> within - Var (Bound inner) -> bound' r inner - MuR b -> MuR (replaceCommand (l & outer_ %~ succ) r b) - LamR b -> LamR (replaceCommand (l & outer_ %~ succ) (r & outer_ %~ succ) b) + Var (Bound inner) -> maybe (const within) bound' r inner + MuR b -> MuR (replaceCommand (l & _Just.outer_ %~ succ) r b) + LamR b -> LamR (replaceCommand (l & _Just.outer_ %~ succ) (r & _Just.outer_ %~ succ) b) SumR i a -> SumR i (replaceTerm l r a) BottomR b -> BottomR (replaceCommand l r b) UnitR -> within PrdR a b -> PrdR (replaceTerm l r a) (replaceTerm l r b) StringR _ -> within -replaceCoterm :: Replacer Coterm -> Replacer Term -> (Coterm -> Coterm) +replaceCoterm :: Maybe (Replacer Coterm) -> Maybe (Replacer Term) -> (Coterm -> Coterm) replaceCoterm l r within = case within of - Covar (Free (Nil:|>n)) -> free' l n + Covar (Free (Nil:|>n)) -> maybe (const within) free' l n Covar (Free _) -> within - Covar (Bound inner) -> bound' l inner - MuL b -> MuL (replaceCommand l (r & outer_ %~ succ) b) + Covar (Bound inner) -> maybe (const within) bound' l inner + MuL b -> MuL (replaceCommand l (r & _Just.outer_ %~ succ) b) LamL a k -> LamL (replaceTerm l r a) (replaceCoterm l r k) SumL cs -> SumL (map (replaceCoterm l r) cs) UnitL -> within PrdL1 k -> PrdL1 (replaceCoterm l r k) PrdL2 k -> PrdL2 (replaceCoterm l r k) -replaceCommand :: Replacer Coterm -> Replacer Term -> (Command -> Command) +replaceCommand :: Maybe (Replacer Coterm) -> Maybe (Replacer Term) -> (Command -> Command) replaceCommand l r = \case t :|: c -> replaceTerm l r t :|: replaceCoterm l r c - Let t b -> Let (replaceTerm l r t) (replaceCommand l (r & outer_ %~ succ) b) + Let t b -> Let (replaceTerm l r t) (replaceCommand l (r & _Just.outer_ %~ succ) b) From 1e1e18c9b0b5255c144a16eda3d026cebb2a35f3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 07:45:10 -0400 Subject: [PATCH 1197/1324] Top-level abstraction & instantiation are optional. --- src/Facet/Sequent/Expr.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 32a7955e9..a99bde0ac 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -57,25 +57,25 @@ data Command newtype Scope = Scope { getScope :: Command } -abstractLR :: Name -> Name -> (Command -> Scope) -abstractLR t c = Scope . replaceCommand (Just (Replacer 0 freeL boundL)) (Just (Replacer 0 freeR boundR)) where - freeR outer name +abstractLR :: Maybe Name -> Maybe Name -> (Command -> Scope) +abstractLR t c = Scope . replaceCommand (Replacer 0 . freeL <$> c <*> pure boundL) (Replacer 0 . freeR <$> t <*> pure boundR) where + freeR t outer name | name == t = Var (Bound outer) | otherwise = Var (Free (Nil:|>name)) - freeL outer name + freeL c outer name | name == c = Covar (Bound outer) | otherwise = Covar (Free (Nil:|>name)) boundR _ inner = Var (Bound inner) boundL _ inner = Covar (Bound inner) -instantiateLR :: Term -> Coterm -> (Scope -> Command) -instantiateLR t c = replaceCommand (Just (Replacer 0 freeL boundL)) (Just (Replacer 0 freeR boundR)) . getScope where +instantiateLR :: Maybe Term -> Maybe Coterm -> (Scope -> Command) +instantiateLR t c = replaceCommand (Replacer 0 freeL . boundL <$> c) (Replacer 0 freeR . boundR <$> t) . getScope where freeR _ name = Var (Free (Nil:|>name)) freeL _ name = Covar (Free (Nil:|>name)) - boundR outer inner + boundR t outer inner | outer == inner = t | otherwise = Var (Bound inner) - boundL outer inner + boundL c outer inner | outer == inner = c | otherwise = Covar (Bound inner) From d8de5346f4cb73951f4ab48fe8fcb46b8c2a1474 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 07:45:53 -0400 Subject: [PATCH 1198/1324] Simplify the null/null cases. --- src/Facet/Sequent/Expr.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index a99bde0ac..686a72019 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -58,6 +58,7 @@ data Command newtype Scope = Scope { getScope :: Command } abstractLR :: Maybe Name -> Maybe Name -> (Command -> Scope) +abstractLR Nothing Nothing = Scope abstractLR t c = Scope . replaceCommand (Replacer 0 . freeL <$> c <*> pure boundL) (Replacer 0 . freeR <$> t <*> pure boundR) where freeR t outer name | name == t = Var (Bound outer) @@ -69,6 +70,7 @@ abstractLR t c = Scope . replaceCommand (Replacer 0 . freeL <$> c <*> pure bound boundL _ inner = Covar (Bound inner) instantiateLR :: Maybe Term -> Maybe Coterm -> (Scope -> Command) +instantiateLR Nothing Nothing = getScope instantiateLR t c = replaceCommand (Replacer 0 freeL . boundL <$> c) (Replacer 0 freeR . boundR <$> t) . getScope where freeR _ name = Var (Free (Nil:|>name)) freeL _ name = Covar (Free (Nil:|>name)) From 459bfe666a6b7edd9728a77e477d84004ab8ee25 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 07:54:26 -0400 Subject: [PATCH 1199/1324] Flip abstractLR. --- src/Facet/Sequent/Expr.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 686a72019..252daf64a 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -59,7 +59,7 @@ newtype Scope = Scope { getScope :: Command } abstractLR :: Maybe Name -> Maybe Name -> (Command -> Scope) abstractLR Nothing Nothing = Scope -abstractLR t c = Scope . replaceCommand (Replacer 0 . freeL <$> c <*> pure boundL) (Replacer 0 . freeR <$> t <*> pure boundR) where +abstractLR c t = Scope . replaceCommand (Replacer 0 . freeL <$> c <*> pure boundL) (Replacer 0 . freeR <$> t <*> pure boundR) where freeR t outer name | name == t = Var (Bound outer) | otherwise = Var (Free (Nil:|>name)) From c3867be474b06196701a29ed6ca88e295ea858f3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 07:54:42 -0400 Subject: [PATCH 1200/1324] Flip instantiateLR. --- src/Facet/Sequent/Expr.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 252daf64a..4aafa1089 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -69,9 +69,9 @@ abstractLR c t = Scope . replaceCommand (Replacer 0 . freeL <$> c <*> pure bound boundR _ inner = Var (Bound inner) boundL _ inner = Covar (Bound inner) -instantiateLR :: Maybe Term -> Maybe Coterm -> (Scope -> Command) +instantiateLR :: Maybe Coterm -> Maybe Term -> (Scope -> Command) instantiateLR Nothing Nothing = getScope -instantiateLR t c = replaceCommand (Replacer 0 freeL . boundL <$> c) (Replacer 0 freeR . boundR <$> t) . getScope where +instantiateLR c t = replaceCommand (Replacer 0 freeL . boundL <$> c) (Replacer 0 freeR . boundR <$> t) . getScope where freeR _ name = Var (Free (Nil:|>name)) freeL _ name = Covar (Free (Nil:|>name)) boundR t outer inner From fdf9e7164cc53398ee13862473324aa2334d4490 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 07:55:41 -0400 Subject: [PATCH 1201/1324] Define one-sided abstract/instantiate. --- src/Facet/Sequent/Expr.hs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 4aafa1089..eb32cc707 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -7,7 +7,11 @@ module Facet.Sequent.Expr , Command(..) -- * Scopes , Scope +, abstractL +, abstractR , abstractLR +, instantiateL +, instantiateR , instantiateLR ) where @@ -57,6 +61,10 @@ data Command newtype Scope = Scope { getScope :: Command } +abstractL, abstractR :: Maybe Name -> (Command -> Scope) +abstractL c = abstractLR c Nothing +abstractR t = abstractLR Nothing t + abstractLR :: Maybe Name -> Maybe Name -> (Command -> Scope) abstractLR Nothing Nothing = Scope abstractLR c t = Scope . replaceCommand (Replacer 0 . freeL <$> c <*> pure boundL) (Replacer 0 . freeR <$> t <*> pure boundR) where @@ -69,6 +77,12 @@ abstractLR c t = Scope . replaceCommand (Replacer 0 . freeL <$> c <*> pure bound boundR _ inner = Var (Bound inner) boundL _ inner = Covar (Bound inner) +instantiateL :: Maybe Coterm -> (Scope -> Command) +instantiateL c = instantiateLR c Nothing + +instantiateR :: Maybe Term -> (Scope -> Command) +instantiateR t = instantiateLR Nothing t + instantiateLR :: Maybe Coterm -> Maybe Term -> (Scope -> Command) instantiateLR Nothing Nothing = getScope instantiateLR c t = replaceCommand (Replacer 0 freeL . boundL <$> c) (Replacer 0 freeR . boundR <$> t) . getScope where From cf295b181c32d3969451b7dc875b01b5ecbc487e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 07:56:31 -0400 Subject: [PATCH 1202/1324] Define a smart constructor for MuR. --- src/Facet/Sequent/Expr.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index eb32cc707..74486d1e2 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -13,6 +13,8 @@ module Facet.Sequent.Expr , instantiateL , instantiateR , instantiateLR + -- * Smart constructors +, muR ) where import Data.Function ((&)) @@ -139,3 +141,9 @@ replaceCommand :: Maybe (Replacer Coterm) -> Maybe (Replacer Term) -> (Command - replaceCommand l r = \case t :|: c -> replaceTerm l r t :|: replaceCoterm l r c Let t b -> Let (replaceTerm l r t) (replaceCommand l (r & _Just.outer_ %~ succ) b) + + +-- Smart constructors + +muR :: Name -> Command -> Term +muR name body = MuR (getScope (abstractLR (Just name) Nothing body)) From 8c9ba7207fb29c82f6caae5748c4f28a54444b5b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 07:57:24 -0400 Subject: [PATCH 1203/1324] Define a smart constructor for LamR. --- src/Facet/Sequent/Expr.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 74486d1e2..162809458 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -15,6 +15,7 @@ module Facet.Sequent.Expr , instantiateLR -- * Smart constructors , muR +, lamR ) where import Data.Function ((&)) @@ -147,3 +148,6 @@ replaceCommand l r = \case muR :: Name -> Command -> Term muR name body = MuR (getScope (abstractLR (Just name) Nothing body)) + +lamR :: Name -> Name -> Command -> Term +lamR v k body = LamR (getScope (abstractLR (Just v) (Just k) body)) From dfd34903246832519a48af05a3c146d80bcd87a0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 14:12:29 -0400 Subject: [PATCH 1204/1324] :fire: LName. --- src/Facet/Driver.hs | 2 +- src/Facet/Name.hs | 13 ------------- src/Facet/Print.hs | 2 +- 3 files changed, 2 insertions(+), 15 deletions(-) diff --git a/src/Facet/Driver.hs b/src/Facet/Driver.hs index ac82c7f74..ae68e8638 100644 --- a/src/Facet/Driver.hs +++ b/src/Facet/Driver.hs @@ -38,7 +38,7 @@ import qualified Facet.Elab.Term as Elab import Facet.Graph import Facet.Lens import Facet.Module hiding (Import(name), imports, imports_) -import Facet.Name hiding (name) +import Facet.Name import qualified Facet.Notice as Notice import Facet.Notice.Elab (rethrowElabErrors, rethrowElabWarnings) import Facet.Notice.Parser (rethrowParseErrors) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 4899db079..b81b47a03 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -9,7 +9,6 @@ module Facet.Name , __ , QName , prettyQName -, LName(..) , Name(..) , Assoc(..) , Op(..) @@ -78,18 +77,6 @@ prettyQName :: Printer a => QName -> a prettyQName (ns:|>n) = foldr' (surround dot . pretty) (pretty n) ns --- | Local names, consisting of a 'Level' or 'Index' to a pattern in an 'Env' or 'Context' and a 'Name' bound by said pattern. -data LName v = LName - { ident :: v - , name :: Name - } - deriving (Eq, Foldable, Functor, Ord, Show, Traversable) - -instance DeBruijn lv ix => DeBruijn (LName lv) (LName ix) where - toIndexed = fmap . toIndexed - toLeveled = fmap . toLeveled - - -- | Declaration names; a choice of textual or operator names. data Name = T Text diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index e08817f96..681eeb313 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -34,7 +34,7 @@ import Facet.Env as Env import Facet.Interface import Facet.Kind import qualified Facet.Module as C -import Facet.Name as Name hiding (name) +import Facet.Name as Name import Facet.Pattern import Facet.Pretty (lower, upper) import Facet.Print.Options From 7dbfbca2db5d4b23a10fc896b2fb785d5b9a1608 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 17:43:32 -0400 Subject: [PATCH 1205/1324] Define gensym'd names. --- src/Facet/Driver.hs | 5 +++-- src/Facet/Name.hs | 7 +++++-- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/src/Facet/Driver.hs b/src/Facet/Driver.hs index ae68e8638..3ccb6b438 100644 --- a/src/Facet/Driver.hs +++ b/src/Facet/Driver.hs @@ -169,8 +169,9 @@ resolveName searchPaths name = do where toPath components = foldr1 (FP.) (unpack <$> components) unpack = \case - T n -> TS.unpack n - O o -> formatOp (\ a b -> a <> " " <> b) TS.unpack "_" o + T n -> TS.unpack n + O o -> formatOp (\ a b -> a <> " " <> b) TS.unpack "_" o + G n i -> TS.unpack n <> show i -- Errors diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index b81b47a03..c5786d3d7 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -23,6 +23,7 @@ import qualified Data.List.NonEmpty as NE import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as T +import Facet.Pretty (subscript) import Facet.Snoc.NonEmpty import qualified Prettyprinter as P import Silkscreen @@ -81,6 +82,7 @@ prettyQName (ns:|>n) = foldr' (surround dot . pretty) (pretty n) ns data Name = T Text | O Op + | G Text Int deriving (Eq, Ord, Show) instance IsString Name where @@ -88,8 +90,9 @@ instance IsString Name where instance P.Pretty Name where pretty = \case - T n -> P.pretty n - O o -> P.pretty o + T n -> P.pretty n + O o -> P.pretty o + G n i -> P.pretty n <> subscript i -- | Associativity of an infix operator. From f7c8f48b3a3e60e92d9ea43470cbb473a4abdd21 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 17:45:54 -0400 Subject: [PATCH 1206/1324] Construct fresh names. --- src/Facet/Elab/Sequent.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index d1fff6909..96de9b921 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -8,6 +8,8 @@ module Facet.Elab.Sequent , stringS -- * Eliminators , appS + -- * General combinators +, freshName -- * Elaboration , synthExprS , checkExprS @@ -21,6 +23,7 @@ module Facet.Elab.Sequent , check ) where +import Control.Effect.Fresh import Control.Effect.Reader import Control.Effect.State import Control.Effect.Throw @@ -111,6 +114,9 @@ as (m ::: _T) = do a <- check (m ::: _T') pure $ a :==> _T' +freshName :: Has Fresh sig m => Text -> m Name +freshName s = G s <$> fresh + -- Elaboration From f8f8c838f5713cc3d375f7304a972315505e9b97 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 17:46:30 -0400 Subject: [PATCH 1207/1324] Fix a dodgy import, apparently. --- src/Facet/Lexer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Lexer.hs b/src/Facet/Lexer.hs index 547361dfc..f14dc097c 100644 --- a/src/Facet/Lexer.hs +++ b/src/Facet/Lexer.hs @@ -10,7 +10,7 @@ module Facet.Lexer import Data.Char (isSpace) import Data.Text (Text, pack) import Facet.Effect.Parser -import Facet.Name hiding (ident) +import Facet.Name import Facet.Snoc import Facet.Span import Text.Parser.Char From 1be0fb9133ee136c455fde96f9279c1e16155f92 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 17:48:01 -0400 Subject: [PATCH 1208/1324] Define a constructor for QName. --- src/Facet/Name.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index c5786d3d7..8f6719cc6 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -8,6 +8,7 @@ module Facet.Name , Meta(..) , __ , QName +, q , prettyQName , Name(..) , Assoc(..) @@ -24,6 +25,7 @@ import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as T import Facet.Pretty (subscript) +import Facet.Snoc import Facet.Snoc.NonEmpty import qualified Prettyprinter as P import Silkscreen @@ -74,6 +76,9 @@ __ = T T.empty -- | Qualified names, consisting of a module name and declaration name. type QName = NonEmpty Name +q :: Name -> QName +q = (Nil :|>) + prettyQName :: Printer a => QName -> a prettyQName (ns:|>n) = foldr' (surround dot . pretty) (pretty n) ns From 18281554f5c101f233088f1e412a9d6ef14d04ba Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 17:49:25 -0400 Subject: [PATCH 1209/1324] Use the q constructor. --- src/Facet/Print.hs | 2 +- src/Facet/Sequent/Expr.hs | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 681eeb313..936c28d41 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -216,7 +216,7 @@ instance Printable C.Module where (map (\ (C.Import n) -> import' n) is) (map (def . fmap defBody) (view C.toList_ ds)) where - def (n :=: d) = ann (qvar (Nil:|>n) ::: d) + def (n :=: d) = ann (qvar (q n) ::: d) defBody = \case C.DTerm Nothing _T -> print opts env _T C.DTerm (Just b) _T -> defn (print opts env _T :=: print opts env b) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 162809458..34d119545 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -73,10 +73,10 @@ abstractLR Nothing Nothing = Scope abstractLR c t = Scope . replaceCommand (Replacer 0 . freeL <$> c <*> pure boundL) (Replacer 0 . freeR <$> t <*> pure boundR) where freeR t outer name | name == t = Var (Bound outer) - | otherwise = Var (Free (Nil:|>name)) + | otherwise = Var (Free (q name)) freeL c outer name | name == c = Covar (Bound outer) - | otherwise = Covar (Free (Nil:|>name)) + | otherwise = Covar (Free (q name)) boundR _ inner = Var (Bound inner) boundL _ inner = Covar (Bound inner) @@ -89,8 +89,8 @@ instantiateR t = instantiateLR Nothing t instantiateLR :: Maybe Coterm -> Maybe Term -> (Scope -> Command) instantiateLR Nothing Nothing = getScope instantiateLR c t = replaceCommand (Replacer 0 freeL . boundL <$> c) (Replacer 0 freeR . boundR <$> t) . getScope where - freeR _ name = Var (Free (Nil:|>name)) - freeL _ name = Covar (Free (Nil:|>name)) + freeR _ name = Var (Free (q name)) + freeL _ name = Covar (Free (q name)) boundR t outer inner | outer == inner = t | otherwise = Var (Bound inner) From 216a952186702ee95266423d82727d1234f0f428 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 17:50:40 -0400 Subject: [PATCH 1210/1324] :fire: an unused effect. --- src/Facet/Elab/Sequent.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 96de9b921..01a3812e9 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -93,7 +93,7 @@ stringS s = pure $ SQ.StringR s :==> T.String -- Eliminators -appS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Throw ErrReason) sig m) => (HasCallStack => m (SQ.Term :==> Type)) -> (HasCallStack => Type <==: m SQ.Term) -> m (SQ.Term :==> Type) +appS :: (HasCallStack, Has (Throw ErrReason) sig m) => (HasCallStack => m (SQ.Term :==> Type)) -> (HasCallStack => Type <==: m SQ.Term) -> m (SQ.Term :==> Type) appS f a = do f' :==> _F <- f (_, _A, _B) <- assertFunction _F From f1850b908e86a0b9376a454244e899ae34dfe964 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 17:53:18 -0400 Subject: [PATCH 1211/1324] Guard commands behind scopes. --- src/Facet/Elab/Sequent.hs | 22 +++++++++++++--------- src/Facet/Sequent/Expr.hs | 20 ++++++++++---------- 2 files changed, 23 insertions(+), 19 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 01a3812e9..0c17d70dc 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE OverloadedStrings #-} module Facet.Elab.Sequent ( -- * Variables globalS @@ -80,12 +81,14 @@ hole n = Check $ \ _T -> withFrozenCallStack $ throwError $ Hole n _T -- Constructors lamS - :: Has (Throw ErrReason) sig m - => Type <==: m SQ.Command + :: (Has Fresh sig m, Has (Throw ErrReason) sig m) + => (Name -> Name -> Type <==: m SQ.Command) -> Type <==: m SQ.Term lamS b = Check $ \ _T -> do (_, _A, _B) <- assertTacitFunction _T - SQ.LamR <$> check (b ::: _B) + v <- freshName "v" + k <- freshName "k" + SQ.lamR v k <$> check (b v k ::: _B) stringS :: Applicative m => Text -> m (SQ.Term :==> Type) stringS s = pure $ SQ.StringR s :==> T.String @@ -93,12 +96,13 @@ stringS s = pure $ SQ.StringR s :==> T.String -- Eliminators -appS :: (HasCallStack, Has (Throw ErrReason) sig m) => (HasCallStack => m (SQ.Term :==> Type)) -> (HasCallStack => Type <==: m SQ.Term) -> m (SQ.Term :==> Type) +appS :: (HasCallStack, Has Fresh sig m, Has (Throw ErrReason) sig m) => (HasCallStack => m (SQ.Term :==> Type)) -> (HasCallStack => Type <==: m SQ.Term) -> m (SQ.Term :==> Type) appS f a = do f' :==> _F <- f (_, _A, _B) <- assertFunction _F a' <- check (a ::: _A) - pure $ SQ.MuR (f' SQ.:|: SQ.LamL a' (SQ.Covar (Bound (Index 0)))) :==> _B + k <- freshName "k" + pure $ SQ.muR k (f' SQ.:|: SQ.LamL a' (SQ.Covar (Free (q k)))) :==> _B -- General combinators @@ -120,7 +124,7 @@ freshName s = G s <$> fresh -- Elaboration -synthExprS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m) => S.Ann S.Expr -> m (SQ.Term :==> Type) +synthExprS :: (HasCallStack, Has Fresh sig m, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m) => S.Ann S.Expr -> m (SQ.Term :==> Type) synthExprS = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \case S.Var n -> varS n S.App f a -> synthApp f a @@ -131,14 +135,14 @@ synthExprS = let ?callStack = popCallStack GHC.Stack.callStack in withSpan $ \ca where nope = couldNotSynthesize -synthApp :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Expr -> m (SQ.Term :==> Type) +synthApp :: (Has Fresh sig m, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Expr -> m (SQ.Term :==> Type) synthApp f a = appS (synthExprS f) (checkExprS a) -synthAs :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Type -> m (SQ.Term :==> Type) +synthAs :: (HasCallStack, Has Fresh sig m, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m) => S.Ann S.Expr -> S.Ann S.Type -> m (SQ.Term :==> Type) synthAs t _T = as (checkExprS t ::: do { _T :==> _K <- Type.synthType _T ; (:==> _K) <$> evalTExpr _T }) -checkExprS :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m) => S.Ann S.Expr -> Type <==: m SQ.Term +checkExprS :: (HasCallStack, Has Fresh sig m, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m) => S.Ann S.Expr -> Type <==: m SQ.Term checkExprS expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC expr $ \case S.Hole n -> hole n S.Lam cs -> checkLamS (Check (\ _T -> map (\ (S.Clause (S.Ann _ _ p) b) -> Clause [pattern p] (check (checkExprS b ::: _T))) cs)) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 34d119545..85f5e116e 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -32,10 +32,10 @@ import Fresnel.Setter ((%~)) data Term = Var (Var Index) - | MuR Command - | LamR Command + | MuR Scope + | LamR Scope | SumR Int Term - | BottomR Command + | BottomR Scope | UnitR | PrdR Term Term | StringR Text @@ -45,7 +45,7 @@ data Term data Coterm = Covar (Var Index) - | MuL Command + | MuL Scope | LamL Term Coterm | SumL [Coterm] | UnitL @@ -118,10 +118,10 @@ replaceTerm l r within = case within of Var (Free (Nil:|>n)) -> maybe (const within) free' r n Var (Free _) -> within Var (Bound inner) -> maybe (const within) bound' r inner - MuR b -> MuR (replaceCommand (l & _Just.outer_ %~ succ) r b) - LamR b -> LamR (replaceCommand (l & _Just.outer_ %~ succ) (r & _Just.outer_ %~ succ) b) + MuR (Scope b) -> MuR (Scope (replaceCommand (l & _Just.outer_ %~ succ) r b)) + LamR (Scope b) -> LamR (Scope (replaceCommand (l & _Just.outer_ %~ succ) (r & _Just.outer_ %~ succ) b)) SumR i a -> SumR i (replaceTerm l r a) - BottomR b -> BottomR (replaceCommand l r b) + BottomR (Scope b) -> BottomR (Scope (replaceCommand l r b)) UnitR -> within PrdR a b -> PrdR (replaceTerm l r a) (replaceTerm l r b) StringR _ -> within @@ -131,7 +131,7 @@ replaceCoterm l r within = case within of Covar (Free (Nil:|>n)) -> maybe (const within) free' l n Covar (Free _) -> within Covar (Bound inner) -> maybe (const within) bound' l inner - MuL b -> MuL (replaceCommand l (r & _Just.outer_ %~ succ) b) + MuL (Scope b) -> MuL (Scope (replaceCommand l (r & _Just.outer_ %~ succ) b)) LamL a k -> LamL (replaceTerm l r a) (replaceCoterm l r k) SumL cs -> SumL (map (replaceCoterm l r) cs) UnitL -> within @@ -147,7 +147,7 @@ replaceCommand l r = \case -- Smart constructors muR :: Name -> Command -> Term -muR name body = MuR (getScope (abstractLR (Just name) Nothing body)) +muR name body = MuR (abstractLR (Just name) Nothing body) lamR :: Name -> Name -> Command -> Term -lamR v k body = LamR (getScope (abstractLR (Just v) (Just k) body)) +lamR v k body = LamR (abstractLR (Just v) (Just k) body) From c95f09ead02bc3d46ddedfd727a1461b62daa3fa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 23:08:25 -0400 Subject: [PATCH 1212/1324] Wrap Let bodies up in Scopes. --- src/Facet/Sequent/Expr.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 85f5e116e..7d5248993 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -57,7 +57,7 @@ data Coterm data Command = Term :|: Coterm - | Let Term Command + | Let Term Scope -- Scopes @@ -140,8 +140,8 @@ replaceCoterm l r within = case within of replaceCommand :: Maybe (Replacer Coterm) -> Maybe (Replacer Term) -> (Command -> Command) replaceCommand l r = \case - t :|: c -> replaceTerm l r t :|: replaceCoterm l r c - Let t b -> Let (replaceTerm l r t) (replaceCommand l (r & _Just.outer_ %~ succ) b) + t :|: c -> replaceTerm l r t :|: replaceCoterm l r c + Let t (Scope b) -> Let (replaceTerm l r t) (Scope (replaceCommand l (r & _Just.outer_ %~ succ) b)) -- Smart constructors From 734a3e7e7723e56af3d1f9454e6805b0c18cb231 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 23:09:02 -0400 Subject: [PATCH 1213/1324] Define a smart constructor for Let. --- src/Facet/Sequent/Expr.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 7d5248993..b6bc64ee3 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -16,6 +16,7 @@ module Facet.Sequent.Expr -- * Smart constructors , muR , lamR +, let' ) where import Data.Function ((&)) @@ -151,3 +152,7 @@ muR name body = MuR (abstractLR (Just name) Nothing body) lamR :: Name -> Name -> Command -> Term lamR v k body = LamR (abstractLR (Just v) (Just k) body) + + +let' :: Name -> Term -> Command -> Command +let' name value body = Let value (abstractLR Nothing (Just name) body) From 8634b173bfedf8af79505c3d138161d034dfa6cd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 23:10:10 -0400 Subject: [PATCH 1214/1324] abstractL/R always take values. --- src/Facet/Sequent/Expr.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index b6bc64ee3..3c1143883 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -65,9 +65,9 @@ data Command newtype Scope = Scope { getScope :: Command } -abstractL, abstractR :: Maybe Name -> (Command -> Scope) -abstractL c = abstractLR c Nothing -abstractR t = abstractLR Nothing t +abstractL, abstractR :: Name -> (Command -> Scope) +abstractL c = abstractLR (Just c) Nothing +abstractR t = abstractLR Nothing (Just t) abstractLR :: Maybe Name -> Maybe Name -> (Command -> Scope) abstractLR Nothing Nothing = Scope From 74c863a414c23924619e6079d68bdff93f543415 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 23:10:34 -0400 Subject: [PATCH 1215/1324] instantiateL/R always take values. --- src/Facet/Sequent/Expr.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 3c1143883..52738c791 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -81,11 +81,11 @@ abstractLR c t = Scope . replaceCommand (Replacer 0 . freeL <$> c <*> pure bound boundR _ inner = Var (Bound inner) boundL _ inner = Covar (Bound inner) -instantiateL :: Maybe Coterm -> (Scope -> Command) -instantiateL c = instantiateLR c Nothing +instantiateL :: Coterm -> (Scope -> Command) +instantiateL c = instantiateLR (Just c) Nothing -instantiateR :: Maybe Term -> (Scope -> Command) -instantiateR t = instantiateLR Nothing t +instantiateR :: Term -> (Scope -> Command) +instantiateR t = instantiateLR Nothing (Just t) instantiateLR :: Maybe Coterm -> Maybe Term -> (Scope -> Command) instantiateLR Nothing Nothing = getScope From e869286ec660009e0dac4ffbbd4f5393cb6cb8f2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 26 Apr 2022 23:24:59 -0400 Subject: [PATCH 1216/1324] Disallow pointless cases. --- src/Facet/Sequent/Expr.hs | 85 ++++++++++++++++++++++----------------- 1 file changed, 49 insertions(+), 36 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 52738c791..48aad9725 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -19,14 +19,16 @@ module Facet.Sequent.Expr , let' ) where +import Data.Bifunctor (bimap) import Data.Function ((&)) import Data.Text (Text) +import Data.These import Facet.Name import Facet.Snoc import Facet.Snoc.NonEmpty import Facet.Syntax import Fresnel.Lens (Lens', lens) -import Fresnel.Maybe +import Fresnel.Prism import Fresnel.Setter ((%~)) -- Terms @@ -66,12 +68,11 @@ data Command newtype Scope = Scope { getScope :: Command } abstractL, abstractR :: Name -> (Command -> Scope) -abstractL c = abstractLR (Just c) Nothing -abstractR t = abstractLR Nothing (Just t) +abstractL c = abstractLR (This c) +abstractR t = abstractLR (That t) -abstractLR :: Maybe Name -> Maybe Name -> (Command -> Scope) -abstractLR Nothing Nothing = Scope -abstractLR c t = Scope . replaceCommand (Replacer 0 . freeL <$> c <*> pure boundL) (Replacer 0 . freeR <$> t <*> pure boundR) where +abstractLR :: These Name Name -> (Command -> Scope) +abstractLR ct = Scope . replaceCommand (bimap (\ c -> Replacer 0 (freeL c) boundL) (\ t -> Replacer 0 (freeR t) boundR) ct) where freeR t outer name | name == t = Var (Bound outer) | otherwise = Var (Free (q name)) @@ -82,14 +83,13 @@ abstractLR c t = Scope . replaceCommand (Replacer 0 . freeL <$> c <*> pure bound boundL _ inner = Covar (Bound inner) instantiateL :: Coterm -> (Scope -> Command) -instantiateL c = instantiateLR (Just c) Nothing +instantiateL c = instantiateLR (This c) instantiateR :: Term -> (Scope -> Command) -instantiateR t = instantiateLR Nothing (Just t) +instantiateR t = instantiateLR (That t) -instantiateLR :: Maybe Coterm -> Maybe Term -> (Scope -> Command) -instantiateLR Nothing Nothing = getScope -instantiateLR c t = replaceCommand (Replacer 0 freeL . boundL <$> c) (Replacer 0 freeR . boundR <$> t) . getScope where +instantiateLR :: These Coterm Term -> (Scope -> Command) +instantiateLR ct = replaceCommand (bimap (Replacer 0 freeL . boundL) (Replacer 0 freeR . boundR) ct) . getScope where freeR _ name = Var (Free (q name)) freeL _ name = Covar (Free (q name)) boundR t outer inner @@ -114,45 +114,58 @@ free' Replacer{ outer, free } = free outer bound' :: Replacer t -> Index -> t bound' Replacer{ outer, bound } = bound outer -replaceTerm :: Maybe (Replacer Coterm) -> Maybe (Replacer Term) -> (Term -> Term) -replaceTerm l r within = case within of - Var (Free (Nil:|>n)) -> maybe (const within) free' r n +replaceTerm :: These (Replacer Coterm) (Replacer Term) -> (Term -> Term) +replaceTerm lr within = case within of + Var (Free (Nil:|>n)) -> that (const within) free' lr n Var (Free _) -> within - Var (Bound inner) -> maybe (const within) bound' r inner - MuR (Scope b) -> MuR (Scope (replaceCommand (l & _Just.outer_ %~ succ) r b)) - LamR (Scope b) -> LamR (Scope (replaceCommand (l & _Just.outer_ %~ succ) (r & _Just.outer_ %~ succ) b)) - SumR i a -> SumR i (replaceTerm l r a) - BottomR (Scope b) -> BottomR (Scope (replaceCommand l r b)) + Var (Bound inner) -> that (const within) bound' lr inner + MuR (Scope b) -> MuR (Scope (replaceCommand (lr & _This.outer_ %~ succ) b)) + LamR (Scope b) -> LamR (Scope (replaceCommand (lr & _This.outer_ %~ succ & _That.outer_ %~ succ) b)) + SumR i a -> SumR i (replaceTerm lr a) + BottomR (Scope b) -> BottomR (Scope (replaceCommand lr b)) UnitR -> within - PrdR a b -> PrdR (replaceTerm l r a) (replaceTerm l r b) + PrdR a b -> PrdR (replaceTerm lr a) (replaceTerm lr b) StringR _ -> within + where + that :: c -> (b -> c) -> These a b -> c + that d f = these (const d) f (const f) -replaceCoterm :: Maybe (Replacer Coterm) -> Maybe (Replacer Term) -> (Coterm -> Coterm) -replaceCoterm l r within = case within of - Covar (Free (Nil:|>n)) -> maybe (const within) free' l n +replaceCoterm :: These (Replacer Coterm) (Replacer Term) -> (Coterm -> Coterm) +replaceCoterm lr within = case within of + Covar (Free (Nil:|>n)) -> this (const within) free' lr n Covar (Free _) -> within - Covar (Bound inner) -> maybe (const within) bound' l inner - MuL (Scope b) -> MuL (Scope (replaceCommand l (r & _Just.outer_ %~ succ) b)) - LamL a k -> LamL (replaceTerm l r a) (replaceCoterm l r k) - SumL cs -> SumL (map (replaceCoterm l r) cs) + Covar (Bound inner) -> this (const within) bound' lr inner + MuL (Scope b) -> MuL (Scope (replaceCommand (lr & _That.outer_ %~ succ) b)) + LamL a k -> LamL (replaceTerm lr a) (replaceCoterm lr k) + SumL cs -> SumL (map (replaceCoterm lr) cs) UnitL -> within - PrdL1 k -> PrdL1 (replaceCoterm l r k) - PrdL2 k -> PrdL2 (replaceCoterm l r k) + PrdL1 k -> PrdL1 (replaceCoterm lr k) + PrdL2 k -> PrdL2 (replaceCoterm lr k) + where + this :: c -> (a -> c) -> These a b -> c + this d f = these f (const d) (const . f) -replaceCommand :: Maybe (Replacer Coterm) -> Maybe (Replacer Term) -> (Command -> Command) -replaceCommand l r = \case - t :|: c -> replaceTerm l r t :|: replaceCoterm l r c - Let t (Scope b) -> Let (replaceTerm l r t) (Scope (replaceCommand l (r & _Just.outer_ %~ succ) b)) +replaceCommand :: These (Replacer Coterm) (Replacer Term) -> (Command -> Command) +replaceCommand lr = \case + t :|: c -> replaceTerm lr t :|: replaceCoterm lr c + Let t (Scope b) -> Let (replaceTerm lr t) (Scope (replaceCommand (lr & _That.outer_ %~ succ) b)) + + +_This :: Prism' (These a b) a +_This = prism' This (these Just (const Nothing) (const (const Nothing))) + +_That :: Prism' (These a b) b +_That = prism' That (these (const Nothing) Just (const (const Nothing))) -- Smart constructors muR :: Name -> Command -> Term -muR name body = MuR (abstractLR (Just name) Nothing body) +muR name body = MuR (abstractLR (This name) body) lamR :: Name -> Name -> Command -> Term -lamR v k body = LamR (abstractLR (Just v) (Just k) body) +lamR v k body = LamR (abstractLR (These v k) body) let' :: Name -> Term -> Command -> Command -let' name value body = Let value (abstractLR Nothing (Just name) body) +let' name value body = Let value (abstractLR (That name) body) From a40b49468469ee1eb4c8f53e757ace21161325d7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 27 Apr 2022 10:07:23 -0400 Subject: [PATCH 1217/1324] Define a lamR variant taking a term. --- src/Facet/Sequent/Expr.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 48aad9725..9f121d0b6 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -16,6 +16,7 @@ module Facet.Sequent.Expr -- * Smart constructors , muR , lamR +, lamR' , let' ) where @@ -166,6 +167,9 @@ muR name body = MuR (abstractLR (This name) body) lamR :: Name -> Name -> Command -> Term lamR v k body = LamR (abstractLR (These v k) body) +lamR' :: Name -> Name -> Term -> Term +lamR' var covar body = lamR var covar (body :|: Covar (Free (q covar))) + let' :: Name -> Term -> Command -> Command let' name value body = Let value (abstractLR (That name) body) From a266d66ecfe37ca7db3daa80164c9d5b9f197249 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 27 Apr 2022 10:53:08 -0400 Subject: [PATCH 1218/1324] Generalize partitionBy. --- src/Facet/Elab/Sequent.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 0c17d70dc..a86ae864c 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -177,15 +177,15 @@ body_ :: Lens (Clause a) (Clause b) a b body_ = lens body (\ c body -> c{ body }) -partitionBy :: [Clause a] -> Scope.Scope Type -> Maybe (Col.Column [Clause a]) +partitionBy :: Has Empty sig m => [Clause a] -> Scope.Scope Type -> m (Col.Column [Clause a]) partitionBy clauses ctors = fold <$> for clauses (\case Clause (PVal p:ps) b -> case p of PWildcard -> pure (Col.fromList ([Clause (PVal PWildcard:ps) b] <$ view Scope.toList_ ctors)) PVar n -> pure (Col.fromList ([Clause (PVal (PVar n) :ps) b] <$ view Scope.toList_ ctors)) PCon (_:|>n) fs -> case Scope.lookupIndex n ctors of - Nothing -> Nothing + Nothing -> empty Just ix -> pure (Col.singleton ix [Clause (map PVal fs <> ps) b]) - _ -> Nothing) + _ -> empty) -- Assertions From 60b40b954610295bdab07ba4483d72ff881659be Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 28 Apr 2022 03:37:21 -0400 Subject: [PATCH 1219/1324] Idiomatic (:=:) -> (,) conversion. --- src/Facet/Scope.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Facet/Scope.hs b/src/Facet/Scope.hs index b96842f11..9bc8d556d 100644 --- a/src/Facet/Scope.hs +++ b/src/Facet/Scope.hs @@ -12,6 +12,7 @@ import Data.List (findIndex) import qualified Data.Map as Map import Facet.Name import Facet.Syntax +import Fresnel.Getter (view) import Fresnel.Iso import Fresnel.Ixed import Fresnel.Optional (optional') @@ -24,7 +25,7 @@ instance Ixed (Scope a) where type IxValue (Scope a) = a ix n = optional' prj (\ (Scope ds) d' -> Scope (replace (\ (n' :=: _) -> (n' :=: d') <$ guard (n == n')) ds)) where - prj = lookup n . map (\ (n :=: a) -> (n, a)) . decls + prj = lookup n . map (view pair_) . decls replace _ [] = [] replace f (v:vs) = case f v of Nothing -> v:replace f vs From 00acd1d343f8fb7a0fb72e3e194e544475cb948d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 28 Apr 2022 11:15:42 -0400 Subject: [PATCH 1220/1324] Fix a missing import. --- src/Facet/Elab/Sequent.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index a86ae864c..5f9bb3bc7 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -24,6 +24,7 @@ module Facet.Elab.Sequent , check ) where +import Control.Effect.Empty import Control.Effect.Fresh import Control.Effect.Reader import Control.Effect.State From 97841275538cfdd7d9bebae67e14e37f31f044a0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 28 Apr 2022 11:16:06 -0400 Subject: [PATCH 1221/1324] SumL maps constructor names to coterms. --- src/Facet/Sequent/Expr.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 9f121d0b6..716fb7112 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -51,7 +51,7 @@ data Coterm = Covar (Var Index) | MuL Scope | LamL Term Coterm - | SumL [Coterm] + | SumL [Name :=: Coterm] | UnitL | PrdL1 Coterm | PrdL2 Coterm @@ -138,7 +138,7 @@ replaceCoterm lr within = case within of Covar (Bound inner) -> this (const within) bound' lr inner MuL (Scope b) -> MuL (Scope (replaceCommand (lr & _That.outer_ %~ succ) b)) LamL a k -> LamL (replaceTerm lr a) (replaceCoterm lr k) - SumL cs -> SumL (map (replaceCoterm lr) cs) + SumL cs -> SumL (map (fmap (replaceCoterm lr)) cs) UnitL -> within PrdL1 k -> PrdL1 (replaceCoterm lr k) PrdL2 k -> PrdL2 (replaceCoterm lr k) From c1ff4f12e32f80834864f7fe1f5f195fb2d4bd25 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 28 Apr 2022 11:16:26 -0400 Subject: [PATCH 1222/1324] SumR maps a constructor name to a term. --- src/Facet/Sequent/Expr.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 716fb7112..9a6bc727e 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -38,7 +38,7 @@ data Term = Var (Var Index) | MuR Scope | LamR Scope - | SumR Int Term + | SumR Name Term | BottomR Scope | UnitR | PrdR Term Term From 7cfbf214303f5faad36c068313aea01ffe270580 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 28 Apr 2022 11:16:57 -0400 Subject: [PATCH 1223/1324] :fire: BottomR. --- src/Facet/Sequent/Expr.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 9a6bc727e..600118817 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -39,7 +39,6 @@ data Term | MuR Scope | LamR Scope | SumR Name Term - | BottomR Scope | UnitR | PrdR Term Term | StringR Text @@ -123,7 +122,6 @@ replaceTerm lr within = case within of MuR (Scope b) -> MuR (Scope (replaceCommand (lr & _This.outer_ %~ succ) b)) LamR (Scope b) -> LamR (Scope (replaceCommand (lr & _This.outer_ %~ succ & _That.outer_ %~ succ) b)) SumR i a -> SumR i (replaceTerm lr a) - BottomR (Scope b) -> BottomR (Scope (replaceCommand lr b)) UnitR -> within PrdR a b -> PrdR (replaceTerm lr a) (replaceTerm lr b) StringR _ -> within From 8fed5c2c26bc11fdb5bffa7390d4f94cea46616c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 28 Apr 2022 12:09:01 -0400 Subject: [PATCH 1224/1324] Products are introduced n-arily. --- src/Facet/Sequent/Expr.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 600118817..d37bdfd3e 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -40,7 +40,7 @@ data Term | LamR Scope | SumR Name Term | UnitR - | PrdR Term Term + | PrdR [Term] | StringR Text @@ -123,7 +123,7 @@ replaceTerm lr within = case within of LamR (Scope b) -> LamR (Scope (replaceCommand (lr & _This.outer_ %~ succ & _That.outer_ %~ succ) b)) SumR i a -> SumR i (replaceTerm lr a) UnitR -> within - PrdR a b -> PrdR (replaceTerm lr a) (replaceTerm lr b) + PrdR as -> PrdR (map (replaceTerm lr) as) StringR _ -> within where that :: c -> (b -> c) -> These a b -> c From 09e2ccf2df859c0b2fc1d9babffc22d0bea42715 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 28 Apr 2022 12:09:20 -0400 Subject: [PATCH 1225/1324] :fire: UnitL/R. --- src/Facet/Sequent/Expr.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index d37bdfd3e..48541f492 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -39,7 +39,6 @@ data Term | MuR Scope | LamR Scope | SumR Name Term - | UnitR | PrdR [Term] | StringR Text @@ -51,7 +50,6 @@ data Coterm | MuL Scope | LamL Term Coterm | SumL [Name :=: Coterm] - | UnitL | PrdL1 Coterm | PrdL2 Coterm @@ -122,7 +120,6 @@ replaceTerm lr within = case within of MuR (Scope b) -> MuR (Scope (replaceCommand (lr & _This.outer_ %~ succ) b)) LamR (Scope b) -> LamR (Scope (replaceCommand (lr & _This.outer_ %~ succ & _That.outer_ %~ succ) b)) SumR i a -> SumR i (replaceTerm lr a) - UnitR -> within PrdR as -> PrdR (map (replaceTerm lr) as) StringR _ -> within where @@ -137,7 +134,6 @@ replaceCoterm lr within = case within of MuL (Scope b) -> MuL (Scope (replaceCommand (lr & _That.outer_ %~ succ) b)) LamL a k -> LamL (replaceTerm lr a) (replaceCoterm lr k) SumL cs -> SumL (map (fmap (replaceCoterm lr)) cs) - UnitL -> within PrdL1 k -> PrdL1 (replaceCoterm lr k) PrdL2 k -> PrdL2 (replaceCoterm lr k) where From 0dc37ec61a2a6773c2c86d1ee7cada9e7a194058 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 28 Apr 2022 12:13:32 -0400 Subject: [PATCH 1226/1324] Products are strict. --- src/Facet/Sequent/Expr.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 48541f492..3cff10d4e 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -50,8 +50,7 @@ data Coterm | MuL Scope | LamL Term Coterm | SumL [Name :=: Coterm] - | PrdL1 Coterm - | PrdL2 Coterm + | PrdL Scope -- Commands @@ -134,8 +133,7 @@ replaceCoterm lr within = case within of MuL (Scope b) -> MuL (Scope (replaceCommand (lr & _That.outer_ %~ succ) b)) LamL a k -> LamL (replaceTerm lr a) (replaceCoterm lr k) SumL cs -> SumL (map (fmap (replaceCoterm lr)) cs) - PrdL1 k -> PrdL1 (replaceCoterm lr k) - PrdL2 k -> PrdL2 (replaceCoterm lr k) + PrdL (Scope b) -> PrdL (Scope (replaceCommand lr b)) where this :: c -> (a -> c) -> These a b -> c this d f = these f (const d) (const . f) From fe7eedf90bf25bc22ab65ec65c44fd299d7ee313 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 28 Apr 2022 12:18:10 -0400 Subject: [PATCH 1227/1324] Record how many fields are in scope. --- src/Facet/Sequent/Expr.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 3cff10d4e..cbef4839f 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -50,7 +50,7 @@ data Coterm | MuL Scope | LamL Term Coterm | SumL [Name :=: Coterm] - | PrdL Scope + | PrdL Int Scope -- Commands @@ -133,7 +133,7 @@ replaceCoterm lr within = case within of MuL (Scope b) -> MuL (Scope (replaceCommand (lr & _That.outer_ %~ succ) b)) LamL a k -> LamL (replaceTerm lr a) (replaceCoterm lr k) SumL cs -> SumL (map (fmap (replaceCoterm lr)) cs) - PrdL (Scope b) -> PrdL (Scope (replaceCommand lr b)) + PrdL i (Scope b) -> PrdL i (Scope (replaceCommand lr b)) where this :: c -> (a -> c) -> These a b -> c this d f = these f (const d) (const . f) From bf7e231e7fb89e3e8401643c81c6f784e3aa034c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 28 Apr 2022 12:21:52 -0400 Subject: [PATCH 1228/1324] Increment by the number of bound variables. --- src/Facet/Sequent/Expr.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index cbef4839f..ba05e26b9 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -30,7 +30,7 @@ import Facet.Snoc.NonEmpty import Facet.Syntax import Fresnel.Lens (Lens', lens) import Fresnel.Prism -import Fresnel.Setter ((%~)) +import Fresnel.Setter ((%~), (+~)) -- Terms @@ -133,7 +133,7 @@ replaceCoterm lr within = case within of MuL (Scope b) -> MuL (Scope (replaceCommand (lr & _That.outer_ %~ succ) b)) LamL a k -> LamL (replaceTerm lr a) (replaceCoterm lr k) SumL cs -> SumL (map (fmap (replaceCoterm lr)) cs) - PrdL i (Scope b) -> PrdL i (Scope (replaceCommand lr b)) + PrdL i (Scope b) -> PrdL i (Scope (replaceCommand (lr & _This.outer_ +~ Index i) b)) where this :: c -> (a -> c) -> These a b -> c this d f = these f (const d) (const . f) From 1236a9dfa1e97569bf5db28f433fff7b45e78a8d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 28 Apr 2022 21:17:06 -0400 Subject: [PATCH 1229/1324] Define a smart constructor for MuL. --- src/Facet/Sequent/Expr.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index ba05e26b9..a04dd9de8 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -17,6 +17,7 @@ module Facet.Sequent.Expr , muR , lamR , lamR' +, muL , let' ) where @@ -163,5 +164,9 @@ lamR' :: Name -> Name -> Term -> Term lamR' var covar body = lamR var covar (body :|: Covar (Free (q covar))) +muL :: Name -> Command -> Coterm +muL name body = MuL (abstractLR (That name) body) + + let' :: Name -> Term -> Command -> Command let' name value body = Let value (abstractLR (That name) body) From 2ffdb0c5eb192e39463cc997449ebb507b6e5b4b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 29 Apr 2022 14:50:28 -0400 Subject: [PATCH 1230/1324] lamR' uses a single name. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Γ & Δ are disjoint! --- src/Facet/Sequent/Expr.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index a04dd9de8..6ab8faef2 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -160,8 +160,8 @@ muR name body = MuR (abstractLR (This name) body) lamR :: Name -> Name -> Command -> Term lamR v k body = LamR (abstractLR (These v k) body) -lamR' :: Name -> Name -> Term -> Term -lamR' var covar body = lamR var covar (body :|: Covar (Free (q covar))) +lamR' :: Name -> Term -> Term +lamR' name body = lamR name name (body :|: Covar (Free (q name))) muL :: Name -> Command -> Coterm From 8ea371dbc08c4e9d8492d102379153466b995ead Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 30 Apr 2022 22:49:24 -0400 Subject: [PATCH 1231/1324] Give fixity for :|:. --- src/Facet/Sequent/Expr.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 6ab8faef2..dd83322ae 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -60,6 +60,8 @@ data Command = Term :|: Coterm | Let Term Scope +infix 2 :|: + -- Scopes From d6c6f258b0b1d7ff9b14abc3dc91389da866258a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 1 May 2022 17:25:06 -0400 Subject: [PATCH 1232/1324] Define a smart constructor for local variables. --- src/Facet/Sequent/Expr.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index dd83322ae..e87e93b44 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -14,6 +14,7 @@ module Facet.Sequent.Expr , instantiateR , instantiateLR -- * Smart constructors +, localR , muR , lamR , lamR' @@ -156,6 +157,9 @@ _That = prism' That (these (const Nothing) Just (const (const Nothing))) -- Smart constructors +localR :: Name -> Term +localR = Var . Free . q + muR :: Name -> Command -> Term muR name body = MuR (abstractLR (This name) body) From c99ce2b1c006d78a38218b08ff3d608ef6030c1c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 1 May 2022 17:25:32 -0400 Subject: [PATCH 1233/1324] Define a smart constructor for global variables. --- src/Facet/Sequent/Expr.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index e87e93b44..b32256597 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -15,6 +15,7 @@ module Facet.Sequent.Expr , instantiateLR -- * Smart constructors , localR +, globalR , muR , lamR , lamR' @@ -160,6 +161,9 @@ _That = prism' That (these (const Nothing) Just (const (const Nothing))) localR :: Name -> Term localR = Var . Free . q +globalR :: QName -> Term +globalR = Var . Free + muR :: Name -> Command -> Term muR name body = MuR (abstractLR (This name) body) From d5228acb653997e1bdf1ce4401df09809cbfd88f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 1 May 2022 17:36:50 -0400 Subject: [PATCH 1234/1324] Define a smart constructor for local covariables. --- src/Facet/Sequent/Expr.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index b32256597..8ab07bbe3 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -19,6 +19,7 @@ module Facet.Sequent.Expr , muR , lamR , lamR' +, localL , muL , let' ) where @@ -174,6 +175,9 @@ lamR' :: Name -> Term -> Term lamR' name body = lamR name name (body :|: Covar (Free (q name))) +localL :: Name -> Coterm +localL = Covar . Free . q + muL :: Name -> Command -> Coterm muL name body = MuL (abstractLR (That name) body) From 31b76995b6c5cb588a07b1677f7e68004d9b3281 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 May 2022 09:17:18 -0400 Subject: [PATCH 1235/1324] lamS passes term & coterm along. --- src/Facet/Elab/Sequent.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 5f9bb3bc7..4400f6e98 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -83,13 +83,13 @@ hole n = Check $ \ _T -> withFrozenCallStack $ throwError $ Hole n _T lamS :: (Has Fresh sig m, Has (Throw ErrReason) sig m) - => (Name -> Name -> Type <==: m SQ.Command) + => (Type <==: m SQ.Term -> Type <==: m SQ.Coterm -> Type <==: m SQ.Command) -> Type <==: m SQ.Term lamS b = Check $ \ _T -> do (_, _A, _B) <- assertTacitFunction _T v <- freshName "v" k <- freshName "k" - SQ.lamR v k <$> check (b v k ::: _B) + SQ.lamR v k <$> check (b (pure (pure (SQ.localR v))) (pure (pure (SQ.localL k))) ::: _B) stringS :: Applicative m => Text -> m (SQ.Term :==> Type) stringS s = pure $ SQ.StringR s :==> T.String From 5d361b8a9ea6eec8d0770070cc9ce284de0b33a7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 May 2022 09:18:38 -0400 Subject: [PATCH 1236/1324] Define a simple ND-style lambda constructor. --- src/Facet/Elab/Sequent.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 4400f6e98..ffe37254e 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -6,6 +6,7 @@ module Facet.Elab.Sequent , varS -- * Constructors , lamS +, lamS' , stringS -- * Eliminators , appS @@ -91,6 +92,12 @@ lamS b = Check $ \ _T -> do k <- freshName "k" SQ.lamR v k <$> check (b (pure (pure (SQ.localR v))) (pure (pure (SQ.localL k))) ::: _B) +lamS' + :: (Has Fresh sig m, Has (Throw ErrReason) sig m) + => (Type <==: m SQ.Term -> Type <==: m SQ.Term) + -> Type <==: m SQ.Term +lamS' b = lamS (\ v k -> b v >< k) + stringS :: Applicative m => Text -> m (SQ.Term :==> Type) stringS s = pure $ SQ.StringR s :==> T.String From a79652886ee719a39f97840a8049ae7c2f096f78 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 May 2022 09:46:58 -0400 Subject: [PATCH 1237/1324] Tacit. --- src/Facet/Elab/Sequent.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index ffe37254e..2df2ab240 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -169,7 +169,7 @@ checkLamS :: Has (Throw ErrReason) sig m => Type <==: [Clause (m SQ.Term)] -> Type <==: m SQ.Term -checkLamS _ = Check (\ _T -> mismatchTypes (Exp (Left "unimplemented")) (Act _T)) +checkLamS _ = Check (mismatchTypes (Exp (Left "unimplemented")) . Act) data Clause a = Clause From 8aaf27e7825bdca353e21d8339439487dad8438f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 May 2022 09:47:17 -0400 Subject: [PATCH 1238/1324] :fire: parens. --- src/Facet/Elab/Sequent.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 2df2ab240..eac042159 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -161,7 +161,7 @@ checkExprS expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC where pattern (S.PVal (Ann _ _ p)) = PVal (valPattern p) pattern (S.PEff (Ann _ _ (S.POp n fs (Ann _ _ k)))) = PEff (POp n (map (valPattern . out) fs) (valPattern k)) - valPattern (S.PWildcard) = PWildcard + valPattern S.PWildcard = PWildcard valPattern (S.PVar n) = PVar n valPattern (S.PCon n fs) = PCon n (map (valPattern . out) fs) From 5dd1bea2ef3934de2871f197ed0e3a602bdc347f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 2 May 2022 09:47:29 -0400 Subject: [PATCH 1239/1324] Use the smart constructor. --- src/Facet/Elab/Sequent.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index eac042159..b682a4cb5 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -63,7 +63,7 @@ import GHC.Stack (HasCallStack, callStack, popCallStack, withFrozenCal -- FIXME: we’re instantiating when inspecting types in the REPL. globalS :: Has (State (Subst Type)) sig m => QName ::: Type -> m (SQ.Term :==> Type) globalS (q ::: _T) = do - let v = SQ.Var (Free q) + let v = SQ.globalR q (\ (v ::: _T) -> v :==> _T) <$> instantiate const (v ::: _T) -- FIXME: do we need to instantiate here to deal with rank-n applications? From 3b5ba4a8096a6c0f606e4e82390f59d43ba63367 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 3 May 2022 09:37:32 -0400 Subject: [PATCH 1240/1324] Right-associate binding. --- src/Facet/Elab.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 22c133123..42627a878 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -157,7 +157,7 @@ lookupInSig (m :|> n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':|>_) _ (|-) :: Has (Reader ElabContext) sig m => Name :==> Type -> m a -> m a p |- b = locally context_ (|> p) b -infix 1 |- +infixr 1 |- (||-) :: Has (Reader ElabContext) sig m => Name :==> Kind -> m a -> m a k ||- b = locally typeContext_ (TypeContext.|> k) b From 97387277cc31e13bb0b6afb9d3223578676b4b66 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 7 May 2022 02:07:12 -0400 Subject: [PATCH 1241/1324] Define pattern compilation. --- src/Facet/Elab/Sequent.hs | 76 ++++++++++++++++++++++++++++++--------- 1 file changed, 60 insertions(+), 16 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index b682a4cb5..1b76473aa 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -18,19 +18,21 @@ module Facet.Elab.Sequent , Clause(..) , patterns_ , body_ -, partitionBy +, patternBody +-- , partitionBy -- * Assertions , assertTacitFunction -- * Judgements , check ) where +import Control.Applicative (liftA2) import Control.Effect.Empty import Control.Effect.Fresh import Control.Effect.Reader import Control.Effect.State import Control.Effect.Throw -import Data.Foldable (fold) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Text (Text) import Data.Traversable (for) import Facet.Effect.Write @@ -44,17 +46,15 @@ import Facet.Lens as Lens (views) import Facet.Module import Facet.Name import Facet.Pattern -import qualified Facet.Pattern.Column as Col import qualified Facet.Scope as Scope -import Facet.Sequent.Expr as SQ -import Facet.Snoc.NonEmpty +import qualified Facet.Sequent.Expr as SQ import Facet.Subst import qualified Facet.Surface.Term.Expr as S import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) -import Facet.Type.Norm as T +import Facet.Type.Norm as T hiding (($$)) import Facet.Unify -import Fresnel.Getter (view) +import Fresnel.Fold ((^?)) import Fresnel.Lens (Lens, Lens', lens) import GHC.Stack (HasCallStack, callStack, popCallStack, withFrozenCallStack) @@ -185,15 +185,59 @@ body_ :: Lens (Clause a) (Clause b) a b body_ = lens body (\ c body -> c{ body }) -partitionBy :: Has Empty sig m => [Clause a] -> Scope.Scope Type -> m (Col.Column [Clause a]) -partitionBy clauses ctors = fold <$> for clauses (\case - Clause (PVal p:ps) b -> case p of - PWildcard -> pure (Col.fromList ([Clause (PVal PWildcard:ps) b] <$ view Scope.toList_ ctors)) - PVar n -> pure (Col.fromList ([Clause (PVal (PVar n) :ps) b] <$ view Scope.toList_ ctors)) - PCon (_:|>n) fs -> case Scope.lookupIndex n ctors of - Nothing -> empty - Just ix -> pure (Col.singleton ix [Clause (map PVal fs <> ps) b]) - _ -> empty) +-- FIXME: try returning a coterm instead of a command +patternBody + :: (Has Fresh sig m, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) + => [SQ.Term :==> Type] + -> [Clause (Type <==: m SQ.Command)] + -> Type <==: m SQ.Command +patternBody scrutinees clauses = Check $ \ _T -> case scrutinees of + (s :==> _A):scrutinees' -> case _A of + Ne (Free qname) _ -> do + def <- resolveDef qname + let constructors = fromMaybe [] (def ^? (_DData . Scope.toList_)) -- FIXME: throw an error if we can't find the datatype + + filterClauses name fieldTypes c = case c of + Clause (PVal PWildcard :ps) b -> Just (Clause (padding <> ps) b) + Clause (PVal (PVar n) :ps) b -> Just (Clause (padding <> ps) (fmap (n :==> _A |-) b)) + Clause (PVal (PCon n fs):ps) b + | n == q name -> Just (Clause (map PVal fs <> ps) b) + _ -> Nothing + where + padding = replicate (length fieldTypes) (PVal PWildcard) + + groups <- for constructors (\ (name :=: _C) -> do + let fieldTypes = argumentTypes _C + prefix <- for fieldTypes (\ _T -> (:==> _T) . SQ.localR <$> freshName "x") + pure (name :=: muL (const (patternBody (prefix <> scrutinees') (mapMaybe (filterClauses name fieldTypes) clauses))))) + + check (switch (pure (s :==> _A)) >< case' groups ::: _T) + + _ -> check (patternBody scrutinees' (clauses >>= \case + Clause (PVal PWildcard:ps) b -> [Clause ps b] + Clause (PVal (PVar n) :ps) b -> [Clause ps (fmap (n :==> _A |-) b)] + Clause _ _ -> []) ::: _T) + + [] -> check (body (head clauses) ::: _T) -- FIXME: throw an error if there aren't any clauses left + + +muL :: (Has Fresh sig m, Has (Reader ElabContext) sig m) => (SQ.Term -> Type <==: m SQ.Command) -> Type <==: m SQ.Coterm +muL body = Check $ \ _T -> do + x <- freshName "x" + SQ.muL x <$> (x :==> _T |- check (body (SQ.localR x) ::: _T)) + +(><) :: Applicative m => Type <==: m SQ.Term -> Type <==: m SQ.Coterm -> Type <==: m SQ.Command +t >< c = Check $ \ _T -> liftA2 (SQ.:|:) (check (t ::: _T)) (check (c ::: _T)) + +infix 3 >< + +case' :: Has Fresh sig m => [Name :=: (Type <==: m SQ.Coterm)] -> Type <==: m SQ.Coterm +case' cases = Check $ \ _T -> SQ.SumL <$> traverse (traverse (\ body -> check (body ::: _T))) cases + + +argumentTypes :: Type -> [Type] +argumentTypes (T.Arrow _ _A _B) = _A : argumentTypes _B +argumentTypes _ = [] -- Assertions From f338a99f0864b6ad08497cc2e35a0efd26661037 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 7 May 2022 08:34:57 -0400 Subject: [PATCH 1242/1324] Scrutinees are names, not terms. --- src/Facet/Elab/Sequent.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 1b76473aa..eac750ea5 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -188,7 +188,7 @@ body_ = lens body (\ c body -> c{ body }) -- FIXME: try returning a coterm instead of a command patternBody :: (Has Fresh sig m, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) - => [SQ.Term :==> Type] + => [Name :==> Type] -> [Clause (Type <==: m SQ.Command)] -> Type <==: m SQ.Command patternBody scrutinees clauses = Check $ \ _T -> case scrutinees of @@ -208,10 +208,10 @@ patternBody scrutinees clauses = Check $ \ _T -> case scrutinees of groups <- for constructors (\ (name :=: _C) -> do let fieldTypes = argumentTypes _C - prefix <- for fieldTypes (\ _T -> (:==> _T) . SQ.localR <$> freshName "x") + prefix <- for fieldTypes (\ _T -> (:==> _T) <$> freshName "x") pure (name :=: muL (const (patternBody (prefix <> scrutinees') (mapMaybe (filterClauses name fieldTypes) clauses))))) - check (switch (pure (s :==> _A)) >< case' groups ::: _T) + check (switch (pure (SQ.localR s :==> _A)) >< case' groups ::: _T) _ -> check (patternBody scrutinees' (clauses >>= \case Clause (PVal PWildcard:ps) b -> [Clause ps b] From 979dd05af2e5e415d3630083f1991df967f4aabe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 7 May 2022 09:43:24 -0400 Subject: [PATCH 1243/1324] Clause is a Functor. --- src/Facet/Elab/Sequent.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index eac750ea5..97f37ec85 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -176,7 +176,7 @@ data Clause a = Clause { patterns :: [Pattern Name] , body :: a } - deriving (Show) + deriving (Functor, Show) patterns_ :: Lens' (Clause a) [Pattern Name] patterns_ = lens patterns (\ c patterns -> c{ patterns }) From f1a2ba05d6190d2e0cb9942d1d44aa44f8317a8f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 7 May 2022 09:46:32 -0400 Subject: [PATCH 1244/1324] Build lambdas. --- src/Facet/Elab/Sequent.hs | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 97f37ec85..5095ed76c 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -153,7 +153,7 @@ synthAs t _T = as (checkExprS t ::: do { _T :==> _K <- Type.synthType _T ; (:==> checkExprS :: (HasCallStack, Has Fresh sig m, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (State (Subst Type)) sig m, Has (Throw ErrReason) sig m, Has (Write Warn) sig m) => S.Ann S.Expr -> Type <==: m SQ.Term checkExprS expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC expr $ \case S.Hole n -> hole n - S.Lam cs -> checkLamS (Check (\ _T -> map (\ (S.Clause (S.Ann _ _ p) b) -> Clause [pattern p] (check (checkExprS b ::: _T))) cs)) + S.Lam cs -> checkLamS (map (\ (S.Clause (S.Ann _ _ p) b) -> Clause [pattern p] (checkExprS b)) cs) S.Var{} -> switch (synthExprS expr) S.App{} -> switch (synthExprS expr) S.As{} -> switch (synthExprS expr) @@ -166,10 +166,19 @@ checkExprS expr = let ?callStack = popCallStack GHC.Stack.callStack in withSpanC valPattern (S.PCon n fs) = PCon n (map (valPattern . out) fs) checkLamS - :: Has (Throw ErrReason) sig m - => Type <==: [Clause (m SQ.Term)] + :: (Has Fresh sig m, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) + => [Clause (Type <==: m SQ.Term)] -> Type <==: m SQ.Term -checkLamS _ = Check (mismatchTypes (Exp (Left "unimplemented")) . Act) +checkLamS clauses = Check (go id) + where + go scrutinees = \case + T.Arrow _ _A _B -> do + x <- freshName "x" + SQ.lamR' x <$> go (scrutinees . ((x :==> _A) :)) _B + _T -> do + x <- freshName "x" + kx <- freshName "kx" + SQ.lamR x kx <$> check (patternBody (scrutinees []) (map (fmap (fmap (fmap (SQ.:|: SQ.localL kx)))) clauses) ::: _T) data Clause a = Clause From 33d492f34f44077be684d385de55540d443c198f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 7 May 2022 09:49:06 -0400 Subject: [PATCH 1245/1324] Simplify lifting clause bodies into lambda bodies. --- src/Facet/Elab/Sequent.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 5095ed76c..4c492ecda 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -178,7 +178,7 @@ checkLamS clauses = Check (go id) _T -> do x <- freshName "x" kx <- freshName "kx" - SQ.lamR x kx <$> check (patternBody (scrutinees []) (map (fmap (fmap (fmap (SQ.:|: SQ.localL kx)))) clauses) ::: _T) + SQ.lamR x kx <$> check (patternBody (scrutinees []) (map (fmap (>< localL kx)) clauses) ::: _T) data Clause a = Clause @@ -230,6 +230,9 @@ patternBody scrutinees clauses = Check $ \ _T -> case scrutinees of [] -> check (body (head clauses) ::: _T) -- FIXME: throw an error if there aren't any clauses left +localL :: Applicative m => Name -> Type <==: m SQ.Coterm +localL = pure . pure . SQ.localL + muL :: (Has Fresh sig m, Has (Reader ElabContext) sig m) => (SQ.Term -> Type <==: m SQ.Command) -> Type <==: m SQ.Coterm muL body = Check $ \ _T -> do x <- freshName "x" From e32819a824f8558b2c6e6ff33b6a781f1d636e0f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 7 May 2022 10:51:09 -0400 Subject: [PATCH 1246/1324] Simplify lamS. --- src/Facet/Elab/Sequent.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 4c492ecda..716c655c9 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -90,7 +90,7 @@ lamS b = Check $ \ _T -> do (_, _A, _B) <- assertTacitFunction _T v <- freshName "v" k <- freshName "k" - SQ.lamR v k <$> check (b (pure (pure (SQ.localR v))) (pure (pure (SQ.localL k))) ::: _B) + SQ.lamR v k <$> check (b (pure (pure (SQ.localR v))) (localL k) ::: _B) lamS' :: (Has Fresh sig m, Has (Throw ErrReason) sig m) From a7c3b351b0e31b6e29fb9c3caed1f0029e2d670a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 7 May 2022 10:52:24 -0400 Subject: [PATCH 1247/1324] FIXME. --- src/Facet/Elab/Sequent.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 716c655c9..a653b6160 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -222,6 +222,7 @@ patternBody scrutinees clauses = Check $ \ _T -> case scrutinees of check (switch (pure (SQ.localR s :==> _A)) >< case' groups ::: _T) + -- FIXME: what should effect patterns elaborate to? _ -> check (patternBody scrutinees' (clauses >>= \case Clause (PVal PWildcard:ps) b -> [Clause ps b] Clause (PVal (PVar n) :ps) b -> [Clause ps (fmap (n :==> _A |-) b)] From 741a1fade2725c3548af424c62fa00cd45e36637 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 7 May 2022 12:46:11 -0400 Subject: [PATCH 1248/1324] Assume. --- src/Facet/Elab/Sequent.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index a653b6160..e9df11c3c 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -220,7 +220,7 @@ patternBody scrutinees clauses = Check $ \ _T -> case scrutinees of prefix <- for fieldTypes (\ _T -> (:==> _T) <$> freshName "x") pure (name :=: muL (const (patternBody (prefix <> scrutinees') (mapMaybe (filterClauses name fieldTypes) clauses))))) - check (switch (pure (SQ.localR s :==> _A)) >< case' groups ::: _T) + check (localR s >< case' groups ::: _T) -- FIXME: what should effect patterns elaborate to? _ -> check (patternBody scrutinees' (clauses >>= \case @@ -239,6 +239,9 @@ muL body = Check $ \ _T -> do x <- freshName "x" SQ.muL x <$> (x :==> _T |- check (body (SQ.localR x) ::: _T)) +localR :: Applicative m => Name -> Type <==: m SQ.Term +localR = pure . pure . SQ.localR + (><) :: Applicative m => Type <==: m SQ.Term -> Type <==: m SQ.Coterm -> Type <==: m SQ.Command t >< c = Check $ \ _T -> liftA2 (SQ.:|:) (check (t ::: _T)) (check (c ::: _T)) From 2b3dac15bdbf0c77b8a43af6db5454ccac396322 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 7 May 2022 14:43:57 -0400 Subject: [PATCH 1249/1324] Abbreviate elabWith. --- src/Facet/Elab.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 42627a878..1b1da37d9 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -343,9 +343,7 @@ spans_ = lens spans (\ e spans -> e{ spans }) -- Machinery elabWith :: (Subst Type -> a -> m b) -> ReaderC ElabContext (StateC (Subst Type) m) a -> m b -elabWith k m = runState k mempty $ do - let ctx = ElabContext{ context = Context.empty, typeContext = TypeContext.empty, sig = mempty, spans = Nil } - runReader ctx m +elabWith k = runState k mempty . runReader ElabContext{ context = Context.empty, typeContext = TypeContext.empty, sig = mempty, spans = Nil } elabKind :: Applicative m => ReaderC ElabContext (StateC (Subst Type) m) Kind -> m Kind elabKind = elabWith (const pure) From acbd1c06432b68966d56ac9912868674c2e0a33b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 7 May 2022 14:49:30 -0400 Subject: [PATCH 1250/1324] Generalize case'. --- src/Facet/Elab/Sequent.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index e9df11c3c..b199735c4 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -247,7 +247,7 @@ t >< c = Check $ \ _T -> liftA2 (SQ.:|:) (check (t ::: _T)) (check (c ::: _T)) infix 3 >< -case' :: Has Fresh sig m => [Name :=: (Type <==: m SQ.Coterm)] -> Type <==: m SQ.Coterm +case' :: Applicative m => [Name :=: (Type <==: m SQ.Coterm)] -> Type <==: m SQ.Coterm case' cases = Check $ \ _T -> SQ.SumL <$> traverse (traverse (\ body -> check (body ::: _T))) cases From c4eeac03ba1b7e68cc2e26cbc0144519517d0028 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 7 May 2022 14:53:25 -0400 Subject: [PATCH 1251/1324] :fire: an obsolete FIXME. --- src/Facet/Elab/Sequent.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index b199735c4..4d96e10a7 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -194,7 +194,6 @@ body_ :: Lens (Clause a) (Clause b) a b body_ = lens body (\ c body -> c{ body }) --- FIXME: try returning a coterm instead of a command patternBody :: (Has Fresh sig m, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => [Name :==> Type] From ff45da204eecf146ccc7b023f0d6902b67c8f8cc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 7 May 2022 20:56:12 -0400 Subject: [PATCH 1252/1324] Mismatches can be strings on both sides. --- src/Facet/Elab.hs | 10 +++++----- src/Facet/Notice/Elab.hs | 2 +- src/Facet/Unify.hs | 2 +- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 1b1da37d9..a8e26da9a 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -201,7 +201,7 @@ data ErrReason -- FIXME: add source references for the imports, definition sites, and any re-exports. | AmbiguousName QName | CouldNotSynthesize - | UnifyType UnifyErrReason (Exp (Either String Type)) (Act Type) + | UnifyType UnifyErrReason (Exp (Either String Type)) (Act (Either String Type)) | UnifyKind (Exp (Either String Kind)) (Act Kind) | Hole Name Type | Invariant String @@ -217,7 +217,7 @@ _AmbiguousName = prism' AmbiguousName (\case AmbiguousName n -> Just n _ -> Nothing) -_UnifyType :: Prism' ErrReason (UnifyErrReason, Exp (Either String Type), Act Type) +_UnifyType :: Prism' ErrReason (UnifyErrReason, Exp (Either String Type), Act (Either String Type)) _UnifyType = prism' (\ (r, x, a) -> UnifyType r x a) (\case UnifyType r x a -> Just (r, x, a) _ -> Nothing) @@ -242,7 +242,7 @@ applySubst subst r = case r of AmbiguousName{} -> r CouldNotSynthesize{} -> r -- NB: not substituting in @r@ because we want to retain the cyclic occurrence (and finitely) - UnifyType r exp act -> UnifyType r (fmap roundtrip <$> exp) (roundtrip <$> act) + UnifyType r exp act -> UnifyType r (fmap roundtrip <$> exp) (fmap roundtrip <$> act) UnifyKind{} -> r Hole n t -> Hole n (roundtrip t) Invariant{} -> r @@ -251,7 +251,7 @@ applySubst subst r = case r of roundtrip = apply subst Nil -mismatchTypes :: Has (Throw ErrReason) sig m => Exp (Either String Type) -> Act Type -> m a +mismatchTypes :: Has (Throw ErrReason) sig m => Exp (Either String Type) -> Act (Either String Type) -> m a mismatchTypes exp act = withFrozenCallStack $ throwError $ UnifyType Mismatch exp act mismatchKinds :: Has (Throw ErrReason) sig m => Exp (Either String Kind) -> Act Kind -> m a @@ -312,7 +312,7 @@ assertMatch :: Applicative m => (Exp (Either String b) -> Act s -> m a) -> Prism assertMatch mismatch pat exp _T = maybe (mismatch (Exp (Left exp)) (Act _T)) pure (_T ^? pat) assertTypesMatch :: Has (Throw ErrReason) sig m => Prism' Type a -> String -> Type -> m a -assertTypesMatch pat exp _T = maybe (mismatchTypes (Exp (Left exp)) (Act _T)) pure (_T ^? pat) +assertTypesMatch pat exp _T = maybe (mismatchTypes (Exp (Left exp)) (Act (Right _T))) pure (_T ^? pat) assertFunction :: Has (Throw ErrReason) sig m => Type -> m (Maybe Name, Type, Type) assertFunction = assertTypesMatch _Arrow "_ -> _" diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index 1daf18817..c99a93764 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -73,7 +73,7 @@ printErrReason opts ctx = group . \case Mismatch -> pretty "mismatch" Occurs v t -> reflow "infinite type:" <+> getPrint (print opts ctx (metavar v)) <+> reflow "occurs in" <+> getPrint (print opts ctx t) exp' = either reflow (getPrint . print opts ctx) exp - act' = getPrint (print opts ctx act) + act' = either reflow (getPrint . print opts ctx) act -- line things up nicely for e.g. wrapped function types align = nest 2 . (flatAlt (line <> stimes (3 :: Int) space) mempty <>) UnifyKind (Exp exp) (Act act) -> pretty "mismatch" diff --git a/src/Facet/Unify.hs b/src/Facet/Unify.hs index ed3b6e342..09af06331 100644 --- a/src/Facet/Unify.hs +++ b/src/Facet/Unify.hs @@ -37,7 +37,7 @@ unify :: (HasCallStack, Has (Reader ElabContext) sig m, Has (Throw ErrReason) si unify t1 t2 = runUnify t1 t2 (runState (const pure) (mempty :: Subst Type) (unifyType (getExp t1) (getAct t2))) runUnify :: Has (Throw ErrReason) sig m => Exp Type -> Act Type -> ThrowC ErrReason (WithCallStack UnifyErrReason) m a -> m a -runUnify t1 t2 = runThrow (withCallStack (\ r -> throwError (UnifyType r (Right <$> t1) t2))) +runUnify t1 t2 = runThrow (withCallStack (\ r -> throwError (UnifyType r (Right <$> t1) (Right <$> t2)))) runUnifyMaybe :: Applicative m => ErrorC (WithCallStack UnifyErrReason) m a -> m (Maybe a) runUnifyMaybe = runError (const (pure Nothing)) (pure . Just) From 8cb5dad73461ad4f05cbf18d3dff914d3de539c6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 7 May 2022 21:53:40 -0400 Subject: [PATCH 1253/1324] Throw a proper error when a neutral type doesn't reference a datatype. --- src/Facet/Elab/Sequent.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 4d96e10a7..4216b97a6 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -32,7 +32,7 @@ import Control.Effect.Fresh import Control.Effect.Reader import Control.Effect.State import Control.Effect.Throw -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (mapMaybe) import Data.Text (Text) import Data.Traversable (for) import Facet.Effect.Write @@ -203,9 +203,12 @@ patternBody scrutinees clauses = Check $ \ _T -> case scrutinees of (s :==> _A):scrutinees' -> case _A of Ne (Free qname) _ -> do def <- resolveDef qname - let constructors = fromMaybe [] (def ^? (_DData . Scope.toList_)) -- FIXME: throw an error if we can't find the datatype - - filterClauses name fieldTypes c = case c of + constructors <- maybe (mismatchTypes (Exp (Left "datatype")) (Act (Left (case def of + DTerm{} -> "term" + DSubmodule SData{} _ -> "datatype" + DSubmodule SInterface{} _ -> "interface" + DSubmodule SModule{} _ -> "module")))) pure (def ^? (_DData . Scope.toList_)) + let filterClauses name fieldTypes c = case c of Clause (PVal PWildcard :ps) b -> Just (Clause (padding <> ps) b) Clause (PVal (PVar n) :ps) b -> Just (Clause (padding <> ps) (fmap (n :==> _A |-) b)) Clause (PVal (PCon n fs):ps) b From 3284bd29f4fce643e761e7e68238d1d7ccf57f53 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 00:20:46 -0400 Subject: [PATCH 1254/1324] Define a debugging runner for sequents. --- src/Facet/Elab/Sequent.hs | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 4216b97a6..7feec846f 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -24,23 +24,25 @@ module Facet.Elab.Sequent , assertTacitFunction -- * Judgements , check + -- * Debugging +, runSQ ) where import Control.Applicative (liftA2) -import Control.Effect.Empty -import Control.Effect.Fresh -import Control.Effect.Reader -import Control.Effect.State +import Control.Carrier.Fresh.Church +import Control.Carrier.Reader +import Control.Carrier.State.Church import Control.Effect.Throw import Data.Maybe (mapMaybe) import Data.Text (Text) import Data.Traversable (for) +import qualified Facet.Context as C import Facet.Effect.Write import Facet.Elab import qualified Facet.Elab.Type as Type import Facet.Functor.Check import Facet.Functor.Synth -import Facet.Graph +import Facet.Graph as G import Facet.Kind import Facet.Lens as Lens (views) import Facet.Module @@ -53,6 +55,7 @@ import qualified Facet.Surface.Term.Expr as S import qualified Facet.Surface.Type.Expr as S import Facet.Syntax as S hiding (context_) import Facet.Type.Norm as T hiding (($$)) +import qualified Facet.TypeContext as TC import Facet.Unify import Fresnel.Fold ((^?)) import Fresnel.Lens (Lens, Lens', lens) @@ -269,3 +272,14 @@ assertTacitFunction = assertTypesMatch _Arrow "_ -> _" -- FIXME: this binds non- check :: (Type <==: m a) ::: Type -> m a check (m ::: _T) = m <==: _T + + +-- Debugging + +runSQ :: Applicative m => Module -> ReaderC Graph (ReaderC Module (FreshC (ReaderC ElabContext (StateC (Subst Type) m)))) a -> m a +runSQ m + = runState (const pure) mempty + . runReader ElabContext{ context = C.empty, typeContext = TC.empty, sig = mempty, spans = mempty } + . runFresh (const pure) 0 + . runReader m + . runReader (G.singleton Nothing m) From 97f522785870ba92d0bb557eaa6c8537b8ae099e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 09:46:33 -0400 Subject: [PATCH 1255/1324] Products are eliminated by a coterm. --- src/Facet/Sequent/Expr.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 8ab07bbe3..a662bc23e 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -54,7 +54,7 @@ data Coterm | MuL Scope | LamL Term Coterm | SumL [Name :=: Coterm] - | PrdL Int Scope + | PrdL Int Coterm -- Commands @@ -139,7 +139,7 @@ replaceCoterm lr within = case within of MuL (Scope b) -> MuL (Scope (replaceCommand (lr & _That.outer_ %~ succ) b)) LamL a k -> LamL (replaceTerm lr a) (replaceCoterm lr k) SumL cs -> SumL (map (fmap (replaceCoterm lr)) cs) - PrdL i (Scope b) -> PrdL i (Scope (replaceCommand (lr & _This.outer_ +~ Index i) b)) + PrdL i b -> PrdL i (replaceCoterm (lr & _This.outer_ +~ Index i) b) where this :: c -> (a -> c) -> These a b -> c this d f = these f (const d) (const . f) From 62100e089e65b72e40d5c0275919fdead5b8deef Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 10:36:41 -0400 Subject: [PATCH 1256/1324] Define a bound variable constructor. --- src/Facet/Sequent/Expr.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index a662bc23e..fd630f466 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -16,6 +16,7 @@ module Facet.Sequent.Expr -- * Smart constructors , localR , globalR +, boundR , muR , lamR , lamR' @@ -165,6 +166,9 @@ localR = Var . Free . q globalR :: QName -> Term globalR = Var . Free +boundR :: Index -> Term +boundR = Var . Bound + muR :: Name -> Command -> Term muR name body = MuR (abstractLR (This name) body) From 61b261f126c5fea21ef7e4323b4693caef6d64f0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 10:37:20 -0400 Subject: [PATCH 1257/1324] Define a bound covariable constructor. --- src/Facet/Sequent/Expr.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index fd630f466..2328973c8 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -21,6 +21,7 @@ module Facet.Sequent.Expr , lamR , lamR' , localL +, boundL , muL , let' ) where @@ -182,6 +183,9 @@ lamR' name body = lamR name name (body :|: Covar (Free (q name))) localL :: Name -> Coterm localL = Covar . Free . q +boundL :: Index -> Coterm +boundL = Covar . Bound + muL :: Name -> Command -> Coterm muL name body = MuL (abstractLR (That name) body) From 22ab8fa426cb7c7b2e89060afbf64bb3d463d299 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 10:37:36 -0400 Subject: [PATCH 1258/1324] Define Print instances for sequents. --- src/Facet/Print.hs | 49 +++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 48 insertions(+), 1 deletion(-) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 936c28d41..2e9b03e9f 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -30,16 +30,18 @@ module Facet.Print import Data.Foldable (foldl') import Data.Maybe (fromMaybe) import qualified Data.Text as T +import Data.These import Facet.Env as Env import Facet.Interface import Facet.Kind import qualified Facet.Module as C import Facet.Name as Name import Facet.Pattern -import Facet.Pretty (lower, upper) +import Facet.Pretty (lower, subscript, upper) import Facet.Print.Options import Facet.Quote import qualified Facet.Scope as C +import qualified Facet.Sequent.Expr as SQ import Facet.Snoc import Facet.Snoc.NonEmpty (NonEmpty(..)) import Facet.Style @@ -209,6 +211,51 @@ instance Printable a => Printable (Pattern a) where print = print1 +sqbinder :: Level -> (Name :=: Print -> Print) -> Print +sqbinder d f = let n = G (T.pack "x") (getLevel d) ; v = pretty n in f (n :=: v) + +sqblock :: Print -> Print +sqblock = braces . enclose space space + +instance Printable SQ.Term where + print opts@Options{ qname } = go + where + go env = \case + SQ.Var (Free n) -> qvar n + SQ.Var (Bound n) -> fromMaybe (intro __ (toLeveled d n)) $ env Env.!? n + SQ.MuR b -> pretty "µ" <> sqbinder d (\ p@(n :=: v) -> sqblock (v <+> dot <+> print opts (env |> p) (SQ.instantiateR (SQ.localR n) b))) + SQ.LamR b -> pretty "λ" <> sqbinder d (\ x@(xn :=: xv) -> sqbinder (succ d) (\ k@(kn :=: kv) -> sqblock (xv <+> kv <+> dot <+> print opts (env |> x |> k) (SQ.instantiateLR (These (SQ.localL kn) (SQ.localR xn)) b)))) + SQ.SumR n t -> pretty n <+> print opts env t + SQ.PrdR ts -> tupled (map (print opts env) ts) + SQ.StringR s -> annotate Lit (pretty (show s)) + where + d = level env + qvar = group . setPrec Var . qname + +instance Printable SQ.Coterm where + print opts@Options{ qname } = go + where + go env = \case + SQ.Covar (Free n) -> qvar n + SQ.Covar (Bound n) -> fromMaybe (intro __ (toLeveled d n)) $ env Env.!? n + SQ.MuL b -> pretty "µ̃" <> sqbinder d (\ p@(n :=: v) -> sqblock (v <+> dot <+> print opts (env |> p) (SQ.instantiateL (SQ.localL n) b))) + SQ.LamL a k -> print opts env a <> print opts env k + SQ.SumL bs -> pretty "case" <+> sqblock (encloseSep mempty mempty (pretty ", ") (map (\ (n :=: b) -> parens (pretty n) <+> dot <+> print opts env b) bs)) + SQ.PrdL i b -> pretty 'π' <> subscript i <+> print opts env b + where + d = level env + qvar = group . setPrec Var . qname + +instance Printable SQ.Command where + print opts = go + where + go env = \case + t SQ.:|: c -> angles (print opts env t <+> pretty '|' <+> print opts env c) + SQ.Let t b -> pretty "let" <+> sqbinder d (\ p@(n :=: v) -> sqblock (v <+> pretty '=' <+> print opts env t) <+> pretty "in" <+> print opts (env |> p) (SQ.instantiateR (SQ.localR n) b)) + where + d = level env + + instance Printable C.Module where print opts env (C.Module mname is _ ds) = module_ mname From a55a169135bae2e974fdd6f48246a840936fba16 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 10:38:49 -0400 Subject: [PATCH 1259/1324] Rename the free (co)variable smart constructors. --- src/Facet/Elab/Sequent.hs | 8 ++++---- src/Facet/Print.hs | 8 ++++---- src/Facet/Sequent/Expr.hs | 12 ++++++------ 3 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 7feec846f..f7eaec131 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -93,7 +93,7 @@ lamS b = Check $ \ _T -> do (_, _A, _B) <- assertTacitFunction _T v <- freshName "v" k <- freshName "k" - SQ.lamR v k <$> check (b (pure (pure (SQ.localR v))) (localL k) ::: _B) + SQ.lamR v k <$> check (b (pure (pure (SQ.freeR v))) (localL k) ::: _B) lamS' :: (Has Fresh sig m, Has (Throw ErrReason) sig m) @@ -237,15 +237,15 @@ patternBody scrutinees clauses = Check $ \ _T -> case scrutinees of localL :: Applicative m => Name -> Type <==: m SQ.Coterm -localL = pure . pure . SQ.localL +localL = pure . pure . SQ.freeL muL :: (Has Fresh sig m, Has (Reader ElabContext) sig m) => (SQ.Term -> Type <==: m SQ.Command) -> Type <==: m SQ.Coterm muL body = Check $ \ _T -> do x <- freshName "x" - SQ.muL x <$> (x :==> _T |- check (body (SQ.localR x) ::: _T)) + SQ.muL x <$> (x :==> _T |- check (body (SQ.freeR x) ::: _T)) localR :: Applicative m => Name -> Type <==: m SQ.Term -localR = pure . pure . SQ.localR +localR = pure . pure . SQ.freeR (><) :: Applicative m => Type <==: m SQ.Term -> Type <==: m SQ.Coterm -> Type <==: m SQ.Command t >< c = Check $ \ _T -> liftA2 (SQ.:|:) (check (t ::: _T)) (check (c ::: _T)) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 2e9b03e9f..a793fd662 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -223,8 +223,8 @@ instance Printable SQ.Term where go env = \case SQ.Var (Free n) -> qvar n SQ.Var (Bound n) -> fromMaybe (intro __ (toLeveled d n)) $ env Env.!? n - SQ.MuR b -> pretty "µ" <> sqbinder d (\ p@(n :=: v) -> sqblock (v <+> dot <+> print opts (env |> p) (SQ.instantiateR (SQ.localR n) b))) - SQ.LamR b -> pretty "λ" <> sqbinder d (\ x@(xn :=: xv) -> sqbinder (succ d) (\ k@(kn :=: kv) -> sqblock (xv <+> kv <+> dot <+> print opts (env |> x |> k) (SQ.instantiateLR (These (SQ.localL kn) (SQ.localR xn)) b)))) + SQ.MuR b -> pretty "µ" <> sqbinder d (\ p@(n :=: v) -> sqblock (v <+> dot <+> print opts (env |> p) (SQ.instantiateR (SQ.freeR n) b))) + SQ.LamR b -> pretty "λ" <> sqbinder d (\ x@(xn :=: xv) -> sqbinder (succ d) (\ k@(kn :=: kv) -> sqblock (xv <+> kv <+> dot <+> print opts (env |> x |> k) (SQ.instantiateLR (These (SQ.freeL kn) (SQ.freeR xn)) b)))) SQ.SumR n t -> pretty n <+> print opts env t SQ.PrdR ts -> tupled (map (print opts env) ts) SQ.StringR s -> annotate Lit (pretty (show s)) @@ -238,7 +238,7 @@ instance Printable SQ.Coterm where go env = \case SQ.Covar (Free n) -> qvar n SQ.Covar (Bound n) -> fromMaybe (intro __ (toLeveled d n)) $ env Env.!? n - SQ.MuL b -> pretty "µ̃" <> sqbinder d (\ p@(n :=: v) -> sqblock (v <+> dot <+> print opts (env |> p) (SQ.instantiateL (SQ.localL n) b))) + SQ.MuL b -> pretty "µ̃" <> sqbinder d (\ p@(n :=: v) -> sqblock (v <+> dot <+> print opts (env |> p) (SQ.instantiateL (SQ.freeL n) b))) SQ.LamL a k -> print opts env a <> print opts env k SQ.SumL bs -> pretty "case" <+> sqblock (encloseSep mempty mempty (pretty ", ") (map (\ (n :=: b) -> parens (pretty n) <+> dot <+> print opts env b) bs)) SQ.PrdL i b -> pretty 'π' <> subscript i <+> print opts env b @@ -251,7 +251,7 @@ instance Printable SQ.Command where where go env = \case t SQ.:|: c -> angles (print opts env t <+> pretty '|' <+> print opts env c) - SQ.Let t b -> pretty "let" <+> sqbinder d (\ p@(n :=: v) -> sqblock (v <+> pretty '=' <+> print opts env t) <+> pretty "in" <+> print opts (env |> p) (SQ.instantiateR (SQ.localR n) b)) + SQ.Let t b -> pretty "let" <+> sqbinder d (\ p@(n :=: v) -> sqblock (v <+> pretty '=' <+> print opts env t) <+> pretty "in" <+> print opts (env |> p) (SQ.instantiateR (SQ.freeR n) b)) where d = level env diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 2328973c8..4673b433e 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -14,13 +14,13 @@ module Facet.Sequent.Expr , instantiateR , instantiateLR -- * Smart constructors -, localR +, freeR , globalR , boundR , muR , lamR , lamR' -, localL +, freeL , boundL , muL , let' @@ -161,8 +161,8 @@ _That = prism' That (these (const Nothing) Just (const (const Nothing))) -- Smart constructors -localR :: Name -> Term -localR = Var . Free . q +freeR :: Name -> Term +freeR = Var . Free . q globalR :: QName -> Term globalR = Var . Free @@ -180,8 +180,8 @@ lamR' :: Name -> Term -> Term lamR' name body = lamR name name (body :|: Covar (Free (q name))) -localL :: Name -> Coterm -localL = Covar . Free . q +freeL :: Name -> Coterm +freeL = Covar . Free . q boundL :: Index -> Coterm boundL = Covar . Bound From b31fd61095b44fcabe231413b0cb402d7a17189d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 10:42:20 -0400 Subject: [PATCH 1260/1324] Rename the free (co)variable elaborators. --- src/Facet/Elab/Sequent.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index f7eaec131..aaae3a9b7 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -93,7 +93,7 @@ lamS b = Check $ \ _T -> do (_, _A, _B) <- assertTacitFunction _T v <- freshName "v" k <- freshName "k" - SQ.lamR v k <$> check (b (pure (pure (SQ.freeR v))) (localL k) ::: _B) + SQ.lamR v k <$> check (b (pure (pure (SQ.freeR v))) (freeL k) ::: _B) lamS' :: (Has Fresh sig m, Has (Throw ErrReason) sig m) @@ -181,7 +181,7 @@ checkLamS clauses = Check (go id) _T -> do x <- freshName "x" kx <- freshName "kx" - SQ.lamR x kx <$> check (patternBody (scrutinees []) (map (fmap (>< localL kx)) clauses) ::: _T) + SQ.lamR x kx <$> check (patternBody (scrutinees []) (map (fmap (>< freeL kx)) clauses) ::: _T) data Clause a = Clause @@ -225,7 +225,7 @@ patternBody scrutinees clauses = Check $ \ _T -> case scrutinees of prefix <- for fieldTypes (\ _T -> (:==> _T) <$> freshName "x") pure (name :=: muL (const (patternBody (prefix <> scrutinees') (mapMaybe (filterClauses name fieldTypes) clauses))))) - check (localR s >< case' groups ::: _T) + check (freeR s >< case' groups ::: _T) -- FIXME: what should effect patterns elaborate to? _ -> check (patternBody scrutinees' (clauses >>= \case @@ -236,16 +236,16 @@ patternBody scrutinees clauses = Check $ \ _T -> case scrutinees of [] -> check (body (head clauses) ::: _T) -- FIXME: throw an error if there aren't any clauses left -localL :: Applicative m => Name -> Type <==: m SQ.Coterm -localL = pure . pure . SQ.freeL +freeL :: Applicative m => Name -> Type <==: m SQ.Coterm +freeL = pure . pure . SQ.freeL muL :: (Has Fresh sig m, Has (Reader ElabContext) sig m) => (SQ.Term -> Type <==: m SQ.Command) -> Type <==: m SQ.Coterm muL body = Check $ \ _T -> do x <- freshName "x" SQ.muL x <$> (x :==> _T |- check (body (SQ.freeR x) ::: _T)) -localR :: Applicative m => Name -> Type <==: m SQ.Term -localR = pure . pure . SQ.freeR +freeR :: Applicative m => Name -> Type <==: m SQ.Term +freeR = pure . pure . SQ.freeR (><) :: Applicative m => Type <==: m SQ.Term -> Type <==: m SQ.Coterm -> Type <==: m SQ.Command t >< c = Check $ \ _T -> liftA2 (SQ.:|:) (check (t ::: _T)) (check (c ::: _T)) From 35f8f3b7fd8b43150511ec902c6b76c1dd5d099e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 11:16:20 -0400 Subject: [PATCH 1261/1324] Swap the variable names to indicate ordering. --- src/Facet/Sequent/Expr.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 4673b433e..a479d11c6 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -174,7 +174,7 @@ muR :: Name -> Command -> Term muR name body = MuR (abstractLR (This name) body) lamR :: Name -> Name -> Command -> Term -lamR v k body = LamR (abstractLR (These v k) body) +lamR k v body = LamR (abstractLR (These k v) body) lamR' :: Name -> Term -> Term lamR' name body = lamR name name (body :|: Covar (Free (q name))) From f6dcd3513aa1c26ddd834ed77d172e708a10c68d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 11:37:32 -0400 Subject: [PATCH 1262/1324] Define an IsString instance for Term. --- src/Facet/Sequent/Expr.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index a479d11c6..3973500aa 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -28,6 +28,7 @@ module Facet.Sequent.Expr import Data.Bifunctor (bimap) import Data.Function ((&)) +import Data.String import Data.Text (Text) import Data.These import Facet.Name @@ -48,6 +49,9 @@ data Term | PrdR [Term] | StringR Text +instance IsString Term where + fromString = freeR . fromString + -- Coterms From 99b96c22a06309432c1eb3ad77e51fda7d9f3f33 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 11:38:04 -0400 Subject: [PATCH 1263/1324] Define an IsString instance for Coterm. --- src/Facet/Sequent/Expr.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 3973500aa..4bbb03639 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -62,6 +62,9 @@ data Coterm | SumL [Name :=: Coterm] | PrdL Int Coterm +instance IsString Coterm where + fromString = freeL . fromString + -- Commands From cb67f236c5806b02bb101e58ee6b71612d722bb0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 11:50:13 -0400 Subject: [PATCH 1264/1324] Replace the optics on These. --- src/Facet/Sequent/Expr.hs | 30 ++++++++++-------------------- 1 file changed, 10 insertions(+), 20 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 4bbb03639..88b0e72bd 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -26,8 +26,7 @@ module Facet.Sequent.Expr , let' ) where -import Data.Bifunctor (bimap) -import Data.Function ((&)) +import Data.Bifunctor (Bifunctor(..)) import Data.String import Data.Text (Text) import Data.These @@ -35,9 +34,6 @@ import Facet.Name import Facet.Snoc import Facet.Snoc.NonEmpty import Facet.Syntax -import Fresnel.Lens (Lens', lens) -import Fresnel.Prism -import Fresnel.Setter ((%~), (+~)) -- Terms @@ -117,22 +113,23 @@ data Replacer t = Replacer , bound :: Index -> Index -> t } -outer_ :: Lens' (Replacer t) Index -outer_ = lens outer (\ Replacer{ free, bound } outer -> Replacer{ outer, free, bound }) - free' :: Replacer t -> Name -> t free' Replacer{ outer, free } = free outer bound' :: Replacer t -> Index -> t bound' Replacer{ outer, bound } = bound outer +incr :: Replacer t -> Replacer t +incr r@Replacer{ outer } = r{ outer = outer + 1} + + replaceTerm :: These (Replacer Coterm) (Replacer Term) -> (Term -> Term) replaceTerm lr within = case within of Var (Free (Nil:|>n)) -> that (const within) free' lr n Var (Free _) -> within Var (Bound inner) -> that (const within) bound' lr inner - MuR (Scope b) -> MuR (Scope (replaceCommand (lr & _This.outer_ %~ succ) b)) - LamR (Scope b) -> LamR (Scope (replaceCommand (lr & _This.outer_ %~ succ & _That.outer_ %~ succ) b)) + MuR (Scope b) -> MuR (Scope (replaceCommand (first incr lr) b)) + LamR (Scope b) -> LamR (Scope (replaceCommand (bimap incr incr lr) b)) SumR i a -> SumR i (replaceTerm lr a) PrdR as -> PrdR (map (replaceTerm lr) as) StringR _ -> within @@ -145,10 +142,10 @@ replaceCoterm lr within = case within of Covar (Free (Nil:|>n)) -> this (const within) free' lr n Covar (Free _) -> within Covar (Bound inner) -> this (const within) bound' lr inner - MuL (Scope b) -> MuL (Scope (replaceCommand (lr & _That.outer_ %~ succ) b)) + MuL (Scope b) -> MuL (Scope (replaceCommand (second incr lr) b)) LamL a k -> LamL (replaceTerm lr a) (replaceCoterm lr k) SumL cs -> SumL (map (fmap (replaceCoterm lr)) cs) - PrdL i b -> PrdL i (replaceCoterm (lr & _This.outer_ +~ Index i) b) + PrdL i b -> PrdL i (replaceCoterm lr b) where this :: c -> (a -> c) -> These a b -> c this d f = these f (const d) (const . f) @@ -156,14 +153,7 @@ replaceCoterm lr within = case within of replaceCommand :: These (Replacer Coterm) (Replacer Term) -> (Command -> Command) replaceCommand lr = \case t :|: c -> replaceTerm lr t :|: replaceCoterm lr c - Let t (Scope b) -> Let (replaceTerm lr t) (Scope (replaceCommand (lr & _That.outer_ %~ succ) b)) - - -_This :: Prism' (These a b) a -_This = prism' This (these Just (const Nothing) (const (const Nothing))) - -_That :: Prism' (These a b) b -_That = prism' That (these (const Nothing) Just (const (const Nothing))) + Let t (Scope b) -> Let (replaceTerm lr t) (Scope (replaceCommand (second incr lr) b)) -- Smart constructors From 49db7ad5f563b31ecc2fb54fef573d654ca74c9a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 15:19:56 -0400 Subject: [PATCH 1265/1324] Run a Throw handler. --- src/Facet/Elab/Sequent.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index aaae3a9b7..80e96dcae 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -32,7 +32,7 @@ import Control.Applicative (liftA2) import Control.Carrier.Fresh.Church import Control.Carrier.Reader import Control.Carrier.State.Church -import Control.Effect.Throw +import Control.Carrier.Throw.Either import Data.Maybe (mapMaybe) import Data.Text (Text) import Data.Traversable (for) @@ -276,10 +276,11 @@ check (m ::: _T) = m <==: _T -- Debugging -runSQ :: Applicative m => Module -> ReaderC Graph (ReaderC Module (FreshC (ReaderC ElabContext (StateC (Subst Type) m)))) a -> m a +runSQ :: Applicative m => Module -> ThrowC ErrReason (ReaderC Graph (ReaderC Module (FreshC (ReaderC ElabContext (StateC (Subst Type) m))))) a -> m (Either ErrReason a) runSQ m = runState (const pure) mempty . runReader ElabContext{ context = C.empty, typeContext = TC.empty, sig = mempty, spans = mempty } . runFresh (const pure) 0 . runReader m . runReader (G.singleton Nothing m) + . runThrow From 9942795d324cbcf2544364bd676cd11250fb1a65 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 15:21:59 -0400 Subject: [PATCH 1266/1324] Derive Show instances for Exp & Act. --- src/Facet/Syntax.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Syntax.hs b/src/Facet/Syntax.hs index 44357f8fe..c3998d51e 100644 --- a/src/Facet/Syntax.hs +++ b/src/Facet/Syntax.hs @@ -173,10 +173,10 @@ splitr un = go id -- Assertion data newtype Exp a = Exp { getExp :: a } - deriving (Functor) + deriving (Functor, Show) newtype Act a = Act { getAct :: a } - deriving (Functor) + deriving (Functor, Show) -- Natural transformations From cf078ec4368e0a8524b0981202fae383458850fb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 15:22:08 -0400 Subject: [PATCH 1267/1324] Derive Show instances for error reasons. --- src/Facet/Elab.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index a8e26da9a..4b8c12d8e 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -206,6 +206,7 @@ data ErrReason | Hole Name Type | Invariant String | MissingInterface (Interface Type) + deriving (Show) _FreeVariable :: Prism' ErrReason QName _FreeVariable = prism' FreeVariable (\case @@ -225,6 +226,7 @@ _UnifyType = prism' (\ (r, x, a) -> UnifyType r x a) (\case data UnifyErrReason = Mismatch | Occurs Meta Type + deriving (Show) _Mismatch :: Prism' UnifyErrReason () _Mismatch = prism' (const Mismatch) (\case From d1d241c7a80ea1b34ac17ccbf96fe684a9938bc0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 15:31:57 -0400 Subject: [PATCH 1268/1324] Derive a Show instance for Synth. --- src/Facet/Functor/Synth.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Functor/Synth.hs b/src/Facet/Functor/Synth.hs index 53be9f301..59f33e235 100644 --- a/src/Facet/Functor/Synth.hs +++ b/src/Facet/Functor/Synth.hs @@ -15,7 +15,7 @@ import Data.Bitraversable -- Synth judgement data a :==> b = a :==> b - deriving (Foldable, Functor, Traversable) + deriving (Foldable, Functor, Show, Traversable) infixr 2 :==> From 8489ff1ebb302ebb2026a10f1a7db8f05e86d0ff Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 15:32:45 -0400 Subject: [PATCH 1269/1324] Derive Show instances for sequents. --- src/Facet/Sequent/Expr.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 88b0e72bd..29bebb65b 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -44,6 +44,7 @@ data Term | SumR Name Term | PrdR [Term] | StringR Text + deriving (Show) instance IsString Term where fromString = freeR . fromString @@ -57,6 +58,7 @@ data Coterm | LamL Term Coterm | SumL [Name :=: Coterm] | PrdL Int Coterm + deriving (Show) instance IsString Coterm where fromString = freeL . fromString @@ -67,6 +69,7 @@ instance IsString Coterm where data Command = Term :|: Coterm | Let Term Scope + deriving (Show) infix 2 :|: @@ -74,6 +77,7 @@ infix 2 :|: -- Scopes newtype Scope = Scope { getScope :: Command } + deriving (Show) abstractL, abstractR :: Name -> (Command -> Scope) abstractL c = abstractLR (This c) From 1f0d90b25bbb56335b92792d609b3aa6422834fe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 15:34:01 -0400 Subject: [PATCH 1270/1324] Export switch. --- src/Facet/Elab/Sequent.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 80e96dcae..e1e46d760 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -11,6 +11,7 @@ module Facet.Elab.Sequent -- * Eliminators , appS -- * General combinators +, switch , freshName -- * Elaboration , synthExprS From 2903c3df409e3aad8458888df09b94ceeb004b44 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 20:36:01 -0400 Subject: [PATCH 1271/1324] Define a smart constructor for kind arrows. --- src/Facet/Kind.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/Facet/Kind.hs b/src/Facet/Kind.hs index bd74153b2..f3de1a064 100644 --- a/src/Facet/Kind.hs +++ b/src/Facet/Kind.hs @@ -1,8 +1,11 @@ module Facet.Kind -( Kind(..) +( -- * Kinds + Kind(..) , _KType , _KInterface , _KArrow + -- * Constructors +, (==>) ) where import Facet.Name @@ -24,3 +27,10 @@ _KInterface = prism' (const KInterface) (\case{ KInterface -> Just () ; _ -> Not _KArrow :: Prism' Kind (Maybe Name, Kind, Kind) _KArrow = prism' (\ (n, a, b) -> KArrow n a b) (\case{ KArrow n a b -> Just (n, a, b) ; _ -> Nothing }) + + +-- Constructors + +(==>) :: Kind -> Kind -> Kind +(==>) = KArrow Nothing +infixr 1 ==> From 409ecfed9ac3933987a2943e4c5fc78f8ed35b72 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 20:37:30 -0400 Subject: [PATCH 1272/1324] Define a smart constructor for type arrows. --- src/Facet/Type/Norm.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index b37c4f3ce..13b2d7f8a 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -6,9 +6,11 @@ module Facet.Type.Norm , _Arrow , _Ne , _Comp + -- ** Construction , bound , free , metavar +, (-->) , unNeutral , unComp , occursIn @@ -95,6 +97,12 @@ var :: Var (Either Meta Level) -> Type var v = Ne v Nil +(-->) :: Type -> Type -> Type +(-->) = Arrow Nothing + +infixr 1 --> + + unNeutral :: Has Empty sig m => Type -> m (Var (Either Meta Level), Snoc Type) unNeutral = \case Ne h sp -> pure (h, sp) From 4ca66263f4ee57c4114ec447b1623127e94c2ee2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 20:52:29 -0400 Subject: [PATCH 1273/1324] Define a smart constructor for QName. --- src/Facet/Name.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 8f6719cc6..713432bea 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -8,6 +8,7 @@ module Facet.Name , Meta(..) , __ , QName +, (//) , q , prettyQName , Name(..) @@ -76,6 +77,11 @@ __ = T T.empty -- | Qualified names, consisting of a module name and declaration name. type QName = NonEmpty Name +(//) :: QName -> Name -> QName +(//) = (|>) + +infixl 5 // + q :: Name -> QName q = (Nil :|>) From eaabea0722c044d893b1c114fe6d76951b491bd5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 20:55:25 -0400 Subject: [PATCH 1274/1324] Simplify unit construction. --- src/Facet/Elab/Term.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 54dfcc59e..670a1f610 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -164,7 +164,7 @@ varP :: Name -> Bind m (ValPattern (Name :==> Type)) varP n = Bind $ \ _A k -> k (PVar (n :==> wrap _A)) where wrap = \case - T.Comp sig _A -> T.Arrow Nothing (T.Ne (Free (NE.FromList ["Data", "Unit"] |> T "Unit")) Nil) (T.Comp sig _A) + T.Comp sig _A -> T.Arrow Nothing (T.free (NE.FromList ["Data", "Unit"] |> T "Unit")) (T.Comp sig _A) _T -> _T conP :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> [Bind m (ValPattern (Name :==> Type))] -> Bind m (ValPattern (Name :==> Type)) @@ -186,7 +186,7 @@ fieldsP = foldr cons nil allP :: Has (Throw ErrReason :+: Write Warn) sig m => Name -> Bind m (Pattern (Name :==> Type)) allP n = Bind $ \ _A k -> do (sig, _T) <- assertComp _A - k (PVal (PVar (n :==> T.Arrow Nothing (T.Ne (Free (NE.FromList ["Data", "Unit"] |> T "Unit")) Nil) (T.Comp sig _T)))) + k (PVal (PVar (n :==> T.Arrow Nothing (T.free (NE.FromList ["Data", "Unit"] |> T "Unit")) (T.Comp sig _T)))) -- Expression elaboration From 27df986636da3790d7b25315ce22301f3d04ab9f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 20:56:47 -0400 Subject: [PATCH 1275/1324] Simplify unit module references. --- src/Facet/Elab/Term.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 670a1f610..6f465fcf9 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -164,7 +164,7 @@ varP :: Name -> Bind m (ValPattern (Name :==> Type)) varP n = Bind $ \ _A k -> k (PVar (n :==> wrap _A)) where wrap = \case - T.Comp sig _A -> T.Arrow Nothing (T.free (NE.FromList ["Data", "Unit"] |> T "Unit")) (T.Comp sig _A) + T.Comp sig _A -> T.Arrow Nothing (T.free (NE.FromList ["Data", "Unit", "Unit"])) (T.Comp sig _A) _T -> _T conP :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> [Bind m (ValPattern (Name :==> Type))] -> Bind m (ValPattern (Name :==> Type)) @@ -186,7 +186,7 @@ fieldsP = foldr cons nil allP :: Has (Throw ErrReason :+: Write Warn) sig m => Name -> Bind m (Pattern (Name :==> Type)) allP n = Bind $ \ _A k -> do (sig, _T) <- assertComp _A - k (PVal (PVar (n :==> T.Arrow Nothing (T.free (NE.FromList ["Data", "Unit"] |> T "Unit")) (T.Comp sig _T)))) + k (PVal (PVar (n :==> T.Arrow Nothing (T.free (NE.FromList ["Data", "Unit", "Unit"])) (T.Comp sig _T)))) -- Expression elaboration From 5bca4446e777ec9f4004e60260f8cb6a722553d6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 21:01:03 -0400 Subject: [PATCH 1276/1324] Use the QName smart constructor. --- src/Facet/Module.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index f6e6258f8..9a795ab62 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -28,7 +28,6 @@ import Data.Coerce import Facet.Kind import Facet.Name import Facet.Scope -import Facet.Snoc.NonEmpty ((|>)) import Facet.Syntax import Facet.Term.Expr import Facet.Type.Norm @@ -75,11 +74,11 @@ foldMapC f = getChoosing #. foldMap (Choosing #. f) lookupConstructor :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Type) -lookupConstructor n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (scope ^? toList_.folded.def_._DData.ix n) +lookupConstructor n Module{ name, scope } = maybe empty (pure . (name // n :=:)) (scope ^? toList_.folded.def_._DData.ix n) -- | Look up effect operations. lookupOperation :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Type) -lookupOperation n Module{ name, scope } = maybe empty (pure . (name |> n :=:)) (scope ^? toList_.folded.def_._DInterface.ix n) +lookupOperation n Module{ name, scope } = maybe empty (pure . (name // n :=:)) (scope ^? toList_.folded.def_._DInterface.ix n) lookupDef :: Has Empty sig m => Name -> Module -> m Def lookupDef n = maybe empty pure . preview (scope_.ix n) From 73f8861c74d217c113cf2ccf302605b0f600935f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 21:01:37 -0400 Subject: [PATCH 1277/1324] Construct QNames from Names using q. --- src/Facet/Print.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index a793fd662..2383ad243 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -281,7 +281,7 @@ instance (Printable a, Printable b) => Printable (a :=: b) where print = print2 instance Printable Name where - print Options{ qname } _ = qname . (Nil :|>) + print Options{ qname } _ = qname . q class Printable1 f where From ccc33ffe13fe97b9ca3751c01697c928beee7fa5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 22:17:17 -0400 Subject: [PATCH 1278/1324] Define an eliminator for QNames. --- src/Facet/Name.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 713432bea..e5de8372e 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -10,6 +10,7 @@ module Facet.Name , QName , (//) , q +, qlast , prettyQName , Name(..) , Assoc(..) @@ -85,6 +86,9 @@ infixl 5 // q :: Name -> QName q = (Nil :|>) +qlast :: QName -> Name +qlast (_ :|> l) = l + prettyQName :: Printer a => QName -> a prettyQName (ns:|>n) = foldr' (surround dot . pretty) (pretty n) ns From 5b15eda84af0d5a2c6246b3dd7e3e3248d739b95 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 22:17:41 -0400 Subject: [PATCH 1279/1324] Construct QNames using //. --- src/Facet/Elab/Term.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 6f465fcf9..6e9c63c16 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -275,7 +275,7 @@ elabDataDef constructors = Check $ \ _K -> do mname <- Lens.view name_ for constructors $ \ (S.Ann _ _ (n ::: t)) -> do c_T <- elabType $ runErr $ abstractType (Type.switch (synthType t) <==: KType) _K - con' <- elabTerm $ runErr $ check (abstractTerm (const (Con (mname |> n) . toList)) ::: c_T) + con' <- elabTerm $ runErr $ check (abstractTerm (const (Con (mname // n) . toList)) ::: c_T) pure $ n :=: con' ::: c_T elabInterfaceDef From 276692048d89ea633017ec9c0b9121d21d33f680 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 8 May 2022 22:23:04 -0400 Subject: [PATCH 1280/1324] Avoid referencing NonEmpty snocs for QName. --- src/Facet/Print.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 2383ad243..4cc2ceab7 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -43,7 +43,6 @@ import Facet.Quote import qualified Facet.Scope as C import qualified Facet.Sequent.Expr as SQ import Facet.Snoc -import Facet.Snoc.NonEmpty (NonEmpty(..)) import Facet.Style import Facet.Syntax hiding (Ann(..)) import qualified Facet.Term.Expr as C @@ -128,7 +127,7 @@ intro n = name lower n . getLevel tintro n = name upper n . getLevel qvar :: (P.Level p ~ Precedence, PrecedencePrinter p) => QName -> p -qvar (_ :|> n) = setPrec Var (pretty n) +qvar = setPrec Var . pretty . qlast meta :: Meta -> Print meta (Meta m) = setPrec Var $ annotate (Name m) $ pretty '?' <> upper m @@ -259,7 +258,7 @@ instance Printable SQ.Command where instance Printable C.Module where print opts env (C.Module mname is _ ds) = module_ mname - (qvar (fromList [T (T.pack "Kernel")]:|>T (T.pack "Module"))) + (qvar (fromList [T (T.pack "Kernel"), T (T.pack "Module")])) (map (\ (C.Import n) -> import' n) is) (map (def . fmap defBody) (view C.toList_ ds)) where From fd2e491fbacb5c22a10b94d600ed383ee809d32e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 9 May 2022 08:19:03 -0400 Subject: [PATCH 1281/1324] Redefine QName as a newtype. --- src/Facet/Driver.hs | 2 +- src/Facet/Elab.hs | 8 ++++---- src/Facet/Elab/Term.hs | 5 ++--- src/Facet/Eval.hs | 42 +++++++++++++++++++------------------- src/Facet/Graph.hs | 4 ++-- src/Facet/Name.hs | 40 ++++++++++++++++++++++++++++-------- src/Facet/Parser.hs | 8 ++++---- src/Facet/Print/Options.hs | 3 +-- src/Facet/REPL.hs | 3 +-- src/Facet/Sequent/Expr.hs | 30 +++++++++++++-------------- 10 files changed, 82 insertions(+), 63 deletions(-) diff --git a/src/Facet/Driver.hs b/src/Facet/Driver.hs index 3ccb6b438..cb54a9fe3 100644 --- a/src/Facet/Driver.hs +++ b/src/Facet/Driver.hs @@ -167,7 +167,7 @@ resolveName searchPaths name = do [] -> [] _ -> [ nest 2 (reflow "search paths:" <\> concatWith (<\>) (map pretty searchPaths)) ] where - toPath components = foldr1 (FP.) (unpack <$> components) + toPath (QName components) = foldr1 (FP.) (unpack <$> components) unpack = \case T n -> TS.unpack n O o -> formatOp (\ a b -> a <> " " <> b) TS.unpack "_" o diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 4b8c12d8e..608d0f7c2 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -133,23 +133,23 @@ resolveDef :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw E resolveDef = resolveWith lookupDef lookupInContext :: Has (Choose :+: Empty) sig m => QName -> Context -> m (Index, Type) -lookupInContext (m:|>n) +lookupInContext (QName (m :|> n)) | m == Nil = lookupIndex n | otherwise = const empty lookupInTypeContext :: Has (Choose :+: Empty) sig m => QName -> TypeContext.TypeContext -> m (Index, Kind) -lookupInTypeContext (m:|>n) +lookupInTypeContext (QName (m :|> n)) | m == Nil = TypeContext.lookupIndex n | otherwise = const empty -- FIXME: probably we should instead look up the effect op globally, then check for membership in the sig -- FIXME: return the index in the sig; it’s vital for evaluation of polymorphic effects when there are multiple such lookupInSig :: Has (Choose :+: Empty) sig m => QName -> Module -> Graph -> [Signature Type] -> m (QName :=: Type) -lookupInSig (m :|> n) mod graph = foldMapC $ foldMapC (\ (Interface q@(m':|>_) _) -> do +lookupInSig (QName (m :|> n)) mod graph = foldMapC $ foldMapC (\ (Interface q@(QName (m':|>_)) _) -> do guard (m == Nil || m == m') defs <- interfaceScope =<< lookupQ graph mod q d <- maybe empty pure (defs ^? ix n) - pure $ m' :|> n :=: d) . interfaces + pure $ QName (m' :|> n) :=: d) . interfaces where interfaceScope = \case { DSubmodule (SInterface defs) _K -> pure defs ; _ -> empty } diff --git a/src/Facet/Elab/Term.hs b/src/Facet/Elab/Term.hs index 6e9c63c16..49b55a535 100644 --- a/src/Facet/Elab/Term.hs +++ b/src/Facet/Elab/Term.hs @@ -66,7 +66,6 @@ import Facet.Name import Facet.Pattern import Facet.Scope import Facet.Snoc -import Facet.Snoc.NonEmpty as NE import Facet.Source (Source) import Facet.Subst import qualified Facet.Surface.Module as S @@ -164,7 +163,7 @@ varP :: Name -> Bind m (ValPattern (Name :==> Type)) varP n = Bind $ \ _A k -> k (PVar (n :==> wrap _A)) where wrap = \case - T.Comp sig _A -> T.Arrow Nothing (T.free (NE.FromList ["Data", "Unit", "Unit"])) (T.Comp sig _A) + T.Comp sig _A -> T.Arrow Nothing (T.free (fromList ["Data", "Unit", "Unit"])) (T.Comp sig _A) _T -> _T conP :: (Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> [Bind m (ValPattern (Name :==> Type))] -> Bind m (ValPattern (Name :==> Type)) @@ -186,7 +185,7 @@ fieldsP = foldr cons nil allP :: Has (Throw ErrReason :+: Write Warn) sig m => Name -> Bind m (Pattern (Name :==> Type)) allP n = Bind $ \ _A k -> do (sig, _T) <- assertComp _A - k (PVal (PVar (n :==> T.Arrow Nothing (T.free (NE.FromList ["Data", "Unit", "Unit"])) (T.Comp sig _T)))) + k (PVal (PVar (n :==> T.Arrow Nothing (T.free (fromList ["Data", "Unit", "Unit"])) (T.Comp sig _T)))) -- Expression elaboration diff --git a/src/Facet/Eval.hs b/src/Facet/Eval.hs index 3a524eb28..12f28fb50 100644 --- a/src/Facet/Eval.hs +++ b/src/Facet/Eval.hs @@ -27,26 +27,26 @@ module Facet.Eval , reader' ) where -import Control.Algebra -import Control.Carrier.Reader -import Control.Monad (ap, guard, liftM, (>=>)) -import Control.Monad.Trans.Class -import Data.Foldable -import Data.Function -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Facet.Env as Env -import Facet.Graph -import Facet.Module -import Facet.Name hiding (Op) -import Facet.Pattern -import Facet.Quote -import Facet.Semialign (zipWithM) -import qualified Facet.Snoc.NonEmpty as NE -import Facet.Syntax -import Facet.Term.Expr -import GHC.Stack (HasCallStack) -import Prelude hiding (zipWith) +import Control.Algebra +import Control.Carrier.Reader +import Control.Monad (ap, guard, liftM, (>=>)) +import Control.Monad.Trans.Class +import Data.Foldable +import Data.Function +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Facet.Env as Env +import Facet.Graph +import Facet.Module +import Facet.Name hiding (Op) +import Facet.Pattern +import Facet.Quote +import Facet.Semialign (zipWithM) +import Facet.Syntax +import Facet.Term.Expr +import GHC.Exts (fromList) +import GHC.Stack (HasCallStack) +import Prelude hiding (zipWith) eval :: (HasCallStack, Has (Reader Graph :+: Reader Module) sig m, MonadFail m) => Term -> ReaderC (Env (Value (Eval m))) (Eval m) (Value (Eval m)) eval = \case @@ -133,7 +133,7 @@ instance Monad m => Quote (Value m) (m Term) where VString s -> pure . pure $ String s unit :: Value m -unit = VCon (NE.FromList ["Data", "Unit"] NE.|> T "unit") [] +unit = VCon (fromList ["Data", "Unit", "unit"]) [] -- Elimination diff --git a/src/Facet/Graph.hs b/src/Facet/Graph.hs index 3b180c547..6f9ad10a4 100644 --- a/src/Facet/Graph.hs +++ b/src/Facet/Graph.hs @@ -29,7 +29,7 @@ import qualified Data.Set as Set import Facet.Module import Facet.Name import Facet.Snoc -import Facet.Snoc.NonEmpty (NonEmpty(..), fromSnoc, toSnoc) +import Facet.Snoc.NonEmpty (NonEmpty(..)) import Fresnel.At import Fresnel.Iso import Fresnel.Ixed @@ -58,7 +58,7 @@ lookupM :: Has (Choose :+: Empty) sig m => QName -> Graph -> m (Maybe FilePath, lookupM n = maybe empty pure . Map.lookup n . getGraph lookupWith :: Has (Choose :+: Empty) sig m => (Name -> Module -> m res) -> Graph -> Module -> QName -> m res -lookupWith lookup graph mod@Module{ name } (m:|>n) +lookupWith lookup graph mod@Module{ name } (QName (m:|>n)) = guard (m == toSnoc name || m == Nil) *> lookup n mod <|> guard (m == Nil) *> foldMapC (maybe empty (lookup n) . snd) (getGraph graph) <|> guard (m /= Nil) *> (lookupM (fromSnoc m) graph >>= maybe empty pure . snd >>= lookup n) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index e5de8372e..2f91c06b4 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Facet.Name ( Index(..) @@ -7,11 +8,13 @@ module Facet.Name , DeBruijn(..) , Meta(..) , __ -, QName +, QName(..) , (//) , q , qlast , prettyQName +, fromSnoc +, toSnoc , Name(..) , Assoc(..) , Op(..) @@ -23,12 +26,12 @@ module Facet.Name import Data.Foldable (foldl', foldr') import Data.Functor.Classes (showsUnaryWith) import qualified Data.List.NonEmpty as NE -import Data.String (IsString(..)) -import Data.Text (Text) +import Data.Text (Text, pack) import qualified Data.Text as T import Facet.Pretty (subscript) import Facet.Snoc -import Facet.Snoc.NonEmpty +import qualified Facet.Snoc.NonEmpty as SNE +import GHC.Exts import qualified Prettyprinter as P import Silkscreen @@ -76,21 +79,40 @@ __ = T T.empty -- | Qualified names, consisting of a module name and declaration name. -type QName = NonEmpty Name +newtype QName = QName { getQName :: SNE.NonEmpty Name } + deriving (Eq, Ord, Show) + +instance IsList QName where + type Item QName = Name + fromList = QName . fromList + toList = toList . getQName + +instance IsString QName where + fromString = QName . SNE.fromSnoc . go Nil + where + go accum s = let (name, rest) = span (/= '.') s in case rest of + '.':s' -> go (accum :> T (pack name)) s' + _ -> accum :> T (pack name) (//) :: QName -> Name -> QName -(//) = (|>) +q // n = QName (getQName q SNE.|> n) infixl 5 // q :: Name -> QName -q = (Nil :|>) +q = QName . (Nil SNE.:|>) qlast :: QName -> Name -qlast (_ :|> l) = l +qlast (QName (_ SNE.:|> l)) = l prettyQName :: Printer a => QName -> a -prettyQName (ns:|>n) = foldr' (surround dot . pretty) (pretty n) ns +prettyQName (QName (ns SNE.:|> n)) = foldr' (surround dot . pretty) (pretty n) ns + +fromSnoc :: Snoc Name -> QName +fromSnoc = QName . SNE.fromSnoc + +toSnoc :: QName -> Snoc Name +toSnoc = SNE.toSnoc . getQName -- | Declaration names; a choice of textual or operator names. diff --git a/src/Facet/Parser.hs b/src/Facet/Parser.hs index fd23be39b..d0956e402 100644 --- a/src/Facet/Parser.hs +++ b/src/Facet/Parser.hs @@ -61,7 +61,7 @@ whole p = whiteSpace *> p <* eof makeOperator :: (N.QName, N.Op, N.Assoc) -> Operator (S.Ann S.Expr) -makeOperator (name, op, assoc) = (op, assoc, nary (name |> N.O op)) +makeOperator (name, op, assoc) = (op, assoc, nary (name N.// N.O op)) where nary name es = foldl' (S.annBinary S.App) (S.Ann (S.ann (head es)) Nil (S.Var name)) es @@ -201,7 +201,7 @@ tvar = anned (S.TVar <$> qname tname) signature :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p [S.Ann (S.Interface (S.Ann S.Type))] signature = brackets (commaSep delta) "signature" where - delta = anned $ S.Interface <$> head <*> (fromList <$> many type') + delta = anned $ S.Interface . N.QName <$> head <*> (fromList <$> many type') head = mkHead <$> token (runUnspaced (sepByNonEmpty comp dot)) mkHead cs = fromList (NE.init cs) |> NE.last cs comp = ident tnameStyle @@ -236,7 +236,7 @@ clause = S.Clause <$> try (compPattern <* arrow) <*> expr "clause" evar :: (Has Parser sig p, Has (Writer Comments) sig p, TokenParsing p) => p (S.Ann S.Expr) evar = choice - [ token (anned (runUnspaced (S.Var <$> try (fromSnoc <$> ((:>) . fromList <$> many (comp <* dot) <*> ename))))) + [ token (anned (runUnspaced (S.Var <$> try ((N.//) . fromList <$> many (comp <* dot) <*> ename)))) -- FIXME: would be better to commit once we see a placeholder, but try doesn’t really let us express that , try (anned (parens (S.Var <$> qname (N.O <$> oname)))) ] @@ -307,7 +307,7 @@ mname = token (runUnspaced (fromList <$> sepBy1 comp dot)) comp = ident tnameStyle qname :: (Has Parser sig p, TokenParsing p) => p N.Name -> p N.QName -qname name = token (runUnspaced (try ((|>) <$> mname <*> Unspaced name) <|> (Nil :|>) <$> Unspaced name)) "name" +qname name = token (runUnspaced (try ((N.//) <$> mname <*> Unspaced name) <|> N.QName . (Nil :|>) <$> Unspaced name)) "name" reserved :: HashSet.HashSet String diff --git a/src/Facet/Print/Options.hs b/src/Facet/Print/Options.hs index 4d74420cf..ca95a5d57 100644 --- a/src/Facet/Print/Options.hs +++ b/src/Facet/Print/Options.hs @@ -10,7 +10,6 @@ module Facet.Print.Options ) where import Facet.Name -import Facet.Snoc.NonEmpty import Silkscreen -- Options @@ -35,7 +34,7 @@ quietOptions = Options qualified, unqualified :: Printer p => QName -> p qualified = prettyQName -unqualified (_:|>n) = pretty n +unqualified = pretty . qlast printInstantiation :: Printer p => p -> p -> p printInstantiation = (<+>) diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index e12a0e136..9e3705e9b 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -49,7 +49,6 @@ import Facet.Print as Print hiding (meta) import Facet.Quote import Facet.REPL.Parser import Facet.Snoc -import Facet.Snoc.NonEmpty import Facet.Source (Source(..), sourceFromString) import Facet.Style as Style import qualified Facet.Surface.Term.Expr as S @@ -204,7 +203,7 @@ showType e = Action $ do outputDocLn (getPrint (ann (Print.print opts mempty e ::: Print.print opts mempty _T))) showEval e = Action $ do - e' :==> _T <- runElab $ Elab.elabSynthTerm $ Elab.runErr $ locally Elab.sig_ (I.singleton (I.Interface (["Effect", "Console"]:|>T "Output") Nil) :) $ Elab.synthExpr e + e' :==> _T <- runElab $ Elab.elabSynthTerm $ Elab.runErr $ locally Elab.sig_ (I.singleton (I.Interface ["Effect", "Console", "Output"] Nil) :) $ Elab.synthExpr e e'' <- runElab $ runEvalMain e' opts <- get outputDocLn (getPrint (ann (Print.print opts mempty e'' ::: Print.print opts mempty _T))) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 29bebb65b..f4d2d06cb 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -129,27 +129,27 @@ incr r@Replacer{ outer } = r{ outer = outer + 1} replaceTerm :: These (Replacer Coterm) (Replacer Term) -> (Term -> Term) replaceTerm lr within = case within of - Var (Free (Nil:|>n)) -> that (const within) free' lr n - Var (Free _) -> within - Var (Bound inner) -> that (const within) bound' lr inner - MuR (Scope b) -> MuR (Scope (replaceCommand (first incr lr) b)) - LamR (Scope b) -> LamR (Scope (replaceCommand (bimap incr incr lr) b)) - SumR i a -> SumR i (replaceTerm lr a) - PrdR as -> PrdR (map (replaceTerm lr) as) - StringR _ -> within + Var (Free (QName (Nil:|>n))) -> that (const within) free' lr n + Var (Free _) -> within + Var (Bound inner) -> that (const within) bound' lr inner + MuR (Scope b) -> MuR (Scope (replaceCommand (first incr lr) b)) + LamR (Scope b) -> LamR (Scope (replaceCommand (bimap incr incr lr) b)) + SumR i a -> SumR i (replaceTerm lr a) + PrdR as -> PrdR (map (replaceTerm lr) as) + StringR _ -> within where that :: c -> (b -> c) -> These a b -> c that d f = these (const d) f (const f) replaceCoterm :: These (Replacer Coterm) (Replacer Term) -> (Coterm -> Coterm) replaceCoterm lr within = case within of - Covar (Free (Nil:|>n)) -> this (const within) free' lr n - Covar (Free _) -> within - Covar (Bound inner) -> this (const within) bound' lr inner - MuL (Scope b) -> MuL (Scope (replaceCommand (second incr lr) b)) - LamL a k -> LamL (replaceTerm lr a) (replaceCoterm lr k) - SumL cs -> SumL (map (fmap (replaceCoterm lr)) cs) - PrdL i b -> PrdL i (replaceCoterm lr b) + Covar (Free (QName (Nil:|>n))) -> this (const within) free' lr n + Covar (Free _) -> within + Covar (Bound inner) -> this (const within) bound' lr inner + MuL (Scope b) -> MuL (Scope (replaceCommand (second incr lr) b)) + LamL a k -> LamL (replaceTerm lr a) (replaceCoterm lr k) + SumL cs -> SumL (map (fmap (replaceCoterm lr)) cs) + PrdL i b -> PrdL i (replaceCoterm lr b) where this :: c -> (a -> c) -> These a b -> c this d f = these f (const d) (const . f) From a83975f6b29de40d7d68005e1f0dad15cc278411 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 9 May 2022 08:21:17 -0400 Subject: [PATCH 1282/1324] Define a Pretty instance for QName. --- src/Facet/Driver.hs | 8 ++++---- src/Facet/Name.hs | 7 +++---- src/Facet/Notice/Elab.hs | 4 ++-- src/Facet/Print.hs | 4 ++-- src/Facet/Print/Options.hs | 2 +- src/Facet/REPL.hs | 4 ++-- 6 files changed, 14 insertions(+), 15 deletions(-) diff --git a/src/Facet/Driver.hs b/src/Facet/Driver.hs index cb54a9fe3..177f85781 100644 --- a/src/Facet/Driver.hs +++ b/src/Facet/Driver.hs @@ -110,11 +110,11 @@ reloadModules = do let loaded = traverse (\ name -> graph ^. at name >>= snd) h case loaded of Just loaded -> (Just <$> do - outputDocLn $ annotate Progress (brackets (ratio (i :: Int) nModules)) <+> nest 2 (group (fillSep [ pretty "Loading", prettyQName name ])) + outputDocLn $ annotate Progress (brackets (ratio (i :: Int) nModules)) <+> nest 2 (group (fillSep [ pretty "Loading", pretty name ])) storeModule name (path (reference src)) =<< loadModule graph loaded) `catchError` \ err -> Nothing <$ outputDocLn (prettyNotice err) Nothing -> do - outputDocLn $ annotate Progress (brackets (ratio i nModules)) <+> nest 2 (group (fillSep [ pretty "Skipping", prettyQName name ])) + outputDocLn $ annotate Progress (brackets (ratio i nModules)) <+> nest 2 (group (fillSep [ pretty "Skipping", pretty name ])) pure Nothing let nSuccess = length (catMaybes results) status @@ -163,7 +163,7 @@ resolveName searchPaths name = do path <- liftIO $ findFile searchPaths namePath case path of Just path -> pure path - Nothing -> throwError @(Notice.Notice (Doc Style)) $ Notice.Notice (Just Notice.Error) [] (fillSep [pretty "module", squotes (prettyQName name), reflow "could not be found."]) $ case searchPaths of + Nothing -> throwError @(Notice.Notice (Doc Style)) $ Notice.Notice (Just Notice.Error) [] (fillSep [pretty "module", squotes (pretty name), reflow "could not be found."]) $ case searchPaths of [] -> [] _ -> [ nest 2 (reflow "search paths:" <\> concatWith (<\>) (map pretty searchPaths)) ] where @@ -185,4 +185,4 @@ ioErrorToNotice refs err = Notice.Notice (Just Notice.Error) refs (group (reflow rethrowGraphErrors :: Applicative m => [Source] -> I.ThrowC (Notice.Notice (Doc Style)) GraphErr m a -> m a rethrowGraphErrors refs = I.runThrow (pure . formatGraphErr) where - formatGraphErr (CyclicImport path) = Notice.Notice (Just Notice.Error) refs (reflow "cyclic import") (map prettyQName (toList path)) + formatGraphErr (CyclicImport path) = Notice.Notice (Just Notice.Error) refs (reflow "cyclic import") (map pretty (toList path)) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 2f91c06b4..21774a87c 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -12,7 +12,6 @@ module Facet.Name , (//) , q , qlast -, prettyQName , fromSnoc , toSnoc , Name(..) @@ -94,6 +93,9 @@ instance IsString QName where '.':s' -> go (accum :> T (pack name)) s' _ -> accum :> T (pack name) +instance Pretty QName where + pretty (QName (ns SNE.:|> n)) = foldr' (surround dot . pretty) (pretty n) ns + (//) :: QName -> Name -> QName q // n = QName (getQName q SNE.|> n) @@ -105,9 +107,6 @@ q = QName . (Nil SNE.:|>) qlast :: QName -> Name qlast (QName (_ SNE.:|> l)) = l -prettyQName :: Printer a => QName -> a -prettyQName (QName (ns SNE.:|> n)) = foldr' (surround dot . pretty) (pretty n) ns - fromSnoc :: Snoc Name -> QName fromSnoc = QName . SNE.fromSnoc diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index c99a93764..b8ac03ee8 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -62,8 +62,8 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) printErrReason :: Options Print -> Env.Env Print -> ErrReason -> Doc Style printErrReason opts ctx = group . \case - FreeVariable n -> fillSep [reflow "variable not in scope:", prettyQName n] - AmbiguousName n -> fillSep [reflow "ambiguous name", prettyQName n] -- <\> nest 2 (reflow "alternatives:" <\> unlines (map prettyQName qs)) + FreeVariable n -> fillSep [reflow "variable not in scope:", pretty n] + AmbiguousName n -> fillSep [reflow "ambiguous name", pretty n] -- <\> nest 2 (reflow "alternatives:" <\> unlines (map prettyQName qs)) CouldNotSynthesize -> reflow "could not synthesize a type; try a type annotation" UnifyType r (Exp exp) (Act act) -> reason r <> hardline <> pretty "expected:" <> align exp' diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index 4cc2ceab7..ee7c27e09 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -271,8 +271,8 @@ instance Printable C.Module where C.SInterface os -> annotate Keyword (pretty "interface") <+> scope (print opts env) os C.SModule ds -> block (concatWith (surround hardline) (map ((hardline <>) . def . fmap defBody) (view C.toList_ ds))) scope with = block . group . concatWith (surround (hardline <> comma <> space)) . map (group . def . fmap with) . view C.toList_ - import' n = pretty "import" <+> braces (setPrec Var (prettyQName n)) - module_ n t is ds = ann (setPrec Var (prettyQName n) ::: t) concatWith (surround hardline) (is ++ map (hardline <>) ds) + import' n = pretty "import" <+> braces (setPrec Var (pretty n)) + module_ n t is ds = ann (setPrec Var (pretty n) ::: t) concatWith (surround hardline) (is ++ map (hardline <>) ds) defn (a :=: b) = group a <> hardline <> group b diff --git a/src/Facet/Print/Options.hs b/src/Facet/Print/Options.hs index ca95a5d57..38600d867 100644 --- a/src/Facet/Print/Options.hs +++ b/src/Facet/Print/Options.hs @@ -33,7 +33,7 @@ quietOptions = Options } qualified, unqualified :: Printer p => QName -> p -qualified = prettyQName +qualified = pretty unqualified = pretty . qlast printInstantiation :: Printer p => p -> p -> p diff --git a/src/Facet/REPL.hs b/src/Facet/REPL.hs index 9e3705e9b..9c260dcff 100644 --- a/src/Facet/REPL.hs +++ b/src/Facet/REPL.hs @@ -173,9 +173,9 @@ showPaths = Action $ do unless (null searchPaths) $ outputDocLn $ nest 2 $ pretty ("search paths:" :: Text) <\> unlines (map pretty searchPaths) -showModules = Action $ uses (target_.modules_) (unlines . map (\ (name, (path, _)) -> prettyQName name <> maybe mempty ((space <>) . S.parens . pretty) path) . Map.toList . getGraph) >>= outputDocLn +showModules = Action $ uses (target_.modules_) (unlines . map (\ (name, (path, _)) -> pretty name <> maybe mempty ((space <>) . S.parens . pretty) path) . Map.toList . getGraph) >>= outputDocLn -showTargets = Action $ uses (target_.targets_) (unlines . map prettyQName . toList) >>= outputDocLn +showTargets = Action $ uses (target_.targets_) (unlines . map pretty . toList) >>= outputDocLn addPath, removePath :: FilePath -> Action From 051922ad0a0b15ed4efbf44da1ff7decbb7a48b9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 9 May 2022 08:25:56 -0400 Subject: [PATCH 1283/1324] Define a Show instance for Op. --- src/Facet/Name.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 21774a87c..267c88391 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -141,7 +141,10 @@ data Op | Postfix Text | Infix Text | Outfix Text Text - deriving (Eq, Ord, Show) + deriving (Eq, Ord) + +instance Show Op where + showsPrec _ = formatOp (\ a b -> a . showChar ' ' . b) (showString . unpack) (showChar '_') formatOp :: (a -> a -> a) -> (Text -> a) -> a -> Op -> a formatOp (<+>) pretty place = \case From a5c978b09b1b67791687c27779e93c9683cd9a8d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 9 May 2022 08:29:56 -0400 Subject: [PATCH 1284/1324] Define a generalized version of subscript. --- src/Facet/Pretty.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Facet/Pretty.hs b/src/Facet/Pretty.hs index b7f4da09f..b12bcc921 100644 --- a/src/Facet/Pretty.hs +++ b/src/Facet/Pretty.hs @@ -15,6 +15,7 @@ module Facet.Pretty , upper , varFrom , subscript +, subscriptWith , digits -- * Columnar layout , tabulate2 @@ -111,6 +112,13 @@ subscript i = sign <> foldMap (pretty . (subscripts !!) . abs) (digits i) | otherwise = mempty subscripts = ['₀'..'₉'] +subscriptWith :: (s -> s -> s) -> (Char -> s) -> s -> Int -> s +subscriptWith (<>) pretty mempty i = sign <> foldr ((<>) . pretty . (subscripts !!) . abs) mempty (digits i) + where + sign | i < 0 = pretty '₋' + | otherwise = mempty + subscripts = ['₀'..'₉'] + digits :: Int -> [Int] digits = go [] where From 2a62352aa8d0cef3c115e8ea7230160de8b49746 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 9 May 2022 08:30:42 -0400 Subject: [PATCH 1285/1324] Define subscript in terms of subscriptWith. --- src/Facet/Pretty.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Facet/Pretty.hs b/src/Facet/Pretty.hs index b12bcc921..fa9285fe6 100644 --- a/src/Facet/Pretty.hs +++ b/src/Facet/Pretty.hs @@ -106,11 +106,7 @@ varFrom alpha i = pretty (toAlpha alpha i) subscript :: Printer p => Int -> p -subscript i = sign <> foldMap (pretty . (subscripts !!) . abs) (digits i) - where - sign | i < 0 = pretty "₋" - | otherwise = mempty - subscripts = ['₀'..'₉'] +subscript = subscriptWith (<>) pretty mempty subscriptWith :: (s -> s -> s) -> (Char -> s) -> s -> Int -> s subscriptWith (<>) pretty mempty i = sign <> foldr ((<>) . pretty . (subscripts !!) . abs) mempty (digits i) From aed78a2d60db6b0642a9ba3f4b1a0eb3497a1719 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 9 May 2022 08:33:15 -0400 Subject: [PATCH 1286/1324] Define a Show instance for Name. --- src/Facet/Name.hs | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 267c88391..608f04a34 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -25,9 +25,9 @@ module Facet.Name import Data.Foldable (foldl', foldr') import Data.Functor.Classes (showsUnaryWith) import qualified Data.List.NonEmpty as NE -import Data.Text (Text, pack) +import Data.Text (Text, pack, unpack) import qualified Data.Text as T -import Facet.Pretty (subscript) +import Facet.Pretty (subscript, subscriptWith) import Facet.Snoc import qualified Facet.Snoc.NonEmpty as SNE import GHC.Exts @@ -119,7 +119,7 @@ data Name = T Text | O Op | G Text Int - deriving (Eq, Ord, Show) + deriving (Eq, Ord) instance IsString Name where fromString = T . fromString @@ -130,6 +130,12 @@ instance P.Pretty Name where O o -> P.pretty o G n i -> P.pretty n <> subscript i +instance Show Name where + showsPrec p = \case + T n -> showString (unpack n) + O o -> showsPrec p o + G n i -> showString (unpack n) . subscriptWith (.) showChar id i + -- | Associativity of an infix operator. data Assoc = N | L | R | A From a4b1292cd61a52714d27ff3e105729a461440a4f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 9 May 2022 08:33:27 -0400 Subject: [PATCH 1287/1324] Define a Show instance for QName. --- src/Facet/Name.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index 608f04a34..fe10f070d 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -24,6 +24,7 @@ module Facet.Name import Data.Foldable (foldl', foldr') import Data.Functor.Classes (showsUnaryWith) +import Data.List (intercalate) import qualified Data.List.NonEmpty as NE import Data.Text (Text, pack, unpack) import qualified Data.Text as T @@ -79,7 +80,7 @@ __ = T T.empty -- | Qualified names, consisting of a module name and declaration name. newtype QName = QName { getQName :: SNE.NonEmpty Name } - deriving (Eq, Ord, Show) + deriving (Eq, Ord) instance IsList QName where type Item QName = Name @@ -96,6 +97,9 @@ instance IsString QName where instance Pretty QName where pretty (QName (ns SNE.:|> n)) = foldr' (surround dot . pretty) (pretty n) ns +instance Show QName where + showsPrec _ (QName components) = showString (intercalate "." (map show (toList components))) + (//) :: QName -> Name -> QName q // n = QName (getQName q SNE.|> n) From 49f2410b4fcf57c2c604a7c4c9293cdfb50fb71b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 9 May 2022 08:38:45 -0400 Subject: [PATCH 1288/1324] Define an IsList instance for Scope. --- src/Facet/Scope.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Facet/Scope.hs b/src/Facet/Scope.hs index 9bc8d556d..2db5ad545 100644 --- a/src/Facet/Scope.hs +++ b/src/Facet/Scope.hs @@ -16,6 +16,7 @@ import Fresnel.Getter (view) import Fresnel.Iso import Fresnel.Ixed import Fresnel.Optional (optional') +import GHC.Exts (IsList(..)) newtype Scope a = Scope { decls :: [Name :=: a] } deriving (Functor, Monoid, Semigroup) @@ -31,6 +32,11 @@ instance Ixed (Scope a) where Nothing -> v:replace f vs Just v' -> v':vs +instance IsList (Scope a) where + type Item (Scope a) = Name :=: a + fromList = Scope + toList = decls + decls_ :: Iso (Scope a) (Scope b) (Map.Map Name a) (Map.Map Name b) decls_ = toList_.fmapping pair_.iso Map.fromList Map.toList From 0d596453c6665e5b7e209ada17ea236d53da3e3a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 9 May 2022 10:49:50 -0400 Subject: [PATCH 1289/1324] Define a helper for running actions with These in scope. --- src/Facet/Elab/Sequent.hs | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index e1e46d760..5dc6ee965 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -27,6 +27,7 @@ module Facet.Elab.Sequent , check -- * Debugging , runSQ +, runSQThese ) where import Control.Applicative (liftA2) @@ -44,13 +45,14 @@ import qualified Facet.Elab.Type as Type import Facet.Functor.Check import Facet.Functor.Synth import Facet.Graph as G -import Facet.Kind +import Facet.Kind as K import Facet.Lens as Lens (views) import Facet.Module import Facet.Name import Facet.Pattern import qualified Facet.Scope as Scope import qualified Facet.Sequent.Expr as SQ +import Facet.Snoc (Snoc(..)) import Facet.Subst import qualified Facet.Surface.Term.Expr as S import qualified Facet.Surface.Type.Expr as S @@ -60,6 +62,7 @@ import qualified Facet.TypeContext as TC import Facet.Unify import Fresnel.Fold ((^?)) import Fresnel.Lens (Lens, Lens', lens) +import GHC.Exts (fromList) import GHC.Stack (HasCallStack, callStack, popCallStack, withFrozenCallStack) -- Variables @@ -285,3 +288,16 @@ runSQ m . runReader m . runReader (G.singleton Nothing m) . runThrow + +runSQThese :: Applicative m => ThrowC ErrReason (ReaderC Graph (ReaderC Module (FreshC (ReaderC ElabContext (StateC (Subst Type) m))))) a -> m (Either ErrReason a) +runSQThese = runSQ m + where + _These _A _B = Ne (Free "Module.These") (Nil:>_A:>_B) + m = Module "Module.These" [] [] (fromList + [ "These" :=: DSubmodule (SData (fromList + [ "this" :=: ForAll "A" KType (\ _A -> ForAll "B" KType (\ _B -> _A --> _These _A _B)) + , "that" :=: ForAll "A" KType (\ _A -> ForAll "B" KType (\ _B -> _B --> _These _A _B)) + , "these" :=: ForAll "A" KType (\ _A -> ForAll "B" KType (\ _B -> _A --> _B --> _These _A _B)) + ])) + (KType K.==> KType K.==> KType) + ]) From a12fe8be1ebba423f90ed6eb9f8a132e88284c77 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 9 May 2022 10:51:20 -0400 Subject: [PATCH 1290/1324] Export checkLamS. --- src/Facet/Elab/Sequent.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 5dc6ee965..a5b3830f1 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -16,6 +16,7 @@ module Facet.Elab.Sequent -- * Elaboration , synthExprS , checkExprS +, checkLamS , Clause(..) , patterns_ , body_ From 975f0aacf4b7c8b0d07554ad4c47942caa2927cd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 9 May 2022 11:04:05 -0400 Subject: [PATCH 1291/1324] Check recursively. --- src/Facet/Elab/Sequent.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index a5b3830f1..f658893b5 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -177,12 +177,13 @@ checkLamS :: (Has Fresh sig m, Has (Reader ElabContext) sig m, Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => [Clause (Type <==: m SQ.Term)] -> Type <==: m SQ.Term -checkLamS clauses = Check (go id) +checkLamS clauses = go id where - go scrutinees = \case + go scrutinees = Check $ \case T.Arrow _ _A _B -> do x <- freshName "x" - SQ.lamR' x <$> go (scrutinees . ((x :==> _A) :)) _B + kx <- freshName "kx" + SQ.lamR kx x <$> check (go (scrutinees . ((x :==> _A) :)) >< freeL kx ::: _B) _T -> do x <- freshName "x" kx <- freshName "kx" From e3e688dd2c8a8af62a038037254a47c2053b47a0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 9 May 2022 11:05:09 -0400 Subject: [PATCH 1292/1324] Correct lamS' variable occurrences. --- src/Facet/Elab/Sequent.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index f658893b5..8944bf223 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -98,7 +98,7 @@ lamS b = Check $ \ _T -> do (_, _A, _B) <- assertTacitFunction _T v <- freshName "v" k <- freshName "k" - SQ.lamR v k <$> check (b (pure (pure (SQ.freeR v))) (freeL k) ::: _B) + SQ.lamR k v <$> check (b (pure (pure (SQ.freeR v))) (freeL k) ::: _B) lamS' :: (Has Fresh sig m, Has (Throw ErrReason) sig m) From 1c0a3e7d2e26f0167b052d6838e74598cdd7b67c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 9 May 2022 13:04:37 -0400 Subject: [PATCH 1293/1324] Correct the ordering of the final lambda's params. --- src/Facet/Elab/Sequent.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 8944bf223..523db0906 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -187,7 +187,7 @@ checkLamS clauses = go id _T -> do x <- freshName "x" kx <- freshName "kx" - SQ.lamR x kx <$> check (patternBody (scrutinees []) (map (fmap (>< freeL kx)) clauses) ::: _T) + SQ.lamR kx x <$> check (patternBody (scrutinees []) (map (fmap (>< freeL kx)) clauses) ::: _T) data Clause a = Clause From 48f95c2685644aae49e45ad6474fa08c9b103ad2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 9 May 2022 15:28:00 -0400 Subject: [PATCH 1294/1324] Allow resolveWith to produce multiple names. --- src/Facet/Elab.hs | 8 +++++--- src/Facet/Graph.hs | 4 +++- src/Facet/Module.hs | 6 +++--- 3 files changed, 11 insertions(+), 7 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 608d0f7c2..0b26c7a04 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -87,6 +87,7 @@ import qualified Facet.Type.Expr as TX import Facet.Type.Norm as TN import qualified Facet.TypeContext as TypeContext import Fresnel.Fold ((^?)) +import Fresnel.Getter (view) import Fresnel.Ixed (ix) import Fresnel.Lens (Lens', lens) import Fresnel.Prism (Prism', prism') @@ -119,18 +120,19 @@ instantiate inst = go resolveWith :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => (forall sig m . Has (Choose :+: Empty) sig m => Name -> Module -> m d) + -> (d -> QName) -> QName -> m d -resolveWith lookup n = ask >>= \ graph -> asks (\ module' -> lookupWith lookup graph module' n) >>= \case +resolveWith lookup toQName n = ask >>= \ graph -> asks (\ module' -> lookupWith lookup graph module' n) >>= \case [] -> freeVariable n [v] -> pure v _ -> ambiguousName n resolveC :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Type) -resolveC = resolveWith lookupConstructor +resolveC = resolveWith lookupConstructor (view tm_) resolveDef :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m Def -resolveDef = resolveWith lookupDef +resolveDef = fmap (view def_) . resolveWith lookupDef (view tm_) lookupInContext :: Has (Choose :+: Empty) sig m => QName -> Context -> m (Index, Type) lookupInContext (QName (m :|> n)) diff --git a/src/Facet/Graph.hs b/src/Facet/Graph.hs index 6f9ad10a4..c005f705f 100644 --- a/src/Facet/Graph.hs +++ b/src/Facet/Graph.hs @@ -30,7 +30,9 @@ import Facet.Module import Facet.Name import Facet.Snoc import Facet.Snoc.NonEmpty (NonEmpty(..)) +import Facet.Syntax (def_) import Fresnel.At +import Fresnel.Getter (view) import Fresnel.Iso import Fresnel.Ixed @@ -64,7 +66,7 @@ lookupWith lookup graph mod@Module{ name } (QName (m:|>n)) <|> guard (m /= Nil) *> (lookupM (fromSnoc m) graph >>= maybe empty pure . snd >>= lookup n) lookupQ :: Has (Choose :+: Empty) sig m => Graph -> Module -> QName -> m Def -lookupQ = lookupWith lookupDef +lookupQ = lookupWith (\ n m -> view def_ <$> (lookupDef n m)) -- FIXME: enrich this with source references for each diff --git a/src/Facet/Module.hs b/src/Facet/Module.hs index 9a795ab62..1bd8ae121 100644 --- a/src/Facet/Module.hs +++ b/src/Facet/Module.hs @@ -31,7 +31,7 @@ import Facet.Scope import Facet.Syntax import Facet.Term.Expr import Facet.Type.Norm -import Fresnel.Fold (folded, preview, (^?)) +import Fresnel.Fold (folded, (^?)) import Fresnel.Ixed import Fresnel.Lens (Lens', lens) import Fresnel.Optional (Optional') @@ -80,8 +80,8 @@ lookupConstructor n Module{ name, scope } = maybe empty (pure . (name // n :=:)) lookupOperation :: Has (Choose :+: Empty) sig m => Name -> Module -> m (QName :=: Type) lookupOperation n Module{ name, scope } = maybe empty (pure . (name // n :=:)) (scope ^? toList_.folded.def_._DInterface.ix n) -lookupDef :: Has Empty sig m => Name -> Module -> m Def -lookupDef n = maybe empty pure . preview (scope_.ix n) +lookupDef :: Has Empty sig m => Name -> Module -> m (QName :=: Def) +lookupDef n Module{ name, scope } = maybe empty (pure . (name // n :=:)) (scope ^? ix n) newtype Import = Import { name :: QName } From 69ef8e35e3b103f631dd82929fb332a8bbdf5a7d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 9 May 2022 15:29:40 -0400 Subject: [PATCH 1295/1324] Add the alternatives back to ambiguous name errors. --- src/Facet/Elab.hs | 16 ++++++++-------- src/Facet/Notice/Elab.hs | 2 +- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Facet/Elab.hs b/src/Facet/Elab.hs index 0b26c7a04..976357d7a 100644 --- a/src/Facet/Elab.hs +++ b/src/Facet/Elab.hs @@ -126,7 +126,7 @@ resolveWith resolveWith lookup toQName n = ask >>= \ graph -> asks (\ module' -> lookupWith lookup graph module' n) >>= \case [] -> freeVariable n [v] -> pure v - _ -> ambiguousName n + ns -> ambiguousName n (map toQName ns) resolveC :: (Has (Reader Graph) sig m, Has (Reader Module) sig m, Has (Throw ErrReason) sig m) => QName -> m (QName :=: Type) resolveC = resolveWith lookupConstructor (view tm_) @@ -201,7 +201,7 @@ data Err = Err data ErrReason = FreeVariable QName -- FIXME: add source references for the imports, definition sites, and any re-exports. - | AmbiguousName QName + | AmbiguousName QName [QName] | CouldNotSynthesize | UnifyType UnifyErrReason (Exp (Either String Type)) (Act (Either String Type)) | UnifyKind (Exp (Either String Kind)) (Act Kind) @@ -215,10 +215,10 @@ _FreeVariable = prism' FreeVariable (\case FreeVariable n -> Just n _ -> Nothing) -_AmbiguousName :: Prism' ErrReason QName -_AmbiguousName = prism' AmbiguousName (\case - AmbiguousName n -> Just n - _ -> Nothing) +_AmbiguousName :: Prism' ErrReason (QName, [QName]) +_AmbiguousName = prism' (uncurry AmbiguousName) (\case + AmbiguousName n ns -> Just (n, ns) + _ -> Nothing) _UnifyType :: Prism' ErrReason (UnifyErrReason, Exp (Either String Type), Act (Either String Type)) _UnifyType = prism' (\ (r, x, a) -> UnifyType r x a) (\case @@ -271,8 +271,8 @@ freeVariable :: Has (Throw ErrReason) sig m => QName -> m a freeVariable n = withFrozenCallStack $ throwError $ FreeVariable n -- FIXME: get references for the resolved names -ambiguousName :: Has (Throw ErrReason) sig m => QName -> m a -ambiguousName n = withFrozenCallStack $ throwError $ AmbiguousName n +ambiguousName :: Has (Throw ErrReason) sig m => QName -> [QName] -> m a +ambiguousName n ns = withFrozenCallStack $ throwError $ AmbiguousName n ns missingInterface :: Has (Throw ErrReason) sig m => Interface Type -> m a missingInterface i = withFrozenCallStack $ throwError $ MissingInterface i diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index b8ac03ee8..a98fff635 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -63,7 +63,7 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) printErrReason :: Options Print -> Env.Env Print -> ErrReason -> Doc Style printErrReason opts ctx = group . \case FreeVariable n -> fillSep [reflow "variable not in scope:", pretty n] - AmbiguousName n -> fillSep [reflow "ambiguous name", pretty n] -- <\> nest 2 (reflow "alternatives:" <\> unlines (map prettyQName qs)) + AmbiguousName n ns -> fillSep [reflow "ambiguous name", pretty n] <\> nest 2 (reflow "alternatives:" <\> unlines (map pretty ns)) CouldNotSynthesize -> reflow "could not synthesize a type; try a type annotation" UnifyType r (Exp exp) (Act act) -> reason r <> hardline <> pretty "expected:" <> align exp' From 0b1f78ecf11b7618c63eedcadd13cd213e2017fd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 9 May 2022 15:39:50 -0400 Subject: [PATCH 1296/1324] Derive a Functor instance for Notice. --- src/Facet/Notice.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Notice.hs b/src/Facet/Notice.hs index 699165ec5..d99c8f5da 100644 --- a/src/Facet/Notice.hs +++ b/src/Facet/Notice.hs @@ -26,7 +26,7 @@ data Notice a = Notice , reason :: !a , context :: ![a] } - deriving (Show) + deriving (Functor, Show) level_ :: Lens' (Notice a) (Maybe Level) level_ = lens level $ \ n level -> n{ level } From 6544a4ac3a6dce8d3137bc43626380e7354f1e3c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 9 May 2022 15:40:04 -0400 Subject: [PATCH 1297/1324] Print error reasons in Print. --- src/Facet/Notice/Elab.hs | 31 ++++++++++++++++--------------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/src/Facet/Notice/Elab.hs b/src/Facet/Notice/Elab.hs index a98fff635..6acc4f174 100644 --- a/src/Facet/Notice/Elab.hs +++ b/src/Facet/Notice/Elab.hs @@ -1,6 +1,7 @@ module Facet.Notice.Elab ( -- * Elaboration rethrowElabErrors +, printErrReason , rethrowElabWarnings ) where @@ -30,7 +31,7 @@ import Silkscreen -- Elaboration rethrowElabErrors :: Applicative m => Options Print -> L.ThrowC (Notice (Doc Style)) Err m a -> m a -rethrowElabErrors opts = L.runThrow (pure . rethrow) +rethrowElabErrors opts = L.runThrow (pure . fmap getPrint . rethrow) where rethrow Err{ callStack, context, typeContext, reason, sig, subst } = Notice.Notice (Just Error) [] (printErrReason opts mempty reason) [ nest 2 (pretty "Context" <\> concatWith (<\>) ctx) @@ -42,25 +43,25 @@ rethrowElabErrors opts = L.runThrow (pure . rethrow) where (_, printCtx, ctx) = foldl' combine (0, Env.empty, Nil) (Env.bindings (elems context)) (_, _, _, tyCtx) = foldl' combineTyCtx (0, Nil, Env.empty, Nil) (getTypeContext typeContext) - subst' = map (\ (m :=: v) -> getPrint (Print.meta m <+> pretty '=' <+> maybe (pretty '?') (print opts printCtx) v)) (metas subst) - sig' = getPrint . print opts printCtx . fmap (apply subst Nil) <$> (interfaces =<< sig) + subst' = map (\ (m :=: v) -> Print.meta m <+> pretty '=' <+> maybe (pretty '?') (print opts printCtx) v) (metas subst) + sig' = print opts printCtx . fmap (apply subst Nil) <$> (interfaces =<< sig) combineTyCtx :: Printable k - => (Facet.Name.Level, Snoc (Name :=: Type), Env.Env Print, Snoc (Doc Style)) + => (Facet.Name.Level, Snoc (Name :=: Type), Env.Env Print, Snoc Print) -> Name :==> k - -> (Facet.Name.Level, Snoc (Name :=: Type), Env.Env Print, Snoc (Doc Style)) + -> (Facet.Name.Level, Snoc (Name :=: Type), Env.Env Print, Snoc Print) combineTyCtx (d, env, prints, ctx) (n :==> _K) = ( succ d , env :> (n :=: bound d) , prints Env.|> (n :=: intro n d) - , ctx :> getPrint (print opts prints (ann (intro n d ::: print opts prints _K))) ) + , ctx :> print opts prints (ann (intro n d ::: print opts prints _K)) ) combine (d, prints, ctx) (n :=: _T) = ( succ d , prints Env.|> (n :=: intro n d) - , ctx :> getPrint (print opts prints (n :=: ann (intro n d ::: print opts prints (apply subst Nil _T)))) ) + , ctx :> print opts prints (n :=: ann (intro n d ::: print opts prints (apply subst Nil _T))) ) -printErrReason :: Options Print -> Env.Env Print -> ErrReason -> Doc Style +printErrReason :: Options Print -> Env.Env Print -> ErrReason -> Print printErrReason opts ctx = group . \case FreeVariable n -> fillSep [reflow "variable not in scope:", pretty n] AmbiguousName n ns -> fillSep [reflow "ambiguous name", pretty n] <\> nest 2 (reflow "alternatives:" <\> unlines (map pretty ns)) @@ -71,24 +72,24 @@ printErrReason opts ctx = group . \case where reason = \case Mismatch -> pretty "mismatch" - Occurs v t -> reflow "infinite type:" <+> getPrint (print opts ctx (metavar v)) <+> reflow "occurs in" <+> getPrint (print opts ctx t) - exp' = either reflow (getPrint . print opts ctx) exp - act' = either reflow (getPrint . print opts ctx) act + Occurs v t -> reflow "infinite type:" <+> print opts ctx (metavar v) <+> reflow "occurs in" <+> print opts ctx t + exp' = either reflow (print opts ctx) exp + act' = either reflow (print opts ctx) act -- line things up nicely for e.g. wrapped function types align = nest 2 . (flatAlt (line <> stimes (3 :: Int) space) mempty <>) UnifyKind (Exp exp) (Act act) -> pretty "mismatch" <> hardline <> pretty "expected:" <> align exp' <> hardline <> pretty " actual:" <> align act' where - exp' = either reflow (getPrint . print opts ctx) exp - act' = getPrint (print opts ctx act) + exp' = either reflow (print opts ctx) exp + act' = print opts ctx act -- line things up nicely for e.g. wrapped function types align = nest 2 . (flatAlt (line <> stimes (3 :: Int) space) mempty <>) Hole n _T -> - let _T' = getPrint (print opts ctx _T) + let _T' = print opts ctx _T in fillSep [ reflow "found hole", pretty n, colon, _T' ] Invariant s -> reflow s - MissingInterface i -> reflow "could not find required interface" <+> getPrint (print opts ctx i) + MissingInterface i -> reflow "could not find required interface" <+> print opts ctx i rethrowElabWarnings :: L.WriteC (Notice (Doc Style)) Warn m a -> m a From 15f96e2c724f4fd0428b4f53ae86f64d79c70042 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 9 May 2022 15:48:45 -0400 Subject: [PATCH 1298/1324] Solve spurious ambiguity. --- src/Facet/Graph.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/Facet/Graph.hs b/src/Facet/Graph.hs index c005f705f..41a8e895e 100644 --- a/src/Facet/Graph.hs +++ b/src/Facet/Graph.hs @@ -60,10 +60,14 @@ lookupM :: Has (Choose :+: Empty) sig m => QName -> Graph -> m (Maybe FilePath, lookupM n = maybe empty pure . Map.lookup n . getGraph lookupWith :: Has (Choose :+: Empty) sig m => (Name -> Module -> m res) -> Graph -> Module -> QName -> m res -lookupWith lookup graph mod@Module{ name } (QName (m:|>n)) - = guard (m == toSnoc name || m == Nil) *> lookup n mod - <|> guard (m == Nil) *> foldMapC (maybe empty (lookup n) . snd) (getGraph graph) - <|> guard (m /= Nil) *> (lookupM (fromSnoc m) graph >>= maybe empty pure . snd >>= lookup n) +lookupWith lookup graph mod@Module{ name } (QName (m:|>n)) = guards + [ (m == toSnoc name || m == Nil, lookup n mod) + , (m == Nil, foldMapC (maybe empty (lookup n) . snd) (getGraph graph)) + , (m /= Nil, lookupM (fromSnoc m) graph >>= maybe empty pure . snd >>= lookup n) + ] + +guards :: Has Empty sig m => [(Bool, m a)] -> m a +guards cases = foldr (\ (cond, alt) rest -> if cond then alt else rest) empty cases lookupQ :: Has (Choose :+: Empty) sig m => Graph -> Module -> QName -> m Def lookupQ = lookupWith (\ n m -> view def_ <$> (lookupDef n m)) From 281bc13d7cdaeabf91689f46fda3dd2b6a86aa21 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 9 May 2022 18:30:09 -0400 Subject: [PATCH 1299/1324] Customize the Show instance for Type to show its own constructors properly. --- src/Facet/Type/Norm.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 13b2d7f8a..07f0ca2d4 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -47,7 +47,7 @@ data Type | Arrow (Maybe Name) Type Type | Ne (Var (Either Meta Level)) (Snoc Type) | Comp (Signature Type) Type - deriving (Eq, Ord, Show) via Quoting TX.Type Type + deriving (Eq, Ord) via Quoting TX.Type Type instance C.Type Type where string = String @@ -66,6 +66,16 @@ instance Quote Type TX.Type where Comp s t -> TX.Comp <$> traverseSignature quote s <*> quote t Ne n sp -> foldl' (\ h t -> TX.App <$> h <*> quote t) (Quoter (\ d -> TX.Var (toIndexed d n))) sp +instance Show Type where + showsPrec _ = go 0 + where + go d = \case + String -> showString "String" + ForAll n k b -> showString "ForAll " . showsPrec 11 n . showChar ' ' . showsPrec 11 k . showChar ' ' . showParen True (showString "\\ " . showsPrec 11 d . showString "->". go (succ d) (b (bound d))) + Arrow n a b -> showString "Arrow " . showsPrec 11 n . showChar ' ' . go d a . showChar ' ' . go d b + Ne v ts -> showString "Ne " . showsPrec 11 v . showString " [" . foldr (\ t r -> go d t . showString ", " . r) id ts . showChar ']' + Comp s t -> showString "Comp [" . foldr (\ t r -> go d t . showString ", " . r) id s . showString "] " . go d t + _String :: Prism' Type () _String = prism' (const String) (\case{ String -> Just () ; _ -> Nothing }) From d5b3dc98c65faf83eef9fa4f06cb33b981ad944b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 9 May 2022 22:18:43 -0400 Subject: [PATCH 1300/1324] Qualify sum names. --- src/Facet/Elab/Sequent.hs | 6 +++--- src/Facet/Sequent/Expr.hs | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 523db0906..8afae384b 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -221,7 +221,7 @@ patternBody scrutinees clauses = Check $ \ _T -> case scrutinees of Clause (PVal PWildcard :ps) b -> Just (Clause (padding <> ps) b) Clause (PVal (PVar n) :ps) b -> Just (Clause (padding <> ps) (fmap (n :==> _A |-) b)) Clause (PVal (PCon n fs):ps) b - | n == q name -> Just (Clause (map PVal fs <> ps) b) + | n == name -> Just (Clause (map PVal fs <> ps) b) _ -> Nothing where padding = replicate (length fieldTypes) (PVal PWildcard) @@ -229,7 +229,7 @@ patternBody scrutinees clauses = Check $ \ _T -> case scrutinees of groups <- for constructors (\ (name :=: _C) -> do let fieldTypes = argumentTypes _C prefix <- for fieldTypes (\ _T -> (:==> _T) <$> freshName "x") - pure (name :=: muL (const (patternBody (prefix <> scrutinees') (mapMaybe (filterClauses name fieldTypes) clauses))))) + pure (qname // name :=: muL (const (patternBody (prefix <> scrutinees') (mapMaybe (filterClauses (qname // name) fieldTypes) clauses))))) check (freeR s >< case' groups ::: _T) @@ -258,7 +258,7 @@ t >< c = Check $ \ _T -> liftA2 (SQ.:|:) (check (t ::: _T)) (check (c ::: _T)) infix 3 >< -case' :: Applicative m => [Name :=: (Type <==: m SQ.Coterm)] -> Type <==: m SQ.Coterm +case' :: Applicative m => [QName :=: (Type <==: m SQ.Coterm)] -> Type <==: m SQ.Coterm case' cases = Check $ \ _T -> SQ.SumL <$> traverse (traverse (\ body -> check (body ::: _T))) cases diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index f4d2d06cb..2b83dcc4e 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -41,7 +41,7 @@ data Term = Var (Var Index) | MuR Scope | LamR Scope - | SumR Name Term + | SumR QName Term | PrdR [Term] | StringR Text deriving (Show) @@ -56,7 +56,7 @@ data Coterm = Covar (Var Index) | MuL Scope | LamL Term Coterm - | SumL [Name :=: Coterm] + | SumL [QName :=: Coterm] | PrdL Int Coterm deriving (Show) From dab93a0463a01c77f5c4eb33aa4dbecf705b2f8f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 9 May 2022 22:22:12 -0400 Subject: [PATCH 1301/1324] Specialize the error case a bit. --- src/Facet/Elab/Sequent.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 8afae384b..1518d5651 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -239,7 +239,10 @@ patternBody scrutinees clauses = Check $ \ _T -> case scrutinees of Clause (PVal (PVar n) :ps) b -> [Clause ps (fmap (n :==> _A |-) b)] Clause _ _ -> []) ::: _T) - [] -> check (body (head clauses) ::: _T) -- FIXME: throw an error if there aren't any clauses left + -- FIXME: throw a proper error if there aren't any clauses left + [] -> case clauses of + c:_ -> check (body c ::: _T) + [] -> error $ "patternBody: no clause left for exhausted scrutinee at type " <> show _T freeL :: Applicative m => Name -> Type <==: m SQ.Coterm From 60c7d3ae5ec853165c884c67fcdd7a01a076a5a7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 10 May 2022 02:16:36 -0400 Subject: [PATCH 1302/1324] Spacing. --- src/Facet/Type/Norm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 07f0ca2d4..1b827ce29 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -71,7 +71,7 @@ instance Show Type where where go d = \case String -> showString "String" - ForAll n k b -> showString "ForAll " . showsPrec 11 n . showChar ' ' . showsPrec 11 k . showChar ' ' . showParen True (showString "\\ " . showsPrec 11 d . showString "->". go (succ d) (b (bound d))) + ForAll n k b -> showString "ForAll " . showsPrec 11 n . showChar ' ' . showsPrec 11 k . showChar ' ' . showParen True (showString "\\ " . showsPrec 11 d . showString " -> ". go (succ d) (b (bound d))) Arrow n a b -> showString "Arrow " . showsPrec 11 n . showChar ' ' . go d a . showChar ' ' . go d b Ne v ts -> showString "Ne " . showsPrec 11 v . showString " [" . foldr (\ t r -> go d t . showString ", " . r) id ts . showChar ']' Comp s t -> showString "Comp [" . foldr (\ t r -> go d t . showString ", " . r) id s . showString "] " . go d t From 494a03422eabaffd92e84f9eb23c5f714d4d5254 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 10 May 2022 02:20:27 -0400 Subject: [PATCH 1303/1324] Avoid trailing commas. --- src/Facet/Type/Norm.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 1b827ce29..e59948e75 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -24,6 +24,7 @@ module Facet.Type.Norm import Control.Effect.Empty import Data.Foldable (foldl') +import Data.List (intersperse) import Data.Maybe (fromMaybe) import Facet.Interface import Facet.Kind @@ -74,7 +75,7 @@ instance Show Type where ForAll n k b -> showString "ForAll " . showsPrec 11 n . showChar ' ' . showsPrec 11 k . showChar ' ' . showParen True (showString "\\ " . showsPrec 11 d . showString " -> ". go (succ d) (b (bound d))) Arrow n a b -> showString "Arrow " . showsPrec 11 n . showChar ' ' . go d a . showChar ' ' . go d b Ne v ts -> showString "Ne " . showsPrec 11 v . showString " [" . foldr (\ t r -> go d t . showString ", " . r) id ts . showChar ']' - Comp s t -> showString "Comp [" . foldr (\ t r -> go d t . showString ", " . r) id s . showString "] " . go d t + Comp s t -> showString "Comp [" . foldr (.) id (intersperse (showString ", ") (foldr ((:) . go d) [] s)) . showString "] " . go d t _String :: Prism' Type () From d8a953c310e5606ab82634fd390834a6746a76ef Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 10 May 2022 02:27:54 -0400 Subject: [PATCH 1304/1324] Show variables nicely. --- src/Facet/Type/Norm.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index e59948e75..6ffaefb0f 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -29,6 +29,7 @@ import Data.Maybe (fromMaybe) import Facet.Interface import Facet.Kind import Facet.Name +import Facet.Pretty (toAlpha) import Facet.Quote import Facet.Snoc import Facet.Subst @@ -72,11 +73,15 @@ instance Show Type where where go d = \case String -> showString "String" - ForAll n k b -> showString "ForAll " . showsPrec 11 n . showChar ' ' . showsPrec 11 k . showChar ' ' . showParen True (showString "\\ " . showsPrec 11 d . showString " -> ". go (succ d) (b (bound d))) + ForAll n k b -> showString "ForAll " . showsPrec 11 n . showChar ' ' . showsPrec 11 k . showChar ' ' . showParen True (showString "\\ " . showsLevel d . showString " -> ". go (succ d) (b (bound d))) Arrow n a b -> showString "Arrow " . showsPrec 11 n . showChar ' ' . go d a . showChar ' ' . go d b - Ne v ts -> showString "Ne " . showsPrec 11 v . showString " [" . foldr (\ t r -> go d t . showString ", " . r) id ts . showChar ']' + Ne v ts -> showString "Ne " . showsVar v . showString " [" . foldr (\ t r -> go d t . showString ", " . r) id ts . showChar ']' Comp s t -> showString "Comp [" . foldr (.) id (intersperse (showString ", ") (foldr ((:) . go d) [] s)) . showString "] " . go d t - + showsVar = \case + Bound (Left (Meta v)) -> showChar 'σ' . shows v + Bound (Right d) -> showsLevel d + Free n -> shows n + showsLevel (Level v) = showString (toAlpha ['a'..'z'] v) _String :: Prism' Type () _String = prism' (const String) (\case{ String -> Just () ; _ -> Nothing }) From 5740fe2601d999da8afdc8f8e9a3c9e45a89050c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 10 May 2022 02:30:27 -0400 Subject: [PATCH 1305/1324] Show foldables the same way. --- src/Facet/Type/Norm.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 6ffaefb0f..8f4ec0b29 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -75,13 +75,14 @@ instance Show Type where String -> showString "String" ForAll n k b -> showString "ForAll " . showsPrec 11 n . showChar ' ' . showsPrec 11 k . showChar ' ' . showParen True (showString "\\ " . showsLevel d . showString " -> ". go (succ d) (b (bound d))) Arrow n a b -> showString "Arrow " . showsPrec 11 n . showChar ' ' . go d a . showChar ' ' . go d b - Ne v ts -> showString "Ne " . showsVar v . showString " [" . foldr (\ t r -> go d t . showString ", " . r) id ts . showChar ']' - Comp s t -> showString "Comp [" . foldr (.) id (intersperse (showString ", ") (foldr ((:) . go d) [] s)) . showString "] " . go d t + Ne v ts -> showString "Ne " . showsVar v . showString " [" . showsFoldable (go d) ts . showChar ']' + Comp s t -> showString "Comp [" . showsFoldable (go d) s . showString "] " . go d t showsVar = \case Bound (Left (Meta v)) -> showChar 'σ' . shows v Bound (Right d) -> showsLevel d Free n -> shows n showsLevel (Level v) = showString (toAlpha ['a'..'z'] v) + showsFoldable f s = foldr (.) id (intersperse (showString ", ") (foldr ((:) . f) [] s)) _String :: Prism' Type () _String = prism' (const String) (\case{ String -> Just () ; _ -> Nothing }) From a83985686f2a59e411700da38a7e5134a291c33a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 10 May 2022 02:34:31 -0400 Subject: [PATCH 1306/1324] Apply precedence correctly. --- src/Facet/Type/Norm.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 8f4ec0b29..64a6bf8c8 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -69,14 +69,14 @@ instance Quote Type TX.Type where Ne n sp -> foldl' (\ h t -> TX.App <$> h <*> quote t) (Quoter (\ d -> TX.Var (toIndexed d n))) sp instance Show Type where - showsPrec _ = go 0 + showsPrec = go 0 where - go d = \case + go d p = \case String -> showString "String" - ForAll n k b -> showString "ForAll " . showsPrec 11 n . showChar ' ' . showsPrec 11 k . showChar ' ' . showParen True (showString "\\ " . showsLevel d . showString " -> ". go (succ d) (b (bound d))) - Arrow n a b -> showString "Arrow " . showsPrec 11 n . showChar ' ' . go d a . showChar ' ' . go d b - Ne v ts -> showString "Ne " . showsVar v . showString " [" . showsFoldable (go d) ts . showChar ']' - Comp s t -> showString "Comp [" . showsFoldable (go d) s . showString "] " . go d t + ForAll n k b -> showParen (p > 10) $ showString "ForAll " . showsPrec 11 n . showChar ' ' . showsPrec 11 k . showChar ' ' . showParen True (showString "\\ " . showsLevel d . showString " -> ". go (succ d) 0 (b (bound d))) + Arrow n a b -> showParen (p > 10) $ showString "Arrow " . showsPrec 11 n . showChar ' ' . go d 11 a . showChar ' ' . go d 11 b + Ne v ts -> showParen (p > 10) $ showString "Ne " . showsVar v . showString " [" . showsFoldable (go d 0) ts . showChar ']' + Comp s t -> showParen (p > 10) $ showString "Comp [" . showsFoldable (go d 0) s . showString "] " . go d 11 t showsVar = \case Bound (Left (Meta v)) -> showChar 'σ' . shows v Bound (Right d) -> showsLevel d From 518b02da9ead3c9caea7c6f5c6b70232a177a65e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 10 May 2022 02:36:07 -0400 Subject: [PATCH 1307/1324] Show tacit arrows nicely. --- src/Facet/Type/Norm.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 64a6bf8c8..a846a4e56 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -72,11 +72,12 @@ instance Show Type where showsPrec = go 0 where go d p = \case - String -> showString "String" - ForAll n k b -> showParen (p > 10) $ showString "ForAll " . showsPrec 11 n . showChar ' ' . showsPrec 11 k . showChar ' ' . showParen True (showString "\\ " . showsLevel d . showString " -> ". go (succ d) 0 (b (bound d))) - Arrow n a b -> showParen (p > 10) $ showString "Arrow " . showsPrec 11 n . showChar ' ' . go d 11 a . showChar ' ' . go d 11 b - Ne v ts -> showParen (p > 10) $ showString "Ne " . showsVar v . showString " [" . showsFoldable (go d 0) ts . showChar ']' - Comp s t -> showParen (p > 10) $ showString "Comp [" . showsFoldable (go d 0) s . showString "] " . go d 11 t + String -> showString "String" + ForAll n k b -> showParen (p > 10) $ showString "ForAll " . showsPrec 11 n . showChar ' ' . showsPrec 11 k . showChar ' ' . showParen True (showString "\\ " . showsLevel d . showString " -> ". go (succ d) 0 (b (bound d))) + Arrow Nothing a b -> showParen (p > 1) $ go d 2 a . showString " --> " . go d 1 b + Arrow n a b -> showParen (p > 10) $ showString "Arrow " . showsPrec 11 n . showChar ' ' . go d 11 a . showChar ' ' . go d 11 b + Ne v ts -> showParen (p > 10) $ showString "Ne " . showsVar v . showString " [" . showsFoldable (go d 0) ts . showChar ']' + Comp s t -> showParen (p > 10) $ showString "Comp [" . showsFoldable (go d 0) s . showString "] " . go d 11 t showsVar = \case Bound (Left (Meta v)) -> showChar 'σ' . shows v Bound (Right d) -> showsLevel d From f18cb055f1b2a1102f54c6d688e66f626bbdc0cf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 10 May 2022 02:37:06 -0400 Subject: [PATCH 1308/1324] Use uppercase variables. --- src/Facet/Type/Norm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index a846a4e56..550625aaa 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -82,7 +82,7 @@ instance Show Type where Bound (Left (Meta v)) -> showChar 'σ' . shows v Bound (Right d) -> showsLevel d Free n -> shows n - showsLevel (Level v) = showString (toAlpha ['a'..'z'] v) + showsLevel (Level v) = showString ('_':toAlpha ['A'..'Z'] v) showsFoldable f s = foldr (.) id (intersperse (showString ", ") (foldr ((:) . f) [] s)) _String :: Prism' Type () From 51fbc0a82862f24eb81081abcf4bbd755be85a55 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 10 May 2022 02:39:44 -0400 Subject: [PATCH 1309/1324] Show spines as applications. --- src/Facet/Type/Norm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index 550625aaa..af86815bf 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -76,7 +76,7 @@ instance Show Type where ForAll n k b -> showParen (p > 10) $ showString "ForAll " . showsPrec 11 n . showChar ' ' . showsPrec 11 k . showChar ' ' . showParen True (showString "\\ " . showsLevel d . showString " -> ". go (succ d) 0 (b (bound d))) Arrow Nothing a b -> showParen (p > 1) $ go d 2 a . showString " --> " . go d 1 b Arrow n a b -> showParen (p > 10) $ showString "Arrow " . showsPrec 11 n . showChar ' ' . go d 11 a . showChar ' ' . go d 11 b - Ne v ts -> showParen (p > 10) $ showString "Ne " . showsVar v . showString " [" . showsFoldable (go d 0) ts . showChar ']' + Ne v ts -> showParen (p > 10) $ foldl' (\ s t -> s . showChar ' ' . go d 11 t) (showsVar v) ts Comp s t -> showParen (p > 10) $ showString "Comp [" . showsFoldable (go d 0) s . showString "] " . go d 11 t showsVar = \case Bound (Left (Meta v)) -> showChar 'σ' . shows v From 2f54c664aa210584fa145d0803941d18eaed6c16 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 10 May 2022 02:40:09 -0400 Subject: [PATCH 1310/1324] Don't parenthesize atoms. --- src/Facet/Type/Norm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Type/Norm.hs b/src/Facet/Type/Norm.hs index af86815bf..f79639adb 100644 --- a/src/Facet/Type/Norm.hs +++ b/src/Facet/Type/Norm.hs @@ -76,7 +76,7 @@ instance Show Type where ForAll n k b -> showParen (p > 10) $ showString "ForAll " . showsPrec 11 n . showChar ' ' . showsPrec 11 k . showChar ' ' . showParen True (showString "\\ " . showsLevel d . showString " -> ". go (succ d) 0 (b (bound d))) Arrow Nothing a b -> showParen (p > 1) $ go d 2 a . showString " --> " . go d 1 b Arrow n a b -> showParen (p > 10) $ showString "Arrow " . showsPrec 11 n . showChar ' ' . go d 11 a . showChar ' ' . go d 11 b - Ne v ts -> showParen (p > 10) $ foldl' (\ s t -> s . showChar ' ' . go d 11 t) (showsVar v) ts + Ne v ts -> showParen (p > 10 && not (null ts)) $ foldl' (\ s t -> s . showChar ' ' . go d 11 t) (showsVar v) ts Comp s t -> showParen (p > 10) $ showString "Comp [" . showsFoldable (go d 0) s . showString "] " . go d 11 t showsVar = \case Bound (Left (Meta v)) -> showChar 'σ' . shows v From d7e5aa3b408196aea581cf45543dd4a0af7404b5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 10 May 2022 06:50:53 -0400 Subject: [PATCH 1311/1324] Decompose foralls. --- src/Facet/Elab/Sequent.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 1518d5651..df4d18733 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -54,6 +54,7 @@ import Facet.Pattern import qualified Facet.Scope as Scope import qualified Facet.Sequent.Expr as SQ import Facet.Snoc (Snoc(..)) +import Facet.Snoc.NonEmpty (NonEmpty(..)) import Facet.Subst import qualified Facet.Surface.Term.Expr as S import qualified Facet.Surface.Type.Expr as S @@ -210,7 +211,7 @@ patternBody -> Type <==: m SQ.Command patternBody scrutinees clauses = Check $ \ _T -> case scrutinees of (s :==> _A):scrutinees' -> case _A of - Ne (Free qname) _ -> do + Ne (Free qname@(QName (_:>_:|>_))) _ -> do def <- resolveDef qname constructors <- maybe (mismatchTypes (Exp (Left "datatype")) (Act (Left (case def of DTerm{} -> "term" @@ -266,6 +267,7 @@ case' cases = Check $ \ _T -> SQ.SumL <$> traverse (traverse (\ body -> check (b argumentTypes :: Type -> [Type] +argumentTypes (T.ForAll n _ b) = argumentTypes (b (free (q n))) argumentTypes (T.Arrow _ _A _B) = _A : argumentTypes _B argumentTypes _ = [] From 2bd99cb57c48496185b0fac9cbfd947405a3912c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 10 May 2022 07:50:38 -0400 Subject: [PATCH 1312/1324] Don't make recursive calls without clauses. --- src/Facet/Elab/Sequent.hs | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index df4d18733..72dc10383 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -36,7 +36,7 @@ import Control.Carrier.Fresh.Church import Control.Carrier.Reader import Control.Carrier.State.Church import Control.Carrier.Throw.Either -import Data.Maybe (mapMaybe) +import Data.Maybe (catMaybes, mapMaybe) import Data.Text (Text) import Data.Traversable (for) import qualified Facet.Context as C @@ -229,10 +229,14 @@ patternBody scrutinees clauses = Check $ \ _T -> case scrutinees of groups <- for constructors (\ (name :=: _C) -> do let fieldTypes = argumentTypes _C - prefix <- for fieldTypes (\ _T -> (:==> _T) <$> freshName "x") - pure (qname // name :=: muL (const (patternBody (prefix <> scrutinees') (mapMaybe (filterClauses (qname // name) fieldTypes) clauses))))) - - check (freeR s >< case' groups ::: _T) + clauses' = mapMaybe (filterClauses (qname // name) fieldTypes) clauses + if null clauses' then + pure Nothing + else do + prefix <- for fieldTypes (\ _T -> (:==> _T) <$> freshName "x") + pure (Just (qname // name :=: muL (const (patternBody (prefix <> scrutinees') clauses'))))) + + check (freeR s >< case' (catMaybes groups) ::: _T) -- FIXME: what should effect patterns elaborate to? _ -> check (patternBody scrutinees' (clauses >>= \case From 194111083f0f39ebf08da15f4beb16728573f804 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 10 May 2022 08:03:25 -0400 Subject: [PATCH 1313/1324] =?UTF-8?q?Build=20a=20=C2=B5=20abstraction=20fo?= =?UTF-8?q?r=20the=20last=20leg.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Elab/Sequent.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 72dc10383..f3a8a4bd6 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -186,9 +186,8 @@ checkLamS clauses = go id kx <- freshName "kx" SQ.lamR kx x <$> check (go (scrutinees . ((x :==> _A) :)) >< freeL kx ::: _B) _T -> do - x <- freshName "x" kx <- freshName "kx" - SQ.lamR kx x <$> check (patternBody (scrutinees []) (map (fmap (>< freeL kx)) clauses) ::: _T) + SQ.muR kx <$> check (patternBody (scrutinees []) (map (fmap (>< freeL kx)) clauses) ::: _T) data Clause a = Clause From eb4657a74bb415cbeead88d3f4b73cc2eb1a4cbe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 10 May 2022 09:17:24 -0400 Subject: [PATCH 1314/1324] Correct the printing of applications. --- src/Facet/Print.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Print.hs b/src/Facet/Print.hs index ee7c27e09..d5d2deacb 100644 --- a/src/Facet/Print.hs +++ b/src/Facet/Print.hs @@ -238,7 +238,7 @@ instance Printable SQ.Coterm where SQ.Covar (Free n) -> qvar n SQ.Covar (Bound n) -> fromMaybe (intro __ (toLeveled d n)) $ env Env.!? n SQ.MuL b -> pretty "µ̃" <> sqbinder d (\ p@(n :=: v) -> sqblock (v <+> dot <+> print opts (env |> p) (SQ.instantiateL (SQ.freeL n) b))) - SQ.LamL a k -> print opts env a <> print opts env k + SQ.LamL a k -> print opts env a <> dot <> print opts env k SQ.SumL bs -> pretty "case" <+> sqblock (encloseSep mempty mempty (pretty ", ") (map (\ (n :=: b) -> parens (pretty n) <+> dot <+> print opts env b) bs)) SQ.PrdL i b -> pretty 'π' <> subscript i <+> print opts env b where From 3f653f08e691599d6dfb5c02faac8ab29c8fb335 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 10 May 2022 09:29:58 -0400 Subject: [PATCH 1315/1324] Increment both counters. --- src/Facet/Sequent/Expr.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 2b83dcc4e..88a0c99ac 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -132,7 +132,7 @@ replaceTerm lr within = case within of Var (Free (QName (Nil:|>n))) -> that (const within) free' lr n Var (Free _) -> within Var (Bound inner) -> that (const within) bound' lr inner - MuR (Scope b) -> MuR (Scope (replaceCommand (first incr lr) b)) + MuR (Scope b) -> MuR (Scope (replaceCommand (bimap incr incr lr) b)) LamR (Scope b) -> LamR (Scope (replaceCommand (bimap incr incr lr) b)) SumR i a -> SumR i (replaceTerm lr a) PrdR as -> PrdR (map (replaceTerm lr) as) @@ -146,7 +146,7 @@ replaceCoterm lr within = case within of Covar (Free (QName (Nil:|>n))) -> this (const within) free' lr n Covar (Free _) -> within Covar (Bound inner) -> this (const within) bound' lr inner - MuL (Scope b) -> MuL (Scope (replaceCommand (second incr lr) b)) + MuL (Scope b) -> MuL (Scope (replaceCommand (bimap incr incr lr) b)) LamL a k -> LamL (replaceTerm lr a) (replaceCoterm lr k) SumL cs -> SumL (map (fmap (replaceCoterm lr)) cs) PrdL i b -> PrdL i (replaceCoterm lr b) @@ -157,7 +157,7 @@ replaceCoterm lr within = case within of replaceCommand :: These (Replacer Coterm) (Replacer Term) -> (Command -> Command) replaceCommand lr = \case t :|: c -> replaceTerm lr t :|: replaceCoterm lr c - Let t (Scope b) -> Let (replaceTerm lr t) (Scope (replaceCommand (second incr lr) b)) + Let t (Scope b) -> Let (replaceTerm lr t) (Scope (replaceCommand (bimap incr incr lr) b)) -- Smart constructors From 71dd32d35c768d47a3bec34b3432659e13f7e173 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 10 May 2022 09:30:15 -0400 Subject: [PATCH 1316/1324] Bind the final continuation in the context. --- src/Facet/Elab/Sequent.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index f3a8a4bd6..744006da5 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -187,7 +187,7 @@ checkLamS clauses = go id SQ.lamR kx x <$> check (go (scrutinees . ((x :==> _A) :)) >< freeL kx ::: _B) _T -> do kx <- freshName "kx" - SQ.muR kx <$> check (patternBody (scrutinees []) (map (fmap (>< freeL kx)) clauses) ::: _T) + SQ.muR kx <$> (kx :==> _T |- check (patternBody (scrutinees []) (map (fmap (>< freeL kx)) clauses) ::: _T)) data Clause a = Clause From 1a76121ce1d9e2b8365354937f65307f7b5b37fe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 10 May 2022 09:34:28 -0400 Subject: [PATCH 1317/1324] Share a single counter. --- src/Facet/Sequent/Expr.hs | 57 ++++++++++++++++----------------------- 1 file changed, 23 insertions(+), 34 deletions(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 88a0c99ac..73ad5fd82 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -84,7 +84,7 @@ abstractL c = abstractLR (This c) abstractR t = abstractLR (That t) abstractLR :: These Name Name -> (Command -> Scope) -abstractLR ct = Scope . replaceCommand (bimap (\ c -> Replacer 0 (freeL c) boundL) (\ t -> Replacer 0 (freeR t) boundR) ct) where +abstractLR ct = Scope . replaceCommand (bimap (\ c -> Replacer (freeL c) boundL) (\ t -> Replacer (freeR t) boundR) ct) 0 where freeR t outer name | name == t = Var (Bound outer) | otherwise = Var (Free (q name)) @@ -101,7 +101,7 @@ instantiateR :: Term -> (Scope -> Command) instantiateR t = instantiateLR (That t) instantiateLR :: These Coterm Term -> (Scope -> Command) -instantiateLR ct = replaceCommand (bimap (Replacer 0 freeL . boundL) (Replacer 0 freeR . boundR) ct) . getScope where +instantiateLR ct = replaceCommand (bimap (Replacer freeL . boundL) (Replacer freeR . boundR) ct) 0 . getScope where freeR _ name = Var (Free (q name)) freeL _ name = Covar (Free (q name)) boundR t outer inner @@ -112,52 +112,41 @@ instantiateLR ct = replaceCommand (bimap (Replacer 0 freeL . boundL) (Replacer 0 | otherwise = Covar (Bound inner) data Replacer t = Replacer - { outer :: Index - , free :: Index -> Name -> t + { free :: Index -> Name -> t , bound :: Index -> Index -> t } -free' :: Replacer t -> Name -> t -free' Replacer{ outer, free } = free outer - -bound' :: Replacer t -> Index -> t -bound' Replacer{ outer, bound } = bound outer - -incr :: Replacer t -> Replacer t -incr r@Replacer{ outer } = r{ outer = outer + 1} - - -replaceTerm :: These (Replacer Coterm) (Replacer Term) -> (Term -> Term) -replaceTerm lr within = case within of - Var (Free (QName (Nil:|>n))) -> that (const within) free' lr n +replaceTerm :: These (Replacer Coterm) (Replacer Term) -> Index -> (Term -> Term) +replaceTerm lr outer within = case within of + Var (Free (QName (Nil:|>n))) -> that (const within) (`free` outer) lr n Var (Free _) -> within - Var (Bound inner) -> that (const within) bound' lr inner - MuR (Scope b) -> MuR (Scope (replaceCommand (bimap incr incr lr) b)) - LamR (Scope b) -> LamR (Scope (replaceCommand (bimap incr incr lr) b)) - SumR i a -> SumR i (replaceTerm lr a) - PrdR as -> PrdR (map (replaceTerm lr) as) + Var (Bound inner) -> that (const within) (`bound` outer) lr inner + MuR (Scope b) -> MuR (Scope (replaceCommand lr (succ outer) b)) + LamR (Scope b) -> LamR (Scope (replaceCommand lr (succ (succ outer)) b)) + SumR i a -> SumR i (replaceTerm lr outer a) + PrdR as -> PrdR (map (replaceTerm lr outer) as) StringR _ -> within where that :: c -> (b -> c) -> These a b -> c that d f = these (const d) f (const f) -replaceCoterm :: These (Replacer Coterm) (Replacer Term) -> (Coterm -> Coterm) -replaceCoterm lr within = case within of - Covar (Free (QName (Nil:|>n))) -> this (const within) free' lr n +replaceCoterm :: These (Replacer Coterm) (Replacer Term) -> Index -> (Coterm -> Coterm) +replaceCoterm lr outer within = case within of + Covar (Free (QName (Nil:|>n))) -> this (const within) (`free` outer) lr n Covar (Free _) -> within - Covar (Bound inner) -> this (const within) bound' lr inner - MuL (Scope b) -> MuL (Scope (replaceCommand (bimap incr incr lr) b)) - LamL a k -> LamL (replaceTerm lr a) (replaceCoterm lr k) - SumL cs -> SumL (map (fmap (replaceCoterm lr)) cs) - PrdL i b -> PrdL i (replaceCoterm lr b) + Covar (Bound inner) -> this (const within) (`bound` outer) lr inner + MuL (Scope b) -> MuL (Scope (replaceCommand lr (succ outer) b)) + LamL a k -> LamL (replaceTerm lr outer a) (replaceCoterm lr outer k) + SumL cs -> SumL (map (fmap (replaceCoterm lr outer)) cs) + PrdL i b -> PrdL i (replaceCoterm lr outer b) where this :: c -> (a -> c) -> These a b -> c this d f = these f (const d) (const . f) -replaceCommand :: These (Replacer Coterm) (Replacer Term) -> (Command -> Command) -replaceCommand lr = \case - t :|: c -> replaceTerm lr t :|: replaceCoterm lr c - Let t (Scope b) -> Let (replaceTerm lr t) (Scope (replaceCommand (bimap incr incr lr) b)) +replaceCommand :: These (Replacer Coterm) (Replacer Term) -> Index -> (Command -> Command) +replaceCommand lr outer = \case + t :|: c -> replaceTerm lr outer t :|: replaceCoterm lr outer c + Let t (Scope b) -> Let (replaceTerm lr outer t) (Scope (replaceCommand lr (succ outer) b)) -- Smart constructors From 1c41496d4da6060e86645cf08793c89ae950281b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 10 May 2022 16:37:46 -0400 Subject: [PATCH 1318/1324] Distinguish local QNames. --- src/Facet/Name.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Facet/Name.hs b/src/Facet/Name.hs index fe10f070d..accaf756d 100644 --- a/src/Facet/Name.hs +++ b/src/Facet/Name.hs @@ -12,6 +12,7 @@ module Facet.Name , (//) , q , qlast +, qlocal , fromSnoc , toSnoc , Name(..) @@ -111,6 +112,10 @@ q = QName . (Nil SNE.:|>) qlast :: QName -> Name qlast (QName (_ SNE.:|> l)) = l +qlocal :: QName -> Maybe Name +qlocal (QName (Nil SNE.:|> n)) = Just n +qlocal _ = Nothing + fromSnoc :: Snoc Name -> QName fromSnoc = QName . SNE.fromSnoc From f4a00ebc41a91800a56540dd346e838ba750e778 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 10 May 2022 16:40:51 -0400 Subject: [PATCH 1319/1324] =?UTF-8?q?Discard=20pointless=20=C2=B5=CC=83-ab?= =?UTF-8?q?stractions.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Sequent/Expr.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 73ad5fd82..424be597d 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -177,7 +177,14 @@ boundL :: Index -> Coterm boundL = Covar . Bound muL :: Name -> Command -> Coterm -muL name body = MuL (abstractLR (That name) body) +muL name body = compactL name (MuL (abstractLR (That name) body)) + +compactL :: Name -> Coterm -> Coterm +compactL name = \case + MuL body + | Var (Free q) :|: k <- instantiateR (freeR name) body + , Just name == qlocal q -> k + c -> c let' :: Name -> Term -> Command -> Command From bc9acde8cb835c331cab076cb38b435d5bc4a34a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 10 May 2022 16:43:50 -0400 Subject: [PATCH 1320/1324] Use the right-abstraction. --- src/Facet/Sequent/Expr.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Facet/Sequent/Expr.hs b/src/Facet/Sequent/Expr.hs index 424be597d..16a57351a 100644 --- a/src/Facet/Sequent/Expr.hs +++ b/src/Facet/Sequent/Expr.hs @@ -177,7 +177,7 @@ boundL :: Index -> Coterm boundL = Covar . Bound muL :: Name -> Command -> Coterm -muL name body = compactL name (MuL (abstractLR (That name) body)) +muL name body = compactL name (MuL (abstractR name body)) compactL :: Name -> Coterm -> Coterm compactL name = \case From 27bf2c85d4ea9d7beaf6416071167b54b10bf902 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 10 May 2022 16:48:19 -0400 Subject: [PATCH 1321/1324] =?UTF-8?q?=C2=B5-left=20abstractions=20provide?= =?UTF-8?q?=20synths.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Elab/Sequent.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index 744006da5..de0c7bc10 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -252,10 +252,10 @@ patternBody scrutinees clauses = Check $ \ _T -> case scrutinees of freeL :: Applicative m => Name -> Type <==: m SQ.Coterm freeL = pure . pure . SQ.freeL -muL :: (Has Fresh sig m, Has (Reader ElabContext) sig m) => (SQ.Term -> Type <==: m SQ.Command) -> Type <==: m SQ.Coterm +muL :: (Has Fresh sig m, Has (Reader ElabContext) sig m) => (SQ.Term :==> Type -> Type <==: m SQ.Command) -> Type <==: m SQ.Coterm muL body = Check $ \ _T -> do x <- freshName "x" - SQ.muL x <$> (x :==> _T |- check (body (SQ.freeR x) ::: _T)) + SQ.muL x <$> (x :==> _T |- check (body (SQ.freeR x :==> _T) ::: _T)) freeR :: Applicative m => Name -> Type <==: m SQ.Term freeR = pure . pure . SQ.freeR From 2be7feff0b52a085dc5aea232478be2aae76f27e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 10 May 2022 16:50:30 -0400 Subject: [PATCH 1322/1324] =?UTF-8?q?Define=20a=20combinator=20for=20?= =?UTF-8?q?=C2=B5-right=20abstractions.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Facet/Elab/Sequent.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Facet/Elab/Sequent.hs b/src/Facet/Elab/Sequent.hs index de0c7bc10..e53d62c83 100644 --- a/src/Facet/Elab/Sequent.hs +++ b/src/Facet/Elab/Sequent.hs @@ -185,9 +185,7 @@ checkLamS clauses = go id x <- freshName "x" kx <- freshName "kx" SQ.lamR kx x <$> check (go (scrutinees . ((x :==> _A) :)) >< freeL kx ::: _B) - _T -> do - kx <- freshName "kx" - SQ.muR kx <$> (kx :==> _T |- check (patternBody (scrutinees []) (map (fmap (>< freeL kx)) clauses) ::: _T)) + _T -> check (muR (\ kx -> patternBody (scrutinees []) (map (fmap (>< switch (pure kx))) clauses)) ::: _T) data Clause a = Clause @@ -260,6 +258,11 @@ muL body = Check $ \ _T -> do freeR :: Applicative m => Name -> Type <==: m SQ.Term freeR = pure . pure . SQ.freeR +muR :: (Has Fresh sig m, Has (Reader ElabContext) sig m) => (SQ.Coterm :==> Type -> Type <==: m SQ.Command) -> Type <==: m SQ.Term +muR body = Check $ \ _T -> do + x <- freshName "x" + SQ.muR x <$> (x :==> _T |- check (body (SQ.freeL x :==> _T) ::: _T)) + (><) :: Applicative m => Type <==: m SQ.Term -> Type <==: m SQ.Coterm -> Type <==: m SQ.Command t >< c = Check $ \ _T -> liftA2 (SQ.:|:) (check (t ::: _T)) (check (c ::: _T)) From 0e69ba42f037e5867af302be5c768b228e323b57 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 16 Feb 2025 14:37:34 -0500 Subject: [PATCH 1323/1324] :fire: some foldls. --- src/Facet/Snoc.hs | 2 +- src/Facet/Snoc/NonEmpty.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Facet/Snoc.hs b/src/Facet/Snoc.hs index 384c58522..b9d3710df 100644 --- a/src/Facet/Snoc.hs +++ b/src/Facet/Snoc.hs @@ -11,7 +11,7 @@ module Facet.Snoc ) where import Control.Applicative -import Data.Foldable (foldl', foldr') +import Data.Foldable (foldr') import Data.Functor.Classes import Data.Semialign import Data.These diff --git a/src/Facet/Snoc/NonEmpty.hs b/src/Facet/Snoc/NonEmpty.hs index 415ccf45b..81257fbd3 100644 --- a/src/Facet/Snoc/NonEmpty.hs +++ b/src/Facet/Snoc/NonEmpty.hs @@ -9,7 +9,7 @@ module Facet.Snoc.NonEmpty , pattern FromList ) where -import Data.Foldable (foldl', foldr') +import Data.Foldable (foldr') import Facet.Snoc hiding (FromList) import GHC.Exts From 9d38ee7d5556bed71aa8624c6cb01f7c131ed8df Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 16 Feb 2025 19:37:44 -0500 Subject: [PATCH 1324/1324] Typo. --- docs/elaboration.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/elaboration.md b/docs/elaboration.md index beb834e28..c7f15b006 100644 --- a/docs/elaboration.md +++ b/docs/elaboration.md @@ -126,7 +126,7 @@ This judgement is used to elaborate syntax where we need to know the type in adv Γ ⊢ M ~~> V ==> τ ``` -This judgement is used to elaborate syntax where we can deduce the type from the term itselr, perhaps requiring that we are able to deduce some or all of it from its components. +This judgement is used to elaborate syntax where we can deduce the type from the term itself, perhaps requiring that we are able to deduce some or all of it from its components. ### Syntax- vs. type-directed