From fe090e4b2ce9449bfc2c5362e222e0d971076306 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Wed, 5 Oct 2022 16:12:16 +0100 Subject: [PATCH 01/89] [ WIP ] mockup of rules instead of actors, in the middle of the semantic specification --- examples/stlcRules.act | 95 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 95 insertions(+) create mode 100644 examples/stlcRules.act diff --git a/examples/stlcRules.act b/examples/stlcRules.act new file mode 100644 index 0000000..cd74d5b --- /dev/null +++ b/examples/stlcRules.act @@ -0,0 +1,95 @@ +------------------------------------------------------------------------------ +-- Datatypes + +syntax + { 'Type = ['EnumOrTag ['Nat] + [['Arr 'Type 'Type]] + ] + } + +syntax + { 'Check = ['Tag [ ['Lam ['Bind 'Synth 'Check]] + ['Emb 'Synth] + ]] + ; 'Synth = ['Tag [ ['Ann 'Check 'Type] + ['App 'Synth 'Check] + ]] + } + +{- +------------------------------------------------------------------------------ +-- Judgement forms + +/type : $'Type. +check : ?'Type. $'Check. +synth : $'Synth. !'Type. + +{- +-- | myCtxt maps synthesisable variables to types +myCtxt |- 'Synth -> 'Type +-} +-} + +------------------------------------------------------------------------------ +-- Judgement forms and their contracts + +{} type (T : 'Type => 'Type) {} -- no pre- or post conditions, + -- subject T is a 'Type, with citizen version a 'Type +{type T} check T (t : 'Check) {} +{} synth (t : 'Synth) T {type T} + +-- {} myCtxt |- x -> T {synth x T} + +------------------------------------------------------------------------------ +-- Rules + +type 'Nat {} + +type ['Arr S T] + { type S + | type T + } + +-- ~['Arr S T] means to not match, but to constrain instead +check ~['Arr S T] ['Lam \x. body] + -- hypothetical judgement with fresh x, assuming `synth x S` + -- (note hypothetical judgements have patterns in input and subject + -- positions, and expressions in output positions) + { \ x . synth x S |- check T body } +-- Could equivalently be written without deliberate capture of x: +-- { \ y . synth y S |- check T {x=y}body } + +check T ['Emb e] + { synth e S + | S ~ T + } + +synth ['Ann t T] T + { type T + | check T t + } + +synth ['App f s] T + { synth f ~['Arr S T] + | check S s + } + + +------------------------------------------------------------------------------ +-- Examples +{- +exec check@p. p! ['Arr 'Nat ['Arr 'Nat 'Nat]]. + p! ['Lam \z. ['Lam \_. ['Emb z]]]. +-} +{- +exec check@p. p! ['Arr 'Nat 'Nat]. + p! ['Lam \z. ['Emb z]]. + +-} + +exec check@p. + p! ['Arr 'Nat 'Nat]. + p! ['Lam \z. ['Emb + ['App ['Ann ['Lam \w. ['Emb w]] ['Arr 'Nat 'Nat]] + ['Emb z]]]]. + PRINTF "Victory!". From 34582c90c6787b898b6ea1d96b99ef8599555836 Mon Sep 17 00:00:00 2001 From: Jacques Carette Date: Wed, 5 Oct 2022 17:13:16 +0100 Subject: [PATCH 02/89] snapshot of current work --- examples/stlcRules.act | 51 +++++++++++++++++++++++++++++++----------- 1 file changed, 38 insertions(+), 13 deletions(-) diff --git a/examples/stlcRules.act b/examples/stlcRules.act index cd74d5b..56847fc 100644 --- a/examples/stlcRules.act +++ b/examples/stlcRules.act @@ -16,6 +16,12 @@ syntax ]] } +-- this is in 'Universe, or so we declare +syntax -- we're calling in not-'Nat on purpose + { 'Natural = ['EnumOrTag ['Zero] + [['Succ 'Natural]] + ] + } {- ------------------------------------------------------------------------------ -- Judgement forms @@ -33,25 +39,38 @@ myCtxt |- 'Synth -> 'Type ------------------------------------------------------------------------------ -- Judgement forms and their contracts -{} type (T : 'Type => 'Type) {} -- no pre- or post conditions, - -- subject T is a 'Type, with citizen version a 'Type -{type T} check T (t : 'Check) {} -{} synth (t : 'Synth) T {type T} +-- Something that looks like "Z : A => B" says +-- Z is an A when it's a subject, and a B when it becomes a citizen + +{} type (T : 'Type => 'Type) {} {T - 'Value : 'Universe } +{type T} check T (t : 'Check => T - 'Value) {} {} +{} synth (t : 'Synth => T - 'Value) T {type T} {} + +-- Open question in the above: will it always be the subject that's fed to an operator? +-- Note: the "T - 'Value" is in 'Universe and that T is the citizen, not the subject -- {} myCtxt |- x -> T {synth x T} ------------------------------------------------------------------------------ -- Rules +-- We're giving semantic objects as annotations on derivations +-- Proposal: => for citizenship -type 'Nat {} +type 'Nat => 'Nat {} + { 'Nat - 'Value = 'Natural } -type ['Arr S T] +type ['Arr S T] => ['Arr S T] { type S | type T } + -- Global assumption: 'Universe comes with Pi builtin + { ['Arr S T] - 'Value = ['Pi (S - 'Value) \_. (T - 'Value)] } + +-- Invariant: the subject in a premiss is always something with a name +-- payoff - the name BECOMES the name of the citizen -- ~['Arr S T] means to not match, but to constrain instead -check ~['Arr S T] ['Lam \x. body] +check ~['Arr S T] ['Lam \x. body] => \x. body -- hypothetical judgement with fresh x, assuming `synth x S` -- (note hypothetical judgements have patterns in input and subject -- positions, and expressions in output positions) @@ -59,33 +78,38 @@ check ~['Arr S T] ['Lam \x. body] -- Could equivalently be written without deliberate capture of x: -- { \ y . synth y S |- check T {x=y}body } -check T ['Emb e] +check T ['Emb e] => e { synth e S + -- by the magic of STLC, things are first-order, this is just unification | S ~ T } -synth ['Ann t T] T +-- first arg is a (subject) pattern position +-- 2nd argument is in output position & we give the citizen T +-- Note to selves: holy readability issues! +synth (['Ann t T] => t) T { type T | check T t } -synth ['App f s] T +synth (['App f s] => f -['app s]) T -- assuming citizen 'f' is meta-level function + -- irrefutable because of no overloading of application (in STLC) { synth f ~['Arr S T] | check S s } +------------------------------------------------------------------------------ + + ------------------------------------------------------------------------------ -- Examples {- exec check@p. p! ['Arr 'Nat ['Arr 'Nat 'Nat]]. p! ['Lam \z. ['Lam \_. ['Emb z]]]. --} -{- exec check@p. p! ['Arr 'Nat 'Nat]. p! ['Lam \z. ['Emb z]]. --} exec check@p. p! ['Arr 'Nat 'Nat]. @@ -93,3 +117,4 @@ exec check@p. ['App ['Ann ['Lam \w. ['Emb w]] ['Arr 'Nat 'Nat]] ['Emb z]]]]. PRINTF "Victory!". +-} From 1303b4b228928dd188b698f92b95546f0ab3e678 Mon Sep 17 00:00:00 2001 From: Jacques Carette Date: Wed, 5 Oct 2022 17:28:29 +0100 Subject: [PATCH 03/89] a good day's work on rules and citizens --- examples/stlcRules.act | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/examples/stlcRules.act b/examples/stlcRules.act index 56847fc..e532742 100644 --- a/examples/stlcRules.act +++ b/examples/stlcRules.act @@ -70,13 +70,16 @@ type ['Arr S T] => ['Arr S T] -- payoff - the name BECOMES the name of the citizen -- ~['Arr S T] means to not match, but to constrain instead -check ~['Arr S T] ['Lam \x. body] => \x. body +check ~['Arr S T] ['Lam \x. body] => \x. body -- x is a hypothetical inhabitant of S - 'Value -- hypothetical judgement with fresh x, assuming `synth x S` -- (note hypothetical judgements have patterns in input and subject -- positions, and expressions in output positions) { \ x . synth x S |- check T body } -- Could equivalently be written without deliberate capture of x: -- { \ y . synth y S |- check T {x=y}body } + -- note that if we use the above, then we'd expect to capture a y in S - 'Value in body the citizen + -- the elaborator-check that body is used fully generally in the premiss subject + -- needs to return the variables that are in scope for body the citizen check T ['Emb e] => e { synth e S From fd8590e7c43a92689ee206c7bb76c50087165d20 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Malin=20Altenm=C3=BCller?= Date: Fri, 7 Oct 2022 16:47:51 +0100 Subject: [PATCH 04/89] [ WIP ] more design for rules and judg(e)ments --- Src/Concrete/Base.hs | 18 +++++++++++ examples/stlcRules.act | 68 ++++++++++++++++++++++++++++-------------- 2 files changed, 63 insertions(+), 23 deletions(-) diff --git a/Src/Concrete/Base.hs b/Src/Concrete/Base.hs index f4543b9..51951a1 100644 --- a/Src/Concrete/Base.hs +++ b/Src/Concrete/Base.hs @@ -320,3 +320,21 @@ type CProtocol = Protocol Raw type CContextStack = ContextStack Raw type CActor = ACTOR Concrete type CScrutinee = SCRUTINEE Concrete + +{- +type family FORMULA (ph :: Phase) :: * +type instance FORMULA Concrete = Raw +type instance FORMULA Abstract = Term + +-- _=>_ should be a constructor of FORMULA? +-- a raw formula is an expression (and we might make it into a pattern later) +data JUDGEMENT (ph :: Phase) += Judgement (JUDGEMENTFORM ph) [FORMULA ph] + + +type RULE (ph :: Phase) = RULE + { premises :: [JUDGEMENT ph] + , conclusion :: JUDGEMENT ph + , + } +-} diff --git a/examples/stlcRules.act b/examples/stlcRules.act index e532742..dc741f1 100644 --- a/examples/stlcRules.act +++ b/examples/stlcRules.act @@ -42,9 +42,21 @@ myCtxt |- 'Synth -> 'Type -- Something that looks like "Z : A => B" says -- Z is an A when it's a subject, and a B when it becomes a citizen -{} type (T : 'Type => 'Type) {} {T - 'Value : 'Universe } -{type T} check T (t : 'Check => T - 'Value) {} {} -{} synth (t : 'Synth => T - 'Value) T {type T} {} +-- should it be 'judgementform'? +judgment + {} + type (T : 'Type => 'Type) + {T - 'Value : 'Universe} + +judgment + {type T} + check T (t : 'Check => T - 'Value) + {} + +judgment + {} + synth (t : 'Synth => T - 'Value) T + {type T} -- Open question in the above: will it always be the subject that's fed to an operator? -- Note: the "T - 'Value" is in 'Universe and that T is the citizen, not the subject @@ -56,51 +68,61 @@ myCtxt |- 'Synth -> 'Type -- We're giving semantic objects as annotations on derivations -- Proposal: => for citizenship -type 'Nat => 'Nat {} - { 'Nat - 'Value = 'Natural } +-- should it be 'derivation'? +rule + {} + type 'Nat => 'Nat + {'Nat - 'Value = 'Natural} -type ['Arr S T] => ['Arr S T] - { type S - | type T - } - -- Global assumption: 'Universe comes with Pi builtin - { ['Arr S T] - 'Value = ['Pi (S - 'Value) \_. (T - 'Value)] } +rule + {type S, type T} + ------------------------ + type ['Arr S T] => ['Arr S T] +-- Global assumption: 'Universe comes with Pi builtin + {['Arr S T] - 'Value = ['Pi (S - 'Value) \_. (T - 'Value)]} -- Invariant: the subject in a premiss is always something with a name -- payoff - the name BECOMES the name of the citizen --- ~['Arr S T] means to not match, but to constrain instead -check ~['Arr S T] ['Lam \x. body] => \x. body -- x is a hypothetical inhabitant of S - 'Value +rule + { \ x . synth x S |- check T body } + -- x is a hypothetical inhabitant of S - 'Value -- hypothetical judgement with fresh x, assuming `synth x S` -- (note hypothetical judgements have patterns in input and subject -- positions, and expressions in output positions) - { \ x . synth x S |- check T body } + check ~['Arr S T] ['Lam \x. body] => \x. body + -- ~['Arr S T] means to not match, but to constrain instead + {} -- Could equivalently be written without deliberate capture of x: -- { \ y . synth y S |- check T {x=y}body } -- note that if we use the above, then we'd expect to capture a y in S - 'Value in body the citizen -- the elaborator-check that body is used fully generally in the premiss subject -- needs to return the variables that are in scope for body the citizen -check T ['Emb e] => e +rule { synth e S - -- by the magic of STLC, things are first-order, this is just unification - | S ~ T + ; S ~ T -- by the magic of STLC, things are first-order, this is just unification } + check T ['Emb e] => e + {} -- first arg is a (subject) pattern position -- 2nd argument is in output position & we give the citizen T -- Note to selves: holy readability issues! -synth (['Ann t T] => t) T +rule { type T - | check T t + ; check T t } + synth (['Ann t T] => t) T + {} -synth (['App f s] => f -['app s]) T -- assuming citizen 'f' is meta-level function - -- irrefutable because of no overloading of application (in STLC) +rule { synth f ~['Arr S T] - | check S s + ; check S s } - + synth (['App f s] => f -['app s]) T -- assuming citizen 'f' is meta-level function + -- irrefutable because of no overloading of application (in STLC) + {} ------------------------------------------------------------------------------ From de5ea6ab51e27af39e0958917fd51dcb81472338 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Mon, 10 Oct 2022 16:35:01 +0100 Subject: [PATCH 05/89] [ WIP ] towards representing concrete and abstract rules --- Src/Command.hs | 6 ---- Src/Concrete/Base.hs | 27 ++++-------------- Src/Concrete/Parse.hs | 1 + Src/Elaboration/Monad.hs | 5 +--- Src/Machine/Base.hs | 56 +++++++++++++++++++++++------------- Src/Parse.hs | 9 ++++++ Src/Rules.hs | 61 ++++++++++++++++++++++++++++++++++++++++ typos.cabal | 2 ++ 8 files changed, 115 insertions(+), 52 deletions(-) create mode 100644 Src/Rules.hs diff --git a/Src/Command.hs b/Src/Command.hs index acf1917..3c3a029 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -44,15 +44,9 @@ type family PROTOCOL (ph :: Phase) :: * type instance PROTOCOL Concrete = () type instance PROTOCOL Abstract = AProtocol -type OPPATTERN ph = (OPERATOR ph, [PATTERN ph]) - data STATEMENT (ph :: Phase) = Statement (JUDGEMENTFORM ph) [Variable] -type family DEFNOP (ph :: Phase) :: * -type instance DEFNOP Concrete = (PATTERN Concrete, [OPPATTERN Concrete], TERM Concrete) -type instance DEFNOP Abstract = (Operator, Clause) - data COMMAND (ph :: Phase) = DeclJudge ExtractMode (JUDGEMENTFORM ph) (Protocol (SYNTAXDESC ph)) | DefnJudge (JUDGEMENTFORM ph, PROTOCOL ph, CHANNEL ph) (ACTOR ph) diff --git a/Src/Concrete/Base.hs b/Src/Concrete/Base.hs index 51951a1..bf1e002 100644 --- a/Src/Concrete/Base.hs +++ b/Src/Concrete/Base.hs @@ -1,14 +1,12 @@ {-# LANGUAGE UndecidableInstances #-} module Concrete.Base where +import Data.Function (on) + import Bwd import Format import Scope import Location -import Data.Function (on) - -data Operator = Operator { getOperator :: String } - deriving (Show, Eq) data Variable = Variable { variableLoc :: Range @@ -108,6 +106,7 @@ data RawP | LamP Range (Scope (Binder Variable) RawP) | ThP Range (Bwd Variable, ThDirective) RawP | UnderscoreP Range + | Irrefutable Range RawP deriving (Show) instance HasSetRange RawP where @@ -119,6 +118,7 @@ instance HasSetRange RawP where LamP _ sc -> LamP r sc ThP _ sg t -> ThP r sg t UnderscoreP _ -> UnderscoreP r + Irrefutable _ p -> Irrefutable r p instance HasGetRange RawP where getRange = \case @@ -129,6 +129,7 @@ instance HasGetRange RawP where LamP r sc -> r ThP r sg t -> r UnderscoreP r -> r + Irrefutable r p -> r data ThDirective = ThKeep | ThDrop deriving (Show) @@ -320,21 +321,3 @@ type CProtocol = Protocol Raw type CContextStack = ContextStack Raw type CActor = ACTOR Concrete type CScrutinee = SCRUTINEE Concrete - -{- -type family FORMULA (ph :: Phase) :: * -type instance FORMULA Concrete = Raw -type instance FORMULA Abstract = Term - --- _=>_ should be a constructor of FORMULA? --- a raw formula is an expression (and we might make it into a pattern later) -data JUDGEMENT (ph :: Phase) -= Judgement (JUDGEMENTFORM ph) [FORMULA ph] - - -type RULE (ph :: Phase) = RULE - { premises :: [JUDGEMENT ph] - , conclusion :: JUDGEMENT ph - , - } --} diff --git a/Src/Concrete/Parse.hs b/Src/Concrete/Parse.hs index 2e6cc13..8044083 100644 --- a/Src/Concrete/Parse.hs +++ b/Src/Concrete/Parse.hs @@ -85,6 +85,7 @@ ppat = withRange $ <|> pscoped LamP pbinder ppat <|> ThP unknown <$ pch (== '{') <* pspc <*> pth <* punc "}" <*> ppat <|> UnderscoreP unknown <$ pch (== '_') + <|> Irrefutable unknown <$ pch (== '~') <* pspc <*> ppat pth :: Parser (Bwd Variable, ThDirective) pth = (,) <$> ppes pspc pvariable diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 6cd234d..d12f564 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -21,6 +21,7 @@ import qualified Syntax import Thin (Selable(..), DB (..), CdB (..)) import Term.Base (Tm(..), atom) import Utils +import Machine.Base ------------------------------------------------------------------------------ -- Elaboration Monad @@ -251,10 +252,6 @@ turn t ds = ds { location = location ds :< t } ------------------------------------------------------------------------------ -- Operators -type family OPERATOR (ph :: Phase) :: * -type instance OPERATOR Concrete = WithRange String -type instance OPERATOR Abstract = Operator - data ANOPERATOR (ph :: Phase) = AnOperator { opName :: OPERATOR ph , objDesc :: SYNTAXDESC ph diff --git a/Src/Machine/Base.hs b/Src/Machine/Base.hs index 2241609..dddad38 100644 --- a/Src/Machine/Base.hs +++ b/Src/Machine/Base.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExistentialQuantification #-} - +{-# LANGUAGE UndecidableInstances #-} module Machine.Base where import Data.Map (Map) @@ -17,11 +17,13 @@ import Actor.Display() import Bwd import Format import Options +import Location (WithRange) import Term import qualified Term.Substitution as Substitution import Thin -import Concrete.Base (Root, Guard, ExtractMode, ACTOR (..), Operator(..)) +import Concrete.Base (Phase(..), Root, Guard, ExtractMode, TERM, PATTERN, ACTOR (..)) import Syntax (SyntaxDesc) + import Data.Bifunctor (Bifunctor(first)) import Machine.Matching @@ -289,24 +291,6 @@ toClause pobj (ops :< op) rhs opts hnf env targs@(t, args) = (t, Right mtch) -> first (t:) $ matches mtch ps ts matches mtch _ ts = (ts, Left Mismatch) -newtype Clause = Clause { runClause - :: Options - -> (Term -> Term) -- head normaliser - -> Env - -> (Term, [Term]) -- object & parameters - -> Either (Term, [Term]) Term } - -instance Semigroup Clause where - (<>) = mappend - -instance Monoid Clause where - mempty = Clause $ \ _ _ _ -> Left - mappend cl1 cl2 = Clause $ \ opts hd env ops -> case runClause cl2 opts hd env ops of - Left ops -> runClause cl1 opts hd env ops - Right t -> Right t - -instance Show Clause where - show _ = "" appClause :: Clause appClause = Clause $ \ opts hd env (t, args) -> @@ -375,3 +359,35 @@ tracing = fromMaybe [] . tracingOption . options instance (Show s, Show (t Frame)) => Show (Process log s t) where show (Process opts stack root env store actor _ geas) = unwords ["Process ", show opts, show stack, show root, show env, show store, show actor, show geas] + +data Operator = Operator { getOperator :: String } + deriving (Show, Eq) + +type family OPERATOR (ph :: Phase) :: * +type instance OPERATOR Concrete = WithRange String +type instance OPERATOR Abstract = Operator + +newtype Clause = Clause { runClause + :: Options + -> (Term -> Term) -- head normaliser + -> Env + -> (Term, [Term]) -- object & parameters + -> Either (Term, [Term]) Term } + +instance Semigroup Clause where + (<>) = mappend + +instance Monoid Clause where + mempty = Clause $ \ _ _ _ -> Left + mappend cl1 cl2 = Clause $ \ opts hd env ops -> case runClause cl2 opts hd env ops of + Left ops -> runClause cl1 opts hd env ops + Right t -> Right t + +instance Show Clause where + show _ = "" + +type OPPATTERN ph = (OPERATOR ph, [PATTERN ph]) + +type family DEFNOP (ph :: Phase) :: * +type instance DEFNOP Concrete = (PATTERN Concrete, [OPPATTERN Concrete], TERM Concrete) +type instance DEFNOP Abstract = (Operator, Clause) diff --git a/Src/Parse.hs b/Src/Parse.hs index 205d992..f57ad46 100644 --- a/Src/Parse.hs +++ b/Src/Parse.hs @@ -5,6 +5,7 @@ import Control.Monad import Data.Bifunctor import Data.Char +import Data.These import Data.Function import Bwd @@ -251,3 +252,11 @@ plisp = withRange $ mkNil <$ plit "]" <|> id <$ plit "|" <* pspc <*> pCar <* pspc <* plit "]" <|> mkCons <$> pCar <* pspc <*> plisp + +pthese :: Parser a -> Parser b -> Parser (These a b) +pthese pa pb = Parser $ \ i -> case (parser pa i, parser pb i) of + ((c, [(a, rest)]), (_, [])) -> (c, [(This a, rest)]) + ((_, []), (c, [(b, rest)])) -> (c, [(That b, rest)]) + ((c1, [(a, rest1)]), (c2, [(b, rest2)])) | location rest1 == location rest2 -> + (c1 <> c2, [(These a b, rest1)]) + ((c1, as), (c2, bs)) -> (c1 <> c2, [ (This a, rs) | (a, rs) <- as] ++ [ (That b, rs) | (b, rs) <- bs]) diff --git a/Src/Rules.hs b/Src/Rules.hs new file mode 100644 index 0000000..bb3dea4 --- /dev/null +++ b/Src/Rules.hs @@ -0,0 +1,61 @@ +module Rules where + +import Control.Applicative + +import Data.These + +import Actor +import Scope +import Concrete.Base +import Machine.Base (DEFNOP) +import Term.Base + +import Parse +import Location +import Concrete.Parse + +type family FORMULA (ph :: Phase) :: * +type instance FORMULA Concrete = CFormula +type instance FORMULA Abstract = AFormula + +data CFormula + = CFormula (These RawP Raw) -- we don't know if we need a pattern or term yet + | CCitizen RawP Raw -- pat => term + +data AFormula + = Coming Pat + | Going Term + | Citizen Pat Term -- pat => term + +-- _=>_ should be a constructor of FORMULA? +-- a raw formula is an expression (and we might make it into a pattern later) +data JUDGEMENT (ph :: Phase) + = Judgement (JUDGEMENTFORM ph) [FORMULA ph] + +data PREMISE (ph :: Phase) + = Premise (JUDGEMENT ph) + | Binding Range (Scope (Binder Variable) (PREMISE ph)) + | Hypothetical (JUDGEMENT ph) (PREMISE ph) + | Constraint (TERM ph) (TERM ph) + +data RULE (ph :: Phase) = RULE + { premises :: [PREMISE ph] + , conclusion :: JUDGEMENT ph + , operatorDefs :: [DEFNOP ph] + } + +pformula :: Parser CFormula +pformula = CCitizen <$> ppat <* punc "=>" <*> ptm + <|> CFormula <$> pthese ppat ptm + +pjudgement :: Parser (JUDGEMENT Concrete) +pjudgement = Judgement <$> pvariable <*> many (id <$ pspc <*> pformula) + +ppremise :: Parser (PREMISE Concrete) +ppremise = pscoped Binding pbinder ppremise + <|> (pjudgement >>= + \ j -> ((Hypothetical j <$ punc "|-" <*> ppremise) <|> (pure $ Premise j))) + <|> Constraint <$> ptm <* punc "~" <*> ptm + +prule :: Parser (RULE Concrete) +prule = undefined diff --git a/typos.cabal b/typos.cabal index 72a963b..bb7d9d3 100644 --- a/typos.cabal +++ b/typos.cabal @@ -60,6 +60,7 @@ library Pattern, Pattern.Coverage, Pretty, + Rules, Scope, Syntax, Syntax.Debug, @@ -80,6 +81,7 @@ library , optparse-applicative , pretty-compact , terminal-size + , these hs-source-dirs: Src default-language: Haskell2010 ghc-options: -Wunused-imports From 84aae7fa22e00662479ad7582a7812cde47d74ff Mon Sep 17 00:00:00 2001 From: Georgi Nakov Date: Mon, 10 Oct 2022 17:50:53 +0100 Subject: [PATCH 06/89] [ WIP ] towards parsing rules --- Src/Command.hs | 27 ++++++----------------- Src/Concrete/Base.hs | 3 ++- Src/Elaboration/Monad.hs | 15 ------------- Src/Machine/Base.hs | 46 +++++++++++++++++++++++++++++++++++++++- Src/Rules.hs | 31 +++++++++++++++++++++++---- examples/stlcRules.act | 23 +++++++++++--------- 6 files changed, 94 insertions(+), 51 deletions(-) diff --git a/Src/Command.hs b/Src/Command.hs index 3c3a029..b89bd2a 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -30,6 +30,7 @@ import Machine.Trace (Shots) import Options import Parse import Pretty +import Rules import Syntax import Term.Base import Unelaboration(Unelab(..), subunelab, withEnv, initDAEnv, Naming, declareChannel) @@ -58,6 +59,8 @@ data COMMAND (ph :: Phase) | Trace [MachineStep] | DeclOp [ANOPERATOR ph] | DefnOp (DEFNOP ph) + | DeclRule (RULE ph) + deriving instance ( Show (JUDGEMENTFORM ph) @@ -78,6 +81,7 @@ deriving instance , Show (PROTOCOL ph) , Show (LOOKEDUP ph) , Show (DEFNOP ph) + , Show (RULE ph) , Show (GUARD ph)) => Show (COMMAND ph) @@ -89,10 +93,6 @@ type CCommand = COMMAND Concrete type ACommand = COMMAND Abstract type CStatement = STATEMENT Concrete type AStatement = STATEMENT Abstract -type COpPattern = OPPATTERN Concrete -type AOpPattern = OPPATTERN Abstract -type COperator = OPERATOR Concrete -type AOperator = OPERATOR Abstract type CPattern = PATTERN Concrete type APattern = PATTERN Abstract @@ -175,20 +175,6 @@ pstatement = Statement <$> pvariable <*> many (id <$ pspc <*> pvariable) pconditions :: Parser [CStatement] pconditions = pcurlies (psep (punc ",") pstatement) -poperator :: Parser a -> Parser (WithRange String, [a]) -poperator ph = - (,[]) <$> pwithRange patom - <|> (,) <$ pch (== '[') <* pspc <*> pwithRange patom <*> many (id <$ pspc <*> ph) <* pspc <* pch (== ']') - -panoperator :: Parser CAnOperator -panoperator = do - obj <- psyntaxdecl - punc "-" - (opname, params) <- poperator psyntaxdecl - punc "~>" - ret <- psyntaxdecl - pure (AnOperator opname obj params ret) - pcommand :: Parser CCommand pcommand = DeclJudge <$> pextractmode <*> pvariable <* punc ":" <*> pprotocol @@ -202,8 +188,9 @@ pcommand <|> Go <$ plit "exec" <* pspc <*> pACT <|> Trace <$ plit "trace" <*> pcurlies (psep (punc ",") pmachinestep) <|> DeclOp <$ plit "operator" <*> pcurlies (psep (punc ";") panoperator) - <|> DefnOp <$> ((,,) <$> ppat <*> some (punc "-" *> poperator ppat) <* punc "~>" <*> pTM) - + <|> DefnOp <$> pdefnop + <|> DeclRule <$> prule + pfile :: Parser [CCommand] pfile = id <$ pspc <*> psep pspc pcommand <* pspc diff --git a/Src/Concrete/Base.hs b/Src/Concrete/Base.hs index bf1e002..2d5730f 100644 --- a/Src/Concrete/Base.hs +++ b/Src/Concrete/Base.hs @@ -154,13 +154,14 @@ data ExtractMode deriving (Show, Eq) data Keyword - = KwSyntax | KwExec | KwTrace + = KwSyntax |KwRule | KwExec | KwTrace | KwLet | KwCase | KwLookup | KwCompare | KwBREAK | KwPRINT | KwPRINTF deriving (Enum, Bounded) instance Show Keyword where show KwSyntax = "syntax" + show KwRule = "rule" show KwExec = "exec" show KwTrace = "trace" show KwLet = "let" diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index d12f564..c299e20 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -252,21 +252,6 @@ turn t ds = ds { location = location ds :< t } ------------------------------------------------------------------------------ -- Operators -data ANOPERATOR (ph :: Phase) = AnOperator - { opName :: OPERATOR ph - , objDesc :: SYNTAXDESC ph - , paramDescs :: [SYNTAXDESC ph] - , retDesc :: SYNTAXDESC ph - } - -deriving instance - ( Show (OPERATOR ph) - , Show (SYNTAXDESC ph) - ) => Show (ANOPERATOR ph) - -type CAnOperator = ANOPERATOR Concrete -type AAnOperator = ANOPERATOR Abstract - setOperators :: Operators -> Context -> Context setOperators ops ctx = ctx { operators = ops } diff --git a/Src/Machine/Base.hs b/Src/Machine/Base.hs index dddad38..162bb3f 100644 --- a/Src/Machine/Base.hs +++ b/Src/Machine/Base.hs @@ -10,6 +10,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Maybe import Control.Monad.State +import Control.Applicative import Actor import Actor.Display() @@ -21,7 +22,7 @@ import Location (WithRange) import Term import qualified Term.Substitution as Substitution import Thin -import Concrete.Base (Phase(..), Root, Guard, ExtractMode, TERM, PATTERN, ACTOR (..)) +import Concrete.Base (Phase(..), Root, Guard, ExtractMode, TERM, PATTERN, ACTOR (..), SYNTAXDESC) import Syntax (SyntaxDesc) import Data.Bifunctor (Bifunctor(first)) @@ -30,8 +31,11 @@ import Machine.Matching import Debug.Trace (trace) import Display (unsafeDocDisplayClosed) import ANSI hiding (withANSI) +import Parse +import Concrete.Parse import Pretty + newtype Date = Date Int deriving (Show, Eq, Ord, Num) @@ -360,6 +364,24 @@ instance (Show s, Show (t Frame)) => Show (Process log s t) where show (Process opts stack root env store actor _ geas) = unwords ["Process ", show opts, show stack, show root, show env, show store, show actor, show geas] +------------------------------------------------------------------------------ +-- Operators + +data ANOPERATOR (ph :: Phase) = AnOperator + { opName :: OPERATOR ph + , objDesc :: SYNTAXDESC ph + , paramDescs :: [SYNTAXDESC ph] + , retDesc :: SYNTAXDESC ph + } + +deriving instance + ( Show (OPERATOR ph) + , Show (SYNTAXDESC ph) + ) => Show (ANOPERATOR ph) + +type CAnOperator = ANOPERATOR Concrete +type AAnOperator = ANOPERATOR Abstract + data Operator = Operator { getOperator :: String } deriving (Show, Eq) @@ -391,3 +413,25 @@ type OPPATTERN ph = (OPERATOR ph, [PATTERN ph]) type family DEFNOP (ph :: Phase) :: * type instance DEFNOP Concrete = (PATTERN Concrete, [OPPATTERN Concrete], TERM Concrete) type instance DEFNOP Abstract = (Operator, Clause) + +pdefnop :: Parser (DEFNOP Concrete) +pdefnop = (,,) <$> ppat <*> some (punc "-" *> poperator ppat) <* punc "~>" <*> pTM + +type COpPattern = OPPATTERN Concrete +type AOpPattern = OPPATTERN Abstract +type COperator = OPERATOR Concrete +type AOperator = OPERATOR Abstract + +poperator :: Parser a -> Parser (WithRange String, [a]) +poperator ph = + (,[]) <$> pwithRange patom + <|> (,) <$ pch (== '[') <* pspc <*> pwithRange patom <*> many (id <$ pspc <*> ph) <* pspc <* pch (== ']') + +panoperator :: Parser CAnOperator +panoperator = do + obj <- psyntaxdecl + punc "-" + (opname, params) <- poperator psyntaxdecl + punc "~>" + ret <- psyntaxdecl + pure (AnOperator opname obj params ret) diff --git a/Src/Rules.hs b/Src/Rules.hs index bb3dea4..0c26aa7 100644 --- a/Src/Rules.hs +++ b/Src/Rules.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UndecidableInstances #-} module Rules where import Control.Applicative @@ -7,7 +8,7 @@ import Data.These import Actor import Scope import Concrete.Base -import Machine.Base (DEFNOP) +import Machine.Base (DEFNOP, pdefnop) import Term.Base import Parse @@ -21,11 +22,13 @@ type instance FORMULA Abstract = AFormula data CFormula = CFormula (These RawP Raw) -- we don't know if we need a pattern or term yet | CCitizen RawP Raw -- pat => term + deriving (Show) data AFormula = Coming Pat | Going Term | Citizen Pat Term -- pat => term + deriving (Show) -- _=>_ should be a constructor of FORMULA? -- a raw formula is an expression (and we might make it into a pattern later) @@ -44,9 +47,28 @@ data RULE (ph :: Phase) = RULE , operatorDefs :: [DEFNOP ph] } +deriving instance + ( Show (JUDGEMENTFORM ph) + , Show (FORMULA ph)) => + Show (JUDGEMENT ph) + +deriving instance + ( Show (JUDGEMENT ph) + , Show (TERM ph)) => + Show (PREMISE ph) + +deriving instance + ( Show (PREMISE ph) + , Show (JUDGEMENT ph) + , Show (DEFNOP ph)) => + Show (RULE ph) + pformula :: Parser CFormula -pformula = CCitizen <$> ppat <* punc "=>" <*> ptm +pformula = pcitizen <|> CFormula <$> pthese ppat ptm + where + pcitizen = pparens pcitizen + <|> CCitizen <$> ppat <* punc "=>" <*> ptm pjudgement :: Parser (JUDGEMENT Concrete) pjudgement = Judgement <$> pvariable <*> many (id <$ pspc <*> pformula) @@ -55,7 +77,8 @@ ppremise :: Parser (PREMISE Concrete) ppremise = pscoped Binding pbinder ppremise <|> (pjudgement >>= \ j -> ((Hypothetical j <$ punc "|-" <*> ppremise) <|> (pure $ Premise j))) - <|> Constraint <$> ptm <* punc "~" <*> ptm + <|> Constraint <$> ptm <* punc "=" <*> ptm prule :: Parser (RULE Concrete) -prule = undefined +prule = RULE <$ pkeyword KwRule <* pspc <*> pcurlies (psep (punc ";") ppremise) + <* pspc <*> pjudgement <* pspc <*> pcurlies (psep (punc ";") pdefnop) diff --git a/examples/stlcRules.act b/examples/stlcRules.act index dc741f1..400a91f 100644 --- a/examples/stlcRules.act +++ b/examples/stlcRules.act @@ -22,7 +22,7 @@ syntax -- we're calling in not-'Nat on purpose [['Succ 'Natural]] ] } -{- + ------------------------------------------------------------------------------ -- Judgement forms @@ -30,12 +30,11 @@ syntax -- we're calling in not-'Nat on purpose check : ?'Type. $'Check. synth : $'Synth. !'Type. -{- + -- | myCtxt maps synthesisable variables to types myCtxt |- 'Synth -> 'Type --} --} +{- ------------------------------------------------------------------------------ -- Judgement forms and their contracts @@ -62,6 +61,7 @@ judgment -- Note: the "T - 'Value" is in 'Universe and that T is the citizen, not the subject -- {} myCtxt |- x -> T {synth x T} +-} ------------------------------------------------------------------------------ -- Rules @@ -69,17 +69,19 @@ judgment -- Proposal: => for citizenship -- should it be 'derivation'? + rule {} type 'Nat => 'Nat - {'Nat - 'Value = 'Natural} + {'Nat - 'Value ~> 'Natural} + rule - {type S, type T} + {type S; type T} ------------------------ type ['Arr S T] => ['Arr S T] -- Global assumption: 'Universe comes with Pi builtin - {['Arr S T] - 'Value = ['Pi (S - 'Value) \_. (T - 'Value)]} + {['Arr S T] - 'Value ~> ['Pi (S - 'Value) \_. (T - 'Value)]} -- Invariant: the subject in a premiss is always something with a name -- payoff - the name BECOMES the name of the citizen @@ -90,7 +92,7 @@ rule -- hypothetical judgement with fresh x, assuming `synth x S` -- (note hypothetical judgements have patterns in input and subject -- positions, and expressions in output positions) - check ~['Arr S T] ['Lam \x. body] => \x. body + check ~['Arr S T] ['Lam \x. body] => (\x. body) -- ~['Arr S T] means to not match, but to constrain instead {} -- Could equivalently be written without deliberate capture of x: @@ -101,7 +103,7 @@ rule rule { synth e S - ; S ~ T -- by the magic of STLC, things are first-order, this is just unification + ; S = T -- by the magic of STLC, things are first-order, this is just unification } check T ['Emb e] => e {} @@ -109,6 +111,7 @@ rule -- first arg is a (subject) pattern position -- 2nd argument is in output position & we give the citizen T -- Note to selves: holy readability issues! + rule { type T ; check T t @@ -120,7 +123,7 @@ rule { synth f ~['Arr S T] ; check S s } - synth (['App f s] => f -['app s]) T -- assuming citizen 'f' is meta-level function + synth (['App f s] => (f -['app s])) T -- assuming citizen 'f' is meta-level function -- irrefutable because of no overloading of application (in STLC) {} From 39dc5e2568223c90678ae507de562cbab9ff0d03 Mon Sep 17 00:00:00 2001 From: Georgi Nakov Date: Wed, 19 Oct 2022 17:37:54 +0100 Subject: [PATCH 07/89] [ WIP ] judgement form parsing --- Src/Actor.hs | 4 ++-- Src/Command.hs | 31 +++++++++++++++++++++---------- Src/Concrete/Base.hs | 11 ++++++----- Src/Elaboration.hs | 2 +- Src/Machine/Base.hs | 10 +++++----- Src/Machine/Exec.hs | 2 +- Src/Machine/Trace.hs | 8 ++++---- Src/Parse.hs | 2 +- Src/Rules.hs | 41 ++++++++++++++++++++++++++++++++++++++--- Src/Unelaboration.hs | 6 +++--- TODO.md | 1 + examples/stlcRules.act | 17 ++++------------- 12 files changed, 87 insertions(+), 48 deletions(-) diff --git a/Src/Actor.hs b/Src/Actor.hs index 98fba02..6777bb9 100644 --- a/Src/Actor.hs +++ b/Src/Actor.hs @@ -33,10 +33,10 @@ newtype Stack = Stack { rawStack :: String } newtype Channel = Channel { rawChannel :: String } deriving (Show, Eq, Ord) -type JudgementForm = String +type JudgementName = String type Gripe = String -type instance JUDGEMENTFORM Abstract = JudgementForm +type instance JUDGEMENTNAME Abstract = JudgementName type instance CHANNEL Abstract = Channel type instance BINDER Abstract = (Binder ActorMeta) type instance ACTORVAR Abstract = ActorMeta diff --git a/Src/Command.hs b/Src/Command.hs index b89bd2a..4af573d 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -46,11 +46,11 @@ type instance PROTOCOL Concrete = () type instance PROTOCOL Abstract = AProtocol data STATEMENT (ph :: Phase) - = Statement (JUDGEMENTFORM ph) [Variable] + = Statement (JUDGEMENTNAME ph) [Variable] data COMMAND (ph :: Phase) - = DeclJudge ExtractMode (JUDGEMENTFORM ph) (Protocol (SYNTAXDESC ph)) - | DefnJudge (JUDGEMENTFORM ph, PROTOCOL ph, CHANNEL ph) (ACTOR ph) + = DeclJudge ExtractMode (JUDGEMENTNAME ph) (Protocol (SYNTAXDESC ph)) + | DefnJudge (JUDGEMENTNAME ph, PROTOCOL ph, CHANNEL ph) (ACTOR ph) | ContractJudge [STATEMENT ph] (STATEMENT ph) [STATEMENT ph] | DeclSyntax [(SYNTAXCAT ph, SYNTAXDESC ph)] | DeclStack (STACK ph) (ContextStack (SYNTAXDESC ph)) @@ -59,11 +59,12 @@ data COMMAND (ph :: Phase) | Trace [MachineStep] | DeclOp [ANOPERATOR ph] | DefnOp (DEFNOP ph) + | DeclJudgementForm (JUDGEMENTFORM ph) | DeclRule (RULE ph) - + deriving instance - ( Show (JUDGEMENTFORM ph) + ( Show (JUDGEMENTNAME ph) , Show (CHANNEL ph) , Show (BINDER ph) , Show (ACTORVAR ph) @@ -81,12 +82,13 @@ deriving instance , Show (PROTOCOL ph) , Show (LOOKEDUP ph) , Show (DEFNOP ph) + , Show (JUDGEMENTFORM ph) , Show (RULE ph) , Show (GUARD ph)) => Show (COMMAND ph) deriving instance - (Show (JUDGEMENTFORM ph)) => + (Show (JUDGEMENTNAME ph)) => Show (STATEMENT ph) type CCommand = COMMAND Concrete @@ -112,6 +114,12 @@ instance (Show t, Unelab t, Pretty (Unelabed t)) => instance Pretty CStatement where pretty (Statement jd vars) = hsep $ pretty jd : (pretty <$> vars) + +instance Pretty (PLACE Concrete) where + pretty (CitizenPlace v) = pretty v + pretty (SubjectPlace v syntaxdesc semanticsdesc) = + parens (hsep $ [pretty v, ":", pretty syntaxdesc] + ++ foldMap (("=>":) . (:[]) . pretty) semanticsdesc) instance Pretty CCommand where pretty = let prettyCds cds = collapse (BracesList $ pretty <$> cds) in \case @@ -126,7 +134,9 @@ instance Pretty CCommand where , prettyCds posts] Go a -> keyword "exec" <+> pretty a Trace ts -> keyword "trace" <+> collapse (BracesList $ map pretty ts) - + -- DeclJudgementForm j -> keyword "judgementform" <+> collapse (BracesList $ pretty <$> jpreconds j) + -- <+> hsep (pretty (jname j) : map pretty (jplaces j)) + -- <+> collapse (BracesList $ either pretty pretty <$> jpostconds j) instance Unelab ACommand where type UnelabEnv ACommand = Naming @@ -180,15 +190,16 @@ pcommand = DeclJudge <$> pextractmode <*> pvariable <* punc ":" <*> pprotocol <|> DefnJudge <$> pjudgeat <* punc "=" <*> pACT <|> ContractJudge <$> pconditions <* pspc <*> pstatement <* pspc <*> pconditions - <|> DeclSyntax <$ plit "syntax" <*> pcurlies (psep (punc ";") psyntax) + <|> DeclSyntax <$ plit "syntax" <* pspc <*> pcurlies (psep (punc ";") psyntax) <|> DeclStack <$> pvariable <* punc "|-" <*> pcontextstack <|> ContractStack <$> pconditions <* pspc <*> ((,,) <$> pvariable <* punc "|-" <*> pvariable <* punc "->" <*> pvariable) <* pspc <*> pconditions <|> Go <$ plit "exec" <* pspc <*> pACT - <|> Trace <$ plit "trace" <*> pcurlies (psep (punc ",") pmachinestep) - <|> DeclOp <$ plit "operator" <*> pcurlies (psep (punc ";") panoperator) + <|> Trace <$ plit "trace" <* pspc <*> pcurlies (psep (punc ",") pmachinestep) + <|> DeclOp <$ plit "operator" <* pspc <*> pcurlies (psep (punc ";") (panoperator "~>")) <|> DefnOp <$> pdefnop + <|> DeclJudgementForm <$> pjudgementform <|> DeclRule <$> prule pfile :: Parser [CCommand] diff --git a/Src/Concrete/Base.hs b/Src/Concrete/Base.hs index 2d5730f..c0b909b 100644 --- a/Src/Concrete/Base.hs +++ b/Src/Concrete/Base.hs @@ -154,7 +154,7 @@ data ExtractMode deriving (Show, Eq) data Keyword - = KwSyntax |KwRule | KwExec | KwTrace + = KwSyntax | KwRule | KwJudgementForm | KwExec | KwTrace | KwLet | KwCase | KwLookup | KwCompare | KwBREAK | KwPRINT | KwPRINTF deriving (Enum, Bounded) @@ -162,6 +162,7 @@ data Keyword instance Show Keyword where show KwSyntax = "syntax" show KwRule = "rule" + show KwJudgementForm = "judgementform" show KwExec = "exec" show KwTrace = "trace" show KwLet = "let" @@ -174,7 +175,7 @@ instance Show Keyword where data Phase = Concrete | Elaboration | Abstract -type family JUDGEMENTFORM (ph :: Phase) :: * +type family JUDGEMENTNAME (ph :: Phase) :: * type family CHANNEL (ph :: Phase) :: * type family BINDER (ph :: Phase) :: * type family ACTORVAR (ph :: Phase) :: * @@ -190,7 +191,7 @@ type family SCRUTINEETERM (ph :: Phase) :: * type family LOOKEDUP (ph :: Phase) :: * type family GUARD (ph :: Phase) :: * -type instance JUDGEMENTFORM Concrete = Variable +type instance JUDGEMENTNAME Concrete = Variable type instance CHANNEL Concrete = Variable type instance BINDER Concrete = RawP type instance ACTORVAR Concrete = Variable @@ -233,7 +234,7 @@ instance HasGetRange (SCRUTINEE ph) where data ACTOR (ph :: Phase) = Branch Range (ACTOR ph) (ACTOR ph) - | Spawn Range ExtractMode (JUDGEMENTFORM ph) (CHANNEL ph) (ACTOR ph) + | Spawn Range ExtractMode (JUDGEMENTNAME ph) (CHANNEL ph) (ACTOR ph) | Send Range (CHANNEL ph) (GUARD ph) (TERM ph) (ACTOR ph) | Recv Range (CHANNEL ph) (BINDER ph, ACTOR ph) | Connect Range (CONNECT ph) @@ -259,7 +260,7 @@ deriving instance Show (SCRUTINEE ph) deriving instance - ( Show (JUDGEMENTFORM ph) + ( Show (JUDGEMENTNAME ph) , Show (CHANNEL ph) , Show (BINDER ph) , Show (ACTORVAR ph) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 213a9cf..c3d901c 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -414,7 +414,7 @@ isOperator r nm = do data IsJudgement = IsJudgement { judgementExtract :: ExtractMode - , judgementName :: JudgementForm + , judgementName :: JudgementName , judgementProtocol :: AProtocol } diff --git a/Src/Machine/Base.hs b/Src/Machine/Base.hs index 162bb3f..8986c10 100644 --- a/Src/Machine/Base.hs +++ b/Src/Machine/Base.hs @@ -197,7 +197,7 @@ data Hole = Hole deriving Show data Interface c p = Interface { spawnee :: (c, Channel) , spawner :: ((Channel, [String]), p) - , judgeName :: JudgementForm + , judgeName :: JudgementName , judgeProtocol :: AProtocol , extractionMode :: ExtractMode , traffic :: Bwd Term @@ -310,7 +310,7 @@ tickClause = Clause $ \ opts hd env (t, args) -> case args of _ -> Left (t, args) data Frame - = Rules JudgementForm AProtocol (Channel, AActor) + = Rules JudgementName AProtocol (Channel, AActor) | LeftBranch Hole (Process () Status []) | RightBranch (Process () Status []) Hole | Spawnee (Interface Hole (Process () Status [])) @@ -427,11 +427,11 @@ poperator ph = (,[]) <$> pwithRange patom <|> (,) <$ pch (== '[') <* pspc <*> pwithRange patom <*> many (id <$ pspc <*> ph) <* pspc <* pch (== ']') -panoperator :: Parser CAnOperator -panoperator = do +panoperator :: String -> Parser CAnOperator +panoperator copula = do obj <- psyntaxdecl punc "-" (opname, params) <- poperator psyntaxdecl - punc "~>" + punc copula ret <- psyntaxdecl pure (AnOperator opname obj params ret) diff --git a/Src/Machine/Exec.hs b/Src/Machine/Exec.hs index 652f7f0..ace36e1 100644 --- a/Src/Machine/Exec.hs +++ b/Src/Machine/Exec.hs @@ -36,7 +36,7 @@ import Debug.Trace dmesg = trace -lookupRules :: JudgementForm -> Bwd Frame -> Maybe (AProtocol, (Channel, AActor)) +lookupRules :: JudgementName -> Bwd Frame -> Maybe (AProtocol, (Channel, AActor)) lookupRules jd zf = do (_, cha, _) <- (`focusBy` zf) $ \case Rules jd' p cha | jd == jd' -> Just (p, cha) diff --git a/Src/Machine/Trace.hs b/Src/Machine/Trace.hs index 057f099..986b0d3 100644 --- a/Src/Machine/Trace.hs +++ b/Src/Machine/Trace.hs @@ -15,7 +15,7 @@ import qualified Data.Set as Set import Data.Maybe (fromMaybe) import ANSI (Colour(..), Layer(..), Annotation(..)) -import Actor (JudgementForm) +import Actor (JudgementName) import Bwd (Bwd(..), (<>>), (<><)) import Concrete.Base import Concrete.Pretty() @@ -86,7 +86,7 @@ data STEP (ph :: Phase) f ann = BindingStep Variable | NotedStep | PushingStep (STACK ph) (TERMVAR ph) (SyntaxDesc, f (ITERM ph) ann) - | CallingStep (f () (ann, Bool)) (JUDGEMENTFORM ph) [ARGUMENT ph f ann] + | CallingStep (f () (ann, Bool)) (JUDGEMENTNAME ph) [ARGUMENT ph f ann] deriving instance ( Functor (f (ITERM ph)) @@ -440,7 +440,7 @@ cleanup :: [ATrace f ann] -> [ATrace f ann] cleanup = snd . go False [] where go :: Bool -- ^ is the parent suppressable? - -> [JudgementForm] -- ^ list of toplevel judgements already seen + -> [JudgementName] -- ^ list of toplevel judgements already seen -> [ATrace f ann] -> (Any, [ATrace f ann]) go supp seen [] = pure [] go supp seen (Node a (AStep em i@(CallingStep b jd tr)) ts : ats) @@ -640,7 +640,7 @@ combineArg (Argument mode0 desc0 term0) (Argument mode1 desc1 term1) | otherwise = error "Impossible" combineStep :: Eq (STACK ph) - => Eq (JUDGEMENTFORM ph) + => Eq (JUDGEMENTNAME ph) => Eq (TERMVAR ph) => STEP ph Simple ann -> STEP ph Series ann diff --git a/Src/Parse.hs b/Src/Parse.hs index f57ad46..1a95c5b 100644 --- a/Src/Parse.hs +++ b/Src/Parse.hs @@ -28,7 +28,7 @@ pparens :: Parser a -> Parser a pparens p = id <$ pch (== '(') <* pspc <*> p <* pspc <* plit ")" pcurlies :: Parser a -> Parser a -pcurlies p = id <$ punc "{" <*> p <* pspc <* plit "}" +pcurlies p = id <$ plit "{" <* pspc <*> p <* pspc <* plit "}" pstring :: Parser String pstring = Parser $ \ (Source str loc) -> case str of diff --git a/Src/Rules.hs b/Src/Rules.hs index 0c26aa7..f4c2aef 100644 --- a/Src/Rules.hs +++ b/Src/Rules.hs @@ -8,7 +8,7 @@ import Data.These import Actor import Scope import Concrete.Base -import Machine.Base (DEFNOP, pdefnop) +import Machine.Base (DEFNOP, ANOPERATOR, pdefnop, panoperator) import Term.Base import Parse @@ -33,7 +33,7 @@ data AFormula -- _=>_ should be a constructor of FORMULA? -- a raw formula is an expression (and we might make it into a pattern later) data JUDGEMENT (ph :: Phase) - = Judgement (JUDGEMENTFORM ph) [FORMULA ph] + = Judgement (JUDGEMENTNAME ph) [FORMULA ph] data PREMISE (ph :: Phase) = Premise (JUDGEMENT ph) @@ -47,8 +47,21 @@ data RULE (ph :: Phase) = RULE , operatorDefs :: [DEFNOP ph] } +type SEMANTICSDESC (ph :: Phase) = TERM ph + +data PLACE (ph :: Phase) + = CitizenPlace Variable + | SubjectPlace Variable (SYNTAXDESC ph) (Maybe (SEMANTICSDESC ph)) + +data JUDGEMENTFORM (ph :: Phase) = JudgementForm + { jpreconds :: [JUDGEMENT ph] + , jname :: JUDGEMENTNAME ph + , jplaces :: [PLACE ph] + , jpostconds :: [Either (JUDGEMENT ph) (ANOPERATOR ph)] + } + deriving instance - ( Show (JUDGEMENTFORM ph) + ( Show (JUDGEMENTNAME ph) , Show (FORMULA ph)) => Show (JUDGEMENT ph) @@ -63,6 +76,18 @@ deriving instance , Show (DEFNOP ph)) => Show (RULE ph) +deriving instance + ( Show (SYNTAXDESC ph) + , Show (SEMANTICSDESC ph)) => + Show (PLACE ph) + +deriving instance + ( Show (JUDGEMENT ph) + , Show (JUDGEMENTNAME ph) + , Show (PLACE ph) + , Show (ANOPERATOR ph)) => + Show (JUDGEMENTFORM ph) + pformula :: Parser CFormula pformula = pcitizen <|> CFormula <$> pthese ppat ptm @@ -82,3 +107,13 @@ ppremise = pscoped Binding pbinder ppremise prule :: Parser (RULE Concrete) prule = RULE <$ pkeyword KwRule <* pspc <*> pcurlies (psep (punc ";") ppremise) <* pspc <*> pjudgement <* pspc <*> pcurlies (psep (punc ";") pdefnop) + +pplace :: Parser (PLACE Concrete) +pplace = CitizenPlace <$> pvariable + <|> pparens (SubjectPlace <$> pvariable <* punc ":" <*> psyntaxdecl <*> optional (id <$ punc "=>" <*> pTM)) + +pjudgementform :: Parser (JUDGEMENTFORM Concrete) +pjudgementform = JudgementForm <$ pkeyword KwJudgementForm <* pspc <*> pcurlies (psep (punc ";") pjudgement) + <* pspc <*> pvariable + <* pspc <*> psep pspc pplace + <* pspc <*> pcurlies (psep (punc ";") (Left <$> pjudgement <|> Right <$> panoperator ":")) diff --git a/Src/Unelaboration.hs b/Src/Unelaboration.hs index 313f6cb..1546186 100644 --- a/Src/Unelaboration.hs +++ b/Src/Unelaboration.hs @@ -223,9 +223,9 @@ instance Unelab Stack where type Unelabed Stack = Variable unelab (Stack str) = pure (Variable unknown str) -instance Unelab JudgementForm where - type UnelabEnv JudgementForm = () - type Unelabed JudgementForm = Variable +instance Unelab JudgementName where + type UnelabEnv JudgementName = () + type Unelabed JudgementName = Variable unelab str = pure (Variable unknown str) instance Unelab Debug where diff --git a/TODO.md b/TODO.md index a824819..cd11b4c 100644 --- a/TODO.md +++ b/TODO.md @@ -87,6 +87,7 @@ * [ ] Define `ElaborationMonad m =>` & cleanup sclause * [ ] Drop run-length encoding subst in favour of relevant subst * [ ] Match monad for Matching (Env in a state) +* [ ] `keyword` pretty printing should use the data type of keywords ### Pretty diff --git a/examples/stlcRules.act b/examples/stlcRules.act index 400a91f..efa32a5 100644 --- a/examples/stlcRules.act +++ b/examples/stlcRules.act @@ -34,25 +34,24 @@ synth : $'Synth. !'Type. -- | myCtxt maps synthesisable variables to types myCtxt |- 'Synth -> 'Type -{- + ------------------------------------------------------------------------------ -- Judgement forms and their contracts -- Something that looks like "Z : A => B" says -- Z is an A when it's a subject, and a B when it becomes a citizen --- should it be 'judgementform'? -judgment +judgementform {} type (T : 'Type => 'Type) {T - 'Value : 'Universe} -judgment +judgementform {type T} check T (t : 'Check => T - 'Value) {} -judgment +judgementform {} synth (t : 'Synth => T - 'Value) T {type T} @@ -61,14 +60,6 @@ judgment -- Note: the "T - 'Value" is in 'Universe and that T is the citizen, not the subject -- {} myCtxt |- x -> T {synth x T} --} - ------------------------------------------------------------------------------- --- Rules --- We're giving semantic objects as annotations on derivations --- Proposal: => for citizenship - --- should it be 'derivation'? rule {} From 65ce92b8c35fc0ec7cd92234bf6b303a72442db0 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Fri, 21 Oct 2022 17:55:12 +0100 Subject: [PATCH 08/89] [ WIP ] elaborating judgement form declations --- Src/Command.hs | 36 ++++++++++++++++++++++++++++++++---- Src/Concrete/Base.hs | 1 + Src/Elaboration/Monad.hs | 9 ++++++++- Src/Elaboration/Pretty.hs | 14 +++++++++++++- Src/Location.hs | 2 +- Src/Parse.hs | 2 +- Src/Rules.hs | 37 +++++++++++++++++++++++-------------- Src/Utils.hs | 17 +++++++++++++++++ emacs/typos.el | 2 +- examples/stlcRules.act | 8 ++++---- 10 files changed, 101 insertions(+), 27 deletions(-) diff --git a/Src/Command.hs b/Src/Command.hs index 4af573d..5578353 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -11,6 +11,7 @@ import Data.Bifunctor (first) import qualified Data.Map as Map import Data.Maybe (fromMaybe) import Data.Traversable (for) +import Data.These import Actor import Actor.Display () @@ -35,6 +36,8 @@ import Syntax import Term.Base import Unelaboration(Unelab(..), subunelab, withEnv, initDAEnv, Naming, declareChannel) import Location +import Utils + import Data.Char (isSpace) type family SYNTAXCAT (ph :: Phase) :: * @@ -114,10 +117,10 @@ instance (Show t, Unelab t, Pretty (Unelabed t)) => instance Pretty CStatement where pretty (Statement jd vars) = hsep $ pretty jd : (pretty <$> vars) - + instance Pretty (PLACE Concrete) where - pretty (CitizenPlace v) = pretty v - pretty (SubjectPlace v syntaxdesc semanticsdesc) = + pretty (v, CitizenPlace) = pretty v + pretty (v, SubjectPlace syntaxdesc semanticsdesc) = parens (hsep $ [pretty v, ":", pretty syntaxdesc] ++ foldMap (("=>":) . (:[]) . pretty) semanticsdesc) @@ -201,7 +204,7 @@ pcommand <|> DefnOp <$> pdefnop <|> DeclJudgementForm <$> pjudgementform <|> DeclRule <$> prule - + pfile :: Parser [CCommand] pfile = id <$ pspc <*> psep pspc pcommand <* pspc @@ -327,6 +330,31 @@ scommand = \case -- trace (unwords [getOperator op, "-[", '\'':show p, show opargs, "~>", show rhs]) (pure ()) let cl = Clause (toClause p (B0 <>< opargs) rhs) (DefnOp (op, cl),) <$> asks globals + DeclJudgementForm j -> do + (j , gs) <- sjudgementform j + pure (DeclJudgementForm j, gs) + +sjudgementform :: JUDGEMENTFORM Concrete -> Elab (JUDGEMENTFORM Abstract, Globals) +sjudgementform JudgementForm{..} = do + inputs <- concat <$> traverse subjects jpreconds -- TODO: should really be the closure of this info + outputs <- concat <$> traverse subjects [ x | Left x <- jpostconds ] + let names = map fst jplaces + whenLeft (allUnique names) $ \ a -> throwError $ DuplicatedPlace (getRange a) a + undefined -- TODO + -- judgementDecls <- fst <$> asks globals + where + subjects :: JUDGEMENT Concrete -> Elab [Variable] + subjects (Judgement r name fms) = do + IsJudgement{..} <- isJudgement name + xs <- case halfZip judgementProtocol fms of + Just xs -> pure xs + Nothing -> throwError $ JudgementWrongArity r judgementName judgementProtocol fms + let ys = [ fm | ((Subject, _), fm) <- xs ] + forM ys $ \case + -- TODO: should use something like `isSendableSubject` + CFormula (These _ (Var r x)) -> pure x + x -> throwError $ UnexpectedNonSubject r x + -- | sopargs desc cops -- | desc: description of the object the cops are applied to diff --git a/Src/Concrete/Base.hs b/Src/Concrete/Base.hs index c0b909b..e5561b6 100644 --- a/Src/Concrete/Base.hs +++ b/Src/Concrete/Base.hs @@ -14,6 +14,7 @@ data Variable = Variable } instance Show Variable where show = show . getVariable instance Eq Variable where (==) = (==) `on` getVariable +instance Ord Variable where compare = compare `on` getVariable instance HasSetRange Variable where setRange r (Variable _ v) = Variable r v diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index c299e20..ea18b8a 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -12,7 +12,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe) -import Actor (ActorVar, AContextStack, AProtocol, Channel) +import Actor (ActorVar, AContextStack, AProtocol, Channel, JudgementName) import Bwd import Concrete.Base import Location (HasGetRange(..), Range, WithRange (..)) @@ -22,6 +22,7 @@ import Thin (Selable(..), DB (..), CdB (..)) import Term.Base (Tm(..), atom) import Utils import Machine.Base +import Rules ------------------------------------------------------------------------------ -- Elaboration Monad @@ -379,6 +380,9 @@ data Complaint | ProtocolsNotDual Range AProtocol AProtocol | IncompatibleModes Range (Mode, SyntaxDesc) (Mode, SyntaxDesc) | WrongDirection Range (Mode, SyntaxDesc) Ordering (Mode, SyntaxDesc) + | JudgementWrongArity Range JudgementName AProtocol [CFormula] + | UnexpectedNonSubject Range CFormula + | DuplicatedPlace Range Variable -- syntaxes | AlreadyDeclaredSyntaxCat Range SyntaxCat -- syntaxdesc validation @@ -432,6 +436,9 @@ instance HasGetRange Complaint where ProtocolsNotDual r _ _ -> r IncompatibleModes r _ _ -> r WrongDirection r _ _ _ -> r + JudgementWrongArity r _ _ _ -> r + UnexpectedNonSubject r _ -> r + -- syntaxes AlreadyDeclaredSyntaxCat r _ -> r -- syntaxdesc validation diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index 3556f48..c93f4dc 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -3,6 +3,7 @@ module Elaboration.Pretty where import Data.Foldable +import Data.These import ANSI hiding (withANSI) import Actor (ActorMeta(..), Channel(..), Stack(..)) @@ -14,6 +15,7 @@ import Pretty import Syntax import Unelaboration (unsafeEvalUnelab, unelab, initNaming) import Data.List.NonEmpty (NonEmpty((:|))) +import Rules instance Pretty Range where pretty r | r == unknown = "" @@ -50,6 +52,10 @@ instance Pretty ObjVar where instance Pretty (Mode, SyntaxDesc) where pretty (m, desc) = hsep [ pretty m, prettyPrec 1 desc ] +instance Pretty CFormula where + pretty (CFormula a) = these pretty pretty (const pretty) a + pretty (CCitizen p t) = hsep [pretty p, "=>", pretty t] + instance Pretty Warning where pretty w = (withANSI [ SetColour Background Yellow ] "Warning:" <+> pretty (getRange w)) $$ go w where @@ -146,9 +152,15 @@ instance Pretty Complaint where IncompatibleChannelScopes r sc1 sc2 -> hsep [ "Channels scopes", collapse (pretty <$> sc1) , "and", collapse (pretty <$> sc2), "are incompatible"] + WrongDirection r m1 dir m2 -> hsep ["Wrong direction", pretty (show dir), "between", pretty m1, "and", pretty m2] + JudgementWrongArity r name protocol fms -> + let applied = (if length protocol > length fms then "under" else "over") <> "-applied" in + hsep ["Judgement", pretty name, applied] + UnexpectedNonSubject r fm -> hsep ["Unexpected non-subject", pretty fm] + DuplicatedPlace r v -> hsep ["Duplicated place", pretty v] -- syntaxes AlreadyDeclaredSyntaxCat r x -> hsep ["The syntactic category", pretty x, "is already defined"] - WrongDirection r m1 dir m2 -> hsep ["Wrong direction", pretty (show dir), "between", pretty m1, "and", pretty m2] + -- syntaxdesc validation InconsistentSyntaxDesc r -> "Inconsistent syntactic descriptions" InvalidSyntaxDesc r d -> hsep ["Invalid syntax desc", pretty d] diff --git a/Src/Location.hs b/Src/Location.hs index 63f2c2b..c9cf14b 100644 --- a/Src/Location.hs +++ b/Src/Location.hs @@ -63,7 +63,7 @@ type HasRange t = (HasSetRange t, HasGetRange t) fromLocations :: Location -> Location -> Range fromLocations s e = Range (file s) (row s, col s) (row e, col e) -addRange :: HasRange t => Location -> Location -> t -> t +addRange :: HasSetRange t => Location -> Location -> t -> t addRange s e = setRange (fromLocations s e) unknown :: Range diff --git a/Src/Parse.hs b/Src/Parse.hs index 1a95c5b..e3e62cb 100644 --- a/Src/Parse.hs +++ b/Src/Parse.hs @@ -181,7 +181,7 @@ notHere loc = (Candidate B0 loc, []) ploc :: Parser Location ploc = Parser $ \ i@(Source str loc) -> here (loc, i) -withRange :: HasRange t => Parser t -> Parser t +withRange :: HasSetRange t => Parser t -> Parser t withRange p = do start <- ploc x <- p diff --git a/Src/Rules.hs b/Src/Rules.hs index f4c2aef..6f66534 100644 --- a/Src/Rules.hs +++ b/Src/Rules.hs @@ -21,7 +21,7 @@ type instance FORMULA Abstract = AFormula data CFormula = CFormula (These RawP Raw) -- we don't know if we need a pattern or term yet - | CCitizen RawP Raw -- pat => term + | CCitizen RawP Raw -- (pat => term) deriving (Show) data AFormula @@ -33,7 +33,10 @@ data AFormula -- _=>_ should be a constructor of FORMULA? -- a raw formula is an expression (and we might make it into a pattern later) data JUDGEMENT (ph :: Phase) - = Judgement (JUDGEMENTNAME ph) [FORMULA ph] + = Judgement Range (JUDGEMENTNAME ph) [FORMULA ph] + +instance HasSetRange (JUDGEMENT ph) where + setRange r (Judgement _ n fms) = Judgement r n fms data PREMISE (ph :: Phase) = Premise (JUDGEMENT ph) @@ -49,17 +52,23 @@ data RULE (ph :: Phase) = RULE type SEMANTICSDESC (ph :: Phase) = TERM ph -data PLACE (ph :: Phase) - = CitizenPlace Variable - | SubjectPlace Variable (SYNTAXDESC ph) (Maybe (SEMANTICSDESC ph)) +type PLACE (ph :: Phase) = (Variable, PLACEKIND ph) + +data PLACEKIND (ph :: Phase) + = CitizenPlace + | SubjectPlace (SYNTAXDESC ph) (Maybe (SEMANTICSDESC ph)) data JUDGEMENTFORM (ph :: Phase) = JudgementForm - { jpreconds :: [JUDGEMENT ph] + { jrange :: Range + , jpreconds :: [JUDGEMENT ph] , jname :: JUDGEMENTNAME ph , jplaces :: [PLACE ph] - , jpostconds :: [Either (JUDGEMENT ph) (ANOPERATOR ph)] + , jpostconds :: [Either (JUDGEMENT ph) (ANOPERATOR ph)] } - + +instance HasSetRange (JUDGEMENTFORM ph) where + setRange r (JudgementForm _ a b c d) = JudgementForm r a b c d + deriving instance ( Show (JUDGEMENTNAME ph) , Show (FORMULA ph)) => @@ -79,7 +88,7 @@ deriving instance deriving instance ( Show (SYNTAXDESC ph) , Show (SEMANTICSDESC ph)) => - Show (PLACE ph) + Show (PLACEKIND ph) deriving instance ( Show (JUDGEMENT ph) @@ -96,7 +105,7 @@ pformula = pcitizen <|> CCitizen <$> ppat <* punc "=>" <*> ptm pjudgement :: Parser (JUDGEMENT Concrete) -pjudgement = Judgement <$> pvariable <*> many (id <$ pspc <*> pformula) +pjudgement = withRange $ Judgement unknown <$> pvariable <*> many (id <$ pspc <*> pformula) ppremise :: Parser (PREMISE Concrete) ppremise = pscoped Binding pbinder ppremise @@ -106,14 +115,14 @@ ppremise = pscoped Binding pbinder ppremise prule :: Parser (RULE Concrete) prule = RULE <$ pkeyword KwRule <* pspc <*> pcurlies (psep (punc ";") ppremise) - <* pspc <*> pjudgement <* pspc <*> pcurlies (psep (punc ";") pdefnop) + <* pspc <*> pjudgement <* pspc <*> pcurlies (psep (punc ";") pdefnop) pplace :: Parser (PLACE Concrete) -pplace = CitizenPlace <$> pvariable - <|> pparens (SubjectPlace <$> pvariable <* punc ":" <*> psyntaxdecl <*> optional (id <$ punc "=>" <*> pTM)) +pplace = (,CitizenPlace) <$> pvariable + <|> pparens ((,) <$> pvariable <* punc ":" <*> (SubjectPlace <$> psyntaxdecl <*> optional (id <$ punc "=>" <*> pTM))) pjudgementform :: Parser (JUDGEMENTFORM Concrete) -pjudgementform = JudgementForm <$ pkeyword KwJudgementForm <* pspc <*> pcurlies (psep (punc ";") pjudgement) +pjudgementform = withRange $ JudgementForm unknown <$ pkeyword KwJudgementForm <* pspc <*> pcurlies (psep (punc ";") pjudgement) <* pspc <*> pvariable <* pspc <*> psep pspc pplace <* pspc <*> pcurlies (psep (punc ";") (Left <$> pjudgement <|> Right <$> panoperator ":")) diff --git a/Src/Utils.hs b/Src/Utils.hs index 2eaf866..50e0f0e 100644 --- a/Src/Utils.hs +++ b/Src/Utils.hs @@ -1,5 +1,8 @@ module Utils where +import Data.Set (Set) +import qualified Data.Set as Set + import Control.Monad.State isAllJustBy :: [a] -> (a -> Maybe b) -> Either a [b] @@ -38,3 +41,17 @@ instance Semigroup m => Semigroup (State s m) where instance Monoid m => Monoid (State s m) where mempty = pure mempty + +class HalfZip f where + halfZip :: f x -> f y -> Maybe (f (x, y)) + +instance HalfZip [] where + halfZip [] [] = Just [] + halfZip (x:xs) (y:ys) = ((x,y):) <$> halfZip xs ys + halfZip _ _ = Nothing + +allUnique :: (Ord a, Foldable f) => f a -> Either a (Set a) +allUnique = flip foldr (pure Set.empty) $ \ a acc -> do + s <- acc + if a `Set.member` s then Left a else Right (Set.insert a s) + diff --git a/emacs/typos.el b/emacs/typos.el index cb16144..8e400cb 100644 --- a/emacs/typos.el +++ b/emacs/typos.el @@ -3,7 +3,7 @@ ;; based on: http://ergoemacs.org/emacs/elisp_syntax_coloring.html ;; define several class of keywords -(setq typos-keywords '("syntax" "operator" "exec" "trace" +(setq typos-keywords '("syntax" "operator" "exec" "trace" "rule" "judgementform" "break" "unify" "send" "recv" "move" "case" "let" "Atom" "AtomBar" "Wildcard" "EnumOrTag" "Enum" "Tag" "Cons" "Nil" "NilOrCons" "Fix" "Bind" diff --git a/examples/stlcRules.act b/examples/stlcRules.act index efa32a5..70aaa9a 100644 --- a/examples/stlcRules.act +++ b/examples/stlcRules.act @@ -43,7 +43,7 @@ myCtxt |- 'Synth -> 'Type judgementform {} - type (T : 'Type => 'Type) + type (T : 'Type) -- no '=> B' means the citizen version is the same {T - 'Value : 'Universe} judgementform @@ -53,7 +53,7 @@ judgementform judgementform {} - synth (t : 'Synth => T - 'Value) T + synth (t : 'Synth => T - 'Value) T {type T} -- Open question in the above: will it always be the subject that's fed to an operator? @@ -68,7 +68,7 @@ rule rule - {type S; type T} + {type S; type T} ------------------------ type ['Arr S T] => ['Arr S T] -- Global assumption: 'Universe comes with Pi builtin @@ -83,7 +83,7 @@ rule -- hypothetical judgement with fresh x, assuming `synth x S` -- (note hypothetical judgements have patterns in input and subject -- positions, and expressions in output positions) - check ~['Arr S T] ['Lam \x. body] => (\x. body) + check ~['Arr S T] ['Lam \x. body] => (\x. body) -- ~['Arr S T] means to not match, but to constrain instead {} -- Could equivalently be written without deliberate capture of x: From 0b786358e64529d6beafa49d9328d4d38aca04d9 Mon Sep 17 00:00:00 2001 From: Georgi Nakov Date: Fri, 28 Oct 2022 18:07:12 +0100 Subject: [PATCH 09/89] [ wip ] elaboration cont. --- Src/Actor.hs | 2 +- Src/Command.hs | 28 +++++++++++++++++++++++----- Src/Concrete/Base.hs | 20 ++++++++++++++++---- Src/Concrete/Parse.hs | 13 ++++++++----- Src/Concrete/Pretty.hs | 8 ++++---- Src/Elaboration.hs | 26 +++++++++++++++----------- Src/Elaboration/Monad.hs | 4 ++-- Src/Elaboration/Pretty.hs | 6 +++--- Src/Machine/Trace.hs | 24 +++++++++++++----------- Src/Rules.hs | 13 +++++++++---- Src/Syntax.hs | 6 +++++- Src/Unelaboration.hs | 18 ++++++++++-------- 12 files changed, 109 insertions(+), 59 deletions(-) diff --git a/Src/Actor.hs b/Src/Actor.hs index 6777bb9..173ad90 100644 --- a/Src/Actor.hs +++ b/Src/Actor.hs @@ -53,7 +53,7 @@ type instance LOOKEDUP Abstract = ACTm type instance GUARD Abstract = Maybe ActorVar data AConnect = AConnect Channel Th Channel Int deriving (Show) -type AProtocol = Protocol SyntaxDesc +type AProtocol = PROTOCOL Abstract type AContextStack = ContextStack SyntaxDesc type AActor = ACTOR Abstract type ACTm = CdB (Tm ActorMeta) diff --git a/Src/Command.hs b/Src/Command.hs index 5578353..f5c1904 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -339,21 +339,39 @@ sjudgementform JudgementForm{..} = do inputs <- concat <$> traverse subjects jpreconds -- TODO: should really be the closure of this info outputs <- concat <$> traverse subjects [ x | Left x <- jpostconds ] let names = map fst jplaces + let citizenNames = [x | (x, CitizenPlace) <- jplaces] whenLeft (allUnique names) $ \ a -> throwError $ DuplicatedPlace (getRange a) a + -- TODO : report with a proper error on the mismatch between the subject and citizen positions + unless (sort citizenNames == sort (map fst $ inputs ++ outputs)) $ throwError $ undefined + protocol <- traverse (citizenJudgement inputs ouputs) jplaces undefined -- TODO - -- judgementDecls <- fst <$> asks globals + where - subjects :: JUDGEMENT Concrete -> Elab [Variable] + subjects :: JUDGEMENT Concrete -> Elab [(Variable, ASemanticsDesc)] subjects (Judgement r name fms) = do IsJudgement{..} <- isJudgement name xs <- case halfZip judgementProtocol fms of Just xs -> pure xs Nothing -> throwError $ JudgementWrongArity r judgementName judgementProtocol fms - let ys = [ fm | ((Subject, _), fm) <- xs ] + let ys = [ (fm, sem) | ((Subject _, sem), fm) <- xs ] forM ys $ \case -- TODO: should use something like `isSendableSubject` - CFormula (These _ (Var r x)) -> pure x - x -> throwError $ UnexpectedNonSubject r x + (CFormula (These _ (Var r x)), sem) -> pure (x, sem) + (x, _) -> throwError $ UnexpectedNonSubject r x + + citizenJudgement :: [(Variable, ASemanticsDesc)] -> [(Variable, ASemanticsDesc)] + -> CPlace -> Elab (PROTOCOLENTRY Abstract) + citizenJudgement inputs outputs (name, CitizenPlace) = do + case (lookup name inputs, lookup name outputs) of + (Just isem, Nothing) -> pure (Input, isem) + (Nothing, Just osem) -> pure (Output, osem) + _ -> error "Impossible in citizenJudgement" + + citizenJudgement (name, SubjectPlace syn sem) = do + syndecls <- gets (Map.keys . syntaxCats) + syn <- ssyntaxdesc syndecls syn + sem <- ssemanticsdesc sem + pure (Subject syn, sem) -- | sopargs desc cops diff --git a/Src/Concrete/Base.hs b/Src/Concrete/Base.hs index e5561b6..1a5465c 100644 --- a/Src/Concrete/Base.hs +++ b/Src/Concrete/Base.hs @@ -135,10 +135,22 @@ instance HasGetRange RawP where data ThDirective = ThKeep | ThDrop deriving (Show) -data Mode = Input | Subject | Output - deriving (Show, Eq) +data Mode a = Input | Subject a | Output + deriving (Show, Eq, Functor, Foldable, Traversable) + +type SEMANTICSDESC (ph :: Phase) = TERM ph +type CSemanticsDesc = SEMANTICSDESC Concrete +type ASemanticsDesc = SEMANTICSDESC Abstract + +type PROTOCOLENTRY (ph :: Phase) = (Mode (SYNTAXDESC ph), SEMANTICSDESC ph) +type CProtocolEntry = PROTOCOLENTRY Concrete +type AProtocolEntry = PROTOCOLENTRY Abstract -type Protocol t = [(Mode, t)] +newtype PROTOCOL (ph :: Phase) = Protocol {getProtocol :: [PROTOCOLENTRY ph]} + +deriving instance + ( Show (SYNTAXDESC ph) + , Show (SEMANTICSDESC ph)) => Show (PROTOCOL ph) data ContextStack t = ContextStack { keyDesc :: t @@ -320,7 +332,7 @@ isWin :: ACTOR ph -> Bool isWin (Win _) = True isWin _ = False -type CProtocol = Protocol Raw +type CProtocol = PROTOCOL Concrete type CContextStack = ContextStack Raw type CActor = ACTOR Concrete type CScrutinee = SCRUTINEE Concrete diff --git a/Src/Concrete/Parse.hs b/Src/Concrete/Parse.hs index 8044083..68a2f66 100644 --- a/Src/Concrete/Parse.hs +++ b/Src/Concrete/Parse.hs @@ -91,16 +91,19 @@ pth :: Parser (Bwd Variable, ThDirective) pth = (,) <$> ppes pspc pvariable <*> (ThDrop <$ pspc <* pch ('*' ==) <|> pure ThKeep) -pmode :: Parser Mode +pmode :: Parser (Mode ()) pmode = Input <$ pch (== '?') - <|> Subject <$ pch (== '$') + <|> Subject () <$ pch (== '$') <|> Output <$ pch (== '!') -pprotocol :: Parser (Protocol Raw) -pprotocol = psep pspc - ((,) <$> pmode <* pspc +pprotocol :: Parser CProtocol +pprotocol = Protocol <$> psep pspc + (mkp <$> pmode <* pspc <*> pmustwork "Expected a syntax declaration" psyntaxdecl <* pspc <* plit ".") + where + mkp :: Mode () -> Raw -> PROTOCOLENTRY Concrete + mkp m s = (s <$ m, s) psyntaxdecl :: Parser Raw psyntaxdecl = pTM diff --git a/Src/Concrete/Pretty.hs b/Src/Concrete/Pretty.hs index e9ea127..54540b5 100644 --- a/Src/Concrete/Pretty.hs +++ b/Src/Concrete/Pretty.hs @@ -203,13 +203,13 @@ instance Pretty (RawP, CActor) where let pp = pretty p; pa = sep (prettyact a) in hang 2 (hsep [pp, "->"]) pa -instance Pretty Mode where +instance Pretty (Mode a) where pretty Input = "?" - pretty Subject = "$" + pretty (Subject _) = "$" pretty Output = "!" -instance Pretty t => Pretty (Protocol t) where - pretty = foldMap $ \ (m, d) -> fold [pretty m, pretty d, ". "] +instance Pretty CProtocol where + pretty (Protocol ps) = foldMap (\ (m, d) -> fold [pretty m, pretty d, ". "]) ps instance Pretty t => Pretty (ContextStack t) where pretty stk = hsep [pretty (keyDesc stk), "->", pretty (valueDesc stk)] diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index c3d901c..f61ccba 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -11,6 +11,7 @@ import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set import Data.Maybe +import Data.Bitraversable import Actor import Bwd @@ -70,19 +71,19 @@ escrutinee = \case Compare _ _ _ -> Syntax.contract (VEnumOrTag ["LT", "EQ", "GT"] []) Term _ desc -> desc -dual :: Protocol t -> Protocol t -dual = map $ \case +dual :: PROTOCOL ph -> PROTOCOL ph +dual (Protocol ps) = Protocol $ flip map ps $ \case (Input, c) -> (Output, c) - (Subject, c) -> (Subject, c) + (Subject x, c) -> (Subject x, c) (Output, c) -> (Input, c) data Comm = SEND | RECV deriving (Eq, Show) -whatComm :: Mode -> Direction -> Comm +whatComm :: Mode a -> Direction -> Comm whatComm m d = case m of Input -> RECV - Subject -> case d of + Subject _ -> case d of Rootwards -> RECV Leafwards -> SEND Output -> SEND @@ -127,6 +128,9 @@ ssyntaxdesc syndecls syn = do Nothing -> throwError undefined -- this should be impossible, since parsed in empty context Just syn0 -> pure syn0 +ssemanticsdesc :: CSemanticsDesc -> Elab ASemanticsDesc +ssemanticsdesc = stm DontLog $ catToDesc "Semantics" + ssbst :: Usage -> Bwd SbstC -> Elab (ACTSbst, ObjVars) ssbst usage B0 = do ovs <- asks objVars @@ -456,7 +460,7 @@ close :: Bool -> Range -> Channel -> Elab () close b r ch = do -- make sure the protocol was run all the way gets (channelLookup ch) >>= \case - Just (_,_,p) -> case p of + Just (_,_,p) -> case getProtocol p of [] -> pure () _ -> when b $ -- if we cannot win, we don't care @@ -487,7 +491,7 @@ guessDesc b (Cons _ p q) = do guessDesc True (At _ "") = pure (Known $ Syntax.contract VNil) guessDesc _ _ = pure Unknown -compatibleChannels :: Range -> (Direction, AProtocol) -> Ordering -> (Direction, AProtocol) -> Elab Int +compatibleChannels :: Range -> (Direction, [AProtocolEntry]) -> Ordering -> (Direction, [AProtocolEntry]) -> Elab Int compatibleChannels r (dp, []) dir (dq, []) = pure 0 compatibleChannels r (dp, p@(m, s) : ps) dir (dq, q@(n, t) : qs) = do unless (s == t) $ throwError (IncompatibleSyntaxDescs r s t) @@ -498,7 +502,7 @@ compatibleChannels r (dp, p@(m, s) : ps) dir (dq, q@(n, t) : qs) = do (SEND, GT) -> throwError (WrongDirection r p dir q) _ -> pure () (+1) <$> compatibleChannels r (dp, ps) dir (dq , qs) -compatibleChannels r (_,ps) _ (_,qs) = throwError (ProtocolsNotDual r ps qs) +compatibleChannels r (_,ps) _ (_,qs) = throwError (ProtocolsNotDual r (Protocol ps) (Protocol qs)) sirrefutable :: String -> IsSubject -> RawP -> Elab (Binder String, Maybe (CScrutinee, RawP)) sirrefutable nm isSub = \case @@ -565,7 +569,7 @@ sact = \case (usage, gd) <- do case m of Output -> pure (SentInOutput r, Nothing) - Subject -> ((SentAsSubject r ,) <$>) $ asks elabMode >>= \case + Subject _ -> ((SentAsSubject r ,) <$>) $ asks elabMode >>= \case Execution -> pure Nothing Definition -> checkSendableSubject tm @@ -766,9 +770,9 @@ coverageCheckClause rp p = do sprotocol :: CProtocol -> Elab AProtocol -sprotocol ps = during (ProtocolElaboration ps) $ do +sprotocol (Protocol ps) = during (ProtocolElaboration ps) $ do syndecls <- gets (Map.keys . syntaxCats) - traverse (traverse (ssyntaxdesc syndecls)) ps + Protocol <$> traverse (bitraverse (traverse $ ssyntaxdesc syndecls) ssemanticsdesc) ps scontextstack :: CContextStack -> Elab AContextStack scontextstack (ContextStack key val) = do diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index ea18b8a..7efd8ef 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -378,8 +378,8 @@ data Complaint | InconsistentCommunication Range | DoomedBranchCommunicated Range CActor | ProtocolsNotDual Range AProtocol AProtocol - | IncompatibleModes Range (Mode, SyntaxDesc) (Mode, SyntaxDesc) - | WrongDirection Range (Mode, SyntaxDesc) Ordering (Mode, SyntaxDesc) + | IncompatibleModes Range AProtocolEntry AProtocolEntry + | WrongDirection Range AProtocolEntry Ordering AProtocolEntry | JudgementWrongArity Range JudgementName AProtocol [CFormula] | UnexpectedNonSubject Range CFormula | DuplicatedPlace Range Variable diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index c93f4dc..f4bd339 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -7,7 +7,7 @@ import Data.These import ANSI hiding (withANSI) import Actor (ActorMeta(..), Channel(..), Stack(..)) -import Concrete.Base (Mode, Binder (..)) +import Concrete.Base (Mode, Binder (..), PROTOCOL(Protocol)) import Concrete.Pretty() import Elaboration.Monad import Location @@ -49,7 +49,7 @@ instance Pretty SyntaxDesc where instance Pretty ObjVar where pretty (x, info) = hsep [ pretty x, colon, pretty info ] -instance Pretty (Mode, SyntaxDesc) where +instance Pretty (Mode a, SyntaxDesc) where pretty (m, desc) = hsep [ pretty m, prettyPrec 1 desc ] instance Pretty CFormula where @@ -153,7 +153,7 @@ instance Pretty Complaint where hsep [ "Channels scopes", collapse (pretty <$> sc1) , "and", collapse (pretty <$> sc2), "are incompatible"] WrongDirection r m1 dir m2 -> hsep ["Wrong direction", pretty (show dir), "between", pretty m1, "and", pretty m2] - JudgementWrongArity r name protocol fms -> + JudgementWrongArity r name (Protocol protocol) fms -> let applied = (if length protocol > length fms then "under" else "over") <> "-applied" in hsep ["Judgement", pretty name, applied] UnexpectedNonSubject r fm -> hsep ["Unexpected non-subject", pretty fm] diff --git a/Src/Machine/Trace.hs b/Src/Machine/Trace.hs index 986b0d3..ac227ba 100644 --- a/Src/Machine/Trace.hs +++ b/Src/Machine/Trace.hs @@ -55,7 +55,7 @@ type instance ITERM Abstract = Term type instance ITERM Concrete = Raw data ARGUMENT (ph :: Phase) f ann = Argument - { argMode :: Mode + { argMode :: Mode () -- , argDesc :: SyntaxDesc , argTerm :: f (ITERM ph) ann } @@ -284,10 +284,10 @@ instance Bitraversable f => Unelab (ATrace f ann) where instance Pretty (CArgument Simple ()) where pretty (Argument m _ t) = withANSI [ SetColour Background bg, SetColour Foreground fg ] (pretty t) where (bg, fg) = pick m - pick :: Mode -> (Colour, Colour) -- background, foreground - pick Input = (Blue, White) - pick Subject = (White, Blue) - pick Output = (Red, White) + pick :: Mode a -> (Colour, Colour) -- background, foreground + pick Input = (Blue, White) + pick (Subject _) = (White, Blue) + pick Output = (Red, White) instance Pretty (CStep Simple ()) where pretty = \case @@ -406,14 +406,14 @@ extract mkF a = go where Node a (AStep extractionMode $ CallingStep (mkF () (a, isDone (store p))) judgeName - (zipWith toArgument judgeProtocol (traffic <>> []))) + (zipWith toArgument (getProtocol judgeProtocol) (traffic <>> []))) (go fs) : go (stack p) ++ findFailures p Spawner Interface{..} -> let p = fst spawnee in Node a (AStep extractionMode $ CallingStep (mkF () (a, isDone (store p))) judgeName - (zipWith toArgument judgeProtocol (traffic <>> []))) + (zipWith toArgument (getProtocol judgeProtocol) (traffic <>> []))) (go (stack p) ++ findFailures p) : go fs @@ -422,9 +422,11 @@ extract mkF a = go where UnificationProblem date s t -> Error a (StuckUnifying s t) : go fs Noted -> Node a (AStep AlwaysExtract NotedStep) [] : go fs _ -> go fs - - toArgument :: (Mode, SyntaxDesc) -> Term -> AArgument f ann - toArgument (mode, desc) term = Argument mode desc (mkF term a) + + toArgument :: AProtocolEntry -> Term -> AArgument f ann + toArgument (Subject desc, _) term = Argument (Subject ()) desc (mkF term a) + toArgument (Input, desc) term = Argument Input desc (mkF term a) + toArgument (Output, desc) term = Argument Output desc (mkF term a) findFailures :: Process log Status [] -> [ATrace f ann] findFailures p@Process{..} @@ -502,7 +504,7 @@ syntaxPreamble table = concatMap (pure . render) judgementPreamble :: Frame -> [Doc ()] -judgementPreamble (Rules jd jp _) +judgementPreamble (Rules jd (Protocol jp) _) = [text $ mkNewCommand ("calling" ++ jd) (length jp) $ "\\textsc{" ++ jd ++ "}" ++ unwords (nArgs (length jp)) ] diff --git a/Src/Rules.hs b/Src/Rules.hs index 6f66534..6a5ebca 100644 --- a/Src/Rules.hs +++ b/Src/Rules.hs @@ -4,6 +4,7 @@ module Rules where import Control.Applicative import Data.These +import Data.Maybe import Actor import Scope @@ -50,13 +51,17 @@ data RULE (ph :: Phase) = RULE , operatorDefs :: [DEFNOP ph] } -type SEMANTICSDESC (ph :: Phase) = TERM ph - type PLACE (ph :: Phase) = (Variable, PLACEKIND ph) +type CPlace = PLACE Concrete + data PLACEKIND (ph :: Phase) = CitizenPlace - | SubjectPlace (SYNTAXDESC ph) (Maybe (SEMANTICSDESC ph)) + | SubjectPlace (SYNTAXDESC ph) (SEMANTICSDESC ph) + +mkSubjectPlace :: SYNTAXDESC Concrete -> Maybe (SEMANTICSDESC Concrete) + -> PLACEKIND Concrete +mkSubjectPlace syn = SubjectPlace syn . fromMaybe syn data JUDGEMENTFORM (ph :: Phase) = JudgementForm { jrange :: Range @@ -119,7 +124,7 @@ prule = RULE <$ pkeyword KwRule <* pspc <*> pcurlies (psep (punc ";") ppremise) pplace :: Parser (PLACE Concrete) pplace = (,CitizenPlace) <$> pvariable - <|> pparens ((,) <$> pvariable <* punc ":" <*> (SubjectPlace <$> psyntaxdecl <*> optional (id <$ punc "=>" <*> pTM))) + <|> pparens ((,) <$> pvariable <* punc ":" <*> (mkSubjectPlace <$> psyntaxdecl <*> optional (id <$ punc "=>" <*> pTM))) pjudgementform :: Parser (JUDGEMENTFORM Concrete) pjudgementform = withRange $ JudgementForm unknown <$ pkeyword KwJudgementForm <* pspc <*> pcurlies (psep (punc ";") pjudgement) diff --git a/Src/Syntax.hs b/Src/Syntax.hs index 9a54ed5..252cef5 100644 --- a/Src/Syntax.hs +++ b/Src/Syntax.hs @@ -167,7 +167,11 @@ syntaxDesc syns = "EnumOrTag" #%+ [ validateDesc :: [SyntaxCat] -> SyntaxDesc -> Bool validateDesc syns = - validate (Map.singleton "Syntax" (syntaxDesc syns)) B0 + validate (Map.fromList known) B0 (rec "Syntax") + where + known = [ ("Syntax", syntaxDesc syns) + , ("Semantics", wildcard)] -- TODO : change + validateIt = validateDesc ["Syntax"] (syntaxDesc ["Syntax"]) diff --git a/Src/Unelaboration.hs b/Src/Unelaboration.hs index 1546186..87850dd 100644 --- a/Src/Unelaboration.hs +++ b/Src/Unelaboration.hs @@ -299,10 +299,10 @@ instance Unelab AActor where Connect r cnnct -> Connect r <$> subunelab cnnct Note r a -> Note r <$> unelab a -instance Unelab Mode where - type UnelabEnv Mode = () - type Unelabed Mode = Mode - unelab = pure +instance Unelab t => Unelab (Mode t) where + type UnelabEnv (Mode t) = UnelabEnv t + type Unelabed (Mode t) = Mode (Unelabed t) + unelab = traverse unelab instance Unelab () where type UnelabEnv () = () @@ -314,7 +314,9 @@ instance Unelab t => Unelab (ContextStack t) where type Unelabed (ContextStack t) = ContextStack (Unelabed t) unelab = traverse unelab -instance Unelab t => Unelab (Protocol t) where - type UnelabEnv (Protocol t) = UnelabEnv t - type Unelabed (Protocol t) = Protocol (Unelabed t) - unelab = traverse (traverse unelab) +instance Unelab AProtocol where + type UnelabEnv AProtocol = Naming + type Unelabed AProtocol = CProtocol + unelab (Protocol ps) = Protocol <$> traverse f ps + where + f (m, s) = (,) <$> unelab m <*> unelab s From 9e576a8284d7abc45793524cafedf1f9dc851808 Mon Sep 17 00:00:00 2001 From: Georgi Nakov Date: Wed, 2 Nov 2022 16:37:03 +0000 Subject: [PATCH 10/89] [ WIP ] protocol fix, onto syntaxDesc -> semanticsDesc --- Src/Concrete/Base.hs | 4 ++++ Src/Concrete/Pretty.hs | 5 ++++- Src/Elaboration.hs | 23 ++++++++++++----------- Src/Elaboration/Monad.hs | 6 +++--- Src/Elaboration/Pretty.hs | 23 +++++++++++++---------- Src/Syntax.hs | 3 +++ 6 files changed, 39 insertions(+), 25 deletions(-) diff --git a/Src/Concrete/Base.hs b/Src/Concrete/Base.hs index 1a5465c..3cb9cab 100644 --- a/Src/Concrete/Base.hs +++ b/Src/Concrete/Base.hs @@ -138,6 +138,10 @@ data ThDirective = ThKeep | ThDrop data Mode a = Input | Subject a | Output deriving (Show, Eq, Functor, Foldable, Traversable) +isSubjectMode :: Mode a -> Bool +isSubjectMode (Subject _) = True +isSubjectMode _ = False + type SEMANTICSDESC (ph :: Phase) = TERM ph type CSemanticsDesc = SEMANTICSDESC Concrete type ASemanticsDesc = SEMANTICSDESC Abstract diff --git a/Src/Concrete/Pretty.hs b/Src/Concrete/Pretty.hs index 54540b5..351fec0 100644 --- a/Src/Concrete/Pretty.hs +++ b/Src/Concrete/Pretty.hs @@ -207,9 +207,12 @@ instance Pretty (Mode a) where pretty Input = "?" pretty (Subject _) = "$" pretty Output = "!" + +instance (Pretty t) => Pretty (Mode a, t) where + pretty (m, desc) = hsep [ pretty m, prettyPrec 1 desc ] instance Pretty CProtocol where - pretty (Protocol ps) = foldMap (\ (m, d) -> fold [pretty m, pretty d, ". "]) ps + pretty (Protocol ps) = foldMap (\ x -> pretty x <> ". ") ps instance Pretty t => Pretty (ContextStack t) where pretty stk = hsep [pretty (keyDesc stk), "->", pretty (valueDesc stk)] diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index f61ccba..4ce9709 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -98,7 +98,7 @@ spassport :: Usage -> IsSubject -> Passport spassport u IsSubject{} | isBeingScrutinised u = ASubject spassport _ _ = ACitizen -svar :: Usage -> Variable -> Elab (IsSubject, Info SyntaxDesc, ACTm) +svar :: Usage -> Variable -> Elab (IsSubject, Info ASemanticsDesc, ACTm) svar usage x = do ovs <- asks objVars res <- resolve x @@ -202,7 +202,7 @@ sscrutinee (Term r t) = during (ScrutineeTermElaboration t) $ do pure (Term r desc, Term r t) -stm :: Usage -> SyntaxDesc -> Raw -> Elab ACTm +stm :: Usage -> ASemanticsDesc -> Raw -> Elab ACTm stm usage desc (Var r v) = during (TermVariableElaboration v) $ do table <- gets syntaxCats (_, desc', t) <- svar usage v @@ -441,8 +441,9 @@ channelScope (Channel ch) = do case fromJust (focusBy (\ (y, k) -> k <$ guard (ch == y)) ds) of (_, AChannel sc, _) -> pure sc -steppingChannel :: Range -> Channel -> (Direction -> AProtocol -> Elab (a, AProtocol)) -> - Elab a +steppingChannel :: Range -> Channel + -> (Direction -> [AProtocolEntry] -> Elab (a, [AProtocolEntry])) + -> Elab a steppingChannel r ch step = do nm <- getName (dir, pnm, p) <- gets (fromJust . channelLookup ch) @@ -452,7 +453,7 @@ steppingChannel r ch step = do pure cat open :: Direction -> Channel -> AProtocol -> Elab () -open dir ch p = do +open dir ch (Protocol p) = do nm <- getName modify (channelInsert ch (dir, nm, p)) @@ -460,11 +461,11 @@ close :: Bool -> Range -> Channel -> Elab () close b r ch = do -- make sure the protocol was run all the way gets (channelLookup ch) >>= \case - Just (_,_,p) -> case getProtocol p of + Just (_, _, ps) -> case ps of [] -> pure () _ -> when b $ -- if we cannot win, we don't care - throwError (UnfinishedProtocol r ch p) + throwError (UnfinishedProtocol r ch (Protocol ps)) modify (channelDelete ch) withChannel :: Range -> Direction -> Channel -> AProtocol -> Elab a -> Elab a @@ -592,7 +593,7 @@ sact = \case _ -> throwError (InvalidRecv r ch p) let isSub = case m of - Subject -> IsSubject Parent + Subject _ -> IsSubject Parent _ -> IsNotSubject -- elaborate the (potentially pattern-matching) receive @@ -609,7 +610,7 @@ sact = \case -- Check we properly scrutinised a subject input unlessM (checkScrutinised av) $ - when (m == Subject) $ do + when (isSubjectMode m) $ do when canwin $ raiseWarning (RecvSubjectNotScrutinised r ch av) pure $ Recv r ch (ActorMeta (spassport (Scrutinised unknown) isSub) <$> av, a) @@ -770,9 +771,9 @@ coverageCheckClause rp p = do sprotocol :: CProtocol -> Elab AProtocol -sprotocol (Protocol ps) = during (ProtocolElaboration ps) $ do +sprotocol p = during (ProtocolElaboration p) $ do syndecls <- gets (Map.keys . syntaxCats) - Protocol <$> traverse (bitraverse (traverse $ ssyntaxdesc syndecls) ssemanticsdesc) ps + Protocol <$> traverse (bitraverse (traverse $ ssyntaxdesc syndecls) ssemanticsdesc) (getProtocol p) scontextstack :: CContextStack -> Elab AContextStack scontextstack (ContextStack key val) = do diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 7efd8ef..8e87f1a 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -34,7 +34,7 @@ data ElabState = ElabState , warnings :: Bwd (WithStackTrace Warning) } -type ChannelState = (Direction, [Turn], AProtocol) +type ChannelState = (Direction, [Turn], [AProtocolEntry]) type ChannelStates = Map Channel ChannelState type ActvarStates = Map ActorVar (Bwd Usage) @@ -155,7 +155,7 @@ compatibleInfos r desc desc' = do ------------------------------------------------------------------------------ -- Context -type ObjVar = (String, Info SyntaxDesc) +type ObjVar = (String, Info ASemanticsDesc) type ObjVars = Bwd ObjVar data Provenance = Parent | Pattern @@ -183,7 +183,7 @@ isSubjectFree = \case SubjectVar{} -> False data Kind - = ActVar IsSubject (Info SyntaxDesc) ObjVars + = ActVar IsSubject (Info ASemanticsDesc) ObjVars | AChannel ObjVars | AJudgement ExtractMode AProtocol | AStack AContextStack diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index f4bd339..589167b 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, UndecidableInstances #-} {-# OPTIONS_GHC -Wincomplete-patterns #-} module Elaboration.Pretty where @@ -6,16 +6,16 @@ import Data.Foldable import Data.These import ANSI hiding (withANSI) -import Actor (ActorMeta(..), Channel(..), Stack(..)) -import Concrete.Base (Mode, Binder (..), PROTOCOL(Protocol)) +import Actor (ActorMeta(..), Channel(..), Stack(..), AProtocol) +import Concrete.Base (Binder (..), PROTOCOL(Protocol)) import Concrete.Pretty() import Elaboration.Monad import Location import Pretty -import Syntax -import Unelaboration (unsafeEvalUnelab, unelab, initNaming) +import Unelaboration (unsafeEvalUnelab, unelab, initNaming, Unelab, Unelabed, UnelabEnv, Naming) import Data.List.NonEmpty (NonEmpty((:|))) import Rules +import Thin instance Pretty Range where pretty r | r == unknown = "" @@ -43,15 +43,18 @@ instance Pretty Kind where AJudgement{} -> "a judgement" AStack{} -> "a context stack" -instance Pretty SyntaxDesc where - pretty t = pretty $ unsafeEvalUnelab initNaming (unelab t) +instance (Unelab a, Pretty (Unelabed a), UnelabEnv a ~ Naming) + => Pretty (CdB a) where + pretty (CdB a th) + | is0s th = pretty $ unsafeEvalUnelab initNaming (unelab a) + | otherwise = "_" +instance Pretty AProtocol where + pretty (Protocol ps) = foldMap (\ x -> pretty x <> ". ") ps + instance Pretty ObjVar where pretty (x, info) = hsep [ pretty x, colon, pretty info ] -instance Pretty (Mode a, SyntaxDesc) where - pretty (m, desc) = hsep [ pretty m, prettyPrec 1 desc ] - instance Pretty CFormula where pretty (CFormula a) = these pretty pretty (const pretty) a pretty (CCitizen p t) = hsep [pretty p, "=>", pretty t] diff --git a/Src/Syntax.hs b/Src/Syntax.hs index 252cef5..4816e31 100644 --- a/Src/Syntax.hs +++ b/Src/Syntax.hs @@ -74,6 +74,9 @@ expand' w table = go True where expand :: SyntaxTable -> SyntaxDesc -> Maybe VSyntaxDesc expand = expand' No +embed :: SyntaxDesc -> ASemanticsDesc +embed = fmap absurd + contract' :: WithSyntaxCat a -> VSyntaxDesc' a -> SyntaxDesc contract' w = \case VAtom -> atom "Atom" 0 From 218c8590375c513862e9cb03c7263b2e8e8c6669 Mon Sep 17 00:00:00 2001 From: Georgi Nakov Date: Wed, 2 Nov 2022 17:02:58 +0000 Subject: [PATCH 11/89] [ fix ] impossible error in ssyntaxdesc --- Src/Elaboration.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 4ce9709..b60d7ac 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -125,7 +125,7 @@ ssyntaxdesc syndecls syn = do let desc = catToDesc "Syntax" syn <- withSyntax (syntaxDesc syndecls) $ stm DontLog desc syn case isMetaFree syn of - Nothing -> throwError undefined -- this should be impossible, since parsed in empty context + Nothing -> error "Impossible in ssyntaxdesc" -- this should be impossible, since parsed in empty context Just syn0 -> pure syn0 ssemanticsdesc :: CSemanticsDesc -> Elab ASemanticsDesc From 321727a3ed6658d99d842d8d38bc46635c876317 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Fri, 4 Nov 2022 17:20:24 +0000 Subject: [PATCH 12/89] [ fix ] back to building --- Src/Actor.hs | 26 +++++++++--------- Src/Command.hs | 56 +++++++++++++++++++++------------------ Src/Concrete/Base.hs | 10 ++++--- Src/Elaboration.hs | 24 ++++++++++------- Src/Elaboration/Monad.hs | 14 ++++++---- Src/Elaboration/Pretty.hs | 5 ++-- Src/LaTeX.hs | 5 ++-- Src/Pattern/Coverage.hs | 20 +++++++------- Src/Syntax.hs | 50 +++++++++++++++++----------------- Src/Unelaboration.hs | 1 + TODO.md | 2 ++ 11 files changed, 119 insertions(+), 94 deletions(-) diff --git a/Src/Actor.hs b/Src/Actor.hs index 173ad90..53b7542 100644 --- a/Src/Actor.hs +++ b/Src/Actor.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE UndecidableInstances #-} + module Actor where import Data.Map (Map) @@ -10,7 +12,6 @@ import Hide import Location import Options import Pattern -import Syntax (SyntaxDesc) import Term import Thin @@ -40,13 +41,12 @@ type instance JUDGEMENTNAME Abstract = JudgementName type instance CHANNEL Abstract = Channel type instance BINDER Abstract = (Binder ActorMeta) type instance ACTORVAR Abstract = ActorMeta -type instance SYNTAXDESC Abstract = SyntaxDesc type instance TERMVAR Abstract = DB type instance TERM Abstract = ACTm type instance PATTERN Abstract = Pat type instance CONNECT Abstract = AConnect type instance STACK Abstract = Stack -type instance STACKDESC Abstract = SyntaxDesc +type instance STACKDESC Abstract = ASyntaxDesc type instance SCRUTINEEVAR Abstract = ACTm type instance SCRUTINEETERM Abstract = ACTm type instance LOOKEDUP Abstract = ACTm @@ -54,7 +54,7 @@ type instance GUARD Abstract = Maybe ActorVar data AConnect = AConnect Channel Th Channel Int deriving (Show) type AProtocol = PROTOCOL Abstract -type AContextStack = ContextStack SyntaxDesc +type AContextStack = ContextStack ASyntaxDesc type AActor = ACTOR Abstract type ACTm = CdB (Tm ActorMeta) type ACTSbst = CdB (Sbst ActorMeta) @@ -71,7 +71,7 @@ data Env = Env { globalScope :: Bwd String -- free vars ga actor does *not* know about , actorVars :: Map ActorMeta ([String] -- bound vars xi actorVar does know about , Term) -- in scope ga <>< xi - , subjectGuards :: Map String Guard + , subjectGuards :: Map String Guard , localScope :: Bwd String -- vars de actor has bound , alphaRenamings :: Map String (Hide String) } deriving (Show, Eq) @@ -86,14 +86,14 @@ declareAlpha (x, y) rho = rho { alphaRenamings = Map.insert x y (alphaRenamings rho) } initEnv :: Bwd String -> Env -initEnv gamma = Env - { globalScope = gamma - , actorVars = Map.empty - , subjectGuards = Map.empty - , localScope = B0 - , alphaRenamings = Map.empty +initEnv gamma = Env + { globalScope = gamma + , actorVars = Map.empty + , subjectGuards = Map.empty + , localScope = B0 + , alphaRenamings = Map.empty } - + childEnv :: Env -> Env childEnv parentEnv = initEnv (globalScope parentEnv <> localScope parentEnv) @@ -106,7 +106,7 @@ guardSubject v defn gd env = , actorVars = Map.insert (ActorMeta ACitizen v) (interpreted defn) (actorVars env)} where interpreted (bs, t) = (bs, contract (GX gd t)) - + -- | When we encounter a term with actor variables inside and want to send -- or match on it, we need to first substitute all of the terms the actor -- variables map to. diff --git a/Src/Command.hs b/Src/Command.hs index f5c1904..8bb21c5 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -8,6 +8,7 @@ import Control.Monad.Reader import Control.Monad.State import Data.Bifunctor (first) +import Data.List (sort) import qualified Data.Map as Map import Data.Maybe (fromMaybe) import Data.Traversable (for) @@ -44,16 +45,16 @@ type family SYNTAXCAT (ph :: Phase) :: * type instance SYNTAXCAT Concrete = WithRange SyntaxCat type instance SYNTAXCAT Abstract = SyntaxCat -type family PROTOCOL (ph :: Phase) :: * -type instance PROTOCOL Concrete = () -type instance PROTOCOL Abstract = AProtocol +type family DEFNPROTOCOL (ph :: Phase) :: * +type instance DEFNPROTOCOL Concrete = () +type instance DEFNPROTOCOL Abstract = AProtocol data STATEMENT (ph :: Phase) = Statement (JUDGEMENTNAME ph) [Variable] data COMMAND (ph :: Phase) - = DeclJudge ExtractMode (JUDGEMENTNAME ph) (Protocol (SYNTAXDESC ph)) - | DefnJudge (JUDGEMENTNAME ph, PROTOCOL ph, CHANNEL ph) (ACTOR ph) + = DeclJudge ExtractMode (JUDGEMENTNAME ph) (PROTOCOL ph) + | DefnJudge (JUDGEMENTNAME ph, DEFNPROTOCOL ph, CHANNEL ph) (ACTOR ph) | ContractJudge [STATEMENT ph] (STATEMENT ph) [STATEMENT ph] | DeclSyntax [(SYNTAXCAT ph, SYNTAXDESC ph)] | DeclStack (STACK ph) (ContextStack (SYNTAXDESC ph)) @@ -83,6 +84,7 @@ deriving instance , Show (SYNTAXCAT ph) , Show (OPERATOR ph) , Show (PROTOCOL ph) + , Show (DEFNPROTOCOL ph) , Show (LOOKEDUP ph) , Show (DEFNOP ph) , Show (JUDGEMENTFORM ph) @@ -101,8 +103,8 @@ type AStatement = STATEMENT Abstract type CPattern = PATTERN Concrete type APattern = PATTERN Abstract -instance Display Mode where - type DisplayEnv Mode = () +instance (Show a, Unelab a, Pretty (Unelabed a)) => Display (Mode a) where + type DisplayEnv (Mode a) = UnelabEnv a display = viaPretty instance (Show t, Unelab t, Pretty (Unelabed t)) => @@ -110,9 +112,8 @@ instance (Show t, Unelab t, Pretty (Unelabed t)) => type DisplayEnv (ContextStack t) = UnelabEnv t display = viaPretty -instance (Show t, Unelab t, Pretty (Unelabed t)) => - Display (Protocol t) where - type DisplayEnv (Protocol t) = UnelabEnv t +instance Display AProtocol where + type DisplayEnv AProtocol = Naming display = viaPretty instance Pretty CStatement where @@ -121,8 +122,10 @@ instance Pretty CStatement where instance Pretty (PLACE Concrete) where pretty (v, CitizenPlace) = pretty v pretty (v, SubjectPlace syntaxdesc semanticsdesc) = - parens (hsep $ [pretty v, ":", pretty syntaxdesc] - ++ foldMap (("=>":) . (:[]) . pretty) semanticsdesc) + parens $ hsep $ [ pretty v, ":", pretty syntaxdesc ] + ++ (("=>" <+> pretty semanticsdesc) <$ guard (syntaxdesc /= semanticsdesc)) + + instance Pretty CCommand where pretty = let prettyCds cds = collapse (BracesList $ pretty <$> cds) in \case @@ -343,14 +346,14 @@ sjudgementform JudgementForm{..} = do whenLeft (allUnique names) $ \ a -> throwError $ DuplicatedPlace (getRange a) a -- TODO : report with a proper error on the mismatch between the subject and citizen positions unless (sort citizenNames == sort (map fst $ inputs ++ outputs)) $ throwError $ undefined - protocol <- traverse (citizenJudgement inputs ouputs) jplaces + protocol <- traverse (citizenJudgement inputs outputs) jplaces undefined -- TODO - + where subjects :: JUDGEMENT Concrete -> Elab [(Variable, ASemanticsDesc)] subjects (Judgement r name fms) = do IsJudgement{..} <- isJudgement name - xs <- case halfZip judgementProtocol fms of + xs <- case halfZip (getProtocol judgementProtocol) fms of Just xs -> pure xs Nothing -> throwError $ JudgementWrongArity r judgementName judgementProtocol fms let ys = [ (fm, sem) | ((Subject _, sem), fm) <- xs ] @@ -361,17 +364,18 @@ sjudgementform JudgementForm{..} = do citizenJudgement :: [(Variable, ASemanticsDesc)] -> [(Variable, ASemanticsDesc)] -> CPlace -> Elab (PROTOCOLENTRY Abstract) - citizenJudgement inputs outputs (name, CitizenPlace) = do - case (lookup name inputs, lookup name outputs) of - (Just isem, Nothing) -> pure (Input, isem) - (Nothing, Just osem) -> pure (Output, osem) - _ -> error "Impossible in citizenJudgement" - - citizenJudgement (name, SubjectPlace syn sem) = do - syndecls <- gets (Map.keys . syntaxCats) - syn <- ssyntaxdesc syndecls syn - sem <- ssemanticsdesc sem - pure (Subject syn, sem) + citizenJudgement inputs outputs (name, place) = case place of + CitizenPlace -> + case (lookup name inputs, lookup name outputs) of + (Just isem, Nothing) -> pure (Input, isem) + (Nothing, Just osem) -> pure (Output, osem) + _ -> error "Impossible in citizenJudgement" + + SubjectPlace syn sem -> do + syndecls <- gets (Map.keys . syntaxCats) + syn <- ssyntaxdesc syndecls syn + sem <- ssemanticsdesc sem + pure (Subject syn, sem) -- | sopargs desc cops diff --git a/Src/Concrete/Base.hs b/Src/Concrete/Base.hs index 3cb9cab..12d7d8d 100644 --- a/Src/Concrete/Base.hs +++ b/Src/Concrete/Base.hs @@ -142,7 +142,13 @@ isSubjectMode :: Mode a -> Bool isSubjectMode (Subject _) = True isSubjectMode _ = False -type SEMANTICSDESC (ph :: Phase) = TERM ph +type family SYNTAXDESC (ph :: Phase) :: * +type instance SYNTAXDESC Concrete = Raw +type CSyntaxDesc = SYNTAXDESC Concrete +type ASyntaxDesc = SYNTAXDESC Abstract + +type SEMANTICSDESC (ph :: Phase) + = SYNTAXDESC ph -- for now, actually: TERM ph type CSemanticsDesc = SEMANTICSDESC Concrete type ASemanticsDesc = SEMANTICSDESC Abstract @@ -196,7 +202,6 @@ type family JUDGEMENTNAME (ph :: Phase) :: * type family CHANNEL (ph :: Phase) :: * type family BINDER (ph :: Phase) :: * type family ACTORVAR (ph :: Phase) :: * -type family SYNTAXDESC (ph :: Phase) :: * type family TERMVAR (ph :: Phase) :: * type family TERM (ph :: Phase) :: * type family PATTERN (ph :: Phase) :: * @@ -212,7 +217,6 @@ type instance JUDGEMENTNAME Concrete = Variable type instance CHANNEL Concrete = Variable type instance BINDER Concrete = RawP type instance ACTORVAR Concrete = Variable -type instance SYNTAXDESC Concrete = Raw type instance TERMVAR Concrete = Variable type instance TERM Concrete = Raw type instance PATTERN Concrete = RawP diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index b60d7ac..85ac4e4 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -41,7 +41,7 @@ isSubject _ = IsNotSubject checkSendableSubject :: Raw -> Elab (Maybe ActorVar) checkSendableSubject tm = do localVars <- asks objVars - go (fmap fst localVars) tm + go (fmap objVarName localVars) tm where go :: Bwd String -> Raw -> Elab (Maybe ActorVar) go localVars x = case x of @@ -104,7 +104,7 @@ svar usage x = do res <- resolve x case res of Just (Left k) -> case k of -- TODO: come back and remove fst <$> - ActVar isSub desc sc -> case findSub (fst <$> sc) (fst <$> ovs) of + ActVar isSub desc sc -> case findSub (objVarName <$> sc) (objVarName <$> ovs) of Just th -> do logUsage (getVariable x) usage pure (isSub, desc, ActorMeta (spassport usage isSub) (getVariable x) $: sbstW (sbst0 0) th) @@ -118,7 +118,7 @@ spop r = do ovs <- asks objVars case ovs of B0 -> throwError (EmptyContext r) - (xz :< (x, cat)) -> pure (xz, (Variable r x, cat)) + (xz :< ObjVar x cat) -> pure (xz, (Variable r x, cat)) ssyntaxdesc :: [SyntaxCat] -> Raw -> Elab SyntaxDesc ssyntaxdesc syndecls syn = do @@ -129,7 +129,11 @@ ssyntaxdesc syndecls syn = do Just syn0 -> pure syn0 ssemanticsdesc :: CSemanticsDesc -> Elab ASemanticsDesc -ssemanticsdesc = stm DontLog $ catToDesc "Semantics" +ssemanticsdesc sem = do + syndecls <- gets (Map.keys . syntaxCats) + ssyntaxdesc syndecls sem + -- TOOD: use stm to actually be able to use operators & actor vars + -- DontLog (catToDesc "Semantics") ssbst :: Usage -> Bwd SbstC -> Elab (ACTSbst, ObjVars) ssbst usage B0 = do @@ -140,7 +144,7 @@ ssbst usage (sg :< sgc) = case sgc of (xz, (w, cat)) <- spop r when (v /= w) $ throwError (NotTopVariable r v w) (sg, ovs) <- local (setObjVars xz) (ssbst usage sg) - pure (sbstW sg (ones 1), ovs :< (getVariable w, cat)) + pure (sbstW sg (ones 1), ovs :< ObjVar (getVariable w) cat) Drop r v -> do (xz, (w, cat)) <- spop r when (v /= w) $ throwError (NotTopVariable r v w) @@ -152,12 +156,12 @@ ssbst usage (sg :< sgc) = case sgc of t <- stm usage desc t (sg, ovs) <- ssbst usage sg v <- local (setObjVars ovs) $ isFresh v - pure (sbstT sg ((Hide v :=) $^ t), ovs :< (v, info)) + pure (sbstT sg ((Hide v :=) $^ t), ovs :< ObjVar v info) sth :: (Bwd Variable, ThDirective) -> Elab Th sth (xz, b) = do ovs <- asks objVars - let th = which (`elem` (getVariable <$> xz)) (fst <$> ovs) + let th = which (`elem` (getVariable <$> xz)) (objVarName <$> ovs) pure $ case b of ThKeep -> th ThDrop -> comp th @@ -560,7 +564,7 @@ sact = \case pure $ Spawn r em (judgementName jd) ch a - Send r ch () tm a -> do + Send r ch () tm a -> do ch <- isChannel ch -- Check the channel is in sending mode, & step it (m, desc) <- steppingChannel r ch $ \ dir -> \case @@ -570,7 +574,7 @@ sact = \case (usage, gd) <- do case m of Output -> pure (SentInOutput r, Nothing) - Subject _ -> ((SentAsSubject r ,) <$>) $ asks elabMode >>= \case + Subject _ -> ((SentAsSubject r ,) <$>) $ asks elabMode >>= \case Execution -> pure Nothing Definition -> checkSendableSubject tm @@ -578,6 +582,8 @@ sact = \case tm <- during (SendTermElaboration ch tm) $ do sc <- channelScope ch ovs <- asks objVars + -- NB: the lintersection takes the (Info ASemanticsDesc) into account + -- Should it? let (thx, xyz, thy) = lintersection sc ovs (*^ thx) <$> local (setObjVars xyz) (stm usage desc tm) diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 8e87f1a..28487a7 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -155,7 +155,11 @@ compatibleInfos r desc desc' = do ------------------------------------------------------------------------------ -- Context -type ObjVar = (String, Info ASemanticsDesc) +data ObjVar = ObjVar + { objVarName :: String + , objVarDesc :: Info ASemanticsDesc + } deriving (Show, Eq) + type ObjVars = Bwd ObjVar data Provenance = Parent | Pattern @@ -220,8 +224,8 @@ initContext = Context , stackTrace = [] } -declareObjVar :: ObjVar -> Context -> Context -declareObjVar x ctx = ctx { objVars = objVars ctx :< x } +declareObjVar :: (String, Info ASemanticsDesc) -> Context -> Context +declareObjVar (x, info) ctx = ctx { objVars = objVars ctx :< ObjVar x info } setObjVars :: ObjVars -> Context -> Context setObjVars ovs ctx = ctx { objVars = ovs } @@ -438,7 +442,7 @@ instance HasGetRange Complaint where WrongDirection r _ _ _ -> r JudgementWrongArity r _ _ _ -> r UnexpectedNonSubject r _ -> r - + DuplicatedPlace r _ -> r -- syntaxes AlreadyDeclaredSyntaxCat r _ -> r -- syntaxdesc validation @@ -501,7 +505,7 @@ resolve (Variable r x) = do let ovs = objVars ctx case focusBy (\ (y, k) -> k <$ guard (x == y)) ds of Just (_, k, _) -> pure (Just $ Left k) - _ -> case focusBy (\ (y, desc) -> desc <$ guard (x == y)) ovs of + _ -> case focusBy (\ (ObjVar y desc) -> desc <$ guard (x == y)) ovs of Just (xz, desc, xs) -> pure (Just $ Right (desc, DB $ length xs)) Nothing -> pure Nothing diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index 589167b..6faa726 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -15,6 +15,7 @@ import Pretty import Unelaboration (unsafeEvalUnelab, unelab, initNaming, Unelab, Unelabed, UnelabEnv, Naming) import Data.List.NonEmpty (NonEmpty((:|))) import Rules +import Syntax () import Thin instance Pretty Range where @@ -51,9 +52,9 @@ instance (Unelab a, Pretty (Unelabed a), UnelabEnv a ~ Naming) instance Pretty AProtocol where pretty (Protocol ps) = foldMap (\ x -> pretty x <> ". ") ps - + instance Pretty ObjVar where - pretty (x, info) = hsep [ pretty x, colon, pretty info ] + pretty (ObjVar x info) = hsep [ pretty x, colon, pretty info ] instance Pretty CFormula where pretty (CFormula a) = these pretty pretty (const pretty) a diff --git a/Src/LaTeX.hs b/Src/LaTeX.hs index 5d74547..ae90dd9 100644 --- a/Src/LaTeX.hs +++ b/Src/LaTeX.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} module LaTeX where @@ -84,7 +85,7 @@ asList p = [p] latexspace :: Doc () latexspace = "\\ " -toLaTeXCdr :: SyntaxDesc -> Raw -> LaTeXM (Doc ()) +toLaTeXCdr :: ASyntaxDesc -> Raw -> LaTeXM (Doc ()) toLaTeXCdr _ (At _ "") = pure $ call False "typosListEnd" [] toLaTeXCdr d (Cons _ p q) = do (dp, dq) <- ask >>= \ table -> pure $ case expand table d of @@ -99,7 +100,7 @@ toLaTeXCdr d p = do pure $ call False "typosListTail" [p] instance LaTeX Raw where - type Format Raw = SyntaxDesc + type Format Raw = ASyntaxDesc toLaTeX d = \case Var _ v -> do v <- toLaTeX () v diff --git a/Src/Pattern/Coverage.hs b/Src/Pattern/Coverage.hs index d2aa98b..3d0121d 100644 --- a/Src/Pattern/Coverage.hs +++ b/Src/Pattern/Coverage.hs @@ -16,11 +16,11 @@ import Data.List (partition) import Data.List.NonEmpty (NonEmpty ((:|)), fromList, toList) import Data.Maybe (fromJust, mapMaybe) -import Concrete.Base (RawP(..), Binder (..), Variable (..)) +import Concrete.Base (RawP(..), Binder (..), Variable (..), ASyntaxDesc) import Location (unknown) import Pattern (Pat'(..)) import Scope (Scope(..)) -import Syntax ( SyntaxDesc, VSyntaxDesc'(..), WithSyntaxCat(..), SyntaxTable, VSyntaxDesc, SyntaxCat +import Syntax ( VSyntaxDesc'(..), WithSyntaxCat(..), SyntaxTable, VSyntaxDesc, SyntaxCat , expand', contract, expand) import Thin (is1s) import Hide (Hide(Hide)) @@ -69,7 +69,7 @@ data Covering' sd [sd] -- what is left to cover deriving (Functor) -type Covering = Covering' SyntaxDesc +type Covering = Covering' ASyntaxDesc ------------------------------------------------------------------------------ -- Views @@ -139,16 +139,16 @@ combine covs = case partition (isAlreadyCovered . snd) covs of -- Postcondition: -- If `shrinkBy table desc pat` is `PartiallyCovering ps qs` then -- `desc` is morally equivalent to the sum (ps + qs) -shrinkBy :: forall s. SyntaxTable -> SyntaxDesc -> Pat' s -> Covering +shrinkBy :: forall s. SyntaxTable -> ASyntaxDesc -> Pat' s -> Covering shrinkBy table = start where - start :: SyntaxDesc -> Pat' s -> Covering + start :: ASyntaxDesc -> Pat' s -> Covering start desc = go (desc, fromJust (expand table desc)) - starts :: [SyntaxDesc] -> Pat' s -> Covering' [SyntaxDesc] + starts :: [ASyntaxDesc] -> Pat' s -> Covering' [ASyntaxDesc] starts descs = gos (map (\ d -> (d, fromJust (expand table d))) descs) - gos :: [(SyntaxDesc, VSyntaxDesc)] -> Pat' s -> Covering' [SyntaxDesc] + gos :: [(ASyntaxDesc, VSyntaxDesc)] -> Pat' s -> Covering' [ASyntaxDesc] gos [] (AP "") = Covering gos (d:ds) (PP p ps) = case (go d p, gos ds ps) of (Covering, Covering) -> Covering @@ -165,7 +165,7 @@ shrinkBy table = start where PartiallyCovering (map (fst d :) p2) (map (fst d :) p2s) gos _ _ = error "Impossible" - go :: (SyntaxDesc, VSyntaxDesc) -> Pat' s -> Covering + go :: (ASyntaxDesc, VSyntaxDesc) -> Pat' s -> Covering go desc (AT s pat) = go desc pat go (desc, _) (VP db) = PartiallyCovering [] [desc] -- TODO: handle bound variables too go (desc, vdesc) (AP s) = contract <$> case vdesc of @@ -263,13 +263,13 @@ shrinkBy table = start where go (desc, vdesc) GP = PartiallyCovering [] [desc] go _ HP = Covering -missing :: SyntaxTable -> SyntaxDesc -> NonEmpty RawP +missing :: SyntaxTable -> ASyntaxDesc -> NonEmpty RawP missing table desc = fmap (`evalState` names) (start desc) where -- Each solution is a computation using its own name supply because -- there is no reason for us not to reuse the same name in independent -- patterns e.g. ['Leaf a] and ['Node a b c]. - start :: SyntaxDesc -> NonEmpty (State [String] RawP) + start :: ASyntaxDesc -> NonEmpty (State [String] RawP) start = go . fromJust . expand' Yes table -- "a", "b", ..., "z", "a1", "b1", ... diff --git a/Src/Syntax.hs b/Src/Syntax.hs index 4816e31..c4100a5 100644 --- a/Src/Syntax.hs +++ b/Src/Syntax.hs @@ -8,27 +8,29 @@ import Data.Map (Map) import qualified Data.Map as Map import Bwd -import Thin (CdB(..), DB(..), weak, scope, lsb) +import Concrete.Base (SYNTAXDESC, Phase(..), ASyntaxDesc, ASemanticsDesc) +import Thin (CdB(..), DB(..), weak, scope, lsb, ($^)) import Term hiding (contract, expand) type SyntaxCat = String type SyntaxDesc = CdB (Tm Void) - type SyntaxTable = Map SyntaxCat SyntaxDesc +type instance SYNTAXDESC Abstract = SyntaxDesc + data VSyntaxDesc' a = VAtom | VAtomBar [String] | VNil - | VCons SyntaxDesc SyntaxDesc - | VNilOrCons SyntaxDesc SyntaxDesc - | VBind SyntaxCat SyntaxDesc - | VEnumOrTag [String] [(String, [SyntaxDesc])] + | VCons ASyntaxDesc ASyntaxDesc + | VNilOrCons ASyntaxDesc ASyntaxDesc + | VBind SyntaxCat ASyntaxDesc + | VEnumOrTag [String] [(String, [ASyntaxDesc])] | VWildcard | VSyntaxCat a deriving (Eq, Show) -wildcard :: SyntaxDesc +wildcard :: ASyntaxDesc wildcard = contract VWildcard type VSyntaxDesc = VSyntaxDesc' Void @@ -37,10 +39,10 @@ data WithSyntaxCat a where Yes :: WithSyntaxCat SyntaxCat No :: WithSyntaxCat Void -asRec :: OrBust x => (SyntaxCat -> x) -> SyntaxDesc -> x +asRec :: OrBust x => (SyntaxCat -> x) -> ASyntaxDesc -> x asRec f = asAtom $ \ (at, _) -> f at -expand' :: WithSyntaxCat a -> SyntaxTable -> SyntaxDesc -> Maybe (VSyntaxDesc' a) +expand' :: WithSyntaxCat a -> SyntaxTable -> ASyntaxDesc -> Maybe (VSyntaxDesc' a) expand' w table = go True where go b s = ($ s) $ asAtomOrTagged (goAtoms b) (goTagged b s) @@ -71,13 +73,13 @@ expand' w table = go True where "Fix" -> asPair $ asBind $ \ x s' _ -> go False (s' //^ topSbst x s) _ -> bust -expand :: SyntaxTable -> SyntaxDesc -> Maybe VSyntaxDesc +expand :: SyntaxTable -> ASyntaxDesc -> Maybe VSyntaxDesc expand = expand' No -embed :: SyntaxDesc -> ASemanticsDesc -embed = fmap absurd +embed :: ASyntaxDesc -> ASemanticsDesc +embed = (fmap absurd $^) -contract' :: WithSyntaxCat a -> VSyntaxDesc' a -> SyntaxDesc +contract' :: WithSyntaxCat a -> VSyntaxDesc' a -> ASyntaxDesc contract' w = \case VAtom -> atom "Atom" 0 VAtomBar xs -> "AtomBar" #%+ [enums (\ s -> atom s 0) xs] @@ -94,16 +96,16 @@ contract' w = \case where enums f = foldr (%) (nil 0) . map f -contract :: VSyntaxDesc -> SyntaxDesc +contract :: VSyntaxDesc -> ASyntaxDesc contract = contract' No -catToDesc :: SyntaxCat -> SyntaxDesc +catToDesc :: SyntaxCat -> ASyntaxDesc catToDesc c = atom c 0 -validate :: Show m => SyntaxTable -> Bwd SyntaxCat -> SyntaxDesc -> CdB (Tm m) -> Bool +validate :: Show m => SyntaxTable -> Bwd SyntaxCat -> ASyntaxDesc -> CdB (Tm m) -> Bool validate table = go where - go :: Show m => Bwd SyntaxCat -> SyntaxDesc -> CdB (Tm m) -> Bool + go :: Show m => Bwd SyntaxCat -> ASyntaxDesc -> CdB (Tm m) -> Bool go env s t@(CdB V th) = reportError s t $ ($ s) $ asRec $ \ a -> a == env asAtom $ \ (a,_) -> not (null a) @@ -118,22 +120,22 @@ validate table = go where Just ss -> gos env ss t) VWildcard -> \ _ -> True - reportError :: Show m => SyntaxDesc -> CdB (Tm m) -> Bool -> Bool + reportError :: Show m => ASyntaxDesc -> CdB (Tm m) -> Bool -> Bool reportError d t True = True reportError d t False = False -- error $ "Validation error\nDesc: " ++ show d ++ "\nTerm: " ++ show t - gos :: Show m => Bwd SyntaxCat -> [SyntaxDesc] -> CdB (Tm m) -> Bool + gos :: Show m => Bwd SyntaxCat -> [ASyntaxDesc] -> CdB (Tm m) -> Bool gos env [] = asNil True gos env (s:ss) = asPair $ \ t0 t1 -> go env s t0 && gos env ss t1 -listOf :: String -> SyntaxDesc -> SyntaxDesc +listOf :: String -> ASyntaxDesc -> ASyntaxDesc listOf x d = let ga = scope d + 1 in "Fix" #%+ [x \\ (atom "NilOrCons" ga % (weak d % var (DB 0) ga % nil ga))] -rec :: String -> SyntaxDesc +rec :: String -> ASyntaxDesc rec a = atom a 0 -syntaxDesc :: [SyntaxCat] -> SyntaxDesc +syntaxDesc :: [SyntaxCat] -> ASyntaxDesc syntaxDesc syns = "EnumOrTag" #%+ [ enums (atoms ++ syns), (atom "AtomBar" 0 % (listOf "at" atom0 % nil 0)) % @@ -168,7 +170,7 @@ syntaxDesc syns = "EnumOrTag" #%+ [ -} -validateDesc :: [SyntaxCat] -> SyntaxDesc -> Bool +validateDesc :: [SyntaxCat] -> ASyntaxDesc -> Bool validateDesc syns = validate (Map.fromList known) B0 (rec "Syntax") @@ -176,5 +178,5 @@ validateDesc syns = known = [ ("Syntax", syntaxDesc syns) , ("Semantics", wildcard)] -- TODO : change - + validateIt = validateDesc ["Syntax"] (syntaxDesc ["Syntax"]) diff --git a/Src/Unelaboration.hs b/Src/Unelaboration.hs index 87850dd..ed1b0c7 100644 --- a/Src/Unelaboration.hs +++ b/Src/Unelaboration.hs @@ -19,6 +19,7 @@ import Format import Hide import Pattern import Scope +import Syntax() import Term.Base import Thin import Location (unknown) diff --git a/TODO.md b/TODO.md index cd11b4c..d248e1a 100644 --- a/TODO.md +++ b/TODO.md @@ -88,6 +88,8 @@ * [ ] Drop run-length encoding subst in favour of relevant subst * [ ] Match monad for Matching (Env in a state) * [ ] `keyword` pretty printing should use the data type of keywords +* [ ] `class Declarable a where { declare :: a -> Context -> Context }` + instead of declareObjVar, declareChannel, declareXXX ### Pretty From b4d21e6a8987dd370370624c19b87e4feea7bdb7 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Fri, 4 Nov 2022 17:26:58 +0000 Subject: [PATCH 13/89] [ minor ] contextual info for judgementform --- Src/Command.hs | 2 +- Src/Elaboration/Monad.hs | 1 + Src/Elaboration/Pretty.hs | 1 + 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/Src/Command.hs b/Src/Command.hs index 8bb21c5..b28e088 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -338,7 +338,7 @@ scommand = \case pure (DeclJudgementForm j, gs) sjudgementform :: JUDGEMENTFORM Concrete -> Elab (JUDGEMENTFORM Abstract, Globals) -sjudgementform JudgementForm{..} = do +sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do inputs <- concat <$> traverse subjects jpreconds -- TODO: should really be the closure of this info outputs <- concat <$> traverse subjects [ x | Left x <- jpostconds ] let names = map fst jplaces diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 28487a7..97f07f3 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -352,6 +352,7 @@ data ContextualInfo | ScrutineeTermElaboration Raw | MatchScrutineeElaboration CScrutinee | CompareSyntaxCatGuess Raw Raw + | JudgementFormElaboration Variable deriving (Show) data Complaint diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index 6faa726..dff2abe 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -104,6 +104,7 @@ instance Pretty ContextualInfo where TermVariableElaboration v -> hsep ["when elaborating the term variable", pretty v] ProtocolElaboration p -> hsep ["when elaborating the protocol", pretty p] ConnectElaboration ch1 ch2 -> hsep ["when elaborating the connection", pretty ch1, "<->", pretty ch2] + JudgementFormElaboration v -> hsep ["when elaborting the judgement form", pretty v] instance Pretty Complaint where pretty c = flush (pretty (getRange c)) <> case c of From 40bf58e185869f70a5a34aebb6edcc13710dfd4e Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Fri, 4 Nov 2022 18:05:15 +0000 Subject: [PATCH 14/89] [ rule ] error reporting for citizen vs. subject mismatch --- Src/Command.hs | 26 ++++++++++++++++++++++---- Src/Elaboration/Monad.hs | 6 ++++++ Src/Elaboration/Pretty.hs | 11 ++++++++++- Src/Utils.hs | 9 +++++++++ test/golden/missinginput.gold | 11 +++++++++++ test/missinginput.act | 22 ++++++++++++++++++++++ 6 files changed, 80 insertions(+), 5 deletions(-) create mode 100644 test/golden/missinginput.gold create mode 100644 test/missinginput.act diff --git a/Src/Command.hs b/Src/Command.hs index b28e088..f098d15 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -8,9 +8,10 @@ import Control.Monad.Reader import Control.Monad.State import Data.Bifunctor (first) -import Data.List (sort) +import Data.Function (on) +import Data.List (sort, sortBy) import qualified Data.Map as Map -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, catMaybes) import Data.Traversable (for) import Data.These @@ -343,13 +344,30 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do outputs <- concat <$> traverse subjects [ x | Left x <- jpostconds ] let names = map fst jplaces let citizenNames = [x | (x, CitizenPlace) <- jplaces] + let inputNames = map fst inputs + let outputNames = map fst outputs whenLeft (allUnique names) $ \ a -> throwError $ DuplicatedPlace (getRange a) a - -- TODO : report with a proper error on the mismatch between the subject and citizen positions - unless (sort citizenNames == sort (map fst $ inputs ++ outputs)) $ throwError $ undefined + whenLeft (allUnique inputNames) $ \ a -> throwError $ DuplicatedInput (getRange a) a + whenLeft (allUnique outputNames) $ \ a -> throwError $ DuplicatedOutput (getRange a) a + whenCons (mismatch citizenNames inputNames outputNames) $ \ (v, m) _ -> + throwError (ProtocolCitizenSubjectMismatch (getRange v) v m) protocol <- traverse (citizenJudgement inputs outputs) jplaces undefined -- TODO where + mismatch :: [Variable] + -> [Variable] + -> [Variable] + -> [(Variable, Mode ())] + mismatch cs is os = + catMaybes $ alignWith check (sort cs) + $ sortBy (compare `on` fst) + $ map (, Input) is ++ map (, Output) os + + check :: These Variable (Variable, Mode ()) -> Maybe (Variable, Mode ()) + check (These a b) = (a, Subject ()) <$ guard (a /= fst b) + check t = Just (mergeThese const (first (, Subject ()) t)) + subjects :: JUDGEMENT Concrete -> Elab [(Variable, ASemanticsDesc)] subjects (Judgement r name fms) = do IsJudgement{..} <- isJudgement name diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 97f07f3..32f907f 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -388,6 +388,9 @@ data Complaint | JudgementWrongArity Range JudgementName AProtocol [CFormula] | UnexpectedNonSubject Range CFormula | DuplicatedPlace Range Variable + | DuplicatedInput Range Variable + | DuplicatedOutput Range Variable + | ProtocolCitizenSubjectMismatch Range Variable (Mode ()) -- syntaxes | AlreadyDeclaredSyntaxCat Range SyntaxCat -- syntaxdesc validation @@ -444,6 +447,9 @@ instance HasGetRange Complaint where JudgementWrongArity r _ _ _ -> r UnexpectedNonSubject r _ -> r DuplicatedPlace r _ -> r + DuplicatedInput r _ -> r + DuplicatedOutput r _ -> r + ProtocolCitizenSubjectMismatch r _ _ -> r -- syntaxes AlreadyDeclaredSyntaxCat r _ -> r -- syntaxdesc validation diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index dff2abe..3737419 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -7,7 +7,7 @@ import Data.These import ANSI hiding (withANSI) import Actor (ActorMeta(..), Channel(..), Stack(..), AProtocol) -import Concrete.Base (Binder (..), PROTOCOL(Protocol)) +import Concrete.Base (Binder (..), PROTOCOL(Protocol), Mode (..)) import Concrete.Pretty() import Elaboration.Monad import Location @@ -163,6 +163,15 @@ instance Pretty Complaint where hsep ["Judgement", pretty name, applied] UnexpectedNonSubject r fm -> hsep ["Unexpected non-subject", pretty fm] DuplicatedPlace r v -> hsep ["Duplicated place", pretty v] + DuplicatedInput r v -> hsep ["Duplicated input", pretty v] + DuplicatedOutput r v -> hsep ["Duplicated output", pretty v] + ProtocolCitizenSubjectMismatch r v m -> + let (seen, unseen) = case m of + Input -> ("an input", "not as a subject") + Subject{} -> ("a subject", "neither as an input nor an output") + Output -> ("an output", "not as a subject") + in hsep ["Found", pretty v, "as", seen, "but", unseen ] + -- syntaxes AlreadyDeclaredSyntaxCat r x -> hsep ["The syntactic category", pretty x, "is already defined"] diff --git a/Src/Utils.hs b/Src/Utils.hs index 50e0f0e..1688840 100644 --- a/Src/Utils.hs +++ b/Src/Utils.hs @@ -2,6 +2,7 @@ module Utils where import Data.Set (Set) import qualified Data.Set as Set +import Data.These (These(..)) import Control.Monad.State @@ -18,6 +19,10 @@ isAll p (x:xs) = do if p x then pure () else Left x isAll p xs +whenCons :: Applicative m => [a] -> (a -> [a] -> m ()) -> m () +whenCons [] k = pure () +whenCons (a:as) k = k a as + whenLeft :: Applicative m => Either a b -> (a -> m ()) -> m () whenLeft (Left a) k = k a whenLeft (Right _) k = pure () @@ -55,3 +60,7 @@ allUnique = flip foldr (pure Set.empty) $ \ a acc -> do s <- acc if a `Set.member` s then Left a else Right (Set.insert a s) +alignWith :: (These a b -> c) -> [a] -> [b] -> [c] +alignWith f [] bs = map (f . That) bs +alignWith f as [] = map (f . This) as +alignWith f (a:as) (b:bs) = f (These a b) : alignWith f as bs diff --git a/test/golden/missinginput.gold b/test/golden/missinginput.gold new file mode 100644 index 0000000..e51e7b6 --- /dev/null +++ b/test/golden/missinginput.gold @@ -0,0 +1,11 @@ +ret > ExitFailure 1 +out > Error +out > +out > 19 | judgementform +out > 20 | {} +out > 21 | check T (t : 'Check => T - 'Value) +out > ^ +out > missinginput.act:21:8-9 +out > Found T as a subject but neither as an input nor an output +out > when elaborting the judgement form check +out > diff --git a/test/missinginput.act b/test/missinginput.act new file mode 100644 index 0000000..7878265 --- /dev/null +++ b/test/missinginput.act @@ -0,0 +1,22 @@ +------------------------------------------------------------------------------ +-- Datatypes + +syntax + { 'Type = ['EnumOrTag ['Nat] + [['Arr 'Type 'Type]] + ] + } + +syntax + { 'Check = ['Tag [ ['Lam ['Bind 'Synth 'Check]] + ['Emb 'Synth] + ]] + ; 'Synth = ['Tag [ ['Ann 'Check 'Type] + ['App 'Synth 'Check] + ]] + } + +judgementform + {} + check T (t : 'Check => T - 'Value) + {} From 43244fb083eff99860ed2c1fbb547ded7faded2b Mon Sep 17 00:00:00 2001 From: "G. Allais" Date: Fri, 4 Nov 2022 18:09:52 +0000 Subject: [PATCH 15/89] Update Src/Elaboration/Pretty.hs --- Src/Elaboration/Pretty.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index 3737419..a2c3310 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -104,7 +104,7 @@ instance Pretty ContextualInfo where TermVariableElaboration v -> hsep ["when elaborating the term variable", pretty v] ProtocolElaboration p -> hsep ["when elaborating the protocol", pretty p] ConnectElaboration ch1 ch2 -> hsep ["when elaborating the connection", pretty ch1, "<->", pretty ch2] - JudgementFormElaboration v -> hsep ["when elaborting the judgement form", pretty v] + JudgementFormElaboration v -> hsep ["when elaborating the judgement form", pretty v] instance Pretty Complaint where pretty c = flush (pretty (getRange c)) <> case c of From dc7da1d0cf7b1bff7c06d7406e93f99f927501d5 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Sat, 5 Nov 2022 11:12:41 +0000 Subject: [PATCH 16/89] [ fix ] better error messages --- Src/Command.hs | 11 +++++++++-- Src/Elaboration/Monad.hs | 2 ++ Src/Elaboration/Pretty.hs | 7 ++++--- test/bothinputoutput.act | 24 ++++++++++++++++++++++++ test/duplicatedinput.act | 24 ++++++++++++++++++++++++ test/duplicatedoutput.act | 24 ++++++++++++++++++++++++ test/golden/bothinputoutput.gold | 11 +++++++++++ test/golden/duplicatedinput.gold | 11 +++++++++++ test/golden/duplicatedoutput.gold | 11 +++++++++++ test/golden/missinginput.gold | 2 +- 10 files changed, 121 insertions(+), 6 deletions(-) create mode 100644 test/bothinputoutput.act create mode 100644 test/duplicatedinput.act create mode 100644 test/duplicatedoutput.act create mode 100644 test/golden/bothinputoutput.gold create mode 100644 test/golden/duplicatedinput.gold create mode 100644 test/golden/duplicatedoutput.gold diff --git a/Src/Command.hs b/Src/Command.hs index f098d15..b96ac97 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -41,6 +41,7 @@ import Location import Utils import Data.Char (isSpace) +import qualified Data.Set as Set type family SYNTAXCAT (ph :: Phase) :: * type instance SYNTAXCAT Concrete = WithRange SyntaxCat @@ -347,8 +348,14 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do let inputNames = map fst inputs let outputNames = map fst outputs whenLeft (allUnique names) $ \ a -> throwError $ DuplicatedPlace (getRange a) a - whenLeft (allUnique inputNames) $ \ a -> throwError $ DuplicatedInput (getRange a) a - whenLeft (allUnique outputNames) $ \ a -> throwError $ DuplicatedOutput (getRange a) a + inputNamesSet <- case allUnique inputNames of + Left a -> throwError $ DuplicatedInput (getRange a) a + Right as -> pure as + outputNamesSet <- case allUnique outputNames of + Left a -> throwError $ DuplicatedOutput (getRange a) a + Right as -> pure as + whenCons (Set.toList (Set.intersection inputNamesSet outputNamesSet)) $ \ a _ -> + throwError $ BothInputOutput (getRange a) a whenCons (mismatch citizenNames inputNames outputNames) $ \ (v, m) _ -> throwError (ProtocolCitizenSubjectMismatch (getRange v) v m) protocol <- traverse (citizenJudgement inputs outputs) jplaces diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 32f907f..e034f7e 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -390,6 +390,7 @@ data Complaint | DuplicatedPlace Range Variable | DuplicatedInput Range Variable | DuplicatedOutput Range Variable + | BothInputOutput Range Variable | ProtocolCitizenSubjectMismatch Range Variable (Mode ()) -- syntaxes | AlreadyDeclaredSyntaxCat Range SyntaxCat @@ -449,6 +450,7 @@ instance HasGetRange Complaint where DuplicatedPlace r _ -> r DuplicatedInput r _ -> r DuplicatedOutput r _ -> r + BothInputOutput r _ -> r ProtocolCitizenSubjectMismatch r _ _ -> r -- syntaxes AlreadyDeclaredSyntaxCat r _ -> r diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index a2c3310..b3959b3 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -162,9 +162,10 @@ instance Pretty Complaint where let applied = (if length protocol > length fms then "under" else "over") <> "-applied" in hsep ["Judgement", pretty name, applied] UnexpectedNonSubject r fm -> hsep ["Unexpected non-subject", pretty fm] - DuplicatedPlace r v -> hsep ["Duplicated place", pretty v] - DuplicatedInput r v -> hsep ["Duplicated input", pretty v] - DuplicatedOutput r v -> hsep ["Duplicated output", pretty v] + DuplicatedPlace r v -> hsep [pretty v, "is a duplicated place" ] + DuplicatedInput r v -> hsep [pretty v, "is a duplicated input"] + DuplicatedOutput r v -> hsep [pretty v, "is a duplicated output"] + BothInputOutput r v -> hsep [pretty v, "is both an input and an output"] ProtocolCitizenSubjectMismatch r v m -> let (seen, unseen) = case m of Input -> ("an input", "not as a subject") diff --git a/test/bothinputoutput.act b/test/bothinputoutput.act new file mode 100644 index 0000000..e3c81c3 --- /dev/null +++ b/test/bothinputoutput.act @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- Datatypes + +syntax + { 'Type = ['EnumOrTag ['Nat] + [['Arr 'Type 'Type]] + ] + } + +syntax + { 'Check = ['Tag [ ['Lam ['Bind 'Synth 'Check]] + ['Emb 'Synth] + ]] + ; 'Synth = ['Tag [ ['Ann 'Check 'Type] + ['App 'Synth 'Check] + ]] + } + +type : $'Type. + +judgementform + {type T} + check T (t : 'Check => T - 'Value) + {type T} diff --git a/test/duplicatedinput.act b/test/duplicatedinput.act new file mode 100644 index 0000000..e4f50a5 --- /dev/null +++ b/test/duplicatedinput.act @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- Datatypes + +syntax + { 'Type = ['EnumOrTag ['Nat] + [['Arr 'Type 'Type]] + ] + } + +syntax + { 'Check = ['Tag [ ['Lam ['Bind 'Synth 'Check]] + ['Emb 'Synth] + ]] + ; 'Synth = ['Tag [ ['Ann 'Check 'Type] + ['App 'Synth 'Check] + ]] + } + +type : $'Type. + +judgementform + {type T ; type T} + check T (t : 'Check => T - 'Value) + {} diff --git a/test/duplicatedoutput.act b/test/duplicatedoutput.act new file mode 100644 index 0000000..e3e02cf --- /dev/null +++ b/test/duplicatedoutput.act @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- Datatypes + +syntax + { 'Type = ['EnumOrTag ['Nat] + [['Arr 'Type 'Type]] + ] + } + +syntax + { 'Check = ['Tag [ ['Lam ['Bind 'Synth 'Check]] + ['Emb 'Synth] + ]] + ; 'Synth = ['Tag [ ['Ann 'Check 'Type] + ['App 'Synth 'Check] + ]] + } + +type : $'Type. + +judgementform + {} + check T (t : 'Check => T - 'Value) + {type T ; type T} diff --git a/test/golden/bothinputoutput.gold b/test/golden/bothinputoutput.gold new file mode 100644 index 0000000..48694a1 --- /dev/null +++ b/test/golden/bothinputoutput.gold @@ -0,0 +1,11 @@ +ret > ExitFailure 1 +out > Error +out > +out > 20 | +out > 21 | judgementform +out > 22 | {type T} +out > ^ +out > bothinputoutput.act:22:8-9 +out > T is both an input and an output +out > when elaborating the judgement form check +out > diff --git a/test/golden/duplicatedinput.gold b/test/golden/duplicatedinput.gold new file mode 100644 index 0000000..52e0670 --- /dev/null +++ b/test/golden/duplicatedinput.gold @@ -0,0 +1,11 @@ +ret > ExitFailure 1 +out > Error +out > +out > 20 | +out > 21 | judgementform +out > 22 | {type T ; type T} +out > ^ +out > duplicatedinput.act:22:8-9 +out > T is a duplicated input +out > when elaborating the judgement form check +out > diff --git a/test/golden/duplicatedoutput.gold b/test/golden/duplicatedoutput.gold new file mode 100644 index 0000000..f33f6fc --- /dev/null +++ b/test/golden/duplicatedoutput.gold @@ -0,0 +1,11 @@ +ret > ExitFailure 1 +out > Error +out > +out > 22 | {} +out > 23 | check T (t : 'Check => T - 'Value) +out > 24 | {type T ; type T} +out > ^ +out > duplicatedoutput.act:24:8-9 +out > T is a duplicated output +out > when elaborating the judgement form check +out > diff --git a/test/golden/missinginput.gold b/test/golden/missinginput.gold index e51e7b6..31f2b91 100644 --- a/test/golden/missinginput.gold +++ b/test/golden/missinginput.gold @@ -7,5 +7,5 @@ out > 21 | check T (t : 'Check => T - 'Value) out > ^ out > missinginput.act:21:8-9 out > Found T as a subject but neither as an input nor an output -out > when elaborting the judgement form check +out > when elaborating the judgement form check out > From b86d8ba28dc6bbf21996388be540fb82e229c342 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Wed, 9 Nov 2022 16:12:15 +0000 Subject: [PATCH 17/89] [ wip ] progress on elaborating judgement forms --- Src/Command.hs | 58 +++++++++++++++++++++++++++------------ Src/Concrete/Parse.hs | 4 +++ Src/Elaboration.hs | 6 ++-- Src/Elaboration/Monad.hs | 5 +++- Src/Elaboration/Pretty.hs | 3 ++ Src/Machine/Base.hs | 8 +++--- Src/Rules.hs | 35 ++++++++++++----------- TODO.md | 1 + examples/stlcRules.act | 7 +++-- 9 files changed, 83 insertions(+), 44 deletions(-) diff --git a/Src/Command.hs b/Src/Command.hs index b96ac97..2caf4b9 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -7,13 +7,16 @@ import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State -import Data.Bifunctor (first) +import Data.Bifunctor (bimap, first) import Data.Function (on) import Data.List (sort, sortBy) +import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe, catMaybes) import Data.Traversable (for) import Data.These +import Data.Either +import Data.Foldable (fold) import Actor import Actor.Display () @@ -273,7 +276,7 @@ sdeclOps ((AnOperator (WithRange r opname) objDesc paramDescs retDesc) : ops) = syndecls <- gets (Map.keys . syntaxCats) objDesc <- ssyntaxdesc syndecls objDesc paramDescs <- traverse (ssyntaxdesc syndecls) paramDescs - retDesc <- ssyntaxdesc syndecls retDesc + retDesc <- ssemanticsdesc retDesc let op = AnOperator opname objDesc paramDescs retDesc (ops, decls) <- local (addOperator op) $ sdeclOps ops pure (op : ops, decls) @@ -339,12 +342,14 @@ scommand = \case (j , gs) <- sjudgementform j pure (DeclJudgementForm j, gs) -sjudgementform :: JUDGEMENTFORM Concrete -> Elab (JUDGEMENTFORM Abstract, Globals) -sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do - inputs <- concat <$> traverse subjects jpreconds -- TODO: should really be the closure of this info - outputs <- concat <$> traverse subjects [ x | Left x <- jpostconds ] - let names = map fst jplaces - let citizenNames = [x | (x, CitizenPlace) <- jplaces] +checkCompatiblePlaces :: [PLACE Concrete] -> + [(Variable, ASemanticsDesc)] -> + [(Variable, ASemanticsDesc)] -> + Elab () +checkCompatiblePlaces places inputs outputs = do + -- Make sure subject protocol can be found unambiguously + let names = map fst places + let citizenNames = [x | (x, CitizenPlace) <- places] let inputNames = map fst inputs let outputNames = map fst outputs whenLeft (allUnique names) $ \ a -> throwError $ DuplicatedPlace (getRange a) a @@ -358,9 +363,6 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do throwError $ BothInputOutput (getRange a) a whenCons (mismatch citizenNames inputNames outputNames) $ \ (v, m) _ -> throwError (ProtocolCitizenSubjectMismatch (getRange v) v m) - protocol <- traverse (citizenJudgement inputs outputs) jplaces - undefined -- TODO - where mismatch :: [Variable] -> [Variable] @@ -375,6 +377,22 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do check (These a b) = (a, Subject ()) <$ guard (a /= fst b) check t = Just (mergeThese const (first (, Subject ()) t)) + +sjudgementform :: JUDGEMENTFORM Concrete -> Elab (JUDGEMENTFORM Abstract, Globals) +sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do + inputs <- concat <$> traverse subjects jpreconds -- TODO: should really be the closure of this info + let (outputs, operators) = partitionEithers jpostconds + outputs <- concat <$> traverse subjects outputs + checkCompatiblePlaces jplaces inputs outputs + (protocol, subjectKinds) <- bimap Protocol fold . unzip + <$> traverse (citizenJudgement inputs outputs) jplaces + jname <- isFresh jname + local (declare (Used jname) (AJudgement jextractmode protocol)) $ do + (operators, gs) <- sdeclOps =<< traverse (kindify subjectKinds) operators + pure ((jextractmode, jname, protocol), gs) + + + where subjects :: JUDGEMENT Concrete -> Elab [(Variable, ASemanticsDesc)] subjects (Judgement r name fms) = do IsJudgement{..} <- isJudgement name @@ -388,19 +406,25 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do (x, _) -> throwError $ UnexpectedNonSubject r x citizenJudgement :: [(Variable, ASemanticsDesc)] -> [(Variable, ASemanticsDesc)] - -> CPlace -> Elab (PROTOCOLENTRY Abstract) + -> CPlace -> Elab (PROTOCOLENTRY Abstract, Map Variable CSyntaxDesc) citizenJudgement inputs outputs (name, place) = case place of CitizenPlace -> case (lookup name inputs, lookup name outputs) of - (Just isem, Nothing) -> pure (Input, isem) - (Nothing, Just osem) -> pure (Output, osem) + (Just isem, Nothing) -> pure ((Input, isem), Map.empty) + (Nothing, Just osem) -> pure ((Output, osem), Map.empty) _ -> error "Impossible in citizenJudgement" - SubjectPlace syn sem -> do + SubjectPlace rsyn sem -> do syndecls <- gets (Map.keys . syntaxCats) - syn <- ssyntaxdesc syndecls syn + syn <- ssyntaxdesc syndecls rsyn sem <- ssemanticsdesc sem - pure (Subject syn, sem) + pure ((Subject syn, sem), Map.singleton name rsyn) + + kindify :: Map Variable CSyntaxDesc -> CAnOperator -> Elab CAnOperator + kindify m op + | Var _ x <- objDesc op + , Just syn <- Map.lookup x m = pure (op { objDesc = syn}) + | otherwise = throwError (MalformedPostOperator (getRange (objDesc op)) (theValue (opName op))) -- | sopargs desc cops diff --git a/Src/Concrete/Parse.hs b/Src/Concrete/Parse.hs index 68a2f66..79d0995 100644 --- a/Src/Concrete/Parse.hs +++ b/Src/Concrete/Parse.hs @@ -108,6 +108,9 @@ pprotocol = Protocol <$> psep pspc psyntaxdecl :: Parser Raw psyntaxdecl = pTM +psemanticsdecl :: Parser Raw +psemanticsdecl = pTM + pcontextstack :: Parser (ContextStack Raw) pcontextstack = ContextStack <$> psyntaxdecl @@ -133,6 +136,7 @@ withVars con px str pa = do pure (xs, a) pure $ foldr (curry (con r)) a xs +-- Warning: breaks convention and consumes trailing space pextractmode :: Parser ExtractMode pextractmode = TopLevelExtract <$ pch (== '/') <* pspc diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 85ac4e4..a18ce5e 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -131,8 +131,8 @@ ssyntaxdesc syndecls syn = do ssemanticsdesc :: CSemanticsDesc -> Elab ASemanticsDesc ssemanticsdesc sem = do syndecls <- gets (Map.keys . syntaxCats) - ssyntaxdesc syndecls sem - -- TOOD: use stm to actually be able to use operators & actor vars + ssyntaxdesc ("Universe":syndecls) sem + -- TODO: use stm to actually be able to use operators & actor vars -- DontLog (catToDesc "Semantics") ssbst :: Usage -> Bwd SbstC -> Elab (ACTSbst, ObjVars) @@ -413,7 +413,7 @@ isChannel ch = resolve ch >>= \case Just mk -> throwError (NotAValidChannel (getRange ch) ch $ either Just (const Nothing) mk) Nothing -> throwError (OutOfScope (getRange ch) ch) -isOperator :: Range -> String -> Elab (SyntaxDesc, [SyntaxDesc], SyntaxDesc) +isOperator :: Range -> String -> Elab (SyntaxDesc, [SyntaxDesc], ASemanticsDesc) isOperator r nm = do ops <- asks operators case Map.lookup nm ops of diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index e034f7e..f247de2 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -194,7 +194,7 @@ data Kind deriving (Show) type Decls = Bwd (String, Kind) -type Operators = Map String (SyntaxDesc, [SyntaxDesc], SyntaxDesc) +type Operators = Map String (SyntaxDesc, [SyntaxDesc], ASemanticsDesc) data Context = Context { objVars :: ObjVars @@ -385,6 +385,7 @@ data Complaint | ProtocolsNotDual Range AProtocol AProtocol | IncompatibleModes Range AProtocolEntry AProtocolEntry | WrongDirection Range AProtocolEntry Ordering AProtocolEntry + -- judgementforms | JudgementWrongArity Range JudgementName AProtocol [CFormula] | UnexpectedNonSubject Range CFormula | DuplicatedPlace Range Variable @@ -392,6 +393,7 @@ data Complaint | DuplicatedOutput Range Variable | BothInputOutput Range Variable | ProtocolCitizenSubjectMismatch Range Variable (Mode ()) + | MalformedPostOperator Range String -- syntaxes | AlreadyDeclaredSyntaxCat Range SyntaxCat -- syntaxdesc validation @@ -452,6 +454,7 @@ instance HasGetRange Complaint where DuplicatedOutput r _ -> r BothInputOutput r _ -> r ProtocolCitizenSubjectMismatch r _ _ -> r + MalformedPostOperator r _ -> r -- syntaxes AlreadyDeclaredSyntaxCat r _ -> r -- syntaxdesc validation diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index b3959b3..c5c8074 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -158,6 +158,8 @@ instance Pretty Complaint where hsep [ "Channels scopes", collapse (pretty <$> sc1) , "and", collapse (pretty <$> sc2), "are incompatible"] WrongDirection r m1 dir m2 -> hsep ["Wrong direction", pretty (show dir), "between", pretty m1, "and", pretty m2] + + -- judgementforms JudgementWrongArity r name (Protocol protocol) fms -> let applied = (if length protocol > length fms then "under" else "over") <> "-applied" in hsep ["Judgement", pretty name, applied] @@ -172,6 +174,7 @@ instance Pretty Complaint where Subject{} -> ("a subject", "neither as an input nor an output") Output -> ("an output", "not as a subject") in hsep ["Found", pretty v, "as", seen, "but", unseen ] + MalformedPostOperator r op -> hsep ["Malformed operator", pretty op] -- syntaxes AlreadyDeclaredSyntaxCat r x -> hsep ["The syntactic category", pretty x, "is already defined"] diff --git a/Src/Machine/Base.hs b/Src/Machine/Base.hs index 8986c10..e671102 100644 --- a/Src/Machine/Base.hs +++ b/Src/Machine/Base.hs @@ -8,7 +8,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set -import Data.Maybe +import Data.Maybe (fromMaybe) import Control.Monad.State import Control.Applicative @@ -22,7 +22,7 @@ import Location (WithRange) import Term import qualified Term.Substitution as Substitution import Thin -import Concrete.Base (Phase(..), Root, Guard, ExtractMode, TERM, PATTERN, ACTOR (..), SYNTAXDESC) +import Concrete.Base import Syntax (SyntaxDesc) import Data.Bifunctor (Bifunctor(first)) @@ -371,7 +371,7 @@ data ANOPERATOR (ph :: Phase) = AnOperator { opName :: OPERATOR ph , objDesc :: SYNTAXDESC ph , paramDescs :: [SYNTAXDESC ph] - , retDesc :: SYNTAXDESC ph + , retDesc :: SEMANTICSDESC ph } deriving instance @@ -433,5 +433,5 @@ panoperator copula = do punc "-" (opname, params) <- poperator psyntaxdecl punc copula - ret <- psyntaxdecl + ret <- psemanticsdecl pure (AnOperator opname obj params ret) diff --git a/Src/Rules.hs b/Src/Rules.hs index 6a5ebca..7b68c8b 100644 --- a/Src/Rules.hs +++ b/Src/Rules.hs @@ -63,16 +63,26 @@ mkSubjectPlace :: SYNTAXDESC Concrete -> Maybe (SEMANTICSDESC Concrete) -> PLACEKIND Concrete mkSubjectPlace syn = SubjectPlace syn . fromMaybe syn -data JUDGEMENTFORM (ph :: Phase) = JudgementForm +data CJudgementForm = JudgementForm { jrange :: Range - , jpreconds :: [JUDGEMENT ph] - , jname :: JUDGEMENTNAME ph - , jplaces :: [PLACE ph] - , jpostconds :: [Either (JUDGEMENT ph) (ANOPERATOR ph)] + , jpreconds :: [JUDGEMENT Concrete] + , jextractmode :: ExtractMode + , jname :: JUDGEMENTNAME Concrete + , jplaces :: [PLACE Concrete] + , jpostconds :: [Either (JUDGEMENT Concrete) (ANOPERATOR Concrete)] } + deriving Show + +type AJudgementForm = (ExtractMode, String, AProtocol) + +instance HasSetRange CJudgementForm where + setRange r (JudgementForm _ a b c d e) = JudgementForm r a b c d e + + +type family JUDGEMENTFORM (ph :: Phase) :: * +type instance JUDGEMENTFORM Concrete = CJudgementForm +type instance JUDGEMENTFORM Abstract = AJudgementForm -instance HasSetRange (JUDGEMENTFORM ph) where - setRange r (JudgementForm _ a b c d) = JudgementForm r a b c d deriving instance ( Show (JUDGEMENTNAME ph) @@ -95,13 +105,6 @@ deriving instance , Show (SEMANTICSDESC ph)) => Show (PLACEKIND ph) -deriving instance - ( Show (JUDGEMENT ph) - , Show (JUDGEMENTNAME ph) - , Show (PLACE ph) - , Show (ANOPERATOR ph)) => - Show (JUDGEMENTFORM ph) - pformula :: Parser CFormula pformula = pcitizen <|> CFormula <$> pthese ppat ptm @@ -126,8 +129,8 @@ pplace :: Parser (PLACE Concrete) pplace = (,CitizenPlace) <$> pvariable <|> pparens ((,) <$> pvariable <* punc ":" <*> (mkSubjectPlace <$> psyntaxdecl <*> optional (id <$ punc "=>" <*> pTM))) -pjudgementform :: Parser (JUDGEMENTFORM Concrete) +pjudgementform :: Parser CJudgementForm pjudgementform = withRange $ JudgementForm unknown <$ pkeyword KwJudgementForm <* pspc <*> pcurlies (psep (punc ";") pjudgement) - <* pspc <*> pvariable + <* pspc <*> pextractmode <*> pvariable <* pspc <*> psep pspc pplace <* pspc <*> pcurlies (psep (punc ";") (Left <$> pjudgement <|> Right <$> panoperator ":")) diff --git a/TODO.md b/TODO.md index d248e1a..b4a0651 100644 --- a/TODO.md +++ b/TODO.md @@ -15,6 +15,7 @@ * [x] irrefutable patterns in binders * [x] literate markdown * [ ] literate LaTeX +* [ ] protect against "redefining" syntax keywords such as 'Atom etc ### Features diff --git a/examples/stlcRules.act b/examples/stlcRules.act index 70aaa9a..5624d1d 100644 --- a/examples/stlcRules.act +++ b/examples/stlcRules.act @@ -23,7 +23,8 @@ syntax -- we're calling in not-'Nat on purpose ] } ------------------------------------------------------------------------------- +{- +----------------------------------------------------------------------------- -- Judgement forms /type : $'Type. @@ -33,7 +34,7 @@ synth : $'Synth. !'Type. -- | myCtxt maps synthesisable variables to types myCtxt |- 'Synth -> 'Type - +-} ------------------------------------------------------------------------------ -- Judgement forms and their contracts @@ -49,7 +50,7 @@ judgementform judgementform {type T} check T (t : 'Check => T - 'Value) - {} + {t - 'Bla : 'Universe} judgementform {} From c9f9a9e0e53d688086fa00819ff24d088ce9e92b Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Wed, 9 Nov 2022 16:33:35 +0000 Subject: [PATCH 18/89] better malformed op error --- Src/Command.hs | 2 +- Src/Elaboration/Monad.hs | 4 ++-- Src/Elaboration/Pretty.hs | 5 ++++- test/golden/malformedPostOp.gold | 11 +++++++++++ test/malformedPostOp.act | 13 +++++++++++++ 5 files changed, 31 insertions(+), 4 deletions(-) create mode 100644 test/golden/malformedPostOp.gold create mode 100644 test/malformedPostOp.act diff --git a/Src/Command.hs b/Src/Command.hs index 2caf4b9..692ab98 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -424,7 +424,7 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do kindify m op | Var _ x <- objDesc op , Just syn <- Map.lookup x m = pure (op { objDesc = syn}) - | otherwise = throwError (MalformedPostOperator (getRange (objDesc op)) (theValue (opName op))) + | otherwise = throwError (MalformedPostOperator (getRange (objDesc op)) (theValue (opName op)) (Map.keys m)) -- | sopargs desc cops diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index f247de2..d315533 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -393,7 +393,7 @@ data Complaint | DuplicatedOutput Range Variable | BothInputOutput Range Variable | ProtocolCitizenSubjectMismatch Range Variable (Mode ()) - | MalformedPostOperator Range String + | MalformedPostOperator Range String [Variable] -- syntaxes | AlreadyDeclaredSyntaxCat Range SyntaxCat -- syntaxdesc validation @@ -454,7 +454,7 @@ instance HasGetRange Complaint where DuplicatedOutput r _ -> r BothInputOutput r _ -> r ProtocolCitizenSubjectMismatch r _ _ -> r - MalformedPostOperator r _ -> r + MalformedPostOperator r _ _ -> r -- syntaxes AlreadyDeclaredSyntaxCat r _ -> r -- syntaxdesc validation diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index c5c8074..e367e56 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -174,7 +174,10 @@ instance Pretty Complaint where Subject{} -> ("a subject", "neither as an input nor an output") Output -> ("an output", "not as a subject") in hsep ["Found", pretty v, "as", seen, "but", unseen ] - MalformedPostOperator r op -> hsep ["Malformed operator", pretty op] + MalformedPostOperator r op cands -> + let message = case cands of [x] -> "the subject" + _ -> "a subject among" in + hsep $ ["Malformed operator", pretty op <> "; expected it to act on", message] ++ punctuate ", " (map pretty cands) -- syntaxes AlreadyDeclaredSyntaxCat r x -> hsep ["The syntactic category", pretty x, "is already defined"] diff --git a/test/golden/malformedPostOp.gold b/test/golden/malformedPostOp.gold new file mode 100644 index 0000000..0b033e3 --- /dev/null +++ b/test/golden/malformedPostOp.gold @@ -0,0 +1,11 @@ +ret > ExitFailure 1 +out > Error +out > +out > 11 | {} +out > 12 | type (T : 'Type) +out > 13 | {['a 'a] - 'Value : 'Universe} +out > ^^^^^^^ +out > malformedPostOp.act:13:3-10 +out > Malformed operator Value; expected it to act on the subject T +out > when elaborating the judgement form type +out > diff --git a/test/malformedPostOp.act b/test/malformedPostOp.act new file mode 100644 index 0000000..3ab05a1 --- /dev/null +++ b/test/malformedPostOp.act @@ -0,0 +1,13 @@ +------------------------------------------------------------------------------ +-- Datatypes + +syntax + { 'Type = ['EnumOrTag ['Nat] + [['Arr 'Type 'Type]] + ] + } + +judgementform + {} + type (T : 'Type) + {['a 'a] - 'Value : 'Universe} From 569b568fc2ab6cc3f87e4ec99aed804436411f4b Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Wed, 9 Nov 2022 17:53:05 +0000 Subject: [PATCH 19/89] [ broken ] towards proper Semantics --- Src/Concrete/Base.hs | 5 +- Src/Elaboration/Monad.hs | 4 +- Src/Machine/Base.hs | 153 ++++---------------------------- Src/Machine/Trace.hs | 1 + Src/Operator.hs | 86 ++++++++++++++++++ Src/Operator/Eval.hs | 60 +++++++++++++ Src/Rules.hs | 2 +- Src/Semantics.hs | 187 +++++++++++++++++++++++++++++++++++++++ Src/Syntax.hs | 7 +- Src/Unelaboration.hs | 1 + typos.cabal | 3 + 11 files changed, 365 insertions(+), 144 deletions(-) create mode 100644 Src/Operator.hs create mode 100644 Src/Operator/Eval.hs create mode 100644 Src/Semantics.hs diff --git a/Src/Concrete/Base.hs b/Src/Concrete/Base.hs index 12d7d8d..c8f77f2 100644 --- a/Src/Concrete/Base.hs +++ b/Src/Concrete/Base.hs @@ -147,8 +147,9 @@ type instance SYNTAXDESC Concrete = Raw type CSyntaxDesc = SYNTAXDESC Concrete type ASyntaxDesc = SYNTAXDESC Abstract -type SEMANTICSDESC (ph :: Phase) - = SYNTAXDESC ph -- for now, actually: TERM ph +type family SEMANTICSDESC (ph :: Phase) +type instance SEMANTICSDESC Concrete = Raw + type CSemanticsDesc = SEMANTICSDESC Concrete type ASemanticsDesc = SEMANTICSDESC Abstract diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index d315533..f6ef7e7 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -17,11 +17,13 @@ import Bwd import Concrete.Base import Location (HasGetRange(..), Range, WithRange (..)) import Syntax (SyntaxCat, SyntaxDesc, VSyntaxDesc'(..), VSyntaxDesc, SyntaxTable, wildcard) +import Semantics (embed) import qualified Syntax import Thin (Selable(..), DB (..), CdB (..)) import Term.Base (Tm(..), atom) import Utils import Machine.Base +import Operator import Rules ------------------------------------------------------------------------------ @@ -216,7 +218,7 @@ initContext = Context { objVars = B0 , declarations = B0 , operators = Map.fromList - [ ("app", (wildcard, [wildcard], wildcard)) + [ ("app", (wildcard, [wildcard], embed wildcard)) ] , location = B0 , binderHints = Map.empty diff --git a/Src/Machine/Base.hs b/Src/Machine/Base.hs index e671102..f31897e 100644 --- a/Src/Machine/Base.hs +++ b/Src/Machine/Base.hs @@ -10,7 +10,6 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Maybe (fromMaybe) import Control.Monad.State -import Control.Applicative import Actor import Actor.Display() @@ -18,7 +17,6 @@ import Actor.Display() import Bwd import Format import Options -import Location (WithRange) import Term import qualified Term.Substitution as Substitution import Thin @@ -31,95 +29,51 @@ import Machine.Matching import Debug.Trace (trace) import Display (unsafeDocDisplayClosed) import ANSI hiding (withANSI) -import Parse -import Concrete.Parse import Pretty +import Operator +import Operator.Eval newtype Date = Date Int deriving (Show, Eq, Ord, Num) --- | i stores extra information, typically a naming -data StoreF i = Store - { solutions :: Map Meta (i, Maybe Term) - , guards :: Map Guard (Set Guard) -- key is conjunction of values; acyclic! - , today :: Date - } deriving (Show) - -initStore :: StoreF i +initStore :: StoreF i Date initStore = Store Map.empty Map.empty 0 -tick :: StoreF i -> StoreF i +tick :: StoreF i Date -> StoreF i Date tick st@Store{..} = st { today = today + 1 } -declareMeta :: Meta -> i -> StoreF i -> StoreF i +declareMeta :: Meta -> i -> StoreF i d -> StoreF i d declareMeta m i st@Store{..} = st { solutions = Map.insert m (i, Nothing) solutions } -updateStore :: Meta -> Term -> StoreF i -> StoreF i +updateStore :: Meta -> Term -> StoreF i Date -> StoreF i Date updateStore m t st@Store{..} = tick $ st { solutions = Map.adjust (Just t <$) m solutions } -defineGuard :: Guard -> Set Guard -> StoreF i -> StoreF i +mkOpTable :: Bwd Frame -> Operator -> Clause +mkOpTable _ (Operator "app") = appClause +mkOpTable _ (Operator "tick") = tickClause +mkOpTable fs op = flip foldMap fs $ \case + Extended op' cl | op == op' -> cl + _ -> mempty + +defineGuard :: Guard -> Set Guard -> StoreF i d -> StoreF i d defineGuard g gs = execState (compressGuards g gs) -compressGuards :: Guard -> Set Guard -> State (StoreF i) (Set Guard) +compressGuards :: Guard -> Set Guard -> State (StoreF i d) (Set Guard) compressGuards g gs = do gs <- foldMap (\ g -> fromMaybe (Set.singleton g) <$> dependencySetCompression g) gs modify (\ st -> st { guards = Map.insert g gs (guards st) }) pure gs -dependencySetCompression :: Guard -> State (StoreF i) (Maybe (Set Guard)) +dependencySetCompression :: Guard -> State (StoreF i d) (Maybe (Set Guard)) dependencySetCompression g = do gtable <- gets guards case Map.lookup g gtable of Nothing -> pure Nothing Just gs -> Just <$> compressGuards g gs -dependencySet :: StoreF i -> Guard -> Set Guard -dependencySet st@Store{..} g = case Map.lookup g guards of - Nothing -> Set.singleton g - Just gs -> foldMap (dependencySet st) gs - -data HeadUpData = forall i. HeadUpData - { opTable :: Operator -> Clause - , metaStore :: StoreF i - , huOptions :: Options - , huEnv :: Env - } - -mkOpTable :: Bwd Frame -> Operator -> Clause -mkOpTable _ (Operator "app") = appClause -mkOpTable _ (Operator "tick") = tickClause -mkOpTable fs op = flip foldMap fs $ \case - Extended op' cl | op == op' -> cl - _ -> mempty - --- Expanding the term using the information currently available: --- + meta solutions --- + operator clauses -headUp :: HeadUpData -> Term -> Term -headUp dat@HeadUpData{..} term = case expand term of - m :$: sg | Just (_, Just t) <- Map.lookup m (solutions metaStore) - -> headUp dat (t //^ sg) - t :-: o -> case expand o of - AX op i -> operate (Operator op) (t, []) - o@(CdB (A op) th :%: wargs) -> - case asList (\ ps -> pure $ operate (Operator op) (t, ps)) wargs of - Nothing -> contract (t :-: contract o) - Just t -> t - o -> contract (t :-: contract o) - GX g t -> if Set.null (dependencySet metaStore g) then headUp dat t else term - _ -> term - - where - - operate :: Operator -> (Term, [Term]) -> Term - operate op tps = case runClause (opTable op) huOptions (headUp dat) huEnv tps of - Left (t, ps) -> t -% (getOperator op, ps) - Right t -> headUp dat t - - compareUp :: HeadUpData -> Term -> Term -> Maybe Ordering compareUp dat s t = case (expand (headUp dat s), expand (headUp dat t)) of (VX i _, VX j _) -> pure (compare i j) @@ -147,12 +101,12 @@ comparesUp dat sg sg' = compareUp dat (toTerm sg) (toTerm sg') where class Instantiable t where type Instantiated t - instantiate :: StoreF i -> t -> Instantiated t + instantiate :: StoreF i d -> t -> Instantiated t normalise :: HeadUpData -> t -> Instantiated t class Instantiable1 t where type Instantiated1 t :: * -> * - instantiate1 :: StoreF i -> t a -> Instantiated1 t a + instantiate1 :: StoreF i d -> t a -> Instantiated1 t a normalise1 :: HeadUpData -> t a -> Instantiated1 t a instance Instantiable Term where @@ -364,74 +318,3 @@ instance (Show s, Show (t Frame)) => Show (Process log s t) where show (Process opts stack root env store actor _ geas) = unwords ["Process ", show opts, show stack, show root, show env, show store, show actor, show geas] ------------------------------------------------------------------------------- --- Operators - -data ANOPERATOR (ph :: Phase) = AnOperator - { opName :: OPERATOR ph - , objDesc :: SYNTAXDESC ph - , paramDescs :: [SYNTAXDESC ph] - , retDesc :: SEMANTICSDESC ph - } - -deriving instance - ( Show (OPERATOR ph) - , Show (SYNTAXDESC ph) - ) => Show (ANOPERATOR ph) - -type CAnOperator = ANOPERATOR Concrete -type AAnOperator = ANOPERATOR Abstract - -data Operator = Operator { getOperator :: String } - deriving (Show, Eq) - -type family OPERATOR (ph :: Phase) :: * -type instance OPERATOR Concrete = WithRange String -type instance OPERATOR Abstract = Operator - -newtype Clause = Clause { runClause - :: Options - -> (Term -> Term) -- head normaliser - -> Env - -> (Term, [Term]) -- object & parameters - -> Either (Term, [Term]) Term } - -instance Semigroup Clause where - (<>) = mappend - -instance Monoid Clause where - mempty = Clause $ \ _ _ _ -> Left - mappend cl1 cl2 = Clause $ \ opts hd env ops -> case runClause cl2 opts hd env ops of - Left ops -> runClause cl1 opts hd env ops - Right t -> Right t - -instance Show Clause where - show _ = "" - -type OPPATTERN ph = (OPERATOR ph, [PATTERN ph]) - -type family DEFNOP (ph :: Phase) :: * -type instance DEFNOP Concrete = (PATTERN Concrete, [OPPATTERN Concrete], TERM Concrete) -type instance DEFNOP Abstract = (Operator, Clause) - -pdefnop :: Parser (DEFNOP Concrete) -pdefnop = (,,) <$> ppat <*> some (punc "-" *> poperator ppat) <* punc "~>" <*> pTM - -type COpPattern = OPPATTERN Concrete -type AOpPattern = OPPATTERN Abstract -type COperator = OPERATOR Concrete -type AOperator = OPERATOR Abstract - -poperator :: Parser a -> Parser (WithRange String, [a]) -poperator ph = - (,[]) <$> pwithRange patom - <|> (,) <$ pch (== '[') <* pspc <*> pwithRange patom <*> many (id <$ pspc <*> ph) <* pspc <* pch (== ']') - -panoperator :: String -> Parser CAnOperator -panoperator copula = do - obj <- psyntaxdecl - punc "-" - (opname, params) <- poperator psyntaxdecl - punc copula - ret <- psemanticsdecl - pure (AnOperator opname obj params ret) diff --git a/Src/Machine/Trace.hs b/Src/Machine/Trace.hs index ac227ba..3569e96 100644 --- a/Src/Machine/Trace.hs +++ b/Src/Machine/Trace.hs @@ -23,6 +23,7 @@ import Format import LaTeX import Location (unknown) import Machine.Base +import Operator.Eval import Options import Pretty import Syntax (SyntaxDesc, SyntaxTable, expand, VSyntaxDesc'(..), contract) diff --git a/Src/Operator.hs b/Src/Operator.hs new file mode 100644 index 0000000..f560df6 --- /dev/null +++ b/Src/Operator.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE UndecidableInstances #-} +module Operator where + +import Control.Applicative + +import Concrete.Base +import Concrete.Parse +import Location +import Parse +import Options +import Actor (Env) +import Term.Base + +------------------------------------------------------------------------------ +-- Operators + +data ANOPERATOR (ph :: Phase) = AnOperator + { opName :: OPERATOR ph + , objDesc :: SYNTAXDESC ph + , paramDescs :: [SYNTAXDESC ph] + , retDesc :: SEMANTICSDESC ph + } + +deriving instance + ( Show (OPERATOR ph) + , Show (SYNTAXDESC ph) + , Show (SEMANTICSDESC ph) + ) => Show (ANOPERATOR ph) + +type CAnOperator = ANOPERATOR Concrete +type AAnOperator = ANOPERATOR Abstract + +data Operator = Operator { getOperator :: String } + deriving (Show, Eq) + +type family OPERATOR (ph :: Phase) :: * +type instance OPERATOR Concrete = WithRange String +type instance OPERATOR Abstract = Operator + +newtype Clause = Clause { runClause + :: Options + -> (Term -> Term) -- head normaliser + -> Env + -> (Term, [Term]) -- object & parameters + -> Either (Term, [Term]) Term } + +instance Semigroup Clause where + (<>) = mappend + +instance Monoid Clause where + mempty = Clause $ \ _ _ _ -> Left + mappend cl1 cl2 = Clause $ \ opts hd env ops -> case runClause cl2 opts hd env ops of + Left ops -> runClause cl1 opts hd env ops + Right t -> Right t + +instance Show Clause where + show _ = "" + +type OPPATTERN ph = (OPERATOR ph, [PATTERN ph]) + +type family DEFNOP (ph :: Phase) :: * +type instance DEFNOP Concrete = (PATTERN Concrete, [OPPATTERN Concrete], TERM Concrete) +type instance DEFNOP Abstract = (Operator, Clause) + +pdefnop :: Parser (DEFNOP Concrete) +pdefnop = (,,) <$> ppat <*> some (punc "-" *> poperator ppat) <* punc "~>" <*> pTM + +type COpPattern = OPPATTERN Concrete +type AOpPattern = OPPATTERN Abstract +type COperator = OPERATOR Concrete +type AOperator = OPERATOR Abstract + +poperator :: Parser a -> Parser (WithRange String, [a]) +poperator ph = + (,[]) <$> pwithRange patom + <|> (,) <$ pch (== '[') <* pspc <*> pwithRange patom <*> many (id <$ pspc <*> ph) <* pspc <* pch (== ']') + +panoperator :: String -> Parser CAnOperator +panoperator copula = do + obj <- psyntaxdecl + punc "-" + (opname, params) <- poperator psyntaxdecl + punc copula + ret <- psemanticsdecl + pure (AnOperator opname obj params ret) + diff --git a/Src/Operator/Eval.hs b/Src/Operator/Eval.hs new file mode 100644 index 0000000..7ff83bd --- /dev/null +++ b/Src/Operator/Eval.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Operator.Eval where + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set + +import Thin +import Term.Base +import Term.Substitution ((//^)) +import Concrete.Base +import Operator +import Options +import Actor + +dependencySet :: StoreF i d -> Guard -> Set Guard +dependencySet st@Store{..} g = case Map.lookup g guards of + Nothing -> Set.singleton g + Just gs -> foldMap (dependencySet st) gs + +-- | i stores extra information, typically a naming; d is a date type +data StoreF i d = Store + { solutions :: Map Meta (i, Maybe Term) + , guards :: Map Guard (Set Guard) -- key is conjunction of values; acyclic! + , today :: d + } deriving (Show, Functor) + +data HeadUpData = forall i d. HeadUpData + { opTable :: Operator -> Clause + , metaStore :: StoreF i d + , huOptions :: Options + , huEnv :: Env + } + +-- Expanding the term using the information currently available: +-- + meta solutions +-- + operator clauses +headUp :: HeadUpData -> Term -> Term +headUp dat@HeadUpData{..} term = case expand term of + m :$: sg | Just (_, Just t) <- Map.lookup m (solutions metaStore) + -> headUp dat (t //^ sg) + t :-: o -> case expand o of + AX op i -> operate (Operator op) (t, []) + o@(CdB (A op) th :%: wargs) -> + case asList (\ ps -> pure $ operate (Operator op) (t, ps)) wargs of + Nothing -> contract (t :-: contract o) + Just t -> t + o -> contract (t :-: contract o) + GX g t -> if Set.null (dependencySet metaStore g) then headUp dat t else term + _ -> term + + where + + operate :: Operator -> (Term, [Term]) -> Term + operate op tps = case runClause (opTable op) huOptions (headUp dat) huEnv tps of + Left (t, ps) -> t -% (getOperator op, ps) + Right t -> headUp dat t + + diff --git a/Src/Rules.hs b/Src/Rules.hs index 7b68c8b..dd8555b 100644 --- a/Src/Rules.hs +++ b/Src/Rules.hs @@ -9,7 +9,7 @@ import Data.Maybe import Actor import Scope import Concrete.Base -import Machine.Base (DEFNOP, ANOPERATOR, pdefnop, panoperator) +import Operator (DEFNOP, ANOPERATOR, pdefnop, panoperator) import Term.Base import Parse diff --git a/Src/Semantics.hs b/Src/Semantics.hs new file mode 100644 index 0000000..2ae3abf --- /dev/null +++ b/Src/Semantics.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE GADTs #-} +module Semantics where + +import Control.Monad +import Control.Applicative + +import Data.Void +import Data.Map (Map) +import qualified Data.Map as Map + +import Hide +import Bwd +import Concrete.Base (Phase(..), ASyntaxDesc, ASemanticsDesc, SEMANTICSDESC) +import Actor (ACTm, mangleActors) +import Thin (CdB(..), DB(..), weak, scope, lsb, ($^)) +import Term hiding (contract, expand) +import Syntax (SyntaxTable, SyntaxCat, WithSyntaxCat(..)) +import Operator.Eval + +type instance SEMANTICSDESC Abstract = ACTm + +embed :: ASyntaxDesc -> ASemanticsDesc +embed = (fmap absurd $^) + +data VSemanticsDesc' a + -- embedding syntax + = VAtom + | VAtomBar [String] + | VNil + | VCons ASemanticsDesc ASemanticsDesc + | VNilOrCons ASemanticsDesc ASemanticsDesc + | VBind SyntaxCat ASemanticsDesc + | VEnumOrTag [String] [(String, [ASemanticsDesc])] + | VWildcard + | VSyntaxCat a + -- stuck things + | VNeutral ASemanticsDesc + -- canonical semantics constructors + | VUniverse + | VPi ASemanticsDesc (Named Bool, ASemanticsDesc) + deriving (Eq, Show) + +type VSemanticsDesc = VSemanticsDesc' Void + +{- +expand' :: WithSyntaxCat a -> SyntaxTable -> HeadUpData -> ASemanticsDesc -> Maybe (VSemanticsDesc' a) +expand' w table dat desc = do + desc <- mangleActors (huOptions dat) (huEnv dat) desc + go True (headUp dat desc) where + + go b s = (($ s) $ asAtomOrTagged (goAtoms b) (goTagged b s)) + <|> pure (VNeutral desc) + + goAtoms b (a,_) = case a of + "Atom" -> pure VAtom + "Nil" -> pure VNil + "Wildcard" -> pure VWildcard + a -> do + s <- Map.lookup a table + case w of + Yes -> pure (VSyntaxCat a) + No -> do guard b + go False s + + goTagged b s (a, n) = case a of + "AtomBar" -> asPair $ asListOf (asAtom $ Just . fst) + $ \ xs _ -> pure (VAtomBar xs) + "Cons" -> asPair $ \ s0 -> asPair $ \ s1 _ -> pure (VCons s0 s1) + "NilOrCons" -> asPair $ \ s0 -> asPair $ \ s1 _ -> pure (VNilOrCons s0 s1) + "Bind" -> asTagged $ \ (a,_) -> asPair $ \ s _ -> pure (VBind a s) + "Tag" -> asPair $ \ s0 s1 -> goTagged b s ("EnumOrTag", n) (nil n % s0 % s1) + "Enum" -> asPair $ \ s0 s1 -> goTagged b s ("EnumOrTag", n) (s0 % nil n % s1) + "EnumOrTag" -> asPair $ \ es -> asPair $ \ ts _ -> + ($ es) $ asListOf (asAtom $ Just . fst) $ \ xs -> + ($ ts) $ asListOf (asTagged $ \ (a, _) -> asList $ \ bs -> Just (a, bs)) $ \ ys -> + pure (VEnumOrTag xs ys) + "Fix" -> asPair $ asBind $ \ x s' _ -> go False (s' //^ topSbst x s) + _ -> bust + +expand :: SyntaxTable -> HeadUpData -> ASemanticsDesc -> Maybe VSemanticsDesc +expand = expand' No +-} + +{- + +contract' :: WithSyntaxCat a -> VSyntaxDesc' a -> ASemanticsDesc +contract' w = \case + VAtom -> atom "Atom" 0 + VAtomBar xs -> "AtomBar" #%+ [enums (\ s -> atom s 0) xs] + VNil -> atom "Nil" 0 + VCons s t -> "Cons" #%+ [s, t] + VNilOrCons s t -> "NilOrCons" #%+ [s, t] + VBind cat s -> "Bind" #%+ [catToDesc cat, s] + VEnumOrTag es ts -> "EnumOrTag" #%+ + [enums (\ s -> atom s 0) es, enums ( \ (t, s) -> (t,0) #% s) ts] + VWildcard -> atom "Wildcard" 0 + VSyntaxCat cat -> case w of + Yes -> atom cat 0 + No -> absurd cat + where + enums f = foldr (%) (nil 0) . map f + +contract :: VSyntaxDesc -> ASemanticsDesc +contract = contract' No + +catToDesc :: SyntaxCat -> ASemanticsDesc +catToDesc c = atom c 0 + +validate :: Show m => SyntaxTable -> Bwd SyntaxCat -> ASemanticsDesc -> CdB (Tm m) -> Bool +validate table = go where + + go :: Show m => Bwd SyntaxCat -> ASemanticsDesc -> CdB (Tm m) -> Bool + go env s t@(CdB V th) = reportError s t $ ($ s) $ asRec $ \ a -> a == env asAtom $ \ (a,_) -> not (null a) + VAtomBar as -> asAtom $ \ (a,_) -> not (a `elem` as) + VNil -> asAtom $ \ (a,_) -> null a + VCons s0 s1 -> asPair $ \ t0 t1 -> go env s0 t0 && go env s1 t1 + VNilOrCons s0 s1 -> asNilOrCons True $ \ t0 t1 -> go env s0 t0 && go env s1 t1 + VBind a s -> asBind $ \ x t -> go (env :< a) s t + VEnumOrTag es ds -> asAtomOrTagged (\ (e,_) -> e `elem` es) + (\ (a,_) t -> case lookup a ds of + Nothing -> False + Just ss -> gos env ss t) + VWildcard -> \ _ -> True + + reportError :: Show m => ASemanticsDesc -> CdB (Tm m) -> Bool -> Bool + reportError d t True = True + reportError d t False = False -- error $ "Validation error\nDesc: " ++ show d ++ "\nTerm: " ++ show t + + gos :: Show m => Bwd SyntaxCat -> [ASemanticsDesc] -> CdB (Tm m) -> Bool + gos env [] = asNil True + gos env (s:ss) = asPair $ \ t0 t1 -> go env s t0 && gos env ss t1 + +listOf :: String -> ASemanticsDesc -> ASemanticsDesc +listOf x d = let ga = scope d + 1 in + "Fix" #%+ [x \\ (atom "NilOrCons" ga % (weak d % var (DB 0) ga % nil ga))] + +rec :: String -> ASemanticsDesc +rec a = atom a 0 + +syntaxDesc :: [SyntaxCat] -> ASemanticsDesc +syntaxDesc syns = "EnumOrTag" #%+ [ + enums (atoms ++ syns), + (atom "AtomBar" 0 % (listOf "at" atom0 % nil 0)) % + (atom "Cons" 0 % (syntax % syntax % nil 0)) % + (atom "NilOrCons" 0 % (syntax % syntax % nil 0)) % + (atom "Bind" 0 % (("EnumOrTag" #%+ [enums syns, nil 0]) % syntax % nil 0)) % + (atom "EnumOrTag" 0 % (listOf "at" atom0 + % listOf "cell" (atom "Cons" 0 % atom0 % (listOf "rec" syntax % nil 0)) % nil 0)) % + (atom "Enum" 0 % listOf "at" atom0 % nil 0) % + (atom "Tag" 0 % (listOf "cell" (atom "Cons" 0 % atom0 % (listOf "rec" syntax % nil 0)) % nil 0)) % + (atom "Fix" 0 % ("Bind" #%+ [atom "Syntax" 0, syntax]) % nil 0) % + nil 0] + where syntax = rec "Syntax" + atom0 = atom "Atom" 0 -- ("Atom",0) #% [] + atoms = ["Nil", "Atom", "Wildcard"] + enums sc = foldr (%) (nil 0) $ map (\ s -> atom s 0) sc + + +{- > printIt + +['EnumOrTag + ['Nil 'Atom 'Wildcard 'Syntax] + [['AtomBar ['Fix (\list.['NilOrCons 'Atom list])]] + ['Cons 'Syntax 'Syntax] + ['NilOrCons 'Syntax 'Syntax] + ['Bind ['EnumOrTag ['Syntax] []] 'Syntax] + ['EnumOrTag ['Fix (\list.['NilOrCons 'Atom list])] + ['Fix (\list.['NilOrCons ['Cons 'Atom ['Fix (\list.['NilOrCons 'Syntax list])]] list])]] + ['Enum ['Fix (\list.['NilOrCons 'Atom list])]] + ['Tag ['Fix (\list.['NilOrCons ['Cons 'Atom ['Fix (\list.['NilOrCons 'Syntax list])]] list])]] + ['Fix ['Bind 'Syntax 'Syntax]]]] + +-} + +validateDesc :: [SyntaxCat] -> ASemanticsDesc -> Bool +validateDesc syns = + validate (Map.fromList known) B0 + (rec "Syntax") + where + known = [ ("Syntax", syntaxDesc syns) + , ("Semantics", wildcard)] -- TODO : change + + +validateIt = validateDesc ["Syntax"] (syntaxDesc ["Syntax"]) +-} diff --git a/Src/Syntax.hs b/Src/Syntax.hs index c4100a5..5f6ebd6 100644 --- a/Src/Syntax.hs +++ b/Src/Syntax.hs @@ -8,8 +8,8 @@ import Data.Map (Map) import qualified Data.Map as Map import Bwd -import Concrete.Base (SYNTAXDESC, Phase(..), ASyntaxDesc, ASemanticsDesc) -import Thin (CdB(..), DB(..), weak, scope, lsb, ($^)) +import Concrete.Base (SYNTAXDESC, Phase(..), ASyntaxDesc) +import Thin (CdB(..), DB(..), weak, scope, lsb) import Term hiding (contract, expand) type SyntaxCat = String @@ -76,9 +76,6 @@ expand' w table = go True where expand :: SyntaxTable -> ASyntaxDesc -> Maybe VSyntaxDesc expand = expand' No -embed :: ASyntaxDesc -> ASemanticsDesc -embed = (fmap absurd $^) - contract' :: WithSyntaxCat a -> VSyntaxDesc' a -> ASyntaxDesc contract' w = \case VAtom -> atom "Atom" 0 diff --git a/Src/Unelaboration.hs b/Src/Unelaboration.hs index ed1b0c7..9d9e8e4 100644 --- a/Src/Unelaboration.hs +++ b/Src/Unelaboration.hs @@ -20,6 +20,7 @@ import Hide import Pattern import Scope import Syntax() +import Semantics() import Term.Base import Thin import Location (unknown) diff --git a/typos.cabal b/typos.cabal index bb7d9d3..e8abddb 100644 --- a/typos.cabal +++ b/typos.cabal @@ -55,6 +55,8 @@ library Machine.Matching, Machine.Trace, Main, + Operator, + Operator.Eval, Options, Parse, Pattern, @@ -62,6 +64,7 @@ library Pretty, Rules, Scope, + Semantics, Syntax, Syntax.Debug, Term, From aaf96a511a14afdb863a9002bf90418a132153c1 Mon Sep 17 00:00:00 2001 From: Georgi Nakov Date: Wed, 23 Nov 2022 16:55:51 +0000 Subject: [PATCH 20/89] [ wip ] polymorphic headUpData --- Src/Actor.hs | 15 ++++++++---- Src/Elaboration.hs | 2 +- Src/Machine/Exec.hs | 25 +++++++++++--------- Src/Machine/Matching.hs | 40 +++++++++++++++++--------------- Src/Operator.hs | 13 ++++++----- Src/Operator/Eval.hs | 15 +++++++----- Src/Semantics.hs | 19 ++++++++------- Src/Term/Base.hs | 7 ++++-- examples/stlcRules.act | 10 ++++---- test/golden/malformedPostOp.gold | 2 +- test/malformedPostOp.act | 2 +- typos.cabal | 5 ++-- 12 files changed, 87 insertions(+), 68 deletions(-) diff --git a/Src/Actor.hs b/Src/Actor.hs index 53b7542..ae2d3aa 100644 --- a/Src/Actor.hs +++ b/Src/Actor.hs @@ -67,19 +67,24 @@ aconnect r ch1 th ch2 n | otherwise = Win r -data Env = Env +data Env' m = Env { globalScope :: Bwd String -- free vars ga actor does *not* know about - , actorVars :: Map ActorMeta ([String] -- bound vars xi actorVar does know about - , Term) -- in scope ga <>< xi + , actorVars :: Map ActorMeta (EnvImg' m) , subjectGuards :: Map String Guard , localScope :: Bwd String -- vars de actor has bound , alphaRenamings :: Map String (Hide String) } deriving (Show, Eq) +type EnvImg' m = ([String] -- bound vars xi actorVar does know about + , CdB (Tm m)) -- in scope ga <>< xi + +type Env = Env' Meta +type EnvImg = EnvImg' Meta + tryAlpha :: Env -> String -> String tryAlpha rho x = maybe x unhide (Map.lookup x (alphaRenamings rho)) -declareAlpha :: (String, Hide String) -> Env -> Env +declareAlpha :: (String, Hide String) -> Env' m -> Env' m declareAlpha (x, Hide "_") rho = rho declareAlpha ("_", y) rho = rho declareAlpha (x, y) rho = @@ -97,7 +102,7 @@ initEnv gamma = Env childEnv :: Env -> Env childEnv parentEnv = initEnv (globalScope parentEnv <> localScope parentEnv) -newActorVar :: ActorMeta -> ([String], Term) -> Env -> Env +newActorVar :: ActorMeta -> EnvImg' m -> Env' m -> Env' m newActorVar x defn env = env { actorVars = Map.insert x defn (actorVars env) } guardSubject :: ActorVar -> ([String], Term) -> Guard -> Env -> Env diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index a18ce5e..78df1b1 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -131,7 +131,7 @@ ssyntaxdesc syndecls syn = do ssemanticsdesc :: CSemanticsDesc -> Elab ASemanticsDesc ssemanticsdesc sem = do syndecls <- gets (Map.keys . syntaxCats) - ssyntaxdesc ("Universe":syndecls) sem + ssyntaxdesc ("Semantics":syndecls) sem -- TODO: use stm to actually be able to use operators & actor vars -- DontLog (catToDesc "Semantics") diff --git a/Src/Machine/Exec.hs b/Src/Machine/Exec.hs index ace36e1..20774bb 100644 --- a/Src/Machine/Exec.hs +++ b/Src/Machine/Exec.hs @@ -43,10 +43,15 @@ lookupRules jd zf = do _ -> Nothing pure cha +mkHeadUpData :: Process a Store Bwd -> HeadUpData +mkHeadUpData Process{..} = + let what m = Map.lookup m (solutions store) >>= snd + in HeadUpData (mkOpTable stack) store options env what + recordFrame :: Process Shots Store Bwd -> Process Shots Store Bwd recordFrame p@Process{..} = - let dat = HeadUpData (mkOpTable stack) store (options { quiet = True }) env in - p { logs = normalise dat (extract Simple (length logs) (stack <>> [])) : logs } + let dat = mkHeadUpData (p{options = options { quiet = True }}) + in p { logs = normalise dat (extract Simple (length logs) (stack <>> [])) : logs } -- run an actor exec :: Process Shots Store Bwd -> Process Shots Store [] @@ -104,8 +109,7 @@ exec p@Process { actor = m@(Match _ s cls), ..} = switch term cls where - dat :: HeadUpData - dat = HeadUpData (mkOpTable stack) store options env + dat = mkHeadUpData p search :: Bwd Frame -> Int -> Stack -> Int -> Maybe Term search B0 i stk bd = Nothing @@ -170,7 +174,7 @@ exec p@Process { actor = Constrain _ s t, ..} -- , dmesg (show env) True -- , dmesg (show s ++ " ----> " ++ show s') True -- , dmesg (show t ++ " ----> " ++ show t') True - = let dat = HeadUpData (mkOpTable stack) store options env in + = let dat = mkHeadUpData p in unify dat (p { stack = stack :<+>: [UnificationProblem (today store) s' t'], actor = Win unknown }) exec p@Process { actor = Under _ (Scope (Hide x) a), ..} = let scopeSize = length (globalScope env <> localScope env) @@ -225,13 +229,12 @@ evalError p@Process{..} fmt format :: [Annotation] -> Process log Store Bwd -> [Format Directive Debug Term] -> String format ann p@Process{..} fmt - = let dat = HeadUpData (mkOpTable stack) store options env - in renderWith (renderOptions options) + = renderWith (renderOptions options) $ unsafeEvalDisplay (frDisplayEnv stack) $ fmap (withANSI ann) $ subdisplay $ insertDebug p - $ map (followDirectives dat) fmt + $ map (followDirectives $ mkHeadUpData p) fmt unify :: HeadUpData -> Process Shots Store Cursor -> Process Shots Store [] -- unify p | dmesg ("\nunify\n " ++ show p) False = undefined @@ -305,7 +308,7 @@ solveMeta :: Meta -- The meta (m) we're solving -> Process log Store Cursor -> Maybe (Process log Store Cursor) solveMeta m (CdB (S0 :^^ _) th) tm p@Process{..} = do - let dat = HeadUpData (mkOpTable (let (fs :<+>: _) = stack in fs)) store options env + let dat = mkHeadUpData (p{ stack = let (fs :<+>: _) = stack in fs}) (tm, p) <- deepCheck dat th tm p return (p { store = updateStore m tm store }) @@ -417,9 +420,9 @@ move p@Process { stack = zf :< Spawner (Interface (childP, q) (rxs, Hole) jd jdp in exec (childP { stack = stack', store = st, logs }) move p@Process { stack = zf :< UnificationProblem date s t :<+>: fs, .. } | today store > date - = let dat = HeadUpData (mkOpTable zf) store options env in + = let dat = mkHeadUpData (p{ stack = zf}) in unify dat (p { stack = zf :<+>: UnificationProblem (today store) s t : fs }) -move p@Process { stack = (zf :< f) :<+>: fs } +move p@Process { stack = (zf :< f) :<+>: fs } = move (p { stack = zf :<+>: (f : fs) }) debug :: (Show (t Frame), Traversable t, Collapse t, Display0 s) diff --git a/Src/Machine/Matching.hs b/Src/Machine/Matching.hs index 0345ee3..27048cc 100644 --- a/Src/Machine/Matching.hs +++ b/Src/Machine/Matching.hs @@ -30,14 +30,14 @@ instance Pretty Failure where pretty DontKnow = "Don't Know" -- <+> pretty meta pretty Mismatch = "Mismatch" -data Problem = Problem +data Problem m = Problem { localBinders :: Bwd String -- binders we have gone under , problemPat :: Pat -- pattern to match - , problemTerm :: Term -- candidate term + , problemTerm :: Term' m -- candidate term } -- Only use this to debug clauses -mismatch :: Pat -> Term -> Failure +mismatch :: Pat -> Term' m -> Failure mismatch _ _ = Mismatch --mismatch p t = trace (unsafeDisplayClosed unsafeOptions p ++ " ∌ " ++ unsafeDisplayClosed unsafeOptions t) Mismatch @@ -47,11 +47,12 @@ stuck (_ :-: _) = True stuck (GX _ _) = True stuck _ = False -type Matching = ([(ActorMeta, ([String], Term))], [(String, Hide String)]) +type Matching' m = ([(ActorMeta, EnvImg' m)], [(String, Hide String)]) +type Matching = Matching' Meta -matchingToEnv :: Matching -> Env -> Env +matchingToEnv :: Matching' m -> Env' m -> Env' m matchingToEnv (actors, alphas) env = - foldr(uncurry newActorVar) (foldr declareAlpha env alphas) actors + foldr (uncurry newActorVar) (foldr declareAlpha env alphas) actors matchingCase :: Matching -> (Root, Env) -> (Root, Env) matchingCase (actors, alphas) (r, env) = foldr f (r, foldr declareAlpha env alphas) actors @@ -62,21 +63,22 @@ matchingCase (actors, alphas) (r, env) = foldr f (r, foldr declareAlpha env alph ASubject -> case splitRoot r avar of (g, r) -> (r, guardSubject avar defn g env) -initMatching :: Matching +initMatching :: Matching' m initMatching = mempty -match :: (Term -> Term) -- head normal former - -> Matching - -> Problem - -> ( Term -- reduced version of the terms in the input problems - , Either Failure Matching) + +match :: (Term' m -> Term' m) -- head normal former + -> Matching' m + -> Problem m + -> ( Term' m -- reduced version of the terms in the input problems + , Either Failure (Matching' m)) match hnf mat p = first hd $ matchN hnf mat (p :* V0) -matchN :: (Term -> Term) -- head normal former - -> Matching - -> Vector n Problem - -> ( Vector n Term -- reduced version of the terms in the input problems - , Either Failure Matching) +matchN :: (Term' m -> Term' m) -- head normal former + -> Matching' m + -> Vector n (Problem m) + -> ( Vector n (Term' m) -- reduced version of the terms in the input problems + , Either Failure (Matching' m)) matchN hnf mat V0 = (V0, pure mat) matchN hnf mat (Problem zx (AT x p) tm :* xs) = let mat' = first ((x, (zx <>> [], tm)) :) mat in @@ -111,8 +113,8 @@ matchN hnf mat (Problem zx pat tm :* xs) = let tmnf = hnf tm in case (pat, expan _ -> (tmnf :* fmap problemTerm xs, Left (mismatch pat tmnf)) -instThicken :: (Term -> Term) -> Th -> Term - -> (Term, Either Failure Term) +instThicken :: (Term' m -> Term' m) -> Th -> Term' m + -> (Term' m, Either Failure (Term' m)) instThicken hnf ph t = let tmnf = hnf t in case tmnf of v@(CdB V _) -> case thickenCdB ph v of Just v -> (tmnf, pure v) diff --git a/Src/Operator.hs b/Src/Operator.hs index f560df6..d867e31 100644 --- a/Src/Operator.hs +++ b/Src/Operator.hs @@ -8,7 +8,7 @@ import Concrete.Parse import Location import Parse import Options -import Actor (Env) +import Actor (Env, Env') import Term.Base ------------------------------------------------------------------------------ @@ -38,11 +38,12 @@ type instance OPERATOR Concrete = WithRange String type instance OPERATOR Abstract = Operator newtype Clause = Clause { runClause - :: Options - -> (Term -> Term) -- head normaliser - -> Env - -> (Term, [Term]) -- object & parameters - -> Either (Term, [Term]) Term } + :: forall m + . Options + -> (Term' m -> Term' m) -- head normaliser + -> Env' m + -> (Term' m, [Term' m]) -- object & parameters + -> Either (Term' m, [Term' m]) (Term' m) } instance Semigroup Clause where (<>) = mappend diff --git a/Src/Operator/Eval.hs b/Src/Operator/Eval.hs index 7ff83bd..b44d19f 100644 --- a/Src/Operator/Eval.hs +++ b/Src/Operator/Eval.hs @@ -26,19 +26,22 @@ data StoreF i d = Store , today :: d } deriving (Show, Functor) -data HeadUpData = forall i d. HeadUpData +data HeadUpData' m = forall i d. HeadUpData { opTable :: Operator -> Clause , metaStore :: StoreF i d , huOptions :: Options - , huEnv :: Env + , huEnv :: Env' m + , whatIs :: m -> Maybe (Term' m) } +type HeadUpData = HeadUpData' Meta + -- Expanding the term using the information currently available: -- + meta solutions -- + operator clauses -headUp :: HeadUpData -> Term -> Term +headUp :: forall m . Show m => HeadUpData' m -> Term' m -> Term' m headUp dat@HeadUpData{..} term = case expand term of - m :$: sg | Just (_, Just t) <- Map.lookup m (solutions metaStore) + m :$: sg | Just t <- whatIs m -> headUp dat (t //^ sg) t :-: o -> case expand o of AX op i -> operate (Operator op) (t, []) @@ -47,12 +50,12 @@ headUp dat@HeadUpData{..} term = case expand term of Nothing -> contract (t :-: contract o) Just t -> t o -> contract (t :-: contract o) - GX g t -> if Set.null (dependencySet metaStore g) then headUp dat t else term + GX g t | Set.null (dependencySet metaStore g) -> headUp dat t _ -> term where - operate :: Operator -> (Term, [Term]) -> Term + operate :: Operator -> (Term' m, [Term' m]) -> Term' m operate op tps = case runClause (opTable op) huOptions (headUp dat) huEnv tps of Left (t, ps) -> t -% (getOperator op, ps) Right t -> headUp dat t diff --git a/Src/Semantics.hs b/Src/Semantics.hs index 2ae3abf..b8bb430 100644 --- a/Src/Semantics.hs +++ b/Src/Semantics.hs @@ -11,7 +11,7 @@ import qualified Data.Map as Map import Hide import Bwd import Concrete.Base (Phase(..), ASyntaxDesc, ASemanticsDesc, SEMANTICSDESC) -import Actor (ACTm, mangleActors) +import Actor (ACTm, ActorMeta) import Thin (CdB(..), DB(..), weak, scope, lsb, ($^)) import Term hiding (contract, expand) import Syntax (SyntaxTable, SyntaxCat, WithSyntaxCat(..)) @@ -37,30 +37,31 @@ data VSemanticsDesc' a | VNeutral ASemanticsDesc -- canonical semantics constructors | VUniverse - | VPi ASemanticsDesc (Named Bool, ASemanticsDesc) + | VPi ASemanticsDesc (String, ASemanticsDesc) deriving (Eq, Show) type VSemanticsDesc = VSemanticsDesc' Void -{- -expand' :: WithSyntaxCat a -> SyntaxTable -> HeadUpData -> ASemanticsDesc -> Maybe (VSemanticsDesc' a) + +expand' :: forall a. WithSyntaxCat a -> SyntaxTable -> HeadUpData' ActorMeta -> ASemanticsDesc -> Maybe (VSemanticsDesc' a) expand' w table dat desc = do - desc <- mangleActors (huOptions dat) (huEnv dat) desc go True (headUp dat desc) where - go b s = (($ s) $ asAtomOrTagged (goAtoms b) (goTagged b s)) + go :: Bool -> ASemanticsDesc -> Maybe (VSemanticsDesc' a) + go b s = ($ s) (asAtomOrTagged (goAtoms b) (goTagged b s)) <|> pure (VNeutral desc) goAtoms b (a,_) = case a of "Atom" -> pure VAtom "Nil" -> pure VNil "Wildcard" -> pure VWildcard + "Semantics" -> pure VUniverse a -> do s <- Map.lookup a table case w of Yes -> pure (VSyntaxCat a) No -> do guard b - go False s + go False (embed s) goTagged b s (a, n) = case a of "AtomBar" -> asPair $ asListOf (asAtom $ Just . fst) @@ -75,11 +76,11 @@ expand' w table dat desc = do ($ ts) $ asListOf (asTagged $ \ (a, _) -> asList $ \ bs -> Just (a, bs)) $ \ ys -> pure (VEnumOrTag xs ys) "Fix" -> asPair $ asBind $ \ x s' _ -> go False (s' //^ topSbst x s) + "Pi" -> asPair $ \ s0 -> asPair $ asBind $ \ x s1 _ -> pure $ VPi s0 (x, s1) _ -> bust -expand :: SyntaxTable -> HeadUpData -> ASemanticsDesc -> Maybe VSemanticsDesc +expand :: SyntaxTable -> HeadUpData' ActorMeta -> ASemanticsDesc -> Maybe VSemanticsDesc expand = expand' No --} {- diff --git a/Src/Term/Base.hs b/Src/Term/Base.hs index d0d96f7..9f78765 100644 --- a/Src/Term/Base.hs +++ b/Src/Term/Base.hs @@ -57,8 +57,11 @@ compressedMeta (Meta ms) = go (B0 :< "?[") ms where instance Pretty Meta where pretty = pretty . compressedMeta -type Term = CdB (Tm Meta) -type Subst = CdB (Sbst Meta) +type Term' m = CdB (Tm m) +type Subst' m = CdB (Sbst m) + +type Term = Term' Meta +type Subst = Subst' Meta initRoot :: Root initRoot = (B0, 0) diff --git a/examples/stlcRules.act b/examples/stlcRules.act index 5624d1d..e23dc63 100644 --- a/examples/stlcRules.act +++ b/examples/stlcRules.act @@ -16,7 +16,7 @@ syntax ]] } --- this is in 'Universe, or so we declare +-- this is in 'Semantics, or so we declare syntax -- we're calling in not-'Nat on purpose { 'Natural = ['EnumOrTag ['Zero] [['Succ 'Natural]] @@ -45,12 +45,12 @@ myCtxt |- 'Synth -> 'Type judgementform {} type (T : 'Type) -- no '=> B' means the citizen version is the same - {T - 'Value : 'Universe} + {T - 'Value : 'Semantics} judgementform {type T} check T (t : 'Check => T - 'Value) - {t - 'Bla : 'Universe} + {t - 'Bla : 'Semantics} judgementform {} @@ -58,7 +58,7 @@ judgementform {type T} -- Open question in the above: will it always be the subject that's fed to an operator? --- Note: the "T - 'Value" is in 'Universe and that T is the citizen, not the subject +-- Note: the "T - 'Value" is in 'Semantics and that T is the citizen, not the subject -- {} myCtxt |- x -> T {synth x T} @@ -72,7 +72,7 @@ rule {type S; type T} ------------------------ type ['Arr S T] => ['Arr S T] --- Global assumption: 'Universe comes with Pi builtin +-- Global assumption: 'Semantics comes with Pi builtin {['Arr S T] - 'Value ~> ['Pi (S - 'Value) \_. (T - 'Value)]} -- Invariant: the subject in a premiss is always something with a name diff --git a/test/golden/malformedPostOp.gold b/test/golden/malformedPostOp.gold index 0b033e3..48c2dc7 100644 --- a/test/golden/malformedPostOp.gold +++ b/test/golden/malformedPostOp.gold @@ -3,7 +3,7 @@ out > Error out > out > 11 | {} out > 12 | type (T : 'Type) -out > 13 | {['a 'a] - 'Value : 'Universe} +out > 13 | {['a 'a] - 'Value : 'Semantics} out > ^^^^^^^ out > malformedPostOp.act:13:3-10 out > Malformed operator Value; expected it to act on the subject T diff --git a/test/malformedPostOp.act b/test/malformedPostOp.act index 3ab05a1..826b6db 100644 --- a/test/malformedPostOp.act +++ b/test/malformedPostOp.act @@ -10,4 +10,4 @@ syntax judgementform {} type (T : 'Type) - {['a 'a] - 'Value : 'Universe} + {['a 'a] - 'Value : 'Semantics} diff --git a/typos.cabal b/typos.cabal index e8abddb..b08edb5 100644 --- a/typos.cabal +++ b/typos.cabal @@ -17,15 +17,16 @@ common haskell FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, + LambdaCase, MultiParamTypeClasses, NamedFieldPuns, + RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TupleSections, TypeFamilies, - TypeSynonymInstances, - LambdaCase + TypeSynonymInstances library import: haskell From b68d0c15dbc270b03fe8f374680edd8c6cbdea67 Mon Sep 17 00:00:00 2001 From: Georgi Nakov Date: Fri, 25 Nov 2022 17:42:24 +0000 Subject: [PATCH 21/89] [ wip ] validating semantics via typechecking --- Src/Semantics.hs | 137 +++++++++++++++++++++++++++++++++-------------- 1 file changed, 97 insertions(+), 40 deletions(-) diff --git a/Src/Semantics.hs b/Src/Semantics.hs index b8bb430..60bbc4e 100644 --- a/Src/Semantics.hs +++ b/Src/Semantics.hs @@ -12,8 +12,9 @@ import Hide import Bwd import Concrete.Base (Phase(..), ASyntaxDesc, ASemanticsDesc, SEMANTICSDESC) import Actor (ACTm, ActorMeta) -import Thin (CdB(..), DB(..), weak, scope, lsb, ($^)) +import Thin (CdB(..), DB(..), weak, scope, ($^), (*^), ones, none) import Term hiding (contract, expand) +import qualified Term import Syntax (SyntaxTable, SyntaxCat, WithSyntaxCat(..)) import Operator.Eval @@ -24,19 +25,19 @@ embed = (fmap absurd $^) data VSemanticsDesc' a -- embedding syntax - = VAtom - | VAtomBar [String] - | VNil + = VAtom Int + | VAtomBar Int [String] + | VNil Int | VCons ASemanticsDesc ASemanticsDesc | VNilOrCons ASemanticsDesc ASemanticsDesc | VBind SyntaxCat ASemanticsDesc - | VEnumOrTag [String] [(String, [ASemanticsDesc])] - | VWildcard - | VSyntaxCat a + | VEnumOrTag Int [String] [(String, [ASemanticsDesc])] + | VWildcard Int + | VSyntaxCat Int a -- stuck things | VNeutral ASemanticsDesc -- canonical semantics constructors - | VUniverse + | VUniverse Int | VPi ASemanticsDesc (String, ASemanticsDesc) deriving (Eq, Show) @@ -51,30 +52,30 @@ expand' w table dat desc = do go b s = ($ s) (asAtomOrTagged (goAtoms b) (goTagged b s)) <|> pure (VNeutral desc) - goAtoms b (a,_) = case a of - "Atom" -> pure VAtom - "Nil" -> pure VNil - "Wildcard" -> pure VWildcard - "Semantics" -> pure VUniverse + goAtoms b (a, sc) = case a of + "Atom" -> pure $ VAtom sc + "Nil" -> pure $ VNil sc + "Wildcard" -> pure $ VWildcard sc + "Semantics" -> pure $ VUniverse sc a -> do s <- Map.lookup a table case w of - Yes -> pure (VSyntaxCat a) + Yes -> pure (VSyntaxCat sc a) No -> do guard b go False (embed s) - goTagged b s (a, n) = case a of + goTagged b s (a, sc) = case a of "AtomBar" -> asPair $ asListOf (asAtom $ Just . fst) - $ \ xs _ -> pure (VAtomBar xs) + $ \ xs _ -> pure (VAtomBar sc xs) "Cons" -> asPair $ \ s0 -> asPair $ \ s1 _ -> pure (VCons s0 s1) "NilOrCons" -> asPair $ \ s0 -> asPair $ \ s1 _ -> pure (VNilOrCons s0 s1) "Bind" -> asTagged $ \ (a,_) -> asPair $ \ s _ -> pure (VBind a s) - "Tag" -> asPair $ \ s0 s1 -> goTagged b s ("EnumOrTag", n) (nil n % s0 % s1) - "Enum" -> asPair $ \ s0 s1 -> goTagged b s ("EnumOrTag", n) (s0 % nil n % s1) + "Tag" -> asPair $ \ s0 s1 -> goTagged b s ("EnumOrTag", sc) (nil sc % s0 % s1) + "Enum" -> asPair $ \ s0 s1 -> goTagged b s ("EnumOrTag", sc) (s0 % nil sc % s1) "EnumOrTag" -> asPair $ \ es -> asPair $ \ ts _ -> ($ es) $ asListOf (asAtom $ Just . fst) $ \ xs -> ($ ts) $ asListOf (asTagged $ \ (a, _) -> asList $ \ bs -> Just (a, bs)) $ \ ys -> - pure (VEnumOrTag xs ys) + pure (VEnumOrTag sc xs ys) "Fix" -> asPair $ asBind $ \ x s' _ -> go False (s' //^ topSbst x s) "Pi" -> asPair $ \ s0 -> asPair $ asBind $ \ x s1 _ -> pure $ VPi s0 (x, s1) _ -> bust @@ -82,48 +83,50 @@ expand' w table dat desc = do expand :: SyntaxTable -> HeadUpData' ActorMeta -> ASemanticsDesc -> Maybe VSemanticsDesc expand = expand' No -{- - -contract' :: WithSyntaxCat a -> VSyntaxDesc' a -> ASemanticsDesc +contract' :: WithSyntaxCat a -> VSemanticsDesc' a -> ASemanticsDesc contract' w = \case - VAtom -> atom "Atom" 0 - VAtomBar xs -> "AtomBar" #%+ [enums (\ s -> atom s 0) xs] - VNil -> atom "Nil" 0 + VAtom sc -> atom "Atom" sc + VAtomBar sc xs -> "AtomBar" #%+ [enums sc (\ s -> atom s sc) xs] + VNil sc -> atom "Nil" sc VCons s t -> "Cons" #%+ [s, t] VNilOrCons s t -> "NilOrCons" #%+ [s, t] VBind cat s -> "Bind" #%+ [catToDesc cat, s] - VEnumOrTag es ts -> "EnumOrTag" #%+ - [enums (\ s -> atom s 0) es, enums ( \ (t, s) -> (t,0) #% s) ts] - VWildcard -> atom "Wildcard" 0 - VSyntaxCat cat -> case w of - Yes -> atom cat 0 + VEnumOrTag sc es ts -> "EnumOrTag" #%+ + [enums sc (\ s -> atom s sc) es, enums sc ( \ (t, s) -> (t,0) #% s) ts] + VWildcard sc -> atom "Wildcard" sc + VSyntaxCat sc cat -> case w of + Yes -> atom cat sc No -> absurd cat + VNeutral s -> s + VUniverse sc -> atom "Semantics" sc + VPi s (n , t) -> "Pi" #%+ [s, n \\ t] where - enums f = foldr (%) (nil 0) . map f + enums sc f= foldr (%) (nil sc) . map f -contract :: VSyntaxDesc -> ASemanticsDesc +contract :: VSemanticsDesc -> ASemanticsDesc contract = contract' No + catToDesc :: SyntaxCat -> ASemanticsDesc catToDesc c = atom c 0 validate :: Show m => SyntaxTable -> Bwd SyntaxCat -> ASemanticsDesc -> CdB (Tm m) -> Bool validate table = go where - +{- go :: Show m => Bwd SyntaxCat -> ASemanticsDesc -> CdB (Tm m) -> Bool go env s t@(CdB V th) = reportError s t $ ($ s) $ asRec $ \ a -> a == env asAtom $ \ (a,_) -> not (null a) - VAtomBar as -> asAtom $ \ (a,_) -> not (a `elem` as) - VNil -> asAtom $ \ (a,_) -> null a + go env s t = reportError s t $ ($ t) $ flip (maybe bust) (expand table s) $ \case + VAtom _ -> asAtom $ \ (a,_) -> not (null a) + VAtomBar _ as -> asAtom $ \ (a,_) -> not (a `elem` as) + VNil _ -> asAtom $ \ (a,_) -> null a VCons s0 s1 -> asPair $ \ t0 t1 -> go env s0 t0 && go env s1 t1 VNilOrCons s0 s1 -> asNilOrCons True $ \ t0 t1 -> go env s0 t0 && go env s1 t1 VBind a s -> asBind $ \ x t -> go (env :< a) s t - VEnumOrTag es ds -> asAtomOrTagged (\ (e,_) -> e `elem` es) + VEnumOrTag _ es ds -> asAtomOrTagged (\ (e,_) -> e `elem` es) (\ (a,_) t -> case lookup a ds of Nothing -> False Just ss -> gos env ss t) - VWildcard -> \ _ -> True + VWildcard _ -> \ _ -> True reportError :: Show m => ASemanticsDesc -> CdB (Tm m) -> Bool -> Bool reportError d t True = True @@ -132,11 +135,65 @@ validate table = go where gos :: Show m => Bwd SyntaxCat -> [ASemanticsDesc] -> CdB (Tm m) -> Bool gos env [] = asNil True gos env (s:ss) = asPair $ \ t0 t1 -> go env s t0 && gos env ss t1 - +-} + +typecheck :: SyntaxTable + -> Bwd SyntaxCat -- already known syntax environment + -> HeadUpData' ActorMeta + -> Bwd ASemanticsDesc -- type context `ctx` + -> ASemanticsDesc -- type `ty` we are checking, `ty` lives in `ctx` + -> ACTm -- term `t` we are checking, `t` is alson in `ctx` + -> Bool +typecheck table env dat = check where + check :: Bwd ASemanticsDesc -> ASemanticsDesc -> ACTm -> Bool + check ctx ty t = let (Just vty) = expand table dat ty in case Term.expand t of + _ | VWildcard _ <- vty -> True + VX v sc -> ty == var ctx sc v -- should maybe be up to unfolding (which might be undecidable) + AX a sc -> case vty of + VAtom _ -> True + VAtomBar _ as -> a `notElem` as + VNil _ -> a == "" + VNilOrCons{} -> a == "" + VEnumOrTag _ es _ -> a `elem` es + VUniverse _ -> a `elem` (env :< "Semantics") + VBind{} -> False + VCons{} -> False + VSyntaxCat{} -> False + VNeutral{} -> False + VPi{} -> False + a0 :%: a1 -> case vty of + VNilOrCons ty0 ty1 -> check ctx ty0 a0 && check ctx ty1 a1 + VEnumOrTag _ _ atys -> ($ a0) $ asAtom $ \(a, _) -> case lookup a atys of + Nothing -> False + Just tys -> checks ctx tys a1 + VUniverse sc -> ($ a0) $ asAtom $ \(s, _) -> (&&) (s == "Pi") + $ ($ a1) $ asPair $ \ty0 -> asPair $ \ty1 -> asNil + $ check ctx (universe sc) ty0 && check (ctx :< ty0) (universe $ sc + 1) ty1 + VCons ty0 ty1 -> check ctx ty0 a0 && check ctx ty1 a1 + _ -> False -- don't forget to handle any new cases + op0 :-: op1 -> _ + _ :.: t0 -> case vty of + VBind cat ty0 -> check (ctx :< atom cat (scope t)) ty0 t0 + VPi ty0 (_, ty1) -> check (ctx :< ty0) ty1 t0 + _ -> False + m :$: t0 -> _ + GX _ t0 -> check ctx ty t0 + + + checks :: Bwd ASemanticsDesc -> [ASemanticsDesc] -> ACTm -> Bool + checks ctx [] t = ($ t) $ asNil True + checks ctx (ty : tys) t = ($ t) $ asPair $ \t0 t1 -> check ctx ty t0 && checks ctx tys t1 + + var :: Bwd ASemanticsDesc -> Int -> DB -> ASemanticsDesc + var ctx sc (DB i) = (ctx none (1 + i)) + + universe sc = contract $ VUniverse sc + listOf :: String -> ASemanticsDesc -> ASemanticsDesc listOf x d = let ga = scope d + 1 in "Fix" #%+ [x \\ (atom "NilOrCons" ga % (weak d % var (DB 0) ga % nil ga))] +{- rec :: String -> ASemanticsDesc rec a = atom a 0 From 734d03cd8588b40b096f64742217f2ceeeb41a81 Mon Sep 17 00:00:00 2001 From: Georgi Nakov Date: Wed, 30 Nov 2022 18:43:36 +0000 Subject: [PATCH 22/89] [ wip ] further progress / regression --- Src/Command.hs | 23 ++++++++++++++++++++--- Src/Elaboration/Monad.hs | 8 +++++++- Src/Machine/Base.hs | 2 +- Src/Operator.hs | 40 ++++++++++++++++++++++------------------ Src/Rules.hs | 2 +- Src/Semantics.hs | 2 +- Src/Term/Substitution.hs | 12 ++++++------ examples/stlcRules.act | 4 ++-- 8 files changed, 60 insertions(+), 33 deletions(-) diff --git a/Src/Command.hs b/Src/Command.hs index 692ab98..1ac6b25 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -267,20 +267,29 @@ setGlobals (decls, ops) = setDecls decls . setOperators ops sdeclOps :: [CAnOperator] -> Elab ([AAnOperator], Globals) sdeclOps [] = ([],) <$> asks globals -sdeclOps ((AnOperator (WithRange r opname) objDesc paramDescs retDesc) : ops) = do +sdeclOps ((AnOperator (WithRange r opname) (objName, objDesc) paramDescs retDesc) : ops) = do opname <- do ctxt <- ask when (Map.member opname (operators ctxt)) $ throwError (AlreadyDeclaredOperator r opname) pure (Operator opname) syndecls <- gets (Map.keys . syntaxCats) - objDesc <- ssyntaxdesc syndecls objDesc - paramDescs <- traverse (ssyntaxdesc syndecls) paramDescs + {- _ <- case objName of + Nothing -> pure (Nothing, id) + Just objName -> do + objName <- isFresh objName + pure (Just objName , local (declare )) -} + + objDesc <- _ --ssyntaxdesc syndecls objDesc + paramDescs <- _ --traverse (ssyntaxdesc syndecls) paramDescs retDesc <- ssemanticsdesc retDesc let op = AnOperator opname objDesc paramDescs retDesc (ops, decls) <- local (addOperator op) $ sdeclOps ops pure (op : ops, decls) +spatSemantics :: ASemanticsDesc -> CPattern -> Elab (APattern, _ ) +spatSemantics = _ + scommand :: CCommand -> Elab (ACommand, Globals) scommand = \case DeclJudge em jd p -> during (DeclJElaboration jd) $ do @@ -378,6 +387,14 @@ checkCompatiblePlaces places inputs outputs = do check t = Just (mergeThese const (first (, Subject ()) t)) +{- +Do not use operators to compute citizens from subjects. +Rather, transmit glued subject-citizen pairs, +when matching a subject, glue metavars to pattern vars +then use s => c clauses ub rules to constrain the citizen +the parent sent with the subject syntax. +-} + sjudgementform :: JUDGEMENTFORM Concrete -> Elab (JUDGEMENTFORM Abstract, Globals) sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do inputs <- concat <$> traverse subjects jpreconds -- TODO: should really be the closure of this info diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index f6ef7e7..be9c9e2 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -162,7 +162,13 @@ data ObjVar = ObjVar , objVarDesc :: Info ASemanticsDesc } deriving (Show, Eq) -type ObjVars = Bwd ObjVar +-- ObjVars is a representation of variable contexts +-- which are in scope for all the types they contain, +-- i.e. they should be weakened on extension, not on +-- lookup. + +newtype ObjVars = ObjVars { getObjVars :: Bwd ObjVar } + deriving (Show, Eq) data Provenance = Parent | Pattern deriving (Show, Eq) diff --git a/Src/Machine/Base.hs b/Src/Machine/Base.hs index f31897e..a9af073 100644 --- a/Src/Machine/Base.hs +++ b/Src/Machine/Base.hs @@ -132,7 +132,7 @@ instance Instantiable Term where followDirectives :: (Show t, Instantiable t, Instantiated t ~ t) => HeadUpData -> Format Directive dbg t -> Format () dbg t -followDirectives dat@(HeadUpData _ store _ _) = \case +followDirectives dat@(HeadUpData _ store _ _ _) = \case TermPart Instantiate t -> TermPart () (instantiate store t) TermPart Normalise t -> TermPart () (normalise dat t) TermPart Raw t -> TermPart () t diff --git a/Src/Operator.hs b/Src/Operator.hs index d867e31..8644b24 100644 --- a/Src/Operator.hs +++ b/Src/Operator.hs @@ -8,42 +8,44 @@ import Concrete.Parse import Location import Parse import Options -import Actor (Env, Env') +import Actor ( Env') import Term.Base ------------------------------------------------------------------------------ -- Operators data ANOPERATOR (ph :: Phase) = AnOperator - { opName :: OPERATOR ph - , objDesc :: SYNTAXDESC ph - , paramDescs :: [SYNTAXDESC ph] - , retDesc :: SEMANTICSDESC ph + { opName :: OPERATOR ph + , objDesc :: (Maybe (ACTORVAR ph), PATTERN ph) + , paramDescs :: [(Maybe (ACTORVAR ph), SEMANTICSDESC ph)] + , retDesc :: SEMANTICSDESC ph } deriving instance ( Show (OPERATOR ph) - , Show (SYNTAXDESC ph) + , Show (ACTORVAR ph) + , Show (PATTERN ph) , Show (SEMANTICSDESC ph) ) => Show (ANOPERATOR ph) type CAnOperator = ANOPERATOR Concrete type AAnOperator = ANOPERATOR Abstract -data Operator = Operator { getOperator :: String } +newtype Operator = Operator { getOperator :: String } deriving (Show, Eq) type family OPERATOR (ph :: Phase) :: * type instance OPERATOR Concrete = WithRange String type instance OPERATOR Abstract = Operator -newtype Clause = Clause { runClause - :: forall m +newtype Clause = Clause + { runClause :: forall m . Options -> (Term' m -> Term' m) -- head normaliser -> Env' m -> (Term' m, [Term' m]) -- object & parameters - -> Either (Term' m, [Term' m]) (Term' m) } + -> Either (Term' m, [Term' m]) (Term' m) + } instance Semigroup Clause where (<>) = mappend @@ -76,12 +78,14 @@ poperator ph = (,[]) <$> pwithRange patom <|> (,) <$ pch (== '[') <* pspc <*> pwithRange patom <*> many (id <$ pspc <*> ph) <* pspc <* pch (== ']') -panoperator :: String -> Parser CAnOperator -panoperator copula = do - obj <- psyntaxdecl +panoperator :: Parser CAnOperator +panoperator = do + obj <- pmaybeNamed ppat punc "-" - (opname, params) <- poperator psyntaxdecl - punc copula - ret <- psemanticsdecl - pure (AnOperator opname obj params ret) - + (opname, params) <- poperator $ pmaybeNamed psemanticsdecl + punc ":" + AnOperator opname obj params <$> psemanticsdecl + where + pmaybeNamed :: Parser a -> Parser (Maybe (ACTORVAR Concrete), a) + pmaybeNamed p = pparens ((,) . Just <$> pvariable <* punc ":" <*> p) + <|> (Nothing,) <$> p diff --git a/Src/Rules.hs b/Src/Rules.hs index dd8555b..2bf8cb4 100644 --- a/Src/Rules.hs +++ b/Src/Rules.hs @@ -133,4 +133,4 @@ pjudgementform :: Parser CJudgementForm pjudgementform = withRange $ JudgementForm unknown <$ pkeyword KwJudgementForm <* pspc <*> pcurlies (psep (punc ";") pjudgement) <* pspc <*> pextractmode <*> pvariable <* pspc <*> psep pspc pplace - <* pspc <*> pcurlies (psep (punc ";") (Left <$> pjudgement <|> Right <$> panoperator ":")) + <* pspc <*> pcurlies (psep (punc ";") (Left <$> pjudgement <|> Right <$> panoperator)) diff --git a/Src/Semantics.hs b/Src/Semantics.hs index 60bbc4e..58359e3 100644 --- a/Src/Semantics.hs +++ b/Src/Semantics.hs @@ -171,7 +171,7 @@ typecheck table env dat = check where $ check ctx (universe sc) ty0 && check (ctx :< ty0) (universe $ sc + 1) ty1 VCons ty0 ty1 -> check ctx ty0 a0 && check ctx ty1 a1 _ -> False -- don't forget to handle any new cases - op0 :-: op1 -> _ + a0 :-: a1 -> _ _ :.: t0 -> case vty of VBind cat ty0 -> check (ctx :< atom cat (scope t)) ty0 t0 VPi ty0 (_, ty1) -> check (ctx :< ty0) ty1 t0 diff --git a/Src/Term/Substitution.hs b/Src/Term/Substitution.hs index b580223..ba59d5c 100644 --- a/Src/Term/Substitution.hs +++ b/Src/Term/Substitution.hs @@ -21,16 +21,16 @@ euclid x y = let d = x - y in case d < 0 of True -> LtBy (negate d) False -> GeBy d -(//^) :: Show m => CdB (Tm m) -> CdB (Sbst m) -> CdB (Tm m) +(//^) :: CdB (Tm m) -> CdB (Sbst m) -> CdB (Tm m) tth@(CdB t th) //^ sgph@(CdB sg ph) = - track "\n" $ - track ("Term: " ++ show tth) $ - track ("Subst: " ++ show sgph) $ +-- track "\n" $ +-- track ("Term: " ++ show tth) $ +-- track ("Subst: " ++ show sgph) $ case sbstSel th sg of CdB sg ps -> let res = CdB (t // sg) (ps <^> ph) in - track ("Result: " ++ show res) $ - track "\n" $ +-- track ("Result: " ++ show res) $ +-- track "\n" $ res (//) :: Tm m -> Sbst m -> Tm m diff --git a/examples/stlcRules.act b/examples/stlcRules.act index e23dc63..9cf25e2 100644 --- a/examples/stlcRules.act +++ b/examples/stlcRules.act @@ -54,8 +54,8 @@ judgementform judgementform {} - synth (t : 'Synth => T - 'Value) T - {type T} + synth (e : 'Synth => S - 'Value) S + {type S} -- Open question in the above: will it always be the subject that's fed to an operator? -- Note: the "T - 'Value" is in 'Semantics and that T is the citizen, not the subject From da55c25c4b47fd98b131e2b2f5ec2249f012857b Mon Sep 17 00:00:00 2001 From: Georgi Nakov Date: Fri, 2 Dec 2022 10:25:09 +0000 Subject: [PATCH 23/89] [ wip ] small fixes, still not compiling --- Src/Command.hs | 1 + Src/Machine/Base.hs | 4 ++-- Src/Machine/Display.hs | 8 ++++---- Src/Machine/Exec.hs | 1 + Src/Machine/Trace.hs | 2 +- 5 files changed, 9 insertions(+), 7 deletions(-) diff --git a/Src/Command.hs b/Src/Command.hs index 1ac6b25..6b577fc 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -45,6 +45,7 @@ import Utils import Data.Char (isSpace) import qualified Data.Set as Set +import Operator type family SYNTAXCAT (ph :: Phase) :: * type instance SYNTAXCAT Concrete = WithRange SyntaxCat diff --git a/Src/Machine/Base.hs b/Src/Machine/Base.hs index a9af073..9248aae 100644 --- a/Src/Machine/Base.hs +++ b/Src/Machine/Base.hs @@ -117,7 +117,7 @@ instance Instantiable Term where s :%: t -> instantiate store s % instantiate store t s :-: t -> contract (instantiate store s :-: instantiate store t) x :.: b -> x \\ instantiate store b - m :$: sg -> case join $ fmap snd $ Map.lookup m (solutions store) of + m :$: sg -> case snd =<< Map.lookup m (solutions store) of Nothing -> m $: sg -- TODO: instantiate sg Just tm -> instantiate store (tm //^ sg) GX g t -> contract (GX g (instantiate store t)) @@ -189,7 +189,7 @@ toClause :: Pat -> Bwd (Operator, [Pat]) -> ACTm -> (Term, [Term]) -- object & parameters -> Either (Term, [Term]) Term toClause pobj (ops :< op) rhs opts hnf env targs@(t, args) = - let msg = \ result -> flush $ vcat + let msg result = flush $ vcat [ hsep ( "Matching" : withANSI [SetColour Background Green] (unsafeDocDisplayClosed opts t) : "-" diff --git a/Src/Machine/Display.hs b/Src/Machine/Display.hs index e665f72..77c3a90 100644 --- a/Src/Machine/Display.hs +++ b/Src/Machine/Display.hs @@ -22,6 +22,7 @@ import Term import Term.Display () import Unelaboration (DAEnv, initDAEnv, Naming, nameOn, initNaming) import qualified Unelaboration as A +import Operator.Eval (StoreF (..)) instance Display Date where type DisplayEnv Date = () @@ -57,7 +58,7 @@ instance Forget DEnv DEnv where forget = id initChildDEnv :: Channel -> DEnv -> DEnv -initChildDEnv ch de = de { daEnv = A.declareChannel ch $ initDAEnv } +initChildDEnv ch de = de { daEnv = A.declareChannel ch initDAEnv } declareChannel :: Channel -> DEnv -> DEnv declareChannel ch de@DEnv{..} = de { daEnv = A.declareChannel ch daEnv } @@ -141,7 +142,7 @@ displayProcess' Process{..} = do put (de `frameOn` f) pure dis -type Store = StoreF Naming +type Store = StoreF Naming Date instance Display Store where type DisplayEnv Store = () @@ -181,8 +182,7 @@ frDisplayEnv = foldl frameOn initDEnv insertDebug :: (Traversable t, Collapse t, Display0 s) => Process log s t -> [Format dir Debug a] -> [Format dir (Doc Annotations) a] -insertDebug p fmt = map go fmt where - +insertDebug p = map go where (fs, st, en, _) = unsafeEvalDisplay initDEnv (displayProcess' p) go = \case TermPart d t -> TermPart d t diff --git a/Src/Machine/Exec.hs b/Src/Machine/Exec.hs index 20774bb..dcf8969 100644 --- a/Src/Machine/Exec.hs +++ b/Src/Machine/Exec.hs @@ -33,6 +33,7 @@ import Machine.Trace import System.IO.Unsafe import Debug.Trace +import Operator.Eval dmesg = trace diff --git a/Src/Machine/Trace.hs b/Src/Machine/Trace.hs index 3569e96..85c6560 100644 --- a/Src/Machine/Trace.hs +++ b/Src/Machine/Trace.hs @@ -56,7 +56,7 @@ type instance ITERM Abstract = Term type instance ITERM Concrete = Raw data ARGUMENT (ph :: Phase) f ann = Argument - { argMode :: Mode () -- + { argMode :: Mode () , argDesc :: SyntaxDesc , argTerm :: f (ITERM ph) ann } From 40d69979268d95e55dc297c3f86ca562c1b6f770 Mon Sep 17 00:00:00 2001 From: Georgi Nakov Date: Fri, 2 Dec 2022 18:13:29 +0000 Subject: [PATCH 24/89] [ wip ] towards scope checking operator declarations (courtesy of @Fred) --- Src/Actor.hs | 2 +- Src/Command.hs | 46 ++++++++++++++++-------- Src/Elaboration.hs | 52 ++++++++++++++------------- Src/Elaboration/Monad.hs | 78 +++++++++++++++------------------------- Src/Info.hs | 26 ++++++++++++++ Src/Operator.hs | 45 ++++++++++++++++++++--- Src/Semantics.hs | 4 +-- typos.cabal | 1 + 8 files changed, 159 insertions(+), 95 deletions(-) create mode 100644 Src/Info.hs diff --git a/Src/Actor.hs b/Src/Actor.hs index ae2d3aa..8d243fc 100644 --- a/Src/Actor.hs +++ b/Src/Actor.hs @@ -60,13 +60,13 @@ type ACTm = CdB (Tm ActorMeta) type ACTSbst = CdB (Sbst ActorMeta) type AScrutinee = SCRUTINEE Abstract +type instance SEMANTICSDESC Abstract = ACTm aconnect :: Range -> Channel -> Th -> Channel -> Int -> AActor aconnect r ch1 th ch2 n | n > 0 = Connect r (AConnect ch1 th ch2 n) | otherwise = Win r - data Env' m = Env { globalScope :: Bwd String -- free vars ga actor does *not* know about , actorVars :: Map ActorMeta (EnvImg' m) diff --git a/Src/Command.hs b/Src/Command.hs index 6b577fc..f351048 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -275,20 +275,38 @@ sdeclOps ((AnOperator (WithRange r opname) (objName, objDesc) paramDescs retDesc throwError (AlreadyDeclaredOperator r opname) pure (Operator opname) syndecls <- gets (Map.keys . syntaxCats) - {- _ <- case objName of - Nothing -> pure (Nothing, id) - Just objName -> do - objName <- isFresh objName - pure (Just objName , local (declare )) -} - - objDesc <- _ --ssyntaxdesc syndecls objDesc - paramDescs <- _ --traverse (ssyntaxdesc syndecls) paramDescs - retDesc <- ssemanticsdesc retDesc - let op = AnOperator opname objDesc paramDescs retDesc - (ops, decls) <- local (addOperator op) $ sdeclOps ops - pure (op : ops, decls) - -spatSemantics :: ASemanticsDesc -> CPattern -> Elab (APattern, _ ) + (objName, objBinder) <- case objName of + Nothing -> pure (Nothing, Unused) + Just objName -> do + objName <- isFresh objName + pure (Just objName , Used objName) + (descPat, objDesc, ds) <- spatSemantics (atom "Semantics" 0) objDesc + ovs <- asks objVars + local (declare objBinder (ActVar IsNotSubject (ovs :=> objDesc) . setDecls ds)) $ do + (paramDescs, ds) <- sparamdescs paramDescs + retDesc <- local (setDecls ds) $ ssemanticsdesc retDesc + let op = AnOperator opname objDesc paramDescs retDesc + (ops, decls) <- local (addOperator op) $ sdeclOps ops + pure (op : ops, decls) + +-- TODO: change "Maybe" to "Binder" in Anoperator + +sparamdescs :: [(Maybe Variable, Raw)] -> Elab ([(Maybe ActorVar, ASOT)], Decls) +sparamdescs [] = ([],) <$> asks declarations +sparamdescs ((mx , ty):ps) = do + (mx, binder) <- case mx of + Nothing -> pure (Nothing, Unused) + Just x -> do + x <- isFresh x + pure (Just x , Used x) + ovs <- asks objVars + ty <- ssemanticsdesc ty + let sty = ovs :=> ty + (ps, ds) <- local (declare binder (ActVar IsNotSubject sty)) $ sparamdescs ps + pure ((mx , sty):ps, ds) + + +spatSemantics :: ASemanticsDesc -> CPattern -> Elab (APattern, ASemanticsDesc, Decls) spatSemantics = _ scommand :: CCommand -> Elab (ACommand, Globals) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 78df1b1..ea28d95 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -22,6 +22,7 @@ import Scope import Syntax import Thin import Utils +import Info import Elaboration.Monad import Term.Base @@ -32,6 +33,8 @@ import Location import Data.List.NonEmpty (fromList) import Pattern.Coverage (Covering'(..), combine, shrinkBy, missing) import Control.Applicative ((<|>)) +import Operator +import qualified Semantics isSubject :: EScrutinee -> IsSubject' () isSubject SubjectVar{} = IsSubject () @@ -40,13 +43,13 @@ isSubject _ = IsNotSubject -- must be used in definition mode only checkSendableSubject :: Raw -> Elab (Maybe ActorVar) checkSendableSubject tm = do - localVars <- asks objVars + localVars <- asks (getObjVars . objVars) go (fmap objVarName localVars) tm where go :: Bwd String -> Raw -> Elab (Maybe ActorVar) go localVars x = case x of Var r v -> resolve v >>= \case - Just (Left (ActVar (IsSubject {}) _ _)) -> pure . Just $ getVariable v + Just (Left (ActVar (IsSubject {}) _)) -> pure . Just $ getVariable v _ -> Nothing <$ raiseWarning (SentSubjectNotASubjectVar (getRange tm) tm) Sbst r sg x -> do case isInvertible localVars sg of @@ -103,22 +106,22 @@ svar usage x = do ovs <- asks objVars res <- resolve x case res of - Just (Left k) -> case k of -- TODO: come back and remove fst <$> - ActVar isSub desc sc -> case findSub (objVarName <$> sc) (objVarName <$> ovs) of + Just (Left k) -> case k of + ActVar isSub (sc :=> desc) -> case sc `thinsTo` ovs of Just th -> do logUsage (getVariable x) usage pure (isSub, desc, ActorMeta (spassport usage isSub) (getVariable x) $: sbstW (sbst0 0) th) Nothing -> throwError (MetaScopeTooBig (getRange x) x sc ovs) _ -> throwError (NotAValidTermVariable (getRange x) x k) - Just (Right (desc, i)) -> pure (IsNotSubject, desc, var i (length ovs)) + Just (Right (desc, i)) -> pure (IsNotSubject, desc, var i (scopeSize ovs)) Nothing -> throwError (OutOfScope (getRange x) x) -spop :: Range -> Elab (ObjVars, (Variable, Info SyntaxDesc)) +spop :: Range -> Elab (ObjVars, (Variable, Info ASemanticsDesc)) spop r = do ovs <- asks objVars - case ovs of + case getObjVars ovs of B0 -> throwError (EmptyContext r) - (xz :< ObjVar x cat) -> pure (xz, (Variable r x, cat)) + (xz :< ObjVar x cat) -> pure (ObjVars xz, (Variable r x, cat)) ssyntaxdesc :: [SyntaxCat] -> Raw -> Elab SyntaxDesc ssyntaxdesc syndecls syn = do @@ -138,13 +141,13 @@ ssemanticsdesc sem = do ssbst :: Usage -> Bwd SbstC -> Elab (ACTSbst, ObjVars) ssbst usage B0 = do ovs <- asks objVars - pure (sbstI (length ovs), ovs) + pure (sbstI (scopeSize ovs), ovs) ssbst usage (sg :< sgc) = case sgc of Keep r v -> do (xz, (w, cat)) <- spop r when (v /= w) $ throwError (NotTopVariable r v w) (sg, ovs) <- local (setObjVars xz) (ssbst usage sg) - pure (sbstW sg (ones 1), ovs :< ObjVar (getVariable w) cat) + pure (sbstW sg (ones 1), ovs <: ObjVar (getVariable w) cat) Drop r v -> do (xz, (w, cat)) <- spop r when (v /= w) $ throwError (NotTopVariable r v w) @@ -156,12 +159,12 @@ ssbst usage (sg :< sgc) = case sgc of t <- stm usage desc t (sg, ovs) <- ssbst usage sg v <- local (setObjVars ovs) $ isFresh v - pure (sbstT sg ((Hide v :=) $^ t), ovs :< ObjVar v info) + pure (sbstT sg ((Hide v :=) $^ t), ovs <: ObjVar v info) sth :: (Bwd Variable, ThDirective) -> Elab Th sth (xz, b) = do ovs <- asks objVars - let th = which (`elem` (getVariable <$> xz)) (objVarName <$> ovs) + let th = which (`elem` (getVariable <$> xz)) (objVarName <$> getObjVars ovs) pure $ case b of ThKeep -> th ThDrop -> comp th @@ -317,17 +320,17 @@ spat esc@(Lookup _ _ av) rp@(ConsP r (AtP _ "Just") (ConsP _ _ (AtP _ ""))) = do logUsage av (SuccessfullyLookedUp r) spatBase IsNotSubject (escrutinee esc) rp spat esc@(Lookup _ _ av) rp = spatBase IsNotSubject (escrutinee esc) rp -spat esc@(Compare _ _ _) rp = spatBase IsNotSubject (escrutinee esc) rp -spat esc@(Term _ _) rp = spatBase IsNotSubject (escrutinee esc) rp +spat esc@(Compare{}) rp = spatBase IsNotSubject (escrutinee esc) rp +spat esc@(Term{}) rp = spatBase IsNotSubject (escrutinee esc) rp -spatBase :: IsSubject -> SyntaxDesc -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) +spatBase :: IsSubject -> ASemanticsDesc -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) spatBase isSub desc rp@(AsP r v p) = do unless (isSub == IsNotSubject) $ throwError (AsPatternCannotHaveSubjects r rp) v <- isFresh v ds <- asks declarations ovs <- asks objVars - (mr, p, ds, hs) <- local (setDecls (ds :< (v, ActVar isSub (Known desc) ovs))) $ spatBase isSub desc p + (mr, p, ds, hs) <- local (setDecls (ds :< (v, ActVar isSub (ovs :=> desc)))) $ spatBase isSub desc p pure (mr, AT (ActorMeta ACitizen v) p, ds, hs) spatBase isSub desc (ThP r th p) = do th <- sth th @@ -346,8 +349,8 @@ spatBase isSub desc (VarP r v) = during (PatternVariableElaboration v) $ do Nothing -> do ovs <- asks objVars v <- pure (getVariable v) - let pat = MP (ActorMeta (spassport (Scrutinised unknown) isSub) v) (ones (length ovs)) - pure (Nothing, pat, ds :< (v, ActVar isSub (Known desc) ovs), hs) + let pat = MP (ActorMeta (spassport (Scrutinised unknown) isSub) v) (ones $ scopeSize ovs) + pure (Nothing, pat, ds :< (v, ActVar isSub (ovs :=> desc)), hs) spatBase isSub desc (UnderscoreP r) = do let mr = case isSub of IsSubject{} -> Just r @@ -482,18 +485,19 @@ withChannel r dir ch@(Channel rch) p ma = do pure a guessDesc :: Bool -> -- is this in tail position? - Raw -> Elab (Info SyntaxDesc) + Raw -> Elab (Info ASemanticsDesc) guessDesc b (Var _ v) = resolve v >>= \case Just (Right (info, i)) -> pure info - Just (Left (ActVar isSub info _)) -> pure info + Just (Left (ActVar isSub (ObjVars B0 :=> desc))) -> pure $ Known desc _ -> pure Unknown guessDesc b (Cons _ p q) = do dp <- guessDesc False p dq <- guessDesc True q case (dp, dq) of - (Known d1, Known d2) -> pure (Known $ Syntax.contract (VCons d1 d2)) + (Known d1, Known d2) -> pure (Known $ Semantics.contract (VCons d1 d2)) _ -> pure Unknown -guessDesc True (At _ "") = pure (Known $ Syntax.contract VNil) +-- might need better guess for the scope than 0 +guessDesc True (At _ "") = pure (Known $ Semantics.contract (VNil 0)) guessDesc _ _ = pure Unknown compatibleChannels :: Range -> (Direction, [AProtocolEntry]) -> Ordering -> (Direction, [AProtocolEntry]) -> Elab Int @@ -709,7 +713,7 @@ consistentScrutinisation :: Range -> [ActvarStates] -> Elab () consistentScrutinisation r sts = do ds <- asks declarations let subjects = flip foldMap ds $ \case - (nm, ActVar IsSubject{} _ _) -> Set.singleton nm + (nm, ActVar IsSubject{} _) -> Set.singleton nm _ -> Set.empty let check = List.groupBy cmp (flip Map.restrictKeys subjects <$> sts) unless (null check) $ @@ -731,7 +735,7 @@ sbranch r ds ra = do (a, All b) <- censor (const (All True)) $ listen $ sact ra -- make sure that the *newly bound* subject variables have been scrutinised forM ds $ \case -- HACK - (nm, ActVar isSub _ _) -> + (nm, ActVar isSub _) -> unlessM (checkScrutinised (Used nm)) $ -- whenJust me $ \ _ -> -- HACK: do not complain about dead branches case isSub of diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index be9c9e2..555fee5 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -12,19 +12,20 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe) -import Actor (ActorVar, AContextStack, AProtocol, Channel, JudgementName) +import Actor import Bwd import Concrete.Base import Location (HasGetRange(..), Range, WithRange (..)) -import Syntax (SyntaxCat, SyntaxDesc, VSyntaxDesc'(..), VSyntaxDesc, SyntaxTable, wildcard) -import Semantics (embed) +import Syntax (SyntaxCat, SyntaxDesc, VSyntaxDesc'(..), VSyntaxDesc, SyntaxTable) import qualified Syntax -import Thin (Selable(..), DB (..), CdB (..)) -import Term.Base (Tm(..), atom) +import Thin +import Term.Base import Utils -import Machine.Base import Operator import Rules +import Info +import Pattern +import Hide ------------------------------------------------------------------------------ -- Elaboration Monad @@ -105,27 +106,6 @@ evalElab = fmap fst ------------------------------------------------------------------------------ -- Partial Info -data Info a = Unknown | Known a | Inconsistent - deriving (Show, Eq, Functor) - -instance Applicative Info where - pure = Known - (<*>) = ap - -instance Monad Info where - Unknown >>= f = Unknown - Known a >>= f = f a - Inconsistent >>= f = Inconsistent - -instance Eq a => Semigroup (Info a) where - Unknown <> y = y - x <> Unknown = x - Known x <> Known y | x == y = Known x - _ <> _ = Inconsistent - -instance Eq a => Monoid (Info a) where - mempty = Unknown - infoExpand :: SyntaxTable -> SyntaxDesc -> Info VSyntaxDesc infoExpand table s = case Syntax.expand table s of Nothing -> Inconsistent @@ -157,19 +137,6 @@ compatibleInfos r desc desc' = do ------------------------------------------------------------------------------ -- Context -data ObjVar = ObjVar - { objVarName :: String - , objVarDesc :: Info ASemanticsDesc - } deriving (Show, Eq) - --- ObjVars is a representation of variable contexts --- which are in scope for all the types they contain, --- i.e. they should be weakened on extension, not on --- lookup. - -newtype ObjVars = ObjVars { getObjVars :: Bwd ObjVar } - deriving (Show, Eq) - data Provenance = Parent | Pattern deriving (Show, Eq) @@ -195,14 +162,14 @@ isSubjectFree = \case SubjectVar{} -> False data Kind - = ActVar IsSubject (Info ASemanticsDesc) ObjVars + = ActVar IsSubject ASOT | AChannel ObjVars | AJudgement ExtractMode AProtocol | AStack AContextStack deriving (Show) type Decls = Bwd (String, Kind) -type Operators = Map String (SyntaxDesc, [SyntaxDesc], ASemanticsDesc) +type Operators = Map String AAnOperator data Context = Context { objVars :: ObjVars @@ -221,23 +188,36 @@ data ElabMode = Definition | Execution initContext :: Context initContext = Context - { objVars = B0 + { objVars = ObjVars B0 , declarations = B0 , operators = Map.fromList - [ ("app", (wildcard, [wildcard], embed wildcard)) + [ ("app", AnOperator + { opName = Operator "app" + , objDesc = (Nothing, PP (AP "Pi") + $ PP (MP (am "S") (ones 0)) + $ PP (BP (Hide "x") + $ MP (am "T") (ones 1)) $ AP "") + , paramDescs = [(Just (am "s"), ObjVars B0 :=> (am "S" $: sbstI 0))] + , retDesc = ObjVars (B0 :< ObjVar "s" (Known (am "S" $: sbstI 0))) :=> (am "T" $: topSbst "x" (var (DB 0) 1)) + }) ] , location = B0 , binderHints = Map.empty , elabMode = Definition , stackTrace = [] } + where + am = ActorMeta ACitizen declareObjVar :: (String, Info ASemanticsDesc) -> Context -> Context -declareObjVar (x, info) ctx = ctx { objVars = objVars ctx :< ObjVar x info } +declareObjVar (x, info) ctx = ctx { objVars = ObjVars $ getObjVars (objVars ctx) :< ObjVar x info } setObjVars :: ObjVars -> Context -> Context setObjVars ovs ctx = ctx { objVars = ovs } +instance Selable ObjVars where + th ^? (ObjVars ovs) = ObjVars (th ^? ovs) + instance Selable Context where th ^? ctxt = ctxt { objVars = th ^? objVars ctxt } @@ -269,8 +249,8 @@ setOperators :: Operators -> Context -> Context setOperators ops ctx = ctx { operators = ops } addOperator :: AAnOperator -> Context -> Context -addOperator (AnOperator (Operator op) obj params ret) ctx = - ctx { operators = Map.insert op (obj, params, ret) (operators ctx) } +addOperator op ctx = + ctx { operators = Map.insert (getOperator . opName $ op) op (operators ctx) } ------------------------------------------------------------------------------ -- Hints @@ -518,11 +498,11 @@ channelDelete ch st = st { channelStates = Map.delete ch (channelStates st) } ------------------------------------------------------------------------------ -- Variable lookup -resolve :: Variable -> Elab (Maybe (Either Kind (Info SyntaxDesc, DB))) +resolve :: Variable -> Elab (Maybe (Either Kind (Info ASemanticsDesc, DB))) resolve (Variable r x) = do ctx <- ask let ds = declarations ctx - let ovs = objVars ctx + let ovs = getObjVars . objVars $ ctx case focusBy (\ (y, k) -> k <$ guard (x == y)) ds of Just (_, k, _) -> pure (Just $ Left k) _ -> case focusBy (\ (ObjVar y desc) -> desc <$ guard (x == y)) ovs of diff --git a/Src/Info.hs b/Src/Info.hs new file mode 100644 index 0000000..02c0a6f --- /dev/null +++ b/Src/Info.hs @@ -0,0 +1,26 @@ +module Info where +import Control.Monad + +-- Partial info + +data Info a = Unknown | Known a | Inconsistent + deriving (Show, Eq, Functor) + + +instance Applicative Info where + pure = Known + (<*>) = ap + +instance Monad Info where + Unknown >>= f = Unknown + Known a >>= f = f a + Inconsistent >>= f = Inconsistent + +instance Eq a => Semigroup (Info a) where + Unknown <> y = y + x <> Unknown = x + Known x <> Known y | x == y = Known x + _ <> _ = Inconsistent + +instance Eq a => Monoid (Info a) where + mempty = Unknown diff --git a/Src/Operator.hs b/Src/Operator.hs index 8644b24..59a9e8f 100644 --- a/Src/Operator.hs +++ b/Src/Operator.hs @@ -8,8 +8,45 @@ import Concrete.Parse import Location import Parse import Options -import Actor ( Env') +import Actor ( Env', ACTm) import Term.Base +import Info +import Bwd +import Thin + +data ObjVar = ObjVar + { objVarName :: String + , objVarDesc :: Info ASemanticsDesc + } deriving (Show, Eq) + +-- ObjVars is a representation of variable contexts +-- which are in scope for all the types they contain, +-- i.e. they should be weakened on extension, not on +-- lookup. + +newtype ObjVars = ObjVars { getObjVars :: Bwd ObjVar } + deriving (Show, Eq) + +thinsTo :: ObjVars -> ObjVars -> Maybe Th +thinsTo (ObjVars x) (ObjVars y) = findSub (objVarName <$> x) (objVarName <$> y) + +scopeSize :: ObjVars -> Int +scopeSize = length . getObjVars + +(<:) :: ObjVars -> ObjVar -> ObjVars +(ObjVars xz) <: x = ObjVars $ xz :< x + +-- Second Order Type +type family SOT (ph :: Phase) :: * +type instance SOT Concrete = Raw +type instance SOT Abstract = ASOT + + +-- ObjVars are in scope for the ACTm +data ASOT = ObjVars :=> ACTm + deriving (Show) + +infix 2 :=> ------------------------------------------------------------------------------ -- Operators @@ -17,15 +54,15 @@ import Term.Base data ANOPERATOR (ph :: Phase) = AnOperator { opName :: OPERATOR ph , objDesc :: (Maybe (ACTORVAR ph), PATTERN ph) - , paramDescs :: [(Maybe (ACTORVAR ph), SEMANTICSDESC ph)] - , retDesc :: SEMANTICSDESC ph + , paramDescs :: [(Maybe (ACTORVAR ph), SOT ph)] + , retDesc :: SOT ph } deriving instance ( Show (OPERATOR ph) , Show (ACTORVAR ph) , Show (PATTERN ph) - , Show (SEMANTICSDESC ph) + , Show (SOT ph) ) => Show (ANOPERATOR ph) type CAnOperator = ANOPERATOR Concrete diff --git a/Src/Semantics.hs b/Src/Semantics.hs index 58359e3..458727f 100644 --- a/Src/Semantics.hs +++ b/Src/Semantics.hs @@ -18,8 +18,6 @@ import qualified Term import Syntax (SyntaxTable, SyntaxCat, WithSyntaxCat(..)) import Operator.Eval -type instance SEMANTICSDESC Abstract = ACTm - embed :: ASyntaxDesc -> ASemanticsDesc embed = (fmap absurd $^) @@ -111,7 +109,7 @@ catToDesc :: SyntaxCat -> ASemanticsDesc catToDesc c = atom c 0 validate :: Show m => SyntaxTable -> Bwd SyntaxCat -> ASemanticsDesc -> CdB (Tm m) -> Bool -validate table = go where +validate table = _ {- go :: Show m => Bwd SyntaxCat -> ASemanticsDesc -> CdB (Tm m) -> Bool go env s t@(CdB V th) = reportError s t $ ($ s) $ asRec $ \ a -> a == env Date: Wed, 7 Dec 2022 17:56:13 +0000 Subject: [PATCH 25/89] [ wip ] fixing (and introducing) errors in elaboration --- Src/Actor.hs | 2 +- Src/Concrete/Base.hs | 6 +-- Src/Elaboration.hs | 113 +++++++++++++++++++++------------------ Src/Elaboration/Monad.hs | 37 ++++++++----- Src/Operator.hs | 3 +- Src/Operator/Eval.hs | 5 +- Src/Pattern/Coverage.hs | 99 +++++++++++++++++++--------------- Src/Semantics.hs | 14 +++++ 8 files changed, 164 insertions(+), 115 deletions(-) diff --git a/Src/Actor.hs b/Src/Actor.hs index 8d243fc..6983583 100644 --- a/Src/Actor.hs +++ b/Src/Actor.hs @@ -90,7 +90,7 @@ declareAlpha ("_", y) rho = rho declareAlpha (x, y) rho = rho { alphaRenamings = Map.insert x y (alphaRenamings rho) } -initEnv :: Bwd String -> Env +initEnv :: Bwd String -> Env' m initEnv gamma = Env { globalScope = gamma , actorVars = Map.empty diff --git a/Src/Concrete/Base.hs b/Src/Concrete/Base.hs index c8f77f2..143fddd 100644 --- a/Src/Concrete/Base.hs +++ b/Src/Concrete/Base.hs @@ -261,8 +261,8 @@ data ACTOR (ph :: Phase) | Recv Range (CHANNEL ph) (BINDER ph, ACTOR ph) | Connect Range (CONNECT ph) | Note Range (ACTOR ph) - | FreshMeta Range (SYNTAXDESC ph) (ACTORVAR ph, ACTOR ph) - | Let Range (ACTORVAR ph) (SYNTAXDESC ph) (TERM ph) (ACTOR ph) + | FreshMeta Range (SEMANTICSDESC ph) (ACTORVAR ph, ACTOR ph) + | Let Range (ACTORVAR ph) (SEMANTICSDESC ph) (TERM ph) (ACTOR ph) | Under Range (Scope Variable (ACTOR ph)) | Match Range (SCRUTINEE ph) [(PATTERN ph, ACTOR ph)] -- This is going to bite us when it comes to dependent types @@ -288,7 +288,7 @@ deriving instance , Show (ACTORVAR ph) , Show (SCRUTINEEVAR ph) , Show (SCRUTINEETERM ph) - , Show (SYNTAXDESC ph) + , Show (SEMANTICSDESC ph) , Show (TERMVAR ph) , Show (TERM ph) , Show (PATTERN ph) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index ea28d95..bd6a2b8 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -20,6 +20,8 @@ import Format import Hide import Scope import Syntax + ( SyntaxCat, + SyntaxDesc, syntaxDesc) import Thin import Utils import Info @@ -34,7 +36,7 @@ import Data.List.NonEmpty (fromList) import Pattern.Coverage (Covering'(..), combine, shrinkBy, missing) import Control.Applicative ((<|>)) import Operator -import qualified Semantics +import Semantics isSubject :: EScrutinee -> IsSubject' () isSubject SubjectVar{} = IsSubject () @@ -66,12 +68,13 @@ checkSendableSubject tm = do = (:< getVariable v) <$> isInvertible (lz <>< ls) sz isInvertible _ _ = Nothing -escrutinee :: EScrutinee -> SyntaxDesc +escrutinee :: EScrutinee -> ASemanticsDesc escrutinee = \case - Pair _ p q -> Syntax.contract (VCons (escrutinee p) (escrutinee q)) + Pair _ p q -> Semantics.contract (Semantics.VCons (escrutinee p) (escrutinee q)) SubjectVar _ desc -> desc Lookup _ desc _ -> desc - Compare _ _ _ -> Syntax.contract (VEnumOrTag ["LT", "EQ", "GT"] []) + -- TODO : do we need to pass in the scope? + Compare _ t1 t2 -> Semantics.contract (Semantics.VEnumOrTag 0 ["LT", "EQ", "GT"] []) Term _ desc -> desc dual :: PROTOCOL ph -> PROTOCOL ph @@ -103,14 +106,14 @@ spassport _ _ = ACitizen svar :: Usage -> Variable -> Elab (IsSubject, Info ASemanticsDesc, ACTm) svar usage x = do - ovs <- asks objVars + ovs <- asks objVars res <- resolve x case res of Just (Left k) -> case k of ActVar isSub (sc :=> desc) -> case sc `thinsTo` ovs of Just th -> do logUsage (getVariable x) usage - pure (isSub, desc, ActorMeta (spassport usage isSub) (getVariable x) $: sbstW (sbst0 0) th) + pure (isSub, Known desc, ActorMeta (spassport usage isSub) (getVariable x) $: sbstW (sbst0 0) th) Nothing -> throwError (MetaScopeTooBig (getRange x) x sc ovs) _ -> throwError (NotAValidTermVariable (getRange x) x k) Just (Right (desc, i)) -> pure (IsNotSubject, desc, var i (scopeSize ovs)) @@ -169,8 +172,8 @@ sth (xz, b) = do ThKeep -> th ThDrop -> comp th -stms :: Usage -> [SyntaxDesc] -> Raw -> Elab ACTm -stms usage [] (At r "") = atom "" <$> asks (length . objVars) +stms :: Usage -> [ASemanticsDesc] -> Raw -> Elab ACTm +stms usage [] (At r "") = atom "" <$> asks (scopeSize . objVars) stms usage [] (At r a) = throwError (ExpectedNilGot r a) stms usage [] t = throwError (ExpectedANilGot (getRange t) t) stms usage (d:ds) (Cons r p q) = (%) <$> stm usage d p <*> stms usage ds q @@ -193,7 +196,7 @@ sscrutinee (Lookup r stk v) = do (isSub, info, t) <- svar (LookedUp r) v void $ compatibleInfos r (Known (keyDesc stkTy)) info pure t - let desc = Syntax.contract (VEnumOrTag ["Nothing"] [("Just", [valueDesc stkTy])]) + let desc = Semantics.contract (VEnumOrTag ["Nothing"] [("Just", [valueDesc stkTy])]) pure (Lookup r desc (getVariable v), Lookup r stk t) sscrutinee (Compare r s t) = do infoS <- guessDesc False s @@ -221,24 +224,25 @@ stm usage desc (Sbst r sg t) = do pure (t //^ sg) stm usage desc rt = do table <- gets syntaxCats - case Syntax.expand table desc of - Nothing -> throwError (InvalidSyntaxDesc (getRange rt) desc) + dat <- asks headUpData + case Semantics.expand table dat desc of + Nothing -> throwError (InvalidSemanticsDesc (getRange rt) desc) Just vdesc -> case rt of At r a -> do case vdesc of - VAtom -> pure () - VAtomBar as -> when (a `elem` as) $ throwError (GotBarredAtom r a as) - VNil -> unless (a == "") $ throwError (ExpectedNilGot r a) + VAtom _ -> pure () + VAtomBar _ as -> when (a `elem` as) $ throwError (GotBarredAtom r a as) + VNil _ -> unless (a == "") $ throwError (ExpectedNilGot r a) VNilOrCons{} -> unless (a == "") $ throwError (ExpectedNilGot r a) - VEnumOrTag es _ -> unless (a `elem` es) $ throwError (ExpectedEnumGot r es a) - VWildcard -> pure () - _ -> throwError (SyntaxError r desc rt) - atom a <$> asks (length . objVars) + VEnumOrTag _ es _ -> unless (a `elem` es) $ throwError (ExpectedEnumGot r es a) + VWildcard _ -> pure () + _ -> throwError (SemanticsError r desc rt) + atom a <$> asks (scopeSize . objVars) Cons r p q -> case vdesc of VNilOrCons d1 d2 -> (%) <$> stm usage d1 p <*> stm usage d2 q VCons d1 d2 -> (%) <$> stm usage d1 p <*> stm usage d2 q - VWildcard -> (%) <$> stm usage desc p <*> stm usage desc q - VEnumOrTag _ ds -> case p of + VWildcard _ -> (%) <$> stm usage desc p <*> stm usage desc q + VEnumOrTag _ _ ds -> case p of At r a -> case lookup a ds of Nothing -> throwError (ExpectedTagGot r (fst <$> ds) a) Just descs -> (%) <$> stm usage (atom "Atom" 0) p <*> stms usage descs q @@ -246,7 +250,7 @@ stm usage desc rt = do _ -> throwError (SyntaxError r desc rt) Lam r (Scope (Hide x) sc) -> do (s, desc) <- case vdesc of - VWildcard -> pure (Unknown, desc) + VWildcard _ -> pure (Unknown, desc) VBind cat desc -> pure (Known (catToDesc cat), desc) _ -> throwError (SyntaxError r desc rt) case x of @@ -260,15 +264,15 @@ stm usage desc rt = do Op r rs ro -> case ro of -- TODO: usage checking At ra a -> do - (sdesc, psdesc, rdesc) <- isOperator ra a - unless (null psdesc) $ throwError (ExpectedAnEmptyListGot r a psdesc) - o <- stm usage (Syntax.contract VAtom) ro + AnOperator{..} <- isOperator ra a + unless (null paramDescs) $ throwError (ExpectedAnEmptyASOTListGot r a paramDescs) + o <- stm usage (Semantics.contract $ VAtom _) ro s <- stm usage sdesc rs compatibleInfos r (Known rdesc) (Known desc) pure (Term.contract (s :-: o)) Cons rp (At ra a) ps -> do (sdesc, psdesc, rdesc) <- isOperator ra a - o <- stms usage (Syntax.contract VAtom : psdesc) ro + o <- stms usage (Semantics.contract VAtom : psdesc) ro s <- stm usage sdesc rs compatibleInfos r (Known rdesc) (Known desc) pure (Term.contract (s :-: o)) @@ -298,7 +302,7 @@ spat esc rp@(AsP r v p) = do v <- isFresh v ds <- asks declarations ovs <- asks objVars - (mr, p, ds, hs) <- local (setDecls (ds :< (v, ActVar IsNotSubject (Known desc) ovs))) $ spat esc p + (mr, p, ds, hs) <- local (setDecls (ds :< (v, ActVar IsNotSubject (ovs :=> desc)))) $ spat esc p pure (mr, AT (ActorMeta ACitizen v) p, ds, hs) spat esc p@VarP{} = spatBase (Pattern <$ isSubject esc) (escrutinee esc) p spat esc (ThP r th p) = do @@ -358,17 +362,18 @@ spatBase isSub desc (UnderscoreP r) = do (mr,HP,,) <$> asks declarations <*> asks binderHints spatBase isSub desc rp = do table <- gets syntaxCats - case Syntax.expand table desc of - Nothing -> throwError (InvalidSyntaxDesc (getRange rp) desc) + dat <- asks headUpData + case Semantics.expand table dat desc of + Nothing -> throwError (InvalidSemanticsDesc (getRange rp) desc) Just vdesc -> case rp of AtP r a -> do case vdesc of - VAtom -> pure () - VAtomBar as -> when (a `elem` as) $ throwError (GotBarredAtom r a as) - VNil -> unless (a == "") $ throwError (ExpectedNilGot r a) + VAtom _ -> pure () + VAtomBar _ as -> when (a `elem` as) $ throwError (GotBarredAtom r a as) + VNil _ -> unless (a == "") $ throwError (ExpectedNilGot r a) VNilOrCons{} -> unless (a == "") $ throwError (ExpectedNilGot r a) - VEnumOrTag es _ -> unless (a `elem` es) $ throwError (ExpectedEnumGot r es a) - VWildcard -> pure () + VEnumOrTag sc es _ -> unless (a `elem` es) $ throwError (ExpectedEnumGot r es a) + VWildcard sc -> pure () _ -> throwError (SyntaxPError r desc rp) (Nothing, AP a,,) <$> asks declarations <*> asks binderHints @@ -381,11 +386,11 @@ spatBase isSub desc rp = do (mr1, p, ds, hs) <- spatBase isSub d1 p (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spatBase isSub d2 q) pure (mr1 <|> mr2, PP p q, ds, hs) - VWildcard -> do + VWildcard _ -> do (mr1, p, ds, hs) <- spatBase isSub desc p (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spatBase isSub desc q) pure (mr1 <|> mr2, PP p q, ds, hs) - VEnumOrTag _ ds -> case p of + VEnumOrTag _ _ ds -> case p of AtP r a -> case lookup a ds of Nothing -> throwError (ExpectedTagGot r (fst <$> ds) a) Just descs -> do @@ -397,8 +402,8 @@ spatBase isSub desc rp = do LamP r (Scope v@(Hide x) p) -> do (s, desc) <- case vdesc of - VWildcard -> pure (Unknown, desc) - VBind cat desc -> pure (Known (catToDesc cat), desc) + VWildcard _ -> pure (Unknown, desc) + VBind cat desc -> pure (Known (Semantics.catToDesc cat), desc) _ -> throwError (SyntaxPError r desc rp) case x of @@ -416,7 +421,7 @@ isChannel ch = resolve ch >>= \case Just mk -> throwError (NotAValidChannel (getRange ch) ch $ either Just (const Nothing) mk) Nothing -> throwError (OutOfScope (getRange ch) ch) -isOperator :: Range -> String -> Elab (SyntaxDesc, [SyntaxDesc], ASemanticsDesc) +isOperator :: Range -> String -> Elab AAnOperator isOperator r nm = do ops <- asks operators case Map.lookup nm ops of @@ -494,10 +499,10 @@ guessDesc b (Cons _ p q) = do dp <- guessDesc False p dq <- guessDesc True q case (dp, dq) of - (Known d1, Known d2) -> pure (Known $ Semantics.contract (VCons d1 d2)) + (Known d1, Known d2) -> pure (Known $ Semantics.contract (Semantics.VCons d1 d2)) _ -> pure Unknown -- might need better guess for the scope than 0 -guessDesc True (At _ "") = pure (Known $ Semantics.contract (VNil 0)) +guessDesc True (At _ "") = pure (Known $ Semantics.contract (Semantics.VNil 0)) guessDesc _ _ = pure Unknown compatibleChannels :: Range -> (Direction, [AProtocolEntry]) -> Ordering -> (Direction, [AProtocolEntry]) -> Elab Int @@ -520,7 +525,7 @@ sirrefutable nm isSub = \case p -> do ctxt <- ask -- this should be a unique name & is not user-writable let r = getRange p - let av = "&" ++ nm ++ show (length (objVars ctxt) + length (declarations ctxt)) + let av = "&" ++ nm ++ show (scopeSize (objVars ctxt) + length (declarations ctxt)) let var = Variable r av let sc = case isSub of IsSubject{} -> SubjectVar r var @@ -588,8 +593,8 @@ sact = \case ovs <- asks objVars -- NB: the lintersection takes the (Info ASemanticsDesc) into account -- Should it? - let (thx, xyz, thy) = lintersection sc ovs - (*^ thx) <$> local (setObjVars xyz) (stm usage desc tm) + let (thx, xyz, thy) = lintersection (getObjVars sc) (getObjVars ovs) + (*^ thx) <$> local (setObjVars $ ObjVars xyz) (stm usage desc tm) a <- sact a pure $ Send r ch gd tm a @@ -611,7 +616,7 @@ sact = \case -- Further actor sc <- channelScope ch - (a, All canwin) <- local (declare av (ActVar isSub (Known cat) sc)) + (a, All canwin) <- local (declare av (ActVar isSub (sc :=> cat))) $ listen $ sact $ case pat of @@ -632,7 +637,7 @@ sact = \case q <- steppingChannel r ch2 $ \ dir p -> pure ((dir,p), []) sc1 <- channelScope ch1 sc2 <- channelScope ch2 - (dir, th) <- case (findSub sc1 sc2, findSub sc2 sc1) of + (dir, th) <- case (sc1 `thinsTo` sc2, sc2 `thinsTo` sc1) of (Just thl, Just thr) -> pure (EQ, thl) (Just thl, _) -> pure (LT, thl) (_, Just thr) -> pure (GT, thr) @@ -643,22 +648,22 @@ sact = \case FreshMeta r desc (av, a) -> do (desc, av, ovs) <- during FreshMetaElaboration $ do syndecls <- gets (Map.keys . syntaxCats) - desc <- ssyntaxdesc syndecls desc + desc <- ssemanticsdesc desc av <- isFresh av ovs <- asks objVars pure (desc, av, ovs) - a <- local (declare (Used av) (ActVar IsNotSubject (Known desc) ovs)) $ sact a + a <- local (declare (Used av) (ActVar IsNotSubject (ovs :=> desc))) $ sact a pure $ FreshMeta r desc (ActorMeta ACitizen av, a) Let r av desc t a -> do (desc, av, ovs) <- during FreshMetaElaboration $ do syndecls <- gets (Map.keys . syntaxCats) - desc <- ssyntaxdesc syndecls desc + desc <- ssemanticsdesc desc av <- isFresh av ovs <- asks objVars pure (desc, av, ovs) t <- stm (LetBound (getRange t)) desc t - a <- local (declare (Used av) (ActVar IsNotSubject (Known desc) ovs)) $ sact a + a <- local (declare (Used av) (ActVar IsNotSubject (ovs :=> desc))) $ sact a pure (Let r (ActorMeta ACitizen av) desc t a) Under r (Scope v@(Hide x) a) -> do @@ -672,7 +677,8 @@ sact = \case (clsts, cov) <- traverse (sclause esc) cls `runStateT` [escrutinee esc] unless (null cov) $ do table <- gets syntaxCats - let examples = fromList cov >>= missing table + dat <- asks headUpData + let examples = fromList cov >>= missing dat table raiseWarning $ MissingClauses r examples let (cls, sts) = unzip clsts let (chst, avst) = unzip $ catMaybes sts @@ -750,7 +756,7 @@ sbranch r ds ra = do pure (a, ((,) <$> channelStates <*> actvarStates) st <$ guard b ) sclause :: EScrutinee -> (RawP, CActor) -> - StateT [SyntaxDesc] Elab ((Pat, AActor), Maybe (ChannelStates, ActvarStates)) + StateT [ASemanticsDesc] Elab ((Pat, AActor), Maybe (ChannelStates, ActvarStates)) sclause esc (rp, a) = do ds0 <- asks declarations avs <- lift $ gets actvarStates @@ -764,11 +770,12 @@ sclause esc (rp, a) = do whenJust (me *> mr) (lift . raiseWarning . UnderscoreOnSubject) pure ((p, a), me) -coverageCheckClause :: RawP -> Pat -> StateT [SyntaxDesc] Elab () +coverageCheckClause :: RawP -> Pat -> StateT [ASemanticsDesc] Elab () coverageCheckClause rp p = do leftovers <- get table <- lift $ gets syntaxCats - leftovers <- lift $ case combine $ map (\ d -> (d, shrinkBy table d p)) leftovers of + dat <- lift $ asks headUpData + leftovers <- lift $ case combine $ map (\ d -> (d, shrinkBy dat table d p)) leftovers of Covering -> pure [] AlreadyCovered -> do unless (isCatchall p) $ diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 555fee5..e8f52e3 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -26,6 +26,8 @@ import Rules import Info import Pattern import Hide +import Operator.Eval +import Options ------------------------------------------------------------------------------ -- Elaboration Monad @@ -96,10 +98,10 @@ instance MonadError Complaint Elab where catchError ma k = Elab (catchError (runElab ma) (runElab . k . theMessage)) -evalElab :: Elab a -> Either (WithStackTrace Complaint) a -evalElab = fmap fst +evalElab :: Options -> Elab a -> Either (WithStackTrace Complaint) a +evalElab opts = fmap fst . runWriterT - . (`runReaderT` initContext) + . (`runReaderT` (initContext opts)) . (`evalStateT` initElabState) . runElab @@ -112,7 +114,7 @@ infoExpand table s = case Syntax.expand table s of Just VWildcard -> Unknown Just a -> Known a -fromInfo :: Range -> Info SyntaxDesc -> Elab SyntaxDesc +fromInfo :: Range -> Info ASemanticsDesc -> Elab ASemanticsDesc fromInfo r Unknown = pure (atom "Wildcard" 0) fromInfo r (Known desc) = pure desc -- I believe this last case is currently unreachable because this @@ -145,9 +147,9 @@ data IsSubject' a = IsSubject a | IsNotSubject type IsSubject = IsSubject' Provenance -type instance SCRUTINEEVAR Elaboration = SyntaxDesc -type instance SCRUTINEETERM Elaboration = SyntaxDesc -type instance STACK Elaboration = SyntaxDesc +type instance SCRUTINEEVAR Elaboration = ASemanticsDesc +type instance SCRUTINEETERM Elaboration = ASemanticsDesc +type instance STACK Elaboration = ASemanticsDesc type instance TERM Elaboration = () type instance LOOKEDUP Elaboration = String @@ -179,15 +181,16 @@ data Context = Context , binderHints :: Hints , elabMode :: ElabMode , stackTrace :: StackTrace + , headUpData :: HeadUpData' ActorMeta } deriving (Show) -type Hints = Map String (Info SyntaxDesc) +type Hints = Map String (Info ASemanticsDesc) data ElabMode = Definition | Execution deriving (Eq, Show) -initContext :: Context -initContext = Context +initContext :: Options -> Context +initContext opts = Context { objVars = ObjVars B0 , declarations = B0 , operators = Map.fromList @@ -205,6 +208,13 @@ initContext = Context , binderHints = Map.empty , elabMode = Definition , stackTrace = [] + , headUpData = HeadUpData + { opTable = const mempty + , metaStore = Store Map.empty Map.empty () + , huOptions = opts + , huEnv = initEnv B0 + , whatIs = const Nothing + } } where am = ActorMeta ACitizen @@ -258,7 +268,7 @@ addOperator op ctx = setHints :: Hints -> Context -> Context setHints hs ctx = ctx { binderHints = hs } -addHint :: String -> Info SyntaxDesc -> Context -> Context +addHint :: String -> Info ASemanticsDesc -> Context -> Context addHint str cat ctx = let hints = binderHints ctx hints' = case Map.lookup str hints of @@ -266,7 +276,7 @@ addHint str cat ctx = Just cat' -> Map.insert str (cat <> cat') hints in ctx { binderHints = hints' } -getHint :: String -> Elab (Info SyntaxDesc) +getHint :: String -> Elab (Info ASemanticsDesc) getHint str = do hints <- asks binderHints pure $ fromMaybe Unknown $ Map.lookup str hints @@ -387,6 +397,7 @@ data Complaint -- syntaxdesc validation | InconsistentSyntaxDesc Range | InvalidSyntaxDesc Range SyntaxDesc + | InvalidSemanticsDesc Range ASemanticsDesc | IncompatibleSyntaxInfos Range (Info SyntaxDesc) (Info SyntaxDesc) | IncompatibleSyntaxDescs Range SyntaxDesc SyntaxDesc | GotBarredAtom Range String [String] @@ -398,9 +409,11 @@ data Complaint | ExpectedAConsGot Range Raw | ExpectedAConsPGot Range RawP | SyntaxError Range SyntaxDesc Raw + | SemanticsError Range ASemanticsDesc Raw | SyntaxPError Range SyntaxDesc RawP | ExpectedAnOperator Range Raw | ExpectedAnEmptyListGot Range String [SyntaxDesc] + | ExpectedAnEmptyASOTListGot Range String [(Maybe ActorMeta, ASOT)] -- subjects and citizens | AsPatternCannotHaveSubjects Range RawP deriving (Show) diff --git a/Src/Operator.hs b/Src/Operator.hs index 59a9e8f..4545fd4 100644 --- a/Src/Operator.hs +++ b/Src/Operator.hs @@ -34,7 +34,8 @@ scopeSize :: ObjVars -> Int scopeSize = length . getObjVars (<:) :: ObjVars -> ObjVar -> ObjVars -(ObjVars xz) <: x = ObjVars $ xz :< x +(ObjVars xz) <: x = ObjVars $ xz :< x + -- Second Order Type type family SOT (ph :: Phase) :: * diff --git a/Src/Operator/Eval.hs b/Src/Operator/Eval.hs index b44d19f..8f809b4 100644 --- a/Src/Operator/Eval.hs +++ b/Src/Operator/Eval.hs @@ -32,7 +32,10 @@ data HeadUpData' m = forall i d. HeadUpData , huOptions :: Options , huEnv :: Env' m , whatIs :: m -> Maybe (Term' m) - } + } + +instance Show (HeadUpData' m) where + show _ = "HUD" type HeadUpData = HeadUpData' Meta diff --git a/Src/Pattern/Coverage.hs b/Src/Pattern/Coverage.hs index 3d0121d..b1e2cdf 100644 --- a/Src/Pattern/Coverage.hs +++ b/Src/Pattern/Coverage.hs @@ -16,14 +16,16 @@ import Data.List (partition) import Data.List.NonEmpty (NonEmpty ((:|)), fromList, toList) import Data.Maybe (fromJust, mapMaybe) -import Concrete.Base (RawP(..), Binder (..), Variable (..), ASyntaxDesc) +import Concrete.Base (RawP(..), Binder (..), Variable (..), ASyntaxDesc, ASemanticsDesc) import Location (unknown) import Pattern (Pat'(..)) import Scope (Scope(..)) -import Syntax ( VSyntaxDesc'(..), WithSyntaxCat(..), SyntaxTable, VSyntaxDesc, SyntaxCat - , expand', contract, expand) -import Thin (is1s) +import Thin (is1s, scope) import Hide (Hide(Hide)) +import Semantics +import Operator.Eval (HeadUpData') +import Actor (ActorMeta(..)) +import Syntax (SyntaxTable, SyntaxCat, WithSyntaxCat(..)) ------------------------------------------------------------------------------ -- RESULTS @@ -69,7 +71,7 @@ data Covering' sd [sd] -- what is left to cover deriving (Functor) -type Covering = Covering' ASyntaxDesc +type Covering = Covering' ASemanticsDesc ------------------------------------------------------------------------------ -- Views @@ -139,16 +141,16 @@ combine covs = case partition (isAlreadyCovered . snd) covs of -- Postcondition: -- If `shrinkBy table desc pat` is `PartiallyCovering ps qs` then -- `desc` is morally equivalent to the sum (ps + qs) -shrinkBy :: forall s. SyntaxTable -> ASyntaxDesc -> Pat' s -> Covering -shrinkBy table = start where +shrinkBy :: forall s. HeadUpData' ActorMeta -> SyntaxTable -> ASemanticsDesc -> Pat' s -> Covering +shrinkBy dat table = start where - start :: ASyntaxDesc -> Pat' s -> Covering - start desc = go (desc, fromJust (expand table desc)) + start :: ASemanticsDesc -> Pat' s -> Covering + start desc = go (desc, fromJust (expand table dat desc)) - starts :: [ASyntaxDesc] -> Pat' s -> Covering' [ASyntaxDesc] - starts descs = gos (map (\ d -> (d, fromJust (expand table d))) descs) + starts :: [ASemanticsDesc] -> Pat' s -> Covering' [ASemanticsDesc] + starts descs = gos (map (\ d -> (d, fromJust (expand table dat d))) descs) - gos :: [(ASyntaxDesc, VSyntaxDesc)] -> Pat' s -> Covering' [ASyntaxDesc] + gos :: [(ASemanticsDesc, VSemanticsDesc)] -> Pat' s -> Covering' [ASemanticsDesc] gos [] (AP "") = Covering gos (d:ds) (PP p ps) = case (go d p, gos ds ps) of (Covering, Covering) -> Covering @@ -165,22 +167,26 @@ shrinkBy table = start where PartiallyCovering (map (fst d :) p2) (map (fst d :) p2s) gos _ _ = error "Impossible" - go :: (ASyntaxDesc, VSyntaxDesc) -> Pat' s -> Covering + go :: (ASemanticsDesc, VSemanticsDesc) -> Pat' s -> Covering go desc (AT s pat) = go desc pat go (desc, _) (VP db) = PartiallyCovering [] [desc] -- TODO: handle bound variables too go (desc, vdesc) (AP s) = contract <$> case vdesc of - VAtom -> PartiallyCovering [VEnumOrTag [s] []] [VAtomBar [s]] - VAtomBar ss | s `notElem` ss -> - PartiallyCovering [VEnumOrTag [s] []] [VAtomBar (s:ss)] - VNil | null s -> Covering - VNilOrCons cb cb' | null s -> PartiallyCovering [VNil] [VCons cb cb'] - VEnumOrTag ss ts -> + VAtom sc -> PartiallyCovering [VEnumOrTag sc [s] []] [VAtomBar sc [s]] + VAtomBar sc ss | s `notElem` ss -> + PartiallyCovering [VEnumOrTag sc [s] []] [VAtomBar sc (s:ss)] + VNil _ | null s -> Covering + VNilOrCons cb cb' | null s -> PartiallyCovering [VNil $ scope cb] [VCons cb cb'] + VEnumOrTag sc ss ts -> let (matches, ss') = partition (s ==) ss in case (ss', ts) of _ | null matches -> AlreadyCovered ([], []) -> Covering - _ -> PartiallyCovering [VEnumOrTag matches []] [VEnumOrTag ss' ts] - VWildcard -> PartiallyCovering [] [VWildcard] + _ -> PartiallyCovering [VEnumOrTag sc matches []] [VEnumOrTag sc ss' ts] + VWildcard sc -> PartiallyCovering [] [VWildcard sc] + -- TODO : fix + VNeutral _ -> undefined + VUniverse sc -> undefined + VPi s (n, t) -> undefined _ -> AlreadyCovered go (desc, vdesc) (PP pat pat') = case vdesc of VCons cb cb' -> contract <$> case (start cb pat, start cb' pat') of @@ -216,23 +222,23 @@ shrinkBy table = start where PartiallyCovering (map (VCons cb) p2) (map (VCons cb) p2s) VNilOrCons cb cb' -> contract <$> case (start cb pat, start cb' pat') of - (Covering, Covering) -> PartiallyCovering [VCons cb cb'] [VNil] + (Covering, Covering) -> PartiallyCovering [VCons cb cb'] [VNil $ scope cb] (AlreadyCovered, _) -> AlreadyCovered (_, AlreadyCovered) -> AlreadyCovered (PartiallyCovering p1 p1s, PartiallyCovering p2 p2s) -> PartiallyCovering (VCons <$> p1 <*> p2) $ concat - [ [VNil] + [ [VNil $ scope cb] , VCons <$> p1 <*> p2s , VCons <$> p1s <*> p2 , VCons <$> p1s <*> p2s ] (PartiallyCovering p1 p1s, Covering) -> PartiallyCovering (map (`VCons` cb') p1) - (VNil : map (`VCons` cb') p1s) + ((VNil $ scope cb) : map (`VCons` cb') p1s) (Covering, PartiallyCovering p2 p2s) -> PartiallyCovering (map (VCons cb) p2) - (VNil : map (VCons cb) p2s) + ((VNil $ scope cb) : map (VCons cb) p2s) - VEnumOrTag ss ts -> case pat of + VEnumOrTag sc ss ts -> case pat of AP s -> let (matches, ts') = partition ((s ==) . fst) ts in contract <$> case combine $ map (\ (_, ds) -> (ds, starts ds pat')) matches of @@ -240,22 +246,23 @@ shrinkBy table = start where Covering | null ss && null ts' -> Covering Covering -> PartiallyCovering - [VEnumOrTag [] matches] - [VEnumOrTag ss ts'] + [VEnumOrTag sc [] matches] + [VEnumOrTag sc ss ts'] AlreadyCovered -> AlreadyCovered PartiallyCovering p ps -> PartiallyCovering - [VEnumOrTag [] (map (s,) p)] - [VEnumOrTag ss (map (s,) ps ++ ts')] + [VEnumOrTag sc [] (map (s,) p)] + [VEnumOrTag sc ss (map (s,) ps ++ ts')] _ -> error "Impossible" - VWildcard -> contract <$> PartiallyCovering [] [VWildcard] + VWildcard sc -> contract <$> PartiallyCovering [] [VWildcard sc] + -- TODO : what about Neutral, Universe, Pi _ -> error "Impossible" go (desc, vdesc) (BP hi pat) = case vdesc of VBind s d -> contract <$> case start d pat of Covering -> Covering AlreadyCovered -> AlreadyCovered PartiallyCovering p ps -> PartiallyCovering (VBind s <$> p) (VBind s <$> ps) - VWildcard -> contract <$> PartiallyCovering [] [VWildcard] + VWildcard sc -> contract <$> PartiallyCovering [] [VWildcard sc] _ -> error "Impossible" go (desc, vdesc) (MP s th) | is1s th = Covering @@ -263,14 +270,14 @@ shrinkBy table = start where go (desc, vdesc) GP = PartiallyCovering [] [desc] go _ HP = Covering -missing :: SyntaxTable -> ASyntaxDesc -> NonEmpty RawP -missing table desc = fmap (`evalState` names) (start desc) where +missing :: HeadUpData' ActorMeta -> SyntaxTable -> ASemanticsDesc -> NonEmpty RawP +missing dat table desc = fmap (`evalState` names) (start desc) where -- Each solution is a computation using its own name supply because -- there is no reason for us not to reuse the same name in independent -- patterns e.g. ['Leaf a] and ['Node a b c]. - start :: ASyntaxDesc -> NonEmpty (State [String] RawP) - start = go . fromJust . expand' Yes table + start :: ASemanticsDesc -> NonEmpty (State [String] RawP) + start = go . fromJust . expand' Yes table dat -- "a", "b", ..., "z", "a1", "b1", ... names :: [String] @@ -287,21 +294,25 @@ missing table desc = fmap (`evalState` names) (start desc) where put ns pure n - go :: VSyntaxDesc' SyntaxCat -> NonEmpty (State [String] RawP) - go VAtom = (pure $ UnderscoreP unknown) :| [] - go (VAtomBar ss) = (pure $ UnderscoreP unknown) :| [] - go VNil = (pure $ AtP unknown "") :| [] + go :: VSemanticsDesc' SyntaxCat -> NonEmpty (State [String] RawP) + go (VAtom _) = (pure $ UnderscoreP unknown) :| [] + go (VAtomBar _ ss) = (pure $ UnderscoreP unknown) :| [] + go (VNil _) = (pure $ AtP unknown "") :| [] go (VCons cb cb') = do ps <- start cb qs <- start cb' pure (ConsP unknown <$> ps <*> qs) - go (VNilOrCons cb cb') = go VNil <> go (VCons cb cb') + go (VNilOrCons cb cb') = go (VNil $ scope cb) <> go (VCons cb cb') go (VBind s cb) = fmap (LamP unknown . Scope (Hide Unused)) <$> start cb - go (VEnumOrTag ss ts) = + go (VEnumOrTag _ ss ts) = let enums = map (\ s -> (pure $ AtP unknown s) :| []) ss tagged = ts <&> \ (s, ds) -> do args <- traverse start ds pure $ ConsP unknown (AtP unknown s) . foldr (ConsP unknown) (AtP unknown "") <$> sequence args in fromList (concatMap toList (enums ++ tagged)) - go VWildcard = (pure $ UnderscoreP unknown) :| [] - go (VSyntaxCat _) = (VarP unknown . Variable unknown <$> freshName) :| [] + go (VWildcard _)= (pure $ UnderscoreP unknown) :| [] + go (VSyntaxCat _ _) = (VarP unknown . Variable unknown <$> freshName) :| [] +{- TODO: fill in, neutral case might be impossible + go (VNeutral _) = _ + go (VUniverse _) = (pure $ AtP unknown "Semantics") :| [] + go (VPi _ _) = _ -} diff --git a/Src/Semantics.hs b/Src/Semantics.hs index 458727f..6387f1b 100644 --- a/Src/Semantics.hs +++ b/Src/Semantics.hs @@ -41,6 +41,20 @@ data VSemanticsDesc' a type VSemanticsDesc = VSemanticsDesc' Void +extractScope :: VSemanticsDesc' a -> Int +extractScope = \case + VAtom sc -> sc + VAtomBar sc _ -> sc + VNil sc -> sc + VCons s t -> scope s + VNilOrCons s t -> scope s + VBind cat s -> scope s + VEnumOrTag sc _ _ -> sc + VWildcard sc -> sc + VSyntaxCat sc _ -> sc + VNeutral s -> scope s + VUniverse sc -> sc + VPi s (n , t) -> scope s expand' :: forall a. WithSyntaxCat a -> SyntaxTable -> HeadUpData' ActorMeta -> ASemanticsDesc -> Maybe (VSemanticsDesc' a) expand' w table dat desc = do From d97d818f1b495ff479d634b217c8d94c90467003 Mon Sep 17 00:00:00 2001 From: Georgi Nakov Date: Fri, 9 Dec 2022 16:44:59 +0000 Subject: [PATCH 26/89] [ wip ] elaboration cont. --- Src/Actor.hs | 2 +- Src/Command.hs | 20 ---------------- Src/Elaboration.hs | 51 +++++++++++++++++++++++++++++++++++----- Src/Elaboration/Monad.hs | 42 ++++++++++++++++++--------------- Src/Operator.hs | 2 +- 5 files changed, 70 insertions(+), 47 deletions(-) diff --git a/Src/Actor.hs b/Src/Actor.hs index 6983583..85b3e46 100644 --- a/Src/Actor.hs +++ b/Src/Actor.hs @@ -54,7 +54,7 @@ type instance GUARD Abstract = Maybe ActorVar data AConnect = AConnect Channel Th Channel Int deriving (Show) type AProtocol = PROTOCOL Abstract -type AContextStack = ContextStack ASyntaxDesc +type AContextStack = ContextStack ASemanticsDesc type AActor = ACTOR Abstract type ACTm = CdB (Tm ActorMeta) type ACTSbst = CdB (Sbst ActorMeta) diff --git a/Src/Command.hs b/Src/Command.hs index f351048..e7df61b 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -289,26 +289,6 @@ sdeclOps ((AnOperator (WithRange r opname) (objName, objDesc) paramDescs retDesc (ops, decls) <- local (addOperator op) $ sdeclOps ops pure (op : ops, decls) --- TODO: change "Maybe" to "Binder" in Anoperator - -sparamdescs :: [(Maybe Variable, Raw)] -> Elab ([(Maybe ActorVar, ASOT)], Decls) -sparamdescs [] = ([],) <$> asks declarations -sparamdescs ((mx , ty):ps) = do - (mx, binder) <- case mx of - Nothing -> pure (Nothing, Unused) - Just x -> do - x <- isFresh x - pure (Just x , Used x) - ovs <- asks objVars - ty <- ssemanticsdesc ty - let sty = ovs :=> ty - (ps, ds) <- local (declare binder (ActVar IsNotSubject sty)) $ sparamdescs ps - pure ((mx , sty):ps, ds) - - -spatSemantics :: ASemanticsDesc -> CPattern -> Elab (APattern, ASemanticsDesc, Decls) -spatSemantics = _ - scommand :: CCommand -> Elab (ACommand, Globals) scommand = \case DeclJudge em jd p -> during (DeclJElaboration jd) $ do diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index bd6a2b8..9d79fef 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -38,6 +38,9 @@ import Control.Applicative ((<|>)) import Operator import Semantics +type CPattern = PATTERN Concrete +type APattern = PATTERN Abstract + isSubject :: EScrutinee -> IsSubject' () isSubject SubjectVar{} = IsSubject () isSubject _ = IsNotSubject @@ -137,7 +140,8 @@ ssyntaxdesc syndecls syn = do ssemanticsdesc :: CSemanticsDesc -> Elab ASemanticsDesc ssemanticsdesc sem = do syndecls <- gets (Map.keys . syntaxCats) - ssyntaxdesc ("Semantics":syndecls) sem + syndesc <- ssyntaxdesc ("Semantics":syndecls) sem + pure . embed $ syndesc -- TODO: use stm to actually be able to use operators & actor vars -- DontLog (catToDesc "Semantics") @@ -196,7 +200,8 @@ sscrutinee (Lookup r stk v) = do (isSub, info, t) <- svar (LookedUp r) v void $ compatibleInfos r (Known (keyDesc stkTy)) info pure t - let desc = Semantics.contract (VEnumOrTag ["Nothing"] [("Just", [valueDesc stkTy])]) + let vdesc = valueDesc stkTy + desc = Semantics.contract (VEnumOrTag (scope vdesc) ["Nothing"] [("Just", [vdesc])]) pure (Lookup r desc (getVariable v), Lookup r stk t) sscrutinee (Compare r s t) = do infoS <- guessDesc False s @@ -212,6 +217,36 @@ sscrutinee (Term r t) = during (ScrutineeTermElaboration t) $ do pure (Term r desc, Term r t) +-- TODO: change "Maybe" to "Binder" in Anoperator +sparamdescs :: [(Maybe Variable, Raw)] -> Elab ([(Maybe ActorVar, ASOT)], Decls) +sparamdescs [] = ([],) <$> asks declarations +sparamdescs ((mx , ty):ps) = do + (mx, binder) <- case mx of + Nothing -> pure (Nothing, Unused) + Just x -> do + x <- isFresh x + pure (Just x , Used x) + ovs <- asks objVars + ty <- ssemanticsdesc ty + let sty = ovs :=> ty + (ps, ds) <- local (declare binder (ActVar IsNotSubject sty)) $ sparamdescs ps + pure ((mx , sty):ps, ds) + + +spatSemantics :: ASemanticsDesc -> CPattern -> Elab (APattern, ASemanticsDesc, Decls) +spatSemantics ty (AsP r v p) = _ +spatSemantics ty (VarP r v) = _ +spatSemantics ty (AtP r a) = _ +spatSemantics ty (ConsP r p1 p2) = _ +spatSemantics ty (LamP r p) = _ +spatSemantics ty (ThP r th p) = _ +spatSemantics ty (UnderscoreP r) = _ +spatSemantics ty (Irrefutable r p) = _ + + +patToTm :: Pat -> Maybe ASemanticsDesc +patToTm p = _ + stm :: Usage -> ASemanticsDesc -> Raw -> Elab ACTm stm usage desc (Var r v) = during (TermVariableElaboration v) $ do table <- gets syntaxCats @@ -266,10 +301,14 @@ stm usage desc rt = do At ra a -> do AnOperator{..} <- isOperator ra a unless (null paramDescs) $ throwError (ExpectedAnEmptyASOTListGot r a paramDescs) - o <- stm usage (Semantics.contract $ VAtom _) ro - s <- stm usage sdesc rs - compatibleInfos r (Known rdesc) (Known desc) - pure (Term.contract (s :-: o)) + o <- stm usage (Semantics.contract $ VAtom 0) ro + case patToTm . snd $ objDesc of + Nothing -> error "Impossible" + Just sdesc -> do + s <- stm usage sdesc rs + + compatibleInfos r (Known rdesc) (Known desc) + pure (Term.contract (s :-: o)) Cons rp (At ra a) ps -> do (sdesc, psdesc, rdesc) <- isOperator ra a o <- stms usage (Semantics.contract VAtom : psdesc) ro diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index e8f52e3..4a8a35f 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -16,8 +16,7 @@ import Actor import Bwd import Concrete.Base import Location (HasGetRange(..), Range, WithRange (..)) -import Syntax (SyntaxCat, SyntaxDesc, VSyntaxDesc'(..), VSyntaxDesc, SyntaxTable) -import qualified Syntax +import Syntax (SyntaxCat, SyntaxDesc, VSyntaxDesc, SyntaxTable) import Thin import Term.Base import Utils @@ -28,7 +27,7 @@ import Pattern import Hide import Operator.Eval import Options - +import Semantics ------------------------------------------------------------------------------ -- Elaboration Monad @@ -108,10 +107,10 @@ evalElab opts = fmap fst ------------------------------------------------------------------------------ -- Partial Info -infoExpand :: SyntaxTable -> SyntaxDesc -> Info VSyntaxDesc -infoExpand table s = case Syntax.expand table s of +infoExpand :: HeadUpData' ActorMeta -> SyntaxTable -> ASemanticsDesc -> Info VSemanticsDesc +infoExpand dat table s = case Semantics.expand table dat s of Nothing -> Inconsistent - Just VWildcard -> Unknown + Just (VWildcard _) -> Unknown Just a -> Known a fromInfo :: Range -> Info ASemanticsDesc -> Elab ASemanticsDesc @@ -124,17 +123,18 @@ fromInfo r (Known desc) = pure desc -- 2. `compatibleInfos` where the error is handled locally fromInfo r Inconsistent = throwError (InconsistentSyntaxDesc r) -compatibleInfos :: Range -> Info SyntaxDesc -> Info SyntaxDesc -> Elab (Info SyntaxDesc) +compatibleInfos :: Range -> Info ASemanticsDesc -> Info ASemanticsDesc -> Elab (Info ASemanticsDesc) compatibleInfos r desc desc' = do table <- gets syntaxCats - let de = infoExpand table =<< desc - let de' = infoExpand table =<< desc' + dat <- asks headUpData + let de = infoExpand dat table =<< desc + let de' = infoExpand dat table =<< desc' case de <> de' of - Inconsistent -> throwError (IncompatibleSyntaxInfos r desc desc') + Inconsistent -> throwError (IncompatibleSemanticsInfos r desc desc') d -> pure $ case (desc, desc') of (Known (CdB (A _) _), _) -> desc (_, Known (CdB (A _) _)) -> desc' - _ -> Syntax.contract <$> d + _ -> Semantics.contract <$> d ------------------------------------------------------------------------------ -- Context @@ -208,16 +208,19 @@ initContext opts = Context , binderHints = Map.empty , elabMode = Definition , stackTrace = [] - , headUpData = HeadUpData - { opTable = const mempty - , metaStore = Store Map.empty Map.empty () - , huOptions = opts - , huEnv = initEnv B0 - , whatIs = const Nothing - } + , headUpData = initHeadUpData } where - am = ActorMeta ACitizen + am = ActorMeta ACitizen + + initHeadUpData = HeadUpData + { opTable = const mempty + , metaStore = Store Map.empty Map.empty () + , huOptions = opts + , huEnv = initEnv B0 + , whatIs = const Nothing + } + declareObjVar :: (String, Info ASemanticsDesc) -> Context -> Context declareObjVar (x, info) ctx = ctx { objVars = ObjVars $ getObjVars (objVars ctx) :< ObjVar x info } @@ -399,6 +402,7 @@ data Complaint | InvalidSyntaxDesc Range SyntaxDesc | InvalidSemanticsDesc Range ASemanticsDesc | IncompatibleSyntaxInfos Range (Info SyntaxDesc) (Info SyntaxDesc) + | IncompatibleSemanticsInfos Range (Info ASemanticsDesc) (Info ASemanticsDesc) | IncompatibleSyntaxDescs Range SyntaxDesc SyntaxDesc | GotBarredAtom Range String [String] | ExpectedNilGot Range String diff --git a/Src/Operator.hs b/Src/Operator.hs index 4545fd4..f0b7108 100644 --- a/Src/Operator.hs +++ b/Src/Operator.hs @@ -55,7 +55,7 @@ infix 2 :=> data ANOPERATOR (ph :: Phase) = AnOperator { opName :: OPERATOR ph , objDesc :: (Maybe (ACTORVAR ph), PATTERN ph) - , paramDescs :: [(Maybe (ACTORVAR ph), SOT ph)] + , paramsDesc :: [(Maybe (ACTORVAR ph), SOT ph)] , retDesc :: SOT ph } From 2610c52c3dc2d6751212b6bb0d91437d51bc16ff Mon Sep 17 00:00:00 2001 From: Georgi Nakov Date: Thu, 19 Jan 2023 14:35:30 +0000 Subject: [PATCH 27/89] [ fix ] errors with pretty printing --- Src/Command.hs | 2 -- Src/Elaboration.hs | 5 ++--- Src/Elaboration/Monad.hs | 2 +- Src/Elaboration/Pretty.hs | 17 ++++------------- Src/Info.hs | 9 +++++++++ Src/Machine/Base.hs | 1 - Src/Machine/Display.hs | 3 +-- Src/Operator.hs | 9 +++++++++ 8 files changed, 26 insertions(+), 22 deletions(-) diff --git a/Src/Command.hs b/Src/Command.hs index e7df61b..13427a7 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -106,8 +106,6 @@ type CCommand = COMMAND Concrete type ACommand = COMMAND Abstract type CStatement = STATEMENT Concrete type AStatement = STATEMENT Abstract -type CPattern = PATTERN Concrete -type APattern = PATTERN Abstract instance (Show a, Unelab a, Pretty (Unelabed a)) => Display (Mode a) where type DisplayEnv (Mode a) = UnelabEnv a diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 9d79fef..b43b26a 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -243,8 +243,7 @@ spatSemantics ty (ThP r th p) = _ spatSemantics ty (UnderscoreP r) = _ spatSemantics ty (Irrefutable r p) = _ - -patToTm :: Pat -> Maybe ASemanticsDesc +patToTm :: Pat -> ASemanticsDesc -> Maybe ASemanticsDesc patToTm p = _ stm :: Usage -> ASemanticsDesc -> Raw -> Elab ACTm @@ -300,7 +299,7 @@ stm usage desc rt = do -- TODO: usage checking At ra a -> do AnOperator{..} <- isOperator ra a - unless (null paramDescs) $ throwError (ExpectedAnEmptyASOTListGot r a paramDescs) + unless (null paramsDesc) $ throwError (ExpectedAnEmptyASOTListGot r a paramsDesc) o <- stm usage (Semantics.contract $ VAtom 0) ro case patToTm . snd $ objDesc of Nothing -> error "Impossible" diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 4a8a35f..b5109a6 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -200,7 +200,7 @@ initContext opts = Context $ PP (MP (am "S") (ones 0)) $ PP (BP (Hide "x") $ MP (am "T") (ones 1)) $ AP "") - , paramDescs = [(Just (am "s"), ObjVars B0 :=> (am "S" $: sbstI 0))] + , paramsDesc = [(Just (am "s"), ObjVars B0 :=> (am "S" $: sbstI 0))] , retDesc = ObjVars (B0 :< ObjVar "s" (Known (am "S" $: sbstI 0))) :=> (am "T" $: topSbst "x" (var (DB 0) 1)) }) ] diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index e367e56..da92e34 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -31,12 +31,6 @@ instance Pretty Stack where instance Pretty ActorMeta where pretty (ActorMeta _ m) = pretty m -instance Pretty a => Pretty (Info a) where - prettyPrec d = \case - Unknown -> "Unknown" - Known a -> parenthesise (d > 0) (hsep ["Known", prettyPrec 1 a]) - Inconsistent -> "Inconsistent" - instance Pretty Kind where pretty = \case ActVar{} -> "an object variable" @@ -53,9 +47,6 @@ instance (Unelab a, Pretty (Unelabed a), UnelabEnv a ~ Naming) instance Pretty AProtocol where pretty (Protocol ps) = foldMap (\ x -> pretty x <> ". ") ps -instance Pretty ObjVar where - pretty (ObjVar x info) = hsep [ pretty x, colon, pretty info ] - instance Pretty CFormula where pretty (CFormula a) = these pretty pretty (const pretty) a pretty (CCitizen p t) = hsep [pretty p, "=>", pretty t] @@ -113,9 +104,9 @@ instance Pretty Complaint where MetaScopeTooBig r x sc1 sc2 -> hsep [ "Cannot use", pretty x , "here as it is defined in too big a scope" - , parens (hsep [ collapse (pretty <$> sc1) + , parens (hsep [ pretty sc1 , "won't fit in" - , collapse (pretty <$> sc2) ])] + , pretty sc2 ])] VariableShadowing r x -> hsep [pretty x, "is already defined"] EmptyContext r -> "Tried to pop an empty context" NotTopVariable r x y -> @@ -155,8 +146,8 @@ instance Pretty Complaint where ProtocolsNotDual r ps qs -> hsep ["Protocols", pretty ps, "and", pretty qs, "are not dual"] IncompatibleModes r m1 m2 -> hsep ["Modes", pretty m1, "and", pretty m2, "are incompatible"] IncompatibleChannelScopes r sc1 sc2 -> - hsep [ "Channels scopes", collapse (pretty <$> sc1) - , "and", collapse (pretty <$> sc2), "are incompatible"] + hsep [ "Channels scopes", pretty sc1 + , "and", pretty sc2, "are incompatible"] WrongDirection r m1 dir m2 -> hsep ["Wrong direction", pretty (show dir), "between", pretty m1, "and", pretty m2] -- judgementforms diff --git a/Src/Info.hs b/Src/Info.hs index 02c0a6f..cbbe9fe 100644 --- a/Src/Info.hs +++ b/Src/Info.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} module Info where import Control.Monad +import Pretty -- Partial info @@ -24,3 +26,10 @@ instance Eq a => Semigroup (Info a) where instance Eq a => Monoid (Info a) where mempty = Unknown + +instance Pretty a => Pretty (Info a) where + prettyPrec d = \case + Unknown -> "Unknown" + Known a -> parenthesise (d > 0) (hsep ["Known", prettyPrec 1 a]) + Inconsistent -> "Inconsistent" + diff --git a/Src/Machine/Base.hs b/Src/Machine/Base.hs index 9248aae..e3d0030 100644 --- a/Src/Machine/Base.hs +++ b/Src/Machine/Base.hs @@ -4,7 +4,6 @@ {-# LANGUAGE UndecidableInstances #-} module Machine.Base where -import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set diff --git a/Src/Machine/Display.hs b/Src/Machine/Display.hs index 77c3a90..66124de 100644 --- a/Src/Machine/Display.hs +++ b/Src/Machine/Display.hs @@ -72,8 +72,7 @@ instance ( Display c, Forget DEnv (DisplayEnv c) pch' <- subdisplay pch p <- local (declareChannel pch) $ subdisplay p pure $ hang 1 c - $ hang 1 (hsep [ "@", cch', pipe, pch', collapse (pretty <$> xs), "@"]) - $ p + $ hang 1 (hsep [ "@", cch', pipe, pch', collapse (pretty <$> xs), "@"]) p instance Display Frame where type DisplayEnv Frame = DEnv diff --git a/Src/Operator.hs b/Src/Operator.hs index f0b7108..993966c 100644 --- a/Src/Operator.hs +++ b/Src/Operator.hs @@ -13,12 +13,18 @@ import Term.Base import Info import Bwd import Thin +import Pretty + data ObjVar = ObjVar { objVarName :: String , objVarDesc :: Info ASemanticsDesc } deriving (Show, Eq) +-- TODO : print the info +instance Pretty ObjVar where + pretty (ObjVar x info) = pretty x + -- ObjVars is a representation of variable contexts -- which are in scope for all the types they contain, -- i.e. they should be weakened on extension, not on @@ -27,6 +33,9 @@ data ObjVar = ObjVar newtype ObjVars = ObjVars { getObjVars :: Bwd ObjVar } deriving (Show, Eq) +instance Pretty ObjVars where + pretty = collapse . fmap pretty . getObjVars + thinsTo :: ObjVars -> ObjVars -> Maybe Th thinsTo (ObjVars x) (ObjVars y) = findSub (objVarName <$> x) (objVarName <$> y) From e4c7774e920e0d7bac59d0beabe25e6d57f16b13 Mon Sep 17 00:00:00 2001 From: Georgi Nakov Date: Thu, 19 Jan 2023 14:42:07 +0000 Subject: [PATCH 28/89] [ fix ] some undefined values to get past errors --- Src/Semantics.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Src/Semantics.hs b/Src/Semantics.hs index 6387f1b..a1501e3 100644 --- a/Src/Semantics.hs +++ b/Src/Semantics.hs @@ -123,7 +123,7 @@ catToDesc :: SyntaxCat -> ASemanticsDesc catToDesc c = atom c 0 validate :: Show m => SyntaxTable -> Bwd SyntaxCat -> ASemanticsDesc -> CdB (Tm m) -> Bool -validate table = _ +validate table = undefined -- TODO REVERT {- go :: Show m => Bwd SyntaxCat -> ASemanticsDesc -> CdB (Tm m) -> Bool go env s t@(CdB V th) = reportError s t $ ($ s) $ asRec $ \ a -> a == env check ctx ty0 a0 && check ctx ty1 a1 _ -> False -- don't forget to handle any new cases - a0 :-: a1 -> _ + a0 :-: a1 -> undefined -- TODO REVERT _ :.: t0 -> case vty of VBind cat ty0 -> check (ctx :< atom cat (scope t)) ty0 t0 VPi ty0 (_, ty1) -> check (ctx :< ty0) ty1 t0 _ -> False - m :$: t0 -> _ + m :$: t0 -> undefined -- TODO REVERT GX _ t0 -> check ctx ty t0 From 7de5d7fe8a9943d2f9ca87debc4b7cd7f854829d Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Thu, 19 Jan 2023 15:53:01 +0000 Subject: [PATCH 29/89] [ more ] isList, sop, itm, (parts of) stm Also, a lot of trailing whitespaces --- Src/Elaboration.hs | 71 ++++++++++++++++++++++++++++-------------- Src/Operator.hs | 12 ++++--- Src/Semantics.hs | 22 ++++++------- examples/stlcRules.act | 2 +- 4 files changed, 67 insertions(+), 40 deletions(-) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index b43b26a..922235d 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -109,7 +109,7 @@ spassport _ _ = ACitizen svar :: Usage -> Variable -> Elab (IsSubject, Info ASemanticsDesc, ACTm) svar usage x = do - ovs <- asks objVars + ovs <- asks objVars res <- resolve x case res of Just (Left k) -> case k of @@ -234,6 +234,8 @@ sparamdescs ((mx , ty):ps) = do spatSemantics :: ASemanticsDesc -> CPattern -> Elab (APattern, ASemanticsDesc, Decls) +spatSemantics = undefined +{- spatSemantics ty (AsP r v p) = _ spatSemantics ty (VarP r v) = _ spatSemantics ty (AtP r a) = _ @@ -242,9 +244,46 @@ spatSemantics ty (LamP r p) = _ spatSemantics ty (ThP r th p) = _ spatSemantics ty (UnderscoreP r) = _ spatSemantics ty (Irrefutable r p) = _ - -patToTm :: Pat -> ASemanticsDesc -> Maybe ASemanticsDesc -patToTm p = _ +-} + +isList :: Raw -> Elab [Raw] +isList (At r "") = pure [] +isList (At r a) = throwError (ExpectedNilGot r a) +isList (Cons r p q) = (p:) <$> isList q +isList t = throwError (ExpectedAConsGot (getRange t) t) + +sop :: Raw -> Elab (AAnOperator, [Raw]) +sop (At ra a) = do + op <- isOperator ra a + pure (op, []) +sop (Cons rp (At ra a) ps) = do + op <- isOperator ra a + es <- isList ps + pure (op, es) +sop ro = throwError (ExpectedAnOperator (getRange ro) ro) + +itm :: Usage -> Raw -> Elab (ASemanticsDesc, ACTm) +itm usage (Var r v) = do + (_, idesc, v) <- svar usage v + desc <- fromInfo r idesc + pure (desc, v) +itm usage (Op r rs ro) = do + (AnOperator{..}, rps) <- sop ro + (sdesc, s) <- itm usage rs + -- TODO: check sdesc against (snd objDesc) + (desc, ps) <- _ -- rps + let o = case ps of + [] -> atom (getOperator opName) (scope s) + _ -> getOperator opName #%+ ps + pure (desc, Term.contract (s :-: o)) +-- TODO?: annotated terms? +itm _ _ = throwError _ + +itms :: + +{- + o <- stms usage (Semantics.contract VAtom : psdesc) ro +-} stm :: Usage -> ASemanticsDesc -> Raw -> Elab ACTm stm usage desc (Var r v) = during (TermVariableElaboration v) $ do @@ -295,26 +334,10 @@ stm usage desc rt = do Unused -> do sc <- stm usage desc sc pure ((Hide "_" := False :.) $^ sc) - Op r rs ro -> case ro of - -- TODO: usage checking - At ra a -> do - AnOperator{..} <- isOperator ra a - unless (null paramsDesc) $ throwError (ExpectedAnEmptyASOTListGot r a paramsDesc) - o <- stm usage (Semantics.contract $ VAtom 0) ro - case patToTm . snd $ objDesc of - Nothing -> error "Impossible" - Just sdesc -> do - s <- stm usage sdesc rs - - compatibleInfos r (Known rdesc) (Known desc) - pure (Term.contract (s :-: o)) - Cons rp (At ra a) ps -> do - (sdesc, psdesc, rdesc) <- isOperator ra a - o <- stms usage (Semantics.contract VAtom : psdesc) ro - s <- stm usage sdesc rs - compatibleInfos r (Known rdesc) (Known desc) - pure (Term.contract (s :-: o)) - _ -> throwError (ExpectedAnOperator (getRange ro) ro) + Op{} -> do + (tdesc, t) <- itm usage rt + compatibleInfos (getRange t) (Known tdesc) (Known desc) + pure t spats :: IsSubject -> [SyntaxDesc] -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) diff --git a/Src/Operator.hs b/Src/Operator.hs index 993966c..1c31fa8 100644 --- a/Src/Operator.hs +++ b/Src/Operator.hs @@ -23,7 +23,7 @@ data ObjVar = ObjVar -- TODO : print the info instance Pretty ObjVar where - pretty (ObjVar x info) = pretty x + pretty (ObjVar x info) = pretty x -- ObjVars is a representation of variable contexts -- which are in scope for all the types they contain, @@ -47,16 +47,20 @@ scopeSize = length . getObjVars -- Second Order Type +-- i.e. the type of a schematic variable; it can itself bind object variables +-- e.g. ['Pi S \x.T] +-- - S has a SOT, binding nothing +-- - T has a SOT, binding x with type S[] type family SOT (ph :: Phase) :: * type instance SOT Concrete = Raw type instance SOT Abstract = ASOT - + -- ObjVars are in scope for the ACTm data ASOT = ObjVars :=> ACTm deriving (Show) -infix 2 :=> +infix 2 :=> ------------------------------------------------------------------------------ -- Operators @@ -127,7 +131,7 @@ poperator ph = panoperator :: Parser CAnOperator panoperator = do - obj <- pmaybeNamed ppat + obj <- pmaybeNamed ppat punc "-" (opname, params) <- poperator $ pmaybeNamed psemanticsdecl punc ":" diff --git a/Src/Semantics.hs b/Src/Semantics.hs index a1501e3..83331f6 100644 --- a/Src/Semantics.hs +++ b/Src/Semantics.hs @@ -5,12 +5,12 @@ import Control.Monad import Control.Applicative import Data.Void -import Data.Map (Map) +-- import Data.Map (Map) import qualified Data.Map as Map -import Hide +-- import Hide import Bwd -import Concrete.Base (Phase(..), ASyntaxDesc, ASemanticsDesc, SEMANTICSDESC) +import Concrete.Base (ASyntaxDesc, ASemanticsDesc) import Actor (ACTm, ActorMeta) import Thin (CdB(..), DB(..), weak, scope, ($^), (*^), ones, none) import Term hiding (contract, expand) @@ -54,13 +54,13 @@ extractScope = \case VSyntaxCat sc _ -> sc VNeutral s -> scope s VUniverse sc -> sc - VPi s (n , t) -> scope s + VPi s (n , t) -> scope s expand' :: forall a. WithSyntaxCat a -> SyntaxTable -> HeadUpData' ActorMeta -> ASemanticsDesc -> Maybe (VSemanticsDesc' a) expand' w table dat desc = do go True (headUp dat desc) where - go :: Bool -> ASemanticsDesc -> Maybe (VSemanticsDesc' a) + go :: Bool -> ASemanticsDesc -> Maybe (VSemanticsDesc' a) go b s = ($ s) (asAtomOrTagged (goAtoms b) (goTagged b s)) <|> pure (VNeutral desc) @@ -148,10 +148,10 @@ validate table = undefined -- TODO REVERT gos env [] = asNil True gos env (s:ss) = asPair $ \ t0 t1 -> go env s t0 && gos env ss t1 -} - + typecheck :: SyntaxTable -> Bwd SyntaxCat -- already known syntax environment - -> HeadUpData' ActorMeta + -> HeadUpData' ActorMeta -> Bwd ASemanticsDesc -- type context `ctx` -> ASemanticsDesc -- type `ty` we are checking, `ty` lives in `ctx` -> ACTm -- term `t` we are checking, `t` is alson in `ctx` @@ -174,13 +174,13 @@ typecheck table env dat = check where VNeutral{} -> False VPi{} -> False a0 :%: a1 -> case vty of - VNilOrCons ty0 ty1 -> check ctx ty0 a0 && check ctx ty1 a1 + VNilOrCons ty0 ty1 -> check ctx ty0 a0 && check ctx ty1 a1 VEnumOrTag _ _ atys -> ($ a0) $ asAtom $ \(a, _) -> case lookup a atys of Nothing -> False Just tys -> checks ctx tys a1 VUniverse sc -> ($ a0) $ asAtom $ \(s, _) -> (&&) (s == "Pi") $ ($ a1) $ asPair $ \ty0 -> asPair $ \ty1 -> asNil - $ check ctx (universe sc) ty0 && check (ctx :< ty0) (universe $ sc + 1) ty1 + $ check ctx (universe sc) ty0 && check (ctx :< ty0) (universe $ sc + 1) ty1 VCons ty0 ty1 -> check ctx ty0 a0 && check ctx ty1 a1 _ -> False -- don't forget to handle any new cases a0 :-: a1 -> undefined -- TODO REVERT @@ -195,12 +195,12 @@ typecheck table env dat = check where checks :: Bwd ASemanticsDesc -> [ASemanticsDesc] -> ACTm -> Bool checks ctx [] t = ($ t) $ asNil True checks ctx (ty : tys) t = ($ t) $ asPair $ \t0 t1 -> check ctx ty t0 && checks ctx tys t1 - + var :: Bwd ASemanticsDesc -> Int -> DB -> ASemanticsDesc var ctx sc (DB i) = (ctx none (1 + i)) universe sc = contract $ VUniverse sc - + listOf :: String -> ASemanticsDesc -> ASemanticsDesc listOf x d = let ga = scope d + 1 in "Fix" #%+ [x \\ (atom "NilOrCons" ga % (weak d % var (DB 0) ga % nil ga))] diff --git a/examples/stlcRules.act b/examples/stlcRules.act index 9cf25e2..9e61462 100644 --- a/examples/stlcRules.act +++ b/examples/stlcRules.act @@ -75,7 +75,7 @@ rule -- Global assumption: 'Semantics comes with Pi builtin {['Arr S T] - 'Value ~> ['Pi (S - 'Value) \_. (T - 'Value)]} --- Invariant: the subject in a premiss is always something with a name +-- Invariant: the subject in a premise is always something with a name -- payoff - the name BECOMES the name of the citizen rule From c7bb31858c11c1a802cdfe2b539648c6a5cec148 Mon Sep 17 00:00:00 2001 From: Georgi Nakov Date: Tue, 24 Jan 2023 17:06:31 +0000 Subject: [PATCH 30/89] [ refactor ] making mangleActors generic over the meta type --- Src/Actor.hs | 27 ++++++++++++++------------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/Src/Actor.hs b/Src/Actor.hs index 85b3e46..f635802 100644 --- a/Src/Actor.hs +++ b/Src/Actor.hs @@ -81,7 +81,7 @@ type EnvImg' m = ([String] -- bound vars xi actorVar does know about type Env = Env' Meta type EnvImg = EnvImg' Meta -tryAlpha :: Env -> String -> String +tryAlpha :: Env' m -> String -> String tryAlpha rho x = maybe x unhide (Map.lookup x (alphaRenamings rho)) declareAlpha :: (String, Hide String) -> Env' m -> Env' m @@ -120,15 +120,16 @@ guardSubject v defn gd env = -- in the environment (tm := ['Lam \x.['Emb x]]) -- we need to instantiate tm to ['Lam \x.['Emb x]] before -- trying to find the clause that matches -mangleActors :: Options - -> Env {- Env ga -} - -> ACTm {- Src de -} - -> Maybe Term {- Trg (ga <<< de) -} +mangleActors :: forall m . Show m + => Options + -> Env' m {- Env ga -} + -> ACTm {- Src de -} + -> Maybe (Term' m) {- Trg (ga <<< de) -} mangleActors opts rho tm = go tm where ga = length (globalScope rho) - go :: CdB (Tm ActorMeta) {- Src de -} - -> Maybe Term {- Trg (ga <<< de) -} + go :: CdB (Tm ActorMeta) {- Src de -} + -> Maybe (Term' m) {- Trg (ga <<< de) -} go tm = case expand tm of VX i de -> pure (var i (ga + de)) AX a de -> pure (atom a (ga + de)) @@ -140,8 +141,8 @@ mangleActors opts rho tm = go tm where sg <- goSbst sg pure (t //^ sg) - goSbst :: CdB (Sbst ActorMeta) {- xi =>Src de -} - -> Maybe Subst {- ga <<< xi =>Trg ga <<< de -} + goSbst :: CdB (Sbst ActorMeta) {- xi =>Src de -} + -> Maybe (Subst' m) {- ga <<< xi =>Trg ga <<< de -} goSbst (CdB (S0 :^^ 0) th) = pure $ sbstI ga *^ (ones ga <> th) goSbst (CdB (ST rp :^^ 0) th) = splirp (CdB rp th) $ \ s (CdB (x := tm) ph) -> do @@ -157,11 +158,11 @@ mangleActors opts rho tm = go tm where -- local scope extension it was bound in. We expect that the -- substitution acting upon the term will cover all of these local -- variables. - lookupVar :: Env -> ActorMeta -> Maybe ([String], Term) - lookupVar rh av = Map.lookup av (actorVars rh) + lookupVar :: ActorMeta -> Maybe ([String], Term' m) + lookupVar av = Map.lookup av (actorVars rho) - noisyLookupVar :: ActorMeta -> Maybe Term - noisyLookupVar av = case lookupVar rho av of + noisyLookupVar :: ActorMeta -> Maybe (Term' m) + noisyLookupVar av = case lookupVar av of Just (_, t) -> Just t Nothing -> alarm opts ("couldn't find " ++ show av ++ " in " ++ show rho) Nothing From b02233d803b366e6b34c25f311955a11a3321f6c Mon Sep 17 00:00:00 2001 From: Georgi Nakov Date: Tue, 24 Jan 2023 17:08:47 +0000 Subject: [PATCH 31/89] [ new ] itm definition --- Src/Elaboration.hs | 61 ++++++++++++++++++++++++++++++--------- Src/Elaboration/Monad.hs | 25 +++++++++++++--- Src/Elaboration/Pretty.hs | 10 +++++++ 3 files changed, 78 insertions(+), 18 deletions(-) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 922235d..2dfa0c3 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -25,17 +25,19 @@ import Syntax import Thin import Utils import Info +import Machine.Matching import Elaboration.Monad import Term.Base import qualified Term.Base as Term import Term.Substitution -import Pattern as P +import Pattern as P hiding (match) import Location import Data.List.NonEmpty (fromList) import Pattern.Coverage (Covering'(..), combine, shrinkBy, missing) import Control.Applicative ((<|>)) import Operator +import Operator.Eval import Semantics type CPattern = PATTERN Concrete @@ -270,20 +272,51 @@ itm usage (Var r v) = do itm usage (Op r rs ro) = do (AnOperator{..}, rps) <- sop ro (sdesc, s) <- itm usage rs - -- TODO: check sdesc against (snd objDesc) - (desc, ps) <- _ -- rps - let o = case ps of - [] -> atom (getOperator opName) (scope s) - _ -> getOperator opName #%+ ps - pure (desc, Term.contract (s :-: o)) + dat <- do + dat <- asks headUpData + let hnf = headUp dat + env <- case snd $ match hnf initMatching (Problem B0 (snd objDesc) sdesc) of + Left e -> throwError $ InferredDescMismatch r + Right m -> pure $ matchingToEnv m (huEnv dat) + env <- case fst objDesc of + Nothing -> pure env + Just v -> pure $ newActorVar v (localScope env <>> [], s) env + pure dat{huEnv = env} + local (setHeadUpData dat) $ do + (desc, ps) <- itms r usage paramsDesc rps retDesc + let o = case ps of + [] -> atom (getOperator opName) (scope s) + _ -> getOperator opName #%+ ps + pure (desc, Term.contract (s :-: o)) -- TODO?: annotated terms? -itm _ _ = throwError _ - -itms :: - -{- - o <- stms usage (Semantics.contract VAtom : psdesc) ro --} +itm _ t = throwError $ DontKnowHowToInferDesc (getRange t) t + +itms :: Range -> Usage -> [(Maybe ActorMeta, ASOT)] -> [Raw] -> ASOT -> Elab (ASemanticsDesc, [ACTm]) +itms r usage [] [] rdesc = (, []) <$> sasot r rdesc +itms r usage ((binder, asot):bs) (rp:rps) rdesc = do + pdesc <- sasot (getRange rp) asot --interpolate asot with the objVars in the env + p <- stm usage pdesc rp + dat <- do + dat <- asks headUpData + pure $ case binder of + Nothing -> dat + Just v -> + let env = huEnv dat + env' = newActorVar v (localScope env <>> [], p) env + in dat{huEnv = env'} + local (setHeadUpData dat) $ + fmap (p:) <$> itms r usage bs rps rdesc +itms r usage bs rps rdesc = throwError $ ArityMismatchInOperator r + +sasot :: Range -> ASOT -> Elab ASemanticsDesc +sasot r (objVars :=> desc) = do + dat <- asks headUpData + -- we hope that mangleActors will instantiate objVars in desc for us + -- TODO: restrict the env to the actual support + case mangleActors (huOptions dat) (huEnv dat) desc of + Nothing -> throwError $ SchematicVariableNotInstantiated r + Just v -> pure v + stm :: Usage -> ASemanticsDesc -> Raw -> Elab ACTm stm usage desc (Var r v) = during (TermVariableElaboration v) $ do diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index b5109a6..801f185 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -228,6 +228,9 @@ declareObjVar (x, info) ctx = ctx { objVars = ObjVars $ getObjVars (objVars ctx) setObjVars :: ObjVars -> Context -> Context setObjVars ovs ctx = ctx { objVars = ovs } +setHeadUpData :: HeadUpData' ActorMeta -> Context -> Context +setHeadUpData dat ctx = ctx { headUpData = dat} + instance Selable ObjVars where th ^? (ObjVars ovs) = ObjVars (th ^? ovs) @@ -400,9 +403,7 @@ data Complaint -- syntaxdesc validation | InconsistentSyntaxDesc Range | InvalidSyntaxDesc Range SyntaxDesc - | InvalidSemanticsDesc Range ASemanticsDesc | IncompatibleSyntaxInfos Range (Info SyntaxDesc) (Info SyntaxDesc) - | IncompatibleSemanticsInfos Range (Info ASemanticsDesc) (Info ASemanticsDesc) | IncompatibleSyntaxDescs Range SyntaxDesc SyntaxDesc | GotBarredAtom Range String [String] | ExpectedNilGot Range String @@ -413,13 +414,20 @@ data Complaint | ExpectedAConsGot Range Raw | ExpectedAConsPGot Range RawP | SyntaxError Range SyntaxDesc Raw - | SemanticsError Range ASemanticsDesc Raw | SyntaxPError Range SyntaxDesc RawP | ExpectedAnOperator Range Raw | ExpectedAnEmptyListGot Range String [SyntaxDesc] - | ExpectedAnEmptyASOTListGot Range String [(Maybe ActorMeta, ASOT)] + -- semanticsdesc validation + | InvalidSemanticsDesc Range ASemanticsDesc + | SemanticsError Range ASemanticsDesc Raw + | IncompatibleSemanticsInfos Range (Info ASemanticsDesc) (Info ASemanticsDesc) -- subjects and citizens | AsPatternCannotHaveSubjects Range RawP + -- desc inference + | InferredDescMismatch Range + | DontKnowHowToInferDesc Range Raw + | ArityMismatchInOperator Range + | SchematicVariableNotInstantiated Range deriving (Show) instance HasGetRange Complaint where @@ -479,8 +487,17 @@ instance HasGetRange Complaint where SyntaxPError r _ _ -> r ExpectedAnOperator r _ -> r ExpectedAnEmptyListGot r _ _ -> r + -- semantics validation + InvalidSemanticsDesc r _ -> r + SemanticsError r _ _ -> r + IncompatibleSemanticsInfos r _ _ -> r -- subjects and citizens AsPatternCannotHaveSubjects r _ -> r + -- desc inference + InferredDescMismatch r -> r + DontKnowHowToInferDesc r _ -> r + ArityMismatchInOperator r -> r + SchematicVariableNotInstantiated r -> r ------------------------------------------------------------------------------ -- Syntaxes diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index da92e34..5f4341f 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -201,7 +201,17 @@ instance Pretty Complaint where ExpectedAnEmptyListGot r a ds -> hsep ["Expected", pretty a, "to be a constant operator" , "but it takes arguments of type:", collapse (pretty <$> ds)] + -- TODO : learn to print the semantics desc + InvalidSemanticsDesc r sem -> "Invalid semantics description" + SemanticsError r sem t -> hsep [pretty t, "does not match the semantics description"] + IncompatibleSemanticsInfos r isem isem' -> "Incompatible semantics description" AsPatternCannotHaveSubjects r p -> hsep ["As pattern", pretty p, "duplicates a subject variable"] + -- desc inference + -- TODO : add more info + InferredDescMismatch r -> "Inferred object description does not match pattern" + DontKnowHowToInferDesc r t -> hsep ["Do not know how to infer description for", pretty t] + ArityMismatchInOperator r -> "Arity mismatch in operator" + SchematicVariableNotInstantiated r -> "Schematic variable not instantiated" instance Pretty a => Pretty (WithStackTrace a) where pretty (WithStackTrace stk msg) = vcat (pretty msg : map pretty stk) From c0dd1348dbb74cc98b2bf138562197a6e4398569 Mon Sep 17 00:00:00 2001 From: Georgi Nakov Date: Thu, 26 Jan 2023 15:33:40 +0000 Subject: [PATCH 32/89] [ new ] beginning of a LexicalScope --- Src/Command.hs | 4 +--- Src/Elaboration.hs | 13 +++++++------ Src/Elaboration/Monad.hs | 13 +++++++++++++ Src/Operator.hs | 14 ++++++++++++++ 4 files changed, 35 insertions(+), 9 deletions(-) diff --git a/Src/Command.hs b/Src/Command.hs index 13427a7..a729b7c 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -129,8 +129,6 @@ instance Pretty (PLACE Concrete) where parens $ hsep $ [ pretty v, ":", pretty syntaxdesc ] ++ (("=>" <+> pretty semanticsdesc) <$ guard (syntaxdesc /= semanticsdesc)) - - instance Pretty CCommand where pretty = let prettyCds cds = collapse (BracesList $ pretty <$> cds) in \case DeclJudge em jd p -> hsep [pretty em <> pretty jd, colon, pretty p] @@ -280,7 +278,7 @@ sdeclOps ((AnOperator (WithRange r opname) (objName, objDesc) paramDescs retDesc pure (Just objName , Used objName) (descPat, objDesc, ds) <- spatSemantics (atom "Semantics" 0) objDesc ovs <- asks objVars - local (declare objBinder (ActVar IsNotSubject (ovs :=> objDesc) . setDecls ds)) $ do + local (declare objBinder (ActVar IsNotSubject (ovs :=> objDesc)) . setDecls ds) $ do (paramDescs, ds) <- sparamdescs paramDescs retDesc <- local (setDecls ds) $ ssemanticsdesc retDesc let op = AnOperator opname objDesc paramDescs retDesc diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 2dfa0c3..d825781 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -157,18 +157,18 @@ ssbst usage (sg :< sgc) = case sgc of when (v /= w) $ throwError (NotTopVariable r v w) (sg, ovs) <- local (setObjVars xz) (ssbst usage sg) pure (sbstW sg (ones 1), ovs <: ObjVar (getVariable w) cat) + -- TODO : worry about dropped things ocurring in types Drop r v -> do (xz, (w, cat)) <- spop r when (v /= w) $ throwError (NotTopVariable r v w) (sg, ovs) <- local (setObjVars xz) (ssbst usage sg) pure (weak sg, ovs) Assign r v t -> do - info <- getHint (getVariable v) - desc <- fromInfo r info - t <- stm usage desc t (sg, ovs) <- ssbst usage sg - v <- local (setObjVars ovs) $ isFresh v - pure (sbstT sg ((Hide v :=) $^ t), ovs <: ObjVar v info) + local (setObjVars ovs) $ do + (desc, t) <- itm usage t + v <- isFresh v + pure (sbstT sg ((Hide v :=) $^ t), ovs <: ObjVar v (Known desc)) sth :: (Bwd Variable, ThDirective) -> Elab Th sth (xz, b) = do @@ -289,12 +289,13 @@ itm usage (Op r rs ro) = do _ -> getOperator opName #%+ ps pure (desc, Term.contract (s :-: o)) -- TODO?: annotated terms? + itm _ t = throwError $ DontKnowHowToInferDesc (getRange t) t itms :: Range -> Usage -> [(Maybe ActorMeta, ASOT)] -> [Raw] -> ASOT -> Elab (ASemanticsDesc, [ACTm]) itms r usage [] [] rdesc = (, []) <$> sasot r rdesc itms r usage ((binder, asot):bs) (rp:rps) rdesc = do - pdesc <- sasot (getRange rp) asot --interpolate asot with the objVars in the env + pdesc <- sasot (getRange rp) asot p <- stm usage pdesc rp dat <- do dat <- asks headUpData diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 801f185..0fa2bf4 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -173,6 +173,19 @@ data Kind type Decls = Bwd (String, Kind) type Operators = Map String AAnOperator +data LexicalVar = CdBVar ObjVar | Macro Raw + +-- LexicalScope gives the meanings of things that look like variables. +-- Crucially, only the CdBVars are in scope for the abstract syntax +-- and their semantics desc is in the scope of the whole context, +-- i.e., CdbVars are ready for lookup with no further +-- weakening. Consequently, we must weaken them when we go under a +-- binder. Macros are scope checked and expanded at def. site but +-- not elaborated until use site. Hence, they cannot be recursive. The +-- vars that occur in a Macro are CdBVars - we have checked they are +-- in scope and if they are Macros, we have further expanded them. +type LexicalScope = Bwd (String, LexicalVar) + data Context = Context { objVars :: ObjVars , declarations :: Decls diff --git a/Src/Operator.hs b/Src/Operator.hs index 1c31fa8..9ff7b0b 100644 --- a/Src/Operator.hs +++ b/Src/Operator.hs @@ -15,6 +15,20 @@ import Bwd import Thin import Pretty +{- + 1. No subst in parsing phase. + => parser has no clue about lexical scope + 2. Elaborator keeps separate notions of CdB context + and lexical scope. ^ + ^ | + (maps var names to either CdB vars | + or raw terms - the latter must be | + in scope at def. site) | + | + (types in scope for the whole context, weakens under binders, + never strengthens) + +-} data ObjVar = ObjVar { objVarName :: String From 445ff41308feb192b9e1bba1c36029d2c9a0a610 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 31 Jan 2023 16:01:04 +0000 Subject: [PATCH 33/89] [ more ] type fixing --- Src/Actor.hs | 4 +- Src/Concrete/Base.hs | 10 +-- Src/Concrete/Parse.hs | 4 +- Src/Concrete/Pretty.hs | 4 +- Src/Elaboration.hs | 145 ++++++++++++++++++++++++-------------- Src/Elaboration/Monad.hs | 74 ++++++++++++------- Src/Elaboration/Pretty.hs | 6 +- Src/Operator.hs | 20 +++--- Src/Unelaboration.hs | 8 +-- 9 files changed, 172 insertions(+), 103 deletions(-) diff --git a/Src/Actor.hs b/Src/Actor.hs index f635802..acdb2ef 100644 --- a/Src/Actor.hs +++ b/Src/Actor.hs @@ -46,7 +46,7 @@ type instance TERM Abstract = ACTm type instance PATTERN Abstract = Pat type instance CONNECT Abstract = AConnect type instance STACK Abstract = Stack -type instance STACKDESC Abstract = ASyntaxDesc +type instance STACKDESC Abstract = ASemanticsDesc type instance SCRUTINEEVAR Abstract = ACTm type instance SCRUTINEETERM Abstract = ACTm type instance LOOKEDUP Abstract = ACTm @@ -54,7 +54,7 @@ type instance GUARD Abstract = Maybe ActorVar data AConnect = AConnect Channel Th Channel Int deriving (Show) type AProtocol = PROTOCOL Abstract -type AContextStack = ContextStack ASemanticsDesc +type AContextStack = ContextStack ASyntaxDesc ASemanticsDesc type AActor = ACTOR Abstract type ACTm = CdB (Tm ActorMeta) type ACTSbst = CdB (Sbst ActorMeta) diff --git a/Src/Concrete/Base.hs b/Src/Concrete/Base.hs index 143fddd..d0de01a 100644 --- a/Src/Concrete/Base.hs +++ b/Src/Concrete/Base.hs @@ -163,10 +163,10 @@ deriving instance ( Show (SYNTAXDESC ph) , Show (SEMANTICSDESC ph)) => Show (PROTOCOL ph) -data ContextStack t = ContextStack - { keyDesc :: t - , valueDesc :: t - } deriving (Show, Functor, Foldable, Traversable) +data ContextStack k v = ContextStack + { keyDesc :: k + , valueDesc :: v + } deriving (Show) data CConnect = CConnect Variable Variable deriving (Show) @@ -342,6 +342,6 @@ isWin (Win _) = True isWin _ = False type CProtocol = PROTOCOL Concrete -type CContextStack = ContextStack Raw +type CContextStack = ContextStack Raw Raw type CActor = ACTOR Concrete type CScrutinee = SCRUTINEE Concrete diff --git a/Src/Concrete/Parse.hs b/Src/Concrete/Parse.hs index 79d0995..27e1719 100644 --- a/Src/Concrete/Parse.hs +++ b/Src/Concrete/Parse.hs @@ -91,7 +91,7 @@ pth :: Parser (Bwd Variable, ThDirective) pth = (,) <$> ppes pspc pvariable <*> (ThDrop <$ pspc <* pch ('*' ==) <|> pure ThKeep) -pmode :: Parser (Mode ()) +pmode :: Parser (Mode ()) pmode = Input <$ pch (== '?') <|> Subject () <$ pch (== '$') <|> Output <$ pch (== '!') @@ -111,7 +111,7 @@ psyntaxdecl = pTM psemanticsdecl :: Parser Raw psemanticsdecl = pTM -pcontextstack :: Parser (ContextStack Raw) +pcontextstack :: Parser CContextStack pcontextstack = ContextStack <$> psyntaxdecl <* punc "->" diff --git a/Src/Concrete/Pretty.hs b/Src/Concrete/Pretty.hs index 351fec0..1f2455e 100644 --- a/Src/Concrete/Pretty.hs +++ b/Src/Concrete/Pretty.hs @@ -207,14 +207,14 @@ instance Pretty (Mode a) where pretty Input = "?" pretty (Subject _) = "$" pretty Output = "!" - + instance (Pretty t) => Pretty (Mode a, t) where pretty (m, desc) = hsep [ pretty m, prettyPrec 1 desc ] instance Pretty CProtocol where pretty (Protocol ps) = foldMap (\ x -> pretty x <> ". ") ps -instance Pretty t => Pretty (ContextStack t) where +instance (Pretty k, Pretty v) => Pretty (ContextStack k v) where pretty stk = hsep [pretty (keyDesc stk), "->", pretty (valueDesc stk)] instance Pretty CConnect where diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index d825781..32022a3 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -21,7 +21,7 @@ import Hide import Scope import Syntax ( SyntaxCat, - SyntaxDesc, syntaxDesc) + SyntaxDesc, syntaxDesc, wildcard) import Thin import Utils import Info @@ -56,7 +56,7 @@ checkSendableSubject tm = do go :: Bwd String -> Raw -> Elab (Maybe ActorVar) go localVars x = case x of Var r v -> resolve v >>= \case - Just (Left (ActVar (IsSubject {}) _)) -> pure . Just $ getVariable v + Just (ADeclaration (ActVar (IsSubject {}) _)) -> pure . Just $ getVariable v _ -> Nothing <$ raiseWarning (SentSubjectNotASubjectVar (getRange tm) tm) Sbst r sg x -> do case isInvertible localVars sg of @@ -109,22 +109,22 @@ spassport :: Usage -> IsSubject -> Passport spassport u IsSubject{} | isBeingScrutinised u = ASubject spassport _ _ = ACitizen -svar :: Usage -> Variable -> Elab (IsSubject, Info ASemanticsDesc, ACTm) +svar :: Usage -> Variable -> Elab (IsSubject, ASemanticsDesc, ACTm) svar usage x = do ovs <- asks objVars res <- resolve x case res of - Just (Left k) -> case k of + Just (ADeclaration k) -> case k of ActVar isSub (sc :=> desc) -> case sc `thinsTo` ovs of Just th -> do logUsage (getVariable x) usage - pure (isSub, Known desc, ActorMeta (spassport usage isSub) (getVariable x) $: sbstW (sbst0 0) th) + pure (isSub, desc, ActorMeta (spassport usage isSub) (getVariable x) $: sbstW (sbst0 0) th) Nothing -> throwError (MetaScopeTooBig (getRange x) x sc ovs) _ -> throwError (NotAValidTermVariable (getRange x) x k) - Just (Right (desc, i)) -> pure (IsNotSubject, desc, var i (scopeSize ovs)) + Just (AnObjVar desc i) -> pure (IsNotSubject, desc, var i (scopeSize ovs)) Nothing -> throwError (OutOfScope (getRange x) x) -spop :: Range -> Elab (ObjVars, (Variable, Info ASemanticsDesc)) +spop :: Range -> Elab (ObjVars, (Variable, ASemanticsDesc)) spop r = do ovs <- asks objVars case getObjVars ovs of @@ -147,6 +147,21 @@ ssemanticsdesc sem = do -- TODO: use stm to actually be able to use operators & actor vars -- DontLog (catToDesc "Semantics") +ssbst :: Usage -> Bwd SbstC -> Elab (ACTSbst, ObjVars) +ssbst usage B0 = do + ovs <- asks objVars + pure (sbstI (scopeSize ovs), ovs) +ssbst usage (sg :< sgc) = case sgc of + Assign r v t -> do + (sg, ovs) <- ssbst usage sg + -- ovs better be a valid scope (without Drop, we know it will be) + local (setObjVars' ovs) $ do + v <- isFresh v + (desc, t) <- itm usage t + pure (sbstT sg ((Hide v :=) $^ t), ovs <: ObjVar v desc) + _ -> undefined + +{- ssbst :: Usage -> Bwd SbstC -> Elab (ACTSbst, ObjVars) ssbst usage B0 = do ovs <- asks objVars @@ -169,6 +184,7 @@ ssbst usage (sg :< sgc) = case sgc of (desc, t) <- itm usage t v <- isFresh v pure (sbstT sg ((Hide v :=) $^ t), ovs <: ObjVar v (Known desc)) +-} sth :: (Bwd Variable, ThDirective) -> Elab Th sth (xz, b) = do @@ -187,8 +203,9 @@ stms usage _ t = throwError (ExpectedAConsGot (getRange t) t) sscrutinee :: CScrutinee -> Elab (EScrutinee, AScrutinee) sscrutinee (SubjectVar r v) = do - (isSub, info, actm) <- svar (Scrutinised r) v - desc <- fromInfo r info + -- TODO: shouldn't this svar return a syntax desc? + -- We're in subject analysis mode + (isSub, desc, actm) <- svar (Scrutinised r) v case (isSub, actm) of (IsSubject{}, CdB (m :$ sg) _) -> pure (SubjectVar r desc, SubjectVar r actm) _ -> throwError (NotAValidSubjectVar r v) @@ -199,8 +216,14 @@ sscrutinee (Pair r sc1 sc2) = do sscrutinee (Lookup r stk v) = do (stk, stkTy) <- isContextStack stk t <- during (LookupVarElaboration v) $ do - (isSub, info, t) <- svar (LookedUp r) v - void $ compatibleInfos r (Known (keyDesc stkTy)) info + -- TODO: + -- Shouldn't this `svar LookedUp` return the SyntaxDesc attached + -- to v given that we are currently analysing it as a subject? + (isSub, desc, t) <- svar (LookedUp r) v + -- /!\ This is probably not correct. Cf. above comment about + -- LookedUp + let hmmmDesc = embed (keyDesc stkTy) + void $ compatibleInfos r (Known hmmmDesc) (Known desc) pure t let vdesc = valueDesc stkTy desc = Semantics.contract (VEnumOrTag (scope vdesc) ["Nothing"] [("Just", [vdesc])]) @@ -266,8 +289,7 @@ sop ro = throwError (ExpectedAnOperator (getRange ro) ro) itm :: Usage -> Raw -> Elab (ASemanticsDesc, ACTm) itm usage (Var r v) = do - (_, idesc, v) <- svar usage v - desc <- fromInfo r idesc + (_, desc, v) <- svar usage v pure (desc, v) itm usage (Op r rs ro) = do (AnOperator{..}, rps) <- sop ro @@ -283,7 +305,7 @@ itm usage (Op r rs ro) = do Just v -> pure $ newActorVar v (localScope env <>> [], s) env pure dat{huEnv = env} local (setHeadUpData dat) $ do - (desc, ps) <- itms r usage paramsDesc rps retDesc + (desc, ps) <- itms r usage paramsDesc rps retDesc let o = case ps of [] -> atom (getOperator opName) (scope s) _ -> getOperator opName #%+ ps @@ -295,7 +317,7 @@ itm _ t = throwError $ DontKnowHowToInferDesc (getRange t) t itms :: Range -> Usage -> [(Maybe ActorMeta, ASOT)] -> [Raw] -> ASOT -> Elab (ASemanticsDesc, [ACTm]) itms r usage [] [] rdesc = (, []) <$> sasot r rdesc itms r usage ((binder, asot):bs) (rp:rps) rdesc = do - pdesc <- sasot (getRange rp) asot + pdesc <- sasot (getRange rp) asot p <- stm usage pdesc rp dat <- do dat <- asks headUpData @@ -305,7 +327,7 @@ itms r usage ((binder, asot):bs) (rp:rps) rdesc = do let env = huEnv dat env' = newActorVar v (localScope env <>> [], p) env in dat{huEnv = env'} - local (setHeadUpData dat) $ + local (setHeadUpData dat) $ fmap (p:) <$> itms r usage bs rps rdesc itms r usage bs rps rdesc = throwError $ ArityMismatchInOperator r @@ -317,17 +339,17 @@ sasot r (objVars :=> desc) = do case mangleActors (huOptions dat) (huEnv dat) desc of Nothing -> throwError $ SchematicVariableNotInstantiated r Just v -> pure v - + stm :: Usage -> ASemanticsDesc -> Raw -> Elab ACTm stm usage desc (Var r v) = during (TermVariableElaboration v) $ do table <- gets syntaxCats (_, desc', t) <- svar usage v - compatibleInfos (getRange v) (Known desc) desc' + compatibleInfos (getRange v) (Known desc) (Known desc') pure t stm usage desc (Sbst r sg t) = do (sg, ovs) <- during (SubstitutionElaboration sg) $ ssbst usage sg - t <- local (setObjVars ovs) (stm usage desc t) + t <- local (setObjVars' ovs) (stm usage desc t) pure (t //^ sg) stm usage desc rt = do table <- gets syntaxCats @@ -357,8 +379,8 @@ stm usage desc rt = do _ -> throwError (SyntaxError r desc rt) Lam r (Scope (Hide x) sc) -> do (s, desc) <- case vdesc of - VWildcard _ -> pure (Unknown, desc) - VBind cat desc -> pure (Known (catToDesc cat), desc) + VWildcard i -> pure (desc, desc) + VBind cat desc -> pure (catToDesc cat, desc) _ -> throwError (SyntaxError r desc rt) case x of Used x -> do @@ -370,11 +392,11 @@ stm usage desc rt = do pure ((Hide "_" := False :.) $^ sc) Op{} -> do (tdesc, t) <- itm usage rt - compatibleInfos (getRange t) (Known tdesc) (Known desc) + compatibleInfos (getRange rt) (Known tdesc) (Known desc) pure t -spats :: IsSubject -> [SyntaxDesc] -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) +spats :: IsSubject -> [ASemanticsDesc] -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) spats _ [] (AtP r "") = (Nothing, AP "",,) <$> asks declarations <*> asks binderHints spats _ [] (AtP r a) = throwError (ExpectedNilGot r a) spats _ [] t = throwError (ExpectedANilPGot (getRange t) t) @@ -441,10 +463,10 @@ spatBase isSub desc (VarP r v) = during (PatternVariableElaboration v) $ do hs <- asks binderHints res <- resolve v case res of - Just (Left k) -> throwError (NotAValidPatternVariable r v k) - Just (Right (desc', i)) -> do - compatibleInfos (getRange v) (Known desc) desc' + Just (AnObjVar desc' i) -> do + compatibleInfos (getRange v) (Known desc) (Known desc') pure (Nothing, VP i, ds, hs) + Just mk -> throwError (NotAValidPatternVariable r v mk) Nothing -> do ovs <- asks objVars v <- pure (getVariable v) @@ -497,8 +519,8 @@ spatBase isSub desc rp = do LamP r (Scope v@(Hide x) p) -> do (s, desc) <- case vdesc of - VWildcard _ -> pure (Unknown, desc) - VBind cat desc -> pure (Known (Semantics.catToDesc cat), desc) + VWildcard _ -> pure (desc, desc) + VBind cat desc -> pure (Semantics.catToDesc cat, desc) _ -> throwError (SyntaxPError r desc rp) case x of @@ -507,13 +529,19 @@ spatBase isSub desc rp = do pure (mr, BP (Hide "_") p, ds, hs) Used x -> do x <- isFresh x - (mr, p, ds, hs) <- local (declareObjVar (x, s) . addHint x s) $ spatBase isSub desc p + (mr, p, ds, hs) <- local (declareObjVar (x, s) . addHint x (Known s)) $ spatBase isSub desc p pure (mr, BP (Hide x) p, ds, hs) +isObjVar :: Variable -> Elab (ASemanticsDesc, DB) +isObjVar p = resolve p >>= \case + Just (AnObjVar desc i) -> pure (desc, i) + Just mk -> throwError $ NotAValidPatternVariable (getRange p) p mk + Nothing -> throwError $ OutOfScope (getRange p) p + isChannel :: Variable -> Elab Channel isChannel ch = resolve ch >>= \case - Just (Left (AChannel sc)) -> pure (Channel $ getVariable ch) - Just mk -> throwError (NotAValidChannel (getRange ch) ch $ either Just (const Nothing) mk) + Just (ADeclaration (AChannel sc)) -> pure (Channel $ getVariable ch) + Just mk -> throwError (NotAValidChannel (getRange ch) ch mk) Nothing -> throwError (OutOfScope (getRange ch) ch) isOperator :: Range -> String -> Elab AAnOperator @@ -531,14 +559,14 @@ data IsJudgement = IsJudgement isJudgement :: Variable -> Elab IsJudgement isJudgement jd = resolve jd >>= \case - Just (Left (AJudgement em p)) -> pure (IsJudgement em (getVariable jd) p) - Just mk -> throwError (NotAValidJudgement (getRange jd) jd $ either Just (const Nothing) mk) + Just (ADeclaration (AJudgement em p)) -> pure (IsJudgement em (getVariable jd) p) + Just mk -> throwError (NotAValidJudgement (getRange jd) jd mk) Nothing -> throwError (OutOfScope (getRange jd) jd) isContextStack :: Variable -> Elab (Stack, AContextStack) isContextStack stk = resolve stk >>= \case - Just (Left (AStack stkTy)) -> pure (Stack (getVariable stk), stkTy) - Just mk -> throwError (NotAValidStack (getRange stk) stk $ either Just (const Nothing) mk) + Just (ADeclaration (AStack stkTy)) -> pure (Stack (getVariable stk), stkTy) + Just mk -> throwError (NotAValidStack (getRange stk) stk mk) Nothing -> throwError (OutOfScope (getRange stk) stk) @@ -587,8 +615,8 @@ withChannel r dir ch@(Channel rch) p ma = do guessDesc :: Bool -> -- is this in tail position? Raw -> Elab (Info ASemanticsDesc) guessDesc b (Var _ v) = resolve v >>= \case - Just (Right (info, i)) -> pure info - Just (Left (ActVar isSub (ObjVars B0 :=> desc))) -> pure $ Known desc + Just (AnObjVar desc i) -> pure (Known desc) + Just (ADeclaration (ActVar isSub (ObjVars B0 :=> desc))) -> pure $ Known desc _ -> pure Unknown guessDesc b (Cons _ p q) = do dp <- guessDesc False p @@ -600,10 +628,14 @@ guessDesc b (Cons _ p q) = do guessDesc True (At _ "") = pure (Known $ Semantics.contract (Semantics.VNil 0)) guessDesc _ _ = pure Unknown -compatibleChannels :: Range -> (Direction, [AProtocolEntry]) -> Ordering -> (Direction, [AProtocolEntry]) -> Elab Int +compatibleChannels :: Range + -> (Direction, [AProtocolEntry]) + -> Ordering + -> (Direction, [AProtocolEntry]) + -> Elab Int compatibleChannels r (dp, []) dir (dq, []) = pure 0 compatibleChannels r (dp, p@(m, s) : ps) dir (dq, q@(n, t) : qs) = do - unless (s == t) $ throwError (IncompatibleSyntaxDescs r s t) + unless (s == t) $ throwError (IncompatibleSemanticsDescs r s t) let (cp , cq) = (whatComm m dp, whatComm n dq) when (cp == cq) $ throwError (IncompatibleModes r p q) case (cp, dir) of @@ -686,10 +718,16 @@ sact = \case tm <- during (SendTermElaboration ch tm) $ do sc <- channelScope ch ovs <- asks objVars - -- NB: the lintersection takes the (Info ASemanticsDesc) into account - -- Should it? + -- NB: the lintersection takes the ASemanticsDesc into account + -- Should it? Yes? + + -- AFAWU: + -- 1. sc is a prefix of ovs + -- 2. lintersection sc ovs will return sc (?) + -- 3. thx is the thinning embedding sc back into ovs + -- => setObjVars would be legitimate because xyz is a valid scope let (thx, xyz, thy) = lintersection (getObjVars sc) (getObjVars ovs) - (*^ thx) <$> local (setObjVars $ ObjVars xyz) (stm usage desc tm) + (*^ thx) <$> local (setObjVars' $ ObjVars xyz) (stm usage desc tm) a <- sact a pure $ Send r ch gd tm a @@ -702,6 +740,10 @@ sact = \case (m, cat) : p | whatComm m dir == RECV -> pure ((m, cat), p) _ -> throwError (InvalidRecv r ch p) + -- TODO: m contains a SyntaxDesc when it's a subject position + -- Why do we throw it away? Shouldn't it be stored & + -- returned when we `svar` with a validation usage? + -- Should it be stored in the ActVar bound below at GOTO? let isSub = case m of Subject _ -> IsSubject Parent _ -> IsNotSubject @@ -711,7 +753,7 @@ sact = \case -- Further actor sc <- channelScope ch - (a, All canwin) <- local (declare av (ActVar isSub (sc :=> cat))) + (a, All canwin) <- local (declare av (ActVar isSub (sc :=> cat))) -- GOTO $ listen $ sact $ case pat of @@ -762,8 +804,10 @@ sact = \case pure (Let r (ActorMeta ACitizen av) desc t a) Under r (Scope v@(Hide x) a) -> do - during UnderElaboration $ () <$ isFresh x - a <- local (declareObjVar (getVariable x, Unknown)) $ sact a + x <- during UnderElaboration $ isFresh x + -- TODO: Have the syntax carry a desc? Fail if the hint is Unknown? + desc <- fromInfo r =<< getHint x + a <- local (declareObjVar (x, desc)) $ sact a pure $ Under r (Scope v a) Match r rsc cls -> do @@ -782,13 +826,10 @@ sact = \case consistentScrutinisation r avst pure $ Match r sc cls - Push r stk (p, (), t) a -> do + Push r stk (rp, (), t) a -> do (stk, stkTy) <- isContextStack stk - - p <- resolve p >>= \case - Just (Right (cat, i)) -> i <$ compatibleInfos (getRange p) cat (Known $ keyDesc stkTy) - Just (Left k) -> throwError $ NotAValidPatternVariable r p k - _ -> throwError $ OutOfScope (getRange p) p + (desc, p) <- isObjVar rp + compatibleInfos (getRange rp) (Known desc) (Known $ embed $ keyDesc stkTy) t <- during (PushTermElaboration t) $ stm (Pushed r) (valueDesc stkTy) t a <- sact a pure $ Push r stk (p, valueDesc stkTy, t) a @@ -891,5 +932,5 @@ scontextstack :: CContextStack -> Elab AContextStack scontextstack (ContextStack key val) = do syndecls <- gets (Map.keys . syntaxCats) key <- ssyntaxdesc syndecls key - val <- ssyntaxdesc syndecls val + val <- ssemanticsdesc val pure (ContextStack key val) diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 0fa2bf4..c4c807d 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -173,21 +173,23 @@ data Kind type Decls = Bwd (String, Kind) type Operators = Map String AAnOperator -data LexicalVar = CdBVar ObjVar | Macro Raw +-- LexicalScope = ObjVars + Macros +-- gives the meanings of things that look like variables. --- LexicalScope gives the meanings of things that look like variables. --- Crucially, only the CdBVars are in scope for the abstract syntax +-- Crucially, only the ObjVars are in scope for the abstract syntax -- and their semantics desc is in the scope of the whole context, --- i.e., CdbVars are ready for lookup with no further --- weakening. Consequently, we must weaken them when we go under a --- binder. Macros are scope checked and expanded at def. site but +-- i.e. ObjVars are ready for lookup with no further weakening. +-- Consequently, we must weaken them when we go under a binder. + +type Macros = Bwd (String, Raw) +-- Macros are scope checked and expanded at def. site but -- not elaborated until use site. Hence, they cannot be recursive. The -- vars that occur in a Macro are CdBVars - we have checked they are -- in scope and if they are Macros, we have further expanded them. -type LexicalScope = Bwd (String, LexicalVar) data Context = Context { objVars :: ObjVars + , macros :: Macros , declarations :: Decls , operators :: Operators , location :: Bwd Turn @@ -205,6 +207,7 @@ data ElabMode = Definition | Execution initContext :: Options -> Context initContext opts = Context { objVars = ObjVars B0 + , macros = B0 , declarations = B0 , operators = Map.fromList [ ("app", AnOperator @@ -214,7 +217,7 @@ initContext opts = Context $ PP (BP (Hide "x") $ MP (am "T") (ones 1)) $ AP "") , paramsDesc = [(Just (am "s"), ObjVars B0 :=> (am "S" $: sbstI 0))] - , retDesc = ObjVars (B0 :< ObjVar "s" (Known (am "S" $: sbstI 0))) :=> (am "T" $: topSbst "x" (var (DB 0) 1)) + , retDesc = ObjVars (B0 :< ObjVar "s" (am "S" $: sbstI 0)) :=> (am "T" $: topSbst "x" (var (DB 0) 1)) }) ] , location = B0 @@ -225,7 +228,7 @@ initContext opts = Context } where am = ActorMeta ACitizen - + initHeadUpData = HeadUpData { opTable = const mempty , metaStore = Store Map.empty Map.empty () @@ -234,21 +237,33 @@ initContext opts = Context , whatIs = const Nothing } +-- We have already checked the name is fresh +declareObjVar :: (String, ASemanticsDesc) -> Context -> Context +declareObjVar (x, sem) ctx + = let scp = fmap weak <$> getObjVars (objVars ctx) in + ctx { objVars = ObjVars (scp :< ObjVar x sem) } -declareObjVar :: (String, Info ASemanticsDesc) -> Context -> Context -declareObjVar (x, info) ctx = ctx { objVars = ObjVars $ getObjVars (objVars ctx) :< ObjVar x info } +-- Careful! The new ovs better be a valid scope +-- i.e. all the objvars mentioned in the SemanticsDesc of +-- further vars need to be bound earlier in the telescope +setObjVars' :: ObjVars -> Context -> Context +setObjVars' ovs ctx = ctx { objVars = ovs } +{- setObjVars :: ObjVars -> Context -> Context setObjVars ovs ctx = ctx { objVars = ovs } +-} setHeadUpData :: HeadUpData' ActorMeta -> Context -> Context setHeadUpData dat ctx = ctx { headUpData = dat} +{- instance Selable ObjVars where th ^? (ObjVars ovs) = ObjVars (th ^? ovs) instance Selable Context where th ^? ctxt = ctxt { objVars = th ^? objVars ctxt } +-} declare :: Binder String -> Kind -> Context -> Context declare Unused k ctx = ctx @@ -382,10 +397,10 @@ data Complaint | IncompatibleChannelScopes Range ObjVars ObjVars -- kinding | NotAValidTermVariable Range Variable Kind - | NotAValidPatternVariable Range Variable Kind - | NotAValidJudgement Range Variable (Maybe Kind) - | NotAValidStack Range Variable (Maybe Kind) - | NotAValidChannel Range Variable (Maybe Kind) + | NotAValidPatternVariable Range Variable Resolved + | NotAValidJudgement Range Variable Resolved + | NotAValidStack Range Variable Resolved + | NotAValidChannel Range Variable Resolved | NotAValidBoundVar Range Variable | NotAValidSubjectVar Range Variable | NotAValidOperator Range String @@ -417,7 +432,7 @@ data Complaint | InconsistentSyntaxDesc Range | InvalidSyntaxDesc Range SyntaxDesc | IncompatibleSyntaxInfos Range (Info SyntaxDesc) (Info SyntaxDesc) - | IncompatibleSyntaxDescs Range SyntaxDesc SyntaxDesc + | IncompatibleSemanticsDescs Range ASemanticsDesc ASemanticsDesc | GotBarredAtom Range String [String] | ExpectedNilGot Range String | ExpectedEnumGot Range [String] String @@ -426,8 +441,8 @@ data Complaint | ExpectedANilPGot Range RawP | ExpectedAConsGot Range Raw | ExpectedAConsPGot Range RawP - | SyntaxError Range SyntaxDesc Raw - | SyntaxPError Range SyntaxDesc RawP + | SyntaxError Range ASemanticsDesc Raw + | SyntaxPError Range ASemanticsDesc RawP | ExpectedAnOperator Range Raw | ExpectedAnEmptyListGot Range String [SyntaxDesc] -- semanticsdesc validation @@ -487,7 +502,7 @@ instance HasGetRange Complaint where InconsistentSyntaxDesc r -> r InvalidSyntaxDesc r _ -> r IncompatibleSyntaxInfos r _ _ -> r - IncompatibleSyntaxDescs r _ _ -> r + IncompatibleSemanticsDescs r _ _ -> r GotBarredAtom r _ _ -> r ExpectedNilGot r _ -> r ExpectedEnumGot r _ _ -> r @@ -545,16 +560,27 @@ channelDelete ch st = st { channelStates = Map.delete ch (channelStates st) } ------------------------------------------------------------------------------ -- Variable lookup -resolve :: Variable -> Elab (Maybe (Either Kind (Info ASemanticsDesc, DB))) +data Resolved + = ADeclaration Kind + | AnObjVar ASemanticsDesc DB + | AMacro Raw + deriving Show + +resolve :: Variable -> Elab (Maybe Resolved) resolve (Variable r x) = do ctx <- ask let ds = declarations ctx let ovs = getObjVars . objVars $ ctx - case focusBy (\ (y, k) -> k <$ guard (x == y)) ds of - Just (_, k, _) -> pure (Just $ Left k) + let mcs = macros ctx + pure $ case focusBy (\ (y, k) -> k <$ guard (x == y)) ds of + Just (_, k, _) -> Just $ ADeclaration k _ -> case focusBy (\ (ObjVar y desc) -> desc <$ guard (x == y)) ovs of - Just (xz, desc, xs) -> pure (Just $ Right (desc, DB $ length xs)) - Nothing -> pure Nothing + Just (xz, desc, xs) -> + -- no need to weaken desc as it's already living in ctx + Just $ AnObjVar desc (DB $ length xs) + Nothing -> case focusBy (\ (y, k) -> k <$ guard (x == y)) mcs of + Just (_, t, _) -> Just $ AMacro t + Nothing -> Nothing ------------------------------------------------------------------------------ -- Subject usage logging diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index 5f4341f..092c26f 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -176,8 +176,8 @@ instance Pretty Complaint where -- syntaxdesc validation InconsistentSyntaxDesc r -> "Inconsistent syntactic descriptions" InvalidSyntaxDesc r d -> hsep ["Invalid syntax desc", pretty d] - IncompatibleSyntaxDescs r desc desc' -> - hsep ["Incompatible syntax descriptions", prettyPrec 1 desc, "and", prettyPrec 1 desc'] + IncompatibleSemanticsDescs r desc desc' -> + hsep ["Incompatible semantics descriptions", prettyPrec 1 desc, "and", prettyPrec 1 desc'] IncompatibleSyntaxInfos r info1 info2 -> hsep ["Syntax infos", pretty info1, "and", pretty info2, "are incompatible"] GotBarredAtom r a as -> hsep @@ -201,7 +201,7 @@ instance Pretty Complaint where ExpectedAnEmptyListGot r a ds -> hsep ["Expected", pretty a, "to be a constant operator" , "but it takes arguments of type:", collapse (pretty <$> ds)] - -- TODO : learn to print the semantics desc + -- TODO : learn to print the semantics desc InvalidSemanticsDesc r sem -> "Invalid semantics description" SemanticsError r sem t -> hsep [pretty t, "does not match the semantics description"] IncompatibleSemanticsInfos r isem isem' -> "Incompatible semantics description" diff --git a/Src/Operator.hs b/Src/Operator.hs index 9ff7b0b..c018678 100644 --- a/Src/Operator.hs +++ b/Src/Operator.hs @@ -24,20 +24,22 @@ import Pretty (maps var names to either CdB vars | or raw terms - the latter must be | in scope at def. site) | - | + | (types in scope for the whole context, weakens under binders, never strengthens) - + -} -data ObjVar = ObjVar +data ObjVar' a = ObjVar { objVarName :: String - , objVarDesc :: Info ASemanticsDesc - } deriving (Show, Eq) + , objVarDesc :: a + } deriving (Functor, Show, Eq) + +type ObjVar = ObjVar' ASemanticsDesc --- TODO : print the info -instance Pretty ObjVar where - pretty (ObjVar x info) = pretty x +-- TODO : print the sem +instance Pretty (ObjVar' a) where + pretty (ObjVar x sem) = pretty x -- ObjVars is a representation of variable contexts -- which are in scope for all the types they contain, @@ -69,7 +71,7 @@ type family SOT (ph :: Phase) :: * type instance SOT Concrete = Raw type instance SOT Abstract = ASOT - +-- TODO: conversion function to telescope -- ObjVars are in scope for the ACTm data ASOT = ObjVars :=> ACTm deriving (Show) diff --git a/Src/Unelaboration.hs b/Src/Unelaboration.hs index 9d9e8e4..0dec160 100644 --- a/Src/Unelaboration.hs +++ b/Src/Unelaboration.hs @@ -311,10 +311,10 @@ instance Unelab () where type Unelabed () = () unelab = pure -instance Unelab t => Unelab (ContextStack t) where - type UnelabEnv (ContextStack t) = UnelabEnv t - type Unelabed (ContextStack t) = ContextStack (Unelabed t) - unelab = traverse unelab +instance (Unelab k, Unelab v, UnelabEnv k ~ UnelabEnv v) => Unelab (ContextStack k v) where + type UnelabEnv (ContextStack k v) = UnelabEnv k + type Unelabed (ContextStack k v) = ContextStack (Unelabed k) (Unelabed v) + unelab (ContextStack k v) = ContextStack <$> unelab k <*> unelab v instance Unelab AProtocol where type UnelabEnv AProtocol = Naming From cfc19c5cbe99d9a563e7c6789618d7e8b0897fd9 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Tue, 31 Jan 2023 17:12:28 +0000 Subject: [PATCH 34/89] [ done ] change meaning of thinned patterns in spat et al --- Src/Elaboration.hs | 127 ++++++++++++++++++++------------------ Src/Elaboration/Monad.hs | 2 +- test/shadowed-pattern.act | 9 +++ 3 files changed, 78 insertions(+), 60 deletions(-) create mode 100644 test/shadowed-pattern.act diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 32022a3..e5f333e 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -76,7 +76,7 @@ checkSendableSubject tm = do escrutinee :: EScrutinee -> ASemanticsDesc escrutinee = \case Pair _ p q -> Semantics.contract (Semantics.VCons (escrutinee p) (escrutinee q)) - SubjectVar _ desc -> desc + SubjectVar _ desc -> embed desc Lookup _ desc _ -> desc -- TODO : do we need to pass in the scope? Compare _ t1 t2 -> Semantics.contract (Semantics.VEnumOrTag 0 ["LT", "EQ", "GT"] []) @@ -186,10 +186,9 @@ ssbst usage (sg :< sgc) = case sgc of pure (sbstT sg ((Hide v :=) $^ t), ovs <: ObjVar v (Known desc)) -} -sth :: (Bwd Variable, ThDirective) -> Elab Th -sth (xz, b) = do - ovs <- asks objVars - let th = which (`elem` (getVariable <$> xz)) (objVarName <$> getObjVars ovs) +sth :: Bwd String -> (Bwd Variable, ThDirective) -> Elab Th +sth ovs (xz, b) = do + let th = which (`elem` (getVariable <$> xz)) ovs pure $ case b of ThKeep -> th ThDrop -> comp th @@ -396,74 +395,83 @@ stm usage desc rt = do pure t -spats :: IsSubject -> [ASemanticsDesc] -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) -spats _ [] (AtP r "") = (Nothing, AP "",,) <$> asks declarations <*> asks binderHints -spats _ [] (AtP r a) = throwError (ExpectedNilGot r a) -spats _ [] t = throwError (ExpectedANilPGot (getRange t) t) -spats isSub (d:ds) (ConsP r p q) = do - (mr1, p, decls, hints) <- spatBase isSub d p - (mr2, q, decls, hints) <- local (setDecls decls . setHints hints) $ spats isSub ds q +spats :: IsSubject -> [ASemanticsDesc] -> (Bwd String, Th) -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) +spats _ [] (ls, th) (AtP r "") = (Nothing, AP "",,) <$> asks declarations <*> asks binderHints +spats _ [] (ls, th) (AtP r a) = throwError (ExpectedNilGot r a) +spats _ [] (ls, th) t = throwError (ExpectedANilPGot (getRange t) t) +spats isSub (d:ds) (ls, th) (ConsP r p q) = do + (mr1, p, decls, hints) <- spatBase isSub d (ls, th) p + (mr2, q, decls, hints) <- local (setDecls decls . setHints hints) $ spats isSub ds (ls, th) q pure (mr1 <|> mr2, PP p q, decls, hints) -spats _ _ t = throwError (ExpectedAConsPGot (getRange t) t) - +spats _ _ (ls, th) t = throwError (ExpectedAConsPGot (getRange t) t) + +-- Inputs: +-- 0. Elaborated scrutinee -- description of how the scrutinee we are +-- matching on was formed +-- 1. Pair of local variables and thinning describing what we are +-- allowed to depend on +-- 2. Raw pattern to elaborate -- Returns: --- 0. Whether a subject pattern was thrown away --- 1. Elaborated pattern --- 2. Bound variables (together with their syntactic categories) --- 3. Binder hints introduced by \x. patterns -spat :: EScrutinee -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) -spat esc rp@(AsP r v p) = do +-- 0. Whether a subject pattern was thrown away +-- 1. Elaborated pattern +-- 2. Bound variables (together with their syntactic categories) +-- 3. Binder hints introduced by \x. patterns +spat :: EScrutinee -> (Bwd String, Th) -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) +spat esc (ls, th) rp@(AsP r v p) = do unless (isSubjectFree esc) $ throwError (AsPatternCannotHaveSubjects r rp) let desc = escrutinee esc v <- isFresh v ds <- asks declarations ovs <- asks objVars - (mr, p, ds, hs) <- local (setDecls (ds :< (v, ActVar IsNotSubject (ovs :=> desc)))) $ spat esc p + (mr, p, ds, hs) <- local (setDecls (ds :< (v, ActVar IsNotSubject (ovs :=> desc)))) $ spat esc (ls, th) p pure (mr, AT (ActorMeta ACitizen v) p, ds, hs) -spat esc p@VarP{} = spatBase (Pattern <$ isSubject esc) (escrutinee esc) p -spat esc (ThP r th p) = do - th <- sth th - (mr, p, ds, hs) <- local (th ^?) $ spat esc p - pure (mr, p *^ th, ds, hs) -spat esc p@(UnderscoreP r) = do - (_, p, ds, hs) <- spatBase (Pattern <$ isSubject esc) (escrutinee esc) p +spat esc (ls, th) p@VarP{} = spatBase (Pattern <$ isSubject esc) (escrutinee esc) (ls, th) p +spat esc (ls, th) (ThP r ph p) = do + ph <- sth ls ph + (mr, p, ds, hs) <- spat esc (ph ^? ls, ph ^? th) p + pure (mr, p *^ ph, ds, hs) +spat esc (ls, th) p@(UnderscoreP r) = do + (_, p, ds, hs) <- spatBase (Pattern <$ isSubject esc) (escrutinee esc) (ls, th) p let mr = r <$ guard (not (isSubjectFree esc)) pure (mr, p, ds, hs) -spat esc@(Pair r esc1 esc2) rp = case rp of +spat esc@(Pair r esc1 esc2) (ls, th) rp = case rp of ConsP r p q -> do - (mr1, p, ds, hs) <- spat esc1 p - (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spat esc2 q) + (mr1, p, ds, hs) <- spat esc1 (ls, th) p + (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spat esc2 (ls, th) q) pure (mr1 <|> mr2, PP p q, ds, hs) _ -> throwError (SyntaxPError (getRange rp) (escrutinee esc) rp) -spat (SubjectVar r desc) rp = spatBase (IsSubject Pattern) desc rp -spat esc@(Lookup _ _ av) rp@(ConsP r (AtP _ "Just") (ConsP _ _ (AtP _ ""))) = do +spat (SubjectVar r desc) (ls, th) rp = spatBase (IsSubject Pattern) desc (ls, th) rp +spat esc@(Lookup _ _ av) (ls, th) rp@(ConsP r (AtP _ "Just") (ConsP _ _ (AtP _ ""))) = do logUsage av (SuccessfullyLookedUp r) - spatBase IsNotSubject (escrutinee esc) rp -spat esc@(Lookup _ _ av) rp = spatBase IsNotSubject (escrutinee esc) rp -spat esc@(Compare{}) rp = spatBase IsNotSubject (escrutinee esc) rp -spat esc@(Term{}) rp = spatBase IsNotSubject (escrutinee esc) rp + spatBase IsNotSubject (escrutinee esc) (ls, th) rp +spat esc@(Lookup _ _ av) (ls, th) rp = spatBase IsNotSubject (escrutinee esc) (ls, th) rp +spat esc@(Compare{}) (ls, th) rp = spatBase IsNotSubject (escrutinee esc) (ls, th) rp +spat esc@(Term{}) (ls, th) rp = spatBase IsNotSubject (escrutinee esc) (ls, th) rp -spatBase :: IsSubject -> ASemanticsDesc -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) -spatBase isSub desc rp@(AsP r v p) = do +spatBase :: IsSubject -> ASemanticsDesc -> (Bwd String, Th) -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) +spatBase isSub desc (ls, th) rp@(AsP r v p) = do unless (isSub == IsNotSubject) $ throwError (AsPatternCannotHaveSubjects r rp) v <- isFresh v ds <- asks declarations ovs <- asks objVars - (mr, p, ds, hs) <- local (setDecls (ds :< (v, ActVar isSub (ovs :=> desc)))) $ spatBase isSub desc p + (mr, p, ds, hs) <- local (setDecls (ds :< (v, ActVar isSub (ovs :=> desc)))) $ spatBase isSub desc (ls, th) p pure (mr, AT (ActorMeta ACitizen v) p, ds, hs) -spatBase isSub desc (ThP r th p) = do - th <- sth th - (mr, p, ds, hs) <- local (th ^?) $ spatBase isSub desc p - pure (mr, p *^ th, ds, hs) -spatBase isSub desc (VarP r v) = during (PatternVariableElaboration v) $ do - table <- gets syntaxCats +spatBase isSub desc (ls, th) (ThP r ph p) = do + ph <- sth ls ph + (mr, p, ds, hs) <- spatBase isSub desc (ph ^? ls, ph ^? th) p + pure (mr, p *^ ph, ds, hs) +spatBase isSub desc (ls, th) (VarP r v) = during (PatternVariableElaboration v) $ do + -- table <- gets syntaxCats ds <- asks declarations hs <- asks binderHints res <- resolve v case res of Just (AnObjVar desc' i) -> do + i <- case thickx th i of + Nothing -> throwError (OutOfScope r v) + Just i -> pure i compatibleInfos (getRange v) (Known desc) (Known desc') pure (Nothing, VP i, ds, hs) Just mk -> throwError (NotAValidPatternVariable r v mk) @@ -472,12 +480,12 @@ spatBase isSub desc (VarP r v) = during (PatternVariableElaboration v) $ do v <- pure (getVariable v) let pat = MP (ActorMeta (spassport (Scrutinised unknown) isSub) v) (ones $ scopeSize ovs) pure (Nothing, pat, ds :< (v, ActVar isSub (ovs :=> desc)), hs) -spatBase isSub desc (UnderscoreP r) = do +spatBase isSub desc (ls, th) (UnderscoreP r) = do let mr = case isSub of IsSubject{} -> Just r IsNotSubject -> Nothing (mr,HP,,) <$> asks declarations <*> asks binderHints -spatBase isSub desc rp = do +spatBase isSub desc (ls, th) rp = do table <- gets syntaxCats dat <- asks headUpData case Semantics.expand table dat desc of @@ -496,23 +504,23 @@ spatBase isSub desc rp = do ConsP r p q -> case vdesc of VNilOrCons d1 d2 -> do - (mr1, p, ds, hs) <- spatBase isSub d1 p - (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spatBase isSub d2 q) + (mr1, p, ds, hs) <- spatBase isSub d1 (ls, th) p + (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spatBase isSub d2 (ls, th) q) pure (mr1 <|> mr2, PP p q, ds, hs) VCons d1 d2 -> do - (mr1, p, ds, hs) <- spatBase isSub d1 p - (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spatBase isSub d2 q) + (mr1, p, ds, hs) <- spatBase isSub d1 (ls, th) p + (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spatBase isSub d2 (ls, th) q) pure (mr1 <|> mr2, PP p q, ds, hs) VWildcard _ -> do - (mr1, p, ds, hs) <- spatBase isSub desc p - (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spatBase isSub desc q) + (mr1, p, ds, hs) <- spatBase isSub desc (ls, th) p + (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spatBase isSub desc (ls, th) q) pure (mr1 <|> mr2, PP p q, ds, hs) VEnumOrTag _ _ ds -> case p of AtP r a -> case lookup a ds of Nothing -> throwError (ExpectedTagGot r (fst <$> ds) a) Just descs -> do - (mr1, p, ds, hs) <- spatBase isSub (atom "Atom" 0) p - (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spats isSub descs q) + (mr1, p, ds, hs) <- spatBase isSub (atom "Atom" 0) (ls, th) p + (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spats isSub descs (ls, th) q) pure (mr1 <|> mr2, PP p q, ds, hs) _ -> throwError (SyntaxPError r desc rp) _ -> throwError (SyntaxPError r desc rp) @@ -525,11 +533,11 @@ spatBase isSub desc rp = do case x of Unused -> do - (mr, p, ds, hs) <- spatBase isSub desc p + (mr, p, ds, hs) <- spatBase isSub desc (ls, th) p pure (mr, BP (Hide "_") p, ds, hs) Used x -> do x <- isFresh x - (mr, p, ds, hs) <- local (declareObjVar (x, s) . addHint x (Known s)) $ spatBase isSub desc p + (mr, p, ds, hs) <- local (declareObjVar (x, s) . addHint x (Known s)) $ spatBase isSub desc (ls :< x, th -? True) p pure (mr, BP (Hide x) p, ds, hs) isObjVar :: Variable -> Elab (ASemanticsDesc, DB) @@ -896,7 +904,8 @@ sclause :: EScrutinee -> (RawP, CActor) -> sclause esc (rp, a) = do ds0 <- asks declarations avs <- lift $ gets actvarStates - (mr, p, ds, hs) <- lift $ during (MatchBranchElaboration rp) $ spat esc rp + ovs <- asks (fmap objVarName . getObjVars . objVars) + (mr, p, ds, hs) <- lift $ during (MatchBranchElaboration rp) $ spat esc (ovs, ones (length ovs)) rp let pats = takez ds (length ds - length ds0) coverageCheckClause rp p (a, me) <- lift $ during (MatchBranchElaboration rp) $ diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index c4c807d..96a62d9 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -147,7 +147,7 @@ data IsSubject' a = IsSubject a | IsNotSubject type IsSubject = IsSubject' Provenance -type instance SCRUTINEEVAR Elaboration = ASemanticsDesc +type instance SCRUTINEEVAR Elaboration = ASyntaxDesc type instance SCRUTINEETERM Elaboration = ASemanticsDesc type instance STACK Elaboration = ASemanticsDesc type instance TERM Elaboration = () diff --git a/test/shadowed-pattern.act b/test/shadowed-pattern.act new file mode 100644 index 0000000..500f89f --- /dev/null +++ b/test/shadowed-pattern.act @@ -0,0 +1,9 @@ + + +-- This should probably be rejected, because it is confusing: the z in +-- the body is a pattern variable, because the z from the lambda has +-- been evicted from the scope. +a : ?'Wildcard. +a@p = p?x. case x { (\ z . {z*}z) -> PRINTF "the body is %r" z. } + +exec a@p. p!(\ x . 'bbb). From 9b34b086bc7c2d03fcf4f498df0633fd469bf61f Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Thu, 2 Feb 2023 15:06:39 +0000 Subject: [PATCH 35/89] [ fix ] it compiles! --- Src/Command.hs | 26 +++++++++++++++++--------- Src/Elaboration.hs | 4 ++-- Src/Elaboration/Monad.hs | 2 +- Src/Elaboration/Pretty.hs | 14 ++++++++++---- Src/LaTeX.hs | 2 +- Src/Machine/Base.hs | 30 +++++++++++++++++------------- Src/Machine/Trace.hs | 21 +++++++++++---------- Src/Main.hs | 7 +++++-- 8 files changed, 64 insertions(+), 42 deletions(-) diff --git a/Src/Command.hs b/Src/Command.hs index a729b7c..5b94794 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -38,6 +38,7 @@ import Parse import Pretty import Rules import Syntax +import Info import Term.Base import Unelaboration(Unelab(..), subunelab, withEnv, initDAEnv, Naming, declareChannel) import Location @@ -63,7 +64,7 @@ data COMMAND (ph :: Phase) | DefnJudge (JUDGEMENTNAME ph, DEFNPROTOCOL ph, CHANNEL ph) (ACTOR ph) | ContractJudge [STATEMENT ph] (STATEMENT ph) [STATEMENT ph] | DeclSyntax [(SYNTAXCAT ph, SYNTAXDESC ph)] - | DeclStack (STACK ph) (ContextStack (SYNTAXDESC ph)) + | DeclStack (STACK ph) (ContextStack (SYNTAXDESC ph) (SEMANTICSDESC ph)) | ContractStack [STATEMENT ph] (STACK ph, Variable, Variable) [STATEMENT ph] | Go (ACTOR ph) | Trace [MachineStep] @@ -81,6 +82,8 @@ deriving instance , Show (SCRUTINEEVAR ph) , Show (SCRUTINEETERM ph) , Show (SYNTAXDESC ph) + , Show (SEMANTICSDESC ph) + , Show (SOT ph) , Show (TERMVAR ph) , Show (TERM ph) , Show (PATTERN ph) @@ -111,9 +114,9 @@ instance (Show a, Unelab a, Pretty (Unelabed a)) => Display (Mode a) where type DisplayEnv (Mode a) = UnelabEnv a display = viaPretty -instance (Show t, Unelab t, Pretty (Unelabed t)) => - Display (ContextStack t) where - type DisplayEnv (ContextStack t) = UnelabEnv t +instance (Show k, Show v, Unelab k, Unelab v, UnelabEnv k ~ UnelabEnv v, Pretty (Unelabed k), Pretty (Unelabed v)) => + Display (ContextStack k v) where + type DisplayEnv (ContextStack k v) = UnelabEnv k display = viaPretty instance Display AProtocol where @@ -156,7 +159,7 @@ instance Unelab ACommand where ContractJudge pres stm posts -> ContractJudge <$> traverse subunelab pres <*> subunelab stm <*> traverse subunelab posts DeclSyntax s -> DeclSyntax . map (first (WithRange unknown)) <$> traverse (traverse unelab) s - DeclStack stk stkTy -> DeclStack <$> subunelab stk <*> traverse unelab stkTy + DeclStack stk stkTy -> DeclStack <$> subunelab stk <*> unelab stkTy ContractStack pres (stk, lhs, rhs) posts -> ContractStack <$> traverse subunelab pres <*> fmap (, lhs, rhs) (subunelab stk) <*> traverse subunelab posts @@ -205,7 +208,7 @@ pcommand <* pspc <*> pconditions <|> Go <$ plit "exec" <* pspc <*> pACT <|> Trace <$ plit "trace" <* pspc <*> pcurlies (psep (punc ",") pmachinestep) - <|> DeclOp <$ plit "operator" <* pspc <*> pcurlies (psep (punc ";") (panoperator "~>")) +-- TODO <|> DeclOp <$ plit "operator" <* pspc <*> pcurlies (psep (punc ";") (panoperator "~>")) <|> DefnOp <$> pdefnop <|> DeclJudgementForm <$> pjudgementform <|> DeclRule <$> prule @@ -262,6 +265,7 @@ globals = (,) <$> asks declarations <*> asks operators setGlobals :: Globals -> Context -> Context setGlobals (decls, ops) = setDecls decls . setOperators ops +{- sdeclOps :: [CAnOperator] -> Elab ([AAnOperator], Globals) sdeclOps [] = ([],) <$> asks globals sdeclOps ((AnOperator (WithRange r opname) (objName, objDesc) paramDescs retDesc) : ops) = do @@ -284,6 +288,7 @@ sdeclOps ((AnOperator (WithRange r opname) (objName, objDesc) paramDescs retDesc let op = AnOperator opname objDesc paramDescs retDesc (ops, decls) <- local (addOperator op) $ sdeclOps ops pure (op : ops, decls) +-} scommand :: CCommand -> Elab (ACommand, Globals) scommand = \case @@ -326,6 +331,7 @@ scommand = \case (ContractStack pres (stk, lhs, rhs) posts,) <$> asks globals Go a -> during ExecElaboration $ (,) . Go <$> local (setElabMode Execution) (sact a) <*> asks globals Trace ts -> (Trace ts,) <$> asks globals +{- DeclOp ops -> first DeclOp <$> sdeclOps ops DefnOp (p, opargs, rhs) -> do ((p, opargs), ret, decls, hints) <- do @@ -345,6 +351,7 @@ scommand = \case DeclJudgementForm j -> do (j , gs) <- sjudgementform j pure (DeclJudgementForm j, gs) +-} checkCompatiblePlaces :: [PLACE Concrete] -> [(Variable, ASemanticsDesc)] -> @@ -390,6 +397,7 @@ then use s => c clauses ub rules to constrain the citizen the parent sent with the subject syntax. -} +{- sjudgementform :: JUDGEMENTFORM Concrete -> Elab (JUDGEMENTFORM Abstract, Globals) sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do inputs <- concat <$> traverse subjects jpreconds -- TODO: should really be the closure of this info @@ -438,7 +446,6 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do , Just syn <- Map.lookup x m = pure (op { objDesc = syn}) | otherwise = throwError (MalformedPostOperator (getRange (objDesc op)) (theValue (opName op)) (Map.keys m)) - -- | sopargs desc cops -- | desc: description of the object the cops are applied to sopargs :: SyntaxDesc -> [COpPattern] -> Elab ([AOpPattern], Decls, Hints) @@ -468,6 +475,7 @@ soperator (WithRange r tag) = do case Map.lookup tag ops of Nothing -> throwError (NotAValidOperator r tag) Just (obj, params, ret) -> pure (AnOperator (Operator tag) obj params ret) +-} scommands :: [CCommand] -> Elab [ACommand] scommands [] = pure [] @@ -476,8 +484,8 @@ scommands (c:cs) = do cs <- local (setGlobals ds) $ scommands cs pure (c:cs) -elaborate :: [CCommand] -> Either (WithStackTrace Complaint) ([WithStackTrace Warning], [ACommand], SyntaxTable) -elaborate ccs = evalElab $ do +elaborate :: Options -> [CCommand] -> Either (WithStackTrace Complaint) ([WithStackTrace Warning], [ACommand], SyntaxTable) +elaborate opts ccs = evalElab opts $ do acs <- scommands ccs st <- get pure (warnings st <>> [], acs, syntaxCats st) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index e5f333e..a1d71c5 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -21,7 +21,7 @@ import Hide import Scope import Syntax ( SyntaxCat, - SyntaxDesc, syntaxDesc, wildcard) + SyntaxDesc, syntaxDesc) import Thin import Utils import Info @@ -76,7 +76,7 @@ checkSendableSubject tm = do escrutinee :: EScrutinee -> ASemanticsDesc escrutinee = \case Pair _ p q -> Semantics.contract (Semantics.VCons (escrutinee p) (escrutinee q)) - SubjectVar _ desc -> embed desc + SubjectVar _ desc -> desc Lookup _ desc _ -> desc -- TODO : do we need to pass in the scope? Compare _ t1 t2 -> Semantics.contract (Semantics.VEnumOrTag 0 ["LT", "EQ", "GT"] []) diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 96a62d9..c4c807d 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -147,7 +147,7 @@ data IsSubject' a = IsSubject a | IsNotSubject type IsSubject = IsSubject' Provenance -type instance SCRUTINEEVAR Elaboration = ASyntaxDesc +type instance SCRUTINEEVAR Elaboration = ASemanticsDesc type instance SCRUTINEETERM Elaboration = ASemanticsDesc type instance STACK Elaboration = ASemanticsDesc type instance TERM Elaboration = () diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index 092c26f..dd50cb6 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -33,11 +33,17 @@ instance Pretty ActorMeta where instance Pretty Kind where pretty = \case - ActVar{} -> "an object variable" + ActVar{} -> "an actor variable" -- TODO: terminology? AChannel{} -> "a channel" AJudgement{} -> "a judgement" AStack{} -> "a context stack" +instance Pretty Resolved where + pretty = \case + ADeclaration k -> pretty k + AnObjVar{} -> "a bound variable" + AMacro t -> "a macro variable" -- TODO: terminology? + instance (Unelab a, Pretty (Unelabed a), UnelabEnv a ~ Naming) => Pretty (CdB a) where pretty (CdB a th) @@ -117,13 +123,13 @@ instance Pretty Complaint where NotAValidPatternVariable r x k -> hsep ["Invalid pattern variable", pretty x, "refers to", pretty k] NotAValidJudgement r x mk -> hsep ["Invalid judgement variable", pretty x - , "refers to", maybe "a bound variable" pretty mk] + , "refers to", pretty mk] NotAValidStack r x mk -> hsep ["Invalid context stack variable", pretty x - , "refers to", maybe "a bound variable" pretty mk] + , "refers to", pretty mk] NotAValidChannel r x mk -> hsep ["Invalid channel variable", pretty x - , "refers to", maybe "a bound variable" pretty mk] + , "refers to", pretty mk] NotAValidBoundVar r x -> hsep ["Invalid bound variable", pretty x] NotAValidSubjectVar r x -> hsep ["Invalid subject variable", pretty x] NotAValidOperator r x -> hsep ["Invalid operator name", pretty x] diff --git a/Src/LaTeX.hs b/Src/LaTeX.hs index ae90dd9..3f5630c 100644 --- a/Src/LaTeX.hs +++ b/Src/LaTeX.hs @@ -100,7 +100,7 @@ toLaTeXCdr d p = do pure $ call False "typosListTail" [p] instance LaTeX Raw where - type Format Raw = ASyntaxDesc + type Format Raw = SyntaxDesc toLaTeX d = \case Var _ v -> do v <- toLaTeX () v diff --git a/Src/Machine/Base.hs b/Src/Machine/Base.hs index e3d0030..ed5c607 100644 --- a/Src/Machine/Base.hs +++ b/Src/Machine/Base.hs @@ -181,14 +181,16 @@ unOp t = case expand t of pure (Operator op, ps) _ -> Nothing -toClause :: Pat -> Bwd (Operator, [Pat]) -> ACTm +toClause :: forall m . Show m => Pat -> Bwd (Operator, [Pat]) -> ACTm -> Options - -> (Term -> Term) -- head normaliser - -> Env - -> (Term, [Term]) -- object & parameters - -> Either (Term, [Term]) Term + -> (Term' m -> Term' m) -- head normaliser + -> Env' m + -> (Term' m, [Term' m]) -- object & parameters + -> Either (Term' m, [Term' m]) (Term' m) toClause pobj (ops :< op) rhs opts hnf env targs@(t, args) = - let msg result = flush $ vcat + let msg result = "" in +{- TODO: reinstate: +let msg result = flush $ vcat [ hsep ( "Matching" : withANSI [SetColour Background Green] (unsafeDocDisplayClosed opts t) : "-" @@ -204,6 +206,7 @@ toClause pobj (ops :< op) rhs opts hnf env targs@(t, args) = ) <> " ~> " <> unsafeDocDisplayClosed opts rhs , result ] in +-} let ((t, ts), res) = loop initMatching ops op targs in case res of Right mtch | Just val <- mangleActors opts (matchingToEnv mtch env) rhs -> whenClause opts (msg (withANSI [SetColour Background Green] "Success!")) $ pure val @@ -218,12 +221,12 @@ toClause pobj (ops :< op) rhs opts hnf env targs@(t, args) = = trace (renderWith (renderOptions opts) doc) a | otherwise = a - loop :: Matching + loop :: Matching' m -> Bwd (Operator, [Pat]) -- left nested operators -> (Operator, [Pat]) -- current operator OP in focus - -> (Term, [Term]) -- current term (t -['OP | ts]) already taken apart - -> ( (Term, [Term]) -- evaluated (t,ts) - , Either Failure Matching) + -> (Term' m, [Term' m]) -- current term (t -['OP | ts]) already taken apart + -> ( (Term' m, [Term' m]) -- evaluated (t,ts) + , Either Failure (Matching' m)) loop mtch ops (op, ps) (tops, tps) = -- match tops against the left-nested (pobj -- ops) -- we don't care about the tps yet @@ -236,12 +239,13 @@ toClause pobj (ops :< op) rhs opts hnf env targs@(t, args) = case loop mtch lops (lop, lps) (ltops, ltps) of ((ltops, ltps), res) -> (ltops -% (getOperator lop, ltps), res) _ -> (contract (ltops :-: loptpsnf), Left Mismatch) -- Careful: could be a stuck meta - _ -> (topsnf, Left (whenClause opts (unsafeDocDisplayClosed unsafeOptions topsnf <+> "not an operator application") Mismatch)) + _ -> (topsnf, Left (whenClause opts "not an operator application" Mismatch)) +-- _ -> (topsnf, Left (whenClause opts (unsafeDocDisplayClosed unsafeOptions topsnf <+> "not an operator application") Mismatch)) in case leftnested of (tops, Left err) -> ((tops, tps), Left err) (tops, Right mtch) -> first (tops,) $ matches mtch ps tps - matches :: Matching -> [Pat] -> [Term] -> ([Term], Either Failure Matching) + matches :: Matching' m -> [Pat] -> [Term' m] -> ([Term' m], Either Failure (Matching' m)) matches mtch [] [] = ([], pure mtch) matches mtch (p:ps) (t:ts) = case match hnf mtch (Problem (localScope env) p t) of (t, Left err) -> (t:ts, Left err) @@ -269,7 +273,7 @@ data Frame | Spawnee (Interface Hole (Process () Status [])) | Spawner (Interface (Process () Status []) Hole) | Sent Channel (Maybe Guard) ([String], Term) - | Pushed Stack (DB, SyntaxDesc, Term) + | Pushed Stack (DB, ASemanticsDesc, Term) | Extended Operator Clause | Binding String | UnificationProblem Date Term Term diff --git a/Src/Machine/Trace.hs b/Src/Machine/Trace.hs index 85c6560..eb6ed66 100644 --- a/Src/Machine/Trace.hs +++ b/Src/Machine/Trace.hs @@ -27,6 +27,7 @@ import Operator.Eval import Options import Pretty import Syntax (SyntaxDesc, SyntaxTable, expand, VSyntaxDesc'(..), contract) +import Semantics (embed) import Term.Base import Unelaboration import Data.String (fromString) @@ -56,8 +57,8 @@ type instance ITERM Abstract = Term type instance ITERM Concrete = Raw data ARGUMENT (ph :: Phase) f ann = Argument - { argMode :: Mode () - , argDesc :: SyntaxDesc + { argMode :: Mode () + , argDesc :: ASemanticsDesc , argTerm :: f (ITERM ph) ann } @@ -86,7 +87,7 @@ instance Bifunctor f => Instantiable (AArgument f ann) where data STEP (ph :: Phase) f ann = BindingStep Variable | NotedStep - | PushingStep (STACK ph) (TERMVAR ph) (SyntaxDesc, f (ITERM ph) ann) + | PushingStep (STACK ph) (TERMVAR ph) (ASemanticsDesc, f (ITERM ph) ann) | CallingStep (f () (ann, Bool)) (JUDGEMENTNAME ph) [ARGUMENT ph f ann] deriving instance @@ -321,14 +322,14 @@ instance AnnotateLaTeX () where instance AnnotateLaTeX Int where annotateLaTeX n d = call False (fromString ("visible<" ++ show n ++ "->")) [d] -instance (LaTeX (f Raw ann), LaTeX.Format (f Raw ann) ~ SyntaxDesc) => +instance (LaTeX (f Raw ann), LaTeX.Format (f Raw ann) ~ ASemanticsDesc) => LaTeX (CArgument f ann) where type Format (CArgument f ann) = () toLaTeX _ (Argument m d t) = do t <- toLaTeX d t pure $ call False (fromString $ "typos" ++ show m) [t] -instance ( LaTeX (f Raw ann), LaTeX.Format (f Raw ann) ~ SyntaxDesc +instance ( LaTeX (f Raw ann), LaTeX.Format (f Raw ann) ~ ASemanticsDesc , LaTeX (f () (ann, Bool)), LaTeX.Format (f () (ann, Bool)) ~ ()) => LaTeX (CStep f ann) where type Format (CStep f ann) = () @@ -358,7 +359,7 @@ instance LaTeX CError where pure $ call False "typosStuckUnifying" [s, t] Failed s -> call False "typosFailed" . pure <$> toLaTeX () s -instance ( LaTeX (f Raw ann), LaTeX.Format (f Raw ann) ~ SyntaxDesc +instance ( LaTeX (f Raw ann), LaTeX.Format (f Raw ann) ~ ASemanticsDesc , LaTeX (f () (ann, Bool)), LaTeX.Format (f () (ann, Bool)) ~ () , AnnotateLaTeX ann) => LaTeX (CTrace f ann) where type Format (CTrace f ann) = () @@ -425,7 +426,7 @@ extract mkF a = go where _ -> go fs toArgument :: AProtocolEntry -> Term -> AArgument f ann - toArgument (Subject desc, _) term = Argument (Subject ()) desc (mkF term a) + toArgument (Subject desc, _) term = Argument (Subject ()) (embed desc) (mkF term a) toArgument (Input, desc) term = Argument Input desc (mkF term a) toArgument (Output, desc) term = Argument Output desc (mkF term a) @@ -515,7 +516,7 @@ ldiagnostic :: SyntaxTable -> HeadUpData -> [Frame] -> String ldiagnostic table dat fs = let ats = cleanup $ extract Simple () fs in let iats = normalise dat ats in - ldiagnostic' standalone table fs iats + undefined --TODO!!!: ldiagnostic' standalone table fs iats adiagnostic :: SyntaxTable -> HeadUpData -> [Frame] -> Shots -> String adiagnostic table dat fs trs = @@ -532,7 +533,7 @@ adiagnostic table dat fs trs = -- with its position in the sorted array. fmap (\ i -> fromMaybe (error "Impossible") (elemIndex i as)) at -- we can now render the beamer - in ldiagnostic' beamer table fs res + in undefined -- TODO!!!: ldiagnostic' beamer table fs res data LaTeXConfig = LaTeXConfig { documentClass :: String @@ -559,7 +560,7 @@ beamer = LaTeXConfig ldiagnostic' :: AnnotateLaTeX ann => Bitraversable f => LaTeX (f Raw ann) - => LaTeX.Format (f Raw ann) ~ SyntaxDesc + => LaTeX.Format (f Raw ann) ~ ASemanticsDesc => LaTeX (f () (ann, Bool)) => LaTeX.Format (f () (ann, Bool)) ~ () => LaTeXConfig diff --git a/Src/Main.hs b/Src/Main.hs index 107a9ac..4fee631 100644 --- a/Src/Main.hs +++ b/Src/Main.hs @@ -21,6 +21,7 @@ import Pretty import Term.Base import Options import Command +import Operator.Eval import Machine.Trace (diagnostic, ldiagnostic, adiagnostic) import Utils import Location @@ -36,7 +37,7 @@ main = do ".md" -> pmarkdown _ -> pfile let ccs = parse parser (Source txt $ initLocation (filename opts)) - case elaborate ccs of + case elaborate opts ccs of Left err -> do ctxt <- if noContext opts then pure "" else fileContext (getRange err) putStrLn $ renderWith (renderOptions opts) $ fold @@ -54,8 +55,10 @@ main = do let p = Process opts B0 initRoot (initEnv B0) initStore (Win unknown) [] initRoot let res@(Process _ fs _ env sto a _ geas) = run opts p acs + let whatIs m = Map.lookup m (solutions sto) >>= snd + -- TODO: eventually need to be more careful about the operators due to local extensions - let dat = HeadUpData (mkOpTable (B0 <>< fs)) sto (opts {quiet = True}) env + let dat = HeadUpData (mkOpTable (B0 <>< fs)) sto (opts {quiet = True}) env whatIs -- run diagnostics let (win, trace) = diagnostic opts dat fs From 2707475cea26de4074b645058cf80946bb3a8d8b Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Thu, 2 Feb 2023 17:36:44 +0000 Subject: [PATCH 36/89] [ broken ] DefnOp, and its telescopic nature, is hard --- Src/Command.hs | 51 +++++--- Src/Elaboration.hs | 241 +++++++++++++++++++++++++++----------- Src/Elaboration/Monad.hs | 32 +++++ Src/Elaboration/Pretty.hs | 2 + Src/Operator.hs | 4 +- Src/Pattern.hs | 4 +- 6 files changed, 244 insertions(+), 90 deletions(-) diff --git a/Src/Command.hs b/Src/Command.hs index 5b94794..0d353d8 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -208,7 +208,7 @@ pcommand <* pspc <*> pconditions <|> Go <$ plit "exec" <* pspc <*> pACT <|> Trace <$ plit "trace" <* pspc <*> pcurlies (psep (punc ",") pmachinestep) --- TODO <|> DeclOp <$ plit "operator" <* pspc <*> pcurlies (psep (punc ";") (panoperator "~>")) + <|> DeclOp <$ plit "operator" <* pspc <*> pcurlies (psep (punc ";") panoperator) <|> DefnOp <$> pdefnop <|> DeclJudgementForm <$> pjudgementform <|> DeclRule <$> prule @@ -265,7 +265,6 @@ globals = (,) <$> asks declarations <*> asks operators setGlobals :: Globals -> Context -> Context setGlobals (decls, ops) = setDecls decls . setOperators ops -{- sdeclOps :: [CAnOperator] -> Elab ([AAnOperator], Globals) sdeclOps [] = ([],) <$> asks globals sdeclOps ((AnOperator (WithRange r opname) (objName, objDesc) paramDescs retDesc) : ops) = do @@ -279,16 +278,17 @@ sdeclOps ((AnOperator (WithRange r opname) (objName, objDesc) paramDescs retDesc Nothing -> pure (Nothing, Unused) Just objName -> do objName <- isFresh objName - pure (Just objName , Used objName) - (descPat, objDesc, ds) <- spatSemantics (atom "Semantics" 0) objDesc + pure (Just (ActorMeta ACitizen objName) , Used objName) ovs <- asks objVars + (descPat, ds, objDesc) <- spatSemantics (atom "Semantics" 0) (initRestriction ovs) objDesc local (declare objBinder (ActVar IsNotSubject (ovs :=> objDesc)) . setDecls ds) $ do (paramDescs, ds) <- sparamdescs paramDescs - retDesc <- local (setDecls ds) $ ssemanticsdesc retDesc - let op = AnOperator opname objDesc paramDescs retDesc + retDesc <- local (setDecls ds) $ do + ovs <- asks objVars + (ovs :=>) <$> ssemanticsdesc retDesc + let op = AnOperator opname (objName, descPat) paramDescs retDesc (ops, decls) <- local (addOperator op) $ sdeclOps ops pure (op : ops, decls) --} scommand :: CCommand -> Elab (ACommand, Globals) scommand = \case @@ -331,14 +331,23 @@ scommand = \case (ContractStack pres (stk, lhs, rhs) posts,) <$> asks globals Go a -> during ExecElaboration $ (,) . Go <$> local (setElabMode Execution) (sact a) <*> asks globals Trace ts -> (Trace ts,) <$> asks globals -{- DeclOp ops -> first DeclOp <$> sdeclOps ops - DefnOp (p, opargs, rhs) -> do + + + -- Sig S \x.T - 'fst ~> S + -- (p : Sig S \x.T) - 'snd ~> {x=[ p - 'fst ]}T + + DefnOp (p, opelims, rhs) -> do + ovs <- asks objVars + let scp = scopeSize ovs + -- p -[ opelim0 ] -[ opelim1 ] ... -[ opelimn ] ~> rhs ((p, opargs), ret, decls, hints) <- do -- this is the op applied to the object, not the outer op being extended - let op = fst (head opargs) - (AnOperator op obj _ ret) <- soperator op - (mr1, p, decls, hints) <- spat (Term unknown obj) p + let op = fst (head opelims) + (AnOperator op (mb, opat{-, odesc-}) pdescs rdesc) <- soperator op + let rest = initRestriction ovs + (opat, decls, otm) <- spatSemantics (atom "Semantics" scp) rest opat + (mr1, p, decls, hints) <- spat (Term unknown otm) rest p (opargs, decls, hints) <- local (setDecls decls . setHints hints) $ sopargs obj opargs pure ((p, opargs), ret, decls, hints) @@ -348,10 +357,16 @@ scommand = \case -- trace (unwords [getOperator op, "-[", '\'':show p, show opargs, "~>", show rhs]) (pure ()) let cl = Clause (toClause p (B0 <>< opargs) rhs) (DefnOp (op, cl),) <$> asks globals - DeclJudgementForm j -> do - (j , gs) <- sjudgementform j - pure (DeclJudgementForm j, gs) --} + + + + + + + +-- DeclJudgementForm j -> do +-- (j , gs) <- sjudgementform j +-- pure (DeclJudgementForm j, gs) checkCompatiblePlaces :: [PLACE Concrete] -> [(Variable, ASemanticsDesc)] -> @@ -445,6 +460,7 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do | Var _ x <- objDesc op , Just syn <- Map.lookup x m = pure (op { objDesc = syn}) | otherwise = throwError (MalformedPostOperator (getRange (objDesc op)) (theValue (opName op)) (Map.keys m)) +-} -- | sopargs desc cops -- | desc: description of the object the cops are applied to @@ -474,8 +490,7 @@ soperator (WithRange r tag) = do ops <- asks operators case Map.lookup tag ops of Nothing -> throwError (NotAValidOperator r tag) - Just (obj, params, ret) -> pure (AnOperator (Operator tag) obj params ret) --} + Just anop -> pure anop scommands :: [CCommand] -> Elab [ACommand] scommands [] = pure [] diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index a1d71c5..b3073a2 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -186,8 +186,8 @@ ssbst usage (sg :< sgc) = case sgc of pure (sbstT sg ((Hide v :=) $^ t), ovs <: ObjVar v (Known desc)) -} -sth :: Bwd String -> (Bwd Variable, ThDirective) -> Elab Th -sth ovs (xz, b) = do +sth :: Restriction -> (Bwd Variable, ThDirective) -> Elab Th +sth (Restriction ovs th) (xz, b) = do let th = which (`elem` (getVariable <$> xz)) ovs pure $ case b of ThKeep -> th @@ -242,33 +242,123 @@ sscrutinee (Term r t) = during (ScrutineeTermElaboration t) $ do -- TODO: change "Maybe" to "Binder" in Anoperator -sparamdescs :: [(Maybe Variable, Raw)] -> Elab ([(Maybe ActorVar, ASOT)], Decls) +sparamdescs :: [(Maybe Variable, Raw)] -> Elab ([(Maybe ActorMeta, ASOT)], Decls) sparamdescs [] = ([],) <$> asks declarations sparamdescs ((mx , ty):ps) = do (mx, binder) <- case mx of Nothing -> pure (Nothing, Unused) Just x -> do x <- isFresh x - pure (Just x , Used x) + pure (Just (ActorMeta ACitizen x) , Used x) ovs <- asks objVars ty <- ssemanticsdesc ty let sty = ovs :=> ty (ps, ds) <- local (declare binder (ActVar IsNotSubject sty)) $ sparamdescs ps pure ((mx , sty):ps, ds) +spatSemantics :: ASemanticsDesc -> Restriction -> CPattern -> + Elab (APattern, Decls, ACTm) +spatSemantics desc rest (Irrefutable r p) = do + raiseWarning (IgnoredIrrefutable r p) + spatSemantics desc rest p +spatSemantics desc rest (AsP r v p) = do + v <- isFresh v + ds <- asks declarations + (ovs, asot) <- thickenedASOT (restriction rest) desc + (p, ds, t) <- + local (setDecls (ds :< (v, ActVar IsNotSubject asot))) $ spatSemantics desc rest p + pure (AT (ActorMeta ACitizen v) p, ds, t) +spatSemantics desc rest (ThP r ph p) = do + ph <- sth rest ph + (p, ds, t) <- spatSemantics desc (ph ^? rest) p + pure (p *^ ph, ds, t *^ ph) +spatSemantics desc rest (UnderscoreP r) = do + ds <- asks declarations + let hack = Variable r ("_" ++ show (length ds)) + spatSemantics desc rest (VarP r hack) +spatSemantics desc rest (VarP r v) = during (PatternVariableElaboration v) $ do + ds <- asks declarations + res <- resolve v + let th = restriction rest + let scp = weeEnd th + case res of + Just (AnObjVar desc' i) -> do + i <- case thickx th i of -- TODO: do we need to check whether desc' is thickenable? + Nothing -> throwError (OutOfScope r v) + Just i -> pure i + compatibleInfos (getRange v) (Known desc) (Known desc') + pure (VP i, ds, var i scp) + Just mk -> throwError (NotAValidPatternVariable r v mk) + Nothing -> do + (ovs, asot) <- thickenedASOT th desc + v <- pure (getVariable v) + let pat = MP (ActorMeta ACitizen v) (ones scp) + pure (pat, ds :< (v, ActVar IsNotSubject asot), ActorMeta ACitizen v $: sbstI scp) +spatSemantics desc rest rp = do + table <- gets syntaxCats + dat <- asks headUpData + ds <- asks declarations + case Semantics.expand table dat desc of + Nothing -> throwError (InvalidSemanticsDesc (getRange rp) desc) + Just vdesc -> case rp of + AtP r a -> do + case vdesc of + VAtom _ -> pure () + VAtomBar _ as -> when (a `elem` as) $ throwError (GotBarredAtom r a as) + VNil _ -> unless (a == "") $ throwError (ExpectedNilGot r a) + VNilOrCons{} -> unless (a == "") $ throwError (ExpectedNilGot r a) + VEnumOrTag sc es _ -> unless (a `elem` es) $ throwError (ExpectedEnumGot r es a) + VWildcard sc -> pure () + _ -> throwError (SyntaxPError r desc rp) + pure (AP a, ds, atom a (weeEnd (restriction rest))) + ConsP r p1 p2 -> do + descs <- case vdesc of + VNilOrCons d1 d2 -> pure (Left (d1, d2)) + VCons d1 d2 -> pure (Left (d1, d2)) + VWildcard _ -> pure (Left (desc, desc)) + VEnumOrTag _ _ ds -> pure (Right ds) + _ -> throwError (SyntaxPError r desc rp) + case descs of + Left (d1, d2) -> do + (p1, ds, t1) <- spatSemantics d1 rest p1 + (p2, ds, t2) <- local (setDecls ds) (spatSemantics d2 rest p2) + pure (PP p1 p2, ds, t1 % t2) + Right ds -> case p1 of + AtP r a -> case lookup a ds of + Nothing -> throwError (ExpectedTagGot r (fst <$> ds) a) + Just descs -> do + (p1, ds, t1) <- spatSemantics (atom "Atom" 0) rest p1 + (p2, ds, t2) <- local (setDecls ds) (spatSemanticss descs rest p2) + pure (PP p1 p2, ds, t1 % t2) + _ -> throwError (SyntaxPError r desc rp) -spatSemantics :: ASemanticsDesc -> CPattern -> Elab (APattern, ASemanticsDesc, Decls) -spatSemantics = undefined -{- -spatSemantics ty (AsP r v p) = _ -spatSemantics ty (VarP r v) = _ -spatSemantics ty (AtP r a) = _ -spatSemantics ty (ConsP r p1 p2) = _ -spatSemantics ty (LamP r p) = _ -spatSemantics ty (ThP r th p) = _ -spatSemantics ty (UnderscoreP r) = _ -spatSemantics ty (Irrefutable r p) = _ --} + LamP r (Scope v@(Hide x) p) -> do + (s, desc) <- case vdesc of + VWildcard _ -> pure (desc, desc) + VBind cat desc -> pure (Semantics.catToDesc cat, desc) + _ -> throwError (SyntaxPError r desc rp) + + case x of + Unused -> do + (p, ds, t) <- spatSemantics desc rest p + pure (BP (Hide "_") p, ds, (Hide "_" := False :.) $^ t) + Used x -> do + x <- isFresh x + (p, ds, t) <- local (declareObjVar (x, s)) $ spatSemantics desc (extend rest x) p + pure (BP (Hide x) p, ds, x \\ t) + +spatSemanticss :: [ASemanticsDesc] + -> Restriction + -> RawP + -> Elab (Pat, Decls, ACTm) +spatSemanticss [] rest (AtP r "") = (AP "",, atom "" (weeEnd (restriction rest))) <$> asks declarations +spatSemanticss [] rest (AtP r a) = throwError (ExpectedNilGot r a) +spatSemanticss [] rest t = throwError (ExpectedANilPGot (getRange t) t) +spatSemanticss (d:ds) rest (ConsP r p ps) = do + (p, decls, t) <- spatSemantics d rest p + (ps, decls, ts) <- local (setDecls decls) $ spatSemanticss ds rest ps + pure (PP p ps, decls, t % ts) +spatSemanticss _ rest t = throwError (ExpectedAConsPGot (getRange t) t) isList :: Raw -> Elab [Raw] isList (At r "") = pure [] @@ -395,15 +485,15 @@ stm usage desc rt = do pure t -spats :: IsSubject -> [ASemanticsDesc] -> (Bwd String, Th) -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) -spats _ [] (ls, th) (AtP r "") = (Nothing, AP "",,) <$> asks declarations <*> asks binderHints -spats _ [] (ls, th) (AtP r a) = throwError (ExpectedNilGot r a) -spats _ [] (ls, th) t = throwError (ExpectedANilPGot (getRange t) t) -spats isSub (d:ds) (ls, th) (ConsP r p q) = do - (mr1, p, decls, hints) <- spatBase isSub d (ls, th) p - (mr2, q, decls, hints) <- local (setDecls decls . setHints hints) $ spats isSub ds (ls, th) q +spats :: IsSubject -> [ASemanticsDesc] -> Restriction -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) +spats _ [] rest (AtP r "") = (Nothing, AP "",,) <$> asks declarations <*> asks binderHints +spats _ [] rest (AtP r a) = throwError (ExpectedNilGot r a) +spats _ [] rest t = throwError (ExpectedANilPGot (getRange t) t) +spats isSub (d:ds) rest (ConsP r p q) = do + (mr1, p, decls, hints) <- spatBase isSub d rest p + (mr2, q, decls, hints) <- local (setDecls decls . setHints hints) $ spats isSub ds rest q pure (mr1 <|> mr2, PP p q, decls, hints) -spats _ _ (ls, th) t = throwError (ExpectedAConsPGot (getRange t) t) +spats _ _ rest t = throwError (ExpectedAConsPGot (getRange t) t) -- Inputs: -- 0. Elaborated scrutinee -- description of how the scrutinee we are @@ -416,76 +506,87 @@ spats _ _ (ls, th) t = throwError (ExpectedAConsPGot (getRange t) t) -- 1. Elaborated pattern -- 2. Bound variables (together with their syntactic categories) -- 3. Binder hints introduced by \x. patterns -spat :: EScrutinee -> (Bwd String, Th) -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) -spat esc (ls, th) rp@(AsP r v p) = do +spat :: EScrutinee -> Restriction -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) +spat esc rest rp@(AsP r v p) = do unless (isSubjectFree esc) $ throwError (AsPatternCannotHaveSubjects r rp) let desc = escrutinee esc v <- isFresh v ds <- asks declarations - ovs <- asks objVars - (mr, p, ds, hs) <- local (setDecls (ds :< (v, ActVar IsNotSubject (ovs :=> desc)))) $ spat esc (ls, th) p + (ovs, asot) <- thickenedASOT (restriction rest) desc + (mr, p, ds, hs) <- local (setDecls (ds :< (v, ActVar IsNotSubject asot))) $ spat esc rest p pure (mr, AT (ActorMeta ACitizen v) p, ds, hs) -spat esc (ls, th) p@VarP{} = spatBase (Pattern <$ isSubject esc) (escrutinee esc) (ls, th) p -spat esc (ls, th) (ThP r ph p) = do - ph <- sth ls ph - (mr, p, ds, hs) <- spat esc (ph ^? ls, ph ^? th) p +spat esc rest p@VarP{} = spatBase (Pattern <$ isSubject esc) (escrutinee esc) rest p +spat esc rest (ThP r ph p) = do + ph <- sth rest ph + (mr, p, ds, hs) <- spat esc (ph ^? rest) p pure (mr, p *^ ph, ds, hs) -spat esc (ls, th) p@(UnderscoreP r) = do - (_, p, ds, hs) <- spatBase (Pattern <$ isSubject esc) (escrutinee esc) (ls, th) p +spat esc rest p@(UnderscoreP r) = do + (_, p, ds, hs) <- spatBase (Pattern <$ isSubject esc) (escrutinee esc) rest p let mr = r <$ guard (not (isSubjectFree esc)) pure (mr, p, ds, hs) -spat esc@(Pair r esc1 esc2) (ls, th) rp = case rp of +spat esc@(Pair r esc1 esc2) rest rp = case rp of ConsP r p q -> do - (mr1, p, ds, hs) <- spat esc1 (ls, th) p - (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spat esc2 (ls, th) q) + (mr1, p, ds, hs) <- spat esc1 rest p + (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spat esc2 rest q) pure (mr1 <|> mr2, PP p q, ds, hs) _ -> throwError (SyntaxPError (getRange rp) (escrutinee esc) rp) -spat (SubjectVar r desc) (ls, th) rp = spatBase (IsSubject Pattern) desc (ls, th) rp -spat esc@(Lookup _ _ av) (ls, th) rp@(ConsP r (AtP _ "Just") (ConsP _ _ (AtP _ ""))) = do +spat (SubjectVar r desc) rest rp = spatBase (IsSubject Pattern) desc rest rp +spat esc@(Lookup _ _ av) rest rp@(ConsP r (AtP _ "Just") (ConsP _ _ (AtP _ ""))) = do logUsage av (SuccessfullyLookedUp r) - spatBase IsNotSubject (escrutinee esc) (ls, th) rp -spat esc@(Lookup _ _ av) (ls, th) rp = spatBase IsNotSubject (escrutinee esc) (ls, th) rp -spat esc@(Compare{}) (ls, th) rp = spatBase IsNotSubject (escrutinee esc) (ls, th) rp -spat esc@(Term{}) (ls, th) rp = spatBase IsNotSubject (escrutinee esc) (ls, th) rp + spatBase IsNotSubject (escrutinee esc) rest rp +spat esc@(Lookup _ _ av) rest rp = spatBase IsNotSubject (escrutinee esc) rest rp +spat esc@(Compare{}) rest rp = spatBase IsNotSubject (escrutinee esc) rest rp +spat esc@(Term{}) rest rp = spatBase IsNotSubject (escrutinee esc) rest rp -spatBase :: IsSubject -> ASemanticsDesc -> (Bwd String, Th) -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) -spatBase isSub desc (ls, th) rp@(AsP r v p) = do +thickenedASOT :: Th -> ASemanticsDesc -> Elab (ObjVars, ASOT) +thickenedASOT th desc = do + ovs <- asks objVars + ovs <- case thickenObjVars th ovs of + Nothing -> throwError (NotAValidContextRestriction th ovs) + Just ovs -> pure ovs + desc <- case thickenCdB th desc of + Nothing -> throwError (NotAValidDescriptionRestriction th desc) + Just desc -> pure desc + pure (ovs, ovs :=> desc) + +spatBase :: IsSubject -> ASemanticsDesc -> Restriction -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) +spatBase isSub desc rest rp@(AsP r v p) = do unless (isSub == IsNotSubject) $ throwError (AsPatternCannotHaveSubjects r rp) v <- isFresh v ds <- asks declarations - ovs <- asks objVars - (mr, p, ds, hs) <- local (setDecls (ds :< (v, ActVar isSub (ovs :=> desc)))) $ spatBase isSub desc (ls, th) p + (ovs, asot) <- thickenedASOT (restriction rest) desc + (mr, p, ds, hs) <- local (setDecls (ds :< (v, ActVar isSub asot))) $ spatBase isSub desc rest p pure (mr, AT (ActorMeta ACitizen v) p, ds, hs) -spatBase isSub desc (ls, th) (ThP r ph p) = do - ph <- sth ls ph - (mr, p, ds, hs) <- spatBase isSub desc (ph ^? ls, ph ^? th) p +spatBase isSub desc rest (ThP r ph p) = do + ph <- sth rest ph + (mr, p, ds, hs) <- spatBase isSub desc (ph ^? rest) p pure (mr, p *^ ph, ds, hs) -spatBase isSub desc (ls, th) (VarP r v) = during (PatternVariableElaboration v) $ do - -- table <- gets syntaxCats +spatBase isSub desc rest (VarP r v) = during (PatternVariableElaboration v) $ do ds <- asks declarations hs <- asks binderHints res <- resolve v + let th = restriction rest case res of Just (AnObjVar desc' i) -> do - i <- case thickx th i of + i <- case thickx th i of -- TODO: do we need to check whether desc' is thickenable? Nothing -> throwError (OutOfScope r v) Just i -> pure i compatibleInfos (getRange v) (Known desc) (Known desc') pure (Nothing, VP i, ds, hs) Just mk -> throwError (NotAValidPatternVariable r v mk) Nothing -> do - ovs <- asks objVars + (ovs, asot) <- thickenedASOT th desc v <- pure (getVariable v) let pat = MP (ActorMeta (spassport (Scrutinised unknown) isSub) v) (ones $ scopeSize ovs) - pure (Nothing, pat, ds :< (v, ActVar isSub (ovs :=> desc)), hs) -spatBase isSub desc (ls, th) (UnderscoreP r) = do + pure (Nothing, pat, ds :< (v, ActVar isSub asot), hs) +spatBase isSub desc rest (UnderscoreP r) = do let mr = case isSub of IsSubject{} -> Just r IsNotSubject -> Nothing (mr,HP,,) <$> asks declarations <*> asks binderHints -spatBase isSub desc (ls, th) rp = do +spatBase isSub desc rest rp = do table <- gets syntaxCats dat <- asks headUpData case Semantics.expand table dat desc of @@ -504,23 +605,23 @@ spatBase isSub desc (ls, th) rp = do ConsP r p q -> case vdesc of VNilOrCons d1 d2 -> do - (mr1, p, ds, hs) <- spatBase isSub d1 (ls, th) p - (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spatBase isSub d2 (ls, th) q) + (mr1, p, ds, hs) <- spatBase isSub d1 rest p + (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spatBase isSub d2 rest q) pure (mr1 <|> mr2, PP p q, ds, hs) VCons d1 d2 -> do - (mr1, p, ds, hs) <- spatBase isSub d1 (ls, th) p - (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spatBase isSub d2 (ls, th) q) + (mr1, p, ds, hs) <- spatBase isSub d1 rest p + (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spatBase isSub d2 rest q) pure (mr1 <|> mr2, PP p q, ds, hs) VWildcard _ -> do - (mr1, p, ds, hs) <- spatBase isSub desc (ls, th) p - (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spatBase isSub desc (ls, th) q) + (mr1, p, ds, hs) <- spatBase isSub desc rest p + (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spatBase isSub desc rest q) pure (mr1 <|> mr2, PP p q, ds, hs) VEnumOrTag _ _ ds -> case p of AtP r a -> case lookup a ds of Nothing -> throwError (ExpectedTagGot r (fst <$> ds) a) Just descs -> do - (mr1, p, ds, hs) <- spatBase isSub (atom "Atom" 0) (ls, th) p - (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spats isSub descs (ls, th) q) + (mr1, p, ds, hs) <- spatBase isSub (atom "Atom" 0) rest p + (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spats isSub descs rest q) pure (mr1 <|> mr2, PP p q, ds, hs) _ -> throwError (SyntaxPError r desc rp) _ -> throwError (SyntaxPError r desc rp) @@ -533,11 +634,13 @@ spatBase isSub desc (ls, th) rp = do case x of Unused -> do - (mr, p, ds, hs) <- spatBase isSub desc (ls, th) p + (mr, p, ds, hs) <- spatBase isSub desc rest p pure (mr, BP (Hide "_") p, ds, hs) Used x -> do x <- isFresh x - (mr, p, ds, hs) <- local (declareObjVar (x, s) . addHint x (Known s)) $ spatBase isSub desc (ls :< x, th -? True) p + (mr, p, ds, hs) <- + local (declareObjVar (x, s) . addHint x (Known s)) $ + spatBase isSub desc (extend rest x) p pure (mr, BP (Hide x) p, ds, hs) isObjVar :: Variable -> Elab (ASemanticsDesc, DB) @@ -904,8 +1007,8 @@ sclause :: EScrutinee -> (RawP, CActor) -> sclause esc (rp, a) = do ds0 <- asks declarations avs <- lift $ gets actvarStates - ovs <- asks (fmap objVarName . getObjVars . objVars) - (mr, p, ds, hs) <- lift $ during (MatchBranchElaboration rp) $ spat esc (ovs, ones (length ovs)) rp + ovs <- asks objVars + (mr, p, ds, hs) <- lift $ during (MatchBranchElaboration rp) $ spat esc (initRestriction ovs) rp let pats = takez ds (length ds - length ds0) coverageCheckClause rp p (a, me) <- lift $ during (MatchBranchElaboration rp) $ diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index c4c807d..2c4bd83 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -201,6 +201,20 @@ data Context = Context type Hints = Map String (Info ASemanticsDesc) +data Restriction = Restriction + { support :: Bwd String + , restriction :: Th + } + +initRestriction :: ObjVars -> Restriction +initRestriction ovs = Restriction (objVarName <$> getObjVars ovs) (ones (scopeSize ovs)) + +extend :: Restriction -> String -> Restriction +extend (Restriction ls th) x = Restriction (ls :< x) (th -? True) + +instance Selable Restriction where + ph ^? Restriction ls th = Restriction (ph ^? ls) (ph ^? th) + data ElabMode = Definition | Execution deriving (Eq, Show) @@ -249,6 +263,18 @@ declareObjVar (x, sem) ctx setObjVars' :: ObjVars -> Context -> Context setObjVars' ovs ctx = ctx { objVars = ovs } +-- A Γ-context Δ gives Δ variables with Γ-types + +-- Thicken a context. It is the user's responsibility to +-- evict all variables whose type depends on other evicted +-- variables. +thickenObjVars :: Th -- Δ ≤ Γ + -> ObjVars -- Γ-context Γ + -> Maybe ObjVars -- Δ-context Δ +thickenObjVars th (ObjVars ga) = ObjVars <$> + let de = th ^? ga in + traverse (traverse (thickenCdB th)) de + {- setObjVars :: ObjVars -> Context -> Context setObjVars ovs ctx = ctx { objVars = ovs } @@ -327,6 +353,8 @@ data Warning | PatternSubjectNotScrutinised Range String | UnderscoreOnSubject Range | InconsistentScrutinisation Range + -- Missing features + | IgnoredIrrefutable Range RawP instance HasGetRange Warning where getRange = \case @@ -338,6 +366,8 @@ instance HasGetRange Warning where PatternSubjectNotScrutinised r _ -> r UnderscoreOnSubject r -> r InconsistentScrutinisation r -> r + -- Missing features + IgnoredIrrefutable r _ -> r raiseWarning :: Warning -> Elab () raiseWarning w = do @@ -395,6 +425,8 @@ data Complaint | EmptyContext Range | NotTopVariable Range Variable Variable | IncompatibleChannelScopes Range ObjVars ObjVars + | NotAValidContextRestriction Th ObjVars + | NotAValidDescriptionRestriction Th ASemanticsDesc -- kinding | NotAValidTermVariable Range Variable Kind | NotAValidPatternVariable Range Variable Resolved diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index dd50cb6..af6dd00 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -75,6 +75,8 @@ instance Pretty Warning where PatternSubjectNotScrutinised r x -> hsep ["Pattern subject", pretty x, "did not get scrutinised"] UnderscoreOnSubject r -> hsep ["Subject pattern thrown away using an underscore"] InconsistentScrutinisation r -> hsep ["Inconsistent scrutinisation of subject in match"] + -- Missing feature + IgnoredIrrefutable r p -> hsep ["TODO: actually implement irrefutable patterns (", pretty p, ")"] instance Pretty ContextualInfo where pretty = \case diff --git a/Src/Operator.hs b/Src/Operator.hs index c018678..d4beacf 100644 --- a/Src/Operator.hs +++ b/Src/Operator.hs @@ -33,7 +33,7 @@ import Pretty data ObjVar' a = ObjVar { objVarName :: String , objVarDesc :: a - } deriving (Functor, Show, Eq) + } deriving (Functor, Foldable, Traversable, Show, Eq) type ObjVar = ObjVar' ASemanticsDesc @@ -83,7 +83,7 @@ infix 2 :=> data ANOPERATOR (ph :: Phase) = AnOperator { opName :: OPERATOR ph - , objDesc :: (Maybe (ACTORVAR ph), PATTERN ph) + , objDesc :: (Maybe (ACTORVAR ph), PATTERN ph) -- add ([ACTORVar ph], TERM ph)? , paramsDesc :: [(Maybe (ACTORVAR ph), SOT ph)] , retDesc :: SOT ph } diff --git a/Src/Pattern.hs b/Src/Pattern.hs index 4349c59..4e8f5d8 100644 --- a/Src/Pattern.hs +++ b/Src/Pattern.hs @@ -12,8 +12,10 @@ import Concrete.Base (Root) import Term.Base -- patterns are de Bruijn +-- | Abstract Patterns, generic over the notion of +-- | binding site data Pat' s - = AT s (Pat' s) + = AT s (Pat' s) -- v@p | VP DB | AP String | PP (Pat' s) (Pat' s) From cdabccba2cf86e776fcd6406854364a81578c9f6 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 7 Feb 2023 15:41:11 +0000 Subject: [PATCH 37/89] [ done ] fixing sdeclOps --- Src/Command.hs | 34 +++++++++++------- Src/Elaboration.hs | 77 ++++++++++++++++++++++++---------------- Src/Elaboration/Monad.hs | 2 +- Src/Operator.hs | 22 +++++++----- 4 files changed, 83 insertions(+), 52 deletions(-) diff --git a/Src/Command.hs b/Src/Command.hs index 0d353d8..a72e765 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -267,7 +267,16 @@ setGlobals (decls, ops) = setDecls decls . setOperators ops sdeclOps :: [CAnOperator] -> Elab ([AAnOperator], Globals) sdeclOps [] = ([],) <$> asks globals -sdeclOps ((AnOperator (WithRange r opname) (objName, objDesc) paramDescs retDesc) : ops) = do +-- (objName : objDescPat) -[ opname (p0 : paramDesc0) ... ] : retDesc +-- e.g. +-- 1. (p : ['Sig a \x.b]) -[ 'snd ] : {x = p -[ 'fst ]} b +-- 2. (f : ['Pi a \x.b]) -[ 'app (t : a) ] : {x = t} b +-- 3. (n : 'Nat) +-- -[ 'rec ('Nat\m. p : 'Semantics) +-- ( pZ : {m = 'Zero} p) +-- ('Nat\m. {m}p\ih. pS : {m = ['Succ m]} p) +-- ] : {m = n} p +sdeclOps ((AnOperator (objName, objDescPat) (WithRange r opname) paramDescs retDesc) : ops) = do opname <- do ctxt <- ask when (Map.member opname (operators ctxt)) $ @@ -278,17 +287,17 @@ sdeclOps ((AnOperator (WithRange r opname) (objName, objDesc) paramDescs retDesc Nothing -> pure (Nothing, Unused) Just objName -> do objName <- isFresh objName - pure (Just (ActorMeta ACitizen objName) , Used objName) + pure (Just (ActorMeta ACitizen objName), Used objName) ovs <- asks objVars - (descPat, ds, objDesc) <- spatSemantics (atom "Semantics" 0) (initRestriction ovs) objDesc - local (declare objBinder (ActVar IsNotSubject (ovs :=> objDesc)) . setDecls ds) $ do + sem <- satom "Semantics" + (descPat, ds, objDesc) <- spatSemantics sem (initRestriction ovs) objDescPat + op <- local (declare objBinder (ActVar IsNotSubject (ovs :=> objDesc)) . setDecls ds) $ do (paramDescs, ds) <- sparamdescs paramDescs - retDesc <- local (setDecls ds) $ do - ovs <- asks objVars - (ovs :=>) <$> ssemanticsdesc retDesc - let op = AnOperator opname (objName, descPat) paramDescs retDesc - (ops, decls) <- local (addOperator op) $ sdeclOps ops - pure (op : ops, decls) + retDesc <- local (setDecls ds) $ sty retDesc + pure $ AnOperator (objName, descPat) opname paramDescs retDesc + -- Process the rest of the declarations, in the original context + (ops, decls) <- local (addOperator op) $ sdeclOps ops + pure (op : ops, decls) scommand :: CCommand -> Elab (ACommand, Globals) scommand = \case @@ -337,6 +346,7 @@ scommand = \case -- Sig S \x.T - 'fst ~> S -- (p : Sig S \x.T) - 'snd ~> {x=[ p - 'fst ]}T +{- DefnOp (p, opelims, rhs) -> do ovs <- asks objVars let scp = scopeSize ovs @@ -357,7 +367,7 @@ scommand = \case -- trace (unwords [getOperator op, "-[", '\'':show p, show opargs, "~>", show rhs]) (pure ()) let cl = Clause (toClause p (B0 <>< opargs) rhs) (DefnOp (op, cl),) <$> asks globals - +-} @@ -467,7 +477,7 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do sopargs :: SyntaxDesc -> [COpPattern] -> Elab ([AOpPattern], Decls, Hints) sopargs desc [] = ([],,) <$> asks declarations <*> asks binderHints sopargs desc ((rop, args):xs) = do - (AnOperator op obj ps ret) <- soperator rop + (AnOperator obj op ps ret) <- soperator rop compatibleInfos (theRange rop) (Known desc) (Known obj) (args, decls, hints) <- splat (getRange rop <> foldMap getRange args) ps args (rest, decls, hints) <- local (setDecls decls . setHints hints) $ sopargs ret xs diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index b3073a2..23b17fa 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -139,14 +139,6 @@ ssyntaxdesc syndecls syn = do Nothing -> error "Impossible in ssyntaxdesc" -- this should be impossible, since parsed in empty context Just syn0 -> pure syn0 -ssemanticsdesc :: CSemanticsDesc -> Elab ASemanticsDesc -ssemanticsdesc sem = do - syndecls <- gets (Map.keys . syntaxCats) - syndesc <- ssyntaxdesc ("Semantics":syndecls) sem - pure . embed $ syndesc - -- TODO: use stm to actually be able to use operators & actor vars - -- DontLog (catToDesc "Semantics") - ssbst :: Usage -> Bwd SbstC -> Elab (ACTSbst, ObjVars) ssbst usage B0 = do ovs <- asks objVars @@ -241,25 +233,38 @@ sscrutinee (Term r t) = during (ScrutineeTermElaboration t) $ do pure (Term r desc, Term r t) --- TODO: change "Maybe" to "Binder" in Anoperator -sparamdescs :: [(Maybe Variable, Raw)] -> Elab ([(Maybe ActorMeta, ASOT)], Decls) +satom :: String -> Elab ACTm +satom at = atom at <$> asks (scopeSize . objVars) + +sty :: CSemanticsDesc -> Elab ASemanticsDesc +sty t = do + sem <- satom "Semantics" + stm DontLog sem t + +ssot :: SOT 'Concrete -> Elab ASOT +ssot ([], ty) = (:=>) <$> asks objVars <*> sty ty +ssot ((desc, x) : xs, ty) = do + desc <- sty desc + x <- isFresh x + local (declareObjVar (x, desc)) $ ssot (xs, ty) + +sparamdescs :: [(Maybe Variable, ([(Raw, Variable)], Raw))] + -> Elab ([(Maybe ActorMeta, ASOT)], Decls) sparamdescs [] = ([],) <$> asks declarations -sparamdescs ((mx , ty):ps) = do +sparamdescs ((mx , sot):ps) = do + sot <- ssot sot (mx, binder) <- case mx of Nothing -> pure (Nothing, Unused) Just x -> do x <- isFresh x pure (Just (ActorMeta ACitizen x) , Used x) - ovs <- asks objVars - ty <- ssemanticsdesc ty - let sty = ovs :=> ty - (ps, ds) <- local (declare binder (ActVar IsNotSubject sty)) $ sparamdescs ps - pure ((mx , sty):ps, ds) + (ps, ds) <- local (declare binder (ActVar IsNotSubject sot)) $ sparamdescs ps + pure ((mx , sot):ps, ds) spatSemantics :: ASemanticsDesc -> Restriction -> CPattern -> Elab (APattern, Decls, ACTm) spatSemantics desc rest (Irrefutable r p) = do - raiseWarning (IgnoredIrrefutable r p) + raiseWarning (IgnoredIrrefutable r p) -- TODO spatSemantics desc rest p spatSemantics desc rest (AsP r v p) = do v <- isFresh v @@ -394,7 +399,7 @@ itm usage (Op r rs ro) = do Just v -> pure $ newActorVar v (localScope env <>> [], s) env pure dat{huEnv = env} local (setHeadUpData dat) $ do - (desc, ps) <- itms r usage paramsDesc rps retDesc + (desc, ps) <- undefined -- TODO (was: itms r usage paramsDesc rps retDesc) let o = case ps of [] -> atom (getOperator opName) (scope s) _ -> getOperator opName #%+ ps @@ -403,10 +408,19 @@ itm usage (Op r rs ro) = do itm _ t = throwError $ DontKnowHowToInferDesc (getRange t) t -itms :: Range -> Usage -> [(Maybe ActorMeta, ASOT)] -> [Raw] -> ASOT -> Elab (ASemanticsDesc, [ACTm]) -itms r usage [] [] rdesc = (, []) <$> sasot r rdesc +itms :: Range -> Usage + -- Parameters types e.g. (_ : 'Nat\n. {m = n}p\ih. {m = ['Succ n]}p) + -> [(Maybe ActorMeta, ASOT)] + -- Raw parameters + -> [Raw] + -- Return type as a SOT -- TODO: come back once we have DeclOps + -> ASOT + -- + -> Elab (ASemanticsDesc -- Inferred return type (instantiated ^SOT) + , [ACTm]) -- Elaborated parameters +itms r usage [] [] rdesc = undefined -- TODO (was: (, []) <$> sasot r rdesc) itms r usage ((binder, asot):bs) (rp:rps) rdesc = do - pdesc <- sasot (getRange rp) asot + pdesc <- undefined -- TODO (was: sasot (getRange rp) asot) p <- stm usage pdesc rp dat <- do dat <- asks headUpData @@ -420,15 +434,18 @@ itms r usage ((binder, asot):bs) (rp:rps) rdesc = do fmap (p:) <$> itms r usage bs rps rdesc itms r usage bs rps rdesc = throwError $ ArityMismatchInOperator r +{- +sp is only for Concrete p to Abstract p + sasot :: Range -> ASOT -> Elab ASemanticsDesc sasot r (objVars :=> desc) = do dat <- asks headUpData - -- we hope that mangleActors will instantiate objVars in desc for us - -- TODO: restrict the env to the actual support + -- The object acted upon and the parameters appearing before the + -- one currently being elaborated need to be substituted into the SOT case mangleActors (huOptions dat) (huEnv dat) desc of Nothing -> throwError $ SchematicVariableNotInstantiated r - Just v -> pure v - + Just v -> pure v -- TODO: foldr (\ (x,t) v => ['Bind t \x.v]) id v +-} stm :: Usage -> ASemanticsDesc -> Raw -> Elab ACTm stm usage desc (Var r v) = during (TermVariableElaboration v) $ do @@ -455,7 +472,7 @@ stm usage desc rt = do VEnumOrTag _ es _ -> unless (a `elem` es) $ throwError (ExpectedEnumGot r es a) VWildcard _ -> pure () _ -> throwError (SemanticsError r desc rt) - atom a <$> asks (scopeSize . objVars) + satom a Cons r p q -> case vdesc of VNilOrCons d1 d2 -> (%) <$> stm usage d1 p <*> stm usage d2 q VCons d1 d2 -> (%) <$> stm usage d1 p <*> stm usage d2 q @@ -896,7 +913,7 @@ sact = \case FreshMeta r desc (av, a) -> do (desc, av, ovs) <- during FreshMetaElaboration $ do syndecls <- gets (Map.keys . syntaxCats) - desc <- ssemanticsdesc desc + desc <- sty desc av <- isFresh av ovs <- asks objVars pure (desc, av, ovs) @@ -906,7 +923,7 @@ sact = \case Let r av desc t a -> do (desc, av, ovs) <- during FreshMetaElaboration $ do syndecls <- gets (Map.keys . syntaxCats) - desc <- ssemanticsdesc desc + desc <- sty desc av <- isFresh av ovs <- asks objVars pure (desc, av, ovs) @@ -1038,11 +1055,11 @@ coverageCheckClause rp p = do sprotocol :: CProtocol -> Elab AProtocol sprotocol p = during (ProtocolElaboration p) $ do syndecls <- gets (Map.keys . syntaxCats) - Protocol <$> traverse (bitraverse (traverse $ ssyntaxdesc syndecls) ssemanticsdesc) (getProtocol p) + Protocol <$> traverse (bitraverse (traverse $ ssyntaxdesc syndecls) sty) (getProtocol p) scontextstack :: CContextStack -> Elab AContextStack scontextstack (ContextStack key val) = do syndecls <- gets (Map.keys . syntaxCats) key <- ssyntaxdesc syndecls key - val <- ssemanticsdesc val + val <- sty val pure (ContextStack key val) diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 2c4bd83..e9d2c29 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -231,7 +231,7 @@ initContext opts = Context $ PP (BP (Hide "x") $ MP (am "T") (ones 1)) $ AP "") , paramsDesc = [(Just (am "s"), ObjVars B0 :=> (am "S" $: sbstI 0))] - , retDesc = ObjVars (B0 :< ObjVar "s" (am "S" $: sbstI 0)) :=> (am "T" $: topSbst "x" (var (DB 0) 1)) + , retDesc = am "T" $: topSbst "x" (am "s" $: sbstI 0) }) ] , location = B0 diff --git a/Src/Operator.hs b/Src/Operator.hs index d4beacf..9202d4e 100644 --- a/Src/Operator.hs +++ b/Src/Operator.hs @@ -10,11 +10,11 @@ import Parse import Options import Actor ( Env', ACTm) import Term.Base -import Info import Bwd import Thin import Pretty + {- 1. No subst in parsing phase. => parser has no clue about lexical scope @@ -68,7 +68,7 @@ scopeSize = length . getObjVars -- - S has a SOT, binding nothing -- - T has a SOT, binding x with type S[] type family SOT (ph :: Phase) :: * -type instance SOT Concrete = Raw +type instance SOT Concrete = ([(Raw, Variable)], Raw) type instance SOT Abstract = ASOT -- TODO: conversion function to telescope @@ -82,14 +82,15 @@ infix 2 :=> -- Operators data ANOPERATOR (ph :: Phase) = AnOperator - { opName :: OPERATOR ph - , objDesc :: (Maybe (ACTORVAR ph), PATTERN ph) -- add ([ACTORVar ph], TERM ph)? - , paramsDesc :: [(Maybe (ACTORVAR ph), SOT ph)] - , retDesc :: SOT ph - } + {- (p : ['Sig a \x.b]) -} { objDesc :: (Maybe (ACTORVAR ph), PATTERN ph) -- add ([ACTORVar ph], TERM ph)? + {- -[ 'snd -} , opName :: OPERATOR ph + {- ] -} , paramsDesc :: [(Maybe (ACTORVAR ph), SOT ph)] + {- : {x = p -'fst} b -} , retDesc :: SEMANTICSDESC ph + } deriving instance ( Show (OPERATOR ph) + , Show (SEMANTICSDESC ph) , Show (ACTORVAR ph) , Show (PATTERN ph) , Show (SOT ph) @@ -145,13 +146,16 @@ poperator ph = (,[]) <$> pwithRange patom <|> (,) <$ pch (== '[') <* pspc <*> pwithRange patom <*> many (id <$ pspc <*> ph) <* pspc <* pch (== ']') +pBinders :: Parser (a, b) -> Parser (a, ([(Raw, Variable)], b)) +pBinders p = fmap . (,) <$> many ((,) <$> pTM <* punc "\\" <*> pvariable <* pspc <* pch ('.' ==)) <*> p + panoperator :: Parser CAnOperator panoperator = do obj <- pmaybeNamed ppat punc "-" - (opname, params) <- poperator $ pmaybeNamed psemanticsdecl + (opname, params) <- poperator $ pBinders $ pmaybeNamed psemanticsdecl punc ":" - AnOperator opname obj params <$> psemanticsdecl + AnOperator obj opname params <$> psemanticsdecl where pmaybeNamed :: Parser a -> Parser (Maybe (ACTORVAR Concrete), a) pmaybeNamed p = pparens ((,) . Just <$> pvariable <* punc ":" <*> p) From 42d6389d60ad3e3e6e7138a173c9891acaf8e63a Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Tue, 7 Feb 2023 17:56:29 +0000 Subject: [PATCH 38/89] [ more ] sparam --- Src/Elaboration.hs | 89 ++++++++++++++++++++++++++-------------- Src/Elaboration/Monad.hs | 1 + Src/Operator.hs | 23 +++++++++-- Src/Operator/Eval.hs | 7 +++- Src/Term/Base.hs | 15 ++++++- 5 files changed, 98 insertions(+), 37 deletions(-) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 23b17fa..9d7953d 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -342,7 +342,7 @@ spatSemantics desc rest rp = do VWildcard _ -> pure (desc, desc) VBind cat desc -> pure (Semantics.catToDesc cat, desc) _ -> throwError (SyntaxPError r desc rp) - + -- TODO: refactor using Dischargeable case x of Unused -> do (p, ds, t) <- spatSemantics desc rest p @@ -371,6 +371,8 @@ isList (At r a) = throwError (ExpectedNilGot r a) isList (Cons r p q) = (p:) <$> isList q isList t = throwError (ExpectedAConsGot (getRange t) t) +-- Input: fully applied operator ready to operate +-- Output: (abstract operator, raw parameters) sop :: Raw -> Elab (AAnOperator, [Raw]) sop (At ra a) = do op <- isOperator ra a @@ -385,27 +387,27 @@ itm :: Usage -> Raw -> Elab (ASemanticsDesc, ACTm) itm usage (Var r v) = do (_, desc, v) <- svar usage v pure (desc, v) -itm usage (Op r rs ro) = do - (AnOperator{..}, rps) <- sop ro - (sdesc, s) <- itm usage rs +-- rob -rop +itm usage (Op r rob rop) = do + (obDesc, ob) <- itm usage rob + (AnOperator{..}, rps) <- sop rop dat <- do dat <- asks headUpData let hnf = headUp dat - env <- case snd $ match hnf initMatching (Problem B0 (snd objDesc) sdesc) of + env <- case snd $ match hnf initMatching (Problem B0 (snd objDesc) obDesc) of Left e -> throwError $ InferredDescMismatch r Right m -> pure $ matchingToEnv m (huEnv dat) env <- case fst objDesc of Nothing -> pure env - Just v -> pure $ newActorVar v (localScope env <>> [], s) env + Just v -> pure $ newActorVar v (localScope env <>> [], ob) env pure dat{huEnv = env} local (setHeadUpData dat) $ do - (desc, ps) <- undefined -- TODO (was: itms r usage paramsDesc rps retDesc) - let o = case ps of - [] -> atom (getOperator opName) (scope s) + (desc, ps) <- itms r usage paramsDesc rps retDesc + let o = case ps of --TODO: break out into a smart constructor + [] -> atom (getOperator opName) (scope ob) _ -> getOperator opName #%+ ps - pure (desc, Term.contract (s :-: o)) + pure (desc, Term.contract (ob :-: o)) -- TODO?: annotated terms? - itm _ t = throwError $ DontKnowHowToInferDesc (getRange t) t itms :: Range -> Usage @@ -413,14 +415,27 @@ itms :: Range -> Usage -> [(Maybe ActorMeta, ASOT)] -- Raw parameters -> [Raw] - -- Return type as a SOT -- TODO: come back once we have DeclOps - -> ASOT + -- Return type + -> ASemanticsDesc -- - -> Elab (ASemanticsDesc -- Inferred return type (instantiated ^SOT) + -> Elab (ASemanticsDesc -- Instantiated return type , [ACTm]) -- Elaborated parameters -itms r usage [] [] rdesc = undefined -- TODO (was: (, []) <$> sasot r rdesc) -itms r usage ((binder, asot):bs) (rp:rps) rdesc = do - pdesc <- undefined -- TODO (was: sasot (getRange rp) asot) +itms r usage [] [] rdesc = (, []) <$> instantiateDesc r rdesc +itms r usage ((binder, sot):bs) (rp:rps) rdesc = do + (ovs :=> desc) <- instantiateSOT r sot + (p, dat) <- sparam usage binder B0 (discharge ovs desc) rp + local (setHeadUpData dat) $ + fmap (p:) <$> itms r usage bs rps rdesc +itms r usage bs rps rdesc = throwError $ ArityMismatchInOperator r + +sparam :: Usage + -> Maybe ActorMeta -- Name of parameter + -> Bwd String -- Names of formal parameters of the parameter + -> Telescopic ASemanticsDesc -- Type of the parameter + -> Raw -- Raw term naming the actual parameters + -> Elab (ACTm, HeadUpData' ActorMeta) -- Elaborated term, + -- headupdata with the parameter defined +sparam usage binder namez (Stop pdesc) rp = do p <- stm usage pdesc rp dat <- do dat <- asks headUpData @@ -428,11 +443,26 @@ itms r usage ((binder, asot):bs) (rp:rps) rdesc = do Nothing -> dat Just v -> let env = huEnv dat - env' = newActorVar v (localScope env <>> [], p) env - in dat{huEnv = env'} - local (setHeadUpData dat) $ - fmap (p:) <$> itms r usage bs rps rdesc -itms r usage bs rps rdesc = throwError $ ArityMismatchInOperator r + env' = newActorVar v (namez <>> [], p) env + in dat {huEnv = env'} + pure (p, dat) +sparam usage binder namez (Tele desc (Scope (Hide name) tele)) (Lam r (Scope (Hide x) rp)) = + elabUnder (x, desc) $ sparam usage binder (namez :< name) tele rp +sparam _ _ _ _ rp = throwError $ ExpectedParameterBinding (getRange rp) rp + +instantiateSOT :: Range -> ASOT -> Elab ASOT +instantiateSOT r (ovs :=> desc) + = (:=>) <$> traverse (instantiateDesc r) ovs <*> instantiateDesc r desc + +instantiateDesc :: Range -> ASemanticsDesc -> Elab ASemanticsDesc +instantiateDesc r desc = do + dat <- asks headUpData + -- The object acted upon and the parameters appearing before the + -- one currently being elaborated need to be substituted into the desc + case mangleActors (huOptions dat) (huEnv dat) desc of + Nothing -> throwError $ SchematicVariableNotInstantiated r + Just v -> pure v + {- sp is only for Concrete p to Abstract p @@ -488,19 +518,18 @@ stm usage desc rt = do VWildcard i -> pure (desc, desc) VBind cat desc -> pure (catToDesc cat, desc) _ -> throwError (SyntaxError r desc rt) - case x of - Used x -> do - x <- isFresh x - sc <- local (declareObjVar (x, s)) $ stm usage desc sc - pure (x \\ sc) - Unused -> do - sc <- stm usage desc sc - pure ((Hide "_" := False :.) $^ sc) + elabUnder (x, s) $ stm usage desc sc Op{} -> do (tdesc, t) <- itm usage rt compatibleInfos (getRange rt) (Known tdesc) (Known desc) pure t +elabUnder :: Dischargeable a => (Binder Variable, ASemanticsDesc) -> Elab a -> Elab a +elabUnder (x, desc) ma = do + x <- case x of + Used x -> isFresh x + Unused -> pure "_" + (x \\) <$> local (declareObjVar (x, desc)) ma spats :: IsSubject -> [ASemanticsDesc] -> Restriction -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) spats _ [] rest (AtP r "") = (Nothing, AP "",,) <$> asks declarations <*> asks binderHints diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index e9d2c29..8313ccd 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -439,6 +439,7 @@ data Complaint -- operators | AlreadyDeclaredOperator Range String | InvalidOperatorArity Range String [SyntaxDesc] [RawP] + | ExpectedParameterBinding Range Raw -- protocol | InvalidSend Range Channel Raw | InvalidRecv Range Channel RawP diff --git a/Src/Operator.hs b/Src/Operator.hs index 9202d4e..990cb95 100644 --- a/Src/Operator.hs +++ b/Src/Operator.hs @@ -11,6 +11,8 @@ import Options import Actor ( Env', ACTm) import Term.Base import Bwd +import Hide +import Scope import Thin import Pretty @@ -46,10 +48,12 @@ instance Pretty (ObjVar' a) where -- i.e. they should be weakened on extension, not on -- lookup. -newtype ObjVars = ObjVars { getObjVars :: Bwd ObjVar } - deriving (Show, Eq) +newtype ObjVars' a = ObjVars { getObjVars :: Bwd (ObjVar' a) } + deriving (Functor, Foldable, Traversable, Show, Eq) + +type ObjVars = ObjVars' ASemanticsDesc -instance Pretty ObjVars where +instance Pretty (ObjVars' a) where pretty = collapse . fmap pretty . getObjVars thinsTo :: ObjVars -> ObjVars -> Maybe Th @@ -78,6 +82,19 @@ data ASOT = ObjVars :=> ACTm infix 2 :=> +data Telescopic a = Stop a + | Tele ASemanticsDesc (Scope String (Telescopic a)) + +discharge :: ObjVars -> a -> Telescopic a +discharge (ObjVars oz) a = go oz (ones (length oz)) (Stop a) + where + -- Invariant: Thinning th is from scope of acc into the scope of oz + go B0 th acc = acc + go (oz :< ObjVar name ty) th acc = let th' = pop th in + case thickenCdB th' ty of + Nothing -> error "discharge: invalid context" + Just ty -> go oz th' (Tele ty (Scope (Hide name) acc)) + ------------------------------------------------------------------------------ -- Operators diff --git a/Src/Operator/Eval.hs b/Src/Operator/Eval.hs index 8f809b4..ae2ecac 100644 --- a/Src/Operator/Eval.hs +++ b/Src/Operator/Eval.hs @@ -32,11 +32,14 @@ data HeadUpData' m = forall i d. HeadUpData , huOptions :: Options , huEnv :: Env' m , whatIs :: m -> Maybe (Term' m) - } - + } + instance Show (HeadUpData' m) where show _ = "HUD" +instance Dischargeable (HeadUpData' m) where + _ \\ dat = dat + type HeadUpData = HeadUpData' Meta -- Expanding the term using the information currently available: diff --git a/Src/Term/Base.hs b/Src/Term/Base.hs index 9f78765..d363d28 100644 --- a/Src/Term/Base.hs +++ b/Src/Term/Base.hs @@ -257,8 +257,18 @@ asList :: OrBust x => ([CdB (Tm m)] -> x) -> CdB (Tm m) -> x asList f = asNilOrCons (f []) (\ x -> asList (f . (x:))) infixr 3 \\ -(\\) :: String -> CdB (Tm m) -> CdB (Tm m) -x \\ t = contract (x :.: t) + +class Dischargeable a where + (\\) :: String -> a -> a + +instance Dischargeable (CdB (Tm m)) where + x \\ t = contract (x :.: t) + +instance Dischargeable () where + x \\ t = t + +instance (Dischargeable a, Dischargeable b) => Dischargeable (a, b) where + x \\ (s, t) = (x \\ s, x \\ t) infixr 5 $: ($:) :: m -> CdB (Sbst m) -> CdB (Tm m) @@ -266,3 +276,4 @@ m $: sg = contract (m :$: sg) shitMeta :: String -> Meta shitMeta s = Meta [("user",0),(s,0)] + From 2ece2fd68c365dfd58bbf847957e7d171142da70 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Thu, 9 Feb 2023 17:41:19 +0000 Subject: [PATCH 39/89] [ more ] towards elaborating operator definitions --- Src/Command.hs | 48 +++++++++++++++++++++++++++++++++++----------- Src/Elaboration.hs | 30 +++++++++++++++++++---------- Src/Operator.hs | 11 ++++++++--- 3 files changed, 65 insertions(+), 24 deletions(-) diff --git a/Src/Command.hs b/Src/Command.hs index a72e765..5d3e975 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -342,15 +342,24 @@ scommand = \case Trace ts -> (Trace ts,) <$> asks globals DeclOp ops -> first DeclOp <$> sdeclOps ops - -- Sig S \x.T - 'fst ~> S -- (p : Sig S \x.T) - 'snd ~> {x=[ p - 'fst ]}T + DefnOp ((p, pty), opelims, rhs) -> do + -- p : pty -[ opelim0 ] -[ opelim1 ] ... -[ opelimn ] ~> rhs + sem <- satom "Semantics" + (pty, decls, ty) <- spatSemantics0 sem pty + (p, decls, t) <- local (setDecls decls) $ spatSemantics0 ty p + (opelimz, decls, lhsTy) <- sopelims0 decls (ty, t) opelims + rhs <- local (setDecls decls) $ stm DontLog lhsTy rhs + -- this is the outer op being extended + let op = case opelimz of (_ :< (op, _)) -> op + let cl = Clause (toClause p opelimz rhs) + (DefnOp (op, cl),) <$> asks globals {- - DefnOp (p, opelims, rhs) -> do ovs <- asks objVars let scp = scopeSize ovs - -- p -[ opelim0 ] -[ opelim1 ] ... -[ opelimn ] ~> rhs + ((p, opargs), ret, decls, hints) <- do -- this is the op applied to the object, not the outer op being extended let op = fst (head opelims) @@ -362,18 +371,11 @@ scommand = \case sopargs obj opargs pure ((p, opargs), ret, decls, hints) rhs <- local (setDecls decls . setHints hints) $ stm DontLog ret rhs - -- this is the outer op being extended - let op = fst (last opargs) + -- trace (unwords [getOperator op, "-[", '\'':show p, show opargs, "~>", show rhs]) (pure ()) - let cl = Clause (toClause p (B0 <>< opargs) rhs) - (DefnOp (op, cl),) <$> asks globals -} - - - - -- DeclJudgementForm j -> do -- (j , gs) <- sjudgementform j -- pure (DeclJudgementForm j, gs) @@ -472,6 +474,29 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do | otherwise = throwError (MalformedPostOperator (getRange (objDesc op)) (theValue (opName op)) (Map.keys m)) -} +sopelims0 :: Decls + -> (ASemanticsDesc, ACTm) + -> [(OPERATOR Concrete, [RawP])] + -> Elab (Bwd (OPERATOR Abstract, [Pat]), Decls, ASemanticsDesc) +sopelims0 = sopelims B0 + +sopelims :: Bwd (OPERATOR Abstract, [Pat]) + -> Decls + -> (ASemanticsDesc, ACTm) + -> [(OPERATOR Concrete, [RawP])] + -> Elab (Bwd (OPERATOR Abstract, [Pat]), Decls, ASemanticsDesc) +sopelims opelimz decls (ty, t) [] = pure (opelimz, decls, ty) +sopelims opelimz decls (ty, t) ((op, args):opelims) = do + (AnOperator (mb, opat) op pdescs rdesc) <- soperator op + dat <- matchObjType (foldMap getRange args) (mb, opat) (ty, t) + _ --TODO: continue here + +{- +Note to selves: we need to worry about freshening up names in operator +declarations when checking definitions. +-} + +{- -- | sopargs desc cops -- | desc: description of the object the cops are applied to sopargs :: SyntaxDesc -> [COpPattern] -> Elab ([AOpPattern], Decls, Hints) @@ -494,6 +519,7 @@ sopargs desc ((rop, args):xs) = do ([], (_:_)) -> foldMap getRange ps _ -> r throwError (InvalidOperatorArity r (theValue rop) ds ps) +-} soperator :: COperator -> Elab AAnOperator soperator (WithRange r tag) = do diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 9d7953d..9992752 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -261,6 +261,11 @@ sparamdescs ((mx , sot):ps) = do (ps, ds) <- local (declare binder (ActVar IsNotSubject sot)) $ sparamdescs ps pure ((mx , sot):ps, ds) +spatSemantics0 :: ASemanticsDesc -> CPattern -> Elab (APattern, Decls, ACTm) +spatSemantics0 desc p = do + ovs <- asks objVars + spatSemantics desc (initRestriction ovs) p + spatSemantics :: ASemanticsDesc -> Restriction -> CPattern -> Elab (APattern, Decls, ACTm) spatSemantics desc rest (Irrefutable r p) = do @@ -369,6 +374,7 @@ isList :: Raw -> Elab [Raw] isList (At r "") = pure [] isList (At r a) = throwError (ExpectedNilGot r a) isList (Cons r p q) = (p:) <$> isList q + isList t = throwError (ExpectedAConsGot (getRange t) t) -- Input: fully applied operator ready to operate @@ -383,6 +389,19 @@ sop (Cons rp (At ra a) ps) = do pure (op, es) sop ro = throwError (ExpectedAnOperator (getRange ro) ro) + +matchObjType :: Range -> (Maybe ActorMeta, Pat) -> (ASemanticsDesc, ACTm) -> Elab (HeadUpData' ActorMeta) +matchObjType r (mb , oty) (obDesc, ob) = do + dat <- asks headUpData + let hnf = headUp dat + env <- case snd $ match hnf initMatching (Problem B0 oty obDesc) of + Left e -> throwError $ InferredDescMismatch r + Right m -> pure $ matchingToEnv m (huEnv dat) + env <- case mb of + Nothing -> pure env + Just v -> pure $ newActorVar v (localScope env <>> [], ob) env + pure dat{huEnv = env} + itm :: Usage -> Raw -> Elab (ASemanticsDesc, ACTm) itm usage (Var r v) = do (_, desc, v) <- svar usage v @@ -391,16 +410,7 @@ itm usage (Var r v) = do itm usage (Op r rob rop) = do (obDesc, ob) <- itm usage rob (AnOperator{..}, rps) <- sop rop - dat <- do - dat <- asks headUpData - let hnf = headUp dat - env <- case snd $ match hnf initMatching (Problem B0 (snd objDesc) obDesc) of - Left e -> throwError $ InferredDescMismatch r - Right m -> pure $ matchingToEnv m (huEnv dat) - env <- case fst objDesc of - Nothing -> pure env - Just v -> pure $ newActorVar v (localScope env <>> [], ob) env - pure dat{huEnv = env} + dat <- matchObjType r objDesc (obDesc, ob) local (setHeadUpData dat) $ do (desc, ps) <- itms r usage paramsDesc rps retDesc let o = case ps of --TODO: break out into a smart constructor diff --git a/Src/Operator.hs b/Src/Operator.hs index 990cb95..ce10256 100644 --- a/Src/Operator.hs +++ b/Src/Operator.hs @@ -125,7 +125,7 @@ type instance OPERATOR Abstract = Operator newtype Clause = Clause { runClause :: forall m - . Options + . Show m => Options -> (Term' m -> Term' m) -- head normaliser -> Env' m -> (Term' m, [Term' m]) -- object & parameters @@ -147,11 +147,16 @@ instance Show Clause where type OPPATTERN ph = (OPERATOR ph, [PATTERN ph]) type family DEFNOP (ph :: Phase) :: * -type instance DEFNOP Concrete = (PATTERN Concrete, [OPPATTERN Concrete], TERM Concrete) +type instance DEFNOP Concrete = ((PATTERN Concrete, PATTERN Concrete) -- object and its type + , [OPPATTERN Concrete] -- spine + , TERM Concrete) -- right hand side type instance DEFNOP Abstract = (Operator, Clause) pdefnop :: Parser (DEFNOP Concrete) -pdefnop = (,,) <$> ppat <*> some (punc "-" *> poperator ppat) <* punc "~>" <*> pTM +pdefnop = (,,) <$> ((,) <$> ppat <* punc ":" <*> ppat) + <*> some (punc "-" *> poperator ppat) + <* punc "~>" + <*> pTM type COpPattern = OPPATTERN Concrete type AOpPattern = OPPATTERN Abstract From 7846695c9da6ba108039a8f50cbd54a8d24ad040 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Thu, 16 Feb 2023 15:33:15 +0000 Subject: [PATCH 40/89] [ done ] (hopefully) with defnop --- Src/Actor.hs | 6 ++- Src/Command.hs | 86 ++++++++++++++++++++++++++++++++------- Src/Elaboration.hs | 11 +++-- Src/Elaboration/Monad.hs | 3 +- Src/Elaboration/Pretty.hs | 2 +- Src/Pattern.hs | 5 ++- Src/Term/Base.hs | 1 - Src/Thin.hs | 1 + 8 files changed, 89 insertions(+), 26 deletions(-) diff --git a/Src/Actor.hs b/Src/Actor.hs index acdb2ef..3067ada 100644 --- a/Src/Actor.hs +++ b/Src/Actor.hs @@ -22,8 +22,10 @@ type Pat = Pat' ActorMeta data Passport = ASubject | ACitizen deriving (Show, Eq, Ord) -data ActorMeta = ActorMeta Passport ActorVar - deriving (Eq, Ord) +data ActorMeta' a = ActorMeta Passport a + deriving (Eq, Ord, Functor) + +type ActorMeta = ActorMeta' ActorVar instance Show ActorMeta where show (ActorMeta _ str) = str diff --git a/Src/Command.hs b/Src/Command.hs index 5d3e975..d160d1e 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -47,6 +47,11 @@ import Utils import Data.Char (isSpace) import qualified Data.Set as Set import Operator +import Elaboration.Monad (clock) +import Thin +import Operator.Eval (HeadUpData' (..)) +import Hide (Hide(..)) +import Scope (Scope(..)) type family SYNTAXCAT (ph :: Phase) :: * type instance SYNTAXCAT Concrete = WithRange SyntaxCat @@ -347,9 +352,9 @@ scommand = \case DefnOp ((p, pty), opelims, rhs) -> do -- p : pty -[ opelim0 ] -[ opelim1 ] ... -[ opelimn ] ~> rhs sem <- satom "Semantics" - (pty, decls, ty) <- spatSemantics0 sem pty + (_, decls, ty) <- spatSemantics0 sem pty (p, decls, t) <- local (setDecls decls) $ spatSemantics0 ty p - (opelimz, decls, lhsTy) <- sopelims0 decls (ty, t) opelims + (opelimz, decls, lhsTy) <- local (setDecls decls) $ sopelims0 (ty, t) opelims rhs <- local (setDecls decls) $ stm DontLog lhsTy rhs -- this is the outer op being extended let op = case opelimz of (_ :< (op, _)) -> op @@ -474,27 +479,65 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do | otherwise = throwError (MalformedPostOperator (getRange (objDesc op)) (theValue (opName op)) (Map.keys m)) -} -sopelims0 :: Decls - -> (ASemanticsDesc, ACTm) +sopelims0 :: (ASemanticsDesc, ACTm) -> [(OPERATOR Concrete, [RawP])] -> Elab (Bwd (OPERATOR Abstract, [Pat]), Decls, ASemanticsDesc) sopelims0 = sopelims B0 sopelims :: Bwd (OPERATOR Abstract, [Pat]) - -> Decls -> (ASemanticsDesc, ACTm) -> [(OPERATOR Concrete, [RawP])] -> Elab (Bwd (OPERATOR Abstract, [Pat]), Decls, ASemanticsDesc) -sopelims opelimz decls (ty, t) [] = pure (opelimz, decls, ty) -sopelims opelimz decls (ty, t) ((op, args):opelims) = do - (AnOperator (mb, opat) op pdescs rdesc) <- soperator op - dat <- matchObjType (foldMap getRange args) (mb, opat) (ty, t) - _ --TODO: continue here +sopelims opelimz (ty, t) [] = (opelimz,,ty) <$> asks declarations +sopelims opelimz (ty, t) ((op, args):opelims) = do + -- We need to worry about freshening up names in operator + -- declarations when checking definitions to avoid clashes + (AnOperator (mb, opat) opName pdescs rdesc) <- freshenOp =<< soperator op + let r = getRange op <> foldMap getRange args + dat <- matchObjType r (mb, opat) (ty, t) + local (setHeadUpData dat) $ do + ((ty, decls), (pargs, args)) <- spats r pdescs args rdesc + local (setDecls decls) $ + sopelims (opelimz :< (opName, pargs)) (ty, t -% (getOperator opName, args)) opelims -{- -Note to selves: we need to worry about freshening up names in operator -declarations when checking definitions. --} + where + + + -- cf. sparam + sparamSemantics :: Maybe ActorMeta + -> Bwd String + -> Telescopic ASemanticsDesc + -> RawP + -> Elab ((Pat, ACTm), HeadUpData' ActorMeta) + sparamSemantics binder namez (Stop pdesc) rp = do + (p, decls, t) <- spatSemantics0 pdesc rp + dat <- do + dat <- asks headUpData + pure $ case binder of + Nothing -> dat + Just v -> + let env = huEnv dat + env' = newActorVar v (namez <>> [], t) env + in dat {huEnv = env'} + pure ((p, t), dat) + sparamSemantics binder namez + (Tele desc (Scope (Hide name) tele)) + (LamP r (Scope (Hide x) rp)) = + elabUnder (x, desc) $ sparamSemantics binder (namez :< name) tele rp + + -- cf. itms + spats :: Range + -> [(Maybe ActorMeta, ASOT)] + -> [CPattern] + -> ASemanticsDesc + -> Elab ((ASemanticsDesc, Decls), ([APattern], [ACTm])) + spats r [] [] rdesc = (,([], [])) <$> ((,) <$> instantiateDesc r rdesc <*> asks declarations) + spats r ((binder, sot) : bs) (rp:rps) rdesc = do + (ovs :=> desc) <- instantiateSOT (getRange rp) sot + ((p, t), dat) <- sparamSemantics binder B0 (discharge ovs desc) rp + local (setHeadUpData dat) $ + fmap (bimap (p:) (t:)) <$> spats r bs rps rdesc + spats r bs rps rdesc = throwError $ ArityMismatchInOperator r {- -- | sopargs desc cops @@ -521,6 +564,21 @@ sopargs desc ((rop, args):xs) = do throwError (InvalidOperatorArity r (theValue rop) ds ps) -} +freshenOp :: AAnOperator -> Elab AAnOperator +freshenOp (AnOperator (mp, p) opName pdesc rdesc) = do + n <- gets clock + modify (\ st -> st { clock = 1+n }) + let tick = ((show n ++) <$>) + let tickCdB = ((tick <$>) $^) + let tick' (ObjVars ovs :=> t) = + ObjVars (fmap (tickCdB <$>) ovs) :=> tickCdB t + pure $ AnOperator + { objDesc = (tick <$> mp, tick <$> p) + , opName + , paramsDesc = map (bimap (tick <$>) tick') pdesc + , retDesc = tickCdB rdesc + } + soperator :: COperator -> Elab AAnOperator soperator (WithRange r tag) = do ops <- asks operators diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 9992752..854ec7c 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -389,7 +389,9 @@ sop (Cons rp (At ra a) ps) = do pure (op, es) sop ro = throwError (ExpectedAnOperator (getRange ro) ro) - +-- e.g. (p : ['Sig S \x.T]) -'snd +-- ['MkSig a b] : ['Sig A \y.B] +-- Then we want an environment extended by: (S = A, \x.T = \y.B, p = ['MkSig a b]) matchObjType :: Range -> (Maybe ActorMeta, Pat) -> (ASemanticsDesc, ACTm) -> Elab (HeadUpData' ActorMeta) matchObjType r (mb , oty) (obDesc, ob) = do dat <- asks headUpData @@ -413,10 +415,7 @@ itm usage (Op r rob rop) = do dat <- matchObjType r objDesc (obDesc, ob) local (setHeadUpData dat) $ do (desc, ps) <- itms r usage paramsDesc rps retDesc - let o = case ps of --TODO: break out into a smart constructor - [] -> atom (getOperator opName) (scope ob) - _ -> getOperator opName #%+ ps - pure (desc, Term.contract (ob :-: o)) + pure (desc, ob -% (getOperator opName, ps)) -- TODO?: annotated terms? itm _ t = throwError $ DontKnowHowToInferDesc (getRange t) t @@ -432,7 +431,7 @@ itms :: Range -> Usage , [ACTm]) -- Elaborated parameters itms r usage [] [] rdesc = (, []) <$> instantiateDesc r rdesc itms r usage ((binder, sot):bs) (rp:rps) rdesc = do - (ovs :=> desc) <- instantiateSOT r sot + (ovs :=> desc) <- instantiateSOT (getRange rp) sot (p, dat) <- sparam usage binder B0 (discharge ovs desc) rp local (setHeadUpData dat) $ fmap (p:) <$> itms r usage bs rps rdesc diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 8313ccd..05a0cb0 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -36,6 +36,7 @@ data ElabState = ElabState , actvarStates :: ActvarStates , syntaxCats :: SyntaxTable , warnings :: Bwd (WithStackTrace Warning) + , clock :: Int } type ChannelState = (Direction, [Turn], [AProtocolEntry]) @@ -77,7 +78,7 @@ data Direction = Rootwards deriving (Eq, Show) initElabState :: ElabState -initElabState = ElabState Map.empty Map.empty Map.empty B0 +initElabState = ElabState Map.empty Map.empty Map.empty B0 0 newtype Elab a = Elab { runElab :: StateT ElabState diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index af6dd00..ddc745c 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -6,7 +6,7 @@ import Data.Foldable import Data.These import ANSI hiding (withANSI) -import Actor (ActorMeta(..), Channel(..), Stack(..), AProtocol) +import Actor (ActorMeta'(..), ActorMeta, Channel(..), Stack(..), AProtocol) import Concrete.Base (Binder (..), PROTOCOL(Protocol), Mode (..)) import Concrete.Pretty() import Elaboration.Monad diff --git a/Src/Pattern.hs b/Src/Pattern.hs index 4e8f5d8..fd7edcb 100644 --- a/Src/Pattern.hs +++ b/Src/Pattern.hs @@ -23,7 +23,7 @@ data Pat' s | MP s Th | GP -- grumpy pattern | HP -- happy pattern - deriving (Show, Eq) + deriving (Show, Eq, Functor) isCatchall :: Pat' s -> Bool isCatchall (MP x th) = is1s th @@ -50,6 +50,9 @@ instance Selable (Pat' s) where th ^? GP = GP th ^? HP = HP +instance Dischargeable (Pat' m) where + x \\ p = BP (Hide x) p + (#?) :: String -> [Pat' s] -> Pat' s a #? ts = foldr PP (AP "") (AP a : ts) diff --git a/Src/Term/Base.hs b/Src/Term/Base.hs index d363d28..ceeff73 100644 --- a/Src/Term/Base.hs +++ b/Src/Term/Base.hs @@ -276,4 +276,3 @@ m $: sg = contract (m :$: sg) shitMeta :: String -> Meta shitMeta s = Meta [("user",0),(s,0)] - diff --git a/Src/Thin.hs b/Src/Thin.hs index 066f80a..270ee59 100644 --- a/Src/Thin.hs +++ b/Src/Thin.hs @@ -156,6 +156,7 @@ weak (CdB t th) = CdB t (th -? False) weaks :: Int -> CdB a -> CdB a weaks i (CdB t th) = CdB t (th <> none i) +-- TODO: refactor via derive Functor ($^) :: (a -> b) -> CdB a -> CdB b f $^ CdB a th = CdB (f a) th -- f better be support-preserving From 5768b0ff26f24f0630359dd2100cd01e8a2dac5d Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Thu, 16 Feb 2023 15:52:39 +0000 Subject: [PATCH 41/89] [ stm ] universe checking for atoms probably broken --- Src/Elaboration.hs | 2 ++ Src/Elaboration/Monad.hs | 1 + 2 files changed, 3 insertions(+) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 854ec7c..c3c1798 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -510,6 +510,8 @@ stm usage desc rt = do VNilOrCons{} -> unless (a == "") $ throwError (ExpectedNilGot r a) VEnumOrTag _ es _ -> unless (a `elem` es) $ throwError (ExpectedEnumGot r es a) VWildcard _ -> pure () + VUniverse _ -> unless (a `elem` ("Semantics" : Map.keys table)) $ throwError (ExpectedASemanticsGot r a) + -- TODO we're probably missing semantics here _ -> throwError (SemanticsError r desc rt) satom a Cons r p q -> case vdesc of diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 05a0cb0..b4db75e 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -468,6 +468,7 @@ data Complaint | IncompatibleSyntaxInfos Range (Info SyntaxDesc) (Info SyntaxDesc) | IncompatibleSemanticsDescs Range ASemanticsDesc ASemanticsDesc | GotBarredAtom Range String [String] + | ExpectedASemanticsGot Range String | ExpectedNilGot Range String | ExpectedEnumGot Range [String] String | ExpectedTagGot Range [String] String From c7b6c03bbfee45de7a645da485e3dc82cac509c8 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Thu, 16 Feb 2023 16:14:59 +0000 Subject: [PATCH 42/89] [ todo ] WithRange Complaint --- TODO.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/TODO.md b/TODO.md index b4a0651..d196037 100644 --- a/TODO.md +++ b/TODO.md @@ -91,6 +91,9 @@ * [ ] `keyword` pretty printing should use the data type of keywords * [ ] `class Declarable a where { declare :: a -> Context -> Context }` instead of declareObjVar, declareChannel, declareXXX +* [ ] Add `throwComplaint :: Range -> Complaint -> Elab ()` and + refactor `Complaint` to be range-free with the range carried + by a `WithRange` wrapper. ### Pretty From 959833d332931964c0d0c6ed27e736836b0a94a0 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Thu, 16 Feb 2023 17:09:00 +0000 Subject: [PATCH 43/89] [ debug ] added typecheck command --- Src/Command.hs | 10 +++++++++- Src/Elaboration.hs | 27 +++++++++++++++++---------- Src/Elaboration/Monad.hs | 19 +++++++++++++------ Src/Elaboration/Pretty.hs | 9 ++++++++- Src/Term/Base.hs | 1 + emacs/typos.el | 2 +- test/typecheck.act | 17 +++++++++++++++++ 7 files changed, 66 insertions(+), 19 deletions(-) create mode 100644 test/typecheck.act diff --git a/Src/Command.hs b/Src/Command.hs index d160d1e..cd1446b 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -77,7 +77,7 @@ data COMMAND (ph :: Phase) | DefnOp (DEFNOP ph) | DeclJudgementForm (JUDGEMENTFORM ph) | DeclRule (RULE ph) - + | Typecheck (TERM ph) (SEMANTICSDESC ph) deriving instance ( Show (JUDGEMENTNAME ph) @@ -153,6 +153,7 @@ instance Pretty CCommand where -- DeclJudgementForm j -> keyword "judgementform" <+> collapse (BracesList $ pretty <$> jpreconds j) -- <+> hsep (pretty (jname j) : map pretty (jplaces j)) -- <+> collapse (BracesList $ either pretty pretty <$> jpostconds j) + Typecheck t ty -> keyword "typecheck" <+> pretty t <+> ":" <+> pretty ty instance Unelab ACommand where type UnelabEnv ACommand = Naming @@ -170,6 +171,7 @@ instance Unelab ACommand where <*> traverse subunelab posts Go a -> Go <$> withEnv initDAEnv (unelab a) Trace ts -> pure $ Trace ts + Typecheck t ty -> Typecheck <$> unelab t <*> unelab ty instance Unelab AStatement where type UnelabEnv AStatement = () @@ -217,6 +219,7 @@ pcommand <|> DefnOp <$> pdefnop <|> DeclJudgementForm <$> pjudgementform <|> DeclRule <$> prule + <|> Typecheck <$ plit "typecheck" <* pspc <*> pTM <* punc ":" <*> pTM pfile :: Parser [CCommand] pfile = id <$ pspc <*> psep pspc pcommand <* pspc @@ -346,6 +349,11 @@ scommand = \case Go a -> during ExecElaboration $ (,) . Go <$> local (setElabMode Execution) (sact a) <*> asks globals Trace ts -> (Trace ts,) <$> asks globals DeclOp ops -> first DeclOp <$> sdeclOps ops + Typecheck t ty -> do + ty <- sty ty + t <- stm DontLog ty t + g <- asks globals + pure (Typecheck t ty, g) -- Sig S \x.T - 'fst ~> S -- (p : Sig S \x.T) - 'snd ~> {x=[ p - 'fst ]}T diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index c3c1798..d89cab2 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -274,7 +274,7 @@ spatSemantics desc rest (Irrefutable r p) = do spatSemantics desc rest (AsP r v p) = do v <- isFresh v ds <- asks declarations - (ovs, asot) <- thickenedASOT (restriction rest) desc + (ovs, asot) <- thickenedASOT r (restriction rest) desc (p, ds, t) <- local (setDecls (ds :< (v, ActVar IsNotSubject asot))) $ spatSemantics desc rest p pure (AT (ActorMeta ACitizen v) p, ds, t) @@ -300,7 +300,7 @@ spatSemantics desc rest (VarP r v) = during (PatternVariableElaboration v) $ do pure (VP i, ds, var i scp) Just mk -> throwError (NotAValidPatternVariable r v mk) Nothing -> do - (ovs, asot) <- thickenedASOT th desc + (ovs, asot) <- thickenedASOT r th desc v <- pure (getVariable v) let pat = MP (ActorMeta ACitizen v) (ones scp) pure (pat, ds :< (v, ActVar IsNotSubject asot), ActorMeta ACitizen v $: sbstI scp) @@ -510,7 +510,7 @@ stm usage desc rt = do VNilOrCons{} -> unless (a == "") $ throwError (ExpectedNilGot r a) VEnumOrTag _ es _ -> unless (a `elem` es) $ throwError (ExpectedEnumGot r es a) VWildcard _ -> pure () - VUniverse _ -> unless (a `elem` ("Semantics" : Map.keys table)) $ throwError (ExpectedASemanticsGot r a) + VUniverse _ -> unless (a `elem` ("Semantics" : Map.keys table)) $ throwError (ExpectedASemanticsGot r rt) -- TODO we're probably missing semantics here _ -> throwError (SemanticsError r desc rt) satom a @@ -523,11 +523,18 @@ stm usage desc rt = do Nothing -> throwError (ExpectedTagGot r (fst <$> ds) a) Just descs -> (%) <$> stm usage (atom "Atom" 0) p <*> stms usage descs q _ -> throwError (SyntaxError r desc rt) + VUniverse _ -> case (p , q) of + (At _ "Pi", Cons _ s (Cons _ (Lam _ (Scope (Hide x) t)) (At _ ""))) -> do + s <- sty s + t <- elabUnder (x, s) $ sty t + pure ("Pi" #%+ [s, t]) + _ -> throwError (ExpectedASemanticsGot r rt) _ -> throwError (SyntaxError r desc rt) Lam r (Scope (Hide x) sc) -> do (s, desc) <- case vdesc of VWildcard i -> pure (desc, desc) VBind cat desc -> pure (catToDesc cat, desc) + VPi s (y, t) -> pure (s, t) _ -> throwError (SyntaxError r desc rt) elabUnder (x, s) $ stm usage desc sc Op{} -> do @@ -570,7 +577,7 @@ spat esc rest rp@(AsP r v p) = do let desc = escrutinee esc v <- isFresh v ds <- asks declarations - (ovs, asot) <- thickenedASOT (restriction rest) desc + (ovs, asot) <- thickenedASOT r (restriction rest) desc (mr, p, ds, hs) <- local (setDecls (ds :< (v, ActVar IsNotSubject asot))) $ spat esc rest p pure (mr, AT (ActorMeta ACitizen v) p, ds, hs) spat esc rest p@VarP{} = spatBase (Pattern <$ isSubject esc) (escrutinee esc) rest p @@ -596,14 +603,14 @@ spat esc@(Lookup _ _ av) rest rp = spatBase IsNotSubject (escrutinee esc) rest r spat esc@(Compare{}) rest rp = spatBase IsNotSubject (escrutinee esc) rest rp spat esc@(Term{}) rest rp = spatBase IsNotSubject (escrutinee esc) rest rp -thickenedASOT :: Th -> ASemanticsDesc -> Elab (ObjVars, ASOT) -thickenedASOT th desc = do +thickenedASOT :: Range -> Th -> ASemanticsDesc -> Elab (ObjVars, ASOT) +thickenedASOT r th desc = do ovs <- asks objVars ovs <- case thickenObjVars th ovs of - Nothing -> throwError (NotAValidContextRestriction th ovs) + Nothing -> throwError (NotAValidContextRestriction r th ovs) Just ovs -> pure ovs desc <- case thickenCdB th desc of - Nothing -> throwError (NotAValidDescriptionRestriction th desc) + Nothing -> throwError (NotAValidDescriptionRestriction r th desc) Just desc -> pure desc pure (ovs, ovs :=> desc) @@ -613,7 +620,7 @@ spatBase isSub desc rest rp@(AsP r v p) = do throwError (AsPatternCannotHaveSubjects r rp) v <- isFresh v ds <- asks declarations - (ovs, asot) <- thickenedASOT (restriction rest) desc + (ovs, asot) <- thickenedASOT r (restriction rest) desc (mr, p, ds, hs) <- local (setDecls (ds :< (v, ActVar isSub asot))) $ spatBase isSub desc rest p pure (mr, AT (ActorMeta ACitizen v) p, ds, hs) spatBase isSub desc rest (ThP r ph p) = do @@ -634,7 +641,7 @@ spatBase isSub desc rest (VarP r v) = during (PatternVariableElaboration v) $ do pure (Nothing, VP i, ds, hs) Just mk -> throwError (NotAValidPatternVariable r v mk) Nothing -> do - (ovs, asot) <- thickenedASOT th desc + (ovs, asot) <- thickenedASOT r th desc v <- pure (getVariable v) let pat = MP (ActorMeta (spassport (Scrutinised unknown) isSub) v) (ones $ scopeSize ovs) pure (Nothing, pat, ds :< (v, ActVar isSub asot), hs) diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index b4db75e..8bded19 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -254,9 +254,10 @@ initContext opts = Context -- We have already checked the name is fresh declareObjVar :: (String, ASemanticsDesc) -> Context -> Context -declareObjVar (x, sem) ctx - = let scp = fmap weak <$> getObjVars (objVars ctx) in - ctx { objVars = ObjVars (scp :< ObjVar x sem) } +declareObjVar (x, sem) ctx = + -- We store semantics descs ready to be deployed at use sites + let scp = getObjVars (objVars ctx) :< ObjVar x sem in + ctx { objVars = ObjVars (fmap weak <$> scp) } -- Careful! The new ovs better be a valid scope -- i.e. all the objvars mentioned in the SemanticsDesc of @@ -426,8 +427,8 @@ data Complaint | EmptyContext Range | NotTopVariable Range Variable Variable | IncompatibleChannelScopes Range ObjVars ObjVars - | NotAValidContextRestriction Th ObjVars - | NotAValidDescriptionRestriction Th ASemanticsDesc + | NotAValidContextRestriction Range Th ObjVars + | NotAValidDescriptionRestriction Range Th ASemanticsDesc -- kinding | NotAValidTermVariable Range Variable Kind | NotAValidPatternVariable Range Variable Resolved @@ -468,7 +469,7 @@ data Complaint | IncompatibleSyntaxInfos Range (Info SyntaxDesc) (Info SyntaxDesc) | IncompatibleSemanticsDescs Range ASemanticsDesc ASemanticsDesc | GotBarredAtom Range String [String] - | ExpectedASemanticsGot Range String + | ExpectedASemanticsGot Range Raw | ExpectedNilGot Range String | ExpectedEnumGot Range [String] String | ExpectedTagGot Range [String] String @@ -561,6 +562,12 @@ instance HasGetRange Complaint where DontKnowHowToInferDesc r _ -> r ArityMismatchInOperator r -> r SchematicVariableNotInstantiated r -> r + -- TODO: categorise + NotAValidContextRestriction r _ _ -> r + NotAValidDescriptionRestriction r _ _ -> r + ExpectedParameterBinding r _ -> r + ExpectedASemanticsGot r _ -> r + ------------------------------------------------------------------------------ -- Syntaxes diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index ddc745c..ce0f4e1 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -212,7 +212,8 @@ instance Pretty Complaint where -- TODO : learn to print the semantics desc InvalidSemanticsDesc r sem -> "Invalid semantics description" SemanticsError r sem t -> hsep [pretty t, "does not match the semantics description"] - IncompatibleSemanticsInfos r isem isem' -> "Incompatible semantics description" + IncompatibleSemanticsInfos r isem isem' -> + hsep ["Incompatible semantics description infos", prettyPrec 1 isem, "and", prettyPrec 1 isem'] AsPatternCannotHaveSubjects r p -> hsep ["As pattern", pretty p, "duplicates a subject variable"] -- desc inference -- TODO : add more info @@ -220,6 +221,12 @@ instance Pretty Complaint where DontKnowHowToInferDesc r t -> hsep ["Do not know how to infer description for", pretty t] ArityMismatchInOperator r -> "Arity mismatch in operator" SchematicVariableNotInstantiated r -> "Schematic variable not instantiated" + NotAValidContextRestriction r x y -> "Not a valid context restriction" + NotAValidDescriptionRestriction r x y -> "Not a valid description restriction" + ExpectedParameterBinding r x -> "Expected parameter binding" + ExpectedASemanticsGot r t -> hsep ["Expected a semantics but got", pretty t] + + instance Pretty a => Pretty (WithStackTrace a) where pretty (WithStackTrace stk msg) = vcat (pretty msg : map pretty stk) diff --git a/Src/Term/Base.hs b/Src/Term/Base.hs index ceeff73..3dfbd91 100644 --- a/Src/Term/Base.hs +++ b/Src/Term/Base.hs @@ -252,6 +252,7 @@ asAtomOrTagged :: OrBust x => ((String, Int) -> x) -> ((String, Int) -> CdB (Tm asAtomOrTagged atom tagged t = t ?: \case AX s n -> atom (s, n) x :%: xs -> ($ x) $ asAtom (`tagged` xs) + _ -> bust asList :: OrBust x => ([CdB (Tm m)] -> x) -> CdB (Tm m) -> x asList f = asNilOrCons (f []) (\ x -> asList (f . (x:))) diff --git a/emacs/typos.el b/emacs/typos.el index 8e400cb..c44c211 100644 --- a/emacs/typos.el +++ b/emacs/typos.el @@ -3,7 +3,7 @@ ;; based on: http://ergoemacs.org/emacs/elisp_syntax_coloring.html ;; define several class of keywords -(setq typos-keywords '("syntax" "operator" "exec" "trace" "rule" "judgementform" +(setq typos-keywords '("syntax" "operator" "exec" "trace" "rule" "judgementform" "typecheck" "break" "unify" "send" "recv" "move" "case" "let" "Atom" "AtomBar" "Wildcard" "EnumOrTag" "Enum" "Tag" "Cons" "Nil" "NilOrCons" "Fix" "Bind" diff --git a/test/typecheck.act b/test/typecheck.act new file mode 100644 index 0000000..709adbb --- /dev/null +++ b/test/typecheck.act @@ -0,0 +1,17 @@ +typecheck 'Semantics : 'Semantics + +syntax { + 'Nat = ['EnumOrTag ['Zero] [['Suc 'Nat]]] +} + +typecheck 'Nat : 'Semantics +typecheck 'Zero : 'Nat +typecheck ['Suc 'Zero] : 'Nat + +typecheck ['Pi 'Nat (\_.'Nat)] : 'Semantics +typecheck \x.x : ['Pi 'Nat (\_.'Nat)] + +typecheck ['Pi 'Semantics \X.['Pi X \_.X]] : 'Semantics +typecheck \X x.x : ['Pi 'Semantics \X.['Pi X \_.X]] + +exec PRINTF "Hurrah!". From e3b6900a8f1ecef63626c872bf1eac01da53e5c5 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Thu, 16 Feb 2023 17:51:59 +0000 Subject: [PATCH 44/89] [ refactor ] get rid of HasGetRange Complaint --- Src/Command.hs | 28 ++--- Src/Elaboration.hs | 176 +++++++++++++++--------------- Src/Elaboration/Monad.hs | 218 +++++++++++++------------------------- Src/Elaboration/Pretty.hs | 136 ++++++++++++------------ Src/Location.hs | 3 + 5 files changed, 249 insertions(+), 312 deletions(-) diff --git a/Src/Command.hs b/Src/Command.hs index cd1446b..f4e1f85 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -288,7 +288,7 @@ sdeclOps ((AnOperator (objName, objDescPat) (WithRange r opname) paramDescs retD opname <- do ctxt <- ask when (Map.member opname (operators ctxt)) $ - throwError (AlreadyDeclaredOperator r opname) + throwComplaint r (AlreadyDeclaredOperator opname) pure (Operator opname) syndecls <- gets (Map.keys . syntaxCats) (objName, objBinder) <- case objName of @@ -403,17 +403,17 @@ checkCompatiblePlaces places inputs outputs = do let citizenNames = [x | (x, CitizenPlace) <- places] let inputNames = map fst inputs let outputNames = map fst outputs - whenLeft (allUnique names) $ \ a -> throwError $ DuplicatedPlace (getRange a) a + whenLeft (allUnique names) $ \ a -> throwComplaint a $ DuplicatedPlace a inputNamesSet <- case allUnique inputNames of - Left a -> throwError $ DuplicatedInput (getRange a) a + Left a -> throwComplaint a $ DuplicatedInput a Right as -> pure as outputNamesSet <- case allUnique outputNames of - Left a -> throwError $ DuplicatedOutput (getRange a) a + Left a -> throwComplaint a $ DuplicatedOutput a Right as -> pure as whenCons (Set.toList (Set.intersection inputNamesSet outputNamesSet)) $ \ a _ -> - throwError $ BothInputOutput (getRange a) a + throwComplaint a $ BothInputOutput a whenCons (mismatch citizenNames inputNames outputNames) $ \ (v, m) _ -> - throwError (ProtocolCitizenSubjectMismatch (getRange v) v m) + throwComplaint v (ProtocolCitizenSubjectMismatch v m) where mismatch :: [Variable] -> [Variable] @@ -458,12 +458,12 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do IsJudgement{..} <- isJudgement name xs <- case halfZip (getProtocol judgementProtocol) fms of Just xs -> pure xs - Nothing -> throwError $ JudgementWrongArity r judgementName judgementProtocol fms + Nothing -> throwComplaint r $ JudgementWrongArity judgementName judgementProtocol fms let ys = [ (fm, sem) | ((Subject _, sem), fm) <- xs ] forM ys $ \case -- TODO: should use something like `isSendableSubject` (CFormula (These _ (Var r x)), sem) -> pure (x, sem) - (x, _) -> throwError $ UnexpectedNonSubject r x + (x, _) -> throwComplaint r $ UnexpectedNonSubject x citizenJudgement :: [(Variable, ASemanticsDesc)] -> [(Variable, ASemanticsDesc)] -> CPlace -> Elab (PROTOCOLENTRY Abstract, Map Variable CSyntaxDesc) @@ -484,7 +484,7 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do kindify m op | Var _ x <- objDesc op , Just syn <- Map.lookup x m = pure (op { objDesc = syn}) - | otherwise = throwError (MalformedPostOperator (getRange (objDesc op)) (theValue (opName op)) (Map.keys m)) + | otherwise = throwComplaint (objDesc op) (MalformedPostOperator (theValue (opName op)) (Map.keys m)) -} sopelims0 :: (ASemanticsDesc, ACTm) @@ -545,7 +545,7 @@ sopelims opelimz (ty, t) ((op, args):opelims) = do ((p, t), dat) <- sparamSemantics binder B0 (discharge ovs desc) rp local (setHeadUpData dat) $ fmap (bimap (p:) (t:)) <$> spats r bs rps rdesc - spats r bs rps rdesc = throwError $ ArityMismatchInOperator r + spats r bs rps rdesc = throwComplaint r $ ArityMismatchInOperator {- -- | sopargs desc cops @@ -569,7 +569,7 @@ sopargs desc ((rop, args):xs) = do r <- pure $ case (ds, ps) of ([], (_:_)) -> foldMap getRange ps _ -> r - throwError (InvalidOperatorArity r (theValue rop) ds ps) + throwComplaint r (InvalidOperatorArity (theValue rop) ds ps) -} freshenOp :: AAnOperator -> Elab AAnOperator @@ -591,7 +591,7 @@ soperator :: COperator -> Elab AAnOperator soperator (WithRange r tag) = do ops <- asks operators case Map.lookup tag ops of - Nothing -> throwError (NotAValidOperator r tag) + Nothing -> throwComplaint r (NotAValidOperator tag) Just anop -> pure anop scommands :: [CCommand] -> Elab [ACommand] @@ -601,7 +601,9 @@ scommands (c:cs) = do cs <- local (setGlobals ds) $ scommands cs pure (c:cs) -elaborate :: Options -> [CCommand] -> Either (WithStackTrace Complaint) ([WithStackTrace Warning], [ACommand], SyntaxTable) +elaborate :: Options -> [CCommand] + -> Either (WithStackTrace (WithRange Complaint)) + ([WithStackTrace Warning], [ACommand], SyntaxTable) elaborate opts ccs = evalElab opts $ do acs <- scommands ccs st <- get diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index d89cab2..89fe4c5 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -102,7 +102,7 @@ whatComm m d = case m of isFresh :: Variable -> Elab String isFresh x = do res <- resolve x - whenJust res $ \ _ -> throwError (VariableShadowing (getRange x) x) + whenJust res $ \ _ -> throwComplaint x (VariableShadowing x) pure (getVariable x) spassport :: Usage -> IsSubject -> Passport @@ -119,16 +119,16 @@ svar usage x = do Just th -> do logUsage (getVariable x) usage pure (isSub, desc, ActorMeta (spassport usage isSub) (getVariable x) $: sbstW (sbst0 0) th) - Nothing -> throwError (MetaScopeTooBig (getRange x) x sc ovs) - _ -> throwError (NotAValidTermVariable (getRange x) x k) + Nothing -> throwComplaint x (MetaScopeTooBig x sc ovs) + _ -> throwComplaint x (NotAValidTermVariable x k) Just (AnObjVar desc i) -> pure (IsNotSubject, desc, var i (scopeSize ovs)) - Nothing -> throwError (OutOfScope (getRange x) x) + Nothing -> throwComplaint x (OutOfScope x) spop :: Range -> Elab (ObjVars, (Variable, ASemanticsDesc)) spop r = do ovs <- asks objVars case getObjVars ovs of - B0 -> throwError (EmptyContext r) + B0 -> throwComplaint r EmptyContext (xz :< ObjVar x cat) -> pure (ObjVars xz, (Variable r x, cat)) ssyntaxdesc :: [SyntaxCat] -> Raw -> Elab SyntaxDesc @@ -161,13 +161,13 @@ ssbst usage B0 = do ssbst usage (sg :< sgc) = case sgc of Keep r v -> do (xz, (w, cat)) <- spop r - when (v /= w) $ throwError (NotTopVariable r v w) + when (v /= w) $ throwComplaint r (NotTopVariable v w) (sg, ovs) <- local (setObjVars xz) (ssbst usage sg) pure (sbstW sg (ones 1), ovs <: ObjVar (getVariable w) cat) -- TODO : worry about dropped things ocurring in types Drop r v -> do (xz, (w, cat)) <- spop r - when (v /= w) $ throwError (NotTopVariable r v w) + when (v /= w) $ throwComplaint r (NotTopVariable v w) (sg, ovs) <- local (setObjVars xz) (ssbst usage sg) pure (weak sg, ovs) Assign r v t -> do @@ -187,10 +187,10 @@ sth (Restriction ovs th) (xz, b) = do stms :: Usage -> [ASemanticsDesc] -> Raw -> Elab ACTm stms usage [] (At r "") = atom "" <$> asks (scopeSize . objVars) -stms usage [] (At r a) = throwError (ExpectedNilGot r a) -stms usage [] t = throwError (ExpectedANilGot (getRange t) t) +stms usage [] (At r a) = throwComplaint r (ExpectedNilGot a) +stms usage [] t = throwComplaint t (ExpectedANilGot t) stms usage (d:ds) (Cons r p q) = (%) <$> stm usage d p <*> stms usage ds q -stms usage _ t = throwError (ExpectedAConsGot (getRange t) t) +stms usage _ t = throwComplaint t (ExpectedAConsGot t) sscrutinee :: CScrutinee -> Elab (EScrutinee, AScrutinee) sscrutinee (SubjectVar r v) = do @@ -199,7 +199,7 @@ sscrutinee (SubjectVar r v) = do (isSub, desc, actm) <- svar (Scrutinised r) v case (isSub, actm) of (IsSubject{}, CdB (m :$ sg) _) -> pure (SubjectVar r desc, SubjectVar r actm) - _ -> throwError (NotAValidSubjectVar r v) + _ -> throwComplaint r (NotAValidSubjectVar v) sscrutinee (Pair r sc1 sc2) = do (esc1, asc1) <- sscrutinee sc1 (esc2, asc2) <- sscrutinee sc2 @@ -294,11 +294,11 @@ spatSemantics desc rest (VarP r v) = during (PatternVariableElaboration v) $ do case res of Just (AnObjVar desc' i) -> do i <- case thickx th i of -- TODO: do we need to check whether desc' is thickenable? - Nothing -> throwError (OutOfScope r v) + Nothing -> throwComplaint r (OutOfScope v) Just i -> pure i compatibleInfos (getRange v) (Known desc) (Known desc') pure (VP i, ds, var i scp) - Just mk -> throwError (NotAValidPatternVariable r v mk) + Just mk -> throwComplaint r (NotAValidPatternVariable v mk) Nothing -> do (ovs, asot) <- thickenedASOT r th desc v <- pure (getVariable v) @@ -309,17 +309,17 @@ spatSemantics desc rest rp = do dat <- asks headUpData ds <- asks declarations case Semantics.expand table dat desc of - Nothing -> throwError (InvalidSemanticsDesc (getRange rp) desc) + Nothing -> throwComplaint rp (InvalidSemanticsDesc desc) Just vdesc -> case rp of AtP r a -> do case vdesc of VAtom _ -> pure () - VAtomBar _ as -> when (a `elem` as) $ throwError (GotBarredAtom r a as) - VNil _ -> unless (a == "") $ throwError (ExpectedNilGot r a) - VNilOrCons{} -> unless (a == "") $ throwError (ExpectedNilGot r a) - VEnumOrTag sc es _ -> unless (a `elem` es) $ throwError (ExpectedEnumGot r es a) + VAtomBar _ as -> when (a `elem` as) $ throwComplaint r (GotBarredAtom a as) + VNil _ -> unless (a == "") $ throwComplaint r (ExpectedNilGot a) + VNilOrCons{} -> unless (a == "") $ throwComplaint r (ExpectedNilGot a) + VEnumOrTag sc es _ -> unless (a `elem` es) $ throwComplaint r (ExpectedEnumGot es a) VWildcard sc -> pure () - _ -> throwError (SyntaxPError r desc rp) + _ -> throwComplaint r (SyntaxPError desc rp) pure (AP a, ds, atom a (weeEnd (restriction rest))) ConsP r p1 p2 -> do descs <- case vdesc of @@ -327,7 +327,7 @@ spatSemantics desc rest rp = do VCons d1 d2 -> pure (Left (d1, d2)) VWildcard _ -> pure (Left (desc, desc)) VEnumOrTag _ _ ds -> pure (Right ds) - _ -> throwError (SyntaxPError r desc rp) + _ -> throwComplaint r (SyntaxPError desc rp) case descs of Left (d1, d2) -> do (p1, ds, t1) <- spatSemantics d1 rest p1 @@ -335,18 +335,18 @@ spatSemantics desc rest rp = do pure (PP p1 p2, ds, t1 % t2) Right ds -> case p1 of AtP r a -> case lookup a ds of - Nothing -> throwError (ExpectedTagGot r (fst <$> ds) a) + Nothing -> throwComplaint r (ExpectedTagGot (fst <$> ds) a) Just descs -> do (p1, ds, t1) <- spatSemantics (atom "Atom" 0) rest p1 (p2, ds, t2) <- local (setDecls ds) (spatSemanticss descs rest p2) pure (PP p1 p2, ds, t1 % t2) - _ -> throwError (SyntaxPError r desc rp) + _ -> throwComplaint r (SyntaxPError desc rp) LamP r (Scope v@(Hide x) p) -> do (s, desc) <- case vdesc of VWildcard _ -> pure (desc, desc) VBind cat desc -> pure (Semantics.catToDesc cat, desc) - _ -> throwError (SyntaxPError r desc rp) + _ -> throwComplaint r (SyntaxPError desc rp) -- TODO: refactor using Dischargeable case x of Unused -> do @@ -362,20 +362,20 @@ spatSemanticss :: [ASemanticsDesc] -> RawP -> Elab (Pat, Decls, ACTm) spatSemanticss [] rest (AtP r "") = (AP "",, atom "" (weeEnd (restriction rest))) <$> asks declarations -spatSemanticss [] rest (AtP r a) = throwError (ExpectedNilGot r a) -spatSemanticss [] rest t = throwError (ExpectedANilPGot (getRange t) t) +spatSemanticss [] rest (AtP r a) = throwComplaint r (ExpectedNilGot a) +spatSemanticss [] rest t = throwComplaint t (ExpectedANilPGot t) spatSemanticss (d:ds) rest (ConsP r p ps) = do (p, decls, t) <- spatSemantics d rest p (ps, decls, ts) <- local (setDecls decls) $ spatSemanticss ds rest ps pure (PP p ps, decls, t % ts) -spatSemanticss _ rest t = throwError (ExpectedAConsPGot (getRange t) t) +spatSemanticss _ rest t = throwComplaint t (ExpectedAConsPGot t) isList :: Raw -> Elab [Raw] isList (At r "") = pure [] -isList (At r a) = throwError (ExpectedNilGot r a) +isList (At r a) = throwComplaint r (ExpectedNilGot a) isList (Cons r p q) = (p:) <$> isList q -isList t = throwError (ExpectedAConsGot (getRange t) t) +isList t = throwComplaint t (ExpectedAConsGot t) -- Input: fully applied operator ready to operate -- Output: (abstract operator, raw parameters) @@ -387,7 +387,7 @@ sop (Cons rp (At ra a) ps) = do op <- isOperator ra a es <- isList ps pure (op, es) -sop ro = throwError (ExpectedAnOperator (getRange ro) ro) +sop ro = throwComplaint ro (ExpectedAnOperator ro) -- e.g. (p : ['Sig S \x.T]) -'snd -- ['MkSig a b] : ['Sig A \y.B] @@ -397,7 +397,7 @@ matchObjType r (mb , oty) (obDesc, ob) = do dat <- asks headUpData let hnf = headUp dat env <- case snd $ match hnf initMatching (Problem B0 oty obDesc) of - Left e -> throwError $ InferredDescMismatch r + Left e -> throwComplaint r $ InferredDescMismatch Right m -> pure $ matchingToEnv m (huEnv dat) env <- case mb of Nothing -> pure env @@ -417,7 +417,7 @@ itm usage (Op r rob rop) = do (desc, ps) <- itms r usage paramsDesc rps retDesc pure (desc, ob -% (getOperator opName, ps)) -- TODO?: annotated terms? -itm _ t = throwError $ DontKnowHowToInferDesc (getRange t) t +itm _ t = throwComplaint t $ DontKnowHowToInferDesc t itms :: Range -> Usage -- Parameters types e.g. (_ : 'Nat\n. {m = n}p\ih. {m = ['Succ n]}p) @@ -435,7 +435,7 @@ itms r usage ((binder, sot):bs) (rp:rps) rdesc = do (p, dat) <- sparam usage binder B0 (discharge ovs desc) rp local (setHeadUpData dat) $ fmap (p:) <$> itms r usage bs rps rdesc -itms r usage bs rps rdesc = throwError $ ArityMismatchInOperator r +itms r usage bs rps rdesc = throwComplaint r $ ArityMismatchInOperator sparam :: Usage -> Maybe ActorMeta -- Name of parameter @@ -457,7 +457,7 @@ sparam usage binder namez (Stop pdesc) rp = do pure (p, dat) sparam usage binder namez (Tele desc (Scope (Hide name) tele)) (Lam r (Scope (Hide x) rp)) = elabUnder (x, desc) $ sparam usage binder (namez :< name) tele rp -sparam _ _ _ _ rp = throwError $ ExpectedParameterBinding (getRange rp) rp +sparam _ _ _ _ rp = throwComplaint rp $ ExpectedParameterBinding rp instantiateSOT :: Range -> ASOT -> Elab ASOT instantiateSOT r (ovs :=> desc) @@ -469,7 +469,7 @@ instantiateDesc r desc = do -- The object acted upon and the parameters appearing before the -- one currently being elaborated need to be substituted into the desc case mangleActors (huOptions dat) (huEnv dat) desc of - Nothing -> throwError $ SchematicVariableNotInstantiated r + Nothing -> throwComplaint r $ SchematicVariableNotInstantiated Just v -> pure v @@ -482,7 +482,7 @@ sasot r (objVars :=> desc) = do -- The object acted upon and the parameters appearing before the -- one currently being elaborated need to be substituted into the SOT case mangleActors (huOptions dat) (huEnv dat) desc of - Nothing -> throwError $ SchematicVariableNotInstantiated r + Nothing -> throwComplaint r $ SchematicVariableNotInstantiated r Just v -> pure v -- TODO: foldr (\ (x,t) v => ['Bind t \x.v]) id v -} @@ -500,19 +500,19 @@ stm usage desc rt = do table <- gets syntaxCats dat <- asks headUpData case Semantics.expand table dat desc of - Nothing -> throwError (InvalidSemanticsDesc (getRange rt) desc) + Nothing -> throwComplaint rt (InvalidSemanticsDesc desc) Just vdesc -> case rt of At r a -> do case vdesc of VAtom _ -> pure () - VAtomBar _ as -> when (a `elem` as) $ throwError (GotBarredAtom r a as) - VNil _ -> unless (a == "") $ throwError (ExpectedNilGot r a) - VNilOrCons{} -> unless (a == "") $ throwError (ExpectedNilGot r a) - VEnumOrTag _ es _ -> unless (a `elem` es) $ throwError (ExpectedEnumGot r es a) + VAtomBar _ as -> when (a `elem` as) $ throwComplaint r (GotBarredAtom a as) + VNil _ -> unless (a == "") $ throwComplaint r (ExpectedNilGot a) + VNilOrCons{} -> unless (a == "") $ throwComplaint r (ExpectedNilGot a) + VEnumOrTag _ es _ -> unless (a `elem` es) $ throwComplaint r (ExpectedEnumGot es a) VWildcard _ -> pure () - VUniverse _ -> unless (a `elem` ("Semantics" : Map.keys table)) $ throwError (ExpectedASemanticsGot r rt) + VUniverse _ -> unless (a `elem` ("Semantics" : Map.keys table)) $ throwComplaint r (ExpectedASemanticsGot rt) -- TODO we're probably missing semantics here - _ -> throwError (SemanticsError r desc rt) + _ -> throwComplaint r (SemanticsError desc rt) satom a Cons r p q -> case vdesc of VNilOrCons d1 d2 -> (%) <$> stm usage d1 p <*> stm usage d2 q @@ -520,22 +520,22 @@ stm usage desc rt = do VWildcard _ -> (%) <$> stm usage desc p <*> stm usage desc q VEnumOrTag _ _ ds -> case p of At r a -> case lookup a ds of - Nothing -> throwError (ExpectedTagGot r (fst <$> ds) a) + Nothing -> throwComplaint r (ExpectedTagGot (fst <$> ds) a) Just descs -> (%) <$> stm usage (atom "Atom" 0) p <*> stms usage descs q - _ -> throwError (SyntaxError r desc rt) + _ -> throwComplaint r (SyntaxError desc rt) VUniverse _ -> case (p , q) of (At _ "Pi", Cons _ s (Cons _ (Lam _ (Scope (Hide x) t)) (At _ ""))) -> do s <- sty s t <- elabUnder (x, s) $ sty t pure ("Pi" #%+ [s, t]) - _ -> throwError (ExpectedASemanticsGot r rt) - _ -> throwError (SyntaxError r desc rt) + _ -> throwComplaint r (ExpectedASemanticsGot rt) + _ -> throwComplaint r (SyntaxError desc rt) Lam r (Scope (Hide x) sc) -> do (s, desc) <- case vdesc of VWildcard i -> pure (desc, desc) VBind cat desc -> pure (catToDesc cat, desc) VPi s (y, t) -> pure (s, t) - _ -> throwError (SyntaxError r desc rt) + _ -> throwComplaint r (SyntaxError desc rt) elabUnder (x, s) $ stm usage desc sc Op{} -> do (tdesc, t) <- itm usage rt @@ -551,13 +551,13 @@ elabUnder (x, desc) ma = do spats :: IsSubject -> [ASemanticsDesc] -> Restriction -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) spats _ [] rest (AtP r "") = (Nothing, AP "",,) <$> asks declarations <*> asks binderHints -spats _ [] rest (AtP r a) = throwError (ExpectedNilGot r a) -spats _ [] rest t = throwError (ExpectedANilPGot (getRange t) t) +spats _ [] rest (AtP r a) = throwComplaint r (ExpectedNilGot a) +spats _ [] rest t = throwComplaint t (ExpectedANilPGot t) spats isSub (d:ds) rest (ConsP r p q) = do (mr1, p, decls, hints) <- spatBase isSub d rest p (mr2, q, decls, hints) <- local (setDecls decls . setHints hints) $ spats isSub ds rest q pure (mr1 <|> mr2, PP p q, decls, hints) -spats _ _ rest t = throwError (ExpectedAConsPGot (getRange t) t) +spats _ _ rest t = throwComplaint t (ExpectedAConsPGot t) -- Inputs: -- 0. Elaborated scrutinee -- description of how the scrutinee we are @@ -573,7 +573,7 @@ spats _ _ rest t = throwError (ExpectedAConsPGot (getRange t) t) spat :: EScrutinee -> Restriction -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) spat esc rest rp@(AsP r v p) = do unless (isSubjectFree esc) $ - throwError (AsPatternCannotHaveSubjects r rp) + throwComplaint r (AsPatternCannotHaveSubjects rp) let desc = escrutinee esc v <- isFresh v ds <- asks declarations @@ -594,7 +594,7 @@ spat esc@(Pair r esc1 esc2) rest rp = case rp of (mr1, p, ds, hs) <- spat esc1 rest p (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spat esc2 rest q) pure (mr1 <|> mr2, PP p q, ds, hs) - _ -> throwError (SyntaxPError (getRange rp) (escrutinee esc) rp) + _ -> throwComplaint rp (SyntaxPError (escrutinee esc) rp) spat (SubjectVar r desc) rest rp = spatBase (IsSubject Pattern) desc rest rp spat esc@(Lookup _ _ av) rest rp@(ConsP r (AtP _ "Just") (ConsP _ _ (AtP _ ""))) = do logUsage av (SuccessfullyLookedUp r) @@ -607,17 +607,17 @@ thickenedASOT :: Range -> Th -> ASemanticsDesc -> Elab (ObjVars, ASOT) thickenedASOT r th desc = do ovs <- asks objVars ovs <- case thickenObjVars th ovs of - Nothing -> throwError (NotAValidContextRestriction r th ovs) + Nothing -> throwComplaint r (NotAValidContextRestriction th ovs) Just ovs -> pure ovs desc <- case thickenCdB th desc of - Nothing -> throwError (NotAValidDescriptionRestriction r th desc) + Nothing -> throwComplaint r (NotAValidDescriptionRestriction th desc) Just desc -> pure desc pure (ovs, ovs :=> desc) spatBase :: IsSubject -> ASemanticsDesc -> Restriction -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) spatBase isSub desc rest rp@(AsP r v p) = do unless (isSub == IsNotSubject) $ - throwError (AsPatternCannotHaveSubjects r rp) + throwComplaint r (AsPatternCannotHaveSubjects rp) v <- isFresh v ds <- asks declarations (ovs, asot) <- thickenedASOT r (restriction rest) desc @@ -635,11 +635,11 @@ spatBase isSub desc rest (VarP r v) = during (PatternVariableElaboration v) $ do case res of Just (AnObjVar desc' i) -> do i <- case thickx th i of -- TODO: do we need to check whether desc' is thickenable? - Nothing -> throwError (OutOfScope r v) + Nothing -> throwComplaint r (OutOfScope v) Just i -> pure i compatibleInfos (getRange v) (Known desc) (Known desc') pure (Nothing, VP i, ds, hs) - Just mk -> throwError (NotAValidPatternVariable r v mk) + Just mk -> throwComplaint r (NotAValidPatternVariable v mk) Nothing -> do (ovs, asot) <- thickenedASOT r th desc v <- pure (getVariable v) @@ -654,17 +654,17 @@ spatBase isSub desc rest rp = do table <- gets syntaxCats dat <- asks headUpData case Semantics.expand table dat desc of - Nothing -> throwError (InvalidSemanticsDesc (getRange rp) desc) + Nothing -> throwComplaint rp (InvalidSemanticsDesc desc) Just vdesc -> case rp of AtP r a -> do case vdesc of VAtom _ -> pure () - VAtomBar _ as -> when (a `elem` as) $ throwError (GotBarredAtom r a as) - VNil _ -> unless (a == "") $ throwError (ExpectedNilGot r a) - VNilOrCons{} -> unless (a == "") $ throwError (ExpectedNilGot r a) - VEnumOrTag sc es _ -> unless (a `elem` es) $ throwError (ExpectedEnumGot r es a) + VAtomBar _ as -> when (a `elem` as) $ throwComplaint r (GotBarredAtom a as) + VNil _ -> unless (a == "") $ throwComplaint r (ExpectedNilGot a) + VNilOrCons{} -> unless (a == "") $ throwComplaint r (ExpectedNilGot a) + VEnumOrTag sc es _ -> unless (a `elem` es) $ throwComplaint r (ExpectedEnumGot es a) VWildcard sc -> pure () - _ -> throwError (SyntaxPError r desc rp) + _ -> throwComplaint r (SyntaxPError desc rp) (Nothing, AP a,,) <$> asks declarations <*> asks binderHints ConsP r p q -> case vdesc of @@ -682,19 +682,19 @@ spatBase isSub desc rest rp = do pure (mr1 <|> mr2, PP p q, ds, hs) VEnumOrTag _ _ ds -> case p of AtP r a -> case lookup a ds of - Nothing -> throwError (ExpectedTagGot r (fst <$> ds) a) + Nothing -> throwComplaint r (ExpectedTagGot (fst <$> ds) a) Just descs -> do (mr1, p, ds, hs) <- spatBase isSub (atom "Atom" 0) rest p (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spats isSub descs rest q) pure (mr1 <|> mr2, PP p q, ds, hs) - _ -> throwError (SyntaxPError r desc rp) - _ -> throwError (SyntaxPError r desc rp) + _ -> throwComplaint r (SyntaxPError desc rp) + _ -> throwComplaint r (SyntaxPError desc rp) LamP r (Scope v@(Hide x) p) -> do (s, desc) <- case vdesc of VWildcard _ -> pure (desc, desc) VBind cat desc -> pure (Semantics.catToDesc cat, desc) - _ -> throwError (SyntaxPError r desc rp) + _ -> throwComplaint r (SyntaxPError desc rp) case x of Unused -> do @@ -710,21 +710,21 @@ spatBase isSub desc rest rp = do isObjVar :: Variable -> Elab (ASemanticsDesc, DB) isObjVar p = resolve p >>= \case Just (AnObjVar desc i) -> pure (desc, i) - Just mk -> throwError $ NotAValidPatternVariable (getRange p) p mk - Nothing -> throwError $ OutOfScope (getRange p) p + Just mk -> throwComplaint p $ NotAValidPatternVariable p mk + Nothing -> throwComplaint p $ OutOfScope p isChannel :: Variable -> Elab Channel isChannel ch = resolve ch >>= \case Just (ADeclaration (AChannel sc)) -> pure (Channel $ getVariable ch) - Just mk -> throwError (NotAValidChannel (getRange ch) ch mk) - Nothing -> throwError (OutOfScope (getRange ch) ch) + Just mk -> throwComplaint ch (NotAValidChannel ch mk) + Nothing -> throwComplaint ch (OutOfScope ch) isOperator :: Range -> String -> Elab AAnOperator isOperator r nm = do ops <- asks operators case Map.lookup nm ops of Just res -> pure res - Nothing -> throwError (NotAValidOperator r nm) + Nothing -> throwComplaint r (NotAValidOperator nm) data IsJudgement = IsJudgement { judgementExtract :: ExtractMode @@ -735,14 +735,14 @@ data IsJudgement = IsJudgement isJudgement :: Variable -> Elab IsJudgement isJudgement jd = resolve jd >>= \case Just (ADeclaration (AJudgement em p)) -> pure (IsJudgement em (getVariable jd) p) - Just mk -> throwError (NotAValidJudgement (getRange jd) jd mk) - Nothing -> throwError (OutOfScope (getRange jd) jd) + Just mk -> throwComplaint jd (NotAValidJudgement jd mk) + Nothing -> throwComplaint jd (OutOfScope jd) isContextStack :: Variable -> Elab (Stack, AContextStack) isContextStack stk = resolve stk >>= \case Just (ADeclaration (AStack stkTy)) -> pure (Stack (getVariable stk), stkTy) - Just mk -> throwError (NotAValidStack (getRange stk) stk mk) - Nothing -> throwError (OutOfScope (getRange stk) stk) + Just mk -> throwComplaint stk (NotAValidStack stk mk) + Nothing -> throwComplaint stk (OutOfScope stk) channelScope :: Channel -> Elab ObjVars @@ -757,7 +757,7 @@ steppingChannel :: Range -> Channel steppingChannel r ch step = do nm <- getName (dir, pnm, p) <- gets (fromJust . channelLookup ch) - unless (pnm `isPrefixOf` nm) $ throwError (NonLinearChannelUse r ch) + unless (pnm `isPrefixOf` nm) $ throwComplaint r (NonLinearChannelUse ch) (cat, p) <- step dir p modify (channelInsert ch (dir, nm, p)) pure cat @@ -775,7 +775,7 @@ close b r ch = do [] -> pure () _ -> when b $ -- if we cannot win, we don't care - throwError (UnfinishedProtocol r ch (Protocol ps)) + throwComplaint r (UnfinishedProtocol ch (Protocol ps)) modify (channelDelete ch) withChannel :: Range -> Direction -> Channel -> AProtocol -> Elab a -> Elab a @@ -810,15 +810,15 @@ compatibleChannels :: Range -> Elab Int compatibleChannels r (dp, []) dir (dq, []) = pure 0 compatibleChannels r (dp, p@(m, s) : ps) dir (dq, q@(n, t) : qs) = do - unless (s == t) $ throwError (IncompatibleSemanticsDescs r s t) + unless (s == t) $ throwComplaint r (IncompatibleSemanticsDescs s t) let (cp , cq) = (whatComm m dp, whatComm n dq) - when (cp == cq) $ throwError (IncompatibleModes r p q) + when (cp == cq) $ throwComplaint r (IncompatibleModes p q) case (cp, dir) of - (RECV, LT) -> throwError (WrongDirection r p dir q) - (SEND, GT) -> throwError (WrongDirection r p dir q) + (RECV, LT) -> throwComplaint r (WrongDirection p dir q) + (SEND, GT) -> throwComplaint r (WrongDirection p dir q) _ -> pure () (+1) <$> compatibleChannels r (dp, ps) dir (dq , qs) -compatibleChannels r (_,ps) _ (_,qs) = throwError (ProtocolsNotDual r (Protocol ps) (Protocol qs)) +compatibleChannels r (_,ps) _ (_,qs) = throwComplaint r (ProtocolsNotDual (Protocol ps) (Protocol qs)) sirrefutable :: String -> IsSubject -> RawP -> Elab (Binder String, Maybe (CScrutinee, RawP)) sirrefutable nm isSub = \case @@ -880,7 +880,7 @@ sact = \case -- Check the channel is in sending mode, & step it (m, desc) <- steppingChannel r ch $ \ dir -> \case (m, desc) : p | whatComm m dir == SEND -> pure ((m, desc), p) - _ -> throwError (InvalidSend r ch tm) + _ -> throwComplaint r (InvalidSend ch tm) (usage, gd) <- do case m of @@ -913,7 +913,7 @@ sact = \case -- Check the channel is in receiving mode & step it (m, cat) <- steppingChannel r ch $ \ dir -> \case (m, cat) : p | whatComm m dir == RECV -> pure ((m, cat), p) - _ -> throwError (InvalidRecv r ch p) + _ -> throwComplaint r (InvalidRecv ch p) -- TODO: m contains a SyntaxDesc when it's a subject position -- Why do we throw it away? Shouldn't it be stored & @@ -953,7 +953,7 @@ sact = \case (Just thl, Just thr) -> pure (EQ, thl) (Just thl, _) -> pure (LT, thl) (_, Just thr) -> pure (GT, thr) - _ -> throwError (IncompatibleChannelScopes r sc1 sc2) + _ -> throwComplaint r (IncompatibleChannelScopes sc1 sc2) steps <- compatibleChannels r p dir q pure (aconnect r ch1 th ch2 steps) @@ -1024,7 +1024,7 @@ consistentCommunication r sts = case List.groupBy ((==) `on` fmap (\ (_,_,x) -> x)) sts of [] -> tell (All False) -- all branches are doomed, we don't care [(c:_)] -> modify (\ r -> r { channelStates = c }) - _ -> throwError (InconsistentCommunication r) + _ -> throwComplaint r InconsistentCommunication consistentScrutinisation :: Range -> [ActvarStates] -> Elab () consistentScrutinisation r sts = do @@ -1062,7 +1062,7 @@ sbranch r ds ra = do st <- get unless b $ unless (chs == channelStates st) $ - throwError (DoomedBranchCommunicated (getRange ra) ra) + throwComplaint ra (DoomedBranchCommunicated ra) put (st { channelStates = chs }) pure (a, ((,) <$> channelStates <*> actvarStates) st <$ guard b ) diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 8bded19..1733ab5 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -84,24 +84,27 @@ newtype Elab a = Elab { runElab :: StateT ElabState (ReaderT Context (WriterT All -- Can we win? - (Either (WithStackTrace Complaint)))) + (Either (WithStackTrace (WithRange Complaint))))) a } deriving ( Functor, Applicative, Monad , MonadReader Context , MonadState ElabState , MonadWriter All) -instance MonadError Complaint Elab where +instance MonadError (WithRange Complaint) Elab where throwError err = do stk <- asks stackTrace Elab (throwError (WithStackTrace stk err)) catchError ma k = Elab (catchError (runElab ma) (runElab . k . theMessage)) -evalElab :: Options -> Elab a -> Either (WithStackTrace Complaint) a +throwComplaint :: HasGetRange a => a -> Complaint -> Elab b +throwComplaint r c = throwError (WithRange (getRange r) c) + +evalElab :: Options -> Elab a -> Either (WithStackTrace (WithRange Complaint)) a evalElab opts = fmap fst . runWriterT - . (`runReaderT` (initContext opts)) + . (`runReaderT` initContext opts) . (`evalStateT` initElabState) . runElab @@ -122,7 +125,7 @@ fromInfo r (Known desc) = pure desc -- places: -- 1. `addHint` (and if we had a clash, that'd be a shadowing error) -- 2. `compatibleInfos` where the error is handled locally -fromInfo r Inconsistent = throwError (InconsistentSyntaxDesc r) +fromInfo r Inconsistent = throwComplaint r InconsistentSyntaxDesc compatibleInfos :: Range -> Info ASemanticsDesc -> Info ASemanticsDesc -> Elab (Info ASemanticsDesc) compatibleInfos r desc desc' = do @@ -131,7 +134,9 @@ compatibleInfos r desc desc' = do let de = infoExpand dat table =<< desc let de' = infoExpand dat table =<< desc' case de <> de' of - Inconsistent -> throwError (IncompatibleSemanticsInfos r desc desc') + Inconsistent -> throwComplaint r $ case (desc, desc') of + (Known desc, Known desc') -> IncompatibleSemanticsDescs desc desc' + _ -> IncompatibleSemanticsInfos desc desc' d -> pure $ case (desc, desc') of (Known (CdB (A _) _), _) -> desc (_, Known (CdB (A _) _)) -> desc' @@ -421,154 +426,79 @@ data ContextualInfo data Complaint -- scope - = OutOfScope Range Variable - | MetaScopeTooBig Range Variable ObjVars ObjVars - | VariableShadowing Range Variable - | EmptyContext Range - | NotTopVariable Range Variable Variable - | IncompatibleChannelScopes Range ObjVars ObjVars - | NotAValidContextRestriction Range Th ObjVars - | NotAValidDescriptionRestriction Range Th ASemanticsDesc + = OutOfScope Variable + | MetaScopeTooBig Variable ObjVars ObjVars + | VariableShadowing Variable + | EmptyContext + | NotTopVariable Variable Variable + | IncompatibleChannelScopes ObjVars ObjVars + | NotAValidContextRestriction Th ObjVars + | NotAValidDescriptionRestriction Th ASemanticsDesc -- kinding - | NotAValidTermVariable Range Variable Kind - | NotAValidPatternVariable Range Variable Resolved - | NotAValidJudgement Range Variable Resolved - | NotAValidStack Range Variable Resolved - | NotAValidChannel Range Variable Resolved - | NotAValidBoundVar Range Variable - | NotAValidSubjectVar Range Variable - | NotAValidOperator Range String + | NotAValidTermVariable Variable Kind + | NotAValidPatternVariable Variable Resolved + | NotAValidJudgement Variable Resolved + | NotAValidStack Variable Resolved + | NotAValidChannel Variable Resolved + | NotAValidBoundVar Variable + | NotAValidSubjectVar Variable + | NotAValidOperator String -- operators - | AlreadyDeclaredOperator Range String - | InvalidOperatorArity Range String [SyntaxDesc] [RawP] - | ExpectedParameterBinding Range Raw + | AlreadyDeclaredOperator String + | InvalidOperatorArity String [SyntaxDesc] [RawP] + | ExpectedParameterBinding Raw -- protocol - | InvalidSend Range Channel Raw - | InvalidRecv Range Channel RawP - | NonLinearChannelUse Range Channel - | UnfinishedProtocol Range Channel AProtocol - | InconsistentCommunication Range - | DoomedBranchCommunicated Range CActor - | ProtocolsNotDual Range AProtocol AProtocol - | IncompatibleModes Range AProtocolEntry AProtocolEntry - | WrongDirection Range AProtocolEntry Ordering AProtocolEntry + | InvalidSend Channel Raw + | InvalidRecv Channel RawP + | NonLinearChannelUse Channel + | UnfinishedProtocol Channel AProtocol + | InconsistentCommunication + | DoomedBranchCommunicated CActor + | ProtocolsNotDual AProtocol AProtocol + | IncompatibleModes AProtocolEntry AProtocolEntry + | WrongDirection AProtocolEntry Ordering AProtocolEntry -- judgementforms - | JudgementWrongArity Range JudgementName AProtocol [CFormula] - | UnexpectedNonSubject Range CFormula - | DuplicatedPlace Range Variable - | DuplicatedInput Range Variable - | DuplicatedOutput Range Variable - | BothInputOutput Range Variable - | ProtocolCitizenSubjectMismatch Range Variable (Mode ()) - | MalformedPostOperator Range String [Variable] + | JudgementWrongArity JudgementName AProtocol [CFormula] + | UnexpectedNonSubject CFormula + | DuplicatedPlace Variable + | DuplicatedInput Variable + | DuplicatedOutput Variable + | BothInputOutput Variable + | ProtocolCitizenSubjectMismatch Variable (Mode ()) + | MalformedPostOperator String [Variable] -- syntaxes - | AlreadyDeclaredSyntaxCat Range SyntaxCat + | AlreadyDeclaredSyntaxCat SyntaxCat -- syntaxdesc validation - | InconsistentSyntaxDesc Range - | InvalidSyntaxDesc Range SyntaxDesc - | IncompatibleSyntaxInfos Range (Info SyntaxDesc) (Info SyntaxDesc) - | IncompatibleSemanticsDescs Range ASemanticsDesc ASemanticsDesc - | GotBarredAtom Range String [String] - | ExpectedASemanticsGot Range Raw - | ExpectedNilGot Range String - | ExpectedEnumGot Range [String] String - | ExpectedTagGot Range [String] String - | ExpectedANilGot Range Raw - | ExpectedANilPGot Range RawP - | ExpectedAConsGot Range Raw - | ExpectedAConsPGot Range RawP - | SyntaxError Range ASemanticsDesc Raw - | SyntaxPError Range ASemanticsDesc RawP - | ExpectedAnOperator Range Raw - | ExpectedAnEmptyListGot Range String [SyntaxDesc] + | InconsistentSyntaxDesc + | InvalidSyntaxDesc SyntaxDesc + | IncompatibleSyntaxInfos (Info SyntaxDesc) (Info SyntaxDesc) + | IncompatibleSemanticsDescs ASemanticsDesc ASemanticsDesc + | GotBarredAtom String [String] + | ExpectedASemanticsGot Raw + | ExpectedNilGot String + | ExpectedEnumGot [String] String + | ExpectedTagGot [String] String + | ExpectedANilGot Raw + | ExpectedANilPGot RawP + | ExpectedAConsGot Raw + | ExpectedAConsPGot RawP + | SyntaxError ASemanticsDesc Raw + | SyntaxPError ASemanticsDesc RawP + | ExpectedAnOperator Raw + | ExpectedAnEmptyListGot String [SyntaxDesc] -- semanticsdesc validation - | InvalidSemanticsDesc Range ASemanticsDesc - | SemanticsError Range ASemanticsDesc Raw - | IncompatibleSemanticsInfos Range (Info ASemanticsDesc) (Info ASemanticsDesc) + | InvalidSemanticsDesc ASemanticsDesc + | SemanticsError ASemanticsDesc Raw + | IncompatibleSemanticsInfos (Info ASemanticsDesc) (Info ASemanticsDesc) -- subjects and citizens - | AsPatternCannotHaveSubjects Range RawP + | AsPatternCannotHaveSubjects RawP -- desc inference - | InferredDescMismatch Range - | DontKnowHowToInferDesc Range Raw - | ArityMismatchInOperator Range - | SchematicVariableNotInstantiated Range + | InferredDescMismatch + | DontKnowHowToInferDesc Raw + | ArityMismatchInOperator + | SchematicVariableNotInstantiated deriving (Show) -instance HasGetRange Complaint where - getRange = \case - OutOfScope r _ -> r - MetaScopeTooBig r _ _ _ -> r - VariableShadowing r _ -> r - EmptyContext r -> r - NotTopVariable r _ _ -> r - IncompatibleChannelScopes r _ _ -> r - -- kinding - NotAValidTermVariable r _ _ -> r - NotAValidPatternVariable r _ _ -> r - NotAValidJudgement r _ _ -> r - NotAValidStack r _ _ -> r - NotAValidChannel r _ _ -> r - NotAValidBoundVar r _ -> r - NotAValidSubjectVar r _ -> r - NotAValidOperator r _ -> r - -- operators - AlreadyDeclaredOperator r _ -> r - InvalidOperatorArity r _ _ _ -> r - -- protocol - InvalidSend r _ _ -> r - InvalidRecv r _ _ -> r - NonLinearChannelUse r _ -> r - UnfinishedProtocol r _ _ -> r - InconsistentCommunication r -> r - DoomedBranchCommunicated r _ -> r - ProtocolsNotDual r _ _ -> r - IncompatibleModes r _ _ -> r - WrongDirection r _ _ _ -> r - JudgementWrongArity r _ _ _ -> r - UnexpectedNonSubject r _ -> r - DuplicatedPlace r _ -> r - DuplicatedInput r _ -> r - DuplicatedOutput r _ -> r - BothInputOutput r _ -> r - ProtocolCitizenSubjectMismatch r _ _ -> r - MalformedPostOperator r _ _ -> r - -- syntaxes - AlreadyDeclaredSyntaxCat r _ -> r - -- syntaxdesc validation - InconsistentSyntaxDesc r -> r - InvalidSyntaxDesc r _ -> r - IncompatibleSyntaxInfos r _ _ -> r - IncompatibleSemanticsDescs r _ _ -> r - GotBarredAtom r _ _ -> r - ExpectedNilGot r _ -> r - ExpectedEnumGot r _ _ -> r - ExpectedTagGot r _ _ -> r - ExpectedANilGot r _ -> r - ExpectedANilPGot r _ -> r - ExpectedAConsGot r _ -> r - ExpectedAConsPGot r _ -> r - SyntaxError r _ _ -> r - SyntaxPError r _ _ -> r - ExpectedAnOperator r _ -> r - ExpectedAnEmptyListGot r _ _ -> r - -- semantics validation - InvalidSemanticsDesc r _ -> r - SemanticsError r _ _ -> r - IncompatibleSemanticsInfos r _ _ -> r - -- subjects and citizens - AsPatternCannotHaveSubjects r _ -> r - -- desc inference - InferredDescMismatch r -> r - DontKnowHowToInferDesc r _ -> r - ArityMismatchInOperator r -> r - SchematicVariableNotInstantiated r -> r - -- TODO: categorise - NotAValidContextRestriction r _ _ -> r - NotAValidDescriptionRestriction r _ _ -> r - ExpectedParameterBinding r _ -> r - ExpectedASemanticsGot r _ -> r - - ------------------------------------------------------------------------------ -- Syntaxes @@ -576,7 +506,7 @@ declareSyntax :: WithRange SyntaxCat -> SyntaxDesc -> Elab () declareSyntax (WithRange r cat) desc = do st <- get whenJust (Map.lookup cat (syntaxCats st)) $ \ _ -> - throwError (AlreadyDeclaredSyntaxCat r cat) + throwComplaint r (AlreadyDeclaredSyntaxCat cat) put (st { syntaxCats = Map.insert cat desc (syntaxCats st) }) withSyntax :: SyntaxDesc -> Elab a -> Elab a diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index ce0f4e1..04a787f 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -106,127 +106,129 @@ instance Pretty ContextualInfo where JudgementFormElaboration v -> hsep ["when elaborating the judgement form", pretty v] instance Pretty Complaint where - pretty c = flush (pretty (getRange c)) <> case c of + pretty c = case c of -- scope - OutOfScope r x -> hsep ["Out of scope variable", pretty x] - MetaScopeTooBig r x sc1 sc2 -> + OutOfScope x -> hsep ["Out of scope variable", pretty x] + MetaScopeTooBig x sc1 sc2 -> hsep [ "Cannot use", pretty x , "here as it is defined in too big a scope" , parens (hsep [ pretty sc1 , "won't fit in" , pretty sc2 ])] - VariableShadowing r x -> hsep [pretty x, "is already defined"] - EmptyContext r -> "Tried to pop an empty context" - NotTopVariable r x y -> + VariableShadowing x -> hsep [pretty x, "is already defined"] + EmptyContext -> "Tried to pop an empty context" + NotTopVariable x y -> hsep [ "Expected", pretty x, "to be the top variable" , "but found", pretty y, "instead"] -- kinding - NotAValidTermVariable r x k -> hsep ["Invalid term variable", pretty x, "refers to", pretty k] - NotAValidPatternVariable r x k -> hsep ["Invalid pattern variable", pretty x, "refers to", pretty k] - NotAValidJudgement r x mk -> + NotAValidTermVariable x k -> hsep ["Invalid term variable", pretty x, "refers to", pretty k] + NotAValidPatternVariable x k -> hsep ["Invalid pattern variable", pretty x, "refers to", pretty k] + NotAValidJudgement x mk -> hsep ["Invalid judgement variable", pretty x , "refers to", pretty mk] - NotAValidStack r x mk -> + NotAValidStack x mk -> hsep ["Invalid context stack variable", pretty x , "refers to", pretty mk] - NotAValidChannel r x mk -> + NotAValidChannel x mk -> hsep ["Invalid channel variable", pretty x , "refers to", pretty mk] - NotAValidBoundVar r x -> hsep ["Invalid bound variable", pretty x] - NotAValidSubjectVar r x -> hsep ["Invalid subject variable", pretty x] - NotAValidOperator r x -> hsep ["Invalid operator name", pretty x] + NotAValidBoundVar x -> hsep ["Invalid bound variable", pretty x] + NotAValidSubjectVar x -> hsep ["Invalid subject variable", pretty x] + NotAValidOperator x -> hsep ["Invalid operator name", pretty x] -- operators - AlreadyDeclaredOperator r op -> hsep ["Not a valid operator name", pretty op] - InvalidOperatorArity r op [] ops -> + AlreadyDeclaredOperator op -> hsep ["Not a valid operator name", pretty op] + InvalidOperatorArity op [] ops -> hsep ["Invalid arity:", pretty (show $ length ops), "extra operator parameters for", pretty op] - InvalidOperatorArity r op ds [] -> + InvalidOperatorArity op ds [] -> hsep ["Invalid arity:", pretty (show $ length ds), "missing operator parameters for", pretty op] - InvalidOperatorArity r op ds ps -> + InvalidOperatorArity op ds ps -> hsep ["Invalid arity (the impossible happened)"] -- protocol - InvalidSend r ch tm -> hsep ["Invalid send of", pretty tm, "on channel", pretty ch] - InvalidRecv r ch v -> hsep ["Invalid receive of", pretty v, "on channel", pretty ch] - NonLinearChannelUse r ch -> hsep ["Non linear use of channel", pretty ch] - UnfinishedProtocol r ch p -> + InvalidSend ch tm -> hsep ["Invalid send of", pretty tm, "on channel", pretty ch] + InvalidRecv ch v -> hsep ["Invalid receive of", pretty v, "on channel", pretty ch] + NonLinearChannelUse ch -> hsep ["Non linear use of channel", pretty ch] + UnfinishedProtocol ch p -> hsep ["Unfinished protocol", parens (pretty p), "on channel", pretty ch] - InconsistentCommunication r -> hsep ["Inconsistent communication"] - DoomedBranchCommunicated r a -> hsep ["Doomed branch communicated", pretty a] - ProtocolsNotDual r ps qs -> hsep ["Protocols", pretty ps, "and", pretty qs, "are not dual"] - IncompatibleModes r m1 m2 -> hsep ["Modes", pretty m1, "and", pretty m2, "are incompatible"] - IncompatibleChannelScopes r sc1 sc2 -> + InconsistentCommunication -> hsep ["Inconsistent communication"] + DoomedBranchCommunicated a -> hsep ["Doomed branch communicated", pretty a] + ProtocolsNotDual ps qs -> hsep ["Protocols", pretty ps, "and", pretty qs, "are not dual"] + IncompatibleModes m1 m2 -> hsep ["Modes", pretty m1, "and", pretty m2, "are incompatible"] + IncompatibleChannelScopes sc1 sc2 -> hsep [ "Channels scopes", pretty sc1 , "and", pretty sc2, "are incompatible"] - WrongDirection r m1 dir m2 -> hsep ["Wrong direction", pretty (show dir), "between", pretty m1, "and", pretty m2] + WrongDirection m1 dir m2 -> hsep ["Wrong direction", pretty (show dir), "between", pretty m1, "and", pretty m2] -- judgementforms - JudgementWrongArity r name (Protocol protocol) fms -> + JudgementWrongArity name (Protocol protocol) fms -> let applied = (if length protocol > length fms then "under" else "over") <> "-applied" in hsep ["Judgement", pretty name, applied] - UnexpectedNonSubject r fm -> hsep ["Unexpected non-subject", pretty fm] - DuplicatedPlace r v -> hsep [pretty v, "is a duplicated place" ] - DuplicatedInput r v -> hsep [pretty v, "is a duplicated input"] - DuplicatedOutput r v -> hsep [pretty v, "is a duplicated output"] - BothInputOutput r v -> hsep [pretty v, "is both an input and an output"] - ProtocolCitizenSubjectMismatch r v m -> + UnexpectedNonSubject fm -> hsep ["Unexpected non-subject", pretty fm] + DuplicatedPlace v -> hsep [pretty v, "is a duplicated place" ] + DuplicatedInput v -> hsep [pretty v, "is a duplicated input"] + DuplicatedOutput v -> hsep [pretty v, "is a duplicated output"] + BothInputOutput v -> hsep [pretty v, "is both an input and an output"] + ProtocolCitizenSubjectMismatch v m -> let (seen, unseen) = case m of Input -> ("an input", "not as a subject") Subject{} -> ("a subject", "neither as an input nor an output") Output -> ("an output", "not as a subject") in hsep ["Found", pretty v, "as", seen, "but", unseen ] - MalformedPostOperator r op cands -> + MalformedPostOperator op cands -> let message = case cands of [x] -> "the subject" _ -> "a subject among" in hsep $ ["Malformed operator", pretty op <> "; expected it to act on", message] ++ punctuate ", " (map pretty cands) -- syntaxes - AlreadyDeclaredSyntaxCat r x -> hsep ["The syntactic category", pretty x, "is already defined"] + AlreadyDeclaredSyntaxCat x -> hsep ["The syntactic category", pretty x, "is already defined"] -- syntaxdesc validation - InconsistentSyntaxDesc r -> "Inconsistent syntactic descriptions" - InvalidSyntaxDesc r d -> hsep ["Invalid syntax desc", pretty d] - IncompatibleSemanticsDescs r desc desc' -> + InconsistentSyntaxDesc -> "Inconsistent syntactic descriptions" + InvalidSyntaxDesc d -> hsep ["Invalid syntax desc", pretty d] + IncompatibleSemanticsDescs desc desc' -> hsep ["Incompatible semantics descriptions", prettyPrec 1 desc, "and", prettyPrec 1 desc'] - IncompatibleSyntaxInfos r info1 info2 -> + IncompatibleSyntaxInfos info1 info2 -> hsep ["Syntax infos", pretty info1, "and", pretty info2, "are incompatible"] - GotBarredAtom r a as -> hsep + GotBarredAtom a as -> hsep [ squote <> pretty a, "is one of the barred atoms", collapse (map pretty as) ] - ExpectedNilGot r at -> hsep ["Expected [] and got", squote <> pretty at] - ExpectedEnumGot r es e -> sep + ExpectedNilGot at -> hsep ["Expected [] and got", squote <> pretty at] + ExpectedEnumGot es e -> sep [ "Expected an atom among" , collapse $ map pretty es , hsep ["and got", pretty e]] - ExpectedTagGot r ts t -> sep + ExpectedTagGot ts t -> sep [ "Expected a tag among" , collapse $ map pretty ts , hsep ["and got", pretty t]] - ExpectedANilGot r t -> hsep ["Expected the term [] and got", pretty t] - ExpectedANilPGot r p -> hsep ["Expected the pattern [] and got", pretty p] - ExpectedAConsGot r t -> hsep ["Expected a cons cell and got", pretty t] - ExpectedAConsPGot r p -> hsep ["Expected a pattern for a cons cell and got", pretty p] - SyntaxError r d t -> hsep ["Term", pretty t, "does not match", pretty d] - SyntaxPError r d p -> hsep ["Pattern", pretty p, "does not match", pretty d] - ExpectedAnOperator r t -> hsep ["Expected an operator call but got", pretty t] - ExpectedAnEmptyListGot r a ds -> + ExpectedANilGot t -> hsep ["Expected the term [] and got", pretty t] + ExpectedANilPGot p -> hsep ["Expected the pattern [] and got", pretty p] + ExpectedAConsGot t -> hsep ["Expected a cons cell and got", pretty t] + ExpectedAConsPGot p -> hsep ["Expected a pattern for a cons cell and got", pretty p] + SyntaxError d t -> hsep ["Term", pretty t, "does not match", pretty d] + SyntaxPError d p -> hsep ["Pattern", pretty p, "does not match", pretty d] + ExpectedAnOperator t -> hsep ["Expected an operator call but got", pretty t] + ExpectedAnEmptyListGot a ds -> hsep ["Expected", pretty a, "to be a constant operator" , "but it takes arguments of type:", collapse (pretty <$> ds)] -- TODO : learn to print the semantics desc - InvalidSemanticsDesc r sem -> "Invalid semantics description" - SemanticsError r sem t -> hsep [pretty t, "does not match the semantics description"] - IncompatibleSemanticsInfos r isem isem' -> + InvalidSemanticsDesc sem -> "Invalid semantics description" + SemanticsError sem t -> hsep [pretty t, "does not match the semantics description"] + IncompatibleSemanticsInfos isem isem' -> hsep ["Incompatible semantics description infos", prettyPrec 1 isem, "and", prettyPrec 1 isem'] - AsPatternCannotHaveSubjects r p -> hsep ["As pattern", pretty p, "duplicates a subject variable"] + AsPatternCannotHaveSubjects p -> hsep ["As pattern", pretty p, "duplicates a subject variable"] -- desc inference -- TODO : add more info - InferredDescMismatch r -> "Inferred object description does not match pattern" - DontKnowHowToInferDesc r t -> hsep ["Do not know how to infer description for", pretty t] - ArityMismatchInOperator r -> "Arity mismatch in operator" - SchematicVariableNotInstantiated r -> "Schematic variable not instantiated" - NotAValidContextRestriction r x y -> "Not a valid context restriction" - NotAValidDescriptionRestriction r x y -> "Not a valid description restriction" - ExpectedParameterBinding r x -> "Expected parameter binding" - ExpectedASemanticsGot r t -> hsep ["Expected a semantics but got", pretty t] - - + InferredDescMismatch -> "Inferred object description does not match pattern" + DontKnowHowToInferDesc t -> hsep ["Do not know how to infer description for", pretty t] + ArityMismatchInOperator -> "Arity mismatch in operator" + SchematicVariableNotInstantiated -> "Schematic variable not instantiated" + NotAValidContextRestriction x y -> "Not a valid context restriction" + NotAValidDescriptionRestriction x y -> "Not a valid description restriction" + ExpectedParameterBinding x -> "Expected parameter binding" + ExpectedASemanticsGot t -> hsep ["Expected a semantics but got", pretty t] + + +instance Pretty a => Pretty (WithRange a) where + pretty (WithRange r a) = flush (pretty r) <> pretty a instance Pretty a => Pretty (WithStackTrace a) where pretty (WithStackTrace stk msg) = vcat (pretty msg : map pretty stk) diff --git a/Src/Location.hs b/Src/Location.hs index c9cf14b..d6c8665 100644 --- a/Src/Location.hs +++ b/Src/Location.hs @@ -52,6 +52,9 @@ class HasSetRange t where class HasGetRange t where getRange :: t -> Range +instance HasGetRange Range where + getRange = id + instance HasSetRange (WithRange t) where setRange r (WithRange _ t) = WithRange r t From ca39ad85b45feba96d0203a24714f5f27ae3b646 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Thu, 16 Feb 2023 17:58:35 +0000 Subject: [PATCH 45/89] [ refactor ] get rid of HasGetRange Warning --- Src/Command.hs | 2 +- Src/Elaboration.hs | 20 ++++++++++---------- Src/Elaboration/Monad.hs | 40 ++++++++++++++------------------------- Src/Elaboration/Pretty.hs | 30 +++++++++++++---------------- TODO.md | 2 +- 5 files changed, 39 insertions(+), 55 deletions(-) diff --git a/Src/Command.hs b/Src/Command.hs index f4e1f85..dfc8f00 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -603,7 +603,7 @@ scommands (c:cs) = do elaborate :: Options -> [CCommand] -> Either (WithStackTrace (WithRange Complaint)) - ([WithStackTrace Warning], [ACommand], SyntaxTable) + ([WithStackTrace (WithRange Warning)], [ACommand], SyntaxTable) elaborate opts ccs = evalElab opts $ do acs <- scommands ccs st <- get diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 89fe4c5..fd0f60b 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -57,12 +57,12 @@ checkSendableSubject tm = do go localVars x = case x of Var r v -> resolve v >>= \case Just (ADeclaration (ActVar (IsSubject {}) _)) -> pure . Just $ getVariable v - _ -> Nothing <$ raiseWarning (SentSubjectNotASubjectVar (getRange tm) tm) + _ -> Nothing <$ raiseWarning tm (SentSubjectNotASubjectVar tm) Sbst r sg x -> do case isInvertible localVars sg of - Nothing -> Nothing <$ raiseWarning (SentSubjectNotASubjectVar (getRange tm) tm) + Nothing -> Nothing <$ raiseWarning tm (SentSubjectNotASubjectVar tm) Just localVars -> go localVars x - _ -> Nothing <$ raiseWarning (SentSubjectNotASubjectVar (getRange tm) tm) + _ -> Nothing <$ raiseWarning tm (SentSubjectNotASubjectVar tm) isInvertible :: Bwd String -> Bwd SbstC -> Maybe (Bwd String) isInvertible lvz B0 = pure lvz isInvertible (lvz :< w) (sz :< Keep _ v) | getVariable v == w @@ -269,7 +269,7 @@ spatSemantics0 desc p = do spatSemantics :: ASemanticsDesc -> Restriction -> CPattern -> Elab (APattern, Decls, ACTm) spatSemantics desc rest (Irrefutable r p) = do - raiseWarning (IgnoredIrrefutable r p) -- TODO + raiseWarning r (IgnoredIrrefutable p) -- TODO spatSemantics desc rest p spatSemantics desc rest (AsP r v p) = do v <- isFresh v @@ -938,7 +938,7 @@ sact = \case -- Check we properly scrutinised a subject input unlessM (checkScrutinised av) $ when (isSubjectMode m) $ do - when canwin $ raiseWarning (RecvSubjectNotScrutinised r ch av) + when canwin $ raiseWarning r (RecvSubjectNotScrutinised ch av) pure $ Recv r ch (ActorMeta (spassport (Scrutinised unknown) isSub) <$> av, a) @@ -993,7 +993,7 @@ sact = \case table <- gets syntaxCats dat <- asks headUpData let examples = fromList cov >>= missing dat table - raiseWarning $ MissingClauses r examples + raiseWarning r $ MissingClauses examples let (cls, sts) = unzip clsts let (chst, avst) = unzip $ catMaybes sts during (MatchElaboration rsc) $ do @@ -1036,7 +1036,7 @@ consistentScrutinisation r sts = do unless (null check) $ modify (\ r -> r { actvarStates = foldr (Map.unionWith (<>)) Map.empty sts }) case check of - _:_:_ -> raiseWarning (InconsistentScrutinisation r) + _:_:_ -> raiseWarning r InconsistentScrutinisation _ -> pure () where @@ -1056,7 +1056,7 @@ sbranch r ds ra = do unlessM (checkScrutinised (Used nm)) $ -- whenJust me $ \ _ -> -- HACK: do not complain about dead branches case isSub of - IsSubject{} -> raiseWarning (PatternSubjectNotScrutinised r nm) + IsSubject{} -> raiseWarning r (PatternSubjectNotScrutinised nm) _ -> pure () _ -> pure () @@ -1079,7 +1079,7 @@ sclause esc (rp, a) = do local (setDecls ds . setHints hs) $ sbranch (getRange rp) pats a lift $ modify (\ st -> st { actvarStates = avs }) -- make sure no catchall on subject pattern, except in dead branches - whenJust (me *> mr) (lift . raiseWarning . UnderscoreOnSubject) + whenJust (me *> mr) (lift . flip raiseWarning UnderscoreOnSubject) pure ((p, a), me) coverageCheckClause :: RawP -> Pat -> StateT [ASemanticsDesc] Elab () @@ -1093,7 +1093,7 @@ coverageCheckClause rp p = do unless (isCatchall p) $ -- For now we don't complain about catchalls because they may -- catching variables. - raiseWarning (UnreachableClause (getRange rp) rp) + raiseWarning rp (UnreachableClause rp) pure leftovers PartiallyCovering _ ps -> pure ps put leftovers diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 1733ab5..949166f 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -35,7 +35,7 @@ data ElabState = ElabState { channelStates :: ChannelStates , actvarStates :: ActvarStates , syntaxCats :: SyntaxTable - , warnings :: Bwd (WithStackTrace Warning) + , warnings :: Bwd (WithStackTrace (WithRange Warning)) , clock :: Int } @@ -352,34 +352,22 @@ getHint str = do -- Warnings data Warning - = UnreachableClause Range RawP - | MissingClauses Range (NonEmpty RawP) + = UnreachableClause RawP + | MissingClauses (NonEmpty RawP) -- Subject tracking - | SentSubjectNotASubjectVar Range Raw - | RecvSubjectNotScrutinised Range Channel (Binder String) - | PatternSubjectNotScrutinised Range String - | UnderscoreOnSubject Range - | InconsistentScrutinisation Range + | SentSubjectNotASubjectVar Raw + | RecvSubjectNotScrutinised Channel (Binder String) + | PatternSubjectNotScrutinised String + | UnderscoreOnSubject + | InconsistentScrutinisation -- Missing features - | IgnoredIrrefutable Range RawP - -instance HasGetRange Warning where - getRange = \case - UnreachableClause r _ -> r - MissingClauses r _ -> r - -- Subject analysis - SentSubjectNotASubjectVar r _ -> r - RecvSubjectNotScrutinised r _ _ -> r - PatternSubjectNotScrutinised r _ -> r - UnderscoreOnSubject r -> r - InconsistentScrutinisation r -> r - -- Missing features - IgnoredIrrefutable r _ -> r - -raiseWarning :: Warning -> Elab () -raiseWarning w = do + | IgnoredIrrefutable RawP + +raiseWarning :: HasGetRange a => a -> Warning -> Elab () +raiseWarning a w = do stk <- asks stackTrace - modify (\ r -> r { warnings = warnings r :< WithStackTrace stk w }) + let warning = WithStackTrace stk (WithRange (getRange a) w) + modify (\ st -> st { warnings = warnings st :< warning }) ------------------------------------------------------------------------------ -- Errors diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index 04a787f..3cac2b5 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -57,26 +57,26 @@ instance Pretty CFormula where pretty (CFormula a) = these pretty pretty (const pretty) a pretty (CCitizen p t) = hsep [pretty p, "=>", pretty t] -instance Pretty Warning where - pretty w = (withANSI [ SetColour Background Yellow ] "Warning:" <+> pretty (getRange w)) $$ go w where +instance Pretty (WithRange Warning) where + pretty (WithRange r w) = (withANSI [ SetColour Background Yellow ] "Warning:" <+> pretty r) $$ go w where go :: Warning -> Doc Annotations go = \case - UnreachableClause r pat -> + UnreachableClause pat -> hsep ["Unreachable clause", pretty pat] - MissingClauses r pats -> + MissingClauses pats -> let sIsAre = case pats of { _ :| [] -> " is"; _ -> "s are" } in asBlock 2 ("Incomplete pattern matching. The following pattern" <> sIsAre <+> "missing:") $ map pretty (toList pats) -- Subject analysis - SentSubjectNotASubjectVar r raw -> hsep ["Sent subject", pretty raw, "is not a subject variable"] - RecvSubjectNotScrutinised r ch Unused -> hsep ["Ignored received subject on channel", pretty ch] - RecvSubjectNotScrutinised r ch (Used x) -> hsep ["Received subject", pretty x,"on channel", pretty ch, "and did not scrutinise it"] - PatternSubjectNotScrutinised r x -> hsep ["Pattern subject", pretty x, "did not get scrutinised"] - UnderscoreOnSubject r -> hsep ["Subject pattern thrown away using an underscore"] - InconsistentScrutinisation r -> hsep ["Inconsistent scrutinisation of subject in match"] + SentSubjectNotASubjectVar raw -> hsep ["Sent subject", pretty raw, "is not a subject variable"] + RecvSubjectNotScrutinised ch Unused -> hsep ["Ignored received subject on channel", pretty ch] + RecvSubjectNotScrutinised ch (Used x) -> hsep ["Received subject", pretty x,"on channel", pretty ch, "and did not scrutinise it"] + PatternSubjectNotScrutinised x -> hsep ["Pattern subject", pretty x, "did not get scrutinised"] + UnderscoreOnSubject -> hsep ["Subject pattern thrown away using an underscore"] + InconsistentScrutinisation -> hsep ["Inconsistent scrutinisation of subject in match"] -- Missing feature - IgnoredIrrefutable r p -> hsep ["TODO: actually implement irrefutable patterns (", pretty p, ")"] + IgnoredIrrefutable p -> hsep ["TODO: actually implement irrefutable patterns (", pretty p, ")"] instance Pretty ContextualInfo where pretty = \case @@ -105,8 +105,8 @@ instance Pretty ContextualInfo where ConnectElaboration ch1 ch2 -> hsep ["when elaborating the connection", pretty ch1, "<->", pretty ch2] JudgementFormElaboration v -> hsep ["when elaborating the judgement form", pretty v] -instance Pretty Complaint where - pretty c = case c of +instance Pretty (WithRange Complaint) where + pretty (WithRange r c) = flush (pretty r) <> case c of -- scope OutOfScope x -> hsep ["Out of scope variable", pretty x] MetaScopeTooBig x sc1 sc2 -> @@ -226,9 +226,5 @@ instance Pretty Complaint where ExpectedParameterBinding x -> "Expected parameter binding" ExpectedASemanticsGot t -> hsep ["Expected a semantics but got", pretty t] - -instance Pretty a => Pretty (WithRange a) where - pretty (WithRange r a) = flush (pretty r) <> pretty a - instance Pretty a => Pretty (WithStackTrace a) where pretty (WithStackTrace stk msg) = vcat (pretty msg : map pretty stk) diff --git a/TODO.md b/TODO.md index d196037..003bf79 100644 --- a/TODO.md +++ b/TODO.md @@ -91,7 +91,7 @@ * [ ] `keyword` pretty printing should use the data type of keywords * [ ] `class Declarable a where { declare :: a -> Context -> Context }` instead of declareObjVar, declareChannel, declareXXX -* [ ] Add `throwComplaint :: Range -> Complaint -> Elab ()` and +* [x] Add `throwComplaint :: Range -> Complaint -> Elab ()` and refactor `Complaint` to be range-free with the range carried by a `WithRange` wrapper. From 135695c7ada73c1ac774fa6fa107d28eb4349165 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 21 Feb 2023 16:18:42 +0000 Subject: [PATCH 46/89] [ fix ] some scope issues --- Src/Command.hs | 34 +++++++++++++++-------------- Src/Concrete/Base.hs | 4 ++++ Src/Elaboration.hs | 45 +++++++++++++++++++++++++-------------- Src/Elaboration/Monad.hs | 4 ++++ Src/Elaboration/Pretty.hs | 7 +++--- Src/Term/Base.hs | 3 +++ test/typecheck.act | 25 ++++++++++++++++++++++ 7 files changed, 87 insertions(+), 35 deletions(-) diff --git a/Src/Command.hs b/Src/Command.hs index dfc8f00..11ec743 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -298,7 +298,7 @@ sdeclOps ((AnOperator (objName, objDescPat) (WithRange r opname) paramDescs retD pure (Just (ActorMeta ACitizen objName), Used objName) ovs <- asks objVars sem <- satom "Semantics" - (descPat, ds, objDesc) <- spatSemantics sem (initRestriction ovs) objDescPat + (descPat, ds, objDesc) <- spatSemantics0 sem objDescPat op <- local (declare objBinder (ActVar IsNotSubject (ovs :=> objDesc)) . setDecls ds) $ do (paramDescs, ds) <- sparamdescs paramDescs retDesc <- local (setDecls ds) $ sty retDesc @@ -357,12 +357,12 @@ scommand = \case -- Sig S \x.T - 'fst ~> S -- (p : Sig S \x.T) - 'snd ~> {x=[ p - 'fst ]}T - DefnOp ((p, pty), opelims, rhs) -> do + DefnOp ((rp, pty), opelims, rhs) -> do -- p : pty -[ opelim0 ] -[ opelim1 ] ... -[ opelimn ] ~> rhs sem <- satom "Semantics" (_, decls, ty) <- spatSemantics0 sem pty - (p, decls, t) <- local (setDecls decls) $ spatSemantics0 ty p - (opelimz, decls, lhsTy) <- local (setDecls decls) $ sopelims0 (ty, t) opelims + (p, decls, t) <- local (setDecls decls) $ spatSemantics0 ty rp + (opelimz, decls, lhsTy) <- local (setDecls decls) $ sopelims0 (getRange rp <> getRange pty) (ty, t) opelims rhs <- local (setDecls decls) $ stm DontLog lhsTy rhs -- this is the outer op being extended let op = case opelimz of (_ :< (op, _)) -> op @@ -487,26 +487,28 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do | otherwise = throwComplaint (objDesc op) (MalformedPostOperator (theValue (opName op)) (Map.keys m)) -} -sopelims0 :: (ASemanticsDesc, ACTm) +sopelims0 :: Range + -> (ASemanticsDesc, ACTm) -> [(OPERATOR Concrete, [RawP])] -> Elab (Bwd (OPERATOR Abstract, [Pat]), Decls, ASemanticsDesc) -sopelims0 = sopelims B0 +sopelims0 r = sopelims r B0 -sopelims :: Bwd (OPERATOR Abstract, [Pat]) +sopelims :: Range + -> Bwd (OPERATOR Abstract, [Pat]) -> (ASemanticsDesc, ACTm) -> [(OPERATOR Concrete, [RawP])] -> Elab (Bwd (OPERATOR Abstract, [Pat]), Decls, ASemanticsDesc) -sopelims opelimz (ty, t) [] = (opelimz,,ty) <$> asks declarations -sopelims opelimz (ty, t) ((op, args):opelims) = do +sopelims r opelimz (ty, t) [] = (opelimz,,ty) <$> asks declarations +sopelims r opelimz (ty, t) ((op, args):opelims) = do -- We need to worry about freshening up names in operator -- declarations when checking definitions to avoid clashes (AnOperator (mb, opat) opName pdescs rdesc) <- freshenOp =<< soperator op - let r = getRange op <> foldMap getRange args dat <- matchObjType r (mb, opat) (ty, t) + let r' = getRange op <> foldMap getRange args local (setHeadUpData dat) $ do - ((ty, decls), (pargs, args)) <- spats r pdescs args rdesc + ((ty, decls), (pargs, args)) <- spats r' pdescs args rdesc local (setDecls decls) $ - sopelims (opelimz :< (opName, pargs)) (ty, t -% (getOperator opName, args)) opelims + sopelims (r <> r') (opelimz :< (opName, pargs)) (ty, t -% (getOperator opName, args)) opelims where @@ -516,7 +518,7 @@ sopelims opelimz (ty, t) ((op, args):opelims) = do -> Bwd String -> Telescopic ASemanticsDesc -> RawP - -> Elab ((Pat, ACTm), HeadUpData' ActorMeta) + -> Elab ((Pat, ACTm), Decls, HeadUpData' ActorMeta) sparamSemantics binder namez (Stop pdesc) rp = do (p, decls, t) <- spatSemantics0 pdesc rp dat <- do @@ -527,7 +529,7 @@ sopelims opelimz (ty, t) ((op, args):opelims) = do let env = huEnv dat env' = newActorVar v (namez <>> [], t) env in dat {huEnv = env'} - pure ((p, t), dat) + pure ((p, t), decls, dat) sparamSemantics binder namez (Tele desc (Scope (Hide name) tele)) (LamP r (Scope (Hide x) rp)) = @@ -542,8 +544,8 @@ sopelims opelimz (ty, t) ((op, args):opelims) = do spats r [] [] rdesc = (,([], [])) <$> ((,) <$> instantiateDesc r rdesc <*> asks declarations) spats r ((binder, sot) : bs) (rp:rps) rdesc = do (ovs :=> desc) <- instantiateSOT (getRange rp) sot - ((p, t), dat) <- sparamSemantics binder B0 (discharge ovs desc) rp - local (setHeadUpData dat) $ + ((p, t), decls, dat) <- sparamSemantics binder B0 (discharge ovs desc) rp + local (setDecls decls . setHeadUpData dat) $ fmap (bimap (p:) (t:)) <$> spats r bs rps rdesc spats r bs rps rdesc = throwComplaint r $ ArityMismatchInOperator diff --git a/Src/Concrete/Base.hs b/Src/Concrete/Base.hs index d0de01a..4485a5a 100644 --- a/Src/Concrete/Base.hs +++ b/Src/Concrete/Base.hs @@ -38,6 +38,10 @@ mkBinder :: Variable -> Binder Variable mkBinder (Variable r "_") = Unused mkBinder v = Used v +getBinder :: Binder Variable -> Variable +getBinder (Used v) = v +getBinder Unused = Variable unknown "_" + data Raw = Var Range Variable | At Range Atom diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index fd0f60b..f04736b 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -266,6 +266,11 @@ spatSemantics0 desc p = do ovs <- asks objVars spatSemantics desc (initRestriction ovs) p +data ConsDesc + = ConsCell ASemanticsDesc ASemanticsDesc + | ConsEnum [(String, [ASemanticsDesc])] + | ConsUniverse + spatSemantics :: ASemanticsDesc -> Restriction -> CPattern -> Elab (APattern, Decls, ACTm) spatSemantics desc rest (Irrefutable r p) = do @@ -319,43 +324,51 @@ spatSemantics desc rest rp = do VNilOrCons{} -> unless (a == "") $ throwComplaint r (ExpectedNilGot a) VEnumOrTag sc es _ -> unless (a `elem` es) $ throwComplaint r (ExpectedEnumGot es a) VWildcard sc -> pure () + VUniverse _ -> unless (a `elem` ("Semantics" : Map.keys table)) $ throwComplaint r (ExpectedASemanticsGot (At r a)) _ -> throwComplaint r (SyntaxPError desc rp) pure (AP a, ds, atom a (weeEnd (restriction rest))) ConsP r p1 p2 -> do + -- take vdesc apart and decide what needs to be checked + -- Left (d1, d2): usual cons cell + -- Right ds : enumeration (ds :: [(String, [Desc])]) descs <- case vdesc of - VNilOrCons d1 d2 -> pure (Left (d1, d2)) - VCons d1 d2 -> pure (Left (d1, d2)) - VWildcard _ -> pure (Left (desc, desc)) - VEnumOrTag _ _ ds -> pure (Right ds) + VNilOrCons d1 d2 -> pure (ConsCell d1 d2) + VCons d1 d2 -> pure (ConsCell d1 d2) + VWildcard _ -> pure (ConsCell desc desc) + VEnumOrTag _ _ ds -> pure (ConsEnum ds) + VUniverse _ -> pure ConsUniverse _ -> throwComplaint r (SyntaxPError desc rp) case descs of - Left (d1, d2) -> do + ConsCell d1 d2 -> do (p1, ds, t1) <- spatSemantics d1 rest p1 (p2, ds, t2) <- local (setDecls ds) (spatSemantics d2 rest p2) pure (PP p1 p2, ds, t1 % t2) - Right ds -> case p1 of + ConsEnum ds -> case p1 of AtP r a -> case lookup a ds of Nothing -> throwComplaint r (ExpectedTagGot (fst <$> ds) a) Just descs -> do - (p1, ds, t1) <- spatSemantics (atom "Atom" 0) rest p1 + at <- satom "Atom" + (p1, ds, t1) <- spatSemantics at rest p1 (p2, ds, t2) <- local (setDecls ds) (spatSemanticss descs rest p2) pure (PP p1 p2, ds, t1 % t2) _ -> throwComplaint r (SyntaxPError desc rp) + ConsUniverse -> case (p1 , p2) of + (AtP _ "Pi", ConsP _ s (ConsP _ (LamP _ (Scope (Hide x) t)) (AtP _ ""))) -> do + (ps, ds, ts) <- spatSemantics desc rest s + (pt, ds, tt) <- + local (setDecls ds) $ + elabUnder (x, ts) $ + spatSemantics (weak desc) (extend rest $ getVariable $ getBinder x) t + pure (PP (AP "Pi") (PP ps (PP pt (AP ""))), ds, "Pi" #%+ [ts,tt]) + _ -> throwComplaint r (ExpectedASemanticsPGot rp) LamP r (Scope v@(Hide x) p) -> do (s, desc) <- case vdesc of VWildcard _ -> pure (desc, desc) VBind cat desc -> pure (Semantics.catToDesc cat, desc) + VPi s (y, t) -> pure (s, t) _ -> throwComplaint r (SyntaxPError desc rp) - -- TODO: refactor using Dischargeable - case x of - Unused -> do - (p, ds, t) <- spatSemantics desc rest p - pure (BP (Hide "_") p, ds, (Hide "_" := False :.) $^ t) - Used x -> do - x <- isFresh x - (p, ds, t) <- local (declareObjVar (x, s)) $ spatSemantics desc (extend rest x) p - pure (BP (Hide x) p, ds, x \\ t) + elabUnder (x, s) $ spatSemantics desc (extend rest (getVariable $ getBinder x)) p spatSemanticss :: [ASemanticsDesc] -> Restriction diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 949166f..ca8080f 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -179,6 +179,9 @@ data Kind type Decls = Bwd (String, Kind) type Operators = Map String AAnOperator +instance Dischargeable Decls where + x \\ ds = ds + -- LexicalScope = ObjVars + Macros -- gives the meanings of things that look like variables. @@ -470,6 +473,7 @@ data Complaint | ExpectedANilPGot RawP | ExpectedAConsGot Raw | ExpectedAConsPGot RawP + | ExpectedASemanticsPGot RawP | SyntaxError ASemanticsDesc Raw | SyntaxPError ASemanticsDesc RawP | ExpectedAnOperator Raw diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index 3cac2b5..c8c6a42 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -185,7 +185,7 @@ instance Pretty (WithRange Complaint) where InconsistentSyntaxDesc -> "Inconsistent syntactic descriptions" InvalidSyntaxDesc d -> hsep ["Invalid syntax desc", pretty d] IncompatibleSemanticsDescs desc desc' -> - hsep ["Incompatible semantics descriptions", prettyPrec 1 desc, "and", prettyPrec 1 desc'] + hsep ["Incompatible semantics descriptions", {-prettyPrec 1-} pretty (show desc), "and", {-prettyPrec 1-} pretty (show desc')] IncompatibleSyntaxInfos info1 info2 -> hsep ["Syntax infos", pretty info1, "and", pretty info2, "are incompatible"] GotBarredAtom a as -> hsep @@ -203,8 +203,8 @@ instance Pretty (WithRange Complaint) where ExpectedANilPGot p -> hsep ["Expected the pattern [] and got", pretty p] ExpectedAConsGot t -> hsep ["Expected a cons cell and got", pretty t] ExpectedAConsPGot p -> hsep ["Expected a pattern for a cons cell and got", pretty p] - SyntaxError d t -> hsep ["Term", pretty t, "does not match", pretty d] - SyntaxPError d p -> hsep ["Pattern", pretty p, "does not match", pretty d] + SyntaxError d t -> hsep ["Term", pretty t, "does not check against", pretty d] + SyntaxPError d p -> hsep ["Pattern", pretty p, "does not check against", pretty d] ExpectedAnOperator t -> hsep ["Expected an operator call but got", pretty t] ExpectedAnEmptyListGot a ds -> hsep ["Expected", pretty a, "to be a constant operator" @@ -225,6 +225,7 @@ instance Pretty (WithRange Complaint) where NotAValidDescriptionRestriction x y -> "Not a valid description restriction" ExpectedParameterBinding x -> "Expected parameter binding" ExpectedASemanticsGot t -> hsep ["Expected a semantics but got", pretty t] + ExpectedASemanticsPGot p -> hsep ["Expected a semantics pattern but got", pretty p] instance Pretty a => Pretty (WithStackTrace a) where pretty (WithStackTrace stk msg) = vcat (pretty msg : map pretty stk) diff --git a/Src/Term/Base.hs b/Src/Term/Base.hs index 3dfbd91..9f34604 100644 --- a/Src/Term/Base.hs +++ b/Src/Term/Base.hs @@ -271,6 +271,9 @@ instance Dischargeable () where instance (Dischargeable a, Dischargeable b) => Dischargeable (a, b) where x \\ (s, t) = (x \\ s, x \\ t) +instance (Dischargeable a, Dischargeable b, Dischargeable c) => Dischargeable (a, b, c) where + x \\ (s, t, u) = (x \\ s, x \\ t, x \\ u) + infixr 5 $: ($:) :: m -> CdB (Sbst m) -> CdB (Tm m) m $: sg = contract (m :$: sg) diff --git a/test/typecheck.act b/test/typecheck.act index 709adbb..4fe49a6 100644 --- a/test/typecheck.act +++ b/test/typecheck.act @@ -10,8 +10,33 @@ typecheck ['Suc 'Zero] : 'Nat typecheck ['Pi 'Nat (\_.'Nat)] : 'Semantics typecheck \x.x : ['Pi 'Nat (\_.'Nat)] +typecheck \x.'Zero : ['Pi 'Nat \_.'Nat] typecheck ['Pi 'Semantics \X.['Pi X \_.X]] : 'Semantics typecheck \X x.x : ['Pi 'Semantics \X.['Pi X \_.X]] +operator + { 'Nat -[ 'mul 'Nat ] : 'Nat + ; 'Nat -[ 'add 'Nat ] : 'Nat + } + +-- TODO: improve error message for: +-- \x.'Zero : ['Pi 'Nat \_.'Nat] -[ 'mul m ] ~> 'Zero + +'Zero : 'Nat -[ 'mul n ] ~> 'Zero +['Suc m] : 'Nat -[ 'mul n ] ~> n -['add m -['mul n]] + +'Zero : 'Nat -[ 'add n ] ~> n +['Suc m] : 'Nat -[ 'add n ] ~> ['Suc m -['add n]] + +operator + { ['Pi a \x.b] -['apply (t : a)] : {x=t}b } + +-- TODO: get capture working? +-- operator { ['Pi a \x.b] -['apply (x : a)] : b } + +\x.'Zero : ['Pi 'Nat \_.'Nat] -[ 'apply t ] ~> 'Zero + + + exec PRINTF "Hurrah!". From 5b4611d31e82f154c4ac01381ec643e2ef35b9ad Mon Sep 17 00:00:00 2001 From: Georgi Nakov Date: Tue, 21 Feb 2023 18:06:27 +0000 Subject: [PATCH 47/89] [ unfix ] broke substitutions --- Src/Concrete/Base.hs | 2 ++ Src/Elaboration.hs | 39 ++++++++++++++++++++++++++------------- Src/Elaboration/Monad.hs | 15 +++++++++++---- 3 files changed, 39 insertions(+), 17 deletions(-) diff --git a/Src/Concrete/Base.hs b/Src/Concrete/Base.hs index 4485a5a..d54d021 100644 --- a/Src/Concrete/Base.hs +++ b/Src/Concrete/Base.hs @@ -38,9 +38,11 @@ mkBinder :: Variable -> Binder Variable mkBinder (Variable r "_") = Unused mkBinder v = Used v +{- getBinder :: Binder Variable -> Variable getBinder (Used v) = v getBinder Unused = Variable unknown "_" +-} data Raw = Var Range Variable diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index f04736b..7c5cc2b 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -109,17 +109,29 @@ spassport :: Usage -> IsSubject -> Passport spassport u IsSubject{} | isBeingScrutinised u = ASubject spassport _ _ = ACitizen +smeta :: Usage + -> ActorMeta {- eps -} + -> ACTSbst {- delta -} {- gamma -} + -> Telescopic ASemanticsDesc {- delta -} {- eps -} + -> Elab ({- T :: -} ASemanticsDesc {- gamma -}, ACTm {- gamma -} {- T -}) +smeta usage am sg (Stop desc) = pure (desc //^ sg, am $: sg) +smeta usage am sg (Tele desc (Scope (Hide x) tel)) = do + t <- stm usage (desc //^ sg) (Var unknown $ Variable unknown x) + smeta usage am (sbstT sg ((Hide x :=) $^ t)) tel + +-- TODO: pass (Maybe ASemanticsDesc) and handle macros svar :: Usage -> Variable -> Elab (IsSubject, ASemanticsDesc, ACTm) svar usage x = do ovs <- asks objVars res <- resolve x case res of Just (ADeclaration k) -> case k of - ActVar isSub (sc :=> desc) -> case sc `thinsTo` ovs of - Just th -> do - logUsage (getVariable x) usage - pure (isSub, desc, ActorMeta (spassport usage isSub) (getVariable x) $: sbstW (sbst0 0) th) - Nothing -> throwComplaint x (MetaScopeTooBig x sc ovs) + ActVar isSub (sc :=> desc) -> do + logUsage (getVariable x) usage + let tel = discharge sc desc + let am = ActorMeta (spassport usage isSub) (getVariable x) + (desc, tm) <- smeta usage am (sbst0 $ scopeSize ovs) tel + pure (isSub, desc, tm) _ -> throwComplaint x (NotAValidTermVariable x k) Just (AnObjVar desc i) -> pure (IsNotSubject, desc, var i (scopeSize ovs)) Nothing -> throwComplaint x (OutOfScope x) @@ -139,8 +151,9 @@ ssyntaxdesc syndecls syn = do Nothing -> error "Impossible in ssyntaxdesc" -- this should be impossible, since parsed in empty context Just syn0 -> pure syn0 -ssbst :: Usage -> Bwd SbstC -> Elab (ACTSbst, ObjVars) -ssbst usage B0 = do + +ssbst :: Bwd SbstC -> Elab Macros +ssbst = undefined {-usage B0 = do ovs <- asks objVars pure (sbstI (scopeSize ovs), ovs) ssbst usage (sg :< sgc) = case sgc of @@ -152,6 +165,7 @@ ssbst usage (sg :< sgc) = case sgc of (desc, t) <- itm usage t pure (sbstT sg ((Hide v :=) $^ t), ovs <: ObjVar v desc) _ -> undefined +-} {- ssbst :: Usage -> Bwd SbstC -> Elab (ACTSbst, ObjVars) @@ -358,7 +372,7 @@ spatSemantics desc rest rp = do (pt, ds, tt) <- local (setDecls ds) $ elabUnder (x, ts) $ - spatSemantics (weak desc) (extend rest $ getVariable $ getBinder x) t + spatSemantics (weak desc) (extend rest (getVariable <$> x)) t pure (PP (AP "Pi") (PP ps (PP pt (AP ""))), ds, "Pi" #%+ [ts,tt]) _ -> throwComplaint r (ExpectedASemanticsPGot rp) @@ -368,7 +382,7 @@ spatSemantics desc rest rp = do VBind cat desc -> pure (Semantics.catToDesc cat, desc) VPi s (y, t) -> pure (s, t) _ -> throwComplaint r (SyntaxPError desc rp) - elabUnder (x, s) $ spatSemantics desc (extend rest (getVariable $ getBinder x)) p + elabUnder (x, s) $ spatSemantics desc (extend rest (getVariable <$> x)) p spatSemanticss :: [ASemanticsDesc] -> Restriction @@ -506,9 +520,8 @@ stm usage desc (Var r v) = during (TermVariableElaboration v) $ do compatibleInfos (getRange v) (Known desc) (Known desc') pure t stm usage desc (Sbst r sg t) = do - (sg, ovs) <- during (SubstitutionElaboration sg) $ ssbst usage sg - t <- local (setObjVars' ovs) (stm usage desc t) - pure (t //^ sg) + ms <- during (SubstitutionElaboration sg) $ ssbst sg + local (setMacros ms) (stm usage desc t) stm usage desc rt = do table <- gets syntaxCats dat <- asks headUpData @@ -717,7 +730,7 @@ spatBase isSub desc rest rp = do x <- isFresh x (mr, p, ds, hs) <- local (declareObjVar (x, s) . addHint x (Known s)) $ - spatBase isSub desc (extend rest x) p + spatBase isSub desc (extend rest $ Used x) p pure (mr, BP (Hide x) p, ds, hs) isObjVar :: Variable -> Elab (ASemanticsDesc, DB) diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index ca8080f..0e3f423 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -210,16 +210,20 @@ data Context = Context type Hints = Map String (Info ASemanticsDesc) -data Restriction = Restriction +data Restriction {- gamma -} = Restriction { support :: Bwd String - , restriction :: Th + , restriction :: Th {- support -} {- gamma -} } initRestriction :: ObjVars -> Restriction initRestriction ovs = Restriction (objVarName <$> getObjVars ovs) (ones (scopeSize ovs)) -extend :: Restriction -> String -> Restriction -extend (Restriction ls th) x = Restriction (ls :< x) (th -? True) +extend :: Restriction {- gamma -} + -> {- x :: -} Binder String + -> Restriction {- gamma , x -} +extend (Restriction ls th) (Used x) = Restriction (ls :< x) (th -? True) +extend (Restriction ls th) Unused = Restriction ls (th -? False) + instance Selable Restriction where ph ^? Restriction ls th = Restriction (ph ^? ls) (ph ^? th) @@ -308,6 +312,9 @@ declare (Used x) k ctx = ctx { declarations = declarations ctx :< (x, k) } setDecls :: Decls -> Context -> Context setDecls ds ctx = ctx { declarations = ds } +setMacros :: Macros -> Context -> Context +setMacros ms ctx = ctx { macros = ms } + ------------------------------------------------------------------------------ -- Hierarchical path names generation From b73b90b421352ce0ce61af8a20f2cc54252a3b4c Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Thu, 23 Feb 2023 16:24:17 +0000 Subject: [PATCH 48/89] [ broken ] thun fails hard --- Src/Concrete/Base.hs | 31 ++++------ Src/Concrete/Parse.hs | 8 +-- Src/Concrete/Pretty.hs | 6 +- Src/Elaboration.hs | 125 ++++++++++++++++++++++++++------------- Src/Elaboration/Monad.hs | 23 +++++-- Src/Machine/Trace.hs | 4 +- Src/Semantics.hs | 6 +- Src/Term/Base.hs | 17 +++++- Src/Unelaboration.hs | 8 ++- test/typecheck.act | 32 ++++++---- 10 files changed, 164 insertions(+), 96 deletions(-) diff --git a/Src/Concrete/Base.hs b/Src/Concrete/Base.hs index d54d021..925cd74 100644 --- a/Src/Concrete/Base.hs +++ b/Src/Concrete/Base.hs @@ -49,7 +49,7 @@ data Raw | At Range Atom | Cons Range Raw Raw | Lam Range (Scope (Binder Variable) Raw) - | Sbst Range (Bwd SbstC) Raw + | Sbst Range (Bwd Assign) Raw | Op Range Raw Raw | Guarded Guard Raw deriving (Show) @@ -81,29 +81,20 @@ instance HasGetRange Raw where Sbst r _ _ -> r Op r _ _ -> r -data SbstC - = Keep Range Variable - | Drop Range Variable - | Assign Range Variable Raw - deriving (Show) +data Assign = Assign + { assignRange :: Range + , assignVariable :: Variable + , assignTerm :: Raw + } deriving (Show) -instance Eq SbstC where - Keep _ v == Keep _ w = v == w - Drop _ v == Drop _ w = v == w +instance Eq Assign where Assign _ v t == Assign _ w u = v == w && t == u - _ == _ = False -instance HasSetRange SbstC where - setRange r = \case - Keep _ v -> Keep r v - Drop _ v -> Drop r v - Assign _ v t -> Assign r v t +instance HasSetRange Assign where + setRange r (Assign _ v t) = Assign r v t -instance HasGetRange SbstC where - getRange = \case - Keep r v -> r - Drop r v -> r - Assign r v t -> r +instance HasGetRange Assign where + getRange = assignRange data RawP = AsP Range Variable RawP diff --git a/Src/Concrete/Parse.hs b/Src/Concrete/Parse.hs index 27e1719..3ddab26 100644 --- a/Src/Concrete/Parse.hs +++ b/Src/Concrete/Parse.hs @@ -48,7 +48,7 @@ pTM :: Parser Raw pTM = withRange $ (ptm >>= more) <|> pscoped Lam pbinder pTM - <|> Sbst unknown <$ pch (== '{') <* pspc <*> ppes (punc ",") psbstC <* punc "}" <*> pTM + <|> Sbst unknown <$ pch (== '{') <* pspc <*> ppes (punc ",") passign <* punc "}" <*> pTM where @@ -64,11 +64,9 @@ ptm = withRange $ <|> id <$ pch (== '[') <* pspc <*> plisp <|> pparens pTM -psbstC :: Parser SbstC -psbstC = withRange $ pvariable >>= \ x -> +passign :: Parser Assign +passign = withRange $ pvariable >>= \ x -> Assign unknown x <$ punc "=" <*> pTM - <|> Drop unknown x <$ pspc <* pch (== '*') - <|> pure (Keep unknown x) instance Lisp RawP where mkNil = AtP unknown "" diff --git a/Src/Concrete/Pretty.hs b/Src/Concrete/Pretty.hs index 1f2455e..0f9db2d 100644 --- a/Src/Concrete/Pretty.hs +++ b/Src/Concrete/Pretty.hs @@ -39,7 +39,7 @@ instance Pretty Raw where Op _ s t -> parenthesise (d > 0) $ hsep [ pretty s, "-", prettyPrec 1 t ] Guarded g t -> hsep [ "<", pretty t , ">"] -instance Pretty (Bwd SbstC) where +instance Pretty (Bwd Assign) where pretty sg = encloseSep lbrace rbrace ", " $ pretty <$> sg <>> [] prettyCdr :: Raw -> [Doc Annotations] @@ -48,10 +48,8 @@ prettyCdr = \case Cons _ p q -> pretty p : prettyCdr q p -> [pipe, pretty p] -instance Pretty SbstC where +instance Pretty Assign where pretty = \case - Keep _ x -> pretty x - Drop _ x -> pretty x <> "*" Assign _ x t -> pretty x <> equals <> pretty t instance Pretty ThDirective where diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 7c5cc2b..8c45cc3 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -39,6 +39,7 @@ import Control.Applicative ((<|>)) import Operator import Operator.Eval import Semantics +import Debug.Trace (traceShow) type CPattern = PATTERN Concrete type APattern = PATTERN Abstract @@ -63,7 +64,9 @@ checkSendableSubject tm = do Nothing -> Nothing <$ raiseWarning tm (SentSubjectNotASubjectVar tm) Just localVars -> go localVars x _ -> Nothing <$ raiseWarning tm (SentSubjectNotASubjectVar tm) - isInvertible :: Bwd String -> Bwd SbstC -> Maybe (Bwd String) + isInvertible :: Bwd String -> Bwd Assign -> Maybe (Bwd String) + isInvertible = undefined + {- isInvertible lvz B0 = pure lvz isInvertible (lvz :< w) (sz :< Keep _ v) | getVariable v == w = (:< w) <$> isInvertible lvz sz @@ -72,6 +75,7 @@ checkSendableSubject tm = do isInvertible lvz (sz :< Assign _ v (Var _ w)) | Just (lz, x, ls) <- focus (getVariable w) lvz = (:< getVariable v) <$> isInvertible (lz <>< ls) sz isInvertible _ _ = Nothing +-} escrutinee :: EScrutinee -> ASemanticsDesc escrutinee = \case @@ -119,9 +123,12 @@ smeta usage am sg (Tele desc (Scope (Hide x) tel)) = do t <- stm usage (desc //^ sg) (Var unknown $ Variable unknown x) smeta usage am (sbstT sg ((Hide x :=) $^ t)) tel --- TODO: pass (Maybe ASemanticsDesc) and handle macros -svar :: Usage -> Variable -> Elab (IsSubject, ASemanticsDesc, ACTm) -svar usage x = do +svar :: Usage + -> Maybe ASemanticsDesc + -> Variable + -> Elab (IsSubject, ASemanticsDesc, ACTm) +svar usage mdesc' x = do + let r = getRange x ovs <- asks objVars res <- resolve x case res of @@ -131,9 +138,22 @@ svar usage x = do let tel = discharge sc desc let am = ActorMeta (spassport usage isSub) (getVariable x) (desc, tm) <- smeta usage am (sbst0 $ scopeSize ovs) tel + desc <- fmap (fromMaybe desc) $ flip traverse mdesc' $ \desc' -> do + i <- compatibleInfos r (Known desc') (Known desc) + fromInfo r i -- cannot possibly fail + pure desc pure (isSub, desc, tm) _ -> throwComplaint x (NotAValidTermVariable x k) - Just (AnObjVar desc i) -> pure (IsNotSubject, desc, var i (scopeSize ovs)) + Just (AnObjVar desc i) -> do + desc <- fmap (fromMaybe desc) $ flip traverse mdesc' $ \desc' -> do + i <- compatibleInfos r (Known desc') (Known desc) + fromInfo r i -- cannot possibly fail + pure (IsNotSubject, desc, var i (scopeSize ovs)) + Just (AMacro t) -> do + (desc, t) <- case mdesc' of + Nothing -> itm usage t + Just desc -> (desc,) <$> stm usage desc t + pure (IsNotSubject, desc, t) Nothing -> throwComplaint x (OutOfScope x) spop :: Range -> Elab (ObjVars, (Variable, ASemanticsDesc)) @@ -151,9 +171,46 @@ ssyntaxdesc syndecls syn = do Nothing -> error "Impossible in ssyntaxdesc" -- this should be impossible, since parsed in empty context Just syn0 -> pure syn0 +smacro :: Bwd String -> Raw -> Elab () +smacro xz (Var r v) = do + unless (getVariable v `elem` xz) $ do + x <- resolve v + whenNothing x $ throwComplaint r (OutOfScope v) +smacro xz (At r a) = pure () +smacro xz (Cons r t u) = do + smacro xz t + smacro xz u +smacro xz (Lam r (Scope (Hide x) sc)) = do + xz <- case x of + Unused -> pure xz + Used x -> do x <- isFresh x + pure (xz :< x) + smacro xz sc +smacro xz (Sbst r sg t) = do + xz <- smacros xz (sg <>> []) + smacro xz t +smacro xz (Op r obj opps) = do + smacro xz obj + smacro xz opps +smacro xz (Guarded r t) = smacro xz t + +smacros :: Bwd String -> [Assign] -> Elab (Bwd String) +smacros xz [] = pure xz +smacros xz (Assign r x t : asss) = do + x <- isFresh x + smacro xz t + smacros (xz :< x) asss + +ssbst :: [Assign] -> Elab Macros +ssbst [] = asks macros +ssbst (Assign r x t : asss) = do + x <- isFresh x + smacro B0 t + local (declareMacro (x, t)) $ ssbst asss -ssbst :: Bwd SbstC -> Elab Macros -ssbst = undefined {-usage B0 = do + + +{-usage B0 = do ovs <- asks objVars pure (sbstI (scopeSize ovs), ovs) ssbst usage (sg :< sgc) = case sgc of @@ -168,7 +225,7 @@ ssbst usage (sg :< sgc) = case sgc of -} {- -ssbst :: Usage -> Bwd SbstC -> Elab (ACTSbst, ObjVars) +ssbst :: Usage -> Bwd Assign -> Elab (ACTSbst, ObjVars) ssbst usage B0 = do ovs <- asks objVars pure (sbstI (scopeSize ovs), ovs) @@ -210,7 +267,7 @@ sscrutinee :: CScrutinee -> Elab (EScrutinee, AScrutinee) sscrutinee (SubjectVar r v) = do -- TODO: shouldn't this svar return a syntax desc? -- We're in subject analysis mode - (isSub, desc, actm) <- svar (Scrutinised r) v + (isSub, desc, actm) <- svar (Scrutinised r) Nothing v case (isSub, actm) of (IsSubject{}, CdB (m :$ sg) _) -> pure (SubjectVar r desc, SubjectVar r actm) _ -> throwComplaint r (NotAValidSubjectVar v) @@ -221,14 +278,8 @@ sscrutinee (Pair r sc1 sc2) = do sscrutinee (Lookup r stk v) = do (stk, stkTy) <- isContextStack stk t <- during (LookupVarElaboration v) $ do - -- TODO: - -- Shouldn't this `svar LookedUp` return the SyntaxDesc attached - -- to v given that we are currently analysing it as a subject? - (isSub, desc, t) <- svar (LookedUp r) v - -- /!\ This is probably not correct. Cf. above comment about - -- LookedUp - let hmmmDesc = embed (keyDesc stkTy) - void $ compatibleInfos r (Known hmmmDesc) (Known desc) + desc <- asSemantics (keyDesc stkTy) + (isSub, desc, t) <- svar (LookedUp r) (Just desc) v pure t let vdesc = valueDesc stkTy desc = Semantics.contract (VEnumOrTag (scope vdesc) ["Nothing"] [("Just", [vdesc])]) @@ -373,16 +424,19 @@ spatSemantics desc rest rp = do local (setDecls ds) $ elabUnder (x, ts) $ spatSemantics (weak desc) (extend rest (getVariable <$> x)) t - pure (PP (AP "Pi") (PP ps (PP pt (AP ""))), ds, "Pi" #%+ [ts,tt]) + pure (PP (AP "Pi") (PP ps (PP pt (AP ""))) + , ds + , "Pi" #%+ [ts,tt]) _ -> throwComplaint r (ExpectedASemanticsPGot rp) LamP r (Scope v@(Hide x) p) -> do (s, desc) <- case vdesc of - VWildcard _ -> pure (desc, desc) - VBind cat desc -> pure (Semantics.catToDesc cat, desc) + VWildcard _ -> pure (desc, weak desc) + VBind cat desc -> pure (Semantics.catToDesc cat, weak desc) VPi s (y, t) -> pure (s, t) _ -> throwComplaint r (SyntaxPError desc rp) - elabUnder (x, s) $ spatSemantics desc (extend rest (getVariable <$> x)) p + (p, ds, t) <- elabUnder (x, s) $ spatSemantics desc (extend rest (getVariable <$> x)) p + traceShow t $ pure (p, ds, t) spatSemanticss :: [ASemanticsDesc] -> Restriction @@ -433,7 +487,7 @@ matchObjType r (mb , oty) (obDesc, ob) = do itm :: Usage -> Raw -> Elab (ASemanticsDesc, ACTm) itm usage (Var r v) = do - (_, desc, v) <- svar usage v + (_, desc, v) <- svar usage Nothing v pure (desc, v) -- rob -rop itm usage (Op r rob rop) = do @@ -516,11 +570,10 @@ sasot r (objVars :=> desc) = do stm :: Usage -> ASemanticsDesc -> Raw -> Elab ACTm stm usage desc (Var r v) = during (TermVariableElaboration v) $ do table <- gets syntaxCats - (_, desc', t) <- svar usage v - compatibleInfos (getRange v) (Known desc) (Known desc') + (_, _, t) <- svar usage (Just desc) v pure t stm usage desc (Sbst r sg t) = do - ms <- during (SubstitutionElaboration sg) $ ssbst sg + ms <- during (SubstitutionElaboration sg) $ ssbst (sg <>> []) local (setMacros ms) (stm usage desc t) stm usage desc rt = do table <- gets syntaxCats @@ -558,8 +611,8 @@ stm usage desc rt = do _ -> throwComplaint r (SyntaxError desc rt) Lam r (Scope (Hide x) sc) -> do (s, desc) <- case vdesc of - VWildcard i -> pure (desc, desc) - VBind cat desc -> pure (catToDesc cat, desc) + VWildcard i -> pure (desc, weak desc) + VBind cat desc -> pure (catToDesc cat, weak desc) VPi s (y, t) -> pure (s, t) _ -> throwComplaint r (SyntaxError desc rt) elabUnder (x, s) $ stm usage desc sc @@ -718,20 +771,12 @@ spatBase isSub desc rest rp = do LamP r (Scope v@(Hide x) p) -> do (s, desc) <- case vdesc of - VWildcard _ -> pure (desc, desc) - VBind cat desc -> pure (Semantics.catToDesc cat, desc) + VWildcard _ -> pure (desc, weak desc) + VBind cat desc -> pure (Semantics.catToDesc cat, weak desc) + VPi s (y, t) -> pure (s, t) _ -> throwComplaint r (SyntaxPError desc rp) - case x of - Unused -> do - (mr, p, ds, hs) <- spatBase isSub desc rest p - pure (mr, BP (Hide "_") p, ds, hs) - Used x -> do - x <- isFresh x - (mr, p, ds, hs) <- - local (declareObjVar (x, s) . addHint x (Known s)) $ - spatBase isSub desc (extend rest $ Used x) p - pure (mr, BP (Hide x) p, ds, hs) + elabUnder (x, s) $ spatBase isSub desc (extend rest (getVariable <$> x)) p isObjVar :: Variable -> Elab (ASemanticsDesc, DB) isObjVar p = resolve p >>= \case @@ -1030,7 +1075,7 @@ sact = \case Push r stk (rp, (), t) a -> do (stk, stkTy) <- isContextStack stk (desc, p) <- isObjVar rp - compatibleInfos (getRange rp) (Known desc) (Known $ embed $ keyDesc stkTy) + compatibleInfos (getRange rp) (Known desc) . Known =<< asSemantics (keyDesc stkTy) t <- during (PushTermElaboration t) $ stm (Pushed r) (valueDesc stkTy) t a <- sact a pure $ Push r stk (p, valueDesc stkTy, t) a diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 0e3f423..658431c 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -28,9 +28,16 @@ import Hide import Operator.Eval import Options import Semantics +import Data.Void (absurd) + ------------------------------------------------------------------------------ -- Elaboration Monad +asSemantics :: ASyntaxDesc -> Elab ASemanticsDesc +asSemantics syn = do + sc <- asks (scopeSize . objVars) + pure (embed sc syn) + data ElabState = ElabState { channelStates :: ChannelStates , actvarStates :: ActvarStates @@ -127,7 +134,10 @@ fromInfo r (Known desc) = pure desc -- 2. `compatibleInfos` where the error is handled locally fromInfo r Inconsistent = throwComplaint r InconsistentSyntaxDesc -compatibleInfos :: Range -> Info ASemanticsDesc -> Info ASemanticsDesc -> Elab (Info ASemanticsDesc) +compatibleInfos :: Range + -> Info ASemanticsDesc + -> Info ASemanticsDesc + -> Elab (Info ASemanticsDesc) compatibleInfos r desc desc' = do table <- gets syntaxCats dat <- asks headUpData @@ -191,9 +201,9 @@ instance Dischargeable Decls where -- Consequently, we must weaken them when we go under a binder. type Macros = Bwd (String, Raw) --- Macros are scope checked and expanded at def. site but --- not elaborated until use site. Hence, they cannot be recursive. The --- vars that occur in a Macro are CdBVars - we have checked they are +-- Macros are scope checked at definition site but not elaborated +-- until use site. They cannot be recursive. +-- The vars that occur in a Macro are CdBVars - we have checked they are -- in scope and if they are Macros, we have further expanded them. data Context = Context @@ -315,6 +325,9 @@ setDecls ds ctx = ctx { declarations = ds } setMacros :: Macros -> Context -> Context setMacros ms ctx = ctx { macros = ms } +declareMacro :: (String, Raw) -> Context -> Context +declareMacro xt ctx = ctx { macros = macros ctx :< xt } + ------------------------------------------------------------------------------ -- Hierarchical path names generation @@ -410,7 +423,7 @@ data ContextualInfo | DefnJElaboration Variable | ExecElaboration | DeclaringSyntaxCat SyntaxCat - | SubstitutionElaboration (Bwd SbstC) + | SubstitutionElaboration (Bwd Assign) | PatternVariableElaboration Variable | TermVariableElaboration Variable | ProtocolElaboration CProtocol diff --git a/Src/Machine/Trace.hs b/Src/Machine/Trace.hs index eb6ed66..2011349 100644 --- a/Src/Machine/Trace.hs +++ b/Src/Machine/Trace.hs @@ -424,9 +424,9 @@ extract mkF a = go where UnificationProblem date s t -> Error a (StuckUnifying s t) : go fs Noted -> Node a (AStep AlwaysExtract NotedStep) [] : go fs _ -> go fs - + toArgument :: AProtocolEntry -> Term -> AArgument f ann - toArgument (Subject desc, _) term = Argument (Subject ()) (embed desc) (mkF term a) + toArgument (Subject desc, _) term = Argument (Subject ()) (embed 0 desc) (mkF term a) --- TOOD: Fix embed call toArgument (Input, desc) term = Argument Input desc (mkF term a) toArgument (Output, desc) term = Argument Output desc (mkF term a) diff --git a/Src/Semantics.hs b/Src/Semantics.hs index 83331f6..2ec418c 100644 --- a/Src/Semantics.hs +++ b/Src/Semantics.hs @@ -18,8 +18,8 @@ import qualified Term import Syntax (SyntaxTable, SyntaxCat, WithSyntaxCat(..)) import Operator.Eval -embed :: ASyntaxDesc -> ASemanticsDesc -embed = (fmap absurd $^) +embed :: Int -> ASyntaxDesc -> ASemanticsDesc +embed sc syn = (fmap absurd $^ syn) *^ none sc data VSemanticsDesc' a -- embedding syntax @@ -74,7 +74,7 @@ expand' w table dat desc = do case w of Yes -> pure (VSyntaxCat sc a) No -> do guard b - go False (embed s) + go False (embed sc s) goTagged b s (a, sc) = case a of "AtomBar" -> asPair $ asListOf (asAtom $ Just . fst) diff --git a/Src/Term/Base.hs b/Src/Term/Base.hs index 9f34604..366455d 100644 --- a/Src/Term/Base.hs +++ b/Src/Term/Base.hs @@ -1,5 +1,6 @@ module Term.Base where +import qualified Data.Map as Map import Data.Traversable import Data.Void @@ -7,7 +8,7 @@ import Bwd import Thin import Hide import Pretty (Pretty(..)) - +import Location (Range) import Concrete.Base (Guard, Root) data Pairing = Cell | Oper @@ -268,12 +269,26 @@ instance Dischargeable (CdB (Tm m)) where instance Dischargeable () where x \\ t = t +instance Dischargeable Range where + _ \\ r = r + +instance Dischargeable a => Dischargeable (Maybe a) where + x \\ t = (x \\) <$> t + instance (Dischargeable a, Dischargeable b) => Dischargeable (a, b) where x \\ (s, t) = (x \\ s, x \\ t) instance (Dischargeable a, Dischargeable b, Dischargeable c) => Dischargeable (a, b, c) where x \\ (s, t, u) = (x \\ s, x \\ t, x \\ u) +instance ( Dischargeable a, Dischargeable b + , Dischargeable c, Dischargeable d) => + Dischargeable (a, b, c, d) where + x \\ (s, t, u, v) = (x \\ s, x \\ t, x \\ u, x \\ v) + +instance Dischargeable (Map.Map x v) where + _ \\ m = m + infixr 5 $: ($:) :: m -> CdB (Sbst m) -> CdB (Tm m) m $: sg = contract (m :$: sg) diff --git a/Src/Unelaboration.hs b/Src/Unelaboration.hs index 0dec160..8899a32 100644 --- a/Src/Unelaboration.hs +++ b/Src/Unelaboration.hs @@ -126,7 +126,7 @@ instance UnelabMeta m => Unelab (Tm m) where instance UnelabMeta m => Unelab (Sbst m) where type UnelabEnv (Sbst m) = Naming - type Unelabed (Sbst m) = Bwd SbstC + type Unelabed (Sbst m) = Bwd Assign unelab sg = do na@(_, th, _) <- ask case sg of @@ -139,13 +139,15 @@ instance UnelabMeta m => Unelab (Sbst m) where (_, th, _) | bigEnd th <= 0 -> throwError (UnexpectedEmptyThinning na) (xz, th, yz :< y) -> case thun th of (th, False) -> do + local (const (xz, th, yz)) $ unelab (sg :^^ w) + {- TODO: bring back printing of Drop? sg <- local (const (xz, th, yz)) $ unelab (sg :^^ w) pure (sg :< Drop unknown (Variable unknown y)) + -} (th, True) -> case xz of xz :< x -> do - sg <- local (const (xz, th, yz)) $ unelab (sg :^^ (w - 1)) - pure (sg :< Keep unknown (Variable unknown x)) + local (const (xz, th, yz)) $ unelab (sg :^^ (w - 1)) _ -> throwError $ InvalidNaming na _ -> throwError $ InvalidNaming na diff --git a/test/typecheck.act b/test/typecheck.act index 4fe49a6..0cf81c7 100644 --- a/test/typecheck.act +++ b/test/typecheck.act @@ -1,42 +1,48 @@ +{- typecheck 'Semantics : 'Semantics +-} syntax { 'Nat = ['EnumOrTag ['Zero] [['Suc 'Nat]]] } +{- typecheck 'Nat : 'Semantics typecheck 'Zero : 'Nat typecheck ['Suc 'Zero] : 'Nat -typecheck ['Pi 'Nat (\_.'Nat)] : 'Semantics -typecheck \x.x : ['Pi 'Nat (\_.'Nat)] +typecheck ['Pi 'Nat \_.'Nat] : 'Semantics +typecheck \x.x : ['Pi 'Nat \_.'Nat] typecheck \x.'Zero : ['Pi 'Nat \_.'Nat] typecheck ['Pi 'Semantics \X.['Pi X \_.X]] : 'Semantics typecheck \X x.x : ['Pi 'Semantics \X.['Pi X \_.X]] operator - { 'Nat -[ 'mul 'Nat ] : 'Nat - ; 'Nat -[ 'add 'Nat ] : 'Nat + { 'Nat -[ 'add 'Nat ] : 'Nat + ; 'Nat -[ 'mul 'Nat ] : 'Nat } -- TODO: improve error message for: -- \x.'Zero : ['Pi 'Nat \_.'Nat] -[ 'mul m ] ~> 'Zero -'Zero : 'Nat -[ 'mul n ] ~> 'Zero -['Suc m] : 'Nat -[ 'mul n ] ~> n -['add m -['mul n]] - 'Zero : 'Nat -[ 'add n ] ~> n ['Suc m] : 'Nat -[ 'add n ] ~> ['Suc m -['add n]] -operator - { ['Pi a \x.b] -['apply (t : a)] : {x=t}b } - --- TODO: get capture working? --- operator { ['Pi a \x.b] -['apply (x : a)] : b } +'Zero : 'Nat -[ 'mul n ] ~> 'Zero +['Suc m] : 'Nat -[ 'mul n ] ~> n -['add m -['mul n]] +m : 'Nat -['add n ] -['mul p ] + ~> (m -['mul p]) -['add (n -['mul p ])] -\x.'Zero : ['Pi 'Nat \_.'Nat] -[ 'apply t ] ~> 'Zero +operator + { ['Pi a \x.b] -['apply (t : a)] : {x=t}b + ; ['Pi a \x.b] -['apply2 (x : a)] : b + } +-} +\x.b : ['Pi 'Nat \_.'Nat] -[ 'apply t ] ~> 'Zero +{- exec PRINTF "Hurrah!". +-} \ No newline at end of file From 0291db8ff29a5a69a9dd90e4c04963503b6d49ab Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Thu, 23 Feb 2023 16:32:53 +0000 Subject: [PATCH 49/89] [ debug ] found the issue! --- Src/Elaboration.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 8c45cc3..d917e37 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -39,7 +39,7 @@ import Control.Applicative ((<|>)) import Operator import Operator.Eval import Semantics -import Debug.Trace (traceShow) +import Debug.Trace (traceShow, traceId) type CPattern = PATTERN Concrete type APattern = PATTERN Abstract @@ -435,8 +435,7 @@ spatSemantics desc rest rp = do VBind cat desc -> pure (Semantics.catToDesc cat, weak desc) VPi s (y, t) -> pure (s, t) _ -> throwComplaint r (SyntaxPError desc rp) - (p, ds, t) <- elabUnder (x, s) $ spatSemantics desc (extend rest (getVariable <$> x)) p - traceShow t $ pure (p, ds, t) + elabUnder (x, s) $ spatSemantics desc (extend rest (getVariable <$> x)) p spatSemanticss :: [ASemanticsDesc] -> Restriction @@ -621,12 +620,12 @@ stm usage desc rt = do compatibleInfos (getRange rt) (Known tdesc) (Known desc) pure t -elabUnder :: Dischargeable a => (Binder Variable, ASemanticsDesc) -> Elab a -> Elab a +elabUnder :: Show a => Dischargeable a => (Binder Variable, ASemanticsDesc) -> Elab a -> Elab a elabUnder (x, desc) ma = do x <- case x of Used x -> isFresh x Unused -> pure "_" - (x \\) <$> local (declareObjVar (x, desc)) ma + (x \\) . (\ x -> traceShow x x) <$> local (declareObjVar (x, desc)) ma spats :: IsSubject -> [ASemanticsDesc] -> Restriction -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) spats _ [] rest (AtP r "") = (Nothing, AP "",,) <$> asks declarations <*> asks binderHints From 885695fe1720fdc93d4b55a2ee8a04b827499aa5 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Thu, 23 Feb 2023 16:59:02 +0000 Subject: [PATCH 50/89] [ TODO ] Refactor this bug fix in a clean manner --- Src/Elaboration.hs | 26 ++++++++++++++++++++------ Src/Elaboration/Monad.hs | 1 - test/typecheck.act | 7 ------- 3 files changed, 20 insertions(+), 14 deletions(-) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index d917e37..6669f23 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -39,7 +39,7 @@ import Control.Applicative ((<|>)) import Operator import Operator.Eval import Semantics -import Debug.Trace (traceShow, traceId) +import Debug.Trace (traceShow) type CPattern = PATTERN Concrete type APattern = PATTERN Abstract @@ -422,8 +422,16 @@ spatSemantics desc rest rp = do (ps, ds, ts) <- spatSemantics desc rest s (pt, ds, tt) <- local (setDecls ds) $ - elabUnder (x, ts) $ - spatSemantics (weak desc) (extend rest (getVariable <$> x)) t + elabUnder (x, ts) $ do + -- TODO: refactor this + -- complex interaction between restriction throwing "_" out of scope + -- and Discheargeable (via elabUnder) abstracting over it on the way out + (pt, ds, tt) <- spatSemantics (weak desc) (extend rest (getVariable <$> x)) t + (pt, tt) <- case x of + Unused -> do sc <- asks (scopeSize . objVars) + pure (pt *^ (ones sc -? False), weak tt) + Used _ -> pure (pt, tt) + pure (pt, ds, tt) pure (PP (AP "Pi") (PP ps (PP pt (AP ""))) , ds , "Pi" #%+ [ts,tt]) @@ -435,7 +443,10 @@ spatSemantics desc rest rp = do VBind cat desc -> pure (Semantics.catToDesc cat, weak desc) VPi s (y, t) -> pure (s, t) _ -> throwComplaint r (SyntaxPError desc rp) - elabUnder (x, s) $ spatSemantics desc (extend rest (getVariable <$> x)) p + elabUnder (x, s) $ do + (pt, ds, tt) <- spatSemantics desc (extend rest (getVariable <$> x)) p + sc <- asks (scopeSize . objVars) + pure (pt *^ (ones sc -? False), ds, weak tt) spatSemanticss :: [ASemanticsDesc] -> Restriction @@ -625,7 +636,7 @@ elabUnder (x, desc) ma = do x <- case x of Used x -> isFresh x Unused -> pure "_" - (x \\) . (\ x -> traceShow x x) <$> local (declareObjVar (x, desc)) ma + (x \\) {-. (\ x -> traceShow x x) -} <$> local (declareObjVar (x, desc)) ma spats :: IsSubject -> [ASemanticsDesc] -> Restriction -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) spats _ [] rest (AtP r "") = (Nothing, AP "",,) <$> asks declarations <*> asks binderHints @@ -775,7 +786,10 @@ spatBase isSub desc rest rp = do VPi s (y, t) -> pure (s, t) _ -> throwComplaint r (SyntaxPError desc rp) - elabUnder (x, s) $ spatBase isSub desc (extend rest (getVariable <$> x)) p + elabUnder (x, s) $ do + (mr, p, ds, hs) <- spatBase isSub desc (extend rest (getVariable <$> x)) p + sc <- asks (scopeSize . objVars) + pure (mr, p *^ (ones sc -? False), ds, hs) isObjVar :: Variable -> Elab (ASemanticsDesc, DB) isObjVar p = resolve p >>= \case diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 658431c..5778396 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -234,7 +234,6 @@ extend :: Restriction {- gamma -} extend (Restriction ls th) (Used x) = Restriction (ls :< x) (th -? True) extend (Restriction ls th) Unused = Restriction ls (th -? False) - instance Selable Restriction where ph ^? Restriction ls th = Restriction (ph ^? ls) (ph ^? th) diff --git a/test/typecheck.act b/test/typecheck.act index 0cf81c7..2e99ad4 100644 --- a/test/typecheck.act +++ b/test/typecheck.act @@ -1,12 +1,9 @@ -{- typecheck 'Semantics : 'Semantics --} syntax { 'Nat = ['EnumOrTag ['Zero] [['Suc 'Nat]]] } -{- typecheck 'Nat : 'Semantics typecheck 'Zero : 'Nat typecheck ['Suc 'Zero] : 'Nat @@ -38,11 +35,7 @@ operator { ['Pi a \x.b] -['apply (t : a)] : {x=t}b ; ['Pi a \x.b] -['apply2 (x : a)] : b } --} \x.b : ['Pi 'Nat \_.'Nat] -[ 'apply t ] ~> 'Zero -{- - exec PRINTF "Hurrah!". --} \ No newline at end of file From c8fb36e5ac8e7365c602d5f6713a65dfa51d76e6 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 28 Feb 2023 15:02:50 +0000 Subject: [PATCH 51/89] [ refactor ] last week's dodgy-looking elabUnders --- Src/Elaboration.hs | 121 +++++++++++++++++++++------------------------ 1 file changed, 57 insertions(+), 64 deletions(-) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 6669f23..fbd6469 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -336,8 +336,20 @@ data ConsDesc | ConsEnum [(String, [ASemanticsDesc])] | ConsUniverse -spatSemantics :: ASemanticsDesc -> Restriction -> CPattern -> - Elab (APattern, Decls, ACTm) +vconsDesc :: Range -> ASemanticsDesc -> RawP -- for the error message + -> VSemanticsDesc -> Elab ConsDesc +vconsDesc r desc rp vdesc = case vdesc of + VNilOrCons d1 d2 -> pure (ConsCell d1 d2) + VCons d1 d2 -> pure (ConsCell d1 d2) + VWildcard _ -> pure (ConsCell desc desc) + VEnumOrTag _ _ ds -> pure (ConsEnum ds) + VUniverse _ -> pure ConsUniverse + _ -> throwComplaint r (SyntaxPError desc rp) + +spatSemantics :: ASemanticsDesc {- gamma -} + -> {- r :: -} Restriction {- gamma -} + -> CPattern {- should fit in r.support -} + -> Elab (APattern {- gamma -}, Decls, ACTm {- gamma -}) spatSemantics desc rest (Irrefutable r p) = do raiseWarning r (IgnoredIrrefutable p) -- TODO spatSemantics desc rest p @@ -350,8 +362,7 @@ spatSemantics desc rest (AsP r v p) = do pure (AT (ActorMeta ACitizen v) p, ds, t) spatSemantics desc rest (ThP r ph p) = do ph <- sth rest ph - (p, ds, t) <- spatSemantics desc (ph ^? rest) p - pure (p *^ ph, ds, t *^ ph) + spatSemantics desc (ph ^? rest) p spatSemantics desc rest (UnderscoreP r) = do ds <- asks declarations let hack = Variable r ("_" ++ show (length ds)) @@ -360,20 +371,18 @@ spatSemantics desc rest (VarP r v) = during (PatternVariableElaboration v) $ do ds <- asks declarations res <- resolve v let th = restriction rest - let scp = weeEnd th case res of Just (AnObjVar desc' i) -> do - i <- case thickx th i of -- TODO: do we need to check whether desc' is thickenable? - Nothing -> throwComplaint r (OutOfScope v) - Just i -> pure i + -- TODO: do we need to check whether desc' is thickenable? + whenNothing (thickx th i) $ throwComplaint r (OutOfScope v) compatibleInfos (getRange v) (Known desc) (Known desc') - pure (VP i, ds, var i scp) + pure (VP i, ds, var i (bigEnd th)) Just mk -> throwComplaint r (NotAValidPatternVariable v mk) Nothing -> do (ovs, asot) <- thickenedASOT r th desc - v <- pure (getVariable v) - let pat = MP (ActorMeta ACitizen v) (ones scp) - pure (pat, ds :< (v, ActVar IsNotSubject asot), ActorMeta ACitizen v $: sbstI scp) + v <- isFresh v + let pat = MP (ActorMeta ACitizen v) th + pure (pat, ds :< (v, ActVar IsNotSubject asot), ActorMeta ACitizen v $: sbstW (sbstI 0) th) spatSemantics desc rest rp = do table <- gets syntaxCats dat <- asks headUpData @@ -391,18 +400,10 @@ spatSemantics desc rest rp = do VWildcard sc -> pure () VUniverse _ -> unless (a `elem` ("Semantics" : Map.keys table)) $ throwComplaint r (ExpectedASemanticsGot (At r a)) _ -> throwComplaint r (SyntaxPError desc rp) - pure (AP a, ds, atom a (weeEnd (restriction rest))) + pure (AP a, ds, atom a (bigEnd (restriction rest))) ConsP r p1 p2 -> do -- take vdesc apart and decide what needs to be checked - -- Left (d1, d2): usual cons cell - -- Right ds : enumeration (ds :: [(String, [Desc])]) - descs <- case vdesc of - VNilOrCons d1 d2 -> pure (ConsCell d1 d2) - VCons d1 d2 -> pure (ConsCell d1 d2) - VWildcard _ -> pure (ConsCell desc desc) - VEnumOrTag _ _ ds -> pure (ConsEnum ds) - VUniverse _ -> pure ConsUniverse - _ -> throwComplaint r (SyntaxPError desc rp) + descs <- vconsDesc r desc rp vdesc case descs of ConsCell d1 d2 -> do (p1, ds, t1) <- spatSemantics d1 rest p1 @@ -421,17 +422,8 @@ spatSemantics desc rest rp = do (AtP _ "Pi", ConsP _ s (ConsP _ (LamP _ (Scope (Hide x) t)) (AtP _ ""))) -> do (ps, ds, ts) <- spatSemantics desc rest s (pt, ds, tt) <- - local (setDecls ds) $ - elabUnder (x, ts) $ do - -- TODO: refactor this - -- complex interaction between restriction throwing "_" out of scope - -- and Discheargeable (via elabUnder) abstracting over it on the way out - (pt, ds, tt) <- spatSemantics (weak desc) (extend rest (getVariable <$> x)) t - (pt, tt) <- case x of - Unused -> do sc <- asks (scopeSize . objVars) - pure (pt *^ (ones sc -? False), weak tt) - Used _ -> pure (pt, tt) - pure (pt, ds, tt) + local (setDecls ds) $ elabUnder (x, ts) $ + spatSemantics (weak desc) (extend rest (getVariable <$> x)) t pure (PP (AP "Pi") (PP ps (PP pt (AP ""))) , ds , "Pi" #%+ [ts,tt]) @@ -443,10 +435,7 @@ spatSemantics desc rest rp = do VBind cat desc -> pure (Semantics.catToDesc cat, weak desc) VPi s (y, t) -> pure (s, t) _ -> throwComplaint r (SyntaxPError desc rp) - elabUnder (x, s) $ do - (pt, ds, tt) <- spatSemantics desc (extend rest (getVariable <$> x)) p - sc <- asks (scopeSize . objVars) - pure (pt *^ (ones sc -? False), ds, weak tt) + elabUnder (x, s) $ spatSemantics desc (extend rest (getVariable <$> x)) p spatSemanticss :: [ASemanticsDesc] -> Restriction @@ -756,29 +745,35 @@ spatBase isSub desc rest rp = do _ -> throwComplaint r (SyntaxPError desc rp) (Nothing, AP a,,) <$> asks declarations <*> asks binderHints - ConsP r p q -> case vdesc of - VNilOrCons d1 d2 -> do - (mr1, p, ds, hs) <- spatBase isSub d1 rest p - (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spatBase isSub d2 rest q) - pure (mr1 <|> mr2, PP p q, ds, hs) - VCons d1 d2 -> do - (mr1, p, ds, hs) <- spatBase isSub d1 rest p - (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spatBase isSub d2 rest q) - pure (mr1 <|> mr2, PP p q, ds, hs) - VWildcard _ -> do - (mr1, p, ds, hs) <- spatBase isSub desc rest p - (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spatBase isSub desc rest q) - pure (mr1 <|> mr2, PP p q, ds, hs) - VEnumOrTag _ _ ds -> case p of - AtP r a -> case lookup a ds of - Nothing -> throwComplaint r (ExpectedTagGot (fst <$> ds) a) - Just descs -> do - (mr1, p, ds, hs) <- spatBase isSub (atom "Atom" 0) rest p - (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spats isSub descs rest q) - pure (mr1 <|> mr2, PP p q, ds, hs) - _ -> throwComplaint r (SyntaxPError desc rp) - _ -> throwComplaint r (SyntaxPError desc rp) - + ConsP r p q -> do + -- take vdesc apart and decide what needs to be checked + descs <- vconsDesc r desc rp vdesc + case descs of + ConsCell d1 d2 -> do + (mr1, p, ds, hs) <- spatBase isSub d1 rest p + (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spatBase isSub d2 rest q) + pure (mr1 <|> mr2, PP p q, ds, hs) + ConsEnum ds -> case p of + AtP r a -> case lookup a ds of + Nothing -> throwComplaint r (ExpectedTagGot (fst <$> ds) a) + Just descs -> do + (mr1, p, ds, hs) <- spatBase isSub (atom "Atom" 0) rest p + (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spats isSub descs rest q) + pure (mr1 <|> mr2, PP p q, ds, hs) + _ -> throwComplaint r (SyntaxPError desc rp) + ConsUniverse -> case (isSub, p, q) of + (IsNotSubject, AtP _ "Pi", ConsP _ s (ConsP _ (LamP _ (Scope (Hide x) t)) (AtP _ ""))) -> do + (ps, ds, s) <- spatSemantics desc rest s + (mr, pt, ds, hs) <- + local (setDecls ds) $ + elabUnder (x, s) $ + spatBase isSub (weak desc) (extend rest (getVariable <$> x)) q + pure ( mr + , PP (AP "Pi") (PP ps (PP pt (AP ""))) + , ds + , hs) + (IsSubject{}, _, _) -> throwComplaint r undefined + _ -> throwComplaint r (ExpectedASemanticsPGot rp) LamP r (Scope v@(Hide x) p) -> do (s, desc) <- case vdesc of VWildcard _ -> pure (desc, weak desc) @@ -786,10 +781,8 @@ spatBase isSub desc rest rp = do VPi s (y, t) -> pure (s, t) _ -> throwComplaint r (SyntaxPError desc rp) - elabUnder (x, s) $ do - (mr, p, ds, hs) <- spatBase isSub desc (extend rest (getVariable <$> x)) p - sc <- asks (scopeSize . objVars) - pure (mr, p *^ (ones sc -? False), ds, hs) + elabUnder (x, s) $ + spatBase isSub desc (extend rest (getVariable <$> x)) p isObjVar :: Variable -> Elab (ASemanticsDesc, DB) isObjVar p = resolve p >>= \case From 0a2f4ada4ba8a54b56b5be7f5242126f892adb5f Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 28 Feb 2023 16:48:07 +0000 Subject: [PATCH 52/89] [ fix ] scope of context stack decls & binder annotations --- Src/Concrete/Base.hs | 14 +++++++---- Src/Concrete/Parse.hs | 2 +- Src/Concrete/Pretty.hs | 11 ++++++--- Src/Elaboration.hs | 53 +++++++++++++++++++++++++--------------- Src/Elaboration/Monad.hs | 22 +++++++++++------ Src/Machine/Exec.hs | 4 +-- Src/Unelaboration.hs | 4 ++- examples/stlc.act | 6 ++--- 8 files changed, 73 insertions(+), 43 deletions(-) diff --git a/Src/Concrete/Base.hs b/Src/Concrete/Base.hs index 925cd74..d6f6fac 100644 --- a/Src/Concrete/Base.hs +++ b/Src/Concrete/Base.hs @@ -7,6 +7,7 @@ import Bwd import Format import Scope import Location +import Data.Bifunctor (Bifunctor (..)) data Variable = Variable { variableLoc :: Range @@ -161,10 +162,13 @@ deriving instance , Show (SEMANTICSDESC ph)) => Show (PROTOCOL ph) data ContextStack k v = ContextStack - { keyDesc :: k - , valueDesc :: v + { keyDesc :: k {- syntax desc -} + , valueDesc :: v {- closed semantics desc -} } deriving (Show) +instance Bifunctor ContextStack where + bimap f g (ContextStack k v) = ContextStack (f k) (g v) + data CConnect = CConnect Variable Variable deriving (Show) @@ -260,7 +264,7 @@ data ACTOR (ph :: Phase) | Note Range (ACTOR ph) | FreshMeta Range (SEMANTICSDESC ph) (ACTORVAR ph, ACTOR ph) | Let Range (ACTORVAR ph) (SEMANTICSDESC ph) (TERM ph) (ACTOR ph) - | Under Range (Scope Variable (ACTOR ph)) + | Under Range (Maybe (SEMANTICSDESC ph)) (Scope Variable (ACTOR ph)) | Match Range (SCRUTINEE ph) [(PATTERN ph, ACTOR ph)] -- This is going to bite us when it comes to dependent types | Constrain Range (TERM ph) (TERM ph) @@ -306,7 +310,7 @@ instance HasSetRange (ACTOR ph) where Note _ ac -> Note r ac FreshMeta _ syn x0 -> FreshMeta r syn x0 Let _ x d t a -> Let r x d t a - Under _ sc -> Under r sc + Under _ mty sc -> Under r mty sc Match _ tm x0 -> Match r tm x0 Constrain _ tm tm' -> Constrain r tm tm' Push _ jd x0 ac -> Push r jd x0 ac @@ -325,7 +329,7 @@ instance HasGetRange (ACTOR ph) where Note r ac -> r FreshMeta r syn x0 -> r Let r _ _ _ _ -> r - Under r sc -> r + Under r mty sc -> r Match r tm x0 -> r Constrain r tm tm' -> r Push r jd x0 ac -> r diff --git a/Src/Concrete/Parse.hs b/Src/Concrete/Parse.hs index 3ddab26..47e92f5 100644 --- a/Src/Concrete/Parse.hs +++ b/Src/Concrete/Parse.hs @@ -162,7 +162,7 @@ pscrutinee = withRange $ do pact :: Parser CActor pact = withRange $ - pscoped Under pvariable pact + do { ty <- optional pTM; pscoped (flip Under ty) pvariable pact } <|> Send unknown <$> pvariable <*> pure () <* punc "!" <*> pmustwork "Expected a term" pTM <* punc "." <*> pact <|> do tm <- pTM punc "?" diff --git a/Src/Concrete/Pretty.hs b/Src/Concrete/Pretty.hs index 0f9db2d..97bf677 100644 --- a/Src/Concrete/Pretty.hs +++ b/Src/Concrete/Pretty.hs @@ -117,7 +117,7 @@ prettyact = go B0 B0 where Recv r ch (av, a) -> go ls (l `add` [pretty ch, "?", pretty av, dot]) a FreshMeta r syn (av, a) -> freshMetas ls l syn (B0 :< av) a Let r av syn t a -> go (ls :< fold (l `add` [hsep ["let", pretty av, ":", pretty syn, "=", pretty t] <> dot])) B0 a - Under r (Scope x a) -> unders ls l (B0 :< x) a + Under r mty (Scope x a) -> unders ls l mty (B0 :< x) a Note r a -> go ls (l `add` ["!", dot]) a Push r stk (x, _, t) a -> let push = hsep [pretty stk, "|-", pretty x, "->", pretty t] <> dot in @@ -139,9 +139,14 @@ prettyact = go B0 B0 where unders :: Bwd (Doc Annotations) -> -- lines above us Bwd (Doc Annotations) -> -- part of the line on our left + Maybe Raw -> -- Type annotation Bwd (Hide Variable) -> CActor -> [Doc Annotations] - unders ls l xs (Under _ (Scope x a)) = unders ls l (xs :< x) a - unders ls l xs a = go ls (l `add` [backslash , hsep (pretty <$> xs <>> []), dot]) a + unders ls l mty xs (Under _ mty' (Scope x a)) + | mty == mty' = unders ls l mty (xs :< x) a + unders ls l mty xs a + = go ls (l `add` [ maybe id (\ ty r -> pretty ty <+> r) mty backslash + , hsep (pretty <$> xs <>> []) + , dot]) a instance Pretty CActor where diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index fbd6469..de69550 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -39,7 +39,8 @@ import Control.Applicative ((<|>)) import Operator import Operator.Eval import Semantics -import Debug.Trace (traceShow) +import Debug.Trace (traceShow, traceShowId) +import Data.Bifunctor (bimap) type CPattern = PATTERN Concrete type APattern = PATTERN Abstract @@ -278,7 +279,7 @@ sscrutinee (Pair r sc1 sc2) = do sscrutinee (Lookup r stk v) = do (stk, stkTy) <- isContextStack stk t <- during (LookupVarElaboration v) $ do - desc <- asSemantics (keyDesc stkTy) + let desc = asSemantics (keyDesc stkTy) (isSub, desc, t) <- svar (LookedUp r) (Just desc) v pure t let vdesc = valueDesc stkTy @@ -423,6 +424,7 @@ spatSemantics desc rest rp = do (ps, ds, ts) <- spatSemantics desc rest s (pt, ds, tt) <- local (setDecls ds) $ elabUnder (x, ts) $ +-- local (addHint (getVariable <$> x) (Known desc)) $ spatSemantics (weak desc) (extend rest (getVariable <$> x)) t pure (PP (AP "Pi") (PP ps (PP pt (AP ""))) , ds @@ -435,7 +437,9 @@ spatSemantics desc rest rp = do VBind cat desc -> pure (Semantics.catToDesc cat, weak desc) VPi s (y, t) -> pure (s, t) _ -> throwComplaint r (SyntaxPError desc rp) - elabUnder (x, s) $ spatSemantics desc (extend rest (getVariable <$> x)) p + elabUnder (x, s) $ +-- local (addHint (getVariable <$> x) (Known s)) $ + spatSemantics desc (extend rest (getVariable <$> x)) p spatSemanticss :: [ASemanticsDesc] -> Restriction @@ -568,7 +572,6 @@ sasot r (objVars :=> desc) = do stm :: Usage -> ASemanticsDesc -> Raw -> Elab ACTm stm usage desc (Var r v) = during (TermVariableElaboration v) $ do - table <- gets syntaxCats (_, _, t) <- svar usage (Just desc) v pure t stm usage desc (Sbst r sg t) = do @@ -662,7 +665,7 @@ spat esc rest p@VarP{} = spatBase (Pattern <$ isSubject esc) (escrutinee esc) re spat esc rest (ThP r ph p) = do ph <- sth rest ph (mr, p, ds, hs) <- spat esc (ph ^? rest) p - pure (mr, p *^ ph, ds, hs) + pure (mr, p, ds, hs) spat esc rest p@(UnderscoreP r) = do (_, p, ds, hs) <- spatBase (Pattern <$ isSubject esc) (escrutinee esc) rest p let mr = r <$ guard (not (isSubjectFree esc)) @@ -692,7 +695,11 @@ thickenedASOT r th desc = do Just desc -> pure desc pure (ovs, ovs :=> desc) -spatBase :: IsSubject -> ASemanticsDesc -> Restriction -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) +spatBase :: IsSubject + -> ASemanticsDesc + -> Restriction + -> RawP + -> Elab (Maybe Range, Pat, Decls, Hints) spatBase isSub desc rest rp@(AsP r v p) = do unless (isSub == IsNotSubject) $ throwComplaint r (AsPatternCannotHaveSubjects rp) @@ -704,7 +711,7 @@ spatBase isSub desc rest rp@(AsP r v p) = do spatBase isSub desc rest (ThP r ph p) = do ph <- sth rest ph (mr, p, ds, hs) <- spatBase isSub desc (ph ^? rest) p - pure (mr, p *^ ph, ds, hs) + pure (mr, p, ds, hs) spatBase isSub desc rest (VarP r v) = during (PatternVariableElaboration v) $ do ds <- asks declarations hs <- asks binderHints @@ -712,9 +719,8 @@ spatBase isSub desc rest (VarP r v) = during (PatternVariableElaboration v) $ do let th = restriction rest case res of Just (AnObjVar desc' i) -> do - i <- case thickx th i of -- TODO: do we need to check whether desc' is thickenable? - Nothing -> throwComplaint r (OutOfScope v) - Just i -> pure i + -- TODO: do we need to check whether desc' is thickenable? + whenNothing (thickx th i) $ throwComplaint r (OutOfScope v) compatibleInfos (getRange v) (Known desc) (Known desc') pure (Nothing, VP i, ds, hs) Just mk -> throwComplaint r (NotAValidPatternVariable v mk) @@ -767,7 +773,8 @@ spatBase isSub desc rest rp = do (mr, pt, ds, hs) <- local (setDecls ds) $ elabUnder (x, s) $ - spatBase isSub (weak desc) (extend rest (getVariable <$> x)) q +-- local (addHint (getVariable <$> x) (Known desc)) $ + spatBase isSub (weak desc) (extend rest (getVariable <$> x)) q pure ( mr , PP (AP "Pi") (PP ps (PP pt (AP ""))) , ds @@ -782,7 +789,8 @@ spatBase isSub desc rest rp = do _ -> throwComplaint r (SyntaxPError desc rp) elabUnder (x, s) $ - spatBase isSub desc (extend rest (getVariable <$> x)) p +-- local (addHint (getVariable <$> x) (Known s)) $ + spatBase isSub desc (extend rest (getVariable <$> x)) p isObjVar :: Variable -> Elab (ASemanticsDesc, DB) isObjVar p = resolve p >>= \case @@ -817,7 +825,9 @@ isJudgement jd = resolve jd >>= \case isContextStack :: Variable -> Elab (Stack, AContextStack) isContextStack stk = resolve stk >>= \case - Just (ADeclaration (AStack stkTy)) -> pure (Stack (getVariable stk), stkTy) + Just (ADeclaration (AStack stkTy)) -> do + scp <- asks (scopeSize . objVars) + pure (Stack (getVariable stk), bimap (weaks scp) (weaks scp) stkTy) Just mk -> throwComplaint stk (NotAValidStack stk mk) Nothing -> throwComplaint stk (OutOfScope stk) @@ -1055,12 +1065,14 @@ sact = \case a <- local (declare (Used av) (ActVar IsNotSubject (ovs :=> desc))) $ sact a pure (Let r (ActorMeta ACitizen av) desc t a) - Under r (Scope v@(Hide x) a) -> do + Under r mdesc (Scope v@(Hide x) a) -> do x <- during UnderElaboration $ isFresh x -- TODO: Have the syntax carry a desc? Fail if the hint is Unknown? - desc <- fromInfo r =<< getHint x + desc <- case mdesc of + Nothing -> fromInfo r =<< getHint x + Just desc -> sty desc a <- local (declareObjVar (x, desc)) $ sact a - pure $ Under r (Scope v a) + pure $ Under r (desc <$ mdesc) (Scope v a) Match r rsc cls -> do (esc, sc) <- during (MatchScrutineeElaboration rsc) $ sscrutinee rsc @@ -1079,9 +1091,9 @@ sact = \case pure $ Match r sc cls Push r stk (rp, (), t) a -> do - (stk, stkTy) <- isContextStack stk - (desc, p) <- isObjVar rp - compatibleInfos (getRange rp) (Known desc) . Known =<< asSemantics (keyDesc stkTy) + (stk, stkTy) <- traceShowId <$> isContextStack stk + (desc, p) <- traceShowId <$> isObjVar rp + compatibleInfos (getRange rp) (Known desc) (Known $ asSemantics (keyDesc stkTy)) t <- during (PushTermElaboration t) $ stm (Pushed r) (valueDesc stkTy) t a <- sact a pure $ Push r stk (p, valueDesc stkTy, t) a @@ -1151,7 +1163,8 @@ sclause esc (rp, a) = do ovs <- asks objVars (mr, p, ds, hs) <- lift $ during (MatchBranchElaboration rp) $ spat esc (initRestriction ovs) rp let pats = takez ds (length ds - length ds0) - coverageCheckClause rp p + + traceShow hs $ coverageCheckClause rp p (a, me) <- lift $ during (MatchBranchElaboration rp) $ local (setDecls ds . setHints hs) $ sbranch (getRange rp) pats a lift $ modify (\ st -> st { actvarStates = avs }) diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 5778396..0c94550 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -29,14 +29,13 @@ import Operator.Eval import Options import Semantics import Data.Void (absurd) +import Data.Bifunctor (bimap) ------------------------------------------------------------------------------ -- Elaboration Monad -asSemantics :: ASyntaxDesc -> Elab ASemanticsDesc -asSemantics syn = do - sc <- asks (scopeSize . objVars) - pure (embed sc syn) +asSemantics :: ASyntaxDesc -> ASemanticsDesc +asSemantics syn = fmap absurd $^ syn data ElabState = ElabState { channelStates :: ChannelStates @@ -274,11 +273,16 @@ initContext opts = Context } -- We have already checked the name is fresh -declareObjVar :: (String, ASemanticsDesc) -> Context -> Context +declareObjVar :: ( {- x :: -} String + , {- S :: -} ASemanticsDesc {- gamma -}) + -> Context {- gamma -} + -> Context {- gamma, x :: S -} declareObjVar (x, sem) ctx = -- We store semantics descs ready to be deployed at use sites let scp = getObjVars (objVars ctx) :< ObjVar x sem in - ctx { objVars = ObjVars (fmap weak <$> scp) } + ctx { objVars = ObjVars (fmap weak <$> scp) + , binderHints = fmap weak <$> binderHints ctx + } -- Careful! The new ovs better be a valid scope -- i.e. all the objvars mentioned in the SemanticsDesc of @@ -357,8 +361,10 @@ addOperator op ctx = setHints :: Hints -> Context -> Context setHints hs ctx = ctx { binderHints = hs } -addHint :: String -> Info ASemanticsDesc -> Context -> Context -addHint str cat ctx = +-- TODO: hints should be ASOTs +addHint :: Binder String -> Info ASemanticsDesc -> Context -> Context +addHint Unused cat ctx = ctx +addHint (Used str) cat ctx = let hints = binderHints ctx hints' = case Map.lookup str hints of Nothing -> Map.insert str cat hints diff --git a/Src/Machine/Exec.hs b/Src/Machine/Exec.hs index dcf8969..e30f005 100644 --- a/Src/Machine/Exec.hs +++ b/Src/Machine/Exec.hs @@ -177,7 +177,7 @@ exec p@Process { actor = Constrain _ s t, ..} -- , dmesg (show t ++ " ----> " ++ show t') True = let dat = mkHeadUpData p in unify dat (p { stack = stack :<+>: [UnificationProblem (today store) s' t'], actor = Win unknown }) -exec p@Process { actor = Under _ (Scope (Hide x) a), ..} +exec p@Process { actor = Under _ _ (Scope (Hide x) a), ..} = let scopeSize = length (globalScope env <> localScope env) stack' = stack :< Binding (tryAlpha env (getVariable x) ++ "_" ++ show scopeSize) env' = env { localScope = localScope env :< tryAlpha env (getVariable x) } @@ -423,7 +423,7 @@ move p@Process { stack = zf :< UnificationProblem date s t :<+>: fs, .. } | today store > date = let dat = mkHeadUpData (p{ stack = zf}) in unify dat (p { stack = zf :<+>: UnificationProblem (today store) s t : fs }) -move p@Process { stack = (zf :< f) :<+>: fs } +move p@Process { stack = (zf :< f) :<+>: fs } = move (p { stack = zf :<+>: (f : fs) }) debug :: (Show (t Frame), Traversable t, Collapse t, Display0 s) diff --git a/Src/Unelaboration.hs b/Src/Unelaboration.hs index 8899a32..3c40b85 100644 --- a/Src/Unelaboration.hs +++ b/Src/Unelaboration.hs @@ -292,7 +292,9 @@ instance Unelab AActor where Recv r ch (av, a) -> Recv r <$> subunelab ch <*> ((,) <$> subunelab av <*> unelab a) FreshMeta r desc (av, a) -> FreshMeta r <$> subunelab desc <*> ((,) <$> subunelab av <*> unelab a) Let r av desc t a -> Let r <$> subunelab av <*> subunelab desc <*> subunelab t <*> unelab a - Under r (Scope x a) -> Under r. Scope x <$> local (updateNaming (`nameOn` getVariable (unhide x))) (unelab a) + Under r mty (Scope x a) -> + Under r <$> traverse subunelab mty + <*> (Scope x <$> local (updateNaming (`nameOn` getVariable (unhide x))) (unelab a)) Push r stk (p, _, t) a -> Push r <$> subunelab stk <*> ((,(),) <$> subunelab p <*> subunelab t) <*> unelab a Match r tm pts -> Match r <$> subunelab tm <*> traverse unelab pts Constrain r s t -> Constrain r <$> subunelab s <*> subunelab t diff --git a/examples/stlc.act b/examples/stlc.act index 6fa408e..ebdbb50 100644 --- a/examples/stlc.act +++ b/examples/stlc.act @@ -45,11 +45,11 @@ type@p = p?ty. case $ty ) } -check@p = p?ty. p?tm. case $tm - { ['Lam \x. body] -> +check@p = p?ty. p?tm. case tm + { ['Lam \x. body@['Lam \y._]] -> 'Type?S T. ( ty ~ ['Arr S T] - | \x. + | 'Synth\x. myCtxt |- x -> S. check@q. q!T. q!body.) ; ['Emb e] -> synth@q. q!e. q?S. S ~ ty From 225f9e6bbcee10b1e02aaa3b190191f1f8ca3c77 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 7 Mar 2023 15:17:46 +0000 Subject: [PATCH 53/89] [ fix ] got STLC working! --- Src/Elaboration.hs | 42 ++++++++++++++++++++++++--------------- Src/Elaboration/Pretty.hs | 5 ++++- Src/Rules.hs | 2 +- Src/Semantics.hs | 6 +----- examples/stlc.act | 4 ++-- 5 files changed, 34 insertions(+), 25 deletions(-) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index de69550..7b2d639 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -39,8 +39,9 @@ import Control.Applicative ((<|>)) import Operator import Operator.Eval import Semantics -import Debug.Trace (traceShow, traceShowId) +import Debug.Trace (traceShow, traceShowId, trace) import Data.Bifunctor (bimap) +import GHC.Stack.Types (HasCallStack) type CPattern = PATTERN Concrete type APattern = PATTERN Abstract @@ -132,6 +133,7 @@ svar usage mdesc' x = do let r = getRange x ovs <- asks objVars res <- resolve x + {- trace ("Looking at " ++ show x ++ ", objvars: " ++ show ovs) $ -} case res of Just (ADeclaration k) -> case k of ActVar isSub (sc :=> desc) -> do @@ -166,7 +168,7 @@ spop r = do ssyntaxdesc :: [SyntaxCat] -> Raw -> Elab SyntaxDesc ssyntaxdesc syndecls syn = do - let desc = catToDesc "Syntax" + desc <- satom "Syntax" syn <- withSyntax (syntaxDesc syndecls) $ stm DontLog desc syn case isMetaFree syn of Nothing -> error "Impossible in ssyntaxdesc" -- this should be impossible, since parsed in empty context @@ -434,7 +436,7 @@ spatSemantics desc rest rp = do LamP r (Scope v@(Hide x) p) -> do (s, desc) <- case vdesc of VWildcard _ -> pure (desc, weak desc) - VBind cat desc -> pure (Semantics.catToDesc cat, weak desc) + VBind cat desc -> (, weak desc) <$> satom cat VPi s (y, t) -> pure (s, t) _ -> throwComplaint r (SyntaxPError desc rp) elabUnder (x, s) $ @@ -614,17 +616,21 @@ stm usage desc rt = do Lam r (Scope (Hide x) sc) -> do (s, desc) <- case vdesc of VWildcard i -> pure (desc, weak desc) - VBind cat desc -> pure (catToDesc cat, weak desc) + VBind cat desc -> (,weak desc) <$> satom cat VPi s (y, t) -> pure (s, t) _ -> throwComplaint r (SyntaxError desc rt) elabUnder (x, s) $ stm usage desc sc Op{} -> do (tdesc, t) <- itm usage rt - compatibleInfos (getRange rt) (Known tdesc) (Known desc) + compatibleInfos (getRange rt) (Known desc) (Known tdesc) pure t -elabUnder :: Show a => Dischargeable a => (Binder Variable, ASemanticsDesc) -> Elab a -> Elab a +elabUnder :: HasCallStack => Show a => Dischargeable a => (Binder Variable, ASemanticsDesc) -> Elab a -> Elab a elabUnder (x, desc) ma = do + scp <- asks (scopeSize . objVars) + unless (scp == scope desc) $ do + st <- asks stackTrace + error ("The IMPOSSIBLE has happened when binding " ++ show x ++ show st) x <- case x of Used x -> isFresh x Unused -> pure "_" @@ -784,7 +790,7 @@ spatBase isSub desc rest rp = do LamP r (Scope v@(Hide x) p) -> do (s, desc) <- case vdesc of VWildcard _ -> pure (desc, weak desc) - VBind cat desc -> pure (Semantics.catToDesc cat, weak desc) + VBind cat desc -> (, weak desc) <$> satom cat VPi s (y, t) -> pure (s, t) _ -> throwComplaint r (SyntaxPError desc rp) @@ -845,9 +851,9 @@ steppingChannel r ch step = do nm <- getName (dir, pnm, p) <- gets (fromJust . channelLookup ch) unless (pnm `isPrefixOf` nm) $ throwComplaint r (NonLinearChannelUse ch) - (cat, p) <- step dir p + (a, p) <- step dir p modify (channelInsert ch (dir, nm, p)) - pure cat + pure a open :: Direction -> Channel -> AProtocol -> Elab () open dir ch (Protocol p) = do @@ -966,7 +972,9 @@ sact = \case ch <- isChannel ch -- Check the channel is in sending mode, & step it (m, desc) <- steppingChannel r ch $ \ dir -> \case - (m, desc) : p | whatComm m dir == SEND -> pure ((m, desc), p) + (m, desc) : p | whatComm m dir == SEND -> + do scp <- asks (scopeSize . objVars) + pure ((m, weaks scp desc), p) _ -> throwComplaint r (InvalidSend ch tm) (usage, gd) <- do @@ -999,7 +1007,9 @@ sact = \case -- Check the channel is in receiving mode & step it (m, cat) <- steppingChannel r ch $ \ dir -> \case - (m, cat) : p | whatComm m dir == RECV -> pure ((m, cat), p) + (m, cat) : p | whatComm m dir == RECV -> + do scp <- asks (scopeSize . objVars) + pure ((m, weaks scp cat), p) _ -> throwComplaint r (InvalidRecv ch p) -- TODO: m contains a SyntaxDesc when it's a subject position @@ -1091,9 +1101,9 @@ sact = \case pure $ Match r sc cls Push r stk (rp, (), t) a -> do - (stk, stkTy) <- traceShowId <$> isContextStack stk - (desc, p) <- traceShowId <$> isObjVar rp - compatibleInfos (getRange rp) (Known desc) (Known $ asSemantics (keyDesc stkTy)) + (stk, stkTy) <- {- traceShowId <$> -} isContextStack stk + (desc, p) <- {- traceShowId <$> -} isObjVar rp + compatibleInfos (getRange rp) (Known $ asSemantics (keyDesc stkTy)) (Known desc) t <- during (PushTermElaboration t) $ stm (Pushed r) (valueDesc stkTy) t a <- sact a pure $ Push r stk (p, valueDesc stkTy, t) a @@ -1163,8 +1173,8 @@ sclause esc (rp, a) = do ovs <- asks objVars (mr, p, ds, hs) <- lift $ during (MatchBranchElaboration rp) $ spat esc (initRestriction ovs) rp let pats = takez ds (length ds - length ds0) - - traceShow hs $ coverageCheckClause rp p + {- traceShow hs $ -} + coverageCheckClause rp p (a, me) <- lift $ during (MatchBranchElaboration rp) $ local (setDecls ds . setHints hs) $ sbranch (getRange rp) pats a lift $ modify (\ st -> st { actvarStates = avs }) diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index c8c6a42..51b2ae8 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -185,7 +185,10 @@ instance Pretty (WithRange Complaint) where InconsistentSyntaxDesc -> "Inconsistent syntactic descriptions" InvalidSyntaxDesc d -> hsep ["Invalid syntax desc", pretty d] IncompatibleSemanticsDescs desc desc' -> - hsep ["Incompatible semantics descriptions", {-prettyPrec 1-} pretty (show desc), "and", {-prettyPrec 1-} pretty (show desc')] + hsep [ "Incompatible semantics descriptions, expected" + , {-prettyPrec 1-} pretty (show desc) + , "but got" + , {-prettyPrec 1-} pretty (show desc')] IncompatibleSyntaxInfos info1 info2 -> hsep ["Syntax infos", pretty info1, "and", pretty info2, "are incompatible"] GotBarredAtom a as -> hsep diff --git a/Src/Rules.hs b/Src/Rules.hs index 2bf8cb4..3dbc3f2 100644 --- a/Src/Rules.hs +++ b/Src/Rules.hs @@ -61,7 +61,7 @@ data PLACEKIND (ph :: Phase) mkSubjectPlace :: SYNTAXDESC Concrete -> Maybe (SEMANTICSDESC Concrete) -> PLACEKIND Concrete -mkSubjectPlace syn = SubjectPlace syn . fromMaybe syn +mkSubjectPlace syn = SubjectPlace syn . fromMaybe syn data CJudgementForm = JudgementForm { jrange :: Range diff --git a/Src/Semantics.hs b/Src/Semantics.hs index 2ec418c..930d950 100644 --- a/Src/Semantics.hs +++ b/Src/Semantics.hs @@ -102,7 +102,7 @@ contract' w = \case VNil sc -> atom "Nil" sc VCons s t -> "Cons" #%+ [s, t] VNilOrCons s t -> "NilOrCons" #%+ [s, t] - VBind cat s -> "Bind" #%+ [catToDesc cat, s] + VBind cat s -> "Bind" #%+ [atom cat (scope s), s] VEnumOrTag sc es ts -> "EnumOrTag" #%+ [enums sc (\ s -> atom s sc) es, enums sc ( \ (t, s) -> (t,0) #% s) ts] VWildcard sc -> atom "Wildcard" sc @@ -118,10 +118,6 @@ contract' w = \case contract :: VSemanticsDesc -> ASemanticsDesc contract = contract' No - -catToDesc :: SyntaxCat -> ASemanticsDesc -catToDesc c = atom c 0 - validate :: Show m => SyntaxTable -> Bwd SyntaxCat -> ASemanticsDesc -> CdB (Tm m) -> Bool validate table = undefined -- TODO REVERT {- diff --git a/examples/stlc.act b/examples/stlc.act index ebdbb50..e13bbc9 100644 --- a/examples/stlc.act +++ b/examples/stlc.act @@ -45,8 +45,8 @@ type@p = p?ty. case $ty ) } -check@p = p?ty. p?tm. case tm - { ['Lam \x. body@['Lam \y._]] -> +check@p = p?ty. p?tm. case $tm + { ['Lam \x. body] -> 'Type?S T. ( ty ~ ['Arr S T] | 'Synth\x. From 1cdb00b10ff606bbcf941397348edc1c4fc29c2a Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 7 Mar 2023 15:30:50 +0000 Subject: [PATCH 54/89] [ fix ] got stlc2 working! --- Src/Elaboration.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 7b2d639..2762516 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -56,6 +56,7 @@ checkSendableSubject tm = do localVars <- asks (getObjVars . objVars) go (fmap objVarName localVars) tm where + -- TODO: move this check to *after* elaboration? Might be easier. go :: Bwd String -> Raw -> Elab (Maybe ActorVar) go localVars x = case x of Var r v -> resolve v >>= \case @@ -67,17 +68,16 @@ checkSendableSubject tm = do Just localVars -> go localVars x _ -> Nothing <$ raiseWarning tm (SentSubjectNotASubjectVar tm) isInvertible :: Bwd String -> Bwd Assign -> Maybe (Bwd String) - isInvertible = undefined - {- isInvertible lvz B0 = pure lvz +{- isInvertible (lvz :< w) (sz :< Keep _ v) | getVariable v == w = (:< w) <$> isInvertible lvz sz isInvertible (lvz :< w) (sz :< Drop _ v) | getVariable v == w = isInvertible lvz sz +-} isInvertible lvz (sz :< Assign _ v (Var _ w)) | Just (lz, x, ls) <- focus (getVariable w) lvz = (:< getVariable v) <$> isInvertible (lz <>< ls) sz isInvertible _ _ = Nothing --} escrutinee :: EScrutinee -> ASemanticsDesc escrutinee = \case From 9446f927d41de761f6d0d3f5bc68e682f9b9ee64 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 7 Mar 2023 15:33:13 +0000 Subject: [PATCH 55/89] [ cleanup ] got stlc3 working! --- examples/stlc3.act | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/examples/stlc3.act b/examples/stlc3.act index 3ab1d05..97417f6 100644 --- a/examples/stlc3.act +++ b/examples/stlc3.act @@ -12,6 +12,14 @@ syntax ] } +type : $'Type. +type@p = p?ty. case $ty + { 'Base -> + ; 'Nat -> + ; 'Bool -> + ; ['Arr s t] -> (type@q. q!s. | type@r. r!t.) + } + check : ?'Type. $'Check. synth : $'Synth. !'Type. ctxt |- 'Synth -> 'Type @@ -26,7 +34,7 @@ check@p = p?ty. p?tm. case $tm synth@p = p?tm . case (lookup ctxt tm) { ['Just S] -> p!S. ; 'Nothing -> case $tm - { ['Rad t ty] -> (check@q. q!ty. q!t. | p!ty.) + { ['Rad t ty] -> (check@q. q!ty. q!t. | p!ty. | type@r. r!ty.) ; ['App f s] -> 'Type?U. 'Type?V. ( synth@q. q!f. q?ty. ty ~ ['Arr U V] | check@r. r!U. r!s. From 5ec64bcdda72834da13b6791c93bfcc76e40b3c8 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 7 Mar 2023 15:40:00 +0000 Subject: [PATCH 56/89] [ fix ] got stlctpp working! --- Src/Elaboration.hs | 2 +- examples/stlctpp.act | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 2762516..c310f37 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -593,7 +593,7 @@ stm usage desc rt = do VNilOrCons{} -> unless (a == "") $ throwComplaint r (ExpectedNilGot a) VEnumOrTag _ es _ -> unless (a `elem` es) $ throwComplaint r (ExpectedEnumGot es a) VWildcard _ -> pure () - VUniverse _ -> unless (a `elem` ("Semantics" : Map.keys table)) $ throwComplaint r (ExpectedASemanticsGot rt) + VUniverse _ -> unless (a `elem` ("Atom" : "Nil" : "Wildcard" : "Semantics" : Map.keys table)) $ throwComplaint r (ExpectedASemanticsGot rt) -- TODO we're probably missing semantics here _ -> throwComplaint r (SemanticsError desc rt) satom a diff --git a/examples/stlctpp.act b/examples/stlctpp.act index bd08de0..3791976 100644 --- a/examples/stlctpp.act +++ b/examples/stlctpp.act @@ -1,4 +1,4 @@ -trace { exec } +-- trace { exec } syntax { 'Check = ['EnumOrTag ['Nil] From 42bdc93d699b107ef61b3070b404c66a72cd06d2 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 7 Mar 2023 16:05:47 +0000 Subject: [PATCH 57/89] [ fix ] got stlctpp2 working! --- Src/Elaboration.hs | 27 ++++++++++++++------------- Src/Elaboration/Monad.hs | 5 ++++- examples/stlctpp2.act | 2 +- 3 files changed, 19 insertions(+), 15 deletions(-) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index c310f37..fbc6ef9 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -46,6 +46,8 @@ import GHC.Stack.Types (HasCallStack) type CPattern = PATTERN Concrete type APattern = PATTERN Abstract +dmesg = const id + isSubject :: EScrutinee -> IsSubject' () isSubject SubjectVar{} = IsSubject () isSubject _ = IsNotSubject @@ -133,8 +135,7 @@ svar usage mdesc' x = do let r = getRange x ovs <- asks objVars res <- resolve x - {- trace ("Looking at " ++ show x ++ ", objvars: " ++ show ovs) $ -} - case res of + dmesg ("Looking at " ++ show x ++ ", objvars: " ++ show ovs) $ case res of Just (ADeclaration k) -> case k of ActVar isSub (sc :=> desc) -> do logUsage (getVariable x) usage @@ -301,9 +302,6 @@ sscrutinee (Term r t) = during (ScrutineeTermElaboration t) $ do pure (Term r desc, Term r t) -satom :: String -> Elab ACTm -satom at = atom at <$> asks (scopeSize . objVars) - sty :: CSemanticsDesc -> Elab ASemanticsDesc sty t = do sem <- satom "Semantics" @@ -611,6 +609,10 @@ stm usage desc rt = do s <- sty s t <- elabUnder (x, s) $ sty t pure ("Pi" #%+ [s, t]) + (At _ "Cons", Cons _ s (Cons _ t (At _ ""))) -> do + s <- sty s + t <- sty t + pure ("Cons" #%+ [s, t]) _ -> throwComplaint r (ExpectedASemanticsGot rt) _ -> throwComplaint r (SyntaxError desc rt) Lam r (Scope (Hide x) sc) -> do @@ -893,7 +895,7 @@ guessDesc b (Cons _ p q) = do (Known d1, Known d2) -> pure (Known $ Semantics.contract (Semantics.VCons d1 d2)) _ -> pure Unknown -- might need better guess for the scope than 0 -guessDesc True (At _ "") = pure (Known $ Semantics.contract (Semantics.VNil 0)) +guessDesc True (At _ "") = Known <$> satom "Nil" guessDesc _ _ = pure Unknown compatibleChannels :: Range @@ -972,9 +974,7 @@ sact = \case ch <- isChannel ch -- Check the channel is in sending mode, & step it (m, desc) <- steppingChannel r ch $ \ dir -> \case - (m, desc) : p | whatComm m dir == SEND -> - do scp <- asks (scopeSize . objVars) - pure ((m, weaks scp desc), p) + (m, desc) : p | whatComm m dir == SEND -> pure ((m, desc), p) _ -> throwComplaint r (InvalidSend ch tm) (usage, gd) <- do @@ -997,7 +997,9 @@ sact = \case -- 3. thx is the thinning embedding sc back into ovs -- => setObjVars would be legitimate because xyz is a valid scope let (thx, xyz, thy) = lintersection (getObjVars sc) (getObjVars ovs) - (*^ thx) <$> local (setObjVars' $ ObjVars xyz) (stm usage desc tm) + let ovs = ObjVars xyz + desc <- pure (weaks (scopeSize ovs) desc) + (*^ thx) <$> local (setObjVars' ovs) (stm usage desc tm) a <- sact a pure $ Send r ch gd tm a @@ -1007,9 +1009,7 @@ sact = \case -- Check the channel is in receiving mode & step it (m, cat) <- steppingChannel r ch $ \ dir -> \case - (m, cat) : p | whatComm m dir == RECV -> - do scp <- asks (scopeSize . objVars) - pure ((m, weaks scp cat), p) + (m, cat) : p | whatComm m dir == RECV -> pure ((m, cat), p) _ -> throwComplaint r (InvalidRecv ch p) -- TODO: m contains a SyntaxDesc when it's a subject position @@ -1025,6 +1025,7 @@ sact = \case -- Further actor sc <- channelScope ch + cat <- pure (weaks (scopeSize sc) cat) (a, All canwin) <- local (declare av (ActVar isSub (sc :=> cat))) -- GOTO $ listen $ sact diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 0c94550..4c04d3b 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -123,8 +123,11 @@ infoExpand dat table s = case Semantics.expand table dat s of Just (VWildcard _) -> Unknown Just a -> Known a +satom :: String -> Elab ACTm +satom at = atom at <$> asks (scopeSize . objVars) + fromInfo :: Range -> Info ASemanticsDesc -> Elab ASemanticsDesc -fromInfo r Unknown = pure (atom "Wildcard" 0) +fromInfo r Unknown = satom "Wildcard" fromInfo r (Known desc) = pure desc -- I believe this last case is currently unreachable because this -- may only arise from a call to (<>) and this is only used in two diff --git a/examples/stlctpp2.act b/examples/stlctpp2.act index e61f9ef..e6873c4 100644 --- a/examples/stlctpp2.act +++ b/examples/stlctpp2.act @@ -88,7 +88,7 @@ synth@p = p?tm . checkEval@p = p?ty. p?tm. case tm { ['Lam \x.body] -> case ty - { ['Arr s t] -> \yy. evalCtxt |- yy -> [yy | s]. + { ['Arr s t] -> 'Synth\yy. evalCtxt |- yy -> [yy | s]. checkEval@q. q!t. q!{x=yy}body. q?nf. p!['Lam \z.{yy=z}nf]. ; _ -> #"Expected a function type" From f98428ff5e22df33a2f2da661b8f584fb55d60ed Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 7 Mar 2023 17:07:33 +0000 Subject: [PATCH 58/89] [ fix ] got krivine2 working! --- Src/Concrete/Pretty.hs | 4 ++-- Src/Elaboration.hs | 4 ++-- examples/krivine2.act | 23 +++++++++++++++++------ 3 files changed, 21 insertions(+), 10 deletions(-) diff --git a/Src/Concrete/Pretty.hs b/Src/Concrete/Pretty.hs index 97bf677..d570a7c 100644 --- a/Src/Concrete/Pretty.hs +++ b/Src/Concrete/Pretty.hs @@ -168,9 +168,9 @@ instance Pretty CActor where instance Pretty Debug where pretty = \case - ShowEnv -> "%e" + ShowEnv -> "%E" ShowStack -> "%S" - ShowStore -> "%m" + ShowStore -> "%M" instance Pretty Directive where pretty = \case diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index fbc6ef9..dd6cdd2 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -734,8 +734,8 @@ spatBase isSub desc rest (VarP r v) = during (PatternVariableElaboration v) $ do Just mk -> throwComplaint r (NotAValidPatternVariable v mk) Nothing -> do (ovs, asot) <- thickenedASOT r th desc - v <- pure (getVariable v) - let pat = MP (ActorMeta (spassport (Scrutinised unknown) isSub) v) (ones $ scopeSize ovs) + v <- isFresh v + let pat = MP (ActorMeta (spassport (Scrutinised unknown) isSub) v) th pure (Nothing, pat, ds :< (v, ActVar isSub asot), hs) spatBase isSub desc rest (UnderscoreP r) = do let mr = case isSub of diff --git a/examples/krivine2.act b/examples/krivine2.act index 794baaa..4da1678 100644 --- a/examples/krivine2.act +++ b/examples/krivine2.act @@ -21,7 +21,7 @@ unwind@p = p?tm. p?stk. case stk { ['Lam \x.b] -> -- stack is empty: evaluate under a binder with a placeholder variable \x. env |- x -> ['Variable x]. - krivine@q. q!b. q![]. q?res. p!['Lam \x.res]. + krivine@q. q!b. q![]. q?res. p!['Lam \x.res]. ; _ -> p!tm. } ; [a | as] -> case tm @@ -38,18 +38,29 @@ unwind@p = p?tm. p?stk. case stk krivine@p = p?tm. p?stk. case (lookup env tm) - { ['Just ['Argument val]] -> krivine@q. q!val. q!stk. q?res. p!res. - ; ['Just ['Variable var]] -> unwind@q. q!var. q!stk. q?res. p!res. + { ['Just ['Argument val]] -> krivine@q. q!val. q!stk. q?res. p!res. -- compute (val stk) + ; ['Just ['Variable var]] -> unwind@q. q!var. q!stk. q?res. p!res. -- return (var $$ stk) ; 'Nothing -> case tm { ['App f t] -> 'Term?vt. ( krivine@q. q!t. q![]. q?res. res ~ vt | krivine@q. q!f. q![vt|stk]. q?res. p!res. ) - ; _ -> unwind@q. q!tm. q!stk. q?res. p!res. + ; ['Lam \x.body] -> unwind@q. q!tm. q!stk. q?res. p!res. } } + +exec krivine@p. + p!['App ['Lam \f. f] -- id + ['Lam \g. g]]. -- id + p![]. p?v. PRINTF "%i" v. + +exec krivine@p. + p!['App ['Lam \f. ['Lam \x.['App f ['App f x]]]] -- id + ['Lam \g. g]]. -- id + p![]. p?v. PRINTF "%i" v. + exec krivine@p. - p!['App ['Lam \f. ['Lam \x. ['App f ['App f x]]]] - ['Lam \g. ['Lam \y. ['App g ['App g y]]]]]. + p!['App ['Lam \f. ['Lam \x. ['App f ['App f x]]]] -- 2 + ['Lam \g. ['Lam \y. ['App g ['App g y]]]]]. -- 2 p![]. p?v. PRINTF "%i" v . From 38cb83532dfb63a7cc798e649c1f47de473ed924 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 7 Mar 2023 17:09:16 +0000 Subject: [PATCH 59/89] [ test ] updating some golden files --- examples/golden/krivine2.gold | 2 ++ examples/golden/stlc3.gold | 6 ------ examples/krivine.act | 2 +- examples/krivine2.act | 2 +- 4 files changed, 4 insertions(+), 8 deletions(-) diff --git a/examples/golden/krivine2.gold b/examples/golden/krivine2.gold index cda1d84..026d54a 100644 --- a/examples/golden/krivine2.gold +++ b/examples/golden/krivine2.gold @@ -1,5 +1,7 @@ ret > ExitSuccess out > ['Lam \x. ['Lam \y. ['App x ['App x ['App x ['App x y]]]]]] +out > ['Lam \x. x] +out > ['Lam \g. g] out > err > err > diff --git a/examples/golden/stlc3.gold b/examples/golden/stlc3.gold index ee1af52..619921f 100644 --- a/examples/golden/stlc3.gold +++ b/examples/golden/stlc3.gold @@ -1,9 +1,3 @@ ret > ExitSuccess -out > Warning: stlc3.act:29:5-16 -out > Pattern subject ty did not get scrutinised -out > when elaborating a case branch handling the pattern ['Rad t ty] -out > when elaborating a case branch handling the pattern 'Nothing -out > when elaborating the judgement definition for synth -out > err > err > diff --git a/examples/krivine.act b/examples/krivine.act index 8987670..4884bf7 100644 --- a/examples/krivine.act +++ b/examples/krivine.act @@ -1,4 +1,4 @@ -trace { exec } +-- trace { exec } syntax { 'Term = ['Tag [ diff --git a/examples/krivine2.act b/examples/krivine2.act index 4da1678..bc03b15 100644 --- a/examples/krivine2.act +++ b/examples/krivine2.act @@ -1,4 +1,4 @@ -trace { break } +-- trace { break } syntax { 'Term = ['Tag [ From d80e8bc46a8023250654a70616f09007de771d44 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Wed, 8 Mar 2023 14:55:59 +0000 Subject: [PATCH 60/89] [ debugging ] HasCallStack for all uses of thun --- Src/Term/Base.hs | 7 +++++-- Src/Thin.hs | 14 +++++++------- 2 files changed, 12 insertions(+), 9 deletions(-) diff --git a/Src/Term/Base.hs b/Src/Term/Base.hs index 366455d..33514b2 100644 --- a/Src/Term/Base.hs +++ b/Src/Term/Base.hs @@ -11,6 +11,8 @@ import Pretty (Pretty(..)) import Location (Range) import Concrete.Base (Guard, Root) +import GHC.Stack + data Pairing = Cell | Oper deriving (Show, Eq, Ord) @@ -128,7 +130,8 @@ sbstDom (sg :^^ w) = case sg of ST (CdB sg th :<>: t) -> sbstDom sg + 1 + w sbstSel - :: Th -- ga0 from ga + :: HasCallStack + => Th -- ga0 from ga -> Sbst m -- ga -> de -> CdB (Sbst m) sbstSel th (S0 :^^ w) = CdB (S0 :^^ weeEnd th) th -- w = bigEnd th @@ -165,7 +168,7 @@ expand (CdB t th) = case t of (?:) :: CdB (Tm m) -> (Xn m -> a) -> a t ?: f = f (expand t) -contract :: Xn m -> CdB (Tm m) +contract :: HasCallStack => Xn m -> CdB (Tm m) contract t = case t of VX x ga -> CdB V (inx (x, ga)) AX a ga -> CdB (A a) (none ga) diff --git a/Src/Thin.hs b/Src/Thin.hs index 270ee59..c18e9c5 100644 --- a/Src/Thin.hs +++ b/Src/Thin.hs @@ -26,7 +26,7 @@ class Thable t where (*^) :: HasCallStack => t -> Th -> t class Selable t where - (^?) :: Th -> t -> t + (^?) :: HasCallStack => Th -> t -> t instance Thable (CdB a) where CdB a th *^ ph = CdB a (th *^ ph) @@ -111,12 +111,12 @@ inx :: ( DB -- var is non-negative and strictly less than inx (DB i, j) {- | 0 <= i && i < j -} = Th (bit i) j -- th must not be 0 -lsb :: Th -> DB +lsb :: HasCallStack => Th -> DB lsb th = case thun th of (_, True) -> DB 0 (th, False) -> scc (lsb th) -thickx :: Th -> DB -> Maybe DB +thickx :: HasCallStack => Th -> DB -> Maybe DB thickx (Th th i) v | i <= 0 = error $ "thickx with i = " ++ show i thickx th v = case thun th of (th, False) -> guard (v > DB 0) >> thickx th (prd v) @@ -139,7 +139,7 @@ thChop :: Th -> Int -> (Th, Th) thChop (Th th i) j = (Th (shiftR th j) (i-j), Th (th .&. full j) j) -- "take" from the wee end -chopTh :: Int -> Th -> (Th, Th) +chopTh :: HasCallStack => Int -> Th -> (Th, Th) chopTh 0 th = (th, ones 0) chopTh w th = case thun th of (th, True) -> chopTh (w-1) th <> (ones 0, ones 1) @@ -169,7 +169,7 @@ support (CdB _ th) = weeEnd th -- Invariant: bigEnd th = bigEnd ph -- The big ends of the outputs coincide at the union. -cop :: Th -> Th -> CdB (Th, Th) +cop :: HasCallStack => Th -> Th -> CdB (Th, Th) cop th ph | bigEnd th == 0 = CdB (none 0, none 0) (none 0) | otherwise = case (thun th, thun ph) of @@ -206,7 +206,7 @@ instance Selable (Bwd x) where -- (iz, th) and (jz, ph) are images for some of a scope -- compute a merge of iz and jz which are images for -- the union of th and ph -riffle :: (Bwd a, Th) -> (Bwd a, Th) -> Bwd a +riffle :: HasCallStack => (Bwd a, Th) -> (Bwd a, Th) -> Bwd a riffle (B0, _) (jz, _) = jz riffle (iz :< i, th) (jz, ph) = case thun th of (th, True) -> case (jz, thun ph) of @@ -226,7 +226,7 @@ riffle (iz :< i, th) (jz, ph) = case thun th of -- | vv -- o---ph---->o -- Note: invariant that bigEnd th == bigEnd ph -pullback :: Th -> Th -> (Th, Th, Th) +pullback :: HasCallStack => Th -> Th -> (Th, Th, Th) pullback th ph | bigEnd th == 0 = (none 0, none 0, none 0) | otherwise = case (thun th, thun ph) of From 34e5698ce93827bfb56d60dfaa88a423846ce94a Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Thu, 9 Mar 2023 16:52:14 +0000 Subject: [PATCH 61/89] got elaboration.act working! --- Src/Elaboration.hs | 70 ++++++++++++++++++++++++++++++++++----- Src/Elaboration/Monad.hs | 2 ++ Src/Elaboration/Pretty.hs | 2 ++ Src/Term/Base.hs | 3 +- test/semanticPi.act | 5 +++ 5 files changed, 71 insertions(+), 11 deletions(-) create mode 100644 test/semanticPi.act diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index dd6cdd2..a77797b 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -435,7 +435,7 @@ spatSemantics desc rest rp = do (s, desc) <- case vdesc of VWildcard _ -> pure (desc, weak desc) VBind cat desc -> (, weak desc) <$> satom cat - VPi s (y, t) -> pure (s, t) + VPi s (y, t) -> throwComplaint r (CantMatchOnPi desc rp) _ -> throwComplaint r (SyntaxPError desc rp) elabUnder (x, s) $ -- local (addHint (getVariable <$> x) (Known s)) $ @@ -458,9 +458,13 @@ isList :: Raw -> Elab [Raw] isList (At r "") = pure [] isList (At r a) = throwComplaint r (ExpectedNilGot a) isList (Cons r p q) = (p:) <$> isList q - isList t = throwComplaint t (ExpectedAConsGot t) +mkList :: [ACTm] -> Elab ACTm +mkList ts = do + snil <- satom "" + pure (foldr (%) snil ts) + -- Input: fully applied operator ready to operate -- Output: (abstract operator, raw parameters) sop :: Raw -> Elab (AAnOperator, [Raw]) @@ -591,8 +595,7 @@ stm usage desc rt = do VNilOrCons{} -> unless (a == "") $ throwComplaint r (ExpectedNilGot a) VEnumOrTag _ es _ -> unless (a `elem` es) $ throwComplaint r (ExpectedEnumGot es a) VWildcard _ -> pure () - VUniverse _ -> unless (a `elem` ("Atom" : "Nil" : "Wildcard" : "Semantics" : Map.keys table)) $ throwComplaint r (ExpectedASemanticsGot rt) - -- TODO we're probably missing semantics here + VUniverse _ -> unless (a `elem` ("Atom" : "Nil" : "Wildcard" : "Syntax" : "Semantics" : Map.keys table)) $ throwComplaint r (ExpectedASemanticsGot rt) _ -> throwComplaint r (SemanticsError desc rt) satom a Cons r p q -> case vdesc of @@ -602,17 +605,28 @@ stm usage desc rt = do VEnumOrTag _ _ ds -> case p of At r a -> case lookup a ds of Nothing -> throwComplaint r (ExpectedTagGot (fst <$> ds) a) - Just descs -> (%) <$> stm usage (atom "Atom" 0) p <*> stms usage descs q + Just descs -> do + adesc <- satom "Atom" + (%) <$> stm usage adesc p <*> stms usage descs q _ -> throwComplaint r (SyntaxError desc rt) VUniverse _ -> case (p , q) of (At _ "Pi", Cons _ s (Cons _ (Lam _ (Scope (Hide x) t)) (At _ ""))) -> do s <- sty s t <- elabUnder (x, s) $ sty t pure ("Pi" #%+ [s, t]) - (At _ "Cons", Cons _ s (Cons _ t (At _ ""))) -> do + (At _ a, Cons _ s (Cons _ t (At _ ""))) | a `elem` ["Cons", "NilOrCons", "Bind"] -> do s <- sty s t <- sty t - pure ("Cons" #%+ [s, t]) + pure (a #%+ [s, t]) + (At _ a, Cons _ es nil@(At _ "")) | a `elem` ["Enum", "AtomBar"] -> + senumortag r a es nil + (At _ "Tag", Cons _ tds nil@(At _ "")) -> + senumortag r "Tag" nil tds + (At _ "EnumOrTag", Cons _ es (Cons _ tds nil@(At _ ""))) -> + senumortag r "EnumOrTag" es tds + (At _ "Fix", Cons _ f (At _ "")) -> do + f <- stm usage (Semantics.contract (VBind "Semantics" desc)) f + pure ("Fix" #%+ [f]) _ -> throwComplaint r (ExpectedASemanticsGot rt) _ -> throwComplaint r (SyntaxError desc rt) Lam r (Scope (Hide x) sc) -> do @@ -627,6 +641,42 @@ stm usage desc rt = do compatibleInfos (getRange rt) (Known desc) (Known tdesc) pure t +senumortag :: Range -> String -> Raw -> Raw -> Elab ACTm +senumortag r a es tds = do + -- elaborate enums + es <- isList es + es <- forM es $ \case + (At _ a) -> do + e <- satom a + pure (a, e) + x -> do + adesc <- satom "Atom" + throwComplaint x (SyntaxError adesc x) + (as, es) <- do pure (unzip es) + whenLeft (allUnique as) $ \ a -> throwComplaint r (DuplicatedTag a) + es <- mkList es + -- elaborate tags + tds <- isList tds + tds <- forM tds $ \case + (Cons _ (At _ ra) args) -> do + args <- isList args + args <- traverse sty args + a <- satom ra + as <- mkList (a:args) + pure (ra, as) + x -> throwComplaint x (ExpectedAConsGot x) + (ts, tds) <- do pure (unzip tds) + whenLeft (allUnique ts) $ \ a -> throwComplaint r (DuplicatedTag a) + tds <- mkList tds + -- put things back together + case a of + "AtomBar" -> do + a <- satom a + mkList [a,es] + _ -> do + hd <- satom "EnumOrTag" + mkList [hd, es, tds] + elabUnder :: HasCallStack => Show a => Dischargeable a => (Binder Variable, ASemanticsDesc) -> Elab a -> Elab a elabUnder (x, desc) ma = do scp <- asks (scopeSize . objVars) @@ -793,7 +843,7 @@ spatBase isSub desc rest rp = do (s, desc) <- case vdesc of VWildcard _ -> pure (desc, weak desc) VBind cat desc -> (, weak desc) <$> satom cat - VPi s (y, t) -> pure (s, t) + VPi s (y, t) -> throwComplaint r (CantMatchOnPi desc rp) _ -> throwComplaint r (SyntaxPError desc rp) elabUnder (x, s) $ @@ -886,7 +936,9 @@ guessDesc :: Bool -> -- is this in tail position? Raw -> Elab (Info ASemanticsDesc) guessDesc b (Var _ v) = resolve v >>= \case Just (AnObjVar desc i) -> pure (Known desc) - Just (ADeclaration (ActVar isSub (ObjVars B0 :=> desc))) -> pure $ Known desc + Just (ADeclaration (ActVar isSub (ObjVars B0 :=> desc))) -> do + scp <- asks (scopeSize . objVars) + pure $ Known (weaks scp desc) _ -> pure Unknown guessDesc b (Cons _ p q) = do dp <- guessDesc False p diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 4c04d3b..e2da065 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -504,6 +504,8 @@ data Complaint | ExpectedASemanticsPGot RawP | SyntaxError ASemanticsDesc Raw | SyntaxPError ASemanticsDesc RawP + | CantMatchOnPi ASemanticsDesc RawP + | DuplicatedTag String | ExpectedAnOperator Raw | ExpectedAnEmptyListGot String [SyntaxDesc] -- semanticsdesc validation diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index 51b2ae8..3a27b46 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -208,6 +208,8 @@ instance Pretty (WithRange Complaint) where ExpectedAConsPGot p -> hsep ["Expected a pattern for a cons cell and got", pretty p] SyntaxError d t -> hsep ["Term", pretty t, "does not check against", pretty d] SyntaxPError d p -> hsep ["Pattern", pretty p, "does not check against", pretty d] + CantMatchOnPi d p -> hsep ["Cannot match pattern", pretty p, "at semantic Pi", pretty d] + DuplicatedTag t -> hsep ["Duplicated tag", pretty t] ExpectedAnOperator t -> hsep ["Expected an operator call but got", pretty t] ExpectedAnEmptyListGot a ds -> hsep ["Expected", pretty a, "to be a constant operator" diff --git a/Src/Term/Base.hs b/Src/Term/Base.hs index 33514b2..020e26f 100644 --- a/Src/Term/Base.hs +++ b/Src/Term/Base.hs @@ -200,8 +200,7 @@ t -% (o, []) = contract (t :-: atom o (scope t)) t -% (o, ps) = contract (t :-: (o #%+ ps)) (#%) :: (String, Int) -> [CdB (Tm m)] -> CdB (Tm m) -(a, ga) #% ts = uncurry CdB $ case foldr (%) (nil ga) ts of - CdB t th -> (P Cell (atom a ga :<>: CdB t (ones (weeEnd th))), th) +(a, ga) #% ts = foldr (%) (nil ga) (atom a ga:ts) (#%+) :: String -> [CdB (Tm m)] -> CdB (Tm m) a #%+ ts = let ga = scope (head ts) in (a, ga) #% ts diff --git a/test/semanticPi.act b/test/semanticPi.act new file mode 100644 index 0000000..13738e2 --- /dev/null +++ b/test/semanticPi.act @@ -0,0 +1,5 @@ + +exec ['Pi 'Wildcard \_. 'Wildcard]?t. case t + { \ x. b -> PRINTF "%i" b. + ; y -> PRINTF "Not pi: %i" y. + } From e0d191261d6e7c6e2326883feec9515908e6a1cc Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 14 Mar 2023 14:47:13 +0000 Subject: [PATCH 62/89] [ fix ] got mlttList working! --- Src/Concrete/Base.hs | 9 ++++++++- Src/Concrete/Parse.hs | 1 + Src/Concrete/Pretty.hs | 1 + Src/Elaboration.hs | 15 +++++++++++++-- Src/Elaboration/Monad.hs | 3 +-- examples/golden/stlc4.gold | 4 ++-- examples/mlttList.act | 2 +- 7 files changed, 27 insertions(+), 8 deletions(-) diff --git a/Src/Concrete/Base.hs b/Src/Concrete/Base.hs index d6f6fac..93c2b27 100644 --- a/Src/Concrete/Base.hs +++ b/Src/Concrete/Base.hs @@ -53,6 +53,7 @@ data Raw | Sbst Range (Bwd Assign) Raw | Op Range Raw Raw | Guarded Guard Raw + | Thicken Range (Bwd Variable, ThDirective) Raw deriving (Show) instance HasSetRange Raw where @@ -63,6 +64,8 @@ instance HasSetRange Raw where Lam _ sc -> Lam r sc Sbst _ sg t -> Sbst r sg t Op _ s t -> Op r s t + t@Guarded{} -> t + Thicken _ th t -> Thicken r th t instance Eq Raw where Var _ v == Var _ w = v == w @@ -71,6 +74,8 @@ instance Eq Raw where Lam _ sc == Lam _ bd = sc == bd Sbst _ cs t == Sbst _ ds u = cs == ds && t == u Op _ s t == Op _ a b = s == a && t == b + Guarded g t == Guarded h u = (g, t) == (h, u) + Thicken _ th t == Thicken _ ph u = (th, t) == (ph, u) _ == _ = False instance HasGetRange Raw where @@ -81,6 +86,8 @@ instance HasGetRange Raw where Lam r _ -> r Sbst r _ _ -> r Op r _ _ -> r + Guarded _ _ -> unknown + Thicken r _ _ -> r data Assign = Assign { assignRange :: Range @@ -131,7 +138,7 @@ instance HasGetRange RawP where Irrefutable r p -> r data ThDirective = ThKeep | ThDrop - deriving (Show) + deriving (Show, Eq) data Mode a = Input | Subject a | Output deriving (Show, Eq, Functor, Foldable, Traversable) diff --git a/Src/Concrete/Parse.hs b/Src/Concrete/Parse.hs index 47e92f5..db7fd39 100644 --- a/Src/Concrete/Parse.hs +++ b/Src/Concrete/Parse.hs @@ -49,6 +49,7 @@ pTM = withRange $ (ptm >>= more) <|> pscoped Lam pbinder pTM <|> Sbst unknown <$ pch (== '{') <* pspc <*> ppes (punc ",") passign <* punc "}" <*> pTM + <|> Thicken unknown <$ pch (== '{') <* pspc <*> pth <* punc "}" <*> pTM where diff --git a/Src/Concrete/Pretty.hs b/Src/Concrete/Pretty.hs index d570a7c..3aafb60 100644 --- a/Src/Concrete/Pretty.hs +++ b/Src/Concrete/Pretty.hs @@ -38,6 +38,7 @@ instance Pretty Raw where Sbst _ sg t -> parenthesise (d > 0) $ hsep [ pretty sg, pretty t ] Op _ s t -> parenthesise (d > 0) $ hsep [ pretty s, "-", prettyPrec 1 t ] Guarded g t -> hsep [ "<", pretty t , ">"] + Thicken _ (thxz, thd) t -> braces (hsep (pretty <$> thxz <>> []) <> pretty thd) <+> pretty t instance Pretty (Bwd Assign) where pretty sg = encloseSep lbrace rbrace ", " $ pretty <$> sg <>> [] diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index a77797b..bf84464 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -578,9 +578,20 @@ stm :: Usage -> ASemanticsDesc -> Raw -> Elab ACTm stm usage desc (Var r v) = during (TermVariableElaboration v) $ do (_, _, t) <- svar usage (Just desc) v pure t +stm usage desc (Thicken r th t) = do + ovs <- asks objVars + let rest = initRestriction ovs + th <- sth rest th + desc <- case thickenCdB th desc of + Nothing -> throwComplaint r (NotAValidDescriptionRestriction th desc) + Just desc -> pure desc + ovs <- case thickenObjVars th ovs of + Nothing -> throwComplaint r (NotAValidContextRestriction th ovs) + Just ovs -> pure ovs + fmap (*^ th) $ local (setObjVars' ovs) $ stm usage desc t stm usage desc (Sbst r sg t) = do - ms <- during (SubstitutionElaboration sg) $ ssbst (sg <>> []) - local (setMacros ms) (stm usage desc t) + ms <- during (SubstitutionElaboration sg) $ ssbst (sg <>> []) + local (setMacros ms) (stm usage desc t) stm usage desc rt = do table <- gets syntaxCats dat <- asks headUpData diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index e2da065..d350a9e 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -239,8 +239,7 @@ extend (Restriction ls th) Unused = Restriction ls (th -? False) instance Selable Restriction where ph ^? Restriction ls th = Restriction (ph ^? ls) (ph ^? th) -data ElabMode = Definition | Execution - deriving (Eq, Show) +data ElabMode = Definition | Execution deriving (Eq, Show) initContext :: Options -> Context initContext opts = Context diff --git a/examples/golden/stlc4.gold b/examples/golden/stlc4.gold index b30ab5d..3fa9d74 100644 --- a/examples/golden/stlc4.gold +++ b/examples/golden/stlc4.gold @@ -14,7 +14,7 @@ out > , synth |-@p {} out > , ([] Done ) | <> out > , ([([] Done ) | <> out > , \z_0. -out > , ctxt |- z_0 -> {z_0*} ?[("check",[1])("S",[1])] . +out > , ctxt |- z_0 -> ?[("check",[1])("S",[1])] . out > , ([([([([<> | ([([] Done ) | <>, ([([([] Done ) @ p | q [] @ <>] Done ) | <> out > , ([] Done ) @ p | q [] @ <>] out > Done @@ -23,7 +23,7 @@ out > @ p | q [] @ <>] out > Done out > ) out > , ([<> | ([\w_1. -out > , ctxt |- w_1 -> {w_1*} ?[("check",[1,4])("synth",[1])("",[4])("synth",[0])("",[2])("check",[0])("S",[1])] . +out > , ctxt |- w_1 -> ?[("check",[1,4])("synth",[1])("",[4])("synth",[0])("",[2])("check",[0])("S",[1])] . out > , ([([] Done ) @ p | q [] @ <>] Done ) @ p | q [w] @ <>] out > Done out > )] diff --git a/examples/mlttList.act b/examples/mlttList.act index 670e175..ee72d5f 100644 --- a/examples/mlttList.act +++ b/examples/mlttList.act @@ -408,7 +408,7 @@ normSynthWorker@p = p?e. | \y. ctxt |- y -> S. \ys. ctxt |- ys -> fty. \ih. ctxt |- ih -> {xs = ys}T. - checkNorm@u. u!{xs = ['Rad ['Plus ['Sing ['Emb y 'Id]] ['Emb ys 'Id]] fty]}T. u!c. u?nc1. nc ~ {y*,ys*,ih*}\y ys ih.nc1 + checkNorm@u. u!{xs = ['Rad ['Plus ['Sing ['Emb y 'Id]] ['Emb ys 'Id]] fty]}T. u!c. u?nc1. nc ~ {y ys ih*}\y ys ih.nc1 | p!['App nf ['ListRec NT nn nc]]. p!{xs = nf}T.) ; _ -> #"Expected ListRec's; got %i" s } From da2524373faf5dd95190970d66f75caeceed5cae Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 14 Mar 2023 15:01:29 +0000 Subject: [PATCH 63/89] [ fix ] scopecheck thinning elaboration --- Src/Elaboration.hs | 2 ++ test/golden/case-pair-failing.gold | 2 +- test/golden/case-tuples-failing.gold | 2 +- test/golden/semanticPi.gold | 12 ++++++++++++ test/golden/shadowed-pattern.gold | 13 +++++++++++++ test/golden/spop-fail.gold | 7 +++---- 6 files changed, 32 insertions(+), 6 deletions(-) create mode 100644 test/golden/semanticPi.gold create mode 100644 test/golden/shadowed-pattern.gold diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index bf84464..d945284 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -255,6 +255,8 @@ ssbst usage (sg :< sgc) = case sgc of sth :: Restriction -> (Bwd Variable, ThDirective) -> Elab Th sth (Restriction ovs th) (xz, b) = do + whenLeft (isAll ((`elem` ovs) . getVariable) (xz <>> [])) $ \ x -> + throwComplaint x (OutOfScope x) let th = which (`elem` (getVariable <$> xz)) ovs pure $ case b of ThKeep -> th diff --git a/test/golden/case-pair-failing.gold b/test/golden/case-pair-failing.gold index a5b03a5..7e2b1ec 100644 --- a/test/golden/case-pair-failing.gold +++ b/test/golden/case-pair-failing.gold @@ -6,7 +6,7 @@ out > 6 | ; ['Nat|'Nat] -> PRINTF "Happy Nats". out > 7 | ; 'Nat -> -- correctly rejected out > ^^^^ out > case-pair-failing.act:7:4-8 -out > Pattern 'Nat does not match ['Cons 'Type 'Type] +out > Pattern 'Nat does not check against ['Cons 'Type 'Type] out > when elaborating a case branch handling the pattern 'Nat out > when elaborating the judgement definition for typeEq out > diff --git a/test/golden/case-tuples-failing.gold b/test/golden/case-tuples-failing.gold index 4278191..6525f51 100644 --- a/test/golden/case-tuples-failing.gold +++ b/test/golden/case-tuples-failing.gold @@ -6,7 +6,7 @@ out > 6 | ; ['Nat 'Nat] -> PRINTF "Happy Nats". out > 7 | ; 'Nat -> -- correctly rejected out > ^^^^ out > case-tuples-failing.act:7:4-8 -out > Pattern 'Nat does not match ['Cons 'Type ['Cons 'Type 'Nil]] +out > Pattern 'Nat does not check against ['Cons 'Type ['Cons 'Type 'Nil]] out > when elaborating a case branch handling the pattern 'Nat out > when elaborating the judgement definition for typeEq out > diff --git a/test/golden/semanticPi.gold b/test/golden/semanticPi.gold new file mode 100644 index 0000000..3a214c0 --- /dev/null +++ b/test/golden/semanticPi.gold @@ -0,0 +1,12 @@ +ret > ExitFailure 1 +out > Error +out > +out > 1 | +out > 2 | exec ['Pi 'Wildcard \_. 'Wildcard]?t. case t +out > 3 | { \ x. b -> PRINTF "%i" b. +out > ^^^^^^ +out > semanticPi.act:3:4-10 +out > Cannot match pattern \x. b at semantic Pi ['Pi 'Wildcard \_. 'Wildcard] +out > when elaborating a case branch handling the pattern \x. b +out > when elaborating an exec statement +out > diff --git a/test/golden/shadowed-pattern.gold b/test/golden/shadowed-pattern.gold new file mode 100644 index 0000000..535ad22 --- /dev/null +++ b/test/golden/shadowed-pattern.gold @@ -0,0 +1,13 @@ +ret > ExitFailure 1 +out > Error +out > +out > 5 | -- been evicted from the scope. +out > 6 | a : ?'Wildcard. +out > 7 | a@p = p?x. case x { (\ z . {z*}z) -> PRINTF "the body is %r" z. } +out > ^ +out > shadowed-pattern.act:7:31-32 +out > Out of scope variable z +out > when elaborating the pattern variable z +out > when elaborating a case branch handling the pattern \z. {z*} z +out > when elaborating the judgement definition for a +out > diff --git a/test/golden/spop-fail.gold b/test/golden/spop-fail.gold index 2dc9d68..eae608e 100644 --- a/test/golden/spop-fail.gold +++ b/test/golden/spop-fail.gold @@ -3,10 +3,9 @@ out > Error out > out > 1 | source : !'Wildcard. out > 2 | source@p = p!{x*}[]. -out > ^^ -out > spop-fail.act:2:14-16 -out > Tried to pop an empty context -out > when elaborating the substitution {x*} +out > ^ +out > spop-fail.act:2:14-15 +out > Out of scope variable x out > when elaborating p!{x*} [] out > when elaborating the judgement definition for source out > From 72bfa756e52e19dcfb02f45e898bc5fd07e52aa0 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 14 Mar 2023 16:44:08 +0000 Subject: [PATCH 64/89] [ fix ] missing range info in smeta --- Src/Concrete/Base.hs | 2 +- Src/Elaboration.hs | 13 +++++++------ test/spop-top-fail.act | 5 ++++- test/typecheck.act | 2 +- 4 files changed, 13 insertions(+), 9 deletions(-) diff --git a/Src/Concrete/Base.hs b/Src/Concrete/Base.hs index 93c2b27..0744db8 100644 --- a/Src/Concrete/Base.hs +++ b/Src/Concrete/Base.hs @@ -86,7 +86,7 @@ instance HasGetRange Raw where Lam r _ -> r Sbst r _ _ -> r Op r _ _ -> r - Guarded _ _ -> unknown + Guarded _ t -> getRange t Thicken r _ _ -> r data Assign = Assign diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index d945284..b3a201e 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -117,15 +117,16 @@ spassport :: Usage -> IsSubject -> Passport spassport u IsSubject{} | isBeingScrutinised u = ASubject spassport _ _ = ACitizen -smeta :: Usage +smeta :: Range + -> Usage -> ActorMeta {- eps -} -> ACTSbst {- delta -} {- gamma -} -> Telescopic ASemanticsDesc {- delta -} {- eps -} -> Elab ({- T :: -} ASemanticsDesc {- gamma -}, ACTm {- gamma -} {- T -}) -smeta usage am sg (Stop desc) = pure (desc //^ sg, am $: sg) -smeta usage am sg (Tele desc (Scope (Hide x) tel)) = do - t <- stm usage (desc //^ sg) (Var unknown $ Variable unknown x) - smeta usage am (sbstT sg ((Hide x :=) $^ t)) tel +smeta r usage am sg (Stop desc) = pure (desc //^ sg, am $: sg) +smeta r usage am sg (Tele desc (Scope (Hide x) tel)) = do + t <- stm usage (desc //^ sg) (Var r $ Variable r x) + smeta r usage am (sbstT sg ((Hide x :=) $^ t)) tel svar :: Usage -> Maybe ASemanticsDesc @@ -141,7 +142,7 @@ svar usage mdesc' x = do logUsage (getVariable x) usage let tel = discharge sc desc let am = ActorMeta (spassport usage isSub) (getVariable x) - (desc, tm) <- smeta usage am (sbst0 $ scopeSize ovs) tel + (desc, tm) <- smeta r usage am (sbst0 $ scopeSize ovs) tel desc <- fmap (fromMaybe desc) $ flip traverse mdesc' $ \desc' -> do i <- compatibleInfos r (Known desc') (Known desc) fromInfo r i -- cannot possibly fail diff --git a/test/spop-top-fail.act b/test/spop-top-fail.act index 60ec3ff..93de688 100644 --- a/test/spop-top-fail.act +++ b/test/spop-top-fail.act @@ -1,2 +1,5 @@ source : !'Wildcard. -source@p = \x. \y. source@q. q?t. let v : 'Wildcard = {y,x}t. \ No newline at end of file +source@p + = \x. \y. source@q. q?t. + let v : 'Wildcard = {y x}t. + p!v. \ No newline at end of file diff --git a/test/typecheck.act b/test/typecheck.act index 2e99ad4..f03cabe 100644 --- a/test/typecheck.act +++ b/test/typecheck.act @@ -36,6 +36,6 @@ operator ; ['Pi a \x.b] -['apply2 (x : a)] : b } -\x.b : ['Pi 'Nat \_.'Nat] -[ 'apply t ] ~> 'Zero +f : ['Pi 'Nat \_.'Nat] -[ 'apply t ] ~> 'Zero exec PRINTF "Hurrah!". From dfe40a61bb3150918146ac95770878fa2176a116 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 14 Mar 2023 17:47:37 +0000 Subject: [PATCH 65/89] [ fix ] printing open terms in error messages --- Src/Concrete/Parse.hs | 6 ++-- Src/Concrete/Pretty.hs | 2 +- Src/Elaboration.hs | 44 +++++++++++------------ Src/Elaboration/Monad.hs | 56 +++++++++++++++++++++++------- Src/Elaboration/Pretty.hs | 38 +++++++++++--------- examples/stlcRules.act | 4 +-- test/app-operator-fail.act | 4 +++ test/app-operator.act | 7 ++-- test/golden/app-operator-fail.gold | 12 +++++++ test/golden/operator-fail.gold | 15 ++++---- test/golden/printing-open.gold | 10 ++++++ test/golden/printing-open2.gold | 11 ++++++ test/golden/spop-top-fail.gold | 15 ++++---- test/golden/syntaxcat-fail.gold | 14 ++++---- test/golden/typecheck.gold | 5 +++ test/printing-open.act | 4 +++ test/printing-open2.act | 3 ++ 17 files changed, 172 insertions(+), 78 deletions(-) create mode 100644 test/app-operator-fail.act create mode 100644 test/golden/app-operator-fail.gold create mode 100644 test/golden/printing-open.gold create mode 100644 test/golden/printing-open2.gold create mode 100644 test/golden/typecheck.gold create mode 100644 test/printing-open.act create mode 100644 test/printing-open2.act diff --git a/Src/Concrete/Parse.hs b/Src/Concrete/Parse.hs index db7fd39..523c635 100644 --- a/Src/Concrete/Parse.hs +++ b/Src/Concrete/Parse.hs @@ -54,8 +54,10 @@ pTM = withRange $ where more :: Raw -> Parser Raw - more t = withRange $ - ((Op unknown t <$ punc "-" <*> ptm) >>= more) + more t = + (do punc "-" + tm <- ptm + more (Op (getRange t <> getRange tm) t tm)) <|> pure t ptm :: Parser Raw diff --git a/Src/Concrete/Pretty.hs b/Src/Concrete/Pretty.hs index 3aafb60..f71763c 100644 --- a/Src/Concrete/Pretty.hs +++ b/Src/Concrete/Pretty.hs @@ -212,7 +212,7 @@ instance Pretty (Mode a) where pretty (Subject _) = "$" pretty Output = "!" -instance (Pretty t) => Pretty (Mode a, t) where +instance Pretty t => Pretty (Mode a, t) where pretty (m, desc) = hsep [ pretty m, prettyPrec 1 desc ] instance Pretty CProtocol where diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index b3a201e..99ac8cc 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -348,7 +348,7 @@ vconsDesc r desc rp vdesc = case vdesc of VWildcard _ -> pure (ConsCell desc desc) VEnumOrTag _ _ ds -> pure (ConsEnum ds) VUniverse _ -> pure ConsUniverse - _ -> throwComplaint r (SyntaxPError desc rp) + _ -> throwComplaint r =<< syntaxPError desc rp spatSemantics :: ASemanticsDesc {- gamma -} -> {- r :: -} Restriction {- gamma -} @@ -392,7 +392,7 @@ spatSemantics desc rest rp = do dat <- asks headUpData ds <- asks declarations case Semantics.expand table dat desc of - Nothing -> throwComplaint rp (InvalidSemanticsDesc desc) + Nothing -> throwComplaint rp . InvalidSemanticsDesc =<< withVarNames desc Just vdesc -> case rp of AtP r a -> do case vdesc of @@ -403,7 +403,7 @@ spatSemantics desc rest rp = do VEnumOrTag sc es _ -> unless (a `elem` es) $ throwComplaint r (ExpectedEnumGot es a) VWildcard sc -> pure () VUniverse _ -> unless (a `elem` ("Semantics" : Map.keys table)) $ throwComplaint r (ExpectedASemanticsGot (At r a)) - _ -> throwComplaint r (SyntaxPError desc rp) + _ -> throwComplaint r =<< syntaxPError desc rp pure (AP a, ds, atom a (bigEnd (restriction rest))) ConsP r p1 p2 -> do -- take vdesc apart and decide what needs to be checked @@ -421,7 +421,7 @@ spatSemantics desc rest rp = do (p1, ds, t1) <- spatSemantics at rest p1 (p2, ds, t2) <- local (setDecls ds) (spatSemanticss descs rest p2) pure (PP p1 p2, ds, t1 % t2) - _ -> throwComplaint r (SyntaxPError desc rp) + _ -> throwComplaint r =<< syntaxPError desc rp ConsUniverse -> case (p1 , p2) of (AtP _ "Pi", ConsP _ s (ConsP _ (LamP _ (Scope (Hide x) t)) (AtP _ ""))) -> do (ps, ds, ts) <- spatSemantics desc rest s @@ -438,8 +438,8 @@ spatSemantics desc rest rp = do (s, desc) <- case vdesc of VWildcard _ -> pure (desc, weak desc) VBind cat desc -> (, weak desc) <$> satom cat - VPi s (y, t) -> throwComplaint r (CantMatchOnPi desc rp) - _ -> throwComplaint r (SyntaxPError desc rp) + VPi s (y, t) -> throwComplaint r =<< CantMatchOnPi <$> withVarNames desc <*> pure rp + _ -> throwComplaint r =<< syntaxPError desc rp elabUnder (x, s) $ -- local (addHint (getVariable <$> x) (Known s)) $ spatSemantics desc (extend rest (getVariable <$> x)) p @@ -488,7 +488,7 @@ matchObjType r (mb , oty) (obDesc, ob) = do dat <- asks headUpData let hnf = headUp dat env <- case snd $ match hnf initMatching (Problem B0 oty obDesc) of - Left e -> throwComplaint r $ InferredDescMismatch + Left e -> throwComplaint r =<< InferredDescMismatch <$> withVarNames oty <*> withVarNames obDesc Right m -> pure $ matchingToEnv m (huEnv dat) env <- case mb of Nothing -> pure env @@ -586,7 +586,7 @@ stm usage desc (Thicken r th t) = do let rest = initRestriction ovs th <- sth rest th desc <- case thickenCdB th desc of - Nothing -> throwComplaint r (NotAValidDescriptionRestriction th desc) + Nothing -> throwComplaint r . NotAValidDescriptionRestriction th =<< withVarNames desc Just desc -> pure desc ovs <- case thickenObjVars th ovs of Nothing -> throwComplaint r (NotAValidContextRestriction th ovs) @@ -599,7 +599,7 @@ stm usage desc rt = do table <- gets syntaxCats dat <- asks headUpData case Semantics.expand table dat desc of - Nothing -> throwComplaint rt (InvalidSemanticsDesc desc) + Nothing -> throwComplaint rt =<< InvalidSemanticsDesc <$> withVarNames desc Just vdesc -> case rt of At r a -> do case vdesc of @@ -610,7 +610,7 @@ stm usage desc rt = do VEnumOrTag _ es _ -> unless (a `elem` es) $ throwComplaint r (ExpectedEnumGot es a) VWildcard _ -> pure () VUniverse _ -> unless (a `elem` ("Atom" : "Nil" : "Wildcard" : "Syntax" : "Semantics" : Map.keys table)) $ throwComplaint r (ExpectedASemanticsGot rt) - _ -> throwComplaint r (SemanticsError desc rt) + _ -> throwComplaint r =<< SemanticsError <$> withVarNames desc <*> pure rt satom a Cons r p q -> case vdesc of VNilOrCons d1 d2 -> (%) <$> stm usage d1 p <*> stm usage d2 q @@ -622,7 +622,7 @@ stm usage desc rt = do Just descs -> do adesc <- satom "Atom" (%) <$> stm usage adesc p <*> stms usage descs q - _ -> throwComplaint r (SyntaxError desc rt) + _ -> throwComplaint r =<< syntaxError desc rt VUniverse _ -> case (p , q) of (At _ "Pi", Cons _ s (Cons _ (Lam _ (Scope (Hide x) t)) (At _ ""))) -> do s <- sty s @@ -642,13 +642,13 @@ stm usage desc rt = do f <- stm usage (Semantics.contract (VBind "Semantics" desc)) f pure ("Fix" #%+ [f]) _ -> throwComplaint r (ExpectedASemanticsGot rt) - _ -> throwComplaint r (SyntaxError desc rt) + _ -> throwComplaint r =<< syntaxError desc rt Lam r (Scope (Hide x) sc) -> do (s, desc) <- case vdesc of VWildcard i -> pure (desc, weak desc) VBind cat desc -> (,weak desc) <$> satom cat VPi s (y, t) -> pure (s, t) - _ -> throwComplaint r (SyntaxError desc rt) + _ -> throwComplaint r =<< syntaxError desc rt elabUnder (x, s) $ stm usage desc sc Op{} -> do (tdesc, t) <- itm usage rt @@ -665,7 +665,7 @@ senumortag r a es tds = do pure (a, e) x -> do adesc <- satom "Atom" - throwComplaint x (SyntaxError adesc x) + throwComplaint x =<< syntaxError adesc x (as, es) <- do pure (unzip es) whenLeft (allUnique as) $ \ a -> throwComplaint r (DuplicatedTag a) es <- mkList es @@ -747,7 +747,7 @@ spat esc@(Pair r esc1 esc2) rest rp = case rp of (mr1, p, ds, hs) <- spat esc1 rest p (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spat esc2 rest q) pure (mr1 <|> mr2, PP p q, ds, hs) - _ -> throwComplaint rp (SyntaxPError (escrutinee esc) rp) + _ -> throwComplaint rp =<< syntaxPError (escrutinee esc) rp spat (SubjectVar r desc) rest rp = spatBase (IsSubject Pattern) desc rest rp spat esc@(Lookup _ _ av) rest rp@(ConsP r (AtP _ "Just") (ConsP _ _ (AtP _ ""))) = do logUsage av (SuccessfullyLookedUp r) @@ -763,7 +763,7 @@ thickenedASOT r th desc = do Nothing -> throwComplaint r (NotAValidContextRestriction th ovs) Just ovs -> pure ovs desc <- case thickenCdB th desc of - Nothing -> throwComplaint r (NotAValidDescriptionRestriction th desc) + Nothing -> throwComplaint r . NotAValidDescriptionRestriction th =<< withVarNames desc Just desc -> pure desc pure (ovs, ovs :=> desc) @@ -810,7 +810,7 @@ spatBase isSub desc rest rp = do table <- gets syntaxCats dat <- asks headUpData case Semantics.expand table dat desc of - Nothing -> throwComplaint rp (InvalidSemanticsDesc desc) + Nothing -> throwComplaint rp . InvalidSemanticsDesc =<< withVarNames desc Just vdesc -> case rp of AtP r a -> do case vdesc of @@ -820,7 +820,7 @@ spatBase isSub desc rest rp = do VNilOrCons{} -> unless (a == "") $ throwComplaint r (ExpectedNilGot a) VEnumOrTag sc es _ -> unless (a `elem` es) $ throwComplaint r (ExpectedEnumGot es a) VWildcard sc -> pure () - _ -> throwComplaint r (SyntaxPError desc rp) + _ -> throwComplaint r =<< syntaxPError desc rp (Nothing, AP a,,) <$> asks declarations <*> asks binderHints ConsP r p q -> do @@ -838,7 +838,7 @@ spatBase isSub desc rest rp = do (mr1, p, ds, hs) <- spatBase isSub (atom "Atom" 0) rest p (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spats isSub descs rest q) pure (mr1 <|> mr2, PP p q, ds, hs) - _ -> throwComplaint r (SyntaxPError desc rp) + _ -> throwComplaint r =<< syntaxPError desc rp ConsUniverse -> case (isSub, p, q) of (IsNotSubject, AtP _ "Pi", ConsP _ s (ConsP _ (LamP _ (Scope (Hide x) t)) (AtP _ ""))) -> do (ps, ds, s) <- spatSemantics desc rest s @@ -857,8 +857,8 @@ spatBase isSub desc rest rp = do (s, desc) <- case vdesc of VWildcard _ -> pure (desc, weak desc) VBind cat desc -> (, weak desc) <$> satom cat - VPi s (y, t) -> throwComplaint r (CantMatchOnPi desc rp) - _ -> throwComplaint r (SyntaxPError desc rp) + VPi s (y, t) -> throwComplaint r =<< CantMatchOnPi <$> withVarNames desc <*> pure rp + _ -> throwComplaint r =<< syntaxPError desc rp elabUnder (x, s) $ -- local (addHint (getVariable <$> x) (Known s)) $ @@ -971,7 +971,7 @@ compatibleChannels :: Range -> Elab Int compatibleChannels r (dp, []) dir (dq, []) = pure 0 compatibleChannels r (dp, p@(m, s) : ps) dir (dq, q@(n, t) : qs) = do - unless (s == t) $ throwComplaint r (IncompatibleSemanticsDescs s t) + unless (s == t) $ throwComplaint r =<< incompatibleSemanticsDescs s t let (cp , cq) = (whatComm m dp, whatComm n dq) when (cp == cq) $ throwComplaint r (IncompatibleModes p q) case (cp, dir) of diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index d350a9e..0498596 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -136,6 +136,26 @@ fromInfo r (Known desc) = pure desc -- 2. `compatibleInfos` where the error is handled locally fromInfo r Inconsistent = throwComplaint r InconsistentSyntaxDesc +incompatibleSemanticsDescs :: ASemanticsDesc -> ASemanticsDesc -> Elab Complaint +incompatibleSemanticsDescs desc desc' = do + vars <- withVarNames () + pure $ IncompatibleSemanticsDescs (desc <$ vars) (desc' <$ vars) + +incompatibleSemanticsInfos :: Info ASemanticsDesc -> Info ASemanticsDesc -> Elab Complaint +incompatibleSemanticsInfos desc desc' = do + vars <- withVarNames () + pure $ IncompatibleSemanticsInfos (fmap (<$ vars) desc) (fmap (<$ vars) desc') + +syntaxError :: ASemanticsDesc -> Raw -> Elab Complaint +syntaxError desc t = do + desc <- withVarNames desc + pure (SyntaxError desc t) + +syntaxPError :: ASemanticsDesc -> RawP -> Elab Complaint +syntaxPError desc p = do + desc <- withVarNames desc + pure (SyntaxPError desc p) + compatibleInfos :: Range -> Info ASemanticsDesc -> Info ASemanticsDesc @@ -146,9 +166,9 @@ compatibleInfos r desc desc' = do let de = infoExpand dat table =<< desc let de' = infoExpand dat table =<< desc' case de <> de' of - Inconsistent -> throwComplaint r $ case (desc, desc') of - (Known desc, Known desc') -> IncompatibleSemanticsDescs desc desc' - _ -> IncompatibleSemanticsInfos desc desc' + Inconsistent -> throwComplaint r =<< case (desc, desc') of + (Known desc, Known desc') -> incompatibleSemanticsDescs desc desc' + _ -> incompatibleSemanticsInfos desc desc' d -> pure $ case (desc, desc') of (Known (CdB (A _) _), _) -> desc (_, Known (CdB (A _) _)) -> desc' @@ -241,6 +261,16 @@ instance Selable Restriction where data ElabMode = Definition | Execution deriving (Eq, Show) +data WithVarNames a = WithVarNames + { varNames :: Bwd String + , scopedValue :: a + } deriving (Show, Functor) + +withVarNames :: t -> Elab (WithVarNames t) +withVarNames t = do + ovs <- asks (fmap objVarName . getObjVars . objVars) + pure (WithVarNames ovs t) + initContext :: Options -> Context initContext opts = Context { objVars = ObjVars B0 @@ -442,6 +472,8 @@ data ContextualInfo | JudgementFormElaboration Variable deriving (Show) +type ESemanticsDesc = WithVarNames ASemanticsDesc + data Complaint -- scope = OutOfScope Variable @@ -451,7 +483,7 @@ data Complaint | NotTopVariable Variable Variable | IncompatibleChannelScopes ObjVars ObjVars | NotAValidContextRestriction Th ObjVars - | NotAValidDescriptionRestriction Th ASemanticsDesc + | NotAValidDescriptionRestriction Th ESemanticsDesc -- kinding | NotAValidTermVariable Variable Kind | NotAValidPatternVariable Variable Resolved @@ -490,7 +522,7 @@ data Complaint | InconsistentSyntaxDesc | InvalidSyntaxDesc SyntaxDesc | IncompatibleSyntaxInfos (Info SyntaxDesc) (Info SyntaxDesc) - | IncompatibleSemanticsDescs ASemanticsDesc ASemanticsDesc + | IncompatibleSemanticsDescs ESemanticsDesc ESemanticsDesc | GotBarredAtom String [String] | ExpectedASemanticsGot Raw | ExpectedNilGot String @@ -501,20 +533,20 @@ data Complaint | ExpectedAConsGot Raw | ExpectedAConsPGot RawP | ExpectedASemanticsPGot RawP - | SyntaxError ASemanticsDesc Raw - | SyntaxPError ASemanticsDesc RawP - | CantMatchOnPi ASemanticsDesc RawP + | SyntaxError ESemanticsDesc Raw + | SyntaxPError ESemanticsDesc RawP + | CantMatchOnPi ESemanticsDesc RawP | DuplicatedTag String | ExpectedAnOperator Raw | ExpectedAnEmptyListGot String [SyntaxDesc] -- semanticsdesc validation - | InvalidSemanticsDesc ASemanticsDesc - | SemanticsError ASemanticsDesc Raw - | IncompatibleSemanticsInfos (Info ASemanticsDesc) (Info ASemanticsDesc) + | InvalidSemanticsDesc ESemanticsDesc + | SemanticsError ESemanticsDesc Raw + | IncompatibleSemanticsInfos (Info ESemanticsDesc) (Info ESemanticsDesc) -- subjects and citizens | AsPatternCannotHaveSubjects RawP -- desc inference - | InferredDescMismatch + | InferredDescMismatch (WithVarNames Pat) ESemanticsDesc | DontKnowHowToInferDesc Raw | ArityMismatchInOperator | SchematicVariableNotInstantiated diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index 3a27b46..9eee6d9 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -17,6 +17,7 @@ import Data.List.NonEmpty (NonEmpty((:|))) import Rules import Syntax () import Thin +import Bwd (Bwd (..)) instance Pretty Range where pretty r | r == unknown = "" @@ -45,13 +46,13 @@ instance Pretty Resolved where AMacro t -> "a macro variable" -- TODO: terminology? instance (Unelab a, Pretty (Unelabed a), UnelabEnv a ~ Naming) - => Pretty (CdB a) where - pretty (CdB a th) - | is0s th = pretty $ unsafeEvalUnelab initNaming (unelab a) - | otherwise = "_" + => Pretty (WithVarNames a) where + pretty (WithVarNames ovs a) + = let naming = (ovs, ones (length ovs), ovs) in + pretty $ unsafeEvalUnelab naming (unelab a) instance Pretty AProtocol where - pretty (Protocol ps) = foldMap (\ x -> pretty x <> ". ") ps + pretty (Protocol ps) = foldMap (\ x -> pretty (WithVarNames B0 <$> x) <> ". ") ps instance Pretty CFormula where pretty (CFormula a) = these pretty pretty (const pretty) a @@ -152,11 +153,14 @@ instance Pretty (WithRange Complaint) where InconsistentCommunication -> hsep ["Inconsistent communication"] DoomedBranchCommunicated a -> hsep ["Doomed branch communicated", pretty a] ProtocolsNotDual ps qs -> hsep ["Protocols", pretty ps, "and", pretty qs, "are not dual"] - IncompatibleModes m1 m2 -> hsep ["Modes", pretty m1, "and", pretty m2, "are incompatible"] + IncompatibleModes m1 m2 -> hsep ["Modes", pretty (WithVarNames B0 <$> m1) + , "and", pretty (WithVarNames B0 <$> m2), "are incompatible"] IncompatibleChannelScopes sc1 sc2 -> hsep [ "Channels scopes", pretty sc1 , "and", pretty sc2, "are incompatible"] - WrongDirection m1 dir m2 -> hsep ["Wrong direction", pretty (show dir), "between", pretty m1, "and", pretty m2] + WrongDirection m1 dir m2 -> hsep ["Wrong direction", pretty (show dir) + , "between", pretty (WithVarNames B0 <$> m1) + , "and", pretty (WithVarNames B0 <$> m2)] -- judgementforms JudgementWrongArity name (Protocol protocol) fms -> @@ -183,14 +187,16 @@ instance Pretty (WithRange Complaint) where -- syntaxdesc validation InconsistentSyntaxDesc -> "Inconsistent syntactic descriptions" - InvalidSyntaxDesc d -> hsep ["Invalid syntax desc", pretty d] + InvalidSyntaxDesc d -> hsep ["Invalid syntax desc", pretty (WithVarNames B0 d)] IncompatibleSemanticsDescs desc desc' -> hsep [ "Incompatible semantics descriptions, expected" - , {-prettyPrec 1-} pretty (show desc) + , prettyPrec 1 desc , "but got" - , {-prettyPrec 1-} pretty (show desc')] + , prettyPrec 1 desc'] IncompatibleSyntaxInfos info1 info2 -> - hsep ["Syntax infos", pretty info1, "and", pretty info2, "are incompatible"] + hsep ["Syntax infos" , pretty (WithVarNames B0 <$> info1) + , "and", pretty (WithVarNames B0 <$> info2) + , "are incompatible"] GotBarredAtom a as -> hsep [ squote <> pretty a, "is one of the barred atoms", collapse (map pretty as) ] ExpectedNilGot at -> hsep ["Expected [] and got", squote <> pretty at] @@ -213,16 +219,16 @@ instance Pretty (WithRange Complaint) where ExpectedAnOperator t -> hsep ["Expected an operator call but got", pretty t] ExpectedAnEmptyListGot a ds -> hsep ["Expected", pretty a, "to be a constant operator" - , "but it takes arguments of type:", collapse (pretty <$> ds)] - -- TODO : learn to print the semantics desc - InvalidSemanticsDesc sem -> "Invalid semantics description" - SemanticsError sem t -> hsep [pretty t, "does not match the semantics description"] + , "but it takes arguments of type:", collapse (pretty . WithVarNames B0 <$> ds)] + InvalidSemanticsDesc sem -> hsep ["Invalid semantics description", pretty sem] + SemanticsError sem t -> hsep [pretty t, "does not match the semantics description", pretty sem] IncompatibleSemanticsInfos isem isem' -> hsep ["Incompatible semantics description infos", prettyPrec 1 isem, "and", prettyPrec 1 isem'] AsPatternCannotHaveSubjects p -> hsep ["As pattern", pretty p, "duplicates a subject variable"] -- desc inference -- TODO : add more info - InferredDescMismatch -> "Inferred object description does not match pattern" + InferredDescMismatch p desc -> hsep [ "Inferred object description", pretty desc + , "does not match pattern", pretty p ] DontKnowHowToInferDesc t -> hsep ["Do not know how to infer description for", pretty t] ArityMismatchInOperator -> "Arity mismatch in operator" SchematicVariableNotInstantiated -> "Schematic variable not instantiated" diff --git a/examples/stlcRules.act b/examples/stlcRules.act index 9e61462..daf36c8 100644 --- a/examples/stlcRules.act +++ b/examples/stlcRules.act @@ -65,7 +65,7 @@ judgementform rule {} type 'Nat => 'Nat - {'Nat - 'Value ~> 'Natural} + {'Nat : 'Type - 'Value ~> 'Natural} rule @@ -73,7 +73,7 @@ rule ------------------------ type ['Arr S T] => ['Arr S T] -- Global assumption: 'Semantics comes with Pi builtin - {['Arr S T] - 'Value ~> ['Pi (S - 'Value) \_. (T - 'Value)]} + {['Arr S T] : 'Type - 'Value ~> ['Pi (S - 'Value) \_. (T - 'Value)]} -- Invariant: the subject in a premise is always something with a name -- payoff - the name BECOMES the name of the citizen diff --git a/test/app-operator-fail.act b/test/app-operator-fail.act new file mode 100644 index 0000000..d3ddad0 --- /dev/null +++ b/test/app-operator-fail.act @@ -0,0 +1,4 @@ +withOp : ?'Wildcard. ?'Wildcard. +withOp@p = p?fun. p?res. + fun - ['app 'arg1] - ['app 'arg2] + ~ res diff --git a/test/app-operator.act b/test/app-operator.act index e85a562..07b6984 100644 --- a/test/app-operator.act +++ b/test/app-operator.act @@ -1,4 +1,5 @@ -withOp : ?'Wildcard. ?'Wildcard. +withOp : ?['Pi 'Wildcard \_. ['Pi 'Wildcard \_.'Wildcard]]. + ?'Wildcard. withOp@p = p?fun. p?res. fun - ['app 'arg1] - ['app 'arg2] ~ res @@ -8,6 +9,6 @@ exec | withOp@p. p!\x y.y. p!'arg2. | withOp@p. p!\x y.x. p!'arg1. | withOp@p. p!\x y.x. p!'arg2. - | withOp@p. p!'stuck. p!'arg1. - | withOp@p. p!'stuck. p!'arg2. +-- | withOp@p. p!'stuck. p!'arg1. +-- | withOp@p. p!'stuck. p!'arg2. ) \ No newline at end of file diff --git a/test/golden/app-operator-fail.gold b/test/golden/app-operator-fail.gold new file mode 100644 index 0000000..af4b4d4 --- /dev/null +++ b/test/golden/app-operator-fail.gold @@ -0,0 +1,12 @@ +ret > ExitFailure 1 +out > Error +out > +out > 1 | withOp : ?'Wildcard. ?'Wildcard. +out > 2 | withOp@p = p?fun. p?res. +out > 3 | fun - ['app 'arg1] - ['app 'arg2] +out > ^^^^^^^^^^^^^^^^^^ +out > app-operator-fail.act:3:2-20 +out > Inferred object description 'Wildcard does not match pattern ['Pi S \x. T] +out > when elaborating a constraint involving fun - ['app 'arg1] - ['app 'arg2] +out > when elaborating the judgement definition for withOp +out > diff --git a/test/golden/operator-fail.gold b/test/golden/operator-fail.gold index a6aca11..ee44f47 100644 --- a/test/golden/operator-fail.gold +++ b/test/golden/operator-fail.gold @@ -1,12 +1,11 @@ ret > ExitFailure 1 out > Error out > -out > 3 | -out > 4 | failure : ?'Wildcard. ?'Wildcard. !'Wildcard. -out > 5 | failure@p = p?f. p?t. p!f - 'app. -out > ^^^^^^^^ -out > operator-fail.act:5:24-32 -out > Expected app to be a constant operator but it takes arguments of type: ['Wildcard] -out > when elaborating p!f - 'app -out > when elaborating the judgement definition for failure +out > 1 | success : ?'Wildcard. ?'Wildcard. !'Wildcard. +out > 2 | success@p = p?f. p?t. p!f - ['app t]. +out > ^^^^^^^^^^^^ +out > operator-fail.act:2:24-36 +out > Inferred object description 'Wildcard does not match pattern ['Pi S \x. T] +out > when elaborating p!f - ['app t] +out > when elaborating the judgement definition for success out > diff --git a/test/golden/printing-open.gold b/test/golden/printing-open.gold new file mode 100644 index 0000000..a08414d --- /dev/null +++ b/test/golden/printing-open.gold @@ -0,0 +1,10 @@ +ret > ExitFailure 1 +out > Error +out > +out > 2 | { a - 'id : a } +out > 3 | +out > 4 | x : a - 'id ~> 'hello +out > ^^^^^^ +out > printing-open.act:4:15-21 +out > 'hello does not match the semantics description a +out > diff --git a/test/golden/printing-open2.gold b/test/golden/printing-open2.gold new file mode 100644 index 0000000..6147921 --- /dev/null +++ b/test/golden/printing-open2.gold @@ -0,0 +1,11 @@ +ret > ExitFailure 1 +out > Error +out > +out > 1 | typecheck \X x.x : ['Pi 'Semantics \A. ['Pi A \_.A]] +out > 2 | +out > 3 | typecheck \X x.X : ['Pi 'Semantics \A. ['Pi A \_.A]] +out > ^ +out > printing-open2.act:3:15-16 +out > Incompatible semantics descriptions, expected X but got 'Semantics +out > when elaborating the term variable X +out > diff --git a/test/golden/spop-top-fail.gold b/test/golden/spop-top-fail.gold index bcf03b2..e51fd31 100644 --- a/test/golden/spop-top-fail.gold +++ b/test/golden/spop-top-fail.gold @@ -1,11 +1,14 @@ ret > ExitFailure 1 out > Error out > -out > 1 | source : !'Wildcard. -out > 2 | source@p = \x. \y. source@q. q?t. let v : 'Wildcard = {y,x}t. -out > ^ -out > spop-top-fail.act:2:57-58 -out > Expected x to be the top variable but found y instead -out > when elaborating the substitution {y, x} +out > 3 | = \x. \y. source@q. q?t. +out > 4 | let v : 'Wildcard = {y x}t. +out > 5 | p!v. +out > ^ +out > spop-top-fail.act:5:6-7 +out > Out of scope variable x +out > when elaborating the term variable x +out > when elaborating the term variable v +out > when elaborating p!v out > when elaborating the judgement definition for source out > diff --git a/test/golden/syntaxcat-fail.gold b/test/golden/syntaxcat-fail.gold index 7bb0dab..da8368d 100644 --- a/test/golden/syntaxcat-fail.gold +++ b/test/golden/syntaxcat-fail.gold @@ -6,12 +6,14 @@ out > 5 | test : out > 6 | test@p = 'Tic?a. 'Tac?b. [a b] ~ [b a] out > ^^^^^^^^^^^^^ out > syntaxcat-fail.act:6:25-38 -out > Syntax infos Known ['Cons -out > 'Tic ['Cons -out > 'Tac 'Nil]] and Known ['Cons -out > 'Tac ['Cons -out > 'Tic -out > 'Nil]] are incompatible +out > Incompatible semantics descriptions, expected ['Cons +out > 'Tic ['Cons +out > 'Tac +out > 'Nil]] but got ['Cons +out > 'Tac +out > ['Cons +out > 'Tic +out > 'Nil]] out > when guessing syntactic categories for [a b] [b a] out > when elaborating the judgement definition for test out > diff --git a/test/golden/typecheck.gold b/test/golden/typecheck.gold new file mode 100644 index 0000000..771a446 --- /dev/null +++ b/test/golden/typecheck.gold @@ -0,0 +1,5 @@ +ret > ExitSuccess +out > Hurrah! +out > +err > +err > diff --git a/test/printing-open.act b/test/printing-open.act new file mode 100644 index 0000000..e686e2c --- /dev/null +++ b/test/printing-open.act @@ -0,0 +1,4 @@ +operator + { a - 'id : a } + +x : a - 'id ~> 'hello \ No newline at end of file diff --git a/test/printing-open2.act b/test/printing-open2.act new file mode 100644 index 0000000..3630d94 --- /dev/null +++ b/test/printing-open2.act @@ -0,0 +1,3 @@ +typecheck \X x.x : ['Pi 'Semantics \A. ['Pi A \_.A]] + +typecheck \X x.X : ['Pi 'Semantics \A. ['Pi A \_.A]] \ No newline at end of file From 8a7f8ea2215ccc733deb077825167d6a4611446e Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Tue, 14 Mar 2023 19:39:05 +0000 Subject: [PATCH 66/89] [ fix ] more now working test cases --- Src/Command.hs | 11 +++--- Src/Elaboration.hs | 14 +++---- Src/Elaboration/Monad.hs | 3 +- Src/Elaboration/Pretty.hs | 13 +++---- test/define-operator.act | 54 ++++++++++++++------------- test/golden/define-operator.gold | 2 +- test/golden/no-space.gold | 2 +- test/golden/operator-elab-fail-2.gold | 8 ++-- test/golden/operator-elab-fail-3.gold | 8 ++-- test/golden/operator-elab-fail-4.gold | 4 +- test/golden/operator-elab-fail.gold | 8 ++-- test/golden/operator-fail.gold | 15 ++++---- test/operator-elab-fail-2.act | 6 +-- test/operator-elab-fail-3.act | 6 +-- test/operator-elab-fail-4.act | 6 +-- test/operator-elab-fail.act | 6 +-- test/operator-fail.act | 4 +- test/printing.act | 6 +-- test/reduce-neutrals-2.act | 8 ++-- test/reduce-neutrals.act | 6 +-- 20 files changed, 97 insertions(+), 93 deletions(-) diff --git a/Src/Command.hs b/Src/Command.hs index 11ec743..e3613c6 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -506,7 +506,7 @@ sopelims r opelimz (ty, t) ((op, args):opelims) = do dat <- matchObjType r (mb, opat) (ty, t) let r' = getRange op <> foldMap getRange args local (setHeadUpData dat) $ do - ((ty, decls), (pargs, args)) <- spats r' pdescs args rdesc + ((ty, decls), (pargs, args)) <- spats r' (getOperator opName) pdescs args rdesc local (setDecls decls) $ sopelims (r <> r') (opelimz :< (opName, pargs)) (ty, t -% (getOperator opName, args)) opelims @@ -537,17 +537,18 @@ sopelims r opelimz (ty, t) ((op, args):opelims) = do -- cf. itms spats :: Range + -> String -> [(Maybe ActorMeta, ASOT)] -> [CPattern] -> ASemanticsDesc -> Elab ((ASemanticsDesc, Decls), ([APattern], [ACTm])) - spats r [] [] rdesc = (,([], [])) <$> ((,) <$> instantiateDesc r rdesc <*> asks declarations) - spats r ((binder, sot) : bs) (rp:rps) rdesc = do + spats r op [] [] rdesc = (,([], [])) <$> ((,) <$> instantiateDesc r rdesc <*> asks declarations) + spats r op ((binder, sot) : bs) (rp:rps) rdesc = do (ovs :=> desc) <- instantiateSOT (getRange rp) sot ((p, t), decls, dat) <- sparamSemantics binder B0 (discharge ovs desc) rp local (setDecls decls . setHeadUpData dat) $ - fmap (bimap (p:) (t:)) <$> spats r bs rps rdesc - spats r bs rps rdesc = throwComplaint r $ ArityMismatchInOperator + fmap (bimap (p:) (t:)) <$> spats r op bs rps rdesc + spats r op bs rps rdesc = throwComplaint r $ ArityMismatchInOperator op ((length bs) - (length rps)) {- -- | sopargs desc cops diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 99ac8cc..e08c084 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -402,7 +402,7 @@ spatSemantics desc rest rp = do VNilOrCons{} -> unless (a == "") $ throwComplaint r (ExpectedNilGot a) VEnumOrTag sc es _ -> unless (a `elem` es) $ throwComplaint r (ExpectedEnumGot es a) VWildcard sc -> pure () - VUniverse _ -> unless (a `elem` ("Semantics" : Map.keys table)) $ throwComplaint r (ExpectedASemanticsGot (At r a)) + VUniverse _ -> unless (a `elem` ("Atom" : "Nil" : "Wildcard" : "Syntax" : "Semantics" : Map.keys table)) $ throwComplaint r (ExpectedASemanticsGot (At r a)) _ -> throwComplaint r =<< syntaxPError desc rp pure (AP a, ds, atom a (bigEnd (restriction rest))) ConsP r p1 p2 -> do @@ -505,12 +505,12 @@ itm usage (Op r rob rop) = do (AnOperator{..}, rps) <- sop rop dat <- matchObjType r objDesc (obDesc, ob) local (setHeadUpData dat) $ do - (desc, ps) <- itms r usage paramsDesc rps retDesc + (desc, ps) <- itms r (getOperator opName) usage paramsDesc rps retDesc pure (desc, ob -% (getOperator opName, ps)) -- TODO?: annotated terms? itm _ t = throwComplaint t $ DontKnowHowToInferDesc t -itms :: Range -> Usage +itms :: Range -> String -> Usage -- Parameters types e.g. (_ : 'Nat\n. {m = n}p\ih. {m = ['Succ n]}p) -> [(Maybe ActorMeta, ASOT)] -- Raw parameters @@ -520,13 +520,13 @@ itms :: Range -> Usage -- -> Elab (ASemanticsDesc -- Instantiated return type , [ACTm]) -- Elaborated parameters -itms r usage [] [] rdesc = (, []) <$> instantiateDesc r rdesc -itms r usage ((binder, sot):bs) (rp:rps) rdesc = do +itms r op usage [] [] rdesc = (, []) <$> instantiateDesc r rdesc +itms r op usage ((binder, sot):bs) (rp:rps) rdesc = do (ovs :=> desc) <- instantiateSOT (getRange rp) sot (p, dat) <- sparam usage binder B0 (discharge ovs desc) rp local (setHeadUpData dat) $ - fmap (p:) <$> itms r usage bs rps rdesc -itms r usage bs rps rdesc = throwComplaint r $ ArityMismatchInOperator + fmap (p:) <$> itms r op usage bs rps rdesc +itms r op usage bs rps rdesc = throwComplaint r $ ArityMismatchInOperator op ((length bs) - (length rps)) sparam :: Usage -> Maybe ActorMeta -- Name of parameter diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 0498596..64a8f91 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -495,7 +495,7 @@ data Complaint | NotAValidOperator String -- operators | AlreadyDeclaredOperator String - | InvalidOperatorArity String [SyntaxDesc] [RawP] + | ArityMismatchInOperator String Int | ExpectedParameterBinding Raw -- protocol | InvalidSend Channel Raw @@ -548,7 +548,6 @@ data Complaint -- desc inference | InferredDescMismatch (WithVarNames Pat) ESemanticsDesc | DontKnowHowToInferDesc Raw - | ArityMismatchInOperator | SchematicVariableNotInstantiated deriving (Show) diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index 9eee6d9..7016bdf 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -138,12 +138,12 @@ instance Pretty (WithRange Complaint) where NotAValidOperator x -> hsep ["Invalid operator name", pretty x] -- operators AlreadyDeclaredOperator op -> hsep ["Not a valid operator name", pretty op] - InvalidOperatorArity op [] ops -> - hsep ["Invalid arity:", pretty (show $ length ops), "extra operator parameters for", pretty op] - InvalidOperatorArity op ds [] -> - hsep ["Invalid arity:", pretty (show $ length ds), "missing operator parameters for", pretty op] - InvalidOperatorArity op ds ps -> - hsep ["Invalid arity (the impossible happened)"] + ArityMismatchInOperator op n -> + let (k, number) = case compare n 0 of + LT -> (-n, "extra") + EQ -> error "the impossible happended in ArityMismatchInOperator" + GT -> (n, "missing") + in hsep ["Invalid arity:", pretty (show $ k), number, "operator parameters for", pretty op] -- protocol InvalidSend ch tm -> hsep ["Invalid send of", pretty tm, "on channel", pretty ch] InvalidRecv ch v -> hsep ["Invalid receive of", pretty v, "on channel", pretty ch] @@ -230,7 +230,6 @@ instance Pretty (WithRange Complaint) where InferredDescMismatch p desc -> hsep [ "Inferred object description", pretty desc , "does not match pattern", pretty p ] DontKnowHowToInferDesc t -> hsep ["Do not know how to infer description for", pretty t] - ArityMismatchInOperator -> "Arity mismatch in operator" SchematicVariableNotInstantiated -> "Schematic variable not instantiated" NotAValidContextRestriction x y -> "Not a valid context restriction" NotAValidDescriptionRestriction x y -> "Not a valid description restriction" diff --git a/test/define-operator.act b/test/define-operator.act index b380192..2a3abda 100644 --- a/test/define-operator.act +++ b/test/define-operator.act @@ -2,47 +2,51 @@ syntax { 'Bool = ['Enum ['True 'False]] } syntax { 'Nat = ['EnumOrTag ['zero] [['succ 'Nat]]] } operator - { 'Wildcard - 'id ~> 'Wildcard - ; 'Wildcard - ['myApp 'Wildcard] ~> 'Wildcard - ; 'Wildcard - ['when 'Bool] ~> 'Wildcard - ; 'Bool - ['if 'Wildcard 'Wildcard] ~> 'Wildcard - ; 'Nat - ['plus 'Nat] ~> 'Nat - ; 'Nat - ['mult 'Nat] ~> 'Nat + { (x : A) - 'id : A + ; 'Wildcard - ['myApp 'Wildcard] : 'Wildcard + ; A - ['when 'Bool] : A + ; 'Bool - ['if 'Wildcard 'Wildcard] : 'Wildcard + ; 'Nat - ['plus 'Nat] : 'Nat + ; 'Nat - ['mult 'Nat] : 'Nat -- TODO: - -- ; (p : ['Sg a \x.b]) - 'snd ~> b {x=p - 'fst} + -- ; (p : ['Sg a \x.b]) - 'fst : a + -- ; (p : ['Sg a \x.b]) - 'snd : {x=p - 'fst} b } -t - 'id ~> t -(\x. t) - ['myApp s] ~> {x=s}t +t : B - 'id ~> t +(\x. t) : 'Wildcard - ['myApp s] ~> {x=s}t -x - ['when 'True] ~> x +x : A - ['when 'True] ~> x -'True - ['if l r] ~> l -'False - ['if l r] ~> r +'True : 'Bool - ['if l r] ~> l +'False : 'Bool - ['if l r] ~> r -'zero - ['plus n] ~> n -['succ m] - ['plus n] ~> ['succ (m - ['plus n])] -m - ['plus 'zero] ~> m -m - ['plus n] - ['plus x] ~> m - ['plus (n - ['plus x])] +'zero : 'Nat - ['plus n] ~> n +['succ m] : 'Nat - ['plus n] ~> ['succ (m - ['plus n])] +m : 'Nat - ['plus 'zero] ~> m +m : 'Nat - ['plus n] - ['plus x] ~> m - ['plus (n - ['plus x])] -- parsed as m [(plus, [n]), (plus, [x])] -'zero - ['mult n] ~> 'zero -m - ['mult 'zero] ~> 'zero +'zero : 'Nat - ['mult n] ~> 'zero +m : 'Nat - ['mult 'zero] ~> 'zero -- TODO: this should raise a complaint that these are non-confluent -- (unless we manage to get plus to be commutative) -['succ m] - ['mult n] ~> n - ['plus (m - ['mult n])] -m - ['mult ['succ n]] ~> m - ['plus (m - ['mult n])] -m - ['plus n] - ['mult p] ~> (m - ['mult p]) - ['plus (n - ['mult p])] +['succ m] : 'Nat - ['mult n] ~> n - ['plus (m - ['mult n])] +m : 'Nat - ['mult ['succ n]] ~> m - ['plus (m - ['mult n])] +m : 'Nat - ['plus n] - ['mult p] ~> (m - ['mult p]) - ['plus (n - ['mult p])] -- parsed as m [(plus, [n]), (mult, [p])] exec 'Bool?block. - ( PRINTF "%i" 'test - 'id. - | 'test - 'id ~ 'test - | 'hello - ['when block] ~ 'hello + -- poor man's type annotations + let t : 'Atom = 'test. + let h : 'Wildcard = 'hello. + ( PRINTF "%i" t - 'id. + | t - 'id ~ t + | h - ['when block] ~ h | block ~ 'True | PRINTF "%i" block. | 'Nat?m n p. m - ['plus n] - ['mult p] ~ (m - ['mult p]) - ['plus (n - ['mult p])] - ) \ No newline at end of file + ) diff --git a/test/golden/define-operator.gold b/test/golden/define-operator.gold index 5f1ff2b..e7fa6c8 100644 --- a/test/golden/define-operator.gold +++ b/test/golden/define-operator.gold @@ -1,7 +1,7 @@ ret > ExitSuccess out > 'test - 'id out > 'True -out > Warning: Unsolved metas (m:7, n:8, p:9) +out > Warning: Unsolved metas (m:9, n:10, p:11) out > out > err > diff --git a/test/golden/no-space.gold b/test/golden/no-space.gold index 93efbd7..661e6d5 100644 --- a/test/golden/no-space.gold +++ b/test/golden/no-space.gold @@ -1,4 +1,4 @@ ret > ExitFailure 1 out > Parse error near location: no-space.act:19:21 -out > Expected '!', '?', '~', '<->', ':', '|-', '@', or '-'. +out > Expected '!', '?', '-', '~', '<->', '|-', '@', or ':'. out > diff --git a/test/golden/operator-elab-fail-2.gold b/test/golden/operator-elab-fail-2.gold index 97c49f6..00c45a2 100644 --- a/test/golden/operator-elab-fail-2.gold +++ b/test/golden/operator-elab-fail-2.gold @@ -1,10 +1,10 @@ ret > ExitFailure 1 out > Error out > -out > 3 | operator { 'Bool - ['if 'Wildcard 'Wildcard] ~> 'Wildcard } +out > 3 | operator { 'Bool - ['if 'Wildcard 'Wildcard] : 'Wildcard } out > 4 | -out > 5 | 'True - ['if l] ~> l -out > ^^^^^ -out > operator-elab-fail-2.act:5:9-14 +out > 5 | 'True : 'Bool - ['if l] ~> l +out > ^^^^^ +out > operator-elab-fail-2.act:5:17-22 out > Invalid arity: 1 missing operator parameters for if out > diff --git a/test/golden/operator-elab-fail-3.gold b/test/golden/operator-elab-fail-3.gold index 5f4bfff..db0613b 100644 --- a/test/golden/operator-elab-fail-3.gold +++ b/test/golden/operator-elab-fail-3.gold @@ -2,9 +2,9 @@ ret > ExitFailure 1 out > Error out > out > 4 | -out > 5 | 'True - ['if l r] ~> l -out > 6 | 'False - ['ifte l r] ~> r -out > ^^^^^ -out > operator-elab-fail-3.act:6:10-15 +out > 5 | 'True : 'Bool - ['if l r] ~> l +out > 6 | 'False : 'Bool - ['ifte l r] ~> r +out > ^^^^^ +out > operator-elab-fail-3.act:6:18-23 out > Invalid operator name ifte out > diff --git a/test/golden/operator-elab-fail-4.gold b/test/golden/operator-elab-fail-4.gold index b558eb5..4ab897f 100644 --- a/test/golden/operator-elab-fail-4.gold +++ b/test/golden/operator-elab-fail-4.gold @@ -3,8 +3,8 @@ out > Error out > out > 1 | syntax { 'Bool = ['Enum ['False 'True]] } out > 2 | -out > 3 | operator { 'Boo - ['if 'Wildcard 'Wildcard] ~> 'Wildcard } +out > 3 | operator { 'Boo - ['if 'Wildcard 'Wildcard] : 'Wildcard } out > ^^^^ out > operator-elab-fail-4.act:3:11-15 -out > Expected an atom among [Nil, Atom, Wildcard, Bool] and got Boo +out > Expected a semantics but got 'Boo out > diff --git a/test/golden/operator-elab-fail.gold b/test/golden/operator-elab-fail.gold index 4546d11..bc76c7a 100644 --- a/test/golden/operator-elab-fail.gold +++ b/test/golden/operator-elab-fail.gold @@ -2,9 +2,9 @@ ret > ExitFailure 1 out > Error out > out > 4 | -out > 5 | 'True - ['if l r] ~> l -out > 6 | 'False - ['if l m r] ~> r -out > ^ -out > operator-elab-fail.act:6:18-19 +out > 5 | 'True : 'Bool - ['if l r] ~> l +out > 6 | 'False : 'Bool - ['if l m r] ~> r +out > ^^^^^^^^^ +out > operator-elab-fail.act:6:18-27 out > Invalid arity: 1 extra operator parameters for if out > diff --git a/test/golden/operator-fail.gold b/test/golden/operator-fail.gold index ee44f47..ee02601 100644 --- a/test/golden/operator-fail.gold +++ b/test/golden/operator-fail.gold @@ -1,11 +1,12 @@ ret > ExitFailure 1 out > Error out > -out > 1 | success : ?'Wildcard. ?'Wildcard. !'Wildcard. -out > 2 | success@p = p?f. p?t. p!f - ['app t]. -out > ^^^^^^^^^^^^ -out > operator-fail.act:2:24-36 -out > Inferred object description 'Wildcard does not match pattern ['Pi S \x. T] -out > when elaborating p!f - ['app t] -out > when elaborating the judgement definition for success +out > 3 | +out > 4 | failure : ?['Pi 'Wildcard \_.'Wildcard]. ?'Wildcard. !'Wildcard. +out > 5 | failure@p = p?f. p?t. p!f - 'app. +out > ^^^^^^^^ +out > operator-fail.act:5:24-32 +out > Invalid arity: 1 missing operator parameters for app +out > when elaborating p!f - 'app +out > when elaborating the judgement definition for failure out > diff --git a/test/operator-elab-fail-2.act b/test/operator-elab-fail-2.act index 4426d1f..b073c85 100644 --- a/test/operator-elab-fail-2.act +++ b/test/operator-elab-fail-2.act @@ -1,6 +1,6 @@ syntax { 'Bool = ['Enum ['False 'True]] } -operator { 'Bool - ['if 'Wildcard 'Wildcard] ~> 'Wildcard } +operator { 'Bool - ['if 'Wildcard 'Wildcard] : 'Wildcard } -'True - ['if l] ~> l -'False - ['if l r] ~> r \ No newline at end of file +'True : 'Bool - ['if l] ~> l +'False : 'Bool - ['if l r] ~> r diff --git a/test/operator-elab-fail-3.act b/test/operator-elab-fail-3.act index cc12b1e..c6f50fd 100644 --- a/test/operator-elab-fail-3.act +++ b/test/operator-elab-fail-3.act @@ -1,6 +1,6 @@ syntax { 'Bool = ['Enum ['False 'True]] } -operator { 'Bool - ['if 'Wildcard 'Wildcard] ~> 'Wildcard } +operator { 'Bool - ['if 'Wildcard 'Wildcard] : 'Wildcard } -'True - ['if l r] ~> l -'False - ['ifte l r] ~> r \ No newline at end of file +'True : 'Bool - ['if l r] ~> l +'False : 'Bool - ['ifte l r] ~> r diff --git a/test/operator-elab-fail-4.act b/test/operator-elab-fail-4.act index 77a2ee7..a4a37a8 100644 --- a/test/operator-elab-fail-4.act +++ b/test/operator-elab-fail-4.act @@ -1,6 +1,6 @@ syntax { 'Bool = ['Enum ['False 'True]] } -operator { 'Boo - ['if 'Wildcard 'Wildcard] ~> 'Wildcard } +operator { 'Boo - ['if 'Wildcard 'Wildcard] : 'Wildcard } -'True - ['if l r] ~> l -'False - ['if l r] ~> r \ No newline at end of file +'True : 'Bool - ['if l r] ~> l +'False : 'Bool - ['if l r] ~> r diff --git a/test/operator-elab-fail.act b/test/operator-elab-fail.act index 9c3a727..d62ee84 100644 --- a/test/operator-elab-fail.act +++ b/test/operator-elab-fail.act @@ -1,6 +1,6 @@ syntax { 'Bool = ['Enum ['False 'True]] } -operator { 'Bool - ['if 'Wildcard 'Wildcard] ~> 'Wildcard } +operator { 'Bool - ['if 'Wildcard 'Wildcard] : 'Wildcard } -'True - ['if l r] ~> l -'False - ['if l m r] ~> r \ No newline at end of file +'True : 'Bool - ['if l r] ~> l +'False : 'Bool - ['if l m r] ~> r diff --git a/test/operator-fail.act b/test/operator-fail.act index dc73500..c0f4c08 100644 --- a/test/operator-fail.act +++ b/test/operator-fail.act @@ -1,5 +1,5 @@ -success : ?'Wildcard. ?'Wildcard. !'Wildcard. +success : ?['Pi 'Wildcard \_.'Wildcard]. ?'Wildcard. !'Wildcard. success@p = p?f. p?t. p!f - ['app t]. -failure : ?'Wildcard. ?'Wildcard. !'Wildcard. +failure : ?['Pi 'Wildcard \_.'Wildcard]. ?'Wildcard. !'Wildcard. failure@p = p?f. p?t. p!f - 'app. diff --git a/test/printing.act b/test/printing.act index 5c7db8b..5a44cf8 100644 --- a/test/printing.act +++ b/test/printing.act @@ -1,8 +1,8 @@ syntax { 'Bool = ['Enum ['False 'True]] } -operator { 'Wildcard - ['if 'Bool] ~> 'Wildcard } +operator { X - ['if 'Bool] : X } -t - ['if 'True] ~> t +t : Y - ['if 'True] ~> t strict : $'Bool. strict@p = p?b. case $b @@ -13,4 +13,4 @@ strict@p = p?b. case $b exec 'Bool?b c. ( strict@p. (p!b. | b ~ 'True) | strict@q. (c ~ 'False | q!c - ['if b].) - ) \ No newline at end of file + ) diff --git a/test/reduce-neutrals-2.act b/test/reduce-neutrals-2.act index ce4bfc6..cdb87cd 100644 --- a/test/reduce-neutrals-2.act +++ b/test/reduce-neutrals-2.act @@ -1,8 +1,8 @@ operator - { 'Wildcard - ['fst ['Enum ['True]]] ~> 'Wildcard - ; 'Wildcard - ['snd ['Enum ['True]]] ~> 'Wildcard + { A - ['fst ['Enum ['True]]] : A + ; B - ['snd ['Enum ['True]]] : B } -x - ['fst b1] - ['snd b2] ~> x - ['fst b1 - ['snd b2]] +x : X - ['fst b1] - ['snd b2] ~> x - ['fst b1 - ['snd b2]] -exec ('Wildcard?b1 b2. 'at - ['fst b1] - ['snd b2] ~ 'at - ['fst b1 - ['snd b2]]) \ No newline at end of file +exec ('Wildcard?b1 b2. let a : 'Atom = 'at . a - ['fst b1] - ['snd b2] ~ a - ['fst b1 - ['snd b2]]) diff --git a/test/reduce-neutrals.act b/test/reduce-neutrals.act index e6e142d..ecddd40 100644 --- a/test/reduce-neutrals.act +++ b/test/reduce-neutrals.act @@ -1,5 +1,5 @@ -operator { 'Wildcard - ['if ['Enum ['True]]] ~> 'Wildcard } +operator { A - ['if ['Enum ['True]]] : A } -x - ['if b1] - ['if b2] ~> x - ['if b1 - ['if b2]] +x : X - ['if b1] - ['if b2] ~> x - ['if b1 - ['if b2]] -exec ('Wildcard?b1 b2. 'at - ['if b1] - ['if b2] ~ 'at - ['if b1 - ['if b2]]) \ No newline at end of file +exec ('Wildcard?b1 b2. let a : 'Atom = 'at. a - ['if b1] - ['if b2] ~ a - ['if b1 - ['if b2]]) From 433302f3d0c54578fc44e928c99739ff30eef2e0 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Thu, 16 Mar 2023 11:14:13 +0000 Subject: [PATCH 67/89] [ fix ] bring back clause tracing --- README.md | 8 ++-- Src/Actor.hs | 5 +- Src/Actor/Display.hs | 3 +- Src/Command.hs | 13 ++--- Src/Display.hs | 19 ++++++-- Src/Elaboration/Pretty.hs | 3 +- Src/LaTeX.hs | 3 +- Src/Machine/Base.hs | 30 ++++++------ Src/Machine/Display.hs | 3 +- Src/Machine/Exec.hs | 4 +- Src/Machine/Trace.hs | 3 +- Src/Operator.hs | 4 +- Src/Operator/Eval.hs | 5 +- Src/Pretty.hs | 2 - Src/Semantics.hs | 1 + Src/Syntax/Debug.hs | 7 +-- Src/Term/Display.hs | 1 + Src/Unelaboration.hs | 70 +-------------------------- Src/Unelaboration/Monad.hs | 97 ++++++++++++++++++++++++++++++++++++++ typos.cabal | 1 + 20 files changed, 163 insertions(+), 119 deletions(-) create mode 100644 Src/Unelaboration/Monad.hs diff --git a/README.md b/README.md index f5b0a38..8af144d 100644 --- a/README.md +++ b/README.md @@ -526,8 +526,8 @@ Since `'app` and `'when` are builtin operators, they do not need to be declared, this is how we would declare our own copies of them: ``` operator - { 'Wildcard - ['myApp 'Wildcard] ~> 'Wildcard - ; 'Wildcard - ['myWhen ['Enum ['True 'False]]] ~> 'Wildcard + { 'Wildcard - ['myApp 'Wildcard] : 'Wildcard + ; 'Wildcard - ['myWhen ['Enum ['True 'False]]] : 'Wildcard } ``` In the future, we might check more interesting semantic notions, but for now, @@ -548,9 +548,9 @@ with pattern variables appropriately instantiated. For example, to match the builtin behaviour of `'app` and `'when`, we can declare the following reduction rules: ``` -(\ x. t) - ['myApp s] ~> {x=s}t +(\ x. t) : 'Wildcard - ['myApp s] ~> {x=s}t -t - ['myWhen 'True] ~> t +t : 'Wildcard - ['myWhen 'True] ~> t ``` Multiple rules may be given for the same operator. We do not currently check if overlapping rules are confluent, so it is up to the rule diff --git a/Src/Actor.hs b/Src/Actor.hs index 3067ada..f8fc0fd 100644 --- a/Src/Actor.hs +++ b/Src/Actor.hs @@ -101,8 +101,11 @@ initEnv gamma = Env , alphaRenamings = Map.empty } +currentScope :: Env' m -> Bwd String +currentScope env = globalScope env <> localScope env + childEnv :: Env -> Env -childEnv parentEnv = initEnv (globalScope parentEnv <> localScope parentEnv) +childEnv parentEnv = initEnv (currentScope parentEnv) newActorVar :: ActorMeta -> EnvImg' m -> Env' m -> Env' m newActorVar x defn env = env { actorVars = Map.insert x defn (actorVars env) } diff --git a/Src/Actor/Display.hs b/Src/Actor/Display.hs index dd3836e..19768d1 100644 --- a/Src/Actor/Display.hs +++ b/Src/Actor/Display.hs @@ -12,7 +12,8 @@ import Display import Pretty import Term.Display () import Thin -import Unelaboration (DAEnv, nameOn) +import Unelaboration.Monad (nameOn) +import Unelaboration (DAEnv) instance Display Env where type DisplayEnv Env = () diff --git a/Src/Command.hs b/Src/Command.hs index e3613c6..df4a0a1 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -16,7 +16,7 @@ import Data.Maybe (fromMaybe, catMaybes) import Data.Traversable (for) import Data.These import Data.Either -import Data.Foldable (fold) +import Data.Foldable (fold, asum) import Actor import Actor.Display () @@ -40,7 +40,8 @@ import Rules import Syntax import Info import Term.Base -import Unelaboration(Unelab(..), subunelab, withEnv, initDAEnv, Naming, declareChannel) +import Unelaboration.Monad (Unelab(..), Naming, subunelab, withEnv) +import Unelaboration (initDAEnv, declareChannel) import Location import Utils @@ -183,13 +184,7 @@ instance Display ACommand where display = viaPretty pmachinestep :: Parser MachineStep -pmachinestep = - MachineRecv <$ plit "recv" - <|> MachineSend <$ plit "send" - <|> MachineExec <$ plit "exec" - <|> MachineMove <$ plit "move" - <|> MachineUnify <$ plit "unify" - <|> MachineBreak <$ plit "break" +pmachinestep = asum $ map (\ s -> s <$ plit (render $ pretty s)) [minBound..maxBound] pjudgeat :: Parser (Variable, (), Variable) pjudgeat = (,,) <$> pvariable <*> punc "@" <*> pvariable diff --git a/Src/Display.hs b/Src/Display.hs index 4f6d86c..028994d 100644 --- a/Src/Display.hs +++ b/Src/Display.hs @@ -15,8 +15,9 @@ import Options import Pretty (Doc, Annotations, Pretty(..), renderWith) import Thin -import Unelaboration (Unelab(..), evalUnelab, Naming) -import qualified Unelaboration +import Unelaboration.Monad (Unelab(..), evalUnelab, Naming) +import qualified Unelaboration.Monad as Unelaboration +import Unelaboration () import GHC.Stack @@ -88,12 +89,12 @@ instance Display Void where instance Display DB where type DisplayEnv DB = Naming display = viaPretty - +{- instance (Show t, Unelab t, Pretty (Unelabed t)) => Display [Format () (Doc Annotations) t] where type DisplayEnv [Format () (Doc Annotations) t] = UnelabEnv t display = viaPretty - +-} instance (Show t, Unelab t, Pretty (Unelabed t)) => Display [Format Directive Debug t] where type DisplayEnv [Format Directive Debug t] = UnelabEnv t @@ -103,11 +104,21 @@ instance Display Pat where type DisplayEnv Pat = Naming display = viaPretty +unsafeDocDisplay :: (DisplayEnv a ~ Naming, Display a) => Options -> Naming -> a -> Doc Annotations +unsafeDocDisplay opts naming t + = unsafeEvalDisplay naming + $ display t + unsafeDocDisplayClosed :: (DisplayEnv a ~ Naming, Display a) => Options -> a -> Doc Annotations unsafeDocDisplayClosed opts t = unsafeEvalDisplay Unelaboration.initNaming $ display t +unsafeDisplay :: (DisplayEnv a ~ Naming, Display a) => Options -> Naming -> a -> String +unsafeDisplay opts naming t + = renderWith (renderOptions opts) + $ unsafeDocDisplay opts naming t + unsafeDisplayClosed :: (DisplayEnv a ~ Naming, Display a) => Options -> a -> String unsafeDisplayClosed opts t = renderWith (renderOptions opts) diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index 7016bdf..0c65e58 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -12,7 +12,8 @@ import Concrete.Pretty() import Elaboration.Monad import Location import Pretty -import Unelaboration (unsafeEvalUnelab, unelab, initNaming, Unelab, Unelabed, UnelabEnv, Naming) +import Unelaboration.Monad (unsafeEvalUnelab, unelab, initNaming, Unelab, Unelabed, UnelabEnv, Naming) +import Unelaboration () import Data.List.NonEmpty (NonEmpty((:|))) import Rules import Syntax () diff --git a/Src/LaTeX.hs b/Src/LaTeX.hs index 3f5630c..af3ae52 100644 --- a/Src/LaTeX.hs +++ b/Src/LaTeX.hs @@ -14,7 +14,8 @@ import Hide import Syntax import Scope -import Unelaboration +import Unelaboration.Monad +import Unelaboration () newtype LaTeXM a = LaTeXM { runLaTeXM :: Reader SyntaxTable a } deriving (Functor, Applicative, Monad, MonadReader SyntaxTable) diff --git a/Src/Machine/Base.hs b/Src/Machine/Base.hs index ed5c607..85df661 100644 --- a/Src/Machine/Base.hs +++ b/Src/Machine/Base.hs @@ -25,12 +25,13 @@ import Syntax (SyntaxDesc) import Data.Bifunctor (Bifunctor(first)) import Machine.Matching -import Debug.Trace (trace) -import Display (unsafeDocDisplayClosed) +import Debug.Trace (trace, traceShow) +import Display (unsafeDocDisplay) import ANSI hiding (withANSI) import Pretty import Operator import Operator.Eval +import Unelaboration.Monad (Naming, UnelabMeta) newtype Date = Date Int @@ -181,32 +182,30 @@ unOp t = case expand t of pure (Operator op, ps) _ -> Nothing -toClause :: forall m . Show m => Pat -> Bwd (Operator, [Pat]) -> ACTm +toClause :: forall m. (Show m, UnelabMeta m) => Pat -> Bwd (Operator, [Pat]) -> ACTm -> Options -> (Term' m -> Term' m) -- head normaliser -> Env' m -> (Term' m, [Term' m]) -- object & parameters -> Either (Term' m, [Term' m]) (Term' m) toClause pobj (ops :< op) rhs opts hnf env targs@(t, args) = - let msg result = "" in -{- TODO: reinstate: -let msg result = flush $ vcat + let msg result = flush $ vcat [ hsep ( "Matching" - : withANSI [SetColour Background Green] (unsafeDocDisplayClosed opts t) + : withANSI [SetColour Background Green] (unsafeDocDisplay opts naming t) : "-" : [let opdoc = pretty (getOperator (fst op)) in case args of [] -> "'" <> opdoc - _ -> "['" <> hsep (opdoc : map (unsafeDocDisplayClosed opts) args) <> "]"] + _ -> "['" <> hsep (opdoc : map (unsafeDocDisplay opts naming) args) <> "]"] ) , hsep ( "against" - : unsafeDocDisplayClosed opts pobj + : unsafeDocDisplay opts naming pobj : flip map (ops <>> [op]) (\ (Operator op, ps) -> "- " <> case ps of [] -> "'" <> pretty op - _ -> "['" <> hsep (pretty op : map (unsafeDocDisplayClosed opts) ps) <> "]") + _ -> "['" <> hsep (pretty op : map (unsafeDocDisplay opts naming) ps) <> "]") ) - <> " ~> " <> unsafeDocDisplayClosed opts rhs + <> " ~> " <> unsafeDocDisplay opts naming rhs , result ] in --} + let ((t, ts), res) = loop initMatching ops op targs in case res of Right mtch | Just val <- mangleActors opts (matchingToEnv mtch env) rhs -> whenClause opts (msg (withANSI [SetColour Background Green] "Success!")) $ pure val @@ -215,6 +214,9 @@ let msg result = flush $ vcat where + naming :: Naming + naming = let scp = currentScope env in (scp, ones (length scp), scp) + whenClause :: Options -> Doc Annotations -> a -> a whenClause opts doc a | MachineClause `elem` fromMaybe [] (tracingOption opts) @@ -239,8 +241,7 @@ let msg result = flush $ vcat case loop mtch lops (lop, lps) (ltops, ltps) of ((ltops, ltps), res) -> (ltops -% (getOperator lop, ltps), res) _ -> (contract (ltops :-: loptpsnf), Left Mismatch) -- Careful: could be a stuck meta - _ -> (topsnf, Left (whenClause opts "not an operator application" Mismatch)) --- _ -> (topsnf, Left (whenClause opts (unsafeDocDisplayClosed unsafeOptions topsnf <+> "not an operator application") Mismatch)) + _ -> (topsnf, Left (whenClause opts (unsafeDocDisplay opts naming topsnf <+> "not an operator application") Mismatch)) in case leftnested of (tops, Left err) -> ((tops, tps), Left err) (tops, Right mtch) -> first (tops,) $ matches mtch ps tps @@ -320,4 +321,3 @@ tracing = fromMaybe [] . tracingOption . options instance (Show s, Show (t Frame)) => Show (Process log s t) where show (Process opts stack root env store actor _ geas) = unwords ["Process ", show opts, show stack, show root, show env, show store, show actor, show geas] - diff --git a/Src/Machine/Display.hs b/Src/Machine/Display.hs index 66124de..e26754d 100644 --- a/Src/Machine/Display.hs +++ b/Src/Machine/Display.hs @@ -20,7 +20,8 @@ import Options import Pretty import Term import Term.Display () -import Unelaboration (DAEnv, initDAEnv, Naming, nameOn, initNaming) +import Unelaboration.Monad (Naming, nameOn, initNaming) +import Unelaboration (DAEnv, initDAEnv) import qualified Unelaboration as A import Operator.Eval (StoreF (..)) diff --git a/Src/Machine/Exec.hs b/Src/Machine/Exec.hs index e30f005..0d09bbd 100644 --- a/Src/Machine/Exec.hs +++ b/Src/Machine/Exec.hs @@ -4,7 +4,7 @@ module Machine.Exec where import qualified Data.Map as Map import qualified Data.Set as Set import Data.Maybe (fromJust) -import Unelaboration (nameSel) +import Unelaboration.Monad (nameSel) import Control.Monad.Reader @@ -233,7 +233,7 @@ format ann p@Process{..} fmt = renderWith (renderOptions options) $ unsafeEvalDisplay (frDisplayEnv stack) $ fmap (withANSI ann) - $ subdisplay + $ withForget . viaPretty $ insertDebug p $ map (followDirectives $ mkHeadUpData p) fmt diff --git a/Src/Machine/Trace.hs b/Src/Machine/Trace.hs index 2011349..056d418 100644 --- a/Src/Machine/Trace.hs +++ b/Src/Machine/Trace.hs @@ -29,7 +29,8 @@ import Pretty import Syntax (SyntaxDesc, SyntaxTable, expand, VSyntaxDesc'(..), contract) import Semantics (embed) import Term.Base -import Unelaboration +import Unelaboration.Monad +import Unelaboration () import Data.String (fromString) import Data.Functor ((<&>)) diff --git a/Src/Operator.hs b/Src/Operator.hs index ce10256..cb46b1b 100644 --- a/Src/Operator.hs +++ b/Src/Operator.hs @@ -15,7 +15,7 @@ import Hide import Scope import Thin import Pretty - +import Unelaboration.Monad (UnelabMeta) {- 1. No subst in parsing phase. @@ -125,7 +125,7 @@ type instance OPERATOR Abstract = Operator newtype Clause = Clause { runClause :: forall m - . Show m => Options + . (Show m, UnelabMeta m) => Options -> (Term' m -> Term' m) -- head normaliser -> Env' m -> (Term' m, [Term' m]) -- object & parameters diff --git a/Src/Operator/Eval.hs b/Src/Operator/Eval.hs index ae2ecac..335fd4f 100644 --- a/Src/Operator/Eval.hs +++ b/Src/Operator/Eval.hs @@ -13,6 +13,7 @@ import Concrete.Base import Operator import Options import Actor +import Unelaboration.Monad (UnelabMeta) dependencySet :: StoreF i d -> Guard -> Set Guard dependencySet st@Store{..} g = case Map.lookup g guards of @@ -45,7 +46,7 @@ type HeadUpData = HeadUpData' Meta -- Expanding the term using the information currently available: -- + meta solutions -- + operator clauses -headUp :: forall m . Show m => HeadUpData' m -> Term' m -> Term' m +headUp :: forall m . (Show m, UnelabMeta m) => HeadUpData' m -> Term' m -> Term' m headUp dat@HeadUpData{..} term = case expand term of m :$: sg | Just t <- whatIs m -> headUp dat (t //^ sg) @@ -65,5 +66,3 @@ headUp dat@HeadUpData{..} term = case expand term of operate op tps = case runClause (opTable op) huOptions (headUp dat) huEnv tps of Left (t, ps) -> t -% (getOperator op, ps) Right t -> headUp dat t - - diff --git a/Src/Pretty.hs b/Src/Pretty.hs index efc7023..ddb02e6 100644 --- a/Src/Pretty.hs +++ b/Src/Pretty.hs @@ -88,5 +88,3 @@ instance Collapse Cursor where , withANSI [SetColour Foreground Red, SetWeight Bold] ":<+>:" , collapse rstrs ] - -instance Show (Doc Annotations) where show = render diff --git a/Src/Semantics.hs b/Src/Semantics.hs index 930d950..d4440f9 100644 --- a/Src/Semantics.hs +++ b/Src/Semantics.hs @@ -17,6 +17,7 @@ import Term hiding (contract, expand) import qualified Term import Syntax (SyntaxTable, SyntaxCat, WithSyntaxCat(..)) import Operator.Eval +import Unelaboration.Monad() embed :: Int -> ASyntaxDesc -> ASemanticsDesc embed sc syn = (fmap absurd $^ syn) *^ none sc diff --git a/Src/Syntax/Debug.hs b/Src/Syntax/Debug.hs index 16d42b9..8019f0a 100644 --- a/Src/Syntax/Debug.hs +++ b/Src/Syntax/Debug.hs @@ -5,14 +5,15 @@ import Data.Maybe (fromJust) import qualified Data.Map as Map import Display (display, unsafeEvalDisplay) import Machine.Display() -import Unelaboration (initNaming) +import Unelaboration.Monad (initNaming) +import Text.PrettyPrint.Compact (render) printIt = putStrLn $ unlines [ show validateIt , "===" - , show (unsafeEvalDisplay initNaming $ display (syntaxDesc ["Syntax"])) + , render (unsafeEvalDisplay initNaming $ display (syntaxDesc ["Syntax"])) , "===" - , show (unsafeEvalDisplay initNaming $ display $ Syntax.contract (fromJust (Syntax.expand (Map.singleton "Syntax" (syntaxDesc ["Syntax"])) (syntaxDesc ["Syntax"]))))] + , render (unsafeEvalDisplay initNaming $ display $ Syntax.contract (fromJust (Syntax.expand (Map.singleton "Syntax" (syntaxDesc ["Syntax"])) (syntaxDesc ["Syntax"]))))] {- ['EnumOrTag diff --git a/Src/Term/Display.hs b/Src/Term/Display.hs index c6595ff..527a6aa 100644 --- a/Src/Term/Display.hs +++ b/Src/Term/Display.hs @@ -5,6 +5,7 @@ module Term.Display where import Display import Term import Thin +import Unelaboration.Monad import Unelaboration instance (Show m, UnelabMeta m) => Display (Tm m) where diff --git a/Src/Unelaboration.hs b/Src/Unelaboration.hs index 3c40b85..01f5e32 100644 --- a/Src/Unelaboration.hs +++ b/Src/Unelaboration.hs @@ -24,63 +24,7 @@ import Semantics() import Term.Base import Thin import Location (unknown) - -type Naming = - ( Bwd String -- what's in the support - , Th -- and how that was chosen from - , Bwd String -- what's in scope - ) - -initNaming :: Naming -initNaming = (B0, ones 0, B0) - -nameOn :: Naming -> String -> Naming -nameOn (xz, th, yz) x = (xz :< x, th -? True, yz :< x) - -nameSel :: Th -> Naming -> Naming -nameSel th (xz, ph, yz) = (th ?< xz, th <^> ph, yz) - -freshen :: String -> Naming -> String -freshen x (xz, _, _) = head [y | y <- ys, all (y /=) xz] where - ys = x : [x ++ show (i :: Integer) | i <- [0..]] - -data Complaint = UnexpectedEmptyThinning Naming - | VarOutOfScope Naming - | InvalidNaming Naming - | UnknownChannel String - deriving (Show) - -newtype UnelabM e a = Unelab - { runUnelab :: (ReaderT e - (Either Complaint)) - a } - deriving ( Functor, Applicative, Monad - , MonadError Complaint - , MonadReader e) - -withEnv :: e' -> UnelabM e' a -> UnelabM e a -withEnv rh (Unelab md) = Unelab (withReaderT (const rh) md) - -evalUnelab :: e -> UnelabM e a -> Either Complaint a -evalUnelab e (Unelab m) = runReaderT m e - -unsafeEvalUnelab :: e -> UnelabM e a -> a -unsafeEvalUnelab e m = either (error . show) id $ evalUnelab e m - -withForget :: Forget e e' => UnelabM e' a -> UnelabM e a -withForget (Unelab md) = Unelab (withReaderT forget md) - -class Unelab t where - type UnelabEnv t - type Unelabed t - - unelab :: HasCallStack => t -> UnelabM (UnelabEnv t) (Unelabed t) - - -subunelab :: (Unelab t, Forget e (UnelabEnv t)) => t -> UnelabM e (Unelabed t) -subunelab = withForget . unelab - -type UnelabMeta m = (Unelab m, UnelabEnv m ~ (), Unelabed m ~ Variable) +import Unelaboration.Monad instance UnelabMeta m => Unelab (CdB (Tm m)) where type UnelabEnv (CdB (Tm m)) = Naming @@ -199,24 +143,12 @@ instance Forget DAEnv Naming where forget = daActorNaming -instance Unelab Meta where - type UnelabEnv Meta = () - type Unelabed Meta = Variable - unelab m = pure $ Variable unknown $ compressedMeta m - instance Unelab (Binder ActorMeta) where type UnelabEnv (Binder ActorMeta) = () type Unelabed (Binder ActorMeta) = RawP unelab Unused = pure (UnderscoreP unknown) unelab (Used av) = VarP unknown <$> unelab av -instance Unelab ActorMeta where - type UnelabEnv ActorMeta = () - type Unelabed ActorMeta = Variable - -- TODO: fixme - unelab (ActorMeta ASubject str) = pure (Variable unknown $ "$" ++ str) - unelab (ActorMeta _ str) = pure (Variable unknown str) - instance Unelab Channel where type UnelabEnv Channel = () type Unelabed Channel = Variable diff --git a/Src/Unelaboration/Monad.hs b/Src/Unelaboration/Monad.hs new file mode 100644 index 0000000..bb2617c --- /dev/null +++ b/Src/Unelaboration/Monad.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE ConstraintKinds #-} + +module Unelaboration.Monad where + +import Control.Monad.Except +import Control.Monad.Reader + +import GHC.Stack + +import Bwd +import Forget + +import Actor (ActorMeta'(..), ActorMeta, Passport(..)) +import Concrete.Base (Variable(..)) +import Location (unknown) +import Term.Base (Meta, compressedMeta) +import Thin + +------------------------------------------------------------------------ +-- Naming + +type Naming = + ( Bwd String -- what's in the support + , Th -- and how that was chosen from + , Bwd String -- what's in scope + ) + +initNaming :: Naming +initNaming = (B0, ones 0, B0) + +nameOn :: Naming -> String -> Naming +nameOn (xz, th, yz) x = (xz :< x, th -? True, yz :< x) + +nameSel :: Th -> Naming -> Naming +nameSel th (xz, ph, yz) = (th ?< xz, th <^> ph, yz) + +freshen :: String -> Naming -> String +freshen x (xz, _, _) = head [y | y <- ys, all (y /=) xz] where + ys = x : [x ++ show (i :: Integer) | i <- [0..]] + +------------------------------------------------------------------------ +-- Monad + +data Complaint = UnexpectedEmptyThinning Naming + | VarOutOfScope Naming + | InvalidNaming Naming + | UnknownChannel String + deriving (Show) + +newtype UnelabM e a = Unelab + { runUnelab :: (ReaderT e + (Either Complaint)) + a } + deriving ( Functor, Applicative, Monad + , MonadError Complaint + , MonadReader e) + +withEnv :: e' -> UnelabM e' a -> UnelabM e a +withEnv rh (Unelab md) = Unelab (withReaderT (const rh) md) + +evalUnelab :: e -> UnelabM e a -> Either Complaint a +evalUnelab e (Unelab m) = runReaderT m e + +unsafeEvalUnelab :: e -> UnelabM e a -> a +unsafeEvalUnelab e m = either (error . show) id $ evalUnelab e m + +withForget :: Forget e e' => UnelabM e' a -> UnelabM e a +withForget (Unelab md) = Unelab (withReaderT forget md) + +------------------------------------------------------------------------ +-- Class + +class Unelab t where + type UnelabEnv t + type Unelabed t + + unelab :: HasCallStack => t -> UnelabM (UnelabEnv t) (Unelabed t) + +subunelab :: (Unelab t, Forget e (UnelabEnv t)) => t -> UnelabM e (Unelabed t) +subunelab = withForget . unelab + +------------------------------------------------------------------------ +-- Unelaboration of meta variables + +type UnelabMeta m = (Unelab m, UnelabEnv m ~ (), Unelabed m ~ Variable) + +instance Unelab Meta where + type UnelabEnv Meta = () + type Unelabed Meta = Variable + unelab m = pure $ Variable unknown $ compressedMeta m + +instance Unelab ActorMeta where + type UnelabEnv ActorMeta = () + type Unelabed ActorMeta = Variable + -- TODO: fixme + unelab (ActorMeta ASubject str) = pure (Variable unknown $ "$" ++ str) + unelab (ActorMeta _ str) = pure (Variable unknown str) diff --git a/typos.cabal b/typos.cabal index 9181ebf..1e3e9f3 100644 --- a/typos.cabal +++ b/typos.cabal @@ -75,6 +75,7 @@ library Term.Mangler, Term.Substitution, Thin, + Unelaboration.Monad, Unelaboration, Utils, Vector From 39341245d063d89401ee533040305e38975d8528 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Thu, 16 Mar 2023 16:41:44 +0000 Subject: [PATCH 68/89] towards bringing back judgement declarations --- Src/Command.hs | 18 +++++++---------- Src/Elaboration.hs | 10 +++++----- Src/Elaboration/Pretty.hs | 4 ---- Src/Operator.hs | 41 ++++++++++++++++++++++++++++++++++++--- Src/Rules.hs | 12 +++++++++++- examples/stlcRules.act | 4 ++-- 6 files changed, 63 insertions(+), 26 deletions(-) diff --git a/Src/Command.hs b/Src/Command.hs index df4a0a1..d648ae0 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -151,9 +151,9 @@ instance Pretty CCommand where , prettyCds posts] Go a -> keyword "exec" <+> pretty a Trace ts -> keyword "trace" <+> collapse (BracesList $ map pretty ts) - -- DeclJudgementForm j -> keyword "judgementform" <+> collapse (BracesList $ pretty <$> jpreconds j) - -- <+> hsep (pretty (jname j) : map pretty (jplaces j)) - -- <+> collapse (BracesList $ either pretty pretty <$> jpostconds j) + DeclJudgementForm j -> keyword "judgementform" <+> collapse (BracesList $ pretty <$> jpreconds j) + <+> hsep (pretty (jname j) : map pretty (jplaces j)) + <+> collapse (BracesList $ either pretty pretty <$> jpostconds j) Typecheck t ty -> keyword "typecheck" <+> pretty t <+> ":" <+> pretty ty instance Unelab ACommand where @@ -344,6 +344,9 @@ scommand = \case Go a -> during ExecElaboration $ (,) . Go <$> local (setElabMode Execution) (sact a) <*> asks globals Trace ts -> (Trace ts,) <$> asks globals DeclOp ops -> first DeclOp <$> sdeclOps ops + DeclJudgementForm j -> do + (j , gs) <- sjudgementform j + pure (DeclJudgementForm j, gs) Typecheck t ty -> do ty <- sty ty t <- stm DontLog ty t @@ -383,11 +386,6 @@ scommand = \case -- trace (unwords [getOperator op, "-[", '\'':show p, show opargs, "~>", show rhs]) (pure ()) -} - --- DeclJudgementForm j -> do --- (j , gs) <- sjudgementform j --- pure (DeclJudgementForm j, gs) - checkCompatiblePlaces :: [PLACE Concrete] -> [(Variable, ASemanticsDesc)] -> [(Variable, ASemanticsDesc)] -> @@ -432,7 +430,6 @@ then use s => c clauses ub rules to constrain the citizen the parent sent with the subject syntax. -} -{- sjudgementform :: JUDGEMENTFORM Concrete -> Elab (JUDGEMENTFORM Abstract, Globals) sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do inputs <- concat <$> traverse subjects jpreconds -- TODO: should really be the closure of this info @@ -472,7 +469,7 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do SubjectPlace rsyn sem -> do syndecls <- gets (Map.keys . syntaxCats) syn <- ssyntaxdesc syndecls rsyn - sem <- ssemanticsdesc sem + sem <- sty sem pure ((Subject syn, sem), Map.singleton name rsyn) kindify :: Map Variable CSyntaxDesc -> CAnOperator -> Elab CAnOperator @@ -480,7 +477,6 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do | Var _ x <- objDesc op , Just syn <- Map.lookup x m = pure (op { objDesc = syn}) | otherwise = throwComplaint (objDesc op) (MalformedPostOperator (theValue (opName op)) (Map.keys m)) --} sopelims0 :: Range -> (ASemanticsDesc, ACTm) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index e08c084..9a53496 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -310,14 +310,14 @@ sty t = do sem <- satom "Semantics" stm DontLog sem t -ssot :: SOT 'Concrete -> Elab ASOT -ssot ([], ty) = (:=>) <$> asks objVars <*> sty ty -ssot ((desc, x) : xs, ty) = do +ssot :: CSOT -> Elab ASOT +ssot (CSOT [] ty) = (:=>) <$> asks objVars <*> sty ty +ssot (CSOT ((desc, x) : xs) ty) = do desc <- sty desc x <- isFresh x - local (declareObjVar (x, desc)) $ ssot (xs, ty) + local (declareObjVar (x, desc)) $ ssot (CSOT xs ty) -sparamdescs :: [(Maybe Variable, ([(Raw, Variable)], Raw))] +sparamdescs :: [(Maybe Variable, CSOT)] -> Elab ([(Maybe ActorMeta, ASOT)], Decls) sparamdescs [] = ([],) <$> asks declarations sparamdescs ((mx , sot):ps) = do diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index 0c65e58..0776bd3 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -55,10 +55,6 @@ instance (Unelab a, Pretty (Unelabed a), UnelabEnv a ~ Naming) instance Pretty AProtocol where pretty (Protocol ps) = foldMap (\ x -> pretty (WithVarNames B0 <$> x) <> ". ") ps -instance Pretty CFormula where - pretty (CFormula a) = these pretty pretty (const pretty) a - pretty (CCitizen p t) = hsep [pretty p, "=>", pretty t] - instance Pretty (WithRange Warning) where pretty (WithRange r w) = (withANSI [ SetColour Background Yellow ] "Warning:" <+> pretty r) $$ go w where diff --git a/Src/Operator.hs b/Src/Operator.hs index cb46b1b..040d44f 100644 --- a/Src/Operator.hs +++ b/Src/Operator.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances, OverloadedStrings #-} module Operator where import Control.Applicative +import Data.Foldable import Concrete.Base import Concrete.Parse @@ -15,6 +16,7 @@ import Hide import Scope import Thin import Pretty +import Concrete.Pretty import Unelaboration.Monad (UnelabMeta) {- @@ -72,9 +74,18 @@ scopeSize = length . getObjVars -- - S has a SOT, binding nothing -- - T has a SOT, binding x with type S[] type family SOT (ph :: Phase) :: * -type instance SOT Concrete = ([(Raw, Variable)], Raw) +type instance SOT Concrete = CSOT type instance SOT Abstract = ASOT +data CSOT = CSOT + { sotBinders :: [(Raw, Variable)] -- sort1 \ variable1 . sort2\ variable2. ... + , sotType :: Raw + } + deriving (Show) +-- For the example above: +-- S has CSOT [] 'Semantics +-- T has CSOT [(S,x)] 'Semantics + -- TODO: conversion function to telescope -- ObjVars are in scope for the ACTm data ASOT = ObjVars :=> ACTm @@ -177,8 +188,32 @@ panoperator = do punc "-" (opname, params) <- poperator $ pBinders $ pmaybeNamed psemanticsdecl punc ":" - AnOperator obj opname params <$> psemanticsdecl + AnOperator obj opname (fmap (fmap $ uncurry CSOT) params) <$> psemanticsdecl where pmaybeNamed :: Parser a -> Parser (Maybe (ACTORVAR Concrete), a) pmaybeNamed p = pparens ((,) . Just <$> pvariable <* punc ":" <*> p) <|> (Nothing,) <$> p + +instance Pretty CAnOperator where + pretty (AnOperator obj (WithRange _ opName) paramsDesc retDesc) = + hsep [ prettyNamed obj, args, ":", pretty retDesc ] + where + args = case paramsDesc of + [] -> "-'" <> pretty opName + xs -> hsep (("-['" <> pretty opName):map prettyNamed paramsDesc) <> "]" + prettyNamed :: (Pretty a, Pretty b) => (Maybe a, b) -> Doc Annotations + prettyNamed (Nothing, b) = pretty b + prettyNamed (Just a, b) = parens $ hsep [pretty a, ":", pretty b] + +instance Pretty CSOT where + pretty (CSOT binders typ) = hsep ((map prettyBinders binders) ++ [pretty typ]) + where + prettyBinders (sort, x) = fold [pretty sort, "\\", pretty x, "."] + +{- + {- (p : ['Sig a \x.b]) -} { objDesc :: (Maybe (ACTORVAR ph), PATTERN ph) -- add ([ACTORVar ph], TERM ph)? + {- -[ 'snd -} , opName :: OPERATOR ph + {- ] -} , paramsDesc :: [(Maybe (ACTORVAR ph), SOT ph)] + {- : {x = p -'fst} b -} , retDesc :: SEMANTICSDESC ph + } +-} diff --git a/Src/Rules.hs b/Src/Rules.hs index 3dbc3f2..953e5b9 100644 --- a/Src/Rules.hs +++ b/Src/Rules.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances, OverloadedStrings #-} module Rules where import Control.Applicative @@ -16,6 +16,9 @@ import Parse import Location import Concrete.Parse +import Pretty +import Concrete.Pretty + type family FORMULA (ph :: Phase) :: * type instance FORMULA Concrete = CFormula type instance FORMULA Abstract = AFormula @@ -134,3 +137,10 @@ pjudgementform = withRange $ JudgementForm unknown <$ pkeyword KwJudgementForm < <* pspc <*> pextractmode <*> pvariable <* pspc <*> psep pspc pplace <* pspc <*> pcurlies (psep (punc ";") (Left <$> pjudgement <|> Right <$> panoperator)) + +instance Pretty (JUDGEMENT Concrete) where + pretty (Judgement _ jname fms) = hsep (pretty jname:map pretty fms) + +instance Pretty CFormula where + pretty (CFormula fm) = mergeTheseWith pretty pretty const fm + pretty (CCitizen pat tm) = hsep [pretty pat, "=>", pretty tm] diff --git a/examples/stlcRules.act b/examples/stlcRules.act index daf36c8..9e61462 100644 --- a/examples/stlcRules.act +++ b/examples/stlcRules.act @@ -65,7 +65,7 @@ judgementform rule {} type 'Nat => 'Nat - {'Nat : 'Type - 'Value ~> 'Natural} + {'Nat - 'Value ~> 'Natural} rule @@ -73,7 +73,7 @@ rule ------------------------ type ['Arr S T] => ['Arr S T] -- Global assumption: 'Semantics comes with Pi builtin - {['Arr S T] : 'Type - 'Value ~> ['Pi (S - 'Value) \_. (T - 'Value)]} + {['Arr S T] - 'Value ~> ['Pi (S - 'Value) \_. (T - 'Value)]} -- Invariant: the subject in a premise is always something with a name -- payoff - the name BECOMES the name of the citizen From 12c57fe17bab591856959b313575c6905b8e37cb Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 21 Mar 2023 14:42:26 +0000 Subject: [PATCH 69/89] [ bug ] alarm-causing test case --- test/type-projection.act | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 test/type-projection.act diff --git a/test/type-projection.act b/test/type-projection.act new file mode 100644 index 0000000..455bf3c --- /dev/null +++ b/test/type-projection.act @@ -0,0 +1,7 @@ +operator { (x : a) - 'typeOf : 'Semantics } + +x : a - 'typeOf ~> a + +syntax { 'Bool = ['Enum ['T 'F]] } + +exec 'Bool?b. PRINTF "%n" (b - 'typeOf). \ No newline at end of file From 40fe9c74f009512078412c911459512e69daee1f Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 21 Mar 2023 14:52:12 +0000 Subject: [PATCH 70/89] [ doc ] matchObjType --- Src/Elaboration.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 9a53496..17670f3 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -480,11 +480,11 @@ sop (Cons rp (At ra a) ps) = do pure (op, es) sop ro = throwComplaint ro (ExpectedAnOperator ro) --- e.g. (p : ['Sig S \x.T]) -'snd --- ['MkSig a b] : ['Sig A \y.B] --- Then we want an environment extended by: (S = A, \x.T = \y.B, p = ['MkSig a b]) -matchObjType :: Range -> (Maybe ActorMeta, Pat) -> (ASemanticsDesc, ACTm) -> Elab (HeadUpData' ActorMeta) -matchObjType r (mb , oty) (obDesc, ob) = do +matchObjType :: Range + -> (Maybe ActorMeta, Pat) -- (p : ['Sig S \x.T]) -'snd + -> (ACTm, ASemanticsDesc) -- ['MkSig a b] : ['Sig A \y.B] + -> Elab (HeadUpData' ActorMeta) -- environment extended by: (S = A, \x.T = \y.B, p = ['MkSig a b]) +matchObjType r (mb , oty) (ob, obDesc) = do dat <- asks headUpData let hnf = headUp dat env <- case snd $ match hnf initMatching (Problem B0 oty obDesc) of @@ -503,7 +503,7 @@ itm usage (Var r v) = do itm usage (Op r rob rop) = do (obDesc, ob) <- itm usage rob (AnOperator{..}, rps) <- sop rop - dat <- matchObjType r objDesc (obDesc, ob) + dat <- matchObjType r objDesc (ob, obDesc) local (setHeadUpData dat) $ do (desc, ps) <- itms r (getOperator opName) usage paramsDesc rps retDesc pure (desc, ob -% (getOperator opName, ps)) From 4ab3a404555b2df45947a75c63c705cc2f1e08d6 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 21 Mar 2023 14:54:10 +0000 Subject: [PATCH 71/89] [ TODO ] type annotations for operator objects --- Src/Elaboration.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 17670f3..ac34168 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -506,7 +506,7 @@ itm usage (Op r rob rop) = do dat <- matchObjType r objDesc (ob, obDesc) local (setHeadUpData dat) $ do (desc, ps) <- itms r (getOperator opName) usage paramsDesc rps retDesc - pure (desc, ob -% (getOperator opName, ps)) + pure (desc, ob {- TODO: store obDesc too -} -% (getOperator opName, ps)) -- TODO?: annotated terms? itm _ t = throwComplaint t $ DontKnowHowToInferDesc t From f5fea2da02623a74951398ccb4a0de1b4c5ec561 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 21 Mar 2023 15:21:52 +0000 Subject: [PATCH 72/89] [ breaking ] insist on binding the obj name in op decl --- Src/Command.hs | 17 +++++++---------- Src/Elaboration.hs | 29 +++++++++++++---------------- Src/Elaboration/Monad.hs | 4 ++-- Src/Operator.hs | 20 +++++++++----------- 4 files changed, 31 insertions(+), 39 deletions(-) diff --git a/Src/Command.hs b/Src/Command.hs index d648ae0..fa2f18e 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -279,18 +279,15 @@ sdeclOps [] = ([],) <$> asks globals -- ( pZ : {m = 'Zero} p) -- ('Nat\m. {m}p\ih. pS : {m = ['Succ m]} p) -- ] : {m = n} p -sdeclOps ((AnOperator (objName, objDescPat) (WithRange r opname) paramDescs retDesc) : ops) = do +sdeclOps ((AnOperator (objBinder, objDescPat) (WithRange r opname) paramDescs retDesc) : ops) = do opname <- do ctxt <- ask when (Map.member opname (operators ctxt)) $ throwComplaint r (AlreadyDeclaredOperator opname) pure (Operator opname) syndecls <- gets (Map.keys . syntaxCats) - (objName, objBinder) <- case objName of - Nothing -> pure (Nothing, Unused) - Just objName -> do - objName <- isFresh objName - pure (Just (ActorMeta ACitizen objName), Used objName) + objBinder <- traverse isFresh objBinder + let objName = ActorMeta ACitizen <$> objBinder ovs <- asks objVars sem <- satom "Semantics" (descPat, ds, objDesc) <- spatSemantics0 sem objDescPat @@ -505,7 +502,7 @@ sopelims r opelimz (ty, t) ((op, args):opelims) = do -- cf. sparam - sparamSemantics :: Maybe ActorMeta + sparamSemantics :: Binder ActorMeta -> Bwd String -> Telescopic ASemanticsDesc -> RawP @@ -515,8 +512,8 @@ sopelims r opelimz (ty, t) ((op, args):opelims) = do dat <- do dat <- asks headUpData pure $ case binder of - Nothing -> dat - Just v -> + Unused -> dat + Used v -> let env = huEnv dat env' = newActorVar v (namez <>> [], t) env in dat {huEnv = env'} @@ -529,7 +526,7 @@ sopelims r opelimz (ty, t) ((op, args):opelims) = do -- cf. itms spats :: Range -> String - -> [(Maybe ActorMeta, ASOT)] + -> [(Binder ActorMeta, ASOT)] -> [CPattern] -> ASemanticsDesc -> Elab ((ASemanticsDesc, Decls), ([APattern], [ACTm])) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index ac34168..6eb84c6 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -317,18 +317,15 @@ ssot (CSOT ((desc, x) : xs) ty) = do x <- isFresh x local (declareObjVar (x, desc)) $ ssot (CSOT xs ty) -sparamdescs :: [(Maybe Variable, CSOT)] - -> Elab ([(Maybe ActorMeta, ASOT)], Decls) +sparamdescs :: [(Binder Variable, CSOT)] + -> Elab ([(Binder ActorMeta, ASOT)], Decls) sparamdescs [] = ([],) <$> asks declarations -sparamdescs ((mx , sot):ps) = do +sparamdescs ((bd , sot):ps) = do sot <- ssot sot - (mx, binder) <- case mx of - Nothing -> pure (Nothing, Unused) - Just x -> do - x <- isFresh x - pure (Just (ActorMeta ACitizen x) , Used x) + binder <- traverse isFresh bd + let bd = ActorMeta ACitizen <$> binder (ps, ds) <- local (declare binder (ActVar IsNotSubject sot)) $ sparamdescs ps - pure ((mx , sot):ps, ds) + pure ((bd , sot):ps, ds) spatSemantics0 :: ASemanticsDesc -> CPattern -> Elab (APattern, Decls, ACTm) spatSemantics0 desc p = do @@ -481,7 +478,7 @@ sop (Cons rp (At ra a) ps) = do sop ro = throwComplaint ro (ExpectedAnOperator ro) matchObjType :: Range - -> (Maybe ActorMeta, Pat) -- (p : ['Sig S \x.T]) -'snd + -> (Binder ActorMeta, Pat) -- (p : ['Sig S \x.T]) -'snd -> (ACTm, ASemanticsDesc) -- ['MkSig a b] : ['Sig A \y.B] -> Elab (HeadUpData' ActorMeta) -- environment extended by: (S = A, \x.T = \y.B, p = ['MkSig a b]) matchObjType r (mb , oty) (ob, obDesc) = do @@ -491,8 +488,8 @@ matchObjType r (mb , oty) (ob, obDesc) = do Left e -> throwComplaint r =<< InferredDescMismatch <$> withVarNames oty <*> withVarNames obDesc Right m -> pure $ matchingToEnv m (huEnv dat) env <- case mb of - Nothing -> pure env - Just v -> pure $ newActorVar v (localScope env <>> [], ob) env + Unused -> pure env + Used v -> pure $ newActorVar v (localScope env <>> [], ob) env pure dat{huEnv = env} itm :: Usage -> Raw -> Elab (ASemanticsDesc, ACTm) @@ -512,7 +509,7 @@ itm _ t = throwComplaint t $ DontKnowHowToInferDesc t itms :: Range -> String -> Usage -- Parameters types e.g. (_ : 'Nat\n. {m = n}p\ih. {m = ['Succ n]}p) - -> [(Maybe ActorMeta, ASOT)] + -> [(Binder ActorMeta, ASOT)] -- Raw parameters -> [Raw] -- Return type @@ -529,7 +526,7 @@ itms r op usage ((binder, sot):bs) (rp:rps) rdesc = do itms r op usage bs rps rdesc = throwComplaint r $ ArityMismatchInOperator op ((length bs) - (length rps)) sparam :: Usage - -> Maybe ActorMeta -- Name of parameter + -> Binder ActorMeta -- Name of parameter -> Bwd String -- Names of formal parameters of the parameter -> Telescopic ASemanticsDesc -- Type of the parameter -> Raw -- Raw term naming the actual parameters @@ -540,8 +537,8 @@ sparam usage binder namez (Stop pdesc) rp = do dat <- do dat <- asks headUpData pure $ case binder of - Nothing -> dat - Just v -> + Unused -> dat + Used v -> let env = huEnv dat env' = newActorVar v (namez <>> [], p) env in dat {huEnv = env'} diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 64a8f91..fd1acf4 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -279,11 +279,11 @@ initContext opts = Context , operators = Map.fromList [ ("app", AnOperator { opName = Operator "app" - , objDesc = (Nothing, PP (AP "Pi") + , objDesc = (Unused, PP (AP "Pi") $ PP (MP (am "S") (ones 0)) $ PP (BP (Hide "x") $ MP (am "T") (ones 1)) $ AP "") - , paramsDesc = [(Just (am "s"), ObjVars B0 :=> (am "S" $: sbstI 0))] + , paramsDesc = [(Used (am "s"), ObjVars B0 :=> (am "S" $: sbstI 0))] , retDesc = am "T" $: topSbst "x" (am "s" $: sbstI 0) }) ] diff --git a/Src/Operator.hs b/Src/Operator.hs index 040d44f..bc7d7bb 100644 --- a/Src/Operator.hs +++ b/Src/Operator.hs @@ -110,9 +110,9 @@ discharge (ObjVars oz) a = go oz (ones (length oz)) (Stop a) -- Operators data ANOPERATOR (ph :: Phase) = AnOperator - {- (p : ['Sig a \x.b]) -} { objDesc :: (Maybe (ACTORVAR ph), PATTERN ph) -- add ([ACTORVar ph], TERM ph)? + {- (p : ['Sig a \x.b]) -} { objDesc :: (Binder (ACTORVAR ph), PATTERN ph) -- add ([ACTORVar ph], TERM ph)? {- -[ 'snd -} , opName :: OPERATOR ph - {- ] -} , paramsDesc :: [(Maybe (ACTORVAR ph), SOT ph)] + {- ] -} , paramsDesc :: [(Binder (ACTORVAR ph), SOT ph)] {- : {x = p -'fst} b -} , retDesc :: SEMANTICSDESC ph } @@ -186,27 +186,25 @@ panoperator :: Parser CAnOperator panoperator = do obj <- pmaybeNamed ppat punc "-" - (opname, params) <- poperator $ pBinders $ pmaybeNamed psemanticsdecl + (opname, params) <- poperator $ pBinders (pmaybeNamed psemanticsdecl) punc ":" AnOperator obj opname (fmap (fmap $ uncurry CSOT) params) <$> psemanticsdecl where - pmaybeNamed :: Parser a -> Parser (Maybe (ACTORVAR Concrete), a) - pmaybeNamed p = pparens ((,) . Just <$> pvariable <* punc ":" <*> p) - <|> (Nothing,) <$> p + pmaybeNamed :: Parser a -> Parser (Binder (ACTORVAR Concrete), a) + pmaybeNamed p = pparens ((,) <$> pbinder <* punc ":" <*> p) instance Pretty CAnOperator where pretty (AnOperator obj (WithRange _ opName) paramsDesc retDesc) = - hsep [ prettyNamed obj, args, ":", pretty retDesc ] + hsep [ prettyNamed obj , args, ":", pretty retDesc ] where args = case paramsDesc of [] -> "-'" <> pretty opName xs -> hsep (("-['" <> pretty opName):map prettyNamed paramsDesc) <> "]" - prettyNamed :: (Pretty a, Pretty b) => (Maybe a, b) -> Doc Annotations - prettyNamed (Nothing, b) = pretty b - prettyNamed (Just a, b) = parens $ hsep [pretty a, ":", pretty b] + prettyNamed :: (Pretty a, Pretty b) => (Binder a, b) -> Doc Annotations + prettyNamed (a, b) = parens $ hsep [pretty a, ":", pretty b] instance Pretty CSOT where - pretty (CSOT binders typ) = hsep ((map prettyBinders binders) ++ [pretty typ]) + pretty (CSOT binders typ) = hsep (map prettyBinders binders ++ [pretty typ]) where prettyBinders (sort, x) = fold [pretty sort, "\\", pretty x, "."] From 570ec1e1948609b942f8851569cb4d387fc9ebd0 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 21 Mar 2023 15:23:01 +0000 Subject: [PATCH 73/89] [ cleanup ] unused imports --- Src/Elaboration.hs | 3 +-- Src/Elaboration/Monad.hs | 3 +-- Src/Elaboration/Pretty.hs | 4 +--- Src/Machine/Base.hs | 4 +--- Src/Operator.hs | 2 +- Src/Pattern/Coverage.hs | 6 +++--- Src/Rules.hs | 1 - Src/Term/Display.hs | 1 - Src/Unelaboration.hs | 2 -- 9 files changed, 8 insertions(+), 18 deletions(-) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 6eb84c6..76308e9 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -29,7 +29,6 @@ import Machine.Matching import Elaboration.Monad import Term.Base -import qualified Term.Base as Term import Term.Substitution import Pattern as P hiding (match) import Location @@ -39,7 +38,7 @@ import Control.Applicative ((<|>)) import Operator import Operator.Eval import Semantics -import Debug.Trace (traceShow, traceShowId, trace) +-- import Debug.Trace (traceShow, traceShowId, trace) import Data.Bifunctor (bimap) import GHC.Stack.Types (HasCallStack) diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index fd1acf4..9b1e291 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -16,7 +16,7 @@ import Actor import Bwd import Concrete.Base import Location (HasGetRange(..), Range, WithRange (..)) -import Syntax (SyntaxCat, SyntaxDesc, VSyntaxDesc, SyntaxTable) +import Syntax (SyntaxCat, SyntaxDesc, SyntaxTable) import Thin import Term.Base import Utils @@ -29,7 +29,6 @@ import Operator.Eval import Options import Semantics import Data.Void (absurd) -import Data.Bifunctor (bimap) ------------------------------------------------------------------------------ -- Elaboration Monad diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index 0776bd3..a1267ba 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -3,7 +3,6 @@ module Elaboration.Pretty where import Data.Foldable -import Data.These import ANSI hiding (withANSI) import Actor (ActorMeta'(..), ActorMeta, Channel(..), Stack(..), AProtocol) @@ -12,10 +11,9 @@ import Concrete.Pretty() import Elaboration.Monad import Location import Pretty -import Unelaboration.Monad (unsafeEvalUnelab, unelab, initNaming, Unelab, Unelabed, UnelabEnv, Naming) +import Unelaboration.Monad (unsafeEvalUnelab, unelab, Unelab, Unelabed, UnelabEnv, Naming) import Unelaboration () import Data.List.NonEmpty (NonEmpty((:|))) -import Rules import Syntax () import Thin import Bwd (Bwd (..)) diff --git a/Src/Machine/Base.hs b/Src/Machine/Base.hs index 85df661..16d9dbe 100644 --- a/Src/Machine/Base.hs +++ b/Src/Machine/Base.hs @@ -20,12 +20,10 @@ import Term import qualified Term.Substitution as Substitution import Thin import Concrete.Base -import Syntax (SyntaxDesc) - import Data.Bifunctor (Bifunctor(first)) import Machine.Matching -import Debug.Trace (trace, traceShow) +import Debug.Trace (trace) import Display (unsafeDocDisplay) import ANSI hiding (withANSI) import Pretty diff --git a/Src/Operator.hs b/Src/Operator.hs index bc7d7bb..6dc51cb 100644 --- a/Src/Operator.hs +++ b/Src/Operator.hs @@ -16,7 +16,7 @@ import Hide import Scope import Thin import Pretty -import Concrete.Pretty +import Concrete.Pretty() import Unelaboration.Monad (UnelabMeta) {- diff --git a/Src/Pattern/Coverage.hs b/Src/Pattern/Coverage.hs index b1e2cdf..4b1be3a 100644 --- a/Src/Pattern/Coverage.hs +++ b/Src/Pattern/Coverage.hs @@ -16,7 +16,7 @@ import Data.List (partition) import Data.List.NonEmpty (NonEmpty ((:|)), fromList, toList) import Data.Maybe (fromJust, mapMaybe) -import Concrete.Base (RawP(..), Binder (..), Variable (..), ASyntaxDesc, ASemanticsDesc) +import Concrete.Base (RawP(..), Binder (..), Variable (..), ASemanticsDesc) import Location (unknown) import Pattern (Pat'(..)) import Scope (Scope(..)) @@ -312,7 +312,7 @@ missing dat table desc = fmap (`evalState` names) (start desc) where in fromList (concatMap toList (enums ++ tagged)) go (VWildcard _)= (pure $ UnderscoreP unknown) :| [] go (VSyntaxCat _ _) = (VarP unknown . Variable unknown <$> freshName) :| [] -{- TODO: fill in, neutral case might be impossible - go (VNeutral _) = _ +{- TODO: fill in, neutral case might be impossible + go (VNeutral _) = _ go (VUniverse _) = (pure $ AtP unknown "Semantics") :| [] go (VPi _ _) = _ -} diff --git a/Src/Rules.hs b/Src/Rules.hs index 953e5b9..dfa584e 100644 --- a/Src/Rules.hs +++ b/Src/Rules.hs @@ -17,7 +17,6 @@ import Location import Concrete.Parse import Pretty -import Concrete.Pretty type family FORMULA (ph :: Phase) :: * type instance FORMULA Concrete = CFormula diff --git a/Src/Term/Display.hs b/Src/Term/Display.hs index 527a6aa..90b19d8 100644 --- a/Src/Term/Display.hs +++ b/Src/Term/Display.hs @@ -6,7 +6,6 @@ import Display import Term import Thin import Unelaboration.Monad -import Unelaboration instance (Show m, UnelabMeta m) => Display (Tm m) where type DisplayEnv (Tm m) = Naming diff --git a/Src/Unelaboration.hs b/Src/Unelaboration.hs index 01f5e32..83139eb 100644 --- a/Src/Unelaboration.hs +++ b/Src/Unelaboration.hs @@ -9,8 +9,6 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Void -import GHC.Stack - import Actor import Bwd import Concrete.Base From 64dab280356bcf8bb5c7fa0c3ef703e9352aab41 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 21 Mar 2023 16:26:04 +0000 Subject: [PATCH 74/89] [ broken ] more uniform operator declaration --- Src/Command.hs | 30 +++++++++++++++--------------- Src/Concrete/Base.hs | 2 ++ Src/Elaboration/Monad.hs | 2 +- Src/Operator.hs | 12 ++++++++---- Src/Rules.hs | 25 +++++++++++++++---------- Src/Syntax.hs | 11 ++++++++++- examples/stlcRules.act | 2 ++ 7 files changed, 53 insertions(+), 31 deletions(-) diff --git a/Src/Command.hs b/Src/Command.hs index fa2f18e..137307c 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -38,7 +38,6 @@ import Parse import Pretty import Rules import Syntax -import Info import Term.Base import Unelaboration.Monad (Unelab(..), Naming, subunelab, withEnv) import Unelaboration (initDAEnv, declareChannel) @@ -48,16 +47,11 @@ import Utils import Data.Char (isSpace) import qualified Data.Set as Set import Operator -import Elaboration.Monad (clock) import Thin import Operator.Eval (HeadUpData' (..)) import Hide (Hide(..)) import Scope (Scope(..)) -type family SYNTAXCAT (ph :: Phase) :: * -type instance SYNTAXCAT Concrete = WithRange SyntaxCat -type instance SYNTAXCAT Abstract = SyntaxCat - type family DEFNPROTOCOL (ph :: Phase) :: * type instance DEFNPROTOCOL Concrete = () type instance DEFNPROTOCOL Abstract = AProtocol @@ -134,9 +128,10 @@ instance Pretty CStatement where instance Pretty (PLACE Concrete) where pretty (v, CitizenPlace) = pretty v - pretty (v, SubjectPlace syntaxdesc semanticsdesc) = - parens $ hsep $ [ pretty v, ":", pretty syntaxdesc ] - ++ (("=>" <+> pretty semanticsdesc) <$ guard (syntaxdesc /= semanticsdesc)) + pretty (v, SubjectPlace (WithRange _ syntaxcat) semanticsdesc) = + parens $ hsep $ [ pretty v, ":", pretty syntaxcat ] + ++ (("=>" <+> pretty semanticsdesc) + <$ guard (At unknown syntaxcat /= semanticsdesc)) instance Pretty CCommand where pretty = let prettyCds cds = collapse (BracesList $ pretty <$> cds) in \case @@ -463,17 +458,22 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do (Nothing, Just osem) -> pure ((Output, osem), Map.empty) _ -> error "Impossible in citizenJudgement" - SubjectPlace rsyn sem -> do + SubjectPlace (WithRange r rsyn) sem -> do syndecls <- gets (Map.keys . syntaxCats) - syn <- ssyntaxdesc syndecls rsyn + unless (rsyn `elem` syndecls) $ + throwComplaint r undefined + syn <- satom rsyn sem <- sty sem pure ((Subject syn, sem), Map.singleton name rsyn) - kindify :: Map Variable CSyntaxDesc -> CAnOperator -> Elab CAnOperator + kindify :: Map Variable SyntaxCat -> CAnOperator -> Elab CAnOperator kindify m op - | Var _ x <- objDesc op - , Just syn <- Map.lookup x m = pure (op { objDesc = syn}) - | otherwise = throwComplaint (objDesc op) (MalformedPostOperator (theValue (opName op)) (Map.keys m)) + | (Used x, pat) <- objDesc op + , Just syn <- Map.lookup x m + = -- check pat is compatible with syn + pure (op { objDesc = (Used x, AtP (getRange x) syn)}) + | otherwise = throwComplaint (snd $ objDesc op) + $ MalformedPostOperator (theValue (opName op)) (Map.keys m) sopelims0 :: Range -> (ASemanticsDesc, ACTm) diff --git a/Src/Concrete/Base.hs b/Src/Concrete/Base.hs index 0744db8..27b315e 100644 --- a/Src/Concrete/Base.hs +++ b/Src/Concrete/Base.hs @@ -147,6 +147,8 @@ isSubjectMode :: Mode a -> Bool isSubjectMode (Subject _) = True isSubjectMode _ = False +type family SYNTAXCAT (ph :: Phase) :: * + type family SYNTAXDESC (ph :: Phase) :: * type instance SYNTAXDESC Concrete = Raw type CSyntaxDesc = SYNTAXDESC Concrete diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 9b1e291..3c744be 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -122,7 +122,7 @@ infoExpand dat table s = case Semantics.expand table dat s of Just (VWildcard _) -> Unknown Just a -> Known a -satom :: String -> Elab ACTm +satom :: String -> Elab (CdB (Tm m)) satom at = atom at <$> asks (scopeSize . objVars) fromInfo :: Range -> Info ASemanticsDesc -> Elab ASemanticsDesc diff --git a/Src/Operator.hs b/Src/Operator.hs index 6dc51cb..f8f71a5 100644 --- a/Src/Operator.hs +++ b/Src/Operator.hs @@ -184,14 +184,18 @@ pBinders p = fmap . (,) <$> many ((,) <$> pTM <* punc "\\" <*> pvariable <* pspc panoperator :: Parser CAnOperator panoperator = do - obj <- pmaybeNamed ppat + obj <- pmaybeNamed ppat (withRange $ pure $ UnderscoreP unknown) punc "-" - (opname, params) <- poperator $ pBinders (pmaybeNamed psemanticsdecl) + (opname, params) <- poperator $ pBinders (pmaybeNamed psemanticsdecl pfail) punc ":" AnOperator obj opname (fmap (fmap $ uncurry CSOT) params) <$> psemanticsdecl where - pmaybeNamed :: Parser a -> Parser (Binder (ACTORVAR Concrete), a) - pmaybeNamed p = pparens ((,) <$> pbinder <* punc ":" <*> p) + pmaybeNamed :: Parser a -- if binder + -> Parser a -- if no binder + -> Parser (Binder (ACTORVAR Concrete), a) + pmaybeNamed p q + = pparens ((,) <$> pbinder <* punc ":" <*> p) + <|> ((,) . Used <$> pvariable <*> q) instance Pretty CAnOperator where pretty (AnOperator obj (WithRange _ opName) paramsDesc retDesc) = diff --git a/Src/Rules.hs b/Src/Rules.hs index dfa584e..d2a00e6 100644 --- a/Src/Rules.hs +++ b/Src/Rules.hs @@ -15,7 +15,7 @@ import Term.Base import Parse import Location import Concrete.Parse - +import Syntax (psyntaxcat) import Pretty type family FORMULA (ph :: Phase) :: * @@ -59,11 +59,13 @@ type CPlace = PLACE Concrete data PLACEKIND (ph :: Phase) = CitizenPlace - | SubjectPlace (SYNTAXDESC ph) (SEMANTICSDESC ph) + | SubjectPlace (SYNTAXCAT ph) (SEMANTICSDESC ph) -mkSubjectPlace :: SYNTAXDESC Concrete -> Maybe (SEMANTICSDESC Concrete) +mkSubjectPlace :: SYNTAXCAT Concrete -> Maybe (SEMANTICSDESC Concrete) -> PLACEKIND Concrete -mkSubjectPlace syn = SubjectPlace syn . fromMaybe syn +mkSubjectPlace syn + = SubjectPlace syn + . fromMaybe (At (getRange syn) (theValue syn)) data CJudgementForm = JudgementForm { jrange :: Range @@ -103,7 +105,7 @@ deriving instance Show (RULE ph) deriving instance - ( Show (SYNTAXDESC ph) + ( Show (SYNTAXCAT ph) , Show (SEMANTICSDESC ph)) => Show (PLACEKIND ph) @@ -129,13 +131,16 @@ prule = RULE <$ pkeyword KwRule <* pspc <*> pcurlies (psep (punc ";") ppremise) pplace :: Parser (PLACE Concrete) pplace = (,CitizenPlace) <$> pvariable - <|> pparens ((,) <$> pvariable <* punc ":" <*> (mkSubjectPlace <$> psyntaxdecl <*> optional (id <$ punc "=>" <*> pTM))) + <|> pparens ((,) <$> pvariable <* punc ":" + <*> (mkSubjectPlace <$> psyntaxcat <*> optional (id <$ punc "=>" <*> pTM))) pjudgementform :: Parser CJudgementForm -pjudgementform = withRange $ JudgementForm unknown <$ pkeyword KwJudgementForm <* pspc <*> pcurlies (psep (punc ";") pjudgement) - <* pspc <*> pextractmode <*> pvariable - <* pspc <*> psep pspc pplace - <* pspc <*> pcurlies (psep (punc ";") (Left <$> pjudgement <|> Right <$> panoperator)) +pjudgementform = withRange $ JudgementForm unknown + <$ pkeyword KwJudgementForm + <* pspc <*> pcurlies (psep (punc ";") pjudgement) + <* pspc <*> pextractmode <*> pvariable + <* pspc <*> psep pspc pplace + <* pspc <*> pcurlies (psep (punc ";") (Left <$> pjudgement <|> Right <$> panoperator)) instance Pretty (JUDGEMENT Concrete) where pretty (Judgement _ jname fms) = hsep (pretty jname:map pretty fms) diff --git a/Src/Syntax.hs b/Src/Syntax.hs index 5f6ebd6..537a7ef 100644 --- a/Src/Syntax.hs +++ b/Src/Syntax.hs @@ -8,11 +8,20 @@ import Data.Map (Map) import qualified Data.Map as Map import Bwd -import Concrete.Base (SYNTAXDESC, Phase(..), ASyntaxDesc) +import Concrete.Base (SYNTAXCAT, SYNTAXDESC, Phase(..), ASyntaxDesc) import Thin (CdB(..), DB(..), weak, scope, lsb) import Term hiding (contract, expand) +import Location (WithRange) +import Parse (Parser, pwithRange, patom) type SyntaxCat = String + +type instance SYNTAXCAT Concrete = WithRange SyntaxCat +type instance SYNTAXCAT Abstract = SyntaxCat + +psyntaxcat :: Parser (SYNTAXCAT Concrete) +psyntaxcat = pwithRange patom + type SyntaxDesc = CdB (Tm Void) type SyntaxTable = Map SyntaxCat SyntaxDesc diff --git a/examples/stlcRules.act b/examples/stlcRules.act index 9e61462..295ceae 100644 --- a/examples/stlcRules.act +++ b/examples/stlcRules.act @@ -47,6 +47,8 @@ judgementform type (T : 'Type) -- no '=> B' means the citizen version is the same {T - 'Value : 'Semantics} +-- exec 'Wildcard?a. PRINTF "%n" a -'Value. + judgementform {type T} check T (t : 'Check => T - 'Value) From 7f84d11d22be75b1309c1cc8aa4381a8dbd0fe3b Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 21 Mar 2023 17:14:37 +0000 Subject: [PATCH 75/89] [ fix ] checking judgement form telescopically Also fixing Send elaboration --- Src/Command.hs | 47 +++++++++++++++++++++++++++++------------- Src/Elaboration.hs | 6 +++++- examples/stlcRules.act | 9 ++++++++ 3 files changed, 47 insertions(+), 15 deletions(-) diff --git a/Src/Command.hs b/Src/Command.hs index 137307c..d396f32 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -16,7 +16,7 @@ import Data.Maybe (fromMaybe, catMaybes) import Data.Traversable (for) import Data.These import Data.Either -import Data.Foldable (fold, asum) +import Data.Foldable (asum) import Actor import Actor.Display () @@ -422,18 +422,19 @@ then use s => c clauses ub rules to constrain the citizen the parent sent with the subject syntax. -} -sjudgementform :: JUDGEMENTFORM Concrete -> Elab (JUDGEMENTFORM Abstract, Globals) +sjudgementform :: JUDGEMENTFORM Concrete + -> Elab (JUDGEMENTFORM Abstract, Globals) sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do inputs <- concat <$> traverse subjects jpreconds -- TODO: should really be the closure of this info let (outputs, operators) = partitionEithers jpostconds outputs <- concat <$> traverse subjects outputs checkCompatiblePlaces jplaces inputs outputs - (protocol, subjectKinds) <- bimap Protocol fold . unzip - <$> traverse (citizenJudgement inputs outputs) jplaces + (ps, subjectKinds, _) <- citizenJudgements Map.empty inputs outputs jplaces + let protocol = Protocol ps jname <- isFresh jname local (declare (Used jname) (AJudgement jextractmode protocol)) $ do - (operators, gs) <- sdeclOps =<< traverse (kindify subjectKinds) operators - pure ((jextractmode, jname, protocol), gs) + (operators, gs) <- sdeclOps =<< traverse (kindify subjectKinds) operators + pure ((jextractmode, jname, protocol), gs) where @@ -449,13 +450,29 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do (CFormula (These _ (Var r x)), sem) -> pure (x, sem) (x, _) -> throwComplaint r $ UnexpectedNonSubject x - citizenJudgement :: [(Variable, ASemanticsDesc)] -> [(Variable, ASemanticsDesc)] - -> CPlace -> Elab (PROTOCOLENTRY Abstract, Map Variable CSyntaxDesc) - citizenJudgement inputs outputs (name, place) = case place of - CitizenPlace -> + citizenJudgements :: Map Variable SyntaxCat + -> [(Variable, ASemanticsDesc)] + -> [(Variable, ASemanticsDesc)] + -> [CPlace] + -> Elab ( [AProtocolEntry] + , Map Variable SyntaxCat + , Decls ) + citizenJudgements mp inputs outputs [] = ([], mp,) <$> asks declarations + citizenJudgements mp inputs outputs ((name, place) : plcs) = case place of + CitizenPlace -> do + bd <- Used <$> isFresh name + th <- asks (ones . scopeSize . objVars) case (lookup name inputs, lookup name outputs) of - (Just isem, Nothing) -> pure ((Input, isem), Map.empty) - (Nothing, Just osem) -> pure ((Output, osem), Map.empty) + (Just isem, Nothing) -> do + (_, asot) <- thickenedASOT (getRange name) th isem + (ps, mp, ds) <- local (declare bd (ActVar IsNotSubject asot)) $ + citizenJudgements mp inputs outputs plcs + pure ((Input, isem) : ps, mp, ds) + (Nothing, Just osem) -> do + (_, asot) <- thickenedASOT (getRange name) th osem + (ps, mp, ds) <- local (declare bd (ActVar IsNotSubject asot)) $ + citizenJudgements mp inputs outputs plcs + pure ((Output, osem) : ps, mp, ds) _ -> error "Impossible in citizenJudgement" SubjectPlace (WithRange r rsyn) sem -> do @@ -463,8 +480,10 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do unless (rsyn `elem` syndecls) $ throwComplaint r undefined syn <- satom rsyn - sem <- sty sem - pure ((Subject syn, sem), Map.singleton name rsyn) + mp <- pure (Map.insert name rsyn mp) + (ps, mp, ds) <- citizenJudgements mp inputs outputs plcs + sem <- local (setDecls ds) $ sty sem + pure ((Subject syn, sem) : ps, mp, ds) kindify :: Map Variable SyntaxCat -> CAnOperator -> Elab CAnOperator kindify m op diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 76308e9..7072f89 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -1036,7 +1036,11 @@ sact = \case ch <- isChannel ch -- Check the channel is in sending mode, & step it (m, desc) <- steppingChannel r ch $ \ dir -> \case - (m, desc) : p | whatComm m dir == SEND -> pure ((m, desc), p) + (m, desc) : p | whatComm m dir == SEND -> do + desc <- pure $ case m of + Subject desc -> asSemantics desc + _ -> desc + pure ((m, desc), p) _ -> throwComplaint r (InvalidSend ch tm) (usage, gd) <- do diff --git a/examples/stlcRules.act b/examples/stlcRules.act index 295ceae..bebc5f6 100644 --- a/examples/stlcRules.act +++ b/examples/stlcRules.act @@ -59,6 +59,15 @@ judgementform synth (e : 'Synth => S - 'Value) S {type S} +exec 'Synth?e. + PRINTF "Spawning synth". + synth@p. + p!e. + PRINTF "About to get stuck". + p?S. + PRINTF "%r" S. + +{- -- Open question in the above: will it always be the subject that's fed to an operator? -- Note: the "T - 'Value" is in 'Semantics and that T is the citizen, not the subject From cae711646b520f31f014e862aeb7fc66f054d946 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 21 Mar 2023 17:52:00 +0000 Subject: [PATCH 76/89] [ broken ] subject should become citizen after sub send --- Src/Command.hs | 20 ++++++++++---------- Src/Rules.hs | 23 ++++++++++++++++------- examples/stlcRules.act | 4 ++-- test/judgement-operator.act | 11 +++++++++++ test/operator-elab-fail.act | 2 +- 5 files changed, 40 insertions(+), 20 deletions(-) create mode 100644 test/judgement-operator.act diff --git a/Src/Command.hs b/Src/Command.hs index d396f32..15143c1 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -128,7 +128,7 @@ instance Pretty CStatement where instance Pretty (PLACE Concrete) where pretty (v, CitizenPlace) = pretty v - pretty (v, SubjectPlace (WithRange _ syntaxcat) semanticsdesc) = + pretty (v, SubjectPlace (WithRange _ syntaxcat) (semanticsdesc, _)) = parens $ hsep $ [ pretty v, ":", pretty syntaxcat ] ++ (("=>" <+> pretty semanticsdesc) <$ guard (At unknown syntaxcat /= semanticsdesc)) @@ -450,12 +450,12 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do (CFormula (These _ (Var r x)), sem) -> pure (x, sem) (x, _) -> throwComplaint r $ UnexpectedNonSubject x - citizenJudgements :: Map Variable SyntaxCat + citizenJudgements :: Map Variable RawP -> [(Variable, ASemanticsDesc)] -> [(Variable, ASemanticsDesc)] -> [CPlace] -> Elab ( [AProtocolEntry] - , Map Variable SyntaxCat + , Map Variable RawP , Decls ) citizenJudgements mp inputs outputs [] = ([], mp,) <$> asks declarations citizenJudgements mp inputs outputs ((name, place) : plcs) = case place of @@ -475,22 +475,22 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do pure ((Output, osem) : ps, mp, ds) _ -> error "Impossible in citizenJudgement" - SubjectPlace (WithRange r rsyn) sem -> do + SubjectPlace (WithRange r rsyn) (sem, msempat) -> do syndecls <- gets (Map.keys . syntaxCats) unless (rsyn `elem` syndecls) $ throwComplaint r undefined syn <- satom rsyn - mp <- pure (Map.insert name rsyn mp) + mp <- pure (Map.insert name (fromMaybe (UnderscoreP unknown) msempat) mp) (ps, mp, ds) <- citizenJudgements mp inputs outputs plcs sem <- local (setDecls ds) $ sty sem pure ((Subject syn, sem) : ps, mp, ds) - kindify :: Map Variable SyntaxCat -> CAnOperator -> Elab CAnOperator + kindify :: Map Variable RawP -> CAnOperator -> Elab CAnOperator kindify m op - | (Used x, pat) <- objDesc op - , Just syn <- Map.lookup x m - = -- check pat is compatible with syn - pure (op { objDesc = (Used x, AtP (getRange x) syn)}) + | (Used x, _) <- objDesc op + , Just sempat <- Map.lookup x m + = -- check pat is compatible with sempat + pure (op { objDesc = (Used x, sempat) }) | otherwise = throwComplaint (snd $ objDesc op) $ MalformedPostOperator (theValue (opName op)) (Map.keys m) diff --git a/Src/Rules.hs b/Src/Rules.hs index d2a00e6..bfca561 100644 --- a/Src/Rules.hs +++ b/Src/Rules.hs @@ -59,13 +59,15 @@ type CPlace = PLACE Concrete data PLACEKIND (ph :: Phase) = CitizenPlace - | SubjectPlace (SYNTAXCAT ph) (SEMANTICSDESC ph) + | SubjectPlace (SYNTAXCAT ph) (SEMANTICSDESC ph, Maybe (PATTERN ph)) -mkSubjectPlace :: SYNTAXCAT Concrete -> Maybe (SEMANTICSDESC Concrete) +mkSubjectPlace :: SYNTAXCAT Concrete + -> Maybe (SEMANTICSDESC Concrete, Maybe (PATTERN Concrete)) -> PLACEKIND Concrete mkSubjectPlace syn = SubjectPlace syn - . fromMaybe (At (getRange syn) (theValue syn)) + . fromMaybe ( At (getRange syn) (theValue syn) + , Just (AtP (getRange syn) (theValue syn))) data CJudgementForm = JudgementForm { jrange :: Range @@ -106,7 +108,8 @@ deriving instance deriving instance ( Show (SYNTAXCAT ph) - , Show (SEMANTICSDESC ph)) => + , Show (SEMANTICSDESC ph) + , Show (PATTERN ph)) => Show (PLACEKIND ph) pformula :: Parser CFormula @@ -129,10 +132,16 @@ prule :: Parser (RULE Concrete) prule = RULE <$ pkeyword KwRule <* pspc <*> pcurlies (psep (punc ";") ppremise) <* pspc <*> pjudgement <* pspc <*> pcurlies (psep (punc ";") pdefnop) +psubjectSem :: Parser (SEMANTICSDESC Concrete, Maybe (PATTERN Concrete)) +psubjectSem = pthese pTM ppat >>= \case + This sem -> pure (sem, Nothing) + These sem pat -> pure (sem, Just pat) + That pat -> pfail + pplace :: Parser (PLACE Concrete) -pplace = (,CitizenPlace) <$> pvariable - <|> pparens ((,) <$> pvariable <* punc ":" - <*> (mkSubjectPlace <$> psyntaxcat <*> optional (id <$ punc "=>" <*> pTM))) +pplace = (,CitizenPlace) <$> pvariable <|> pparens ((,) <$> pvariable <* punc ":" + <*> (mkSubjectPlace <$> psyntaxcat + <*> optional (id <$ punc "=>" <*> psubjectSem))) pjudgementform :: Parser CJudgementForm pjudgementform = withRange $ JudgementForm unknown diff --git a/examples/stlcRules.act b/examples/stlcRules.act index bebc5f6..75694f6 100644 --- a/examples/stlcRules.act +++ b/examples/stlcRules.act @@ -47,7 +47,7 @@ judgementform type (T : 'Type) -- no '=> B' means the citizen version is the same {T - 'Value : 'Semantics} --- exec 'Wildcard?a. PRINTF "%n" a -'Value. +exec 'Type?a. (a ~ 'Nat | PRINTF "%n" a -'Value.) judgementform {type T} @@ -57,7 +57,7 @@ judgementform judgementform {} synth (e : 'Synth => S - 'Value) S - {type S} + {type S; e -'Quote : 'Check} exec 'Synth?e. PRINTF "Spawning synth". diff --git a/test/judgement-operator.act b/test/judgement-operator.act new file mode 100644 index 0000000..152bd45 --- /dev/null +++ b/test/judgement-operator.act @@ -0,0 +1,11 @@ +syntax { 'Bool = ['Enum ['T 'F]] } +syntax { 'Type = ['EnumOrTag ['Nat] [['Prod 'Type 'Type]]] } + +judgementform + {} + type (T : 'Type => 'Semantics) + { T - 'inhabitant : T + ; T -['isInhabitant (_ : T)] : 'Bool + } + +exec 'Type?T. PRINTF "%n" T - 'inhabitant. diff --git a/test/operator-elab-fail.act b/test/operator-elab-fail.act index d62ee84..937eb89 100644 --- a/test/operator-elab-fail.act +++ b/test/operator-elab-fail.act @@ -1,6 +1,6 @@ syntax { 'Bool = ['Enum ['False 'True]] } -operator { 'Bool - ['if 'Wildcard 'Wildcard] : 'Wildcard } +operator { (_ : 'Bool) - ['if 'Wildcard 'Wildcard] : 'Wildcard } 'True : 'Bool - ['if l r] ~> l 'False : 'Bool - ['if l m r] ~> r From a564d57646b17cd50bf390b321b8b29162096ac0 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Thu, 23 Mar 2023 16:13:03 +0000 Subject: [PATCH 77/89] [ test ] update test cases --- Src/Command.hs | 6 +++--- Src/Concrete/Base.hs | 12 ++++++++++-- Src/Concrete/Parse.hs | 2 +- Src/Concrete/Pretty.hs | 2 +- Src/Elaboration.hs | 12 ++++++------ Src/Elaboration/Monad.hs | 10 +++++----- Src/Elaboration/Pretty.hs | 2 +- Src/LaTeX.hs | 2 +- Src/Machine/Exec.hs | 2 +- Src/Pattern/Coverage.hs | 2 +- Src/Unelaboration.hs | 4 ++-- test/define-operator.act | 10 +++++----- test/golden/judgement-operator.gold | 11 +++++++++++ test/golden/malformedPostOp.gold | 6 +++--- test/golden/operator-elab-fail-2.gold | 2 +- test/golden/operator-elab-fail-4.gold | 6 +++--- test/golden/printing-open.gold | 8 ++++---- test/malformedPostOp.act | 2 +- test/operator-elab-fail-2.act | 2 +- test/operator-elab-fail-3.act | 2 +- test/operator-elab-fail-4.act | 2 +- test/operator-elab-fail.act | 2 +- test/printing-open.act | 6 ++++-- test/printing.act | 2 +- test/reduce-neutrals-2.act | 4 ++-- test/reduce-neutrals.act | 2 +- test/typecheck.act | 8 ++++---- 27 files changed, 76 insertions(+), 55 deletions(-) create mode 100644 test/golden/judgement-operator.gold diff --git a/Src/Command.hs b/Src/Command.hs index 15143c1..bbf94a8 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -491,7 +491,7 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do , Just sempat <- Map.lookup x m = -- check pat is compatible with sempat pure (op { objDesc = (Used x, sempat) }) - | otherwise = throwComplaint (snd $ objDesc op) + | otherwise = throwComplaint (fst $ objDesc op) $ MalformedPostOperator (theValue (opName op)) (Map.keys m) sopelims0 :: Range @@ -510,7 +510,7 @@ sopelims r opelimz (ty, t) ((op, args):opelims) = do -- We need to worry about freshening up names in operator -- declarations when checking definitions to avoid clashes (AnOperator (mb, opat) opName pdescs rdesc) <- freshenOp =<< soperator op - dat <- matchObjType r (mb, opat) (ty, t) + dat <- matchObjType r (mb, opat) (t, ty) let r' = getRange op <> foldMap getRange args local (setHeadUpData dat) $ do ((ty, decls), (pargs, args)) <- spats r' (getOperator opName) pdescs args rdesc @@ -531,7 +531,7 @@ sopelims r opelimz (ty, t) ((op, args):opelims) = do dat <- do dat <- asks headUpData pure $ case binder of - Unused -> dat + Unused _ -> dat Used v -> let env = huEnv dat env' = newActorVar v (namez <>> [], t) env diff --git a/Src/Concrete/Base.hs b/Src/Concrete/Base.hs index 27b315e..2ab2357 100644 --- a/Src/Concrete/Base.hs +++ b/Src/Concrete/Base.hs @@ -32,11 +32,19 @@ type Guard = Root data Binder x = Used x - | Unused + | Unused Range deriving (Show, Functor, Foldable, Traversable) +instance HasSetRange x => HasSetRange (Binder x) where + setRange r (Used x) = Used (setRange r x) + setRange r (Unused _) = Unused r + +instance HasGetRange x => HasGetRange (Binder x) where + getRange (Used x) = getRange x + getRange (Unused r) = r + mkBinder :: Variable -> Binder Variable -mkBinder (Variable r "_") = Unused +mkBinder (Variable r "_") = Unused r mkBinder v = Used v {- diff --git a/Src/Concrete/Parse.hs b/Src/Concrete/Parse.hs index 523c635..fffdd22 100644 --- a/Src/Concrete/Parse.hs +++ b/Src/Concrete/Parse.hs @@ -42,7 +42,7 @@ pvariable = do pbinder :: Parser (Binder Variable) pbinder = Used <$> pvariable - <|> Unused <$ plit "_" + <|> withRange (Unused unknown <$ plit "_") pTM :: Parser Raw pTM = withRange $ diff --git a/Src/Concrete/Pretty.hs b/Src/Concrete/Pretty.hs index f71763c..f651b96 100644 --- a/Src/Concrete/Pretty.hs +++ b/Src/Concrete/Pretty.hs @@ -19,7 +19,7 @@ instance Pretty Variable where instance Pretty x => Pretty (Binder x) where pretty (Used v) = pretty v - pretty Unused = "_" + pretty (Unused _) = "_" multiBind :: Bwd (Hide (Binder Variable)) -> Raw -> Doc Annotations multiBind xs (Lam _ (Scope x t)) = multiBind (xs :< x) t diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 7072f89..0b9d6a4 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -186,7 +186,7 @@ smacro xz (Cons r t u) = do smacro xz u smacro xz (Lam r (Scope (Hide x) sc)) = do xz <- case x of - Unused -> pure xz + Unused _ -> pure xz Used x -> do x <- isFresh x pure (xz :< x) smacro xz sc @@ -487,7 +487,7 @@ matchObjType r (mb , oty) (ob, obDesc) = do Left e -> throwComplaint r =<< InferredDescMismatch <$> withVarNames oty <*> withVarNames obDesc Right m -> pure $ matchingToEnv m (huEnv dat) env <- case mb of - Unused -> pure env + Unused _ -> pure env Used v -> pure $ newActorVar v (localScope env <>> [], ob) env pure dat{huEnv = env} @@ -536,7 +536,7 @@ sparam usage binder namez (Stop pdesc) rp = do dat <- do dat <- asks headUpData pure $ case binder of - Unused -> dat + Unused _ -> dat Used v -> let env = huEnv dat env' = newActorVar v (namez <>> [], p) env @@ -695,7 +695,7 @@ elabUnder (x, desc) ma = do error ("The IMPOSSIBLE has happened when binding " ++ show x ++ show st) x <- case x of Used x -> isFresh x - Unused -> pure "_" + Unused _ -> pure "_" (x \\) {-. (\ x -> traceShow x x) -} <$> local (declareObjVar (x, desc)) ma spats :: IsSubject -> [ASemanticsDesc] -> Restriction -> RawP -> Elab (Maybe Range, Pat, Decls, Hints) @@ -980,7 +980,7 @@ compatibleChannels r (_,ps) _ (_,qs) = throwComplaint r (ProtocolsNotDual (Proto sirrefutable :: String -> IsSubject -> RawP -> Elab (Binder String, Maybe (CScrutinee, RawP)) sirrefutable nm isSub = \case VarP _ v -> (, Nothing) . Used <$> isFresh v - UnderscoreP _ -> pure (Unused, Nothing) + UnderscoreP r -> pure (Unused r, Nothing) p -> do ctxt <- ask -- this should be a unique name & is not user-writable let r = getRange p @@ -992,7 +992,7 @@ sirrefutable nm isSub = \case pure (Used av, Just (sc, p)) checkScrutinised :: Binder String -> Elab Bool -checkScrutinised Unused = pure False +checkScrutinised (Unused _) = pure False checkScrutinised (Used nm) = do avs <- gets actvarStates b <- case Map.lookup nm avs of diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 3c744be..a0a4790 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -15,7 +15,7 @@ import Data.Maybe (fromMaybe) import Actor import Bwd import Concrete.Base -import Location (HasGetRange(..), Range, WithRange (..)) +import Location (HasGetRange(..), Range, WithRange (..), unknown) import Syntax (SyntaxCat, SyntaxDesc, SyntaxTable) import Thin import Term.Base @@ -253,7 +253,7 @@ extend :: Restriction {- gamma -} -> {- x :: -} Binder String -> Restriction {- gamma , x -} extend (Restriction ls th) (Used x) = Restriction (ls :< x) (th -? True) -extend (Restriction ls th) Unused = Restriction ls (th -? False) +extend (Restriction ls th) (Unused _) = Restriction ls (th -? False) instance Selable Restriction where ph ^? Restriction ls th = Restriction (ph ^? ls) (ph ^? th) @@ -278,7 +278,7 @@ initContext opts = Context , operators = Map.fromList [ ("app", AnOperator { opName = Operator "app" - , objDesc = (Unused, PP (AP "Pi") + , objDesc = (Unused unknown, PP (AP "Pi") $ PP (MP (am "S") (ones 0)) $ PP (BP (Hide "x") $ MP (am "T") (ones 1)) $ AP "") @@ -350,7 +350,7 @@ instance Selable Context where -} declare :: Binder String -> Kind -> Context -> Context -declare Unused k ctx = ctx +declare (Unused _) k ctx = ctx declare (Used x) k ctx = ctx { declarations = declarations ctx :< (x, k) } setDecls :: Decls -> Context -> Context @@ -394,7 +394,7 @@ setHints hs ctx = ctx { binderHints = hs } -- TODO: hints should be ASOTs addHint :: Binder String -> Info ASemanticsDesc -> Context -> Context -addHint Unused cat ctx = ctx +addHint (Unused _) cat ctx = ctx addHint (Used str) cat ctx = let hints = binderHints ctx hints' = case Map.lookup str hints of diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index a1267ba..04d5ea5 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -66,7 +66,7 @@ instance Pretty (WithRange Warning) where $ map pretty (toList pats) -- Subject analysis SentSubjectNotASubjectVar raw -> hsep ["Sent subject", pretty raw, "is not a subject variable"] - RecvSubjectNotScrutinised ch Unused -> hsep ["Ignored received subject on channel", pretty ch] + RecvSubjectNotScrutinised ch (Unused _) -> hsep ["Ignored received subject on channel", pretty ch] RecvSubjectNotScrutinised ch (Used x) -> hsep ["Received subject", pretty x,"on channel", pretty ch, "and did not scrutinise it"] PatternSubjectNotScrutinised x -> hsep ["Pattern subject", pretty x, "did not get scrutinised"] UnderscoreOnSubject -> hsep ["Subject pattern thrown away using an underscore"] diff --git a/Src/LaTeX.hs b/Src/LaTeX.hs index af3ae52..403973f 100644 --- a/Src/LaTeX.hs +++ b/Src/LaTeX.hs @@ -65,7 +65,7 @@ instance LaTeX x => LaTeX (Hide x) where instance LaTeX a => LaTeX (Binder a) where type Format (Binder a) = Format a toLaTeX d = \case - Unused -> pure "\\_" + Unused _ -> pure "\\_" Used x -> toLaTeX d x instance LaTeX Variable where diff --git a/Src/Machine/Exec.hs b/Src/Machine/Exec.hs index 0d09bbd..45d39ac 100644 --- a/Src/Machine/Exec.hs +++ b/Src/Machine/Exec.hs @@ -375,7 +375,7 @@ recv ch x p@Process { stack = B0 :<+>: fs, ..} recv ch x p@Process { stack = zf :< Sent q gd y :<+>: fs, ..} | ch == q = let env' = case x of - Unused -> env + Unused _ -> env Used x -> case x of ActorMeta ASubject v -> guardSubject v y geas $ newActorVar x y env ActorMeta ACitizen v -> newActorVar x y env diff --git a/Src/Pattern/Coverage.hs b/Src/Pattern/Coverage.hs index 4b1be3a..4d5d373 100644 --- a/Src/Pattern/Coverage.hs +++ b/Src/Pattern/Coverage.hs @@ -303,7 +303,7 @@ missing dat table desc = fmap (`evalState` names) (start desc) where qs <- start cb' pure (ConsP unknown <$> ps <*> qs) go (VNilOrCons cb cb') = go (VNil $ scope cb) <> go (VCons cb cb') - go (VBind s cb) = fmap (LamP unknown . Scope (Hide Unused)) <$> start cb + go (VBind s cb) = fmap (LamP unknown . Scope (Hide (Unused unknown))) <$> start cb go (VEnumOrTag _ ss ts) = let enums = map (\ s -> (pure $ AtP unknown s) :| []) ss tagged = ts <&> \ (s, ds) -> do diff --git a/Src/Unelaboration.hs b/Src/Unelaboration.hs index 83139eb..5efb23b 100644 --- a/Src/Unelaboration.hs +++ b/Src/Unelaboration.hs @@ -53,7 +53,7 @@ instance UnelabMeta m => Unelab (Tm m) where P Cell (s :<>: t) -> Cons unknown <$> unelab s <*> unelab t P Oper (s :<>: t) -> Op unknown <$> unelab s <*> unelab t (x := b) :. t -> Lam unknown . uncurry (Scope . Hide) <$> case b of - False -> (Unused,) <$> unelab t + False -> (Unused unknown,) <$> unelab t True -> do na <- ask let y = freshen (unhide x) na @@ -144,7 +144,7 @@ instance Forget DAEnv Naming where instance Unelab (Binder ActorMeta) where type UnelabEnv (Binder ActorMeta) = () type Unelabed (Binder ActorMeta) = RawP - unelab Unused = pure (UnderscoreP unknown) + unelab (Unused r) = pure (UnderscoreP r) unelab (Used av) = VarP unknown <$> unelab av instance Unelab Channel where diff --git a/test/define-operator.act b/test/define-operator.act index 2a3abda..3d7ff4e 100644 --- a/test/define-operator.act +++ b/test/define-operator.act @@ -3,11 +3,11 @@ syntax { 'Nat = ['EnumOrTag ['zero] [['succ 'Nat]]] } operator { (x : A) - 'id : A - ; 'Wildcard - ['myApp 'Wildcard] : 'Wildcard - ; A - ['when 'Bool] : A - ; 'Bool - ['if 'Wildcard 'Wildcard] : 'Wildcard - ; 'Nat - ['plus 'Nat] : 'Nat - ; 'Nat - ['mult 'Nat] : 'Nat + ; (f : 'Wildcard) - ['myApp (t : 'Wildcard)] : 'Wildcard + ; (a : A) - ['when (b : 'Bool)] : A + ; (b : 'Bool) - ['if (t : 'Wildcard) (e : 'Wildcard)] : 'Wildcard + ; (n : 'Nat) - ['plus (m : 'Nat)] : 'Nat + ; (n : 'Nat) - ['mult (m : 'Nat)] : 'Nat -- TODO: -- ; (p : ['Sg a \x.b]) - 'fst : a -- ; (p : ['Sg a \x.b]) - 'snd : {x=p - 'fst} b diff --git a/test/golden/judgement-operator.gold b/test/golden/judgement-operator.gold new file mode 100644 index 0000000..adde22d --- /dev/null +++ b/test/golden/judgement-operator.gold @@ -0,0 +1,11 @@ +ret > ExitFailure 1 +out > Error +out > +out > 9 | } +out > 10 | +out > 11 | exec 'Type?T. PRINTF "%n" T - 'inhabitant. +out > ^^^^^^^^^^^^^^^ +out > judgement-operator.act:11:26-41 +out > Inferred object description 'Type does not match pattern 'Semantics +out > when elaborating an exec statement +out > diff --git a/test/golden/malformedPostOp.gold b/test/golden/malformedPostOp.gold index 48c2dc7..1356f42 100644 --- a/test/golden/malformedPostOp.gold +++ b/test/golden/malformedPostOp.gold @@ -3,9 +3,9 @@ out > Error out > out > 11 | {} out > 12 | type (T : 'Type) -out > 13 | {['a 'a] - 'Value : 'Semantics} -out > ^^^^^^^ -out > malformedPostOp.act:13:3-10 +out > 13 | {S - 'Value : 'Semantics} +out > ^ +out > malformedPostOp.act:13:3-4 out > Malformed operator Value; expected it to act on the subject T out > when elaborating the judgement form type out > diff --git a/test/golden/operator-elab-fail-2.gold b/test/golden/operator-elab-fail-2.gold index 00c45a2..1037d20 100644 --- a/test/golden/operator-elab-fail-2.gold +++ b/test/golden/operator-elab-fail-2.gold @@ -1,7 +1,7 @@ ret > ExitFailure 1 out > Error out > -out > 3 | operator { 'Bool - ['if 'Wildcard 'Wildcard] : 'Wildcard } +out > 3 | operator { (b : 'Bool) - ['if (t : 'Wildcard) (e : 'Wildcard)] : 'Wildcard } out > 4 | out > 5 | 'True : 'Bool - ['if l] ~> l out > ^^^^^ diff --git a/test/golden/operator-elab-fail-4.gold b/test/golden/operator-elab-fail-4.gold index 4ab897f..94160a6 100644 --- a/test/golden/operator-elab-fail-4.gold +++ b/test/golden/operator-elab-fail-4.gold @@ -3,8 +3,8 @@ out > Error out > out > 1 | syntax { 'Bool = ['Enum ['False 'True]] } out > 2 | -out > 3 | operator { 'Boo - ['if 'Wildcard 'Wildcard] : 'Wildcard } -out > ^^^^ -out > operator-elab-fail-4.act:3:11-15 +out > 3 | operator { (b : 'Boo) - ['if (t : 'Wildcard) (e : 'Wildcard)] : 'Wildcard } +out > ^^^^ +out > operator-elab-fail-4.act:3:16-20 out > Expected a semantics but got 'Boo out > diff --git a/test/golden/printing-open.gold b/test/golden/printing-open.gold index a08414d..b40bf6f 100644 --- a/test/golden/printing-open.gold +++ b/test/golden/printing-open.gold @@ -1,10 +1,10 @@ ret > ExitFailure 1 out > Error out > -out > 2 | { a - 'id : a } -out > 3 | -out > 4 | x : a - 'id ~> 'hello +out > 4 | x : a - 'id ~> x +out > 5 | +out > 6 | x : a - 'id ~> 'hello out > ^^^^^^ -out > printing-open.act:4:15-21 +out > printing-open.act:6:15-21 out > 'hello does not match the semantics description a out > diff --git a/test/malformedPostOp.act b/test/malformedPostOp.act index 826b6db..5c1b2b9 100644 --- a/test/malformedPostOp.act +++ b/test/malformedPostOp.act @@ -10,4 +10,4 @@ syntax judgementform {} type (T : 'Type) - {['a 'a] - 'Value : 'Semantics} + {S - 'Value : 'Semantics} diff --git a/test/operator-elab-fail-2.act b/test/operator-elab-fail-2.act index b073c85..79cecfe 100644 --- a/test/operator-elab-fail-2.act +++ b/test/operator-elab-fail-2.act @@ -1,6 +1,6 @@ syntax { 'Bool = ['Enum ['False 'True]] } -operator { 'Bool - ['if 'Wildcard 'Wildcard] : 'Wildcard } +operator { (b : 'Bool) - ['if (t : 'Wildcard) (e : 'Wildcard)] : 'Wildcard } 'True : 'Bool - ['if l] ~> l 'False : 'Bool - ['if l r] ~> r diff --git a/test/operator-elab-fail-3.act b/test/operator-elab-fail-3.act index c6f50fd..cbfd946 100644 --- a/test/operator-elab-fail-3.act +++ b/test/operator-elab-fail-3.act @@ -1,6 +1,6 @@ syntax { 'Bool = ['Enum ['False 'True]] } -operator { 'Bool - ['if 'Wildcard 'Wildcard] : 'Wildcard } +operator { (b : 'Bool) - ['if (t : 'Wildcard) (e : 'Wildcard)] : 'Wildcard } 'True : 'Bool - ['if l r] ~> l 'False : 'Bool - ['ifte l r] ~> r diff --git a/test/operator-elab-fail-4.act b/test/operator-elab-fail-4.act index a4a37a8..42b5054 100644 --- a/test/operator-elab-fail-4.act +++ b/test/operator-elab-fail-4.act @@ -1,6 +1,6 @@ syntax { 'Bool = ['Enum ['False 'True]] } -operator { 'Boo - ['if 'Wildcard 'Wildcard] : 'Wildcard } +operator { (b : 'Boo) - ['if (t : 'Wildcard) (e : 'Wildcard)] : 'Wildcard } 'True : 'Bool - ['if l r] ~> l 'False : 'Bool - ['if l r] ~> r diff --git a/test/operator-elab-fail.act b/test/operator-elab-fail.act index 937eb89..ffa98cf 100644 --- a/test/operator-elab-fail.act +++ b/test/operator-elab-fail.act @@ -1,6 +1,6 @@ syntax { 'Bool = ['Enum ['False 'True]] } -operator { (_ : 'Bool) - ['if 'Wildcard 'Wildcard] : 'Wildcard } +operator { (b : 'Bool) - ['if (t : 'Wildcard) (e : 'Wildcard)] : 'Wildcard } 'True : 'Bool - ['if l r] ~> l 'False : 'Bool - ['if l m r] ~> r diff --git a/test/printing-open.act b/test/printing-open.act index e686e2c..8c88112 100644 --- a/test/printing-open.act +++ b/test/printing-open.act @@ -1,4 +1,6 @@ operator - { a - 'id : a } + { (x : a) - 'id : a } -x : a - 'id ~> 'hello \ No newline at end of file +x : a - 'id ~> x + +x : a - 'id ~> 'hello diff --git a/test/printing.act b/test/printing.act index 5a44cf8..ba09ca3 100644 --- a/test/printing.act +++ b/test/printing.act @@ -1,6 +1,6 @@ syntax { 'Bool = ['Enum ['False 'True]] } -operator { X - ['if 'Bool] : X } +operator { (x : X) - ['if (b : 'Bool)] : X } t : Y - ['if 'True] ~> t diff --git a/test/reduce-neutrals-2.act b/test/reduce-neutrals-2.act index cdb87cd..1fde06a 100644 --- a/test/reduce-neutrals-2.act +++ b/test/reduce-neutrals-2.act @@ -1,6 +1,6 @@ operator - { A - ['fst ['Enum ['True]]] : A - ; B - ['snd ['Enum ['True]]] : B + { (x : A) - ['fst (b : ['Enum ['True]])] : A + ; (x : B) - ['snd (b : ['Enum ['True]])] : B } x : X - ['fst b1] - ['snd b2] ~> x - ['fst b1 - ['snd b2]] diff --git a/test/reduce-neutrals.act b/test/reduce-neutrals.act index ecddd40..58e4cc0 100644 --- a/test/reduce-neutrals.act +++ b/test/reduce-neutrals.act @@ -1,4 +1,4 @@ -operator { A - ['if ['Enum ['True]]] : A } +operator { (y : A) - ['if (b : ['Enum ['True]])] : A } x : X - ['if b1] - ['if b2] ~> x - ['if b1 - ['if b2]] diff --git a/test/typecheck.act b/test/typecheck.act index f03cabe..a5c4440 100644 --- a/test/typecheck.act +++ b/test/typecheck.act @@ -16,8 +16,8 @@ typecheck ['Pi 'Semantics \X.['Pi X \_.X]] : 'Semantics typecheck \X x.x : ['Pi 'Semantics \X.['Pi X \_.X]] operator - { 'Nat -[ 'add 'Nat ] : 'Nat - ; 'Nat -[ 'mul 'Nat ] : 'Nat + { (n : 'Nat) -[ 'add (m : 'Nat) ] : 'Nat + ; (n : 'Nat) -[ 'mul (m : 'Nat) ] : 'Nat } -- TODO: improve error message for: @@ -32,8 +32,8 @@ m : 'Nat -['add n ] -['mul p ] ~> (m -['mul p]) -['add (n -['mul p ])] operator - { ['Pi a \x.b] -['apply (t : a)] : {x=t}b - ; ['Pi a \x.b] -['apply2 (x : a)] : b + { (f : ['Pi a \x.b]) -['apply (t : a)] : {x=t}b + ; (f : ['Pi a \x.b]) -['apply2 (x : a)] : b } f : ['Pi 'Nat \_.'Nat] -[ 'apply t ] ~> 'Zero From 377a10a7e744660e76f13db6f98cba2212e983e5 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Thu, 23 Mar 2023 16:17:51 +0000 Subject: [PATCH 78/89] [ todo ] add todo --- TODO.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/TODO.md b/TODO.md index 003bf79..0bbe62b 100644 --- a/TODO.md +++ b/TODO.md @@ -30,7 +30,9 @@ + [ ] Unique names for subactors + [ ] block terms on names + [ ] Blocking wrapper evaporates when named thing is `Done` -+ [x] PRINTF argument for model-based normalisation +* [x] PRINTF argument for model-based normalisation +* [ ] PRINTF argument for type of + ### VM From b76a36625a76875f7b92ccc69d106ab3c2cc52bf Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Thu, 23 Mar 2023 17:17:31 +0000 Subject: [PATCH 79/89] [ fix ] checking optional patterns in judgements --- Src/Actor.hs | 2 +- Src/Command.hs | 11 +++++++---- Src/Concrete/Base.hs | 20 +++++++++++++++++++- Src/Elaboration/Monad.hs | 2 ++ Src/Elaboration/Pretty.hs | 8 +++++++- test/golden/judgement-optional-pattern.gold | 5 +++++ test/judgement-optional-pattern.act | 12 ++++++++++++ 7 files changed, 53 insertions(+), 7 deletions(-) create mode 100644 test/golden/judgement-optional-pattern.gold create mode 100644 test/judgement-optional-pattern.act diff --git a/Src/Actor.hs b/Src/Actor.hs index f8fc0fd..c2e9b14 100644 --- a/Src/Actor.hs +++ b/Src/Actor.hs @@ -41,7 +41,7 @@ type Gripe = String type instance JUDGEMENTNAME Abstract = JudgementName type instance CHANNEL Abstract = Channel -type instance BINDER Abstract = (Binder ActorMeta) +type instance BINDER Abstract = Binder ActorMeta type instance ACTORVAR Abstract = ActorMeta type instance TERMVAR Abstract = DB type instance TERM Abstract = ACTm diff --git a/Src/Command.hs b/Src/Command.hs index bbf94a8..e0bdd57 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -478,7 +478,7 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do SubjectPlace (WithRange r rsyn) (sem, msempat) -> do syndecls <- gets (Map.keys . syntaxCats) unless (rsyn `elem` syndecls) $ - throwComplaint r undefined + throwComplaint r $ InvalidSubjectSyntaxCat rsyn syndecls syn <- satom rsyn mp <- pure (Map.insert name (fromMaybe (UnderscoreP unknown) msempat) mp) (ps, mp, ds) <- citizenJudgements mp inputs outputs plcs @@ -487,10 +487,13 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do kindify :: Map Variable RawP -> CAnOperator -> Elab CAnOperator kindify m op - | (Used x, _) <- objDesc op + | (Used x, pat) <- objDesc op , Just sempat <- Map.lookup x m - = -- check pat is compatible with sempat - pure (op { objDesc = (Used x, sempat) }) + = do + case pat of + UnderscoreP _ -> pure () + _ -> when (pat /= sempat) $ throwComplaint pat $ MismatchedObjectPattern (theValue (opName op)) pat sempat + pure (op { objDesc = (Used x, sempat) }) | otherwise = throwComplaint (fst $ objDesc op) $ MalformedPostOperator (theValue (opName op)) (Map.keys m) diff --git a/Src/Concrete/Base.hs b/Src/Concrete/Base.hs index 2ab2357..4d144a5 100644 --- a/Src/Concrete/Base.hs +++ b/Src/Concrete/Base.hs @@ -6,6 +6,7 @@ import Data.Function (on) import Bwd import Format import Scope +import Hide import Location import Data.Bifunctor (Bifunctor (..)) @@ -35,6 +36,11 @@ data Binder x | Unused Range deriving (Show, Functor, Foldable, Traversable) +instance Eq x => Eq (Binder x) where + Used x == Used x' = x == x' + Unused _ == Unused _ = True + _ == _ = False + instance HasSetRange x => HasSetRange (Binder x) where setRange r (Used x) = Used (setRange r x) setRange r (Unused _) = Unused r @@ -79,7 +85,7 @@ instance Eq Raw where Var _ v == Var _ w = v == w At _ a == At _ b = a == b Cons _ p q == Cons _ s t = p == s && q == t - Lam _ sc == Lam _ bd = sc == bd + Lam _ (Scope (Hide x) p) == Lam _ (Scope (Hide x') p') = (x, p) == (x', p') Sbst _ cs t == Sbst _ ds u = cs == ds && t == u Op _ s t == Op _ a b = s == a && t == b Guarded g t == Guarded h u = (g, t) == (h, u) @@ -123,6 +129,18 @@ data RawP | Irrefutable Range RawP deriving (Show) +instance Eq RawP where + AsP _ v p == AsP _ v' p' = (v, p) == (v', p') + VarP _ v == VarP _ v' = v == v' + AtP _ a == AtP _ a' = a == a' + ConsP _ p q == ConsP _ p' q' = (p, q) == (p', q') + LamP _ (Scope (Hide x) p) == LamP _ (Scope (Hide x') p') = (x, p) == (x', p') + ThP _ th t == ThP _ th' t' = (th, t) == (th', t') + UnderscoreP _ == UnderscoreP _ = True + Irrefutable _ p == Irrefutable _ p' = p == p' + _ == _ = False + + instance HasSetRange RawP where setRange r = \case AsP _ v p -> AsP r v p diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index a0a4790..270bca1 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -515,6 +515,8 @@ data Complaint | BothInputOutput Variable | ProtocolCitizenSubjectMismatch Variable (Mode ()) | MalformedPostOperator String [Variable] + | MismatchedObjectPattern String RawP RawP + | InvalidSubjectSyntaxCat SyntaxCat [SyntaxCat] -- syntaxes | AlreadyDeclaredSyntaxCat SyntaxCat -- syntaxdesc validation diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index 04d5ea5..1fef43a 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -176,7 +176,13 @@ instance Pretty (WithRange Complaint) where let message = case cands of [x] -> "the subject" _ -> "a subject among" in hsep $ ["Malformed operator", pretty op <> "; expected it to act on", message] ++ punctuate ", " (map pretty cands) - + MismatchedObjectPattern op got expected -> + vcat [ hsep ["Mismatched object type pattern in operator declaration of ", pretty op <> "."] + , hsep ["Expected", pretty expected, "but got", pretty got] + ] + InvalidSubjectSyntaxCat got known -> vcat [hsep ["Invalid subject syntax category", pretty got] + , hsep ("Expected one among" : punctuate ", " (map pretty known)) + ] -- syntaxes AlreadyDeclaredSyntaxCat x -> hsep ["The syntactic category", pretty x, "is already defined"] diff --git a/test/golden/judgement-optional-pattern.gold b/test/golden/judgement-optional-pattern.gold new file mode 100644 index 0000000..25cdeff --- /dev/null +++ b/test/golden/judgement-optional-pattern.gold @@ -0,0 +1,5 @@ +ret > ExitSuccess +out > 'Nat +out > +err > +err > diff --git a/test/judgement-optional-pattern.act b/test/judgement-optional-pattern.act new file mode 100644 index 0000000..df68763 --- /dev/null +++ b/test/judgement-optional-pattern.act @@ -0,0 +1,12 @@ +syntax { 'Type = ['Enum ['Nat 'Bool]] } + +sem : $'Wildcard. + +judgementform + {sem A; sem B} + judge A B (t : 'Type => ['Pi A \x.B]) + {t {-: ['Pi A \x.B]-} -['action (x : A)] : B} + +f : ['Pi A \x.B] -['action x] ~> f -['app x] + +exec ['Pi 'Type \_.'Type]?f. (f ~ \ X. X | PRINTF "%n" f -['action 'Nat].) From 153417674979f7ce4cff8bd7902fd243dd039351 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Thu, 23 Mar 2023 17:35:20 +0000 Subject: [PATCH 80/89] [ testing ] excluded directories, and fix README.md --- README.md | 6 +++--- test/Test/Main.hs | 23 +++++++++++++++-------- 2 files changed, 18 insertions(+), 11 deletions(-) diff --git a/README.md b/README.md index 8af144d..cd641eb 100644 --- a/README.md +++ b/README.md @@ -526,8 +526,8 @@ Since `'app` and `'when` are builtin operators, they do not need to be declared, this is how we would declare our own copies of them: ``` operator - { 'Wildcard - ['myApp 'Wildcard] : 'Wildcard - ; 'Wildcard - ['myWhen ['Enum ['True 'False]]] : 'Wildcard + { (f : 'Wildcard) - ['myApp (t : 'Wildcard)] : 'Wildcard + ; (a : A) - ['myWhen (b : ['Enum ['True 'False]])] : A } ``` In the future, we might check more interesting semantic notions, but for now, @@ -550,7 +550,7 @@ following reduction rules: ``` (\ x. t) : 'Wildcard - ['myApp s] ~> {x=s}t -t : 'Wildcard - ['myWhen 'True] ~> t +t : A - ['myWhen 'True] ~> t ``` Multiple rules may be given for the same operator. We do not currently check if overlapping rules are confluent, so it is up to the rule diff --git a/test/Test/Main.hs b/test/Test/Main.hs index 71e5d42..b39e3ec 100644 --- a/test/Test/Main.hs +++ b/test/Test/Main.hs @@ -2,7 +2,7 @@ module Main where import Control.Monad -import Data.List ((\\)) +import Data.List ((\\), isPrefixOf) import System.Directory import System.FilePath @@ -12,12 +12,13 @@ import Test.Tasty.Silver import Test.Tasty.Silver.Interactive data TestConfig = TestConfig - { name :: String - , extension :: String - , goldenExt :: String - , goldenDir :: String - , folder :: FilePath - , excluded :: [FilePath] + { name :: String + , extension :: String + , goldenExt :: String + , goldenDir :: String + , folder :: FilePath + , excluded :: [FilePath] + , excludedDirs :: [FilePath] } main :: IO () @@ -36,6 +37,7 @@ paperTYPES = do let folder = "papers/2022-TYPES" let goldenDir = folder "golden" let excluded = [] + let excludedDirs = [] ioTests TestConfig{..} markdown :: IO TestTree @@ -46,6 +48,7 @@ markdown = do let folder = "." let goldenDir = "examples" "golden" let excluded = ["TODO.md"] + let excludedDirs = ["dist/", "dist-newstyle/", "build/"] ioTests TestConfig{..} @@ -57,6 +60,7 @@ typosExamples = do let folder = "examples" let goldenDir = folder "golden" let excluded = [] + let excludedDirs = [] ioTests TestConfig{..} @@ -68,17 +72,20 @@ typosTests = do let folder = "test" let goldenDir = folder "golden" let excluded = [] + let excludedDirs = [] ioTests TestConfig{..} ioTests :: TestConfig -> IO TestTree ioTests TestConfig{..} = testGroup name <$> do files <- map normalise <$> findByExtension [extension] folder - forM (files \\ (normalise . (folder ) <$> excluded)) $ \ file -> do + let excludedFiles = (normalise . (folder ) <$> excluded) + forM (filter (\ f -> not (any (`isPrefixOf` f) excludedDirs)) $ files \\ excludedFiles) $ \ file -> do let dir = takeDirectory file let name = takeBaseName file let gold = goldenDir addExtension name goldenExt let flgs = dir addExtension name "flags" b <- doesFileExist flgs flags <- if b then words <$> readFile flgs else pure ["-q", "--no-colour", "--wAll"] + putStrLn file pure $ goldenVsProg name gold "typos" (flags ++ [file]) "" From a9489916cae21422fa3cbe31d0887166b044b10c Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Thu, 23 Mar 2023 21:36:23 +0000 Subject: [PATCH 81/89] [ cleanup ] remove filepath printing --- test/Test/Main.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/test/Test/Main.hs b/test/Test/Main.hs index b39e3ec..174cf7f 100644 --- a/test/Test/Main.hs +++ b/test/Test/Main.hs @@ -87,5 +87,4 @@ ioTests TestConfig{..} = testGroup name <$> do let flgs = dir addExtension name "flags" b <- doesFileExist flgs flags <- if b then words <$> readFile flgs else pure ["-q", "--no-colour", "--wAll"] - putStrLn file pure $ goldenVsProg name gold "typos" (flags ++ [file]) "" From 9683c37ecd6b00a24bb3b0bb7b057f45c32935f9 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Fri, 24 Mar 2023 10:34:08 +0000 Subject: [PATCH 82/89] [ fix ] disallow matching on the universe --- Src/Elaboration.hs | 20 +++++--------------- Src/Elaboration/Monad.hs | 1 + Src/Elaboration/Pretty.hs | 1 + 3 files changed, 7 insertions(+), 15 deletions(-) diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index 0b9d6a4..d933e93 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -398,7 +398,9 @@ spatSemantics desc rest rp = do VNilOrCons{} -> unless (a == "") $ throwComplaint r (ExpectedNilGot a) VEnumOrTag sc es _ -> unless (a `elem` es) $ throwComplaint r (ExpectedEnumGot es a) VWildcard sc -> pure () - VUniverse _ -> unless (a `elem` ("Atom" : "Nil" : "Wildcard" : "Syntax" : "Semantics" : Map.keys table)) $ throwComplaint r (ExpectedASemanticsGot (At r a)) + VUniverse _ -> + unless (a `elem` ("Atom" : "Nil" : "Wildcard" : "Syntax" : "Semantics" : Map.keys table)) $ + throwComplaint r (ExpectedASemanticsGot (At r a)) _ -> throwComplaint r =<< syntaxPError desc rp pure (AP a, ds, atom a (bigEnd (restriction rest))) ConsP r p1 p2 -> do @@ -816,6 +818,7 @@ spatBase isSub desc rest rp = do VNilOrCons{} -> unless (a == "") $ throwComplaint r (ExpectedNilGot a) VEnumOrTag sc es _ -> unless (a `elem` es) $ throwComplaint r (ExpectedEnumGot es a) VWildcard sc -> pure () + VUniverse _ -> throwComplaint r (CantMatchOnSemantics rp) _ -> throwComplaint r =<< syntaxPError desc rp (Nothing, AP a,,) <$> asks declarations <*> asks binderHints @@ -835,20 +838,7 @@ spatBase isSub desc rest rp = do (mr2, q, ds, hs) <- local (setDecls ds . setHints hs) (spats isSub descs rest q) pure (mr1 <|> mr2, PP p q, ds, hs) _ -> throwComplaint r =<< syntaxPError desc rp - ConsUniverse -> case (isSub, p, q) of - (IsNotSubject, AtP _ "Pi", ConsP _ s (ConsP _ (LamP _ (Scope (Hide x) t)) (AtP _ ""))) -> do - (ps, ds, s) <- spatSemantics desc rest s - (mr, pt, ds, hs) <- - local (setDecls ds) $ - elabUnder (x, s) $ --- local (addHint (getVariable <$> x) (Known desc)) $ - spatBase isSub (weak desc) (extend rest (getVariable <$> x)) q - pure ( mr - , PP (AP "Pi") (PP ps (PP pt (AP ""))) - , ds - , hs) - (IsSubject{}, _, _) -> throwComplaint r undefined - _ -> throwComplaint r (ExpectedASemanticsPGot rp) + ConsUniverse -> throwComplaint r (CantMatchOnSemantics rp) LamP r (Scope v@(Hide x) p) -> do (s, desc) <- case vdesc of VWildcard _ -> pure (desc, weak desc) diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 270bca1..4239451 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -537,6 +537,7 @@ data Complaint | SyntaxError ESemanticsDesc Raw | SyntaxPError ESemanticsDesc RawP | CantMatchOnPi ESemanticsDesc RawP + | CantMatchOnSemantics RawP | DuplicatedTag String | ExpectedAnOperator Raw | ExpectedAnEmptyListGot String [SyntaxDesc] diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index 1fef43a..1268755 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -216,6 +216,7 @@ instance Pretty (WithRange Complaint) where SyntaxError d t -> hsep ["Term", pretty t, "does not check against", pretty d] SyntaxPError d p -> hsep ["Pattern", pretty p, "does not check against", pretty d] CantMatchOnPi d p -> hsep ["Cannot match pattern", pretty p, "at semantic Pi", pretty d] + CantMatchOnSemantics p -> hsep ["Cannot match on semantics in case", pretty p] DuplicatedTag t -> hsep ["Duplicated tag", pretty t] ExpectedAnOperator t -> hsep ["Expected an operator call but got", pretty t] ExpectedAnEmptyListGot a ds -> From 24ac4dc1ca43edd6eeead1ff9b1764a227be35a1 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Tue, 28 Mar 2023 18:03:08 +0100 Subject: [PATCH 83/89] radicals and types in operators --- Src/Actor.hs | 1 + Src/Command.hs | 74 +++++++++++++----------------- Src/Concrete/Base.hs | 4 ++ Src/Concrete/Pretty.hs | 1 + Src/Elaboration.hs | 2 +- Src/Machine/Base.hs | 70 +++++++++++++++------------- Src/Operator.hs | 26 ++++++----- Src/Operator/Eval.hs | 16 +++---- Src/Term/Base.hs | 8 +++- Src/Unelaboration.hs | 1 + examples/stlcRules.act | 11 +---- test/define-operator.act | 4 +- test/golden/define-operator.gold | 2 +- test/golden/printing.gold | 6 +-- test/golden/reduce-neutrals-2.gold | 7 ++- test/golden/reduce-neutrals.gold | 24 +++++++--- test/reduce-neutrals-2.act | 4 +- test/reduce-neutrals.act | 6 ++- test/type-projection.act | 4 +- test/typecheck.act | 2 +- 20 files changed, 147 insertions(+), 126 deletions(-) diff --git a/Src/Actor.hs b/Src/Actor.hs index c2e9b14..e2e4375 100644 --- a/Src/Actor.hs +++ b/Src/Actor.hs @@ -140,6 +140,7 @@ mangleActors opts rho tm = go tm where AX a de -> pure (atom a (ga + de)) a :%: b -> (%) <$> go a <*> go b t :-: o -> Term.contract <$> ((:-:) <$> go t <*> go o) + t ::: o -> Term.contract <$> ((:::) <$> go t <*> go o) x :.: t -> (tryAlpha rho x \\) <$> go t m :$: sg -> do t <- noisyLookupVar m diff --git a/Src/Command.hs b/Src/Command.hs index edb9d76..c15cb9b 100644 --- a/Src/Command.hs +++ b/Src/Command.hs @@ -348,36 +348,15 @@ scommand = \case -- Sig S \x.T - 'fst ~> S -- (p : Sig S \x.T) - 'snd ~> {x=[ p - 'fst ]}T - DefnOp ((rp, pty), opelims, rhs) -> do - -- p : pty -[ opelim0 ] -[ opelim1 ] ... -[ opelimn ] ~> rhs - sem <- satom "Semantics" - (_, decls, ty) <- spatSemantics0 sem pty - (p, decls, t) <- local (setDecls decls) $ spatSemantics0 ty rp - (opelimz, decls, lhsTy) <- local (setDecls decls) $ sopelims0 (getRange rp <> getRange pty) (ty, t) opelims + DefnOp (rp, opelims@((rpty,_,_):_), rhs) -> do + -- p : pty0 -[ opelim0 ] : pty1 -[ opelim1 ] ... : ptyn -[ opelimn ] ~> rhs + (p, opelimz, decls, lhsTy) <- sopelims0 (getRange rp <> getRange rpty) rp opelims rhs <- local (setDecls decls) $ stm DontLog lhsTy rhs -- this is the outer op being extended - let op = case opelimz of (_ :< (op, _)) -> op - let cl = Clause (toClause p opelimz rhs) + let op = case opelimz of (_ :< (_, op, _)) -> op + let cl = toClause p opelimz rhs (DefnOp (op, cl),) <$> asks globals -{- - ovs <- asks objVars - let scp = scopeSize ovs - - ((p, opargs), ret, decls, hints) <- do - -- this is the op applied to the object, not the outer op being extended - let op = fst (head opelims) - (AnOperator op (mb, opat{-, odesc-}) pdescs rdesc) <- soperator op - let rest = initRestriction ovs - (opat, decls, otm) <- spatSemantics (atom "Semantics" scp) rest opat - (mr1, p, decls, hints) <- spat (Term unknown otm) rest p - (opargs, decls, hints) <- local (setDecls decls . setHints hints) $ - sopargs obj opargs - pure ((p, opargs), ret, decls, hints) - rhs <- local (setDecls decls . setHints hints) $ stm DontLog ret rhs - --- trace (unwords [getOperator op, "-[", '\'':show p, show opargs, "~>", show rhs]) (pure ()) --} checkCompatiblePlaces :: [PLACE Concrete] -> [(Variable, ASemanticsDesc)] -> @@ -481,6 +460,7 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do unless (rsyn `elem` syndecls) $ throwComplaint r $ InvalidSubjectSyntaxCat rsyn syndecls syn <- satom rsyn + -- TODO: we use underScore here if the type is not a valid pattern, eg a stuck neutral. It would be good to do better. mp <- pure (Map.insert name (fromMaybe (UnderscoreP unknown) msempat) mp) (ps, mp, ds) <- citizenJudgements mp inputs outputs plcs sem <- local (setDecls ds) $ sty sem @@ -499,27 +479,39 @@ sjudgementform JudgementForm{..} = during (JudgementFormElaboration jname) $ do $ MalformedPostOperator (theValue (opName op)) (Map.keys m) sopelims0 :: Range - -> (ASemanticsDesc, ACTm) - -> [(OPERATOR Concrete, [RawP])] - -> Elab (Bwd (OPERATOR Abstract, [Pat]), Decls, ASemanticsDesc) -sopelims0 r = sopelims r B0 + -> RawP + -> [(RawP, OPERATOR Concrete, [RawP])] + -> Elab (Pat, Bwd (Pat, OPERATOR Abstract, [Pat]), Decls, ASemanticsDesc) +sopelims0 r = sopelims r B0 . Left sopelims :: Range - -> Bwd (OPERATOR Abstract, [Pat]) - -> (ASemanticsDesc, ACTm) - -> [(OPERATOR Concrete, [RawP])] - -> Elab (Bwd (OPERATOR Abstract, [Pat]), Decls, ASemanticsDesc) -sopelims r opelimz (ty, t) [] = (opelimz,,ty) <$> asks declarations -sopelims r opelimz (ty, t) ((op, args):opelims) = do + -> Bwd (Pat, OPERATOR Abstract, [Pat]) + -> Either RawP (Pat, (ASemanticsDesc, ACTm)) + -> [(RawP, OPERATOR Concrete, [RawP])] + -> Elab (Pat, Bwd (Pat, OPERATOR Abstract, [Pat]), Decls, ASemanticsDesc) +sopelims r opelimz (Right (p, (inty, t))) [] = (p,opelimz,,inty) <$> asks declarations +sopelims r opelimz acc ((rpty, op, args):opelims) = do -- We need to worry about freshening up names in operator -- declarations when checking definitions to avoid clashes (AnOperator (mb, opat) opName pdescs rdesc) <- freshenOp =<< soperator op - dat <- matchObjType r (mb, opat) (t, ty) + sem <- satom "Semantics" + (pty, decls, inty) <- spatSemantics0 sem rpty + (decls, (p,(inty, t))) <- local (setDecls decls) $ case acc of + Left rp -> do + (p, decls, t) <- spatSemantics0 inty rp + pure (decls, (p, (inty, t))) + Right x -> do + -- TODO: check that the type in x matches pty + pure (decls, x) + + -- TODO: check that pty is compatible with opat + dat <- matchObjType r (mb, opat) (t, inty) let r' = getRange op <> foldMap getRange args - local (setHeadUpData dat) $ do - ((ty, decls), (pargs, args)) <- spats r' (getOperator opName) pdescs args rdesc - local (setDecls decls) $ - sopelims (r <> r') (opelimz :< (opName, pargs)) (ty, t -% (getOperator opName, args)) opelims + local (setDecls decls . setHeadUpData dat) $ do + ((outty, decls), (pargs, args)) <- spats r' (getOperator opName) pdescs args rdesc + local (setDecls decls) $ do + let acc = Right (p, (outty, rad t inty -% (getOperator opName, args))) + sopelims (r <> r') (opelimz :< (pty, opName, pargs)) acc opelims where diff --git a/Src/Concrete/Base.hs b/Src/Concrete/Base.hs index 4d144a5..be2b5d4 100644 --- a/Src/Concrete/Base.hs +++ b/Src/Concrete/Base.hs @@ -66,6 +66,7 @@ data Raw | Lam Range (Scope (Binder Variable) Raw) | Sbst Range (Bwd Assign) Raw | Op Range Raw Raw + | Rad Range Raw Raw | Guarded Guard Raw | Thicken Range (Bwd Variable, ThDirective) Raw deriving (Show) @@ -78,6 +79,7 @@ instance HasSetRange Raw where Lam _ sc -> Lam r sc Sbst _ sg t -> Sbst r sg t Op _ s t -> Op r s t + Rad _ s t -> Rad r s t t@Guarded{} -> t Thicken _ th t -> Thicken r th t @@ -88,6 +90,7 @@ instance Eq Raw where Lam _ (Scope (Hide x) p) == Lam _ (Scope (Hide x') p') = (x, p) == (x', p') Sbst _ cs t == Sbst _ ds u = cs == ds && t == u Op _ s t == Op _ a b = s == a && t == b + Rad _ s t == Rad _ a b = s == a && t == b Guarded g t == Guarded h u = (g, t) == (h, u) Thicken _ th t == Thicken _ ph u = (th, t) == (ph, u) _ == _ = False @@ -100,6 +103,7 @@ instance HasGetRange Raw where Lam r _ -> r Sbst r _ _ -> r Op r _ _ -> r + Rad r _ _ -> r Guarded _ t -> getRange t Thicken r _ _ -> r diff --git a/Src/Concrete/Pretty.hs b/Src/Concrete/Pretty.hs index f651b96..ae58689 100644 --- a/Src/Concrete/Pretty.hs +++ b/Src/Concrete/Pretty.hs @@ -37,6 +37,7 @@ instance Pretty Raw where Sbst _ B0 t -> prettyPrec d t Sbst _ sg t -> parenthesise (d > 0) $ hsep [ pretty sg, pretty t ] Op _ s t -> parenthesise (d > 0) $ hsep [ pretty s, "-", prettyPrec 1 t ] + Rad _ s t -> parenthesise (d > 0) $ hsep [ pretty s, ":", pretty t ] Guarded g t -> hsep [ "<", pretty t , ">"] Thicken _ (thxz, thd) t -> braces (hsep (pretty <$> thxz <>> []) <> pretty thd) <+> pretty t diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index d933e93..c0fde82 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -504,7 +504,7 @@ itm usage (Op r rob rop) = do dat <- matchObjType r objDesc (ob, obDesc) local (setHeadUpData dat) $ do (desc, ps) <- itms r (getOperator opName) usage paramsDesc rps retDesc - pure (desc, ob {- TODO: store obDesc too -} -% (getOperator opName, ps)) + pure (desc, rad ob obDesc -% (getOperator opName, ps)) -- TODO?: annotated terms? itm _ t = throwComplaint t $ DontKnowHowToInferDesc t diff --git a/Src/Machine/Base.hs b/Src/Machine/Base.hs index 2d32933..e2a9d23 100644 --- a/Src/Machine/Base.hs +++ b/Src/Machine/Base.hs @@ -14,6 +14,7 @@ import Actor import Actor.Display() import Bwd +import Vector import Format import Options import Term @@ -30,7 +31,7 @@ import ANSI hiding (withANSI) import Pretty import Operator import Operator.Eval -import Unelaboration.Monad (Naming, UnelabMeta) +import Unelaboration.Monad (Naming) newtype Date = Date Int @@ -115,6 +116,7 @@ instance Instantiable Term where AX{} -> term s :%: t -> instantiate store s % instantiate store t s :-: t -> contract (instantiate store s :-: instantiate store t) + s ::: t -> contract (instantiate store s ::: instantiate store t) x :.: b -> x \\ instantiate store b m :$: sg -> case snd =<< Map.lookup m (solutions store) of Nothing -> m $: sg -- TODO: instantiate sg @@ -125,6 +127,7 @@ instance Instantiable Term where AX{} -> tnf s :%: t -> normalise dat s % normalise dat t s :-: t -> contract (normalise dat s :-: normalise dat t) + s ::: t -> contract (normalise dat s ::: normalise dat t) x :.: b -> x \\ normalise dat b m :$: sg -> m $: sg -- TODO: instantiate sg GX g t -> tnf -- don't compute under guards @@ -181,31 +184,31 @@ unOp t = case expand t of pure (Operator op, ps) _ -> Nothing -toClause :: forall m. (Show m, UnelabMeta m) => Pat -> Bwd (Operator, [Pat]) -> ACTm - -> Options - -> (Term' m -> Term' m) -- head normaliser - -> Env' m - -> (Term' m, [Term' m]) -- object & parameters - -> Either (Term' m, [Term' m]) (Term' m) -toClause pobj (ops :< op) rhs opts hnf env targs@(t, args) = +toClause :: Pat -- (obj, ty), eg `['Pair p q] : ['Sigma A \x.B]` + -> Bwd (Pat, Operator, [Pat]) -- parameter patterns + -> ACTm -- RHS + -> Clause +toClause pobj (ops :< op@(_, opname, _)) rhs = Clause $ toClause' where + toClause' :: forall m. AClause m + toClause' opts hnf env targs@((t, ty), args) = let msg result = flush $ vcat [ hsep ( "Matching" : withANSI [SetColour Background Green] (unsafeDocDisplay opts naming t) : "-" - : [let opdoc = pretty (getOperator (fst op)) in case args of + : [let opdoc = pretty (getOperator opname) in case args of [] -> "'" <> opdoc _ -> "['" <> hsep (opdoc : map (unsafeDocDisplay opts naming) args) <> "]"] ) , hsep ( "against" : unsafeDocDisplay opts naming pobj - : flip map (ops <>> [op]) (\ (Operator op, ps) -> "- " <> case ps of + : flip map (ops <>> [op]) (\ (ty, Operator op, ps) -> hsep [":", unsafeDocDisplay opts naming ty, "- "] <> case ps of [] -> "'" <> pretty op _ -> "['" <> hsep (pretty op : map (unsafeDocDisplay opts naming) ps) <> "]") ) <> " ~> " <> unsafeDocDisplay opts naming rhs , result ] in - let ((t, ts), res) = loop initMatching ops op targs in case res of + let ((t, ts), res) = loop env initMatching ops op targs in case res of Right mtch | Just val <- mangleActors opts (matchingToEnv mtch env) rhs -> whenClause opts (msg (withANSI [SetColour Background Green] "Success!")) $ pure val | otherwise -> whenClause opts (msg (withANSI [SetColour Background Red] "Failure")) $ Left (t, ts) @@ -222,28 +225,33 @@ toClause pobj (ops :< op) rhs opts hnf env targs@(t, args) = = trace (renderWith (renderOptions opts) doc) a | otherwise = a - loop :: Matching' m - -> Bwd (Operator, [Pat]) -- left nested operators - -> (Operator, [Pat]) -- current operator OP in focus - -> (Term' m, [Term' m]) -- current term (t -['OP | ts]) already taken apart - -> ( (Term' m, [Term' m]) -- evaluated (t,ts) + loop :: Env' m + -> Matching' m + -> Bwd (Pat, Operator, [Pat]) -- left nested operators: object type, operator, parameters + -> (Pat, Operator, [Pat]) -- current operator OP in focus + -> ((Term' m, Term' m), [Term' m]) -- current term (t : ty -['OP | ts]) already taken apart + -> ( ((Term' m, Term' m), [Term' m]) -- evaluated ((t, ty),ts) , Either Failure (Matching' m)) - loop mtch ops (op, ps) (tops, tps) = + loop env mtch ops (pObjDesc, op, ps) ((tops, topsDesc), tps) = -- match tops against the left-nested (pobj -- ops) -- we don't care about the tps yet let leftnested = case ops of - B0 -> match hnf mtch (Problem (localScope env) pobj tops) + B0 -> matchN hnf mtch (Problem (localScope env) pobj tops :* + Problem (localScope env) pObjDesc topsDesc :* + V0) -- leftops + lop to the left of the op currently in focus - (lops :< (lop, lps)) -> let topsnf = hnf tops in case expand topsnf of - (ltops :-: loptps) -> let loptpsnf = hnf loptps in case unOp loptpsnf of - Just (lop', ltps) | lop == lop' -> - case loop mtch lops (lop, lps) (ltops, ltps) of - ((ltops, ltps), res) -> (ltops -% (getOperator lop, ltps), res) - _ -> (contract (ltops :-: loptpsnf), Left Mismatch) -- Careful: could be a stuck meta + (lops :< lop@(_, lopname, _)) -> first (\ t -> t :* topsDesc :* V0) $ let topsnf = hnf tops in case expand topsnf of + (ltops :-: loptps) -> case expand ltops of + (ltops ::: ltopsDesc) -> let loptpsnf = hnf loptps in case unOp loptpsnf of + Just (lop', ltps) | lopname == lop' -> + case loop env mtch lops lop ((ltops, ltopsDesc), ltps) of + (((ltops, ltopsDesc), ltps), res) -> (rad ltops ltopsDesc -% (getOperator lopname, ltps), res) + _ -> (contract (rad ltops ltopsDesc :-: loptpsnf), Left Mismatch) -- Careful: could be a stuck meta + _ -> (topsnf, Left (whenClause opts (unsafeDocDisplay opts naming ltops <+> "not a radical") Mismatch)) _ -> (topsnf, Left (whenClause opts (unsafeDocDisplay opts naming topsnf <+> "not an operator application") Mismatch)) in case leftnested of - (tops, Left err) -> ((tops, tps), Left err) - (tops, Right mtch) -> first (tops,) $ matches mtch ps tps + (tops :* topsTy :* V0, Left err) -> (((tops, topsTy), tps), Left err) + (tops :* topsTy :* V0, Right mtch) -> first ((tops, topsTy),) $ matches mtch ps tps matches :: Matching' m -> [Pat] -> [Term' m] -> ([Term' m], Either Failure (Matching' m)) matches mtch [] [] = ([], pure mtch) @@ -254,17 +262,17 @@ toClause pobj (ops :< op) rhs opts hnf env targs@(t, args) = appClause :: Clause -appClause = Clause $ \ opts hd env (t, args) -> +appClause = Clause $ \ opts hd env ((t, ty), args) -> case args of [arg] -> case expand (hd t) of x :.: b -> Right (b //^ topSbst x arg) - t -> Left (contract t, args) - _ -> Left (t, args) + t -> Left ((contract t, ty), args) + _ -> Left ((t, ty), args) tickClause :: Clause -tickClause = Clause $ \ opts hd env (t, args) -> case args of +tickClause = Clause $ \ opts hd env ((t, ty), args) -> case args of []-> (if not (quiet opts) then trace "Tick" else id) $ Right t - _ -> Left (t, args) + _ -> Left ((t, ty), args) data Frame = Rules JudgementName AProtocol (Channel, AActor) diff --git a/Src/Operator.hs b/Src/Operator.hs index 42a879f..88cf165 100644 --- a/Src/Operator.hs +++ b/Src/Operator.hs @@ -134,14 +134,14 @@ type family OPERATOR (ph :: Phase) :: * type instance OPERATOR Concrete = WithRange String type instance OPERATOR Abstract = Operator -newtype Clause = Clause - { runClause :: forall m - . (Show m, UnelabMeta m) => Options +type AClause m = (Show m, UnelabMeta m) + => Options -> (Term' m -> Term' m) -- head normaliser -> Env' m - -> (Term' m, [Term' m]) -- object & parameters - -> Either (Term' m, [Term' m]) (Term' m) - } + -> ((Term' m, Term' m), [Term' m]) -- (object, object type) & parameters + -> Either ((Term' m, Term' m), [Term' m]) (Term' m) + +newtype Clause = Clause { runClause :: forall m . AClause m } instance Semigroup Clause where (<>) = mappend @@ -155,17 +155,19 @@ instance Monoid Clause where instance Show Clause where show _ = "" -type OPPATTERN ph = (OPERATOR ph, [PATTERN ph]) +type OPPATTERN ph = (PATTERN ph -- type acted on + , OPERATOR ph -- operator + , [PATTERN ph]) -- parameters type family DEFNOP (ph :: Phase) :: * -type instance DEFNOP Concrete = ((PATTERN Concrete, PATTERN Concrete) -- object and its type - , [OPPATTERN Concrete] -- spine - , TERM Concrete) -- right hand side +type instance DEFNOP Concrete = (PATTERN Concrete -- object + , [OPPATTERN Concrete] -- spine (must be non-empty) + , TERM Concrete) -- right hand side type instance DEFNOP Abstract = (Operator, Clause) pdefnop :: Parser (DEFNOP Concrete) -pdefnop = (,,) <$> ((,) <$> ppat <* ppunc ":" <*> ppat) - <*> some (ppunc "-" *> poperator ppat) +pdefnop = (,,) <$> ppat + <*> some ((\a (b,c) -> (a, b, c)) <$ ppunc ":" <*> ppat <* ppunc "-" <*> poperator ppat) <* ppunc "~>" <*> pTM diff --git a/Src/Operator/Eval.hs b/Src/Operator/Eval.hs index 335fd4f..0c2e0aa 100644 --- a/Src/Operator/Eval.hs +++ b/Src/Operator/Eval.hs @@ -50,19 +50,19 @@ headUp :: forall m . (Show m, UnelabMeta m) => HeadUpData' m -> Term' m -> Term' headUp dat@HeadUpData{..} term = case expand term of m :$: sg | Just t <- whatIs m -> headUp dat (t //^ sg) - t :-: o -> case expand o of - AX op i -> operate (Operator op) (t, []) - o@(CdB (A op) th :%: wargs) -> - case asList (\ ps -> pure $ operate (Operator op) (t, ps)) wargs of - Nothing -> contract (t :-: contract o) + tty :-: o -> case (expand tty, expand o) of + (t ::: ty, AX op i) -> operate (Operator op) ((t,ty), []) + (t ::: ty, o@(CdB (A op) th :%: wargs)) -> + case asList (\ ps -> pure $ operate (Operator op) ((t, ty), ps)) wargs of + Nothing -> contract (tty :-: contract o) Just t -> t - o -> contract (t :-: contract o) + (t, o) -> contract (tty :-: contract o) GX g t | Set.null (dependencySet metaStore g) -> headUp dat t _ -> term where - operate :: Operator -> (Term' m, [Term' m]) -> Term' m + operate :: Operator -> ((Term' m, Term' m), [Term' m]) -> Term' m operate op tps = case runClause (opTable op) huOptions (headUp dat) huEnv tps of - Left (t, ps) -> t -% (getOperator op, ps) + Left ((t, ty), ps) -> rad t ty -% (getOperator op, ps) Right t -> headUp dat t diff --git a/Src/Term/Base.hs b/Src/Term/Base.hs index 020e26f..c93ebaf 100644 --- a/Src/Term/Base.hs +++ b/Src/Term/Base.hs @@ -13,7 +13,7 @@ import Concrete.Base (Guard, Root) import GHC.Stack -data Pairing = Cell | Oper +data Pairing = Cell | Oper | Radi deriving (Show, Eq, Ord) data Tm m @@ -150,6 +150,7 @@ data Xn m | AX String Int -- how many free variables? | CdB (Tm m) :%: CdB (Tm m) -- pairing | CdB (Tm m) :-: CdB (Tm m) -- operator + | CdB (Tm m) ::: CdB (Tm m) -- radical | String :.: CdB (Tm m) -- abstraction | m :$: CdB (Sbst m) -- meta + sbst | GX Guard (CdB (Tm m)) @@ -161,6 +162,7 @@ expand (CdB t th) = case t of A a -> AX a (bigEnd th) P Cell (s :<>: t) -> (s *^ th) :%: (t *^ th) P Oper (s :<>: t) -> (s *^ th) :-: (t *^ th) + P Radi (s :<>: t) -> (s *^ th) ::: (t *^ th) (str := b) :. t -> unhide str :.: CdB t (th -? b) f :$ sg -> f :$: CdB sg th G g t -> GX g (CdB t th) @@ -174,6 +176,7 @@ contract t = case t of AX a ga -> CdB (A a) (none ga) s :%: t -> P Cell $^ (s <&> t) s :-: t -> P Oper $^ (s <&> t) + s ::: t -> P Radi $^ (s <&> t) x :.: CdB t th -> case thun th of (th, b) -> CdB ((Hide x := b) :. t) th m :$: sg -> (m :$) $^ sg @@ -194,6 +197,9 @@ infixr 4 % (%) :: CdB (Tm m) -> CdB (Tm m) -> CdB (Tm m) s % t = contract (s :%: t) +rad :: CdB (Tm m) -> CdB (Tm m) -> CdB (Tm m) +rad s t = contract (s ::: t) + infixl 4 -% (-%) :: CdB (Tm m) -> (String, [CdB (Tm m)]) -> CdB (Tm m) t -% (o, []) = contract (t :-: atom o (scope t)) diff --git a/Src/Unelaboration.hs b/Src/Unelaboration.hs index 5efb23b..dba3dc9 100644 --- a/Src/Unelaboration.hs +++ b/Src/Unelaboration.hs @@ -52,6 +52,7 @@ instance UnelabMeta m => Unelab (Tm m) where A a -> pure (At unknown a) P Cell (s :<>: t) -> Cons unknown <$> unelab s <*> unelab t P Oper (s :<>: t) -> Op unknown <$> unelab s <*> unelab t + P Radi (s :<>: t) -> Rad unknown <$> unelab s <*> unelab t (x := b) :. t -> Lam unknown . uncurry (Scope . Hide) <$> case b of False -> (Unused unknown,) <$> unelab t True -> do diff --git a/examples/stlcRules.act b/examples/stlcRules.act index 75694f6..5e10e6b 100644 --- a/examples/stlcRules.act +++ b/examples/stlcRules.act @@ -47,8 +47,6 @@ judgementform type (T : 'Type) -- no '=> B' means the citizen version is the same {T - 'Value : 'Semantics} -exec 'Type?a. (a ~ 'Nat | PRINTF "%n" a -'Value.) - judgementform {type T} check T (t : 'Check => T - 'Value) @@ -59,14 +57,7 @@ judgementform synth (e : 'Synth => S - 'Value) S {type S; e -'Quote : 'Check} -exec 'Synth?e. - PRINTF "Spawning synth". - synth@p. - p!e. - PRINTF "About to get stuck". - p?S. - PRINTF "%r" S. - +exec 'Type?a. (a ~ 'Nat | PRINTF "%n" a -'Bla.) {- -- Open question in the above: will it always be the subject that's fed to an operator? -- Note: the "T - 'Value" is in 'Semantics and that T is the citizen, not the subject diff --git a/test/define-operator.act b/test/define-operator.act index 3d7ff4e..4611651 100644 --- a/test/define-operator.act +++ b/test/define-operator.act @@ -24,7 +24,7 @@ x : A - ['when 'True] ~> x 'zero : 'Nat - ['plus n] ~> n ['succ m] : 'Nat - ['plus n] ~> ['succ (m - ['plus n])] m : 'Nat - ['plus 'zero] ~> m -m : 'Nat - ['plus n] - ['plus x] ~> m - ['plus (n - ['plus x])] +m : 'Nat - ['plus n] : 'Nat - ['plus x] ~> m - ['plus (n - ['plus x])] -- parsed as m [(plus, [n]), (plus, [x])] @@ -34,7 +34,7 @@ m : 'Nat - ['mult 'zero] ~> 'zero -- (unless we manage to get plus to be commutative) ['succ m] : 'Nat - ['mult n] ~> n - ['plus (m - ['mult n])] m : 'Nat - ['mult ['succ n]] ~> m - ['plus (m - ['mult n])] -m : 'Nat - ['plus n] - ['mult p] ~> (m - ['mult p]) - ['plus (n - ['mult p])] +m : 'Nat - ['plus n] : 'Nat - ['mult p] ~> (m - ['mult p]) - ['plus (n - ['mult p])] -- parsed as m [(plus, [n]), (mult, [p])] diff --git a/test/golden/define-operator.gold b/test/golden/define-operator.gold index e7fa6c8..059c2a1 100644 --- a/test/golden/define-operator.gold +++ b/test/golden/define-operator.gold @@ -1,5 +1,5 @@ ret > ExitSuccess -out > 'test - 'id +out > 'test : 'Atom - 'id out > 'True out > Warning: Unsolved metas (m:9, n:10, p:11) out > diff --git a/test/golden/printing.gold b/test/golden/printing.gold index 808bc34..5598f05 100644 --- a/test/golden/printing.gold +++ b/test/golden/printing.gold @@ -2,9 +2,9 @@ ret > ExitSuccess out > Raw: < ?[("b",[1])] > out > Instantiated: < 'True > out > Normalised: < ?[("b",[1])] > -out > Raw: < ?[("c",[2])] - ['if ?[("b",[1])]] > -out > Instantiated: < 'False - ['if 'True] > -out > Normalised: < ?[("c",[2])] - ['if ?[("b",[1])]] > +out > Raw: < ?[("c",[2])] : 'Bool - ['if ?[("b",[1])]] > +out > Instantiated: < 'False : 'Bool - ['if 'True] > +out > Normalised: < ?[("c",[2])] : 'Bool - ['if ?[("b",[1])]] > out > strict 'True out > strict 'False out > diff --git a/test/golden/reduce-neutrals-2.gold b/test/golden/reduce-neutrals-2.gold index c52ec8f..89a1f3a 100644 --- a/test/golden/reduce-neutrals-2.gold +++ b/test/golden/reduce-neutrals-2.gold @@ -2,8 +2,11 @@ ret > ExitSuccess out > Warning: Unsolved metas (b1:1, b2:2) out > out > -err > Matching 'at - ['fst ?[("b1",[1])]] - ['snd ?[("b2",[2])]] -err > against x - ['fst b1] - ['snd b2] ~> x - ['fst b1 - ['snd b2]] +err > Matching 'at : 'Atom - ['fst ?[("b1",[1])]] - ['snd ?[("b2",[2])]] +err > against x : X - ['fst b1] : _3 - ['snd b2] ~> x : X - ['fst +err > b1 : ['EnumOrTag +err > ['True] +err > []] - ['snd b2]] err > Success! err > err > diff --git a/test/golden/reduce-neutrals.gold b/test/golden/reduce-neutrals.gold index 9566ade..0f2706e 100644 --- a/test/golden/reduce-neutrals.gold +++ b/test/golden/reduce-neutrals.gold @@ -3,22 +3,32 @@ out > Warning: Unsolved metas (b1:1, b2:2) out > out > err > 'at not an operator application -err > Matching 'at - ['if ?[("b1",[1])] - ['if ?[("b2",[2])]]] -err > against x - ['if b1] - ['if b2] ~> x - ['if b1 - ['if b2]] +err > Matching 'at - ['if ?[("b1",[1])] : ['EnumOrTag +err > ['True] []] - ['if ?[("b2",[2])]]] +err > against x : X - ['if b1] : _3 - ['if b2] ~> x : X - ['if b1 : ['EnumOrTag +err > ['True] +err > []] - ['if b2]] err > Failure Mismatch err > err > 'at not an operator application err > Matching 'at - ['if ?[("b1",[1])]] -err > against x - ['if b1] - ['if b2] ~> x - ['if b1 - ['if b2]] +err > against x : X - ['if b1] : _3 - ['if b2] ~> x : X - ['if b1 : ['EnumOrTag +err > ['True] +err > []] - ['if b2]] err > Failure Mismatch err > -err > Matching 'at - ['if ?[("b1",[1])]] - ['if ?[("b2",[2])]] -err > against x - ['if b1] - ['if b2] ~> x - ['if b1 - ['if b2]] +err > Matching 'at : 'Atom - ['if ?[("b1",[1])]] - ['if ?[("b2",[2])]] +err > against x : X - ['if b1] : _3 - ['if b2] ~> x : X - ['if b1 : ['EnumOrTag +err > ['True] +err > []] - ['if b2]] err > Success! err > err > 'at not an operator application -err > Matching 'at - ['if ?[("b1",[1])] - ['if ?[("b2",[2])]]] -err > against x - ['if b1] - ['if b2] ~> x - ['if b1 - ['if b2]] +err > Matching 'at - ['if ?[("b1",[1])] : ['EnumOrTag +err > ['True] []] - ['if ?[("b2",[2])]]] +err > against x : X - ['if b1] : _3 - ['if b2] ~> x : X - ['if b1 : ['EnumOrTag +err > ['True] +err > []] - ['if b2]] err > Failure Mismatch err > err > diff --git a/test/reduce-neutrals-2.act b/test/reduce-neutrals-2.act index 1fde06a..996886a 100644 --- a/test/reduce-neutrals-2.act +++ b/test/reduce-neutrals-2.act @@ -3,6 +3,6 @@ operator ; (x : B) - ['snd (b : ['Enum ['True]])] : B } -x : X - ['fst b1] - ['snd b2] ~> x - ['fst b1 - ['snd b2]] +x : X - ['fst b1] : _ - ['snd b2] ~> x - ['fst b1 - ['snd b2]] -exec ('Wildcard?b1 b2. let a : 'Atom = 'at . a - ['fst b1] - ['snd b2] ~ a - ['fst b1 - ['snd b2]]) +exec (['Enum ['True]]?b1 b2. let a : 'Atom = 'at . a - ['fst b1] - ['snd b2] ~ a - ['fst b1 - ['snd b2]]) diff --git a/test/reduce-neutrals.act b/test/reduce-neutrals.act index 58e4cc0..8441fc7 100644 --- a/test/reduce-neutrals.act +++ b/test/reduce-neutrals.act @@ -1,5 +1,7 @@ +trace { clause } + operator { (y : A) - ['if (b : ['Enum ['True]])] : A } -x : X - ['if b1] - ['if b2] ~> x - ['if b1 - ['if b2]] +x : X - ['if b1] : _ - ['if b2] ~> x - ['if b1 - ['if b2]] -exec ('Wildcard?b1 b2. let a : 'Atom = 'at. a - ['if b1] - ['if b2] ~ a - ['if b1 - ['if b2]]) +exec (['Enum ['True]]?b1 b2. let a : 'Atom = 'at. a - ['if b1] - ['if b2] ~ a - ['if b1 - ['if b2]]) diff --git a/test/type-projection.act b/test/type-projection.act index 455bf3c..b9b8ecc 100644 --- a/test/type-projection.act +++ b/test/type-projection.act @@ -1,7 +1,7 @@ -operator { (x : a) - 'typeOf : 'Semantics } +operator { (x : c) - 'typeOf : 'Semantics } x : a - 'typeOf ~> a syntax { 'Bool = ['Enum ['T 'F]] } -exec 'Bool?b. PRINTF "%n" (b - 'typeOf). \ No newline at end of file +exec 'Bool?b. PRINTF "The type of %r is %n" b (b - 'typeOf). diff --git a/test/typecheck.act b/test/typecheck.act index a5c4440..8c4981c 100644 --- a/test/typecheck.act +++ b/test/typecheck.act @@ -28,7 +28,7 @@ operator 'Zero : 'Nat -[ 'mul n ] ~> 'Zero ['Suc m] : 'Nat -[ 'mul n ] ~> n -['add m -['mul n]] -m : 'Nat -['add n ] -['mul p ] +m : 'Nat -['add n ] : 'Nat -['mul p ] ~> (m -['mul p]) -['add (n -['mul p ])] operator From 8d921bb4c71476980f617cdf3b182c15bae92dfd Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Wed, 29 Mar 2023 15:38:12 +0100 Subject: [PATCH 84/89] [ test ] add missing golden file --- test/golden/type-projection.gold | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 test/golden/type-projection.gold diff --git a/test/golden/type-projection.gold b/test/golden/type-projection.gold new file mode 100644 index 0000000..9c6ad45 --- /dev/null +++ b/test/golden/type-projection.gold @@ -0,0 +1,6 @@ +ret > ExitSuccess +out > The type of ?[("b",[1])] is 'Bool +out > Warning: Unsolved meta (b:1) +out > +err > +err > From dd6f862bf69dbaa3de9330db08e4f8365d33a829 Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Fri, 31 Mar 2023 10:44:09 +0100 Subject: [PATCH 85/89] separate examples/stlcRules.act and test/stlcRules.act, which explores corner cases --- Src/Operator.hs | 5 +- examples/stlcRules.act | 12 ++-- test/stlcRules.act | 141 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 150 insertions(+), 8 deletions(-) create mode 100644 test/stlcRules.act diff --git a/Src/Operator.hs b/Src/Operator.hs index 88cf165..b401560 100644 --- a/Src/Operator.hs +++ b/Src/Operator.hs @@ -167,7 +167,10 @@ type instance DEFNOP Abstract = (Operator, Clause) pdefnop :: Parser (DEFNOP Concrete) pdefnop = (,,) <$> ppat - <*> some ((\a (b,c) -> (a, b, c)) <$ ppunc ":" <*> ppat <* ppunc "-" <*> poperator ppat) + <*> some ((\a (b,c) -> (a, b, c)) + <$> withRange (id <$ ppunc ":" <*> ppat + <|> pure (UnderscoreP unknown)) + <* ppunc "-" <*> poperator ppat) <* ppunc "~>" <*> pTM diff --git a/examples/stlcRules.act b/examples/stlcRules.act index 5e10e6b..e7a96b3 100644 --- a/examples/stlcRules.act +++ b/examples/stlcRules.act @@ -50,15 +50,14 @@ judgementform judgementform {type T} check T (t : 'Check => T - 'Value) - {t - 'Bla : 'Semantics} + {} judgementform {} synth (e : 'Synth => S - 'Value) S {type S; e -'Quote : 'Check} -exec 'Type?a. (a ~ 'Nat | PRINTF "%n" a -'Bla.) -{- + -- Open question in the above: will it always be the subject that's fed to an operator? -- Note: the "T - 'Value" is in 'Semantics and that T is the citizen, not the subject @@ -66,15 +65,14 @@ exec 'Type?a. (a ~ 'Nat | PRINTF "%n" a -'Bla.) rule {} - type 'Nat => 'Nat + type 'Nat {'Nat - 'Value ~> 'Natural} - +{- rule {type S; type T} ------------------------ - type ['Arr S T] => ['Arr S T] --- Global assumption: 'Semantics comes with Pi builtin + type ['Arr S T] {['Arr S T] - 'Value ~> ['Pi (S - 'Value) \_. (T - 'Value)]} -- Invariant: the subject in a premise is always something with a name diff --git a/test/stlcRules.act b/test/stlcRules.act new file mode 100644 index 0000000..981b538 --- /dev/null +++ b/test/stlcRules.act @@ -0,0 +1,141 @@ +------------------------------------------------------------------------------ +-- Datatypes + +syntax + { 'Type = ['EnumOrTag ['Nat] + [['Arr 'Type 'Type]] + ] + } + +syntax + { 'Check = ['Tag [ ['Lam ['Bind 'Synth 'Check]] + ['Emb 'Synth] + ]] + ; 'Synth = ['Tag [ ['Ann 'Check 'Type] + ['App 'Synth 'Check] + ]] + } + +-- this is in 'Semantics, or so we declare +syntax -- we're calling in not-'Nat on purpose + { 'Natural = ['EnumOrTag ['Zero] + [['Succ 'Natural]] + ] + } + +{- +----------------------------------------------------------------------------- +-- Judgement forms + +/type : $'Type. +check : ?'Type. $'Check. +synth : $'Synth. !'Type. + + +-- | myCtxt maps synthesisable variables to types +myCtxt |- 'Synth -> 'Type +-} + +------------------------------------------------------------------------------ +-- Judgement forms and their contracts + +-- Something that looks like "Z : A => B" says +-- Z is an A when it's a subject, and a B when it becomes a citizen + +judgementform + {} + type (T : 'Type) -- no '=> B' means the citizen version is the same + {T - 'Value : 'Semantics} + +judgementform + {type T} + check T (t : 'Check => T - 'Value) + {t - 'Bla : 'Semantics} + +judgementform + {} + synth (e : 'Synth => S - 'Value) S + {type S; e -'Quote : 'Check} + + +-- Open question in the above: will it always be the subject that's fed to an operator? +-- Note: the "T - 'Value" is in 'Semantics and that T is the citizen, not the subject + +-- {} myCtxt |- x -> T {synth x T} + +rule + {} + type 'Nat + {'Nat - 'Value ~> 'Natural} + + +rule + {type S; type T} + ------------------------ + type ['Arr S T] => ['Arr S T] +-- Global assumption: 'Semantics comes with Pi builtin + {['Arr S T] - 'Value ~> ['Pi (S - 'Value) \_. (T - 'Value)]} + +-- Invariant: the subject in a premise is always something with a name +-- payoff - the name BECOMES the name of the citizen + +rule + { \ x . synth x S |- check T body } + -- x is a hypothetical inhabitant of S - 'Value + -- hypothetical judgement with fresh x, assuming `synth x S` + -- (note hypothetical judgements have patterns in input and subject + -- positions, and expressions in output positions) + check ~['Arr S T] ['Lam \x. body] => (\x. body) + -- ~['Arr S T] means to not match, but to constrain instead + {} +-- Could equivalently be written without deliberate capture of x: +-- { \ y . synth y S |- check T {x=y}body } + -- note that if we use the above, then we'd expect to capture a y in S - 'Value in body the citizen + -- the elaborator-check that body is used fully generally in the premiss subject + -- needs to return the variables that are in scope for body the citizen + +rule + { synth e S + ; S = T -- by the magic of STLC, things are first-order, this is just unification + } + check T ['Emb e] => e + {} + +-- first arg is a (subject) pattern position +-- 2nd argument is in output position & we give the citizen T +-- Note to selves: holy readability issues! + +rule + { type T + ; check T t + } + synth (['Ann t T] => t) T + {} + +rule + { synth f ~['Arr S T] + ; check S s + } + synth (['App f s] => (f -['app s])) T -- assuming citizen 'f' is meta-level function + -- irrefutable because of no overloading of application (in STLC) + {} + +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +-- Examples +{- +exec check@p. p! ['Arr 'Nat ['Arr 'Nat 'Nat]]. + p! ['Lam \z. ['Lam \_. ['Emb z]]]. +exec check@p. p! ['Arr 'Nat 'Nat]. + p! ['Lam \z. ['Emb z]]. + + +exec check@p. + p! ['Arr 'Nat 'Nat]. + p! ['Lam \z. ['Emb + ['App ['Ann ['Lam \w. ['Emb w]] ['Arr 'Nat 'Nat]] + ['Emb z]]]]. + PRINTF "Victory!". +-} From bb3998d769577f3f0472357820116a83ce88f3d3 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Thu, 6 Apr 2023 15:02:37 +0100 Subject: [PATCH 86/89] [ emacs ] add missing '=>' symbol --- emacs/typos.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/emacs/typos.el b/emacs/typos.el index c44c211..67a42f5 100644 --- a/emacs/typos.el +++ b/emacs/typos.el @@ -9,7 +9,7 @@ "Atom" "AtomBar" "Wildcard" "EnumOrTag" "Enum" "Tag" "Cons" "Nil" "NilOrCons" "Fix" "Bind" "BREAK" "PRINT" "PRINTF")) (setq typos-operators '("@" "!" "$" "?" "~" "#")) -(setq typos-symbols '("|-" "|" "<->" "->" "~>" ";" "=" "{" "}")) +(setq typos-symbols '("|-" "|" "<->" "->" "~>" ";" "=>" "=" "{" "}")) ;; create the regex string for each class of keywords (setq typos-keywords-regexp (regexp-opt typos-keywords 'words)) From aac50deae7f9a7ec1b5e7587138f7c593a14c19e Mon Sep 17 00:00:00 2001 From: Fredrik Nordvall Forsberg Date: Thu, 13 Apr 2023 17:40:59 +0100 Subject: [PATCH 87/89] [ syntax ] wondering about named telescopic things --- Src/Elaboration.hs | 5 +++-- Src/Elaboration/Monad.hs | 11 ++++++++++- Src/Elaboration/Pretty.hs | 3 ++- Src/Operator.hs | 17 ++++++++--------- Src/Operator/Eval.hs | 2 +- test/sot-operator.act | 32 ++++++++++++++++++++++++++++++++ test/telescopic-protocols.act | 20 ++++++++++++++++++++ 7 files changed, 76 insertions(+), 14 deletions(-) create mode 100644 test/sot-operator.act create mode 100644 test/telescopic-protocols.act diff --git a/Src/Elaboration.hs b/Src/Elaboration.hs index c0fde82..fee9fb8 100644 --- a/Src/Elaboration.hs +++ b/Src/Elaboration.hs @@ -38,10 +38,11 @@ import Control.Applicative ((<|>)) import Operator import Operator.Eval import Semantics --- import Debug.Trace (traceShow, traceShowId, trace) import Data.Bifunctor (bimap) import GHC.Stack.Types (HasCallStack) +-- import Debug.Trace (traceShow, traceShowId, trace) + type CPattern = PATTERN Concrete type APattern = PATTERN Abstract @@ -518,7 +519,7 @@ itms :: Range -> String -> Usage -- -> Elab (ASemanticsDesc -- Instantiated return type , [ACTm]) -- Elaborated parameters -itms r op usage [] [] rdesc = (, []) <$> instantiateDesc r rdesc +itms r op usage [] [] rdesc = (, []) <$> (instantiateDesc r rdesc) itms r op usage ((binder, sot):bs) (rp:rps) rdesc = do (ovs :=> desc) <- instantiateSOT (getRange rp) sot (p, dat) <- sparam usage binder B0 (discharge ovs desc) rp diff --git a/Src/Elaboration/Monad.hs b/Src/Elaboration/Monad.hs index 4239451..8076d54 100644 --- a/Src/Elaboration/Monad.hs +++ b/Src/Elaboration/Monad.hs @@ -310,10 +310,19 @@ declareObjVar :: ( {- x :: -} String -> Context {- gamma, x :: S -} declareObjVar (x, sem) ctx = -- We store semantics descs ready to be deployed at use sites - let scp = getObjVars (objVars ctx) :< ObjVar x sem in + let scp = getObjVars (objVars ctx) :< ObjVar x sem + dat = headUpData ctx + in ctx { objVars = ObjVars (fmap weak <$> scp) , binderHints = fmap weak <$> binderHints ctx + , headUpData = dat { huEnv = weakenEnvWith x (huEnv dat) } } + where + -- we extend the global scope so that mangleActors will bring the + -- operator types into local scope during instantiation + weakenEnvWith :: String -> Env' m -> Env' m + weakenEnvWith x env = env { globalScope = globalScope env :< x} + -- Careful! The new ovs better be a valid scope -- i.e. all the objvars mentioned in the SemanticsDesc of diff --git a/Src/Elaboration/Pretty.hs b/Src/Elaboration/Pretty.hs index 398a397..10cd3d8 100644 --- a/Src/Elaboration/Pretty.hs +++ b/Src/Elaboration/Pretty.hs @@ -192,7 +192,8 @@ instance Pretty (WithRange Complaint) where hsep [ "Incompatible semantics descriptions, expected" , prettyPrec 1 desc , "but got" - , prettyPrec 1 desc'] + , prettyPrec 1 desc' + ] IncompatibleSyntaxInfos info1 info2 -> hsep ["Syntax infos" , pretty (WithVarNames B0 <$> info1) , "and", pretty (WithVarNames B0 <$> info2) diff --git a/Src/Operator.hs b/Src/Operator.hs index b401560..8997409 100644 --- a/Src/Operator.hs +++ b/Src/Operator.hs @@ -184,23 +184,22 @@ poperator ph = (,[]) <$> pwithRange patom <|> (,) <$ pch (== '[') <* pspc <*> pwithRange patom <*> many (id <$ pspc <*> ph) <* pspc <* pch (== ']') -pBinders :: Parser (a, b) -> Parser (a, ([(Raw, Variable)], b)) -pBinders p = fmap . (,) <$> many ((,) <$> pTM <* ppunc "\\" <*> pvariable <* pspc <* pch ('.' ==)) <*> p +pBinders :: Parser a -> Parser ([(Raw, Variable)], a) +pBinders p = (,) <$> many ((,) <$> pTM <* ppunc "\\" <*> pvariable <* ppunc ".") <*> p panoperator :: Parser CAnOperator panoperator = do obj <- pmaybeNamed ppat (withRange $ pure $ UnderscoreP unknown) ppunc "-" - (opname, params) <- poperator $ pBinders (pmaybeNamed psemanticsdecl pfail) + (opname, params) <- poperator $ pmaybeNamed (pBinders psemanticsdecl) pfail ppunc ":" AnOperator obj opname (fmap (fmap $ uncurry CSOT) params) <$> psemanticsdecl - where - pmaybeNamed :: Parser a -- if binder + where + pmaybeNamed :: Parser a -- if binder -> Parser a -- if no binder - -> Parser (Binder (ACTORVAR Concrete), a) - pmaybeNamed p q - = pparens ((,) <$> pbinder <* ppunc ":" <*> p) - <|> ((,) . Used <$> pvariable <*> q) + -> Parser (Binder Variable, a) + pmaybeNamed p q = pparens ((,) <$> pbinder <* ppunc ":" <*> p) + <|> ((,) . Used <$> pvariable <*> q) instance Pretty CAnOperator where pretty (AnOperator obj (WithRange _ opName) paramsDesc retDesc) = diff --git a/Src/Operator/Eval.hs b/Src/Operator/Eval.hs index 0c2e0aa..085f90e 100644 --- a/Src/Operator/Eval.hs +++ b/Src/Operator/Eval.hs @@ -32,7 +32,7 @@ data HeadUpData' m = forall i d. HeadUpData , metaStore :: StoreF i d , huOptions :: Options , huEnv :: Env' m - , whatIs :: m -> Maybe (Term' m) + , whatIs :: m -> Maybe (Term' m) -- how to look up meta variables } instance Show (HeadUpData' m) where diff --git a/test/sot-operator.act b/test/sot-operator.act new file mode 100644 index 0000000..e3b7ecf --- /dev/null +++ b/test/sot-operator.act @@ -0,0 +1,32 @@ +syntax { 'Nat = ['EnumOrTag ['Zero] [['Succ 'Nat]]] } + + + + + + + + + + + + + + + + + + +operator + { (n : 'Nat) -['elim (P : 'Nat\x.'Semantics) + (base : {x='Zero}P) + (step : 'Nat\y.{x=y}P\ih.{x=['Succ y]}P) ] : {x=n}P + } + + +operator + { + 'Zero : 'Nat -['elim \x.P base \y ih.step] ~> base ; + ['Succ n] : 'Nat -['elim \x.P base \y ih.step] + ~> {y = n, ih = n -['elim \x.P base \y ih.step]}step + } diff --git a/test/telescopic-protocols.act b/test/telescopic-protocols.act new file mode 100644 index 0000000..ecfac98 --- /dev/null +++ b/test/telescopic-protocols.act @@ -0,0 +1,20 @@ +syntax + { 'Bool = ['Enum ['True 'False]] + ; 'Type = ['EnumOrTag ['Base] [['Arr 'Type 'Type]]] + } + +operator + { (T : 'Type) - 'Meaning : 'Semantics + ; 'Base : 'Type -'Meaning ~> 'Bool + ; ['Arr A B] : 'Type -'Meaning ~> ['Pi (A -'Meaning) \ _. (B -'Meaning)] + } + +inhab : ? A : 'Type. ! A -'Meaning. +inhab@p = p?A. case A + { 'Base -> p!'True. + ; ['Arr S T] -> inhab@q. q!T. q?t. p!\_.t. + } + +exec inhab@p. p!['Arr 'Base ['Arr 'Base 'Base]]. + p?t. + PRINTF "My favourite inhabitant is %i" t. From 287ea2a12ac381dd5c8452835e4e0f4289160cb6 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 18 Apr 2023 17:15:57 +0100 Subject: [PATCH 88/89] [ doc ] design decisions on telescopes' syntax --- syntax.txt | 49 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 49 insertions(+) create mode 100644 syntax.txt diff --git a/syntax.txt b/syntax.txt new file mode 100644 index 0000000..6aa885a --- /dev/null +++ b/syntax.txt @@ -0,0 +1,49 @@ +__________________________________________________________ + | + telescopes in | syntax (^^^ indicates optional parts) +_________________|________________________________________ + | + protocols | [?!$](x,y,z:type). + | ^^^^^^^ ^ +_________________|________________________________________ + | + sot | ^(x,y,z:type).sot + | ^ ^^^^ ^ +_________________|________________________________________ + | + op param decl | (name:sot) + | ^^^^^^ ^ +_________________|________________________________________ + | + op object decl | (name:pat) + | ^^^^^^ ^ +_________________|________________________________________ + | + op object defn | (pat:pat) + | ^ ^^^^^ +_________________|________________________________________ + | + op param defn | \x,y.pat + | ^^^^^ +_________________|________________________________________ + | + actor let | let (x : type) = expr. + | ^ ^ +_________________|________________________________________ + | + actor fresh | make (x,y,z : sot). + | ^ ^^^^ ^ +_________________|________________________________________ + | + actor under | ^(x,y,z : type). + | ^ ^^^^ ^ +_________________|________________________________________ + + in judgementform postcondition: + replace (op [thingy] decl) by schematic variable x means + (x : _) in object position + (x : itstype) in param position + e.g. + {type T} + check T t + { t -['eq T-'Value] : 'Bool} From 80aeb5885ab0744bc6877000fa17868ba627d883 Mon Sep 17 00:00:00 2001 From: Guillaume Allais Date: Tue, 18 Apr 2023 17:16:33 +0100 Subject: [PATCH 89/89] [ cleanup ] examples, tests Added 'Syntax, 'Semantics to emacs mode too --- emacs/typos.el | 1 + examples/stlcRules.act | 43 +++++++++++++---------------------- test/sot-operator.act | 26 ++------------------- test/stlcRules.act | 3 ++- test/telescopic-protocols.act | 2 +- 5 files changed, 22 insertions(+), 53 deletions(-) diff --git a/emacs/typos.el b/emacs/typos.el index 67a42f5..14acf63 100644 --- a/emacs/typos.el +++ b/emacs/typos.el @@ -7,6 +7,7 @@ "break" "unify" "send" "recv" "move" "case" "let" "Atom" "AtomBar" "Wildcard" "EnumOrTag" "Enum" "Tag" "Cons" "Nil" "NilOrCons" "Fix" "Bind" + "Syntax" "Semantics" "BREAK" "PRINT" "PRINTF")) (setq typos-operators '("@" "!" "$" "?" "~" "#")) (setq typos-symbols '("|-" "|" "<->" "->" "~>" ";" "=>" "=" "{" "}")) diff --git a/examples/stlcRules.act b/examples/stlcRules.act index e7a96b3..ca02b85 100644 --- a/examples/stlcRules.act +++ b/examples/stlcRules.act @@ -17,25 +17,12 @@ syntax } -- this is in 'Semantics, or so we declare -syntax -- we're calling in not-'Nat on purpose +syntax -- we're calling it not-'Nat on purpose { 'Natural = ['EnumOrTag ['Zero] [['Succ 'Natural]] ] } -{- ------------------------------------------------------------------------------ --- Judgement forms - -/type : $'Type. -check : ?'Type. $'Check. -synth : $'Synth. !'Type. - - --- | myCtxt maps synthesisable variables to types -myCtxt |- 'Synth -> 'Type --} - ------------------------------------------------------------------------------ -- Judgement forms and their contracts @@ -43,19 +30,19 @@ myCtxt |- 'Synth -> 'Type -- Z is an A when it's a subject, and a B when it becomes a citizen judgementform - {} + {} -- no precondition type (T : 'Type) -- no '=> B' means the citizen version is the same - {T - 'Value : 'Semantics} + {T - 'Value : 'Semantics} -- postcondition: a 'Value operator becomes available judgementform - {type T} - check T (t : 'Check => T - 'Value) - {} + {type T} -- precondition: T has been judged to be a type + check T (t : 'Check => T - 'Value) -- once validated, t becomes its denotational semantics + {} -- no postcondition judgementform {} synth (e : 'Synth => S - 'Value) S - {type S; e -'Quote : 'Check} + {type S} -- postcondition: the output will be a valid type -- Open question in the above: will it always be the subject that's fed to an operator? @@ -65,13 +52,13 @@ judgementform rule {} + --------------------------- (nat) type 'Nat {'Nat - 'Value ~> 'Natural} -{- rule {type S; type T} - ------------------------ + ------------------------------------------------------------ (arr) type ['Arr S T] {['Arr S T] - 'Value ~> ['Pi (S - 'Value) \_. (T - 'Value)]} @@ -84,20 +71,22 @@ rule -- hypothetical judgement with fresh x, assuming `synth x S` -- (note hypothetical judgements have patterns in input and subject -- positions, and expressions in output positions) - check ~['Arr S T] ['Lam \x. body] => (\x. body) + ----------------------------------------------- + check ~['Arr S T] (['Lam \x. body] => \x. body) -- ~['Arr S T] means to not match, but to constrain instead {} -- Could equivalently be written without deliberate capture of x: -- { \ y . synth y S |- check T {x=y}body } - -- note that if we use the above, then we'd expect to capture a y in S - 'Value in body the citizen - -- the elaborator-check that body is used fully generally in the premiss subject - -- needs to return the variables that are in scope for body the citizen +-- note that if we use the above, then we'd expect to capture a y in S - 'Value in body the citizen +-- the elaborator-check that body is used fully generally in the premise subject +-- needs to return the variables that are in scope for body the citizen rule { synth e S ; S = T -- by the magic of STLC, things are first-order, this is just unification } - check T ['Emb e] => e + --------------------- + check T (['Emb e] => e) {} -- first arg is a (subject) pattern position diff --git a/test/sot-operator.act b/test/sot-operator.act index e3b7ecf..73a38f3 100644 --- a/test/sot-operator.act +++ b/test/sot-operator.act @@ -1,32 +1,10 @@ syntax { 'Nat = ['EnumOrTag ['Zero] [['Succ 'Nat]]] } - - - - - - - - - - - - - - - - - operator { (n : 'Nat) -['elim (P : 'Nat\x.'Semantics) (base : {x='Zero}P) (step : 'Nat\y.{x=y}P\ih.{x=['Succ y]}P) ] : {x=n}P - } - - -operator - { - 'Zero : 'Nat -['elim \x.P base \y ih.step] ~> base ; - ['Succ n] : 'Nat -['elim \x.P base \y ih.step] + ; 'Zero : 'Nat -['elim \x.P base \y ih.step] ~> base + ; ['Succ n] : 'Nat -['elim \x.P base \y ih.step] ~> {y = n, ih = n -['elim \x.P base \y ih.step]}step } diff --git a/test/stlcRules.act b/test/stlcRules.act index 981b538..6e9ef8b 100644 --- a/test/stlcRules.act +++ b/test/stlcRules.act @@ -50,7 +50,8 @@ judgementform judgementform {type T} check T (t : 'Check => T - 'Value) - {t - 'Bla : 'Semantics} + { (t : _) -['Bla (T : _)]: 'Semantics + ; (t : _) -['eq (_ : T -'Value)] : 'Bool} judgementform {} diff --git a/test/telescopic-protocols.act b/test/telescopic-protocols.act index ecfac98..629e09c 100644 --- a/test/telescopic-protocols.act +++ b/test/telescopic-protocols.act @@ -9,7 +9,7 @@ operator ; ['Arr A B] : 'Type -'Meaning ~> ['Pi (A -'Meaning) \ _. (B -'Meaning)] } -inhab : ? A : 'Type. ! A -'Meaning. +inhab : ?A : 'Type. ! A -'Meaning. inhab@p = p?A. case A { 'Base -> p!'True. ; ['Arr S T] -> inhab@q. q!T. q?t. p!\_.t.