diff --git a/brat/Brat/Checker.hs b/brat/Brat/Checker.hs index 3b317be0..6bc2643a 100644 --- a/brat/Brat/Checker.hs +++ b/brat/Brat/Checker.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ApplicativeDo #-} + module Brat.Checker (checkBody ,check ,run @@ -5,9 +7,9 @@ module Brat.Checker (checkBody ,kindCheckAnnotation ,kindCheckRow ,tensor + ,CheckConstraints ) where -import Control.Exception (assert) import Control.Monad (foldM, forM, zipWithM_) import Control.Monad.Freer import Data.Bifunctor @@ -19,14 +21,15 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Map as M import Data.Maybe (fromJust) import qualified Data.Set as S -import Data.Type.Equality ((:~:)(..)) +import Data.Traversable (for) +import Data.Type.Equality ((:~:)(..), testEquality) import Prelude hiding (filter) import Brat.Checker.Helpers import Brat.Checker.Monad import Brat.Checker.Quantity import Brat.Checker.SolveHoles (typeEq) -import Brat.Checker.SolvePatterns (argProblems, argProblemsWithLeftovers, solve) +import Brat.Checker.SolvePatterns (argProblems, argProblemsWithLeftovers, solve, typeOfEnd) import Brat.Checker.Types import Brat.Constructors import Brat.Error @@ -109,6 +112,8 @@ type CheckConstraints m k = ,CombineInputs (Inputs m KVerb) ) +-- We're assuming that checkWire is being called in its own fork +-- (it's only called from checkIO) checkWire :: Modey m -> WC (Term d k) -- The term (for error reporting) -> Bool -- Is the "Src" node the expected one? @@ -119,7 +124,7 @@ checkWire Braty _ outputs (dangling, Left ok) (hungry, Left uk) = do throwLeft $ if outputs then kindEq ok uk else kindEq uk ok - defineTgt hungry (endVal ok (ExEnd (end dangling))) + defineTgt' "checkWire" hungry (endVal ok (ExEnd (end dangling))) wire (dangling, kindType ok, hungry) checkWire Braty (WC fc tm) outputs (dangling, o) (hungry, u) = localFC fc $ do let ot = binderToValue Braty o @@ -144,7 +149,7 @@ checkIO :: forall m d k exp act . (CheckConstraints m k, ?my :: Modey m) checkIO tm@(WC fc _) exps acts wireFn errMsg = modily ?my $ do let (rows, rest) = zipSuffixes exps acts localFC fc $ forM rows $ \(e:|exps, a:|acts) -> - wrapError (addRowContext (showRow $ e:exps) (showRow $ a:acts)) $ wireFn e a + mkFork "checkIO" $ wrapError (addRowContext (showRow $ e:exps) (showRow $ a:acts)) $ wireFn e a throwLeft $ first (\(b:|bs) -> TypeErr $ errMsg ++ showRow (b:bs) ++ " for " ++ show tm) rest where addRowContext :: String -> String -> Error -> Error @@ -168,6 +173,7 @@ checkOutputs :: forall m k . (CheckConstraints m k, ?my :: Modey m) -> [(Tgt, BinderType m)] -- Expected -> [(Src, BinderType m)] -- Actual -> Checking [(Tgt, BinderType m)] +checkOutputs _ unders overs | track ("checkOutputs\n " ++ show unders ++ "\n " ++ show overs) False = undefined checkOutputs tm unders overs = checkIO tm unders overs (flip $ checkWire ?my tm True) "No unders but overs: " check :: (CheckConstraints m k @@ -179,7 +185,11 @@ check :: (CheckConstraints m k -> ChkConnectors m d k -> Checking (SynConnectors m d k ,ChkConnectors m d k) -check (WC fc tm) conn = localFC fc (check' tm conn) +check (WC fc tm) conn = do + trackM ("Beginning check of " ++ show tm) + x <- localFC fc (check' tm conn) + trackM ("End check of " ++ show tm) + pure x check' :: forall m d k . (CheckConstraints m k @@ -220,24 +230,28 @@ check' (Lambda c@(WC abstFC abst, body) cs) (overs, unders) = do -- with the other clauses, as part of the body. (ins :->> outs) <- mkSig usedOvers unders (allFakeUnders, rightFakeUnders, tgtMap) <- suppressHoles $ suppressGraph $ do - (_, [], fakeOvers, fakeAcc) <- anext "lambda_fake_source" Hypo (S0, Some (Zy :* S0)) R0 ins - -- Hypo `check` calls need an environment, even just to compute leftovers; - -- we get that env by solving `problem` reformulated in terms of the `fakeOvers` - let srcMap = fromJust $ zipSameLength (fst <$> usedOvers) (fst <$> fakeOvers) - let fakeProblem = [ (fromJust (lookup src srcMap), pat) | (src, pat) <- problem ] - fakeEnv <- localFC abstFC $ solve ?my fakeProblem >>= (solToEnv . snd) + (fakeEnv, fakeAcc) <- "$lhs" -! do + (_, [], fakeOvers, fakeAcc) <- anext' "lambda_fake_source" Hypo (S0, Some (Zy :* S0)) R0 ins SkolemConst + -- Hypo `check` calls need an environment, even just to compute leftovers; + -- we get that env by solving `problem` reformulated in terms of the `fakeOvers` + let srcMap = fromJust $ zipSameLength (fst <$> usedOvers) (fst <$> fakeOvers) + let fakeProblem = [ (fromJust (lookup src srcMap), pat) | (src, pat) <- problem ] + fakeEnv <- localFC abstFC $ solve ?my fakeProblem >>= (solToEnv . snd) + pure (fakeEnv, fakeAcc) localEnv fakeEnv $ do (_, fakeUnders, [], _) <- anext "lambda_fake_target" Hypo fakeAcc outs R0 Just tgtMap <- pure $ zipSameLength (fst <$> fakeUnders) unders - (((), ()), ((), rightFakeUnders)) <- check body ((), fakeUnders) + (((), ()), ((), rightFakeUnders)) <- "$rhs" -! check body ((), fakeUnders) pure (fakeUnders, rightFakeUnders, tgtMap) let usedFakeUnders = (fst <$> allFakeUnders) \\ (fst <$> rightFakeUnders) let usedUnders = [ fromJust (lookup tgt tgtMap) | tgt <- usedFakeUnders ] let rightUnders = [ fromJust (lookup tgt tgtMap) | (tgt, _) <- rightFakeUnders ] - sig <- mkSig usedOvers usedUnders - patOuts <- checkClauses sig usedOvers (c :| cs) - mkWires patOuts usedUnders + mkFork "LambdaChk" $ do + sig <- mkSig usedOvers usedUnders + patOuts <- checkClauses sig usedOvers (c :| cs) + mkWires patOuts usedUnders + pure () pure (((), ()), (rightOvers, rightUnders)) Syny -> do synthOuts <- suppressHoles $ suppressGraph $ do @@ -247,9 +261,9 @@ check' (Lambda c@(WC abstFC abst, body) cs) (overs, unders) = do (solToEnv . snd) (((), synthOuts), ((), ())) <- localEnv env $ check body ((), ()) pure synthOuts - sig <- mkSig usedOvers synthOuts - patOuts <- checkClauses sig usedOvers ((fst c, WC (fcOf body) (Emb body)) :| cs) + patOuts <- checkClauses sig usedOvers + ((fst c, WC (fcOf body) (Emb body)) :| cs) pure (((), patOuts), (rightOvers, ())) where -- Invariant: When solToEnv is called, port pulling has already been resolved, @@ -275,14 +289,19 @@ check' (Lambda c@(WC abstFC abst, body) cs) (overs, unders) = do Nothing -> err $ InternalError "Trying to wire up different sized lists of wires" Just conns -> traverse (\((src, ty), (tgt, _)) -> wire (src, binderToValue ?my ty, tgt)) conns + checkClauses :: CTy m Z -> [(Src, BinderType m)] -> NonEmpty (WC Abstractor, WC (Term Chk Noun)) -> Checking [(Src, BinderType m)] checkClauses cty@(ins :->> outs) overs all_cs = do - let clauses = NE.zip (NE.fromList [0..]) all_cs <&> - \(i, (abs, tm)) -> Clause i (normaliseAbstractor <$> abs) tm - clauses <- traverse (checkClause ?my "lambda" cty) clauses - (_, patMatchUnders, patMatchOvers, _) <- anext "lambda" (PatternMatch clauses) (S0, Some (Zy :* S0)) - ins - outs - mkWires overs patMatchUnders + (node, patMatchUnders, patMatchOvers, _) <- suppressGraph $ + anext "lambda" Hypo (S0, Some (Zy :* S0)) ins outs + mkFork "checkClauses" $ do + let clauses = NE.zip (NE.fromList [0..]) all_cs <&> + \(i, (abs, tm)) -> Clause i (normaliseAbstractor <$> abs) tm + clauses <- traverse (checkClause ?my "lambda" cty) clauses + let inputs = [ (portName p, biType @m ty) | (p, ty) <- patMatchUnders ] + let outputs = [ (portName p, biType @m ty) | (p, ty) <- patMatchOvers ] + req $ AddNode node (mkNode ?my (PatternMatch clauses) inputs outputs) -- not added by anext because suppressGraph + mkWires overs patMatchUnders -- might canonicalize type better now + pure () pure patMatchOvers check' (Pull ports t) (overs, unders) = do @@ -291,7 +310,8 @@ check' (Pull ports t) (overs, unders) = do check' (t ::: outs) (overs, ()) | Braty <- ?my = do (ins :->> outs) :: CTy Brat Z <- kindCheckAnnotation Braty ":::" outs (_, hungries, danglies, _) <- next "id" Id (S0,Some (Zy :* S0)) ins outs - ((), leftOvers) <- noUnders $ check t (overs, hungries) + (((), ()), (leftOvers, unders)) <- check t (overs, hungries) + ensureEmpty "unders" unders pure (((), danglies), (leftOvers, ())) check' (Emb t) (overs, unders) = do ((ins, outs), (overs, ())) <- check t (overs, ()) @@ -299,13 +319,12 @@ check' (Emb t) (overs, unders) = do pure ((ins, ()), (overs, unders)) check' (Th tm) ((), u@(hungry, ty):unders) = case (?my, ty) of (Braty, ty) -> do - ty <- evalBinder Braty ty - case ty of - -- the case split here is so we can be sure we have the necessary CheckConstraints - Right ty@(VFun Braty cty) -> checkThunk Braty "thunk" cty tm >>= wire . (,ty, hungry) - Right ty@(VFun Kerny cty) -> checkThunk Kerny "thunk" cty tm >>= wire . (,ty, hungry) - Left (Star args) -> kindCheck [(hungry, Star args)] (Th tm) $> () - _ -> err . ExpectedThunk "" $ showRow (u:unders) + mkFork "check'Th" $ evalBinder Braty ty >>= \case + -- the case split here is so we can be sure we have the necessary CheckConstraints + Right ty@(VFun Braty cty) -> checkThunk Braty "thunk" cty tm >>= wire . (,ty, hungry) + Right ty@(VFun Kerny cty) -> checkThunk Kerny "thunk" cty tm >>= wire . (,ty, hungry) + Left (Star args) -> kindCheck [(hungry, Star args)] (Th tm) $> () + _ -> err . ExpectedThunk "" $ showRow (u:unders) pure (((), ()), ((), unders)) (Kerny, _) -> err . ThunkInKernel $ show (Th tm) where @@ -327,10 +346,15 @@ check' (Th tm) ((), u@(hungry, ty):unders) = case (?my, ty) of (overs, _) -> err (ThunkLeftOvers (showRow overs)) pure dangling check' (TypedTh t) ((), ()) = case ?my of - -- the thunk itself must be Braty + -- the thunk itself must be Braty... Kerny -> err . ThunkInKernel $ show (TypedTh t) Braty -> do - -- but the computation in it could be either Brat or Kern + -- ...but the computation in it could be either Brat or Kern + -- + -- FIXME: We only want to use one of these branches - any definitions made + -- by the other branch should be undone! + -- Possibly fix by snapshotting the state of the Checking monad, and being + -- biased as to which Mode we prefer. brat <- catchErr $ check t ((), ()) kern <- catchErr $ let ?my = Kerny in check t ((), ()) case (brat, kern) of @@ -350,10 +374,10 @@ check' (TypedTh t) ((), ()) = case ?my of Some (ez :* inR) <- mkArgRo ?my S0 (first (fmap toEnd) <$> ins) Some (_ :* outR) <- mkArgRo ?my ez (first (fmap toEnd) <$> outs) (thunkOut, ()) <- makeBox "thunk" (inR :->> outR) $ - \(thOvers, thUnders) -> do + \(thOvers, thUnders) -> -- if these ensureEmpty's fail then its a bug! - checkInputs t thOvers ins >>= ensureEmpty "TypedTh inputs" - checkOutputs t thUnders outs >>= ensureEmpty "TypedTh outputs" + (checkInputs t thOvers ins >>= ensureEmpty "TypedTh inputs") *> + (checkOutputs t thUnders outs >>= ensureEmpty "TypedTh outputs") pure (((), [thunkOut]), ((), ())) check' (Force th) ((), ()) = do (((), outs), ((), ())) <- let ?my = Braty in check th ((), ()) @@ -377,17 +401,19 @@ check' (Arith op l r) ((), u@(hungry, ty):unders) = case (?my, ty) of Right TInt -> check_arith TInt Right TFloat -> check_arith TFloat _ -> err . ArithNotExpected $ show u - pure (((), ()), ((), unders)) (Kerny, _) -> err ArithInKernel where check_arith ty = let ?my = Braty in do let inRo = RPr ("left", ty) $ RPr ("right", ty) R0 let outRo = RPr ("out", ty) R0 (_, [lunders, runders], [(dangling, _)], _) <- next (show op) (ArithNode op) (S0, Some $ Zy :* S0) inRo outRo - (((), ()), ((), leftUnders)) <- check l ((), [lunders]) - ensureEmpty "arith unders" leftUnders - (((), ()), ((), leftUnders)) <- check r ((), [runders]) - ensureEmpty "arith unders" leftUnders + let lhs = do + (((), ()), ((), leftUnders)) <- check l ((), [lunders]) + ensureEmpty "arith unders" leftUnders + let rhs = do + (((), ()), ((), leftUnders)) <- check r ((), [runders]) + ensureEmpty "arith unders" leftUnders + () <$ lhs <* rhs wire (dangling, ty, hungry) pure (((), ()), ((), unders)) check' (fun :$: arg) (overs, unders) = do @@ -401,6 +427,7 @@ check' (fun :$: arg) (overs, unders) = do ] check' (Let abs x y) conn = do (((), dangling), ((), ())) <- check x ((), ()) + -- TODO: Get rid of this: only use of abstractAll - replace with SolvePatterns env <- abstractAll dangling (unWC abs) localEnv env $ check y conn check' (NHole (mnemonic, name)) connectors = do @@ -446,21 +473,34 @@ check' (VHole (mnemonic, name)) connectors = do pure (((), ()), ([], [])) -- TODO: Better error message check' tm@(Con _ _) ((), []) = typeErr $ "No type to check " ++ show tm ++ " against" -check' tm@(Con vcon vargs) ((), (hungry, ty):unders) = case (?my, ty) of - (Braty, Left k) -> do - (_, leftOvers) <- kindCheck [(hungry, k)] (Con vcon vargs) - ensureEmpty "kindCheck leftovers" leftOvers - pure (((), ()), ((), unders)) - (Braty, Right ty) -> aux Braty clup ty $> (((), ()), ((), unders)) - (Kerny, _) -> aux Kerny kclup ty $> (((), ()), ((), unders)) +check' (Con vcon vargs) ((), (hungry, ty):unders) = do + trackM ("check' Con vcon=" ++ show vcon ++ " vargs=" ++ show vargs) + mkFork "check'Con" $ case (?my, ty) of + (Braty, Left k) -> do + (_, leftOvers) <- kindCheck [(hungry, k)] (Con vcon vargs) + ensureEmpty "kindCheck leftovers" leftOvers + (Braty, Right ty) -> aux Braty clup ty + (Kerny, _) -> track "Kerny" $ aux Kerny kclup ty + pure (((), ()), ((), unders)) where aux :: Modey m -> (QualName -> QualName -> Checking (CtorArgs m)) -> Val Z -> Checking () aux my lup ty = do - VCon tycon tyargs <- eval S0 ty + -- TODO: Use concurrency to avoid strictness - we don't have to work out that + -- this is a VCon immediately. + VCon tycon tyargs <- awaitTypeDefinition ty (CArgs pats nFree _ argTypeRo) <- lup vcon tycon -- Look for vectors to produce better error messages for mismatched lengths - wrap <- detectVecErrors vcon tycon tyargs pats ty (Left tm) - Some (ny :* env) <- throwLeft $ valMatches tyargs pats + -- wrap <- detectVecErrors vcon tycon tyargs pats ty (Left tm) + -- Get the kinds of type args + let m = deModey my -- TODO: remember what this is + (_, ks) <- unzip <$> tlup (m, tycon) + -- Turn `pats` into values for unification + (varz, patVals) <- "$!" -! valPats2Val ks pats + -- Create a unification problem between tyargs and the value versions of pats + typeEq (show tycon) (TypeFor m []) (VCon tycon tyargs) (VCon tycon patVals) + ty <- eval S0 ty + trackM $ "Made it past unification for ty = " ++ show ty + Some (ny :* env) <- pure $ bwdStack varz -- Make sure env is the correct length for args Refl <- throwLeft $ natEqOrBust ny nFree let topy = roTopM my ny argTypeRo @@ -471,7 +511,7 @@ check' tm@(Con vcon vargs) ((), (hungry, ty):unders) = case (?my, ty) of (_, argUnders, [(dangling, _)], _) <- anext (show vcon) (Constructor vcon) (env, Some (Zy :* S0)) argTypeRo (RPr ("value", ty') R0) - (((), ()), ((), leftUnders)) <- wrapError wrap $ check vargs ((), argUnders) + (((), ()), ((), leftUnders)) <- {- wrapError wrap $ -} check vargs ((), argUnders) ensureEmpty "con unders" leftUnders wire (dangling, ty, hungry) @@ -490,13 +530,14 @@ check' (Simple tm) ((), (hungry, ty):unders) = do R0 (REx ("value", Nat) R0) let val = VNum (nConstant (fromIntegral n)) defineSrc dangling val - defineTgt hungry val + defineTgt' "check.simple" hungry val wire (dangling, kindType Nat, hungry) pure (((), ()), ((), unders)) -- No defining needed, so everything else can be unified _ -> do let vty = biType @m ty - throwLeft $ simpleCheck ?my vty tm + vty <- awaitTypeDefinition vty + simpleCheck ?my vty tm (_, _, [(dangling, _)], _) <- anext @m "const" (Const tm) (S0,Some (Zy :* S0)) R0 (RPr ("value", vty) R0) wire (dangling, vty, hungry) @@ -552,7 +593,7 @@ check' FanIn (overs, (tgt, ty):unders) = do wire (dangling, binderToValue my ty, tgt) pure (Just overs) faninNodes _ _ _ _ [] = pure Nothing - faninNodes my n (hungry, ty) elTy ((over, overTy):overs) = do + faninNodes my n (hungry, ty) elTy ((over, overTy):overs) = "$fanin" -! do let k = case my of Kerny -> Dollar [] Braty -> Star [] @@ -591,7 +632,7 @@ check' (Of n e) ((), unders) = case ?my of -- Wire the length into all the replicate nodes for_ lenIns $ \(tgt, _) -> do wire (natOver, kindType Nat, tgt) - defineTgt tgt n + defineTgt' "Of" tgt n (((), ()), ((), elemRightUnders)) <- check e ((), repUnders) -- If `elemRightUnders` isn't empty, it means we were too greedy -- in the call to getVecs, so we should work out which elements of @@ -602,9 +643,11 @@ check' (Of n e) ((), unders) = case ?my of -- Wire up the outputs of the replicate nodes to the _used_ vec -- unders. The remainder of the replicate nodes don't get used. -- (their inputs live in `elemRightUnders`) - assert (length repOvers >= length usedVecUnders) $ do + if length repOvers >= length usedVecUnders + then do zipWithM_ (\(dangling, _) (hungry, ty) -> wire (dangling, ty, hungry)) repOvers usedVecUnders pure (((), ()), ((), (second Right <$> unusedVecUnders) ++ rightUnders)) + else error $ "repOvers " ++ show repOvers ++ "should be >= usedVecUnders " ++ show usedVecUnders _ -> localFC (fcOf e) $ typeErr "No type dependency allowed when using `of`" Syny -> do @@ -619,7 +662,7 @@ check' (Of n e) ((), unders) = case ?my of let (lenIns, elemIns, vecOuts) = unzip3 conns for_ lenIns $ \(tgt,_) -> do wire (natOver, kindType Nat, tgt) - defineTgt tgt n + defineTgt' "Of syn" tgt n zipWithM_ (\(dangling, ty) (hungry, _) -> wire (dangling, ty, hungry)) outputs elemIns pure (((), vecOuts), ((), ())) _ -> localFC (fcOf e) $ typeErr "No type dependency allowed when using `of`" @@ -660,10 +703,15 @@ check' (Of n e) ((), unders) = case ?my of (elems, unders, rightUnders) <- getVecs len unders pure ((tgt, el):elems, (tgt, ty):unders, rightUnders) getVecs _ unders = pure ([], [], unders) -check' Hope ((), (NamedPort hope _, ty):unders) = case (?my, ty) of - (Braty, Left _k) -> do +check' (Hope ident) ((), (tgt@(NamedPort bang _), ty):unders) = case (?my, ty) of + (Braty, Left k) -> do + (_, [(hungry, _)], [(dangling, _)], _) <- anext ("$!" ++ ident) Id (S0, Some (Zy :* S0)) + (REx ("hope", k) R0) (REx ("hope", k) R0) fc <- req AskFC - req (ANewHope hope fc) + wire (dangling, kindType k, NamedPort bang "") + defineTgt' "check hope (tgt)" tgt (endVal k (toEnd hungry)) + defineSrc' "check hope (src)" dangling (endVal k (toEnd hungry)) + req (ANewDynamic (end hungry) fc) pure (((), ()), ((), unders)) (Braty, Right _ty) -> typeErr "Can only infer kinded things with !" (Kerny, _) -> typeErr "Won't infer kernel typed !" @@ -695,29 +743,116 @@ checkClause my fnName cty clause = modily my $ do -- First, we check the patterns on the LHS. This requires some overs, -- so we make a box, however this box will be skipped during compilation. - (vars, match, rhsCty) <- suppressHoles . fmap snd $ - let ?my = my in makeBox (clauseName ++ "_setup") cty $ + (sol, match, rhsCty, defs) <- suppressHoles . fmap snd $ + let ?my = my in ("$lhs" -!) $ makeBox (clauseName ++ "_setup") cty $ \(overs, unders) -> do -- Make a problem to solve based on the lhs and the overs problem <- argProblems (fst <$> overs) (unWC $ lhs clause) [] (tests, sol) <- localFC (fcOf (lhs clause)) $ solve my problem + (sol, defs) :: ([(String, (Src, BinderType m))], [((String, TypeKind), Val Z)]) <- case my of + Braty -> postProcessSolAndOuts sol unders + Kerny -> pure (sol, []) -- The solution gives us the variables bound by the patterns. -- We turn them into a row - Some (patEz :* patRo) <- mkArgRo my S0 ((\(n, (src, ty)) -> (NamedPort (toEnd src) n, ty)) <$> sol) - -- Also make a row for the refined outputs (shifted by the pattern environment) - Some (_ :* outRo) <- mkArgRo my patEz (first (fmap toEnd) <$> unders) - let match = TestMatchData my $ MatchSequence overs tests (snd <$> sol) - let vars = fst <$> sol - pure (vars, match, patRo :->> outRo) + mkArgRo my S0 ((\(n, (src, ty)) -> (NamedPort (toEnd src) n, ty)) <$> sol) >>= \case + -- Also make a row for the refined outputs (shifted by the pattern environment) + Some (patEz :* patRo) -> mkArgRo my patEz (first (fmap toEnd) <$> unders) >>= \case + Some (_ :* outRo) -> do + let testOuts = snd <$> sol + let match = TestMatchData my (MatchSequence overs tests testOuts) + trackM $ "[[[[[[TestMatchData\n" ++ show match ++ "\n]]]]]]" + pure (sol, match, patRo :->> outRo, fmap (Some . (patEz :*) . abstractEndz patEz) <$> defs) + + for defs $ \((name, kind), Some (_ :* val)) -> trackM ("Def: " ++ show ((name, kind), val)) -- Now actually make a box for the RHS and check it ((boxPort, _ty), _) <- let ?my = my in makeBox (clauseName ++ "_rhs") rhsCty $ \(rhsOvers, rhsUnders) -> do - let abstractor = foldr ((:||:) . APat . Bind) AEmpty vars - let ?my = my in do - env <- abstractAll rhsOvers abstractor - localEnv env $ check @m (rhs clause) ((), rhsUnders) + defs :: Env (EnvData m) <- case my of + Braty -> do + let kindedRhsOvers = [ toEnd src | (src, Left _) <- rhsOvers ] + case Some S0 <><< kindedRhsOvers of + Some stk -> foldMap (\((name, k), Some (stk' :* val)) -> case (stkLen stk, testEquality (stkLen stk) (stkLen stk')) of + (ny, Just Refl) -> do + src <- mkGraph k (changeVar (InxToPar (AddZ ny) stk) val) + singletonEnv name (src, Left k) + (_, Nothing) -> err $ InternalError "Invariant violated: Number of deps in defs") defs + Kerny -> pure emptyEnv + case my of + Braty -> trackM $ "Updated defs: " ++ show defs + _ -> pure () + + -- Here we're relying too much on the implementation of typeEq, counting on + -- the fact that it'll define the first argument in the flex-flex case that + -- would arise if we've not yet defined the outer src + let vars = fst <$> sol + env <- mkEnv vars rhsOvers + (localEnv (env <> defs) $ "$rhs" -! check @m (rhs clause) ((), rhsUnders)) let NamedPort {end=Ex rhsNode _} = boxPort pure (match, rhsNode) + where + (<><<) :: Some (Stack Z End) -> [End] -> Some (Stack Z End) + (Some stk) <><< [] = Some stk + (Some stk) <><< (x:xs) = Some (stk :<< x) <><< xs + + -- Process a solution, finding Ends that support the solved types, and return a list of definitions for substituting later on + postProcessSolAndOuts :: [(String, (Src, BinderType Brat))] -> [(Tgt, BinderType Brat)] -> Checking ([(String, (Src, BinderType Brat))], [((String, TypeKind), Val Z)]) + postProcessSolAndOuts sol outputs = worker B0 sol + where + worker :: Bwd (String, (Src, BinderType Brat)) -> [(String, (Src, BinderType Brat))] -> Checking ([(String, (Src, BinderType Brat))], [((String, TypeKind), Val Z)]) + worker zx [] = (, []) <$> outputDeps zx [] outputs + worker zx (entry@(patVar, (src, Left k)):sol) = let vsrc = VApp (VPar (toEnd src)) B0 in do + trackM ("processSol (kinded): " ++ show entry) + def <- eval S0 vsrc + if def == vsrc + then worker (zx :< entry) sol + else do + outPorts <- depOutPorts def + srcAndTys <- for outPorts (\outport -> (NamedPort outport "",) <$> typeOfEnd Braty (ExEnd outport)) + zx <- pure $ foldl (\sol srcAndTy -> insert ("$" ++ show (end (fst srcAndTy)), srcAndTy) sol) zx srcAndTys + (sol, defs) <- worker (zx {-:< entry-}) sol + pure ({-(patVar, (src, Left k)):-}sol, ((patVar, k), def):defs) + -- Pat vars beginning with '_' aren't in scope, we can ignore them + -- (but if they're kinded they might come up later as the dependency of something else) + worker zx (('_':_, _):sol) = worker zx sol + worker zx (entry@(_patVar, (_src, Right ty)):sol) = do + trackM ("processSol (typed): " ++ show entry) + ty <- eval S0 ty + outPorts <- depOutPorts ty + srcAndTys <- for outPorts (\outport -> (NamedPort outport "",) <$> typeOfEnd Braty (ExEnd outport)) + zx <- pure $ foldl (\sol srcAndTy -> insert ("___" ++ show (end (fst srcAndTy)), srcAndTy) sol) zx srcAndTys + worker (zx :< entry) sol + + insert :: (String, (Src, BinderType Brat)) -> Bwd (String, (Src, BinderType Brat)) -> Bwd (String, (Src, BinderType Brat)) + insert entry@(_, (src, _)) entryz + | any (\(_, (src', _f)) -> src == src') entryz = entryz + | otherwise = track ("insert: " ++ show entry) $ entryz :< entry + + outputDeps :: Bwd (String, (Src, BinderType Brat)) -- The solution for inputs, so we can make sure we don't duplicate anything + -> [Tgt] -- Kinded outputs that we're aware of and want to leave out of the solution + -> [(Tgt, BinderType Brat)] -- Outputs we're searching for dependencies + -> Checking [(String, (Src, BinderType Brat))] + outputDeps sol _ [] = pure (sol <>> []) + outputDeps sol ignoredTgts ((tgt, Left _):rest) = outputDeps sol (tgt:ignoredTgts) rest + outputDeps sol ignoredTgts ((_tgt, Right ty):rest) = do + ty <- eval S0 ty + let deps = [ outport | ExEnd outport <- depEnds ty] + depsWithTys <- for deps (\outport -> (NamedPort outport "",) <$> typeOfEnd Braty (ExEnd outport)) + sol <- pure $ foldl (\sol srcAndTy -> insert ("___" ++ show (end (fst srcAndTy)), srcAndTy) sol) sol depsWithTys + outputDeps sol ignoredTgts rest + + -- We could use some checks around the locality of these things. Are they + -- all defined in terms of things which are generated by pattern tests? + depOutPorts :: (Show t, DepEnds t) => t -> Checking [OutPort] + depOutPorts x = for (depEnds x) $ \case + ExEnd outport -> pure outport + InEnd inport -> err . TypeErr $ "Type dependency of " ++ show x ++ " (" ++ show inport ++ ") had an ambiguous type." + + mkEnv :: (?my :: Modey m) => [String] -> [(Src, BinderType m)] -> Checking (Env (EnvData m)) + mkEnv (x:xs) (src:srcs) = do + e1 <- singletonEnv x src + e2 <- mkEnv xs srcs + mergeEnvs [e1, e2] + mkEnv [] [] = pure emptyEnv -- Top level function for type checking function definitions -- Will make a top-level box for the function, then type check the definition @@ -792,7 +927,7 @@ kindCheck ((hungry, k@(TypeFor m [])):unders) (Con c arg) = req (TLup (m, c)) >> ensureEmpty "kindCheck unders" emptyUnders -- now evVa can pick up the definitions value <- eval S0 $ VCon c [ endVal k (InEnd (end tgt)) | (tgt, k) <- kindArgs ] - defineTgt hungry value + defineTgt' "kind0" hungry value defineSrc dangling value wire (dangling, kindType k, hungry) pure ([value],unders) @@ -812,7 +947,7 @@ kindCheck ((hungry, k@(TypeFor m [])):unders) (Con c arg) = req (TLup (m, c)) >> ensureEmpty "alias args" emptyUnders val <- apply aliasLam args defineSrc kindOut val - defineTgt hungry val + defineTgt' "kind1" hungry val wire (kindOut, kindType k, hungry) pure ([val], unders) Nothing -> typeErr $ "Can't find type constructor or type alias " ++ show c @@ -823,7 +958,7 @@ kindCheck ((hungry, Star []):unders) (C (ss :-> ts)) = do (i, env, Some (ez :* inRo)) -> kindCheckRow' Braty ez env (name, i) ts >>= \case (_, _, Some (_ :* outRo)) -> do let val = VFun Braty (inRo :->> outRo) - defineTgt hungry val + defineTgt' "kind2" hungry val pure ([val], unders) kindCheck ((hungry, Star []):unders) (K (ss :-> ts)) = do -- N.B. Kernels can't bind so we don't need to pass around a stack of ends @@ -833,7 +968,7 @@ kindCheck ((hungry, Star []):unders) (K (ss :-> ts)) = do (Some ss, Some ts) -> case kernelNoBind ss of Refl -> do let val = VFun Kerny (ss :->> ts) - defineTgt hungry val + defineTgt' "kind3" hungry val pure ([val], unders) -- N.B. This code is currently only called for checking the validity of type aliases @@ -853,7 +988,7 @@ kindCheck ((hungry, TypeFor m args):unders) (Th (WC _ (Lambda (xs, WC fc body) [ vbody <- eval S0 vbody let vlam = case endz of Some (ny :* endz) -> lambdify endz (changeVar (ParToInx (AddZ ny) endz) vbody) - defineTgt hungry vlam + defineTgt' "kind4" hungry vlam pure ([vlam], unders) where lambdify :: Stack Z End i -> Val i -> Val Z @@ -870,7 +1005,7 @@ kindCheck unders (Emb (WC fc (Var v))) = localFC fc $ vlup v >>= f unders throwLeft $ kindEq k k' wire (dangling, kindType k, hungry) value <- eval S0 (endVal k (ExEnd (end dangling))) - defineTgt hungry value + defineTgt' "kind5" hungry value (vs, leftUnders) <- f us xs pure (value:vs, leftUnders) f _ (x:_) = err $ InternalError $ "Kindchecking a row which contains " ++ show x @@ -878,7 +1013,7 @@ kindCheck unders (Emb (WC fc (Var v))) = localFC fc $ vlup v >>= f unders kindCheck ((hungry, Nat):unders) (Simple (Num n)) | n >= 0 = do (_, _, [(dangling, _)], _) <- next "const" (Const (Num n)) (S0,Some (Zy :* S0)) R0 (REx ("value", Nat) R0) let value = VNum (nConstant (fromIntegral n)) - defineTgt hungry value + defineTgt' "kind6" hungry value defineSrc dangling value wire (dangling, TNat, hungry) pure ([value], unders) @@ -893,7 +1028,7 @@ kindCheck ((hungry, Nat):unders) (Arith op lhs rhs) = do case runArith lhs op rhs of Nothing -> typeErr "Type level arithmetic too confusing" Just result -> do - defineTgt hungry (VNum result) + defineTgt' "kind7" hungry (VNum result) defineSrc dangling (VNum result) wire (dangling, kindType Nat, hungry) pure ([VNum result], unders) @@ -911,7 +1046,7 @@ kindCheck ((hungry, Nat):unders) (Con c arg) ensureEmpty "kindCheck unders" us v <- eval S0 (VNum (f nv)) defineSrc cdangling v - defineTgt hungry v + defineTgt' "kind8" hungry v pure ([v], unders) kindCheck ((_, k):_) tm = typeErr $ "Expected " ++ show tm ++ " to have kind " ++ show k @@ -956,7 +1091,7 @@ kindCheckRow' :: forall m n kindCheckRow' _ ez env (_,i) [] = pure (i, env, Some (ez :* R0)) kindCheckRow' Braty (ny :* s) env (name,i) ((p, Left k):rest) = do -- s is Stack Z n let dangling = Ex name (ny2int ny) - req (Declare (ExEnd dangling) Braty (Left k)) + req (Declare (ExEnd dangling) Braty (Left k) Definable) -- assume none are SkolemConst?? env <- pure $ M.insert (plain p) [(NamedPort dangling p, Left k)] env (i, env, ser) <- kindCheckRow' Braty (Sy ny :* (s :<< ExEnd dangling)) env (name, i) rest case ser of @@ -1054,9 +1189,9 @@ abstractPattern :: forall m -> Pattern -> Checking (Env (EnvData m)) -- Local env for checking body of lambda abstractPattern m (src, ty) (Bind x) = let ?my = m in singletonEnv x (src, ty) -abstractPattern Braty (_, Left Nat) (Lit tm) = throwLeft (simpleCheck Braty TNat tm) $> emptyEnv -abstractPattern Braty (_, Right ty) (Lit tm) = throwLeft (simpleCheck Braty ty tm) $> emptyEnv -abstractPattern Kerny (_, ty) (Lit tm) = throwLeft (simpleCheck Kerny ty tm) $> emptyEnv +abstractPattern Braty (_, Left Nat) (Lit tm) = simpleCheck Braty TNat tm $> emptyEnv +abstractPattern Braty (_, Right ty) (Lit tm) = simpleCheck Braty ty tm $> emptyEnv +abstractPattern Kerny (_, ty) (Lit tm) = simpleCheck Kerny ty tm $> emptyEnv abstractPattern Braty (dangling, Left k) pat = abstractKind k pat where abstractKind :: TypeKind -> Pattern -> Checking (Env (EnvData Brat)) @@ -1130,7 +1265,7 @@ run :: VEnv -> Store -> Namespace -> Checking a - -> Either Error (a, ([TypedHole], Store, Graph)) + -> Either Error (a, ([TypedHole], Store, Graph, CaptureSets)) run ve initStore ns m = do let ctx = Ctx { globalVEnv = ve , store = initStore @@ -1140,18 +1275,20 @@ run ve initStore ns m = do , typeConstructors = defaultTypeConstructors , aliasTable = M.empty , hopes = M.empty + , dynamicSet = M.empty + , captureSets = M.empty } (a,ctx,(holes, graph)) <- handler (localNS ns m) ctx mempty let tyMap = typeMap $ store ctx -- If the `hopes` set has any remaining holes with kind Nat, we need to abort. -- Even though we didn't need them for typechecking problems, our runtime -- behaviour depends on the values of the holes, which we can't account for. - case M.toList $ M.filterWithKey (\e _ -> isNatKinded tyMap (InEnd e)) (hopes ctx) of - [] -> pure (a, (holes, store ctx, graph)) + case M.toList $ M.filterWithKey (\e _ -> isNatKinded tyMap e) (dynamicSet ctx) of + [] -> pure (a, (holes, store ctx, graph, captureSets ctx)) -- Just use the FC of the first hole while we don't have the capacity to -- show multiple error locations hs@((_,fc):_) -> Left $ Err (Just fc) (RemainingNatHopes (show . fst <$> hs)) where - isNatKinded tyMap e = case tyMap M.! e of - EndType Braty (Left Nat) -> True + isNatKinded tyMap e = case tyMap M.! (InEnd e) of + (EndType Braty (Left Nat), _) -> True _ -> False diff --git a/brat/Brat/Checker/Helpers.hs b/brat/Brat/Checker/Helpers.hs index 9b0871e5..38d78c63 100644 --- a/brat/Brat/Checker/Helpers.hs +++ b/brat/Brat/Checker/Helpers.hs @@ -1,56 +1,62 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -module Brat.Checker.Helpers {-(pullPortsRow, pullPortsSig - ,simpleCheck - ,combineDisjointEnvs - ,ensureEmpty, noUnders - ,rowToSig - ,showMode, getVec - ,mkThunkTy - ,wire - ,next, knext, anext - ,kindType, getThunks - ,binderToValue, valueToBinder - ,kConFields - ,defineSrc, defineTgt - ,declareSrc, declareTgt - ,makeBox - ,uncons - ,evalBinder - ,evalSrcRow, evalTgtRow - )-} where - -import Brat.Checker.Monad (Checking, CheckingSig(..), captureOuterLocals, err, typeErr, kindArgRows, defineEnd) +module Brat.Checker.Helpers where + +import Brat.Checker.Monad (Checking, CheckingSig(..), captureOuterLocals, err, typeErr, kindArgRows, defineEnd, tlup, isSkolem, mkYield, throwLeft) import Brat.Checker.Types import Brat.Error (ErrorMsg(..)) -import Brat.Eval (eval, EvMode(..), kindType) +import Brat.Eval (eval, EvMode(..), kindType, quote, doesntOccur) import Brat.FC (FC) import Brat.Graph (Node(..), NodeType(..)) -import Brat.Naming (Name, FreshMonad(..)) +import Brat.Naming (FreshMonad(..), Name(..)) import Brat.Syntax.Common import Brat.Syntax.Core (Term(..)) import Brat.Syntax.Simple -import Brat.Syntax.Port (ToEnd(..)) +import Brat.Syntax.Port (ToEnd(..), endName) import Brat.Syntax.Value import Bwd import Hasochism import Util (log2) +import Control.Monad ((>=>)) +import Control.Monad.Freer import Control.Monad.State.Lazy (StateT(..), runStateT) -import Control.Monad.Freer (req) import Data.Bifunctor import Data.Foldable (foldrM) import Data.List (partition) +import Data.Maybe (isJust) import Data.Type.Equality (TestEquality(..), (:~:)(..)) -import qualified Data.Map as M +import qualified Data.Set as S import Prelude hiding (last) -simpleCheck :: Modey m -> Val Z -> SimpleTerm -> Either ErrorMsg () -simpleCheck Braty TNat (Num n) | n >= 0 = pure () -simpleCheck Braty TInt (Num _) = pure () -simpleCheck Braty TFloat (Float _) = pure () -simpleCheck Braty TText (Text _) = pure () -simpleCheck _ ty tm = Left $ TypeErr $ unwords +trackPermission = const id +--trackPermission = trace + +simpleCheck :: Modey m -> Val Z -> SimpleTerm -> Checking () +simpleCheck my ty tm = case (my, ty) of + (Braty, VApp (VPar e) _) -> do + mine <- mineToSolve + if isJust (mine e) then + case tm of + Float _ -> defineEnd "simpleCheck" e TFloat + Text _ -> defineEnd "simpleCheck" e TText + Num n | n < 0 -> defineEnd "simpleCheck" e TInt + Num _ -> typeErr $ "Can't determine whether Int or Nat: " ++ show tm + _ -> typeErr $ "Unimplemented: checking literal: " ++ show tm + else isSkolem e >>= \case + SkolemConst -> throwLeft $ helper Braty ty tm + Definable -> do + mkYield "simpleCheck" (S.singleton e) + ty <- eval S0 ty + simpleCheck Braty ty tm + _ -> throwLeft $ helper my ty tm + where + helper :: Modey m -> Val Z -> SimpleTerm -> Either ErrorMsg () + helper Braty TNat (Num n) | n >= 0 = pure () + helper Braty TInt (Num _) = pure () + helper Braty TFloat (Float _) = pure () + helper Braty TText (Text _) = pure () + helper _ ty tm = Left $ TypeErr $ unwords ["Expected something of type" ,"`" ++ show ty ++ "`" ,"but got" @@ -109,7 +115,7 @@ pullPortsSig :: Show ty -> Checking [(PortName, ty)] pullPortsSig = pullPorts fst showSig -pullPorts :: forall a ty +pullPorts :: forall a . (a -> PortName) -- A way to get a port name for each element -> ([a] -> String) -- A way to print the list -> [PortName] -- Things to pull to the front @@ -129,11 +135,6 @@ ensureEmpty :: Show ty => String -> [(NamedPort e, ty)] -> Checking () ensureEmpty _ [] = pure () ensureEmpty str xs = err $ InternalError $ "Expected empty " ++ str ++ ", got:\n " ++ showSig (rowToSig xs) -noUnders m = do - ((outs, ()), (overs, unders)) <- m - ensureEmpty "unders" unders - pure (outs, overs) - rowToSig :: Traversable t => t (NamedPort e, ty) -> t (PortName, ty) rowToSig = fmap $ first portName @@ -166,26 +167,40 @@ anext :: forall m i j k -> Ro m i j -- Inputs and Outputs use de Bruijn indices -> Ro m j k -> Checking (Name, Unders m Chk, Overs m UVerb, (Semz k, Some Endz)) -anext str th vals0 ins outs = do +anext str th vals0 ins outs = anext' str th vals0 ins outs $ case th of + Source -> SkolemConst + _ -> Definable + +anext' :: forall m i j k + . EvMode m + => String + -> NodeType m + -> (Semz i, Some Endz) + -> Ro m i j -- Inputs and Outputs use de Bruijn indices + -> Ro m j k + -> IsSkolem -- inports are always Definable + -> Checking (Name, Unders m Chk, Overs m UVerb, (Semz k, Some Endz)) +anext' str th vals0 ins outs skol = do node <- req (Fresh str) -- Pick a name for the thunk -- Use the new name to generate Ends with which to instantiate types (unders, vals1) <- endPorts node InEnd In 0 vals0 ins (overs, vals2) <- endPorts node ExEnd Ex 0 vals1 outs () <- sequence_ $ [ declareTgt tgt (modey @m) ty | (tgt, ty) <- unders ] ++ - [ declareSrc src (modey @m) ty | (src, ty) <- overs ] + [ req (Declare (ExEnd (end src)) (modey @m) ty skol) | (src, ty) <- overs ] + let inputs = [ (portName p, biType @m ty) | (p, ty) <- unders ] let outputs = [ (portName p, biType @m ty) | (p, ty) <- overs ] () <- req (AddNode node (mkNode (modey @m) th inputs outputs)) pure (node, unders, overs, vals2) - where - mkNode :: forall m. Modey m -> NodeType m - -> [(PortName, Val Z)] - -> [(PortName, Val Z)] - -> Node - mkNode Braty = BratNode - mkNode Kerny = KernelNode + +mkNode :: forall m. Modey m -> NodeType m + -> [(PortName, Val Z)] + -> [(PortName, Val Z)] + -> Node +mkNode Braty = BratNode +mkNode Kerny = KernelNode type Endz = Ny :* Stack Z End @@ -245,14 +260,14 @@ getThunks :: Modey m ) getThunks _ [] = pure ([], [], []) getThunks Braty ((src, Right ty):rest) = do - ty <- eval S0 ty + ty <- awaitTypeDefinition ty (src, ss :->> ts) <- vectorise Braty (src, ty) (node, unders, overs, _) <- let ?my = Braty in anext "Eval" (Eval (end src)) (S0, Some (Zy :* S0)) ss ts (nodes, unders', overs') <- getThunks Braty rest pure (node:nodes, unders <> unders', overs <> overs') getThunks Kerny ((src, Right ty):rest) = do - ty <- eval S0 ty + ty <- awaitTypeDefinition ty (src, ss :->> ts) <- vectorise Kerny (src,ty) (node, unders, overs, _) <- let ?my = Kerny in anext "Splice" (Splice (end src)) (S0, Some (Zy :* S0)) ss ts (nodes, unders', overs') <- getThunks Kerny rest @@ -272,58 +287,12 @@ vecLayers :: Modey m -> Val Z -> Checking ([(Src, NumVal (VVar Z))] -- The sizes ,CTy m Z -- The function type at the end ) vecLayers my (TVec ty (VNum n)) = do - src <- mkStaticNum n + src <- buildNatVal n first ((src, n):) <$> vecLayers my ty vecLayers Braty (VFun Braty cty) = pure ([], cty) vecLayers Kerny (VFun Kerny cty) = pure ([], cty) vecLayers my ty = typeErr $ "Expected a " ++ showMode my ++ "function or vector of functions, got " ++ show ty -mkStaticNum :: NumVal (VVar Z) -> Checking Src -mkStaticNum n@(NumValue c gro) = do - (_, [], [(constSrc,_)], _) <- next "const" (Const (Num (fromIntegral c))) (S0, Some (Zy :* S0)) R0 (RPr ("value", TNat) R0) - src <- case gro of - Constant0 -> pure constSrc - StrictMonoFun sm -> do - (_, [(lhs,_),(rhs,_)], [(src,_)], _) <- next "add_const" (ArithNode Add) (S0, Some (Zy :* S0)) - (RPr ("lhs", TNat) (RPr ("rhs", TNat) R0)) - (RPr ("value", TNat) R0) - smSrc <- mkStrictMono sm - wire (constSrc, TNat, lhs) - wire (smSrc, TNat, rhs) - pure src - defineSrc src (VNum n) - pure src - where - mkStrictMono :: StrictMono (VVar Z) -> Checking Src - mkStrictMono (StrictMono k mono) = do - (_, [], [(constSrc,_)], _) <- next "2^k" (Const (Num (2^k))) (S0, Some (Zy :* S0)) R0 (RPr ("value", TNat) R0) - (_, [(lhs,_),(rhs,_)], [(src,_)], _) <- next "mult_const" (ArithNode Mul) (S0, Some (Zy :* S0)) - (RPr ("lhs", TNat) (RPr ("rhs", TNat) R0)) - (RPr ("value", TNat) R0) - monoSrc <- mkMono mono - wire (constSrc, TNat, lhs) - wire (monoSrc, TNat, rhs) - pure src - - mkMono :: Monotone (VVar Z) -> Checking Src - mkMono (Linear (VPar (ExEnd e))) = pure (NamedPort e "mono") - mkMono (Full sm) = do - (_, [], [(twoSrc,_)], _) <- next "2" (Const (Num 2)) (S0, Some (Zy :* S0)) R0 (RPr ("value", TNat) R0) - (_, [(lhs,_),(rhs,_)], [(powSrc,_)], _) <- next "2^" (ArithNode Pow) (S0, Some (Zy :* S0)) - (RPr ("lhs", TNat) (RPr ("rhs", TNat) R0)) - (RPr ("value", TNat) R0) - smSrc <- mkStrictMono sm - wire (twoSrc, TNat, lhs) - wire (smSrc, TNat, rhs) - - (_, [], [(oneSrc,_)], _) <- next "1" (Const (Num 1)) (S0, Some (Zy :* S0)) R0 (RPr ("value", TNat) R0) - (_, [(lhs,_),(rhs,_)], [(src,_)], _) <- next "n-1" (ArithNode Sub) (S0, Some (Zy :* S0)) - (RPr ("lhs", TNat) (RPr ("rhs", TNat) R0)) - (RPr ("value", TNat) R0) - wire (powSrc, TNat, lhs) - wire (oneSrc, TNat, rhs) - pure src - vectorise :: forall m. Modey m -> (Src, Val Z) -> Checking (Src, CTy m Z) vectorise my (src, ty) = do (layers, cty) <- vecLayers my ty @@ -339,7 +308,7 @@ vectorise my (src, ty) = do next "MapFun" MapFun (S0, Some (Zy :* S0)) (REx ("len", Nat) (RPr ("value", weak1 ty) R0)) (RPr ("vector", weak1 vecFun) R0) - defineTgt lenTgt (VNum len) + defineTgt' "vectorise" lenTgt (VNum len) wire (lenSrc, kindType Nat, lenTgt) wire (valSrc, ty, valTgt) let vecCTy = case (my,my',cty) of @@ -376,16 +345,20 @@ valueToBinder Braty = Right valueToBinder Kerny = id defineSrc :: Src -> Val Z -> Checking () -defineSrc src = defineEnd (ExEnd (end src)) +defineSrc src = defineEnd "" (ExEnd (end src)) +-- TODO: Do the work of checking if there's a dynamic hope here defineTgt :: Tgt -> Val Z -> Checking () -defineTgt tgt = defineEnd (InEnd (end tgt)) +defineTgt tgt = defineEnd "" (InEnd (end tgt)) -declareSrc :: Src -> Modey m -> BinderType m -> Checking () -declareSrc src my ty = req (Declare (ExEnd (end src)) my ty) +defineSrc' :: String -> Src -> Val Z -> Checking () +defineSrc' lbl src = defineEnd lbl (ExEnd (end src)) + +defineTgt' :: String -> Tgt -> Val Z -> Checking () +defineTgt' lbl tgt = defineEnd lbl (InEnd (end tgt)) declareTgt :: Tgt -> Modey m -> BinderType m -> Checking () -declareTgt tgt my ty = req (Declare (InEnd (end tgt)) my ty) +declareTgt tgt my ty = req (Declare (InEnd (end tgt)) my ty Definable) -- listToRow :: [(PortName, BinderType m)] -> Ro m Z i -- listToRow [] = R0 @@ -402,14 +375,14 @@ makeBox name cty@(ss :->> ts) body = do (tgt, unders, _, _) <- anext (name ++ "/out") Target ctx ts R0 case (?my, body) of (Kerny, _) -> do - (_,_,[thunk],_) <- next (name ++ "_thunk") (Box M.empty src tgt) (S0, Some (Zy :* S0)) + (_,_,[thunk],_) <- next (name ++ "_thunk") (Box src tgt) (S0, Some (Zy :* S0)) R0 (RPr ("thunk", VFun Kerny cty) R0) - bres <- name -! body (overs, unders) + bres <- body (overs, unders) pure (thunk, bres) (Braty, body) -> do - (bres, captures) <- name -! captureOuterLocals (body (overs, unders)) - (_, [], [thunk], _) <- next (name ++ "_thunk") (Box captures src tgt) (S0, Some (Zy :* S0)) + (node, [], [thunk], _) <- next (name ++ "_thunk") (Box src tgt) (S0, Some (Zy :* S0)) R0 (RPr ("thunk", VFun ?my cty) R0) + bres <- captureOuterLocals node (body (overs, unders)) pure (thunk, bres) -- Evaluate either mode's BinderType @@ -493,7 +466,273 @@ runArith (NumValue upl grol) Pow (NumValue upr gror) = pure $ NumValue (upl ^ upr) (StrictMonoFun (StrictMono (l * upr) (Full (StrictMono (k + k') mono)))) runArith _ _ _ = Nothing +buildArithOp :: ArithOp -> Checking ((Tgt, Tgt), Src) +buildArithOp op = do + (_, [(lhs,_), (rhs,_)], [(out,_)], _) <- next (show op) (ArithNode op) (S0, Some (Zy :* S0)) (REx ("lhs", Nat) (REx ("rhs", Nat) R0)) (REx ("value", Nat) R0) + pure ((lhs, rhs), out) + buildConst :: SimpleTerm -> Val Z -> Checking Src buildConst tm ty = do (_, _, [(out,_)], _) <- next "buildConst" (Const tm) (S0, Some (Zy :* S0)) R0 (RPr ("value", ty) R0) pure out + +buildNum :: Integer -> Checking Src +buildNum n = buildConst (Num (fromIntegral n)) TNat + +buildAdd :: Integer -> Checking (Tgt, Src) +buildAdd n = do + nDangling <- buildNum n + ((lhs,rhs),out) <- buildArithOp Add + req $ Wire (end nDangling, TNat, end lhs) + defineSrc out (VNum (nPlus n (nVar (VPar (toEnd rhs))))) + pure (rhs, out) + +buildSub :: Integer -> Checking (Tgt, Src) +buildSub n = do + nDangling <- buildNum n + ((lhs,rhs),out) <- buildArithOp Sub + req $ Wire (end nDangling, TNat, end rhs) + defineTgt' "Sub" lhs (VNum (nPlus n (nVar (VPar (toEnd out))))) + pure (lhs, out) + +buildDoub :: Checking (Tgt, Src) +buildDoub = do + nDangling <- buildNum 2 + ((lhs,rhs),out) <- buildArithOp Mul + req $ Wire (end nDangling, TNat, end lhs) + defineSrc out (VNum (n2PowTimes 1 (nVar (VPar (toEnd rhs))))) + pure (rhs, out) + +buildHalve :: Checking (Tgt, Src) +buildHalve = do + nDangling <- buildNum 2 + ((lhs,rhs),out) <- buildArithOp Div + req $ Wire (end nDangling, TNat, end rhs) + defineTgt' "Helpers"lhs (VNum (n2PowTimes 1 (nVar (VPar (toEnd out))))) + pure (lhs, out) + +-- Return an End with the same polarity whose value is half that of the input End +makeHalf :: End -> Checking End +makeHalf (InEnd e) = do + (doubIn, doubOut) <- buildDoub + req (Wire (end doubOut, TNat, e)) + defineTgt' "Helpers"(NamedPort e "") (VNum (nVar (VPar (toEnd doubOut)))) + pure (InEnd (end doubIn)) +makeHalf (ExEnd e) = do + (halveIn, halveOut) <- buildHalve + req (Wire (e, TNat, end halveIn)) + defineSrc (NamedPort e "") (VNum (nVar (VPar (toEnd halveIn)))) + pure (toEnd halveOut) + +makePred :: End -> Checking End +makePred (InEnd e) = do + (succIn, succOut) <- buildAdd 1 + req (Wire (end succOut, TNat, e)) + defineTgt' "Helpers"(NamedPort e "") (VNum (nVar (VPar (toEnd succOut)))) + pure (toEnd succIn) +makePred (ExEnd e) = do + (predIn, predOut) <- buildSub 1 + req (Wire (e, TNat, end predIn)) + defineSrc (NamedPort e "") (VNum (nVar (VPar (toEnd predIn)))) + pure (toEnd predOut) + +-- Generate wiring to produce a dynamic instance of the numval argument +-- N.B. In these functions, we wire using Req, rather than the `wire` function +-- because we don't want it to do any extra evaluation. +buildNatVal :: NumVal (VVar Z) -> Checking Src +buildNatVal nv@(NumValue n gro) = case n of + 0 -> buildGro gro + n -> do + (inn, out) <- buildAdd n + src <- buildGro gro + req $ Wire (end src, TNat, end inn) + --traceM $ "buildNatVal " ++ show inn + defineTgt' "Helpers"inn (VNum (nVar (VPar (toEnd src)))) + pure out + where + buildGro :: Fun00 (VVar Z) -> Checking Src + buildGro Constant0 = buildNum 0 + buildGro (StrictMonoFun sm) = buildSM sm + + buildSM :: StrictMono (VVar Z) -> Checking Src + buildSM (StrictMono k mono) = do + factor <- buildNum $ 2 ^ k + -- Multiply mono by 2^k; note we could avoid this if k==0 + ((lhs,rhs),out) <- buildArithOp Mul + monoDangling <- buildMono mono + req $ Wire (end factor, TNat, end lhs) + req $ Wire (end monoDangling, TNat, end rhs) + defineSrc out (VNum (n2PowTimes k (nVar (VPar (toEnd monoDangling))))) + pure out + + buildMono :: Monotone (VVar Z) -> Checking Src + buildMono (Linear (VPar (ExEnd e))) = pure $ NamedPort e "numval" + buildMono (Full sm) = do + -- Calculate 2^n as `outPlus1` + two <- buildNum 2 + dangling <- buildSM sm + ((lhs,rhs),outPlus1) <- buildArithOp Pow + req $ Wire (end two, TNat, end lhs) + req $ Wire (end dangling, TNat, end rhs) + -- Then subtract 1 + one <- buildNum 1 + ((lhs,rhs),out) <- buildArithOp Sub + req $ Wire (end outPlus1, TNat, end lhs) + req $ Wire (end one, TNat, end rhs) + defineSrc out (VNum (nFull (nVar (VPar (toEnd dangling))))) + pure out + buildMono _ = err . InternalError $ "Trying to build a non-closed nat value: " ++ show nv + +invertNatVal :: NumVal (VVar Z) -> Checking Tgt +invertNatVal (NumValue up gro) = case up of + 0 -> invertGro gro + _ -> do + ((lhs,rhs),out) <- buildArithOp Sub + upSrc <- buildNum up + req $ Wire (end upSrc, TNat, end rhs) + tgt <- invertGro gro + req $ Wire (end out, TNat, end tgt) + defineTgt' "Helpers"tgt (VNum (nVar (VPar (toEnd out)))) + defineTgt' "Helpers"lhs (VNum (nPlus up (nVar (VPar (toEnd tgt))))) + pure lhs + where + invertGro Constant0 = error "Invariant violated: the numval arg to invertNatVal should contain a variable" + invertGro (StrictMonoFun sm) = invertSM sm + + invertSM (StrictMono k mono) = case k of + 0 -> invertMono mono + _ -> do + divisor <- buildNum (2 ^ k) + ((lhs,rhs),out) <- buildArithOp Div + tgt <- invertMono mono + req $ Wire (end out, TNat, end tgt) + req $ Wire (end divisor, TNat, end rhs) + defineTgt' "Helpers"tgt (VNum (nVar (VPar (toEnd out)))) + defineTgt' "Helpers"lhs (VNum (n2PowTimes k (nVar (VPar (toEnd tgt))))) + pure lhs + + invertMono (Linear (VPar (InEnd e))) = pure (NamedPort e "numval") + invertMono (Full sm) = do + (_, [(llufTgt,_)], [(llufSrc,_)], _) <- next "luff" (Prim ("BRAT","lluf")) (S0, Some (Zy :* S0)) (REx ("n", Nat) R0) (REx ("n", Nat) R0) + tgt <- invertSM sm + req $ Wire (end llufSrc, TNat, end tgt) + defineTgt' "Helpers"tgt (VNum (nVar (VPar (toEnd llufSrc)))) + defineTgt' "Helpers"llufTgt (VNum (nFull (nVar (VPar (toEnd tgt))))) + pure llufTgt + +-- This will update the `hopes`, potentially invalidating things that have +-- been eval'd. +-- The Sem is closed, for now. +solveVal :: TypeKind -> End -> Val Z -> Checking () +solveVal _ it (VApp (VPar e) B0) | it == e = pure () +solveVal _ it v | Left msg <- doesntOccur it v = + -- TODO: Not all occurrences are toxic. The end could be in an argument + -- to a hoping variable which isn't used. + -- E.g. h1 = h2 h1 - this is valid if h2 is the identity, or ignores h1. + err msg +solveVal Nat it@(InEnd inn) v@(VNum nv) = do + dangling <- buildNatVal nv + req (Wire (end dangling, TNat, inn)) + defineEnd "solveValNat" it v +solveVal _ it v = defineEnd "solveVal" it v + -- Do we also need dummy wiring here? + +solveSem :: TypeKind -> End -> Sem -> Checking () +solveSem k hope = quote Zy >=> solveVal k hope + +-- Convert a pattern into a value for the purposes of solving it with unification +-- for pattern matching. This is used for checking type constructors - we're only +-- dealing in static information. +valPat2Val :: TypeKind + -> ValPat + -> Checking (Bwd (Val Z) -- Values of the pattern vars + ,Val Z -- The value of the whole pattern + ) +valPat2Val k VPVar = do + (_, [(idTgt, _)], [_], _) <- anext "pat2val" Id (S0, Some (Zy :* S0)) (REx ("", k) R0) (REx ("", k) R0) + let val = VApp (VPar (toEnd idTgt)) B0 + pure (B0 :< val, val) +valPat2Val (TypeFor m _) (VPCon con args) = do + ks <- fmap snd <$> tlup (m, con) + (stk, args) <- valPats2Val ks args + let val = VCon con args + pure (stk, val) +valPat2Val Nat (VPNum n) = numPat2Val n >>= \(stk, nv) -> pure (stk, VNum nv) + where + numPat2Val :: NumPat -> Checking (Bwd (Val Z), NumVal (VVar Z)) + numPat2Val NP0 = pure (B0, nZero) + numPat2Val (NP1Plus np) = second (nPlus 1) <$> numPat2Val np + numPat2Val (NP2Times np) = second (n2PowTimes 1) <$> numPat2Val np + numPat2Val NPVar = do + (_, [(idTgt, _)], [_], _) <- anext "numpat2val" Id (S0, Some (Zy :* S0)) (REx ("", Nat) R0) (REx ("", Nat) R0) + let var = endVal Nat (toEnd idTgt) + pure (B0 :< var, nVar (VPar (toEnd idTgt))) + +valPats2Val :: [TypeKind] + -> [ValPat] + -> Checking (Bwd (Val Z) -- Values of the pattern vars + ,[Val Z] -- The value of the whole pattern + ) +valPats2Val (k:ks) (v:vs) = do + (stk, v) <- valPat2Val k v + (stk', vs) <- valPats2Val ks vs + pure (stk <+ stk', v:vs) +valPats2Val [] [] = pure (B0, []) +valPats2Val _ _ = err $ InternalError "Type args didn't match expected - kindCheck should've sorted it" + +traceChecking :: String -> (a -> Checking b) -> (a -> Checking b) +traceChecking _lbl m a = do + -- trackM ("Enter " ++ lbl ++ ": " ++ show a) + b <- m a + -- trackM ("Exit " ++ lbl ++ ": " ++ show b) + pure b + +--traceChecking = const id + +dollarAndItsPrefix :: Bwd (String, Int) -> Maybe (Bwd (String, Int), String) +dollarAndItsPrefix B0 = Nothing +dollarAndItsPrefix (siz :< ('$':doll, _)) = Just (siz, doll) +dollarAndItsPrefix (siz :< _) = dollarAndItsPrefix siz + +prefixLeftOf :: Bwd (String, Int) -> String -> Maybe (Bwd (String, Int)) +prefixLeftOf B0 _ = Nothing +prefixLeftOf (siz :< (s, _)) key + | s == key = Just siz + | otherwise = prefixLeftOf siz key + +allowedToSolve :: Bwd (String, Int) -> End -> Maybe String +allowedToSolve me it = + let MkName itFwd = endName it + itBwd = (B0 <>< itFwd) + in case (it, dollarAndItsPrefix me, dollarAndItsPrefix itBwd) of + -- Solving a hope + (InEnd _, Just (region, "rhs"), Just (maker, '!':_)) + | Just region == prefixLeftOf maker "$rhs" + -> + trackPermission ("Allowed to solve:\n " ++ show me ++ " / " ++ show it) + $ Just "$!" + -- We can only solve dangling wires when doing pattern matching in `solve` + (_, Just (region, "lhs"), Just (region', "lhs")) + | region == region' + -> trackPermission ("Allowed to solve:\n " ++ show me ++ " / " ++ show it) + $ Just "gen" + _ -> trackPermission ("Forbidden to solve:\n " ++ show me ++ " / " ++ show it) + Nothing + +mineToSolve :: Checking (End -> Maybe String) +mineToSolve = allowedToSolve <$> whoAmI + +-- Don't call this on kinds +-- Note: We can't really tell whether there's any prospect of the variable becoming +-- defined - if we could we could give a better error when something that wont be +-- defined is passed in. +awaitTypeDefinition :: Val Z -> Checking (Val Z) +awaitTypeDefinition ty = eval S0 ty >>= \case + VApp (VPar e) _ -> mkYield "awaitTypeDefinition" (S.singleton e) >> awaitTypeDefinition ty + ty -> pure ty + +mkGraph :: TypeKind -> Val Z -> Checking Src +mkGraph Nat (VNum nv) = buildNatVal nv +mkGraph k _ = do + (_, [], [(src,_)], _) <- next "" (Const Unit) (S0, Some (Zy :* S0)) R0 (REx ("", k) R0) + pure src diff --git a/brat/Brat/Checker/Monad.hs b/brat/Brat/Checker/Monad.hs index baecc9e6..12f15aca 100644 --- a/brat/Brat/Checker/Monad.hs +++ b/brat/Brat/Checker/Monad.hs @@ -1,5 +1,6 @@ module Brat.Checker.Monad where +import Bwd import Brat.Checker.Quantity (Quantity(..)) import Brat.Checker.Types hiding (HoleData(..)) import Brat.Constructors (ConstructorMap, CtorArgs) @@ -16,17 +17,23 @@ import Util import Control.Monad.Freer import Control.Monad.Fail () +import Data.Functor ((<&>)) import Data.List (intercalate) import qualified Data.Map as M +import qualified Data.Set as S -- import Debug.Trace +-- Used for messages about thread forking / spawning +thTrace = const id +--thTrace = trace + trackM :: Monad m => String -> m () trackM = const (pure ()) --- trackM = traceM +--trackM = traceM track = const id --- track = trace +--track = trace trackShowId x = track (show x) x -- Data for using a type alias. E.g. @@ -50,7 +57,14 @@ data CtxEnv = CtxEnv , locals :: VEnv } -type Hopes = M.Map InPort FC +data HopeData = HopeData + { hopeFC :: Maybe FC + , hopeDynamic :: Bool + } deriving (Eq, Ord, Show) + +type Hopes = M.Map InPort HopeData + +type CaptureSets = M.Map Name VEnv data Context = Ctx { globalVEnv :: VEnv , store :: Store @@ -58,12 +72,24 @@ data Context = Ctx { globalVEnv :: VEnv , kconstructors :: ConstructorMap Kernel , typeConstructors :: M.Map (Mode, QualName) [(PortName, TypeKind)] , aliasTable :: M.Map QualName Alias + -- On the chopping block , hopes :: Hopes + -- Ends which need to be solved because they affect runtime behaviour + , dynamicSet :: M.Map InPort FC + , captureSets :: CaptureSets } +mkFork :: String -> Free sig () -> Free sig () +mkFork d par = thTrace ("Forking " ++ d) $ Fork d par $ pure () + +mkYield :: String -> S.Set End -> Free sig () +mkYield desc es = thTrace ("Yielding in " ++ desc ++ "\n " ++ show es) $ Yield (AwaitingAny es) (\_ -> trackM ("woke up " ++ desc) >> Ret ()) + +-- Commands for synchronous operations data CheckingSig ty where Fresh :: String -> CheckingSig Name SplitNS :: String -> CheckingSig Namespace + AskNS :: CheckingSig (Bwd (String, Int)) Throw :: Error -> CheckingSig a LogHole :: TypedHole -> CheckingSig () AskFC :: CheckingSig FC @@ -85,75 +111,81 @@ data CheckingSig ty where ELup :: End -> CheckingSig (Maybe (Val Z)) -- Lookup an alias in the table ALup :: QualName -> CheckingSig (Maybe Alias) - TypeOf :: End -> CheckingSig EndType + TypeOf :: End -> CheckingSig (EndType, IsSkolem) AddNode :: Name -> Node -> CheckingSig () Wire :: Wire -> CheckingSig () KDone :: CheckingSig () AskVEnv :: CheckingSig CtxEnv - Declare :: End -> Modey m -> BinderType m -> CheckingSig () - Define :: End -> Val Z -> CheckingSig () - ANewHope :: InPort -> FC -> CheckingSig () - AskHopes :: CheckingSig Hopes - RemoveHope :: InPort -> CheckingSig () + Declare :: End -> Modey m -> BinderType m -> IsSkolem -> CheckingSig () + ANewDynamic :: InPort -> FC -> CheckingSig () + AskDynamics :: CheckingSig (M.Map InPort FC) + AddCapture :: Name -> (QualName, [(Src, BinderType Brat)]) -> CheckingSig () + +wrapper :: (forall a. CheckingSig a -> Checking (Maybe a)) -> Checking v -> Checking v +wrapper _ (Ret v) = Ret v +wrapper f (Req s k) = f s >>= \case + Just v -> wrapper f (k v) + Nothing -> Req s (wrapper f . k) +wrapper f (Define lbl v e k) = Define lbl v e (wrapper f . k) +wrapper f (Yield st k) = Yield st (wrapper f . k) +wrapper f (Fork d par c) = Fork d (wrapper f par) (wrapper f c) + +wrapper2 :: (forall a. CheckingSig a -> Maybe a) -> Checking v -> Checking v +wrapper2 f = wrapper (\s -> pure (f s)) localAlias :: (QualName, Alias) -> Checking v -> Checking v -localAlias _ (Ret v) = Ret v -localAlias con@(name, alias) (Req (ALup u) k) - | u == name = localAlias con $ k (Just alias) -localAlias con (Req r k) = Req r (localAlias con . k) +localAlias (name, alias) = wrapper2 (\case + ALup u | u == name -> Just (Just alias) + _ -> Nothing) localFC :: FC -> Checking v -> Checking v -localFC _ (Ret v) = Ret v -localFC f (Req AskFC k) = localFC f (k f) -localFC f (Req (Throw e@Err{fc=Nothing}) k) = localFC f (Req (Throw (e{fc=Just f})) k) -localFC f (Req r k) = Req r (localFC f . k) +localFC f = wrapper (\case + AskFC -> pure $ Just f + (Throw e@Err{fc=Nothing}) -> req (Throw (e{fc=Just f})) >> error "Throw returned" + _ -> pure $ Nothing) localEnv :: (?my :: Modey m) => Env (EnvData m) -> Checking v -> Checking v localEnv = case ?my of Braty -> localVEnv Kerny -> \env m -> localKVar env (m <* req KDone) -localVEnv :: VEnv -> Checking v -> Checking v -localVEnv _ (Ret v) = Ret v -localVEnv ext (Req (VLup x) k) | Just x <- M.lookup x ext = localVEnv ext (k (Just x)) -localVEnv ext (Req AskVEnv k) = do env <- req AskVEnv - -- ext shadows local vars - localVEnv ext (k (env { locals = M.union ext (locals env) })) -localVEnv ext (Req r k) = Req r (localVEnv ext . k) - --- runs a computation, but intercepts uses of outer *locals* variables and redirects --- them to use new outports of the specified node (expected to be a Source). --- Returns a list of captured variables and their generated (Source-node) outports -captureOuterLocals :: Checking v -> Checking (v, VEnv) -captureOuterLocals c = do +localVEnv :: M.Map QualName [(Src, BinderType Brat)] -> Checking v -> Checking v +localVEnv ext = wrapper (\case + (VLup x) | j@(Just _) <- M.lookup x ext -> pure $ Just j -- invoke continuation with j + AskVEnv -> do + outerEnv <- req AskVEnv + pure $ Just -- value to return to original continuation + (outerEnv { locals = M.union ext (locals outerEnv) }) -- ext shadows local vars + _ -> pure Nothing) + +-- runs a computation, but logs (via AddCapture, under the specified Name) uses of outer +-- *local* variables +captureOuterLocals :: Name -> Checking v -> Checking v +captureOuterLocals n c = do outerLocals <- locals <$> req AskVEnv - helper (outerLocals, M.empty) c + wrapper (helper outerLocals) c where - helper :: (VEnv, VEnv) -> Checking v - -> Checking (v, M.Map QualName [(Src, BinderType Brat)]) - helper (_, captured) (Ret v) = Ret (v, captured) - helper (avail, captured) (Req (VLup x) k) | j@(Just new) <- M.lookup x avail = - helper (avail, M.insert x new captured) (k j) - helper state (Req r k) = Req r (helper state . k) + helper :: VEnv -> forall a. CheckingSig a -> Checking (Maybe a) + helper avail (VLup x) | j@(Just new) <- M.lookup x avail = + (req $ AddCapture n (x,new)) >> (pure $ Just j) + helper _ _ = pure Nothing wrapError :: (Error -> Error) -> Checking v -> Checking v -wrapError _ (Ret v) = Ret v -wrapError f (Req (Throw e) k) = Req (Throw (f e)) k -wrapError f (Req r k) = Req r (wrapError f . k) +wrapError f = wrapper (\case + (Throw e) -> req (Throw (f e)) -- do not return value from outer Throw! + _ -> pure Nothing) throwLeft :: Either ErrorMsg a -> Checking a throwLeft (Right x) = pure x throwLeft (Left msg) = err msg vlup :: QualName -> Checking [(Src, BinderType Brat)] -vlup s = do - req (VLup s) >>= \case +vlup s = req (VLup s) >>= \case Just vty -> pure vty Nothing -> err $ VarNotFound (show s) alup :: QualName -> Checking Alias -alup s = do - req (ALup s) >>= \case +alup s = req (ALup s) >>= \case Just vty -> pure vty Nothing -> err $ VarNotFound (show s) @@ -167,6 +199,9 @@ kclup :: QualName -- Value constructor -> Checking (CtorArgs Kernel) kclup vcon tycon = req AskFC >>= \fc -> req (KCLup fc vcon tycon) +-- TODO: Future proof this by taking a TypeKind argument instead of a mode. +-- Currently we have kinds `Nat` for `TypeFor m`, where we don't lookup `Nat` +-- with tlup, but this will change! tlup :: (Mode, QualName) -> Checking [(PortName, TypeKind)] tlup (m, c) = req (TLup (m, c)) >>= \case Nothing -> req (TLup (otherMode, c)) >>= \case @@ -187,6 +222,7 @@ lookupAndUse x kenv = case M.lookup x kenv of Just (Tons, rest) -> Right $ Just (rest, M.insert x (Tons, rest) kenv) localKVar :: KEnv -> Checking v -> Checking v +-- Doesn't fit the wrapper pattern because the `env` mutates localKVar _ (Ret v) = Ret v localKVar env (Req (KLup x) k) = case lookupAndUse x env of Left err@(Err (Just _) _) -> req $ Throw err @@ -201,11 +237,24 @@ localKVar env (Req KDone k) = case [ x | (x,(One,_)) <- M.assocs env ] of ,"haven't been used" ] localKVar env (Req r k) = Req r (localKVar env . k) +localKVar env (Define lbl e v k) = Define lbl e v (localKVar env . k) +localKVar env (Yield st k) = Yield st (localKVar env . k) +localKVar env (Fork desc par c) = + -- can't send end both ways, so until we can join (TODO), restrict Forks to local scope + thTrace ("Spawning(LKV) " ++ desc) $ localKVar env $ par *> c + +-- SkolemConst constants are e.g. function parameters that are *not* going to be defined if we wait. +-- (exception: clause inputs can sometimes be defined if there is exactly one possible value). +isSkolem :: End -> Checking IsSkolem +isSkolem e = req (TypeOf e) <&> snd catchErr :: Free CheckingSig a -> Free CheckingSig (Either Error a) catchErr (Ret t) = Ret (Right t) catchErr (Req (Throw e) _) = pure $ Left e catchErr (Req r k) = Req r (catchErr . k) +catchErr (Define lbl e v k) = Define lbl e v (catchErr . k) +catchErr (Yield st k) = Yield st (catchErr . k) +catchErr (Fork desc par c) = thTrace ("Spawning(catch) " ++ desc) $ catchErr $ par *> c handler :: Free CheckingSig v -> Context @@ -216,6 +265,7 @@ handler (Req s k) ctx g = case s of Fresh _ -> error "Fresh in handler, should only happen under `-!`" SplitNS _ -> error "SplitNS in handler, should only happen under `-!`" + AskNS -> error "AskNS in handler, should only happen under `-!`" Throw err -> Left err LogHole hole -> do (v,ctx,(holes,g)) <- handler (k ()) ctx g return (v,ctx,(hole:holes,g)) @@ -233,7 +283,7 @@ handler (Req s k) ctx g TypeOf end -> case M.lookup end . typeMap . store $ ctx of Just et -> handler (k et) ctx g Nothing -> Left (dumbErr . InternalError $ "End " ++ show end ++ " isn't Declared") - Declare end my bty -> + Declare end my bty skol -> let st@Store{typeMap=m} = store ctx in case M.lookup end m of Just _ -> Left $ dumbErr (InternalError $ "Redeclaring " ++ show end) @@ -241,19 +291,8 @@ handler (Req s k) ctx g track ("Declared " ++ show end ++ " :: " ++ bty_str) $ handler (k ()) (ctx { store = - st { typeMap = M.insert end (EndType my bty) m } + st { typeMap = M.insert end (EndType my bty, skol) m } }) g - Define end v -> - let st@Store{typeMap=tm, valueMap=vm} = store ctx - in case track ("Define " ++ show end ++ " = " ++ show v) $ M.lookup end vm of - Just _ -> Left $ dumbErr (InternalError $ "Redefining " ++ show end) - Nothing -> case M.lookup end tm of - Nothing -> Left $ dumbErr (InternalError $ "Defining un-Declared " ++ show end ++ " in \n" ++ show tm) - Just _ -> -- TODO can we check the value is of the kind declared? - handler (k ()) - (ctx { store = - st { valueMap = M.insert end v vm } - }) g -- TODO: Use the kind argument for partially applied constructors TLup key -> do let args = M.lookup key (typeConstructors ctx) @@ -273,14 +312,46 @@ handler (Req s k) ctx g M.lookup tycon tbl handler (k args) ctx g - ANewHope e fc -> handler (k ()) (ctx { hopes = M.insert e fc (hopes ctx) }) g - - AskHopes -> handler (k (hopes ctx)) ctx g - - RemoveHope e -> let hset = hopes ctx in - if M.member e hset - then handler (k ()) (ctx { hopes = M.delete e hset }) g - else Left (dumbErr (InternalError ("Trying to remove unknown Hope: " ++ show e))) + ANewDynamic e fc -> trackM ("ANewDynamic " ++ show e) *> handler (k ()) (ctx { dynamicSet = M.insert e fc (dynamicSet ctx) }) g + + AskDynamics -> handler (k (dynamicSet ctx)) ctx g + + AddCapture n (var, ends) -> + handler (k ()) ctx {captureSets=M.insertWith M.union n (M.singleton var ends) (captureSets ctx)} g + +handler (Define lbl end v k) ctx g = let st@Store{typeMap=tm, valueMap=vm} = store ctx in + case track ("Define(" ++ lbl ++ ")" ++ show end ++ " = " ++ show v) $ M.lookup end vm of + Just _ -> Left $ dumbErr (InternalError $ "Redefining " ++ show end) + Nothing -> case M.lookup end tm of + Nothing -> Left $ dumbErr (InternalError $ "Defining un-Declared " ++ show end ++ " in \n" ++ show tm) + -- Allow even Skolems to be defined (e.g. clauses with unique soln) + -- TODO(1) can we check the value is of the kind declared? + -- TODO(2) it'd be better to figure out if the end is really Unstuck, + -- or just awaiting some other end, but that seems overly complex atm, as + -- (a) we must be "Unstuck" if the end is Defined to something SkolemConst *OR* in the HopeSet, + -- (b) Numbers are tricky, whether they are stuck or not depends upon the question + -- (c) since there are no infinite end-creating loops, it's correct (merely inefficient) + -- to just "have another go". + Just _ -> let news = News (M.singleton end Unstuck) + newDynamics = case v of + VNum nv -> [ inport | InEnd inport <- depEnds nv ] + _ -> [] + in handler (k news) + (ctx { store = st { valueMap = M.insert end v vm }, + dynamicSet = case end of + ExEnd _ -> dynamicSet ctx + InEnd inport -> case M.lookup inport (dynamicSet ctx) of + Just fc -> track ("Replace " ++ show end ++ " with " ++ show newDynamics) $ + M.union + (M.fromList (zip newDynamics (repeat fc))) + (M.delete inport (dynamicSet ctx)) + Nothing -> dynamicSet ctx + }) g +handler (Yield Unstuck k) ctx g = handler (k mempty) ctx g +handler (Yield (AwaitingAny ends) _k) ctx _ = Left $ dumbErr $ TypeErr $ unlines $ + ("Typechecking blocked on:":(show <$> S.toList ends)) + ++ "":"Dynamic set is":(show <$> M.keys (dynamicSet ctx)) ++ ["Try writing more types! :-)"] +handler (Fork desc par c) ctx g = handler (thTrace ("Spawning " ++ desc) $ par *> c) ctx g type Checking = Free CheckingSig @@ -302,6 +373,7 @@ typeErr = err . TypeErr instance FreshMonad Checking where freshName x = req $ Fresh x str -! c = inLvl str c + whoAmI = req AskNS -- This way we get file contexts when pattern matching fails instance MonadFail Checking where @@ -309,16 +381,16 @@ instance MonadFail Checking where -- Run a computation without logging any holes suppressHoles :: Checking a -> Checking a -suppressHoles (Ret x) = Ret x -suppressHoles (Req (LogHole _) k) = suppressHoles (k ()) -suppressHoles (Req c k) = Req c (suppressHoles . k) +suppressHoles = wrapper2 (\case + (LogHole _) -> Just () + _ -> Nothing) -- Run a computation without doing any graph generation suppressGraph :: Checking a -> Checking a -suppressGraph (Ret x) = Ret x -suppressGraph (Req (AddNode _ _) k) = suppressGraph (k ()) -suppressGraph (Req (Wire _) k) = suppressGraph (k ()) -suppressGraph (Req c k) = Req c (suppressGraph . k) +suppressGraph = wrapper2 (\case + (AddNode _ _) -> Just () + (Wire _) -> Just () + _ -> Nothing) inLvl :: String -> Checking a -> Checking a inLvl prefix c = req (SplitNS prefix) >>= \prefixNamespace -> localNS prefixNamespace c @@ -329,7 +401,12 @@ localNS ns (Req (Fresh str) k) = let (name, root) = fresh str ns in localNS root (k name) localNS ns (Req (SplitNS str) k) = let (subSpace, newRoot) = split str ns in localNS newRoot (k subSpace) +localNS ns (Req AskNS k) = localNS ns (k (fst ns)) localNS ns (Req c k) = Req c (localNS ns . k) +localNS ns (Define lbl e v k) = Define lbl e v (localNS ns . k) +localNS ns (Yield st k) = Yield st (localNS ns . k) +localNS ns (Fork desc par c) = let (subSpace, newRoot) = split desc ns in + Fork desc (localNS subSpace par) (localNS newRoot c) -defineEnd :: End -> Val Z -> Checking () -defineEnd e v = req (Define e v) +defineEnd :: String -> End -> Val Z -> Checking () +defineEnd lbl e v = Define lbl e v (const (Ret ())) diff --git a/brat/Brat/Checker/SolveHoles.hs b/brat/Brat/Checker/SolveHoles.hs index d26361dd..2631a4f6 100644 --- a/brat/Brat/Checker/SolveHoles.hs +++ b/brat/Brat/Checker/SolveHoles.hs @@ -1,23 +1,25 @@ -module Brat.Checker.SolveHoles (typeEq) where +module Brat.Checker.SolveHoles (typeEq, typesEq) where -import Brat.Checker.Helpers (buildConst) +import Brat.Checker.Helpers (mineToSolve, solveSem) import Brat.Checker.Monad +import Brat.Checker.SolveNumbers import Brat.Checker.Types (kindForMode) import Brat.Error (ErrorMsg(..)) import Brat.Eval +import Brat.Naming (FreshMonad(..)) import Brat.Syntax.Common -import Brat.Syntax.Simple (SimpleTerm(..)) +-- import Brat.Syntax.Simple (SimpleTerm(..)) import Brat.Syntax.Value import Control.Monad.Freer import Bwd import Hasochism +-- import Brat.Syntax.Port (toEnd) -import Control.Monad (when) +import Control.Monad (unless) import Data.Bifunctor (second) import Data.Foldable (sequenceA_) import Data.Functor -import Data.Maybe (mapMaybe) -import qualified Data.Map as M +import qualified Data.Set as S import Data.Type.Equality (TestEquality(..), (:~:)(..)) -- Demand that two closed values are equal, we're allowed to solve variables in the @@ -28,7 +30,20 @@ typeEq :: String -- String representation of the term for error reporting -> Val Z -- Expected -> Val Z -- Actual -> Checking () -typeEq str = typeEq' str (Zy :* S0 :* S0) +typeEq str k exp act = do + prefix <- whoAmI + trackM ("typeEq: Who am I: " ++ show prefix) + typeEq' str (Zy :* S0 :* S0) k exp act + +typesEq :: String -- String representation of the term for error reporting + -> [TypeKind] -- The kinds we're comparing at + -> [Val Z] -- Expected + -> [Val Z] -- Actual + -> Checking () +typesEq str k exp act = do + prefix <- whoAmI + trackM ("typesEq: Who am I: " ++ show prefix) + typeEqs str (Zy :* S0 :* S0) k exp act -- Internal version of typeEq with environment for non-closed values @@ -38,83 +53,53 @@ typeEq' :: String -- String representation of the term for error reporting -> Val n -- Expected -> Val n -- Actual -> Checking () -typeEq' str stuff@(_ny :* _ks :* sems) k exp act = do - hopes <- req AskHopes +typeEq' str stuff@(ny :* _ks :* sems) k exp act = do + mine <- mineToSolve exp <- sem sems exp act <- sem sems act - typeEqEta str stuff hopes k exp act - -isNumVar :: Sem -> Maybe SVar -isNumVar (SNum (NumValue 0 (StrictMonoFun (StrictMono 0 (Linear v))))) = Just v -isNumVar _ = Nothing + qexp <- quote ny exp + qact <- quote ny act + trackM ("typeEq' exp: " ++ show qexp) + trackM ("typeEq' act: " ++ show qact) + typeEqEta str stuff mine k exp act -- Presumes that the hope set and the two `Sem`s are up to date. typeEqEta :: String -- String representation of the term for error reporting -> (Ny :* Stack Z TypeKind :* Stack Z Sem) n - -> Hopes -- A map from the hope set to corresponding FCs + -> (End -> Maybe String) -- Tells us if we can solve a given End -> TypeKind -- The kind we're comparing at -> Sem -- Expected -> Sem -- Actual -> Checking () -typeEqEta tm (lvy :* kz :* sems) hopes (TypeFor m ((_, k):ks)) exp act = do +typeEqEta tm (lvy :* kz :* sems) mine (TypeFor m ((_, k):ks)) exp act = do -- Higher kinded things let nextSem = semLvl lvy let xz = B0 :< nextSem exp <- applySem exp xz act <- applySem act xz - typeEqEta tm (Sy lvy :* (kz :<< k) :* (sems :<< nextSem)) hopes (TypeFor m ks) exp act + typeEqEta tm (Sy lvy :* (kz :<< k) :* (sems :<< nextSem)) mine (TypeFor m ks) exp act -- Not higher kinded - check for flex terms -- (We don't solve under binders for now, so we only consider Zy here) -- 1. "easy" flex cases -typeEqEta _tm (Zy :* _ks :* _sems) hopes k (SApp (SPar (InEnd e)) B0) act - | M.member e hopes = solveHope k e act -typeEqEta _tm (Zy :* _ks :* _sems) hopes k exp (SApp (SPar (InEnd e)) B0) - | M.member e hopes = solveHope k e exp -typeEqEta _ (Zy :* _ :* _) hopes Nat exp act - | Just (SPar (InEnd e)) <- isNumVar exp, M.member e hopes = solveHope Nat e act - | Just (SPar (InEnd e)) <- isNumVar act, M.member e hopes = solveHope Nat e exp +typeEqEta _tm (Zy :* _ks :* _sems) mine k (SApp (SPar e) B0) act + | Just _ <- mine e = solveSem k e act +typeEqEta _tm (Zy :* _ks :* _sems) mine k exp (SApp (SPar e) B0) + | Just _ <- mine e = solveSem k e exp +typeEqEta _ (Zy :* _ :* _) mine Nat (SNum exp) (SNum act) = unifyNum mine (quoteNum Zy exp) (quoteNum Zy act) -- 2. harder cases, neither is in the hope set, so we can't define it ourselves -typeEqEta tm stuff@(ny :* _ks :* _sems) hopes k exp act = do +typeEqEta tm stuff@(ny :* _ks :* _sems) _ k exp act = do exp <- quote ny exp act <- quote ny act - let ends = mapMaybe getEnd [exp,act] - -- sanity check: we've already dealt with either end being in the hopeset - when (or [M.member ie hopes | InEnd ie <- ends]) $ typeErr "ends were in hopeset" - case ends of + unless (exp == act) $ case flexes act ++ flexes exp of [] -> typeEqRigid tm stuff k exp act -- easyish, both rigid i.e. already defined - -- variables are trivially the same, even if undefined, but the values may - -- be different! E.g. X =? 1 + X - [_, _] | exp == act -> pure () - -- TODO: Once we have scheduling, we must wait for one or the other to become more defined, rather than failing - _ -> err (TypeMismatch tm (show exp) (show act)) - where - getEnd (VApp (VPar e) _) = Just e - getEnd (VNum n) = getNumVar n - getEnd _ = Nothing - --- This will update the `hopes`, potentially invalidating things that have --- been eval'd. --- The Sem is closed, for now. -solveHope :: TypeKind -> InPort -> Sem -> Checking () -solveHope k hope v = quote Zy v >>= \v -> case doesntOccur (InEnd hope) v of - Right () -> do - defineEnd (InEnd hope) v - dangling <- case (k, v) of - (Nat, VNum _v) -> err $ Unimplemented "Nat hope solving" [] - (Nat, _) -> err $ InternalError "Head of Nat wasn't a VNum" - _ -> buildConst Unit TUnit - req (Wire (end dangling, kindType k, hope)) - req (RemoveHope hope) - Left msg -> case v of - VApp (VPar (InEnd end)) B0 | hope == end -> pure () - -- TODO: Not all occurrences are toxic. The end could be in an argument - -- to a hoping variable which isn't used. - -- E.g. h1 = h2 h1 - this is valid if h2 is the identity, or ignores h1. - _ -> err msg + -- tricky: must wait for one or other to become more defined + es -> mkYield "typeEqEta" (S.fromList es) >> typeEq' tm stuff k exp act typeEqs :: String -> (Ny :* Stack Z TypeKind :* Stack Z Sem) n -> [TypeKind] -> [Val n] -> [Val n] -> Checking () typeEqs _ _ [] [] [] = pure () -typeEqs tm stuff (k:ks) (exp:exps) (act:acts) = typeEqs tm stuff ks exps acts <* typeEq' tm stuff k exp act +typeEqs tm stuff (k:ks) (exp:exps) (act:acts) = do + mkFork "typeEqsTail" $ typeEqs tm stuff ks exps acts + typeEq' tm stuff k exp act typeEqs _ _ _ _ _ = typeErr "arity mismatch" typeEqRow :: Modey m @@ -145,7 +130,7 @@ typeEqRigid tm (_ :* _ :* semz) Nat exp act = do act <- sem semz act if getNum exp == getNum act then pure () - else err $ TypeMismatch tm (show exp) (show act) + else err $ TypeMismatch tm ("TYPEEQRIGID " ++ show exp) ("TODO " ++ show act) typeEqRigid tm stuff@(_ :* kz :* _) (TypeFor m []) (VApp f args) (VApp f' args') | f == f' = svKind f >>= \case TypeFor m' ks | m == m' -> typeEqs tm stuff (snd <$> ks) (args <>> []) (args' <>> []) diff --git a/brat/Brat/Checker/SolveNumbers.hs b/brat/Brat/Checker/SolveNumbers.hs new file mode 100644 index 00000000..8089c506 --- /dev/null +++ b/brat/Brat/Checker/SolveNumbers.hs @@ -0,0 +1,209 @@ +module Brat.Checker.SolveNumbers (unifyNum) where + +import Brat.Checker.Monad +import Brat.Checker.Helpers +import Brat.Syntax.Value +import Brat.Syntax.Common +import Brat.Syntax.Port +import Brat.Error +import Brat.Eval +import Brat.Graph (NodeType(..)) +import Brat.Naming +import Hasochism +import Control.Monad.Freer + +-- import Debug.Trace +import qualified Data.Set as S + +trailM :: Applicative f => String -> f () +trailM = const (pure ()) +trail = const id +--trail = trace + +-- This is currently lifted from SolvePatterns, which still imports it. +-- It is also used in SolveHoles, where it does the right mathematics +-- but the wrong wiring. + +-- Solve a Nat kinded metavariable. Unlike `instantiateMeta`, this function also +-- makes the dynamic wiring for a metavariable. This only needs to happen for +-- numbers because they have nontrivial runtime behaviour. +-- +-- We assume that the caller has done the occurs check and rules out trivial equations. +-- The caller also must check we have the right to solve the End +solveNumMeta :: (End -> Maybe String) -> End -> NumVal (VVar Z) -> Checking () +solveNumMeta _ e nv | trail ("solveNumMeta " ++ show e ++ " " ++ show nv) False = undefined +solveNumMeta mine e nv = case (e, numVars nv) of + -- Compute the thing that the rhs should be based on the src, and instantiate src to that + (ExEnd src, [InEnd _tgt]) -> do + -- Compute the value of the `tgt` variable from the known `src` value by inverting nv + tgtSrc <- invertNatVal nv + instantiateMeta "solveNumExIn" (ExEnd src) (VNum (nVar (VPar (toEnd tgtSrc)))) + wire (NamedPort src "", TNat, tgtSrc) + + (ExEnd src, _) -> instantiateMeta "solveNumEx_" (ExEnd src) (VNum nv) + + -- Both targets, we need to create the thing that they both derive from + (InEnd bigTgt, [InEnd weeTgt]) -> do + (_, [(idTgt, _)], [(idSrc, _)], _) <- anext "numval id" Id (S0, Some (Zy :* S0)) + (REx ("n", Nat) R0) (REx ("n", Nat) R0) + defineSrc idSrc (VNum (nVar (VPar (toEnd idTgt)))) + let nv' = fmap (const (VPar (toEnd idSrc))) nv -- weeTgt is the only thing to replace + bigSrc <- buildNatVal nv' + nv' <- quoteNum Zy <$> numEval S0 nv' + instantiateMeta "solveNumInIn" (InEnd bigTgt) (VNum nv') + wire (bigSrc, TNat, NamedPort bigTgt "") + unifyNum mine (nVar (VPar (toEnd idSrc))) (nVar (VPar (toEnd weeTgt))) + + + + -- RHS is constant or Src, wire it into tgt + (InEnd tgt, _) -> do + src <- buildNatVal nv + instantiateMeta "solveNumIn_" (InEnd tgt) (VNum nv) + wire (src, TNat, NamedPort tgt "") + +unifyNum :: (End -> Maybe String) -> NumVal (VVar Z) -> NumVal (VVar Z) -> Checking () +unifyNum mine nv0 nv1 = do + trailM $ ("unifyNum In\n " ++ show nv0 ++ "\n " ++ show nv1) + nv0 <- numEval S0 nv0 + nv1 <- numEval S0 nv1 + unifyNum' mine (quoteNum Zy nv0) (quoteNum Zy nv1) + nv0 <- numEval S0 (quoteNum Zy nv0) + nv1 <- numEval S0 (quoteNum Zy nv1) + trailM $ ("unifyNum Out\n " ++ show (quoteNum Zy nv0) ++ "\n " ++ show (quoteNum Zy nv1)) + +-- Need to keep track of which way we're solving - which side is known/unknown +-- Things which are dynamically unknown must be Tgts - information flows from Srcs +-- ...But we don't need to do any wiring here, right? +unifyNum' :: (End -> Maybe String) -> NumVal (VVar Z) -> NumVal (VVar Z) -> Checking () +unifyNum' _ a b | trail ("unifyNum'\n " ++ show a ++ "\n " ++ show b) False = undefined +unifyNum' mine (NumValue lup lgro) (NumValue rup rgro) + | lup <= rup = lhsFun00 lgro (NumValue (rup - lup) rgro) + | otherwise = lhsFun00 rgro (NumValue (lup - rup) lgro) + where + lhsFun00 :: Fun00 (VVar Z) -> NumVal (VVar Z) -> Checking () + lhsFun00 Constant0 num = demand0 num + -- Both sides are variables + lhsFun00 (StrictMonoFun (StrictMono 0 (Linear v))) (NumValue 0 (StrictMonoFun (StrictMono 0 (Linear v')))) = flexFlex v v' + -- There's just a variable on the right - move it to the left + lhsFun00 sm (NumValue 0 (StrictMonoFun smv@(StrictMono 0 (Linear _)))) = lhsStrictMono smv (NumValue 0 sm) + lhsFun00 (StrictMonoFun sm) num = lhsStrictMono sm num + + flexFlex :: VVar Z -> VVar Z -> Checking () + flexFlex v v' = case compare v v' of + GT -> flexFlex v' v + EQ -> pure () + LT -> case (v, v') of + (VPar e@(ExEnd p), VPar e'@(ExEnd p')) + | Just _ <- mine e -> defineSrc (NamedPort p "") (VNum (nVar v')) + | Just _ <- mine e' -> defineSrc (NamedPort p' "") (VNum (nVar v)) + | otherwise -> typeErr $ "Can't force " ++ show v ++ " to be " ++ show v' + (VPar e@(InEnd p), VPar e'@(ExEnd dangling)) + | Just _ <- mine e -> do + req (Wire (dangling, TNat, p)) + defineTgt' ("flex-flex In Ex") (NamedPort p "") (VNum (nVar v')) + | Just _ <- mine e' -> do + req (Wire (dangling, TNat, p)) + defineSrc' ("flex-flex In Ex") (NamedPort dangling "") (VNum (nVar v)) + | otherwise -> mkYield "flexFlex" (S.singleton e) >> unifyNum mine (nVar v) (nVar v') + (VPar e@(InEnd p), VPar e'@(InEnd p')) + | Just _ <- mine e -> defineTgt' "flex-flex In In1" (NamedPort p "") (VNum (nVar v')) + | Just _ <- mine e' -> defineTgt' "flex-flex In In0"(NamedPort p' "") (VNum (nVar v)) + | otherwise -> mkYield "flexFlex" (S.fromList [e, e']) >> unifyNum mine (nVar v) (nVar v') + + lhsStrictMono :: StrictMono (VVar Z) -> NumVal (VVar Z) -> Checking () + lhsStrictMono (StrictMono 0 mono) num = lhsMono mono num + lhsStrictMono (StrictMono n mono) num = do + num <- traceChecking "lhsSM demandEven" demandEven num + unifyNum mine (NumValue 0 (StrictMonoFun (StrictMono (n - 1) mono))) num + + lhsMono :: Monotone (VVar Z) -> NumVal (VVar Z) -> Checking () + lhsMono (Linear (VPar e)) num | x <- mine e, trail ("lhsMono\n " ++ show e ++ "\n " ++ show num ++ "\n " ++ show x) False = undefined + -- x = f(x) has 3 solutions, otherwise we should complain! + lhsMono lhs@(Linear (VPar e)) num | [e'] <- numVars num, e == e' = case num of + (NumValue 0 (StrictMonoFun sm)) -> case anyDoubsAnyFulls sm of + (True, _) -> lhsMono lhs (nConstant 0) + (False, True) -> mkYield "lhsMono2Sols" (S.singleton e) >> + unifyNum mine (nVar (VPar e)) num + (False, False) -> pure () + _ -> err . UnificationError $ "Can't make " ++ show e ++ " = " ++ show num + lhsMono (Linear (VPar e)) num = case mine e of + Just loc -> loc -! solveNumMeta mine e num + _ -> mkYield "lhsMono" (S.singleton e) >> + unifyNum mine (nVar (VPar e)) num + lhsMono (Full sm) (NumValue 0 (StrictMonoFun (StrictMono 0 (Full sm')))) + = lhsFun00 (StrictMonoFun sm) (NumValue 0 (StrictMonoFun sm')) + lhsMono m@(Full _) (NumValue 0 gro) = trail "lhsMono swaps" $ lhsFun00 gro (NumValue 0 (StrictMonoFun (StrictMono 0 m))) + lhsMono (Full sm) (NumValue up gro) = do + smPred <- traceChecking "lhsMono demandSucc" demandSucc (NumValue 0 (StrictMonoFun sm)) + _ <- numEval S0 sm + -- trailM $ "succ now " ++ show (quoteNum Zy sm) + unifyNum mine (n2PowTimes 1 (nFull smPred)) (NumValue (up - 1) gro) + + anyDoubsAnyFulls :: StrictMono (VVar Z) -> (Bool, Bool) + anyDoubsAnyFulls (StrictMono k (Full rest)) = let (ds,_) = anyDoubsAnyFulls rest in (k > 0 || ds, True) + anyDoubsAnyFulls (StrictMono k (Linear _)) = (k > 0, False) + + demand0 :: NumVal (VVar Z) -> Checking () + demand0 (NumValue 0 Constant0) = pure () + demand0 n@(NumValue 0 (StrictMonoFun (StrictMono _ mono))) = case mono of + Linear (VPar e) | Just _ <- mine e -> solveNumMeta mine e (nConstant 0) + Full sm -> demand0 (NumValue 0 (StrictMonoFun sm)) + _ -> err . UnificationError $ "Couldn't force " ++ show n ++ " to be 0" + demand0 n = err . UnificationError $ "Couldn't force " ++ show n ++ " to be 0" + + -- Complain if a number isn't a successor, else return its predecessor + demandSucc :: NumVal (VVar Z) -> Checking (NumVal (VVar Z)) + -- 2^k * x + -- = 2^k * (y + 1) + -- = 2^k + 2^k * y + -- Hence, the predecessor is (2^k - 1) + (2^k * y) + demandSucc (NumValue k x) | k > 0 = pure (NumValue (k - 1) x) + demandSucc (NumValue 0 (StrictMonoFun (mono@(StrictMono k (Linear (VPar e)))))) + | Just loc <- mine e = do + pred <- loc -! traceChecking "makePred" makePred e + pure (nPlus ((2^k) - 1) (nVar (VPar pred))) + + -- 2^k * full(n + 1) + -- = 2^k * (1 + 2 * full(n)) + -- = 2^k + 2^(k + 1) * full(n) + + | otherwise = do + mkYield "demandSucc" (S.singleton e) + nv <- quoteNum Zy <$> numEval S0 mono + demandSucc nv + + -- if it's not "mine" should we wait? + demandSucc (NumValue 0 (StrictMonoFun (StrictMono k (Full nPlus1)))) = do + n <- traceChecking "demandSucc" demandSucc (NumValue 0 (StrictMonoFun nPlus1)) + -- foo <- numEval S0 x + -- trailM $ "ds: " ++ show x ++ " -> " ++ show (quoteNum Zy foo) + pure $ nPlus ((2 ^ k) - 1) $ n2PowTimes (k + 1) $ nFull n + demandSucc n = err . UnificationError $ "Couldn't force " ++ show n ++ " to be a successor" + + -- Complain if a number isn't even, otherwise return half + demandEven :: NumVal (VVar Z) -> Checking (NumVal (VVar Z)) + demandEven (NumValue up gro) = case up `divMod` 2 of + (up, 0) -> nPlus up <$> traceChecking "evenGro" evenGro gro + (up, 1) -> nPlus (up + 1) <$> traceChecking "oddGro" oddGro (NumValue 0 gro) + where + evenGro :: Fun00 (VVar Z) -> Checking (NumVal (VVar Z)) + evenGro Constant0 = pure $ nConstant 0 + evenGro (StrictMonoFun (StrictMono 0 mono)) = case mono of + Linear (VPar e) + | Just loc <- mine e -> loc -! do + -- trailM $ "Calling makeHalf (" ++ show e ++ ")" + half <- traceChecking "makeHalf" makeHalf e + pure (NumValue 0 (StrictMonoFun (StrictMono 0 (Linear (VPar half))))) + | otherwise -> do + mkYield "evenGro" (S.singleton e) + nv <- quoteNum Zy <$> numEval S0 mono + demandEven nv + Full sm -> nConstant 0 <$ demand0 (NumValue 0 (StrictMonoFun sm)) + evenGro (StrictMonoFun (StrictMono n mono)) = pure (NumValue 0 (StrictMonoFun (StrictMono (n - 1) mono))) + + -- Check a numval is odd, and return its rounded down half + oddGro :: NumVal (VVar Z) -> Checking (NumVal (VVar Z)) + oddGro x = do + pred <- demandSucc x + demandEven pred diff --git a/brat/Brat/Checker/SolvePatterns.hs b/brat/Brat/Checker/SolvePatterns.hs index 7339157d..cd49a366 100644 --- a/brat/Brat/Checker/SolvePatterns.hs +++ b/brat/Brat/Checker/SolvePatterns.hs @@ -1,8 +1,10 @@ -module Brat.Checker.SolvePatterns (argProblems, argProblemsWithLeftovers, solve) where +module Brat.Checker.SolvePatterns (argProblems, argProblemsWithLeftovers, solve, typeOfEnd) where import Brat.Checker.Monad import Brat.Checker.Helpers import Brat.Checker.Types (EndType(..)) +import Brat.Checker.SolveNumbers +import Brat.Checker.SolveHoles import Brat.Constructors import Brat.Constructors.Patterns import Brat.Error @@ -16,13 +18,14 @@ import Brat.QualName import Bwd import Control.Monad.Freer import Hasochism +import Brat.Syntax.Port (toEnd) import Control.Monad (unless) import Data.Bifunctor (first) +import Data.Functor ((<&>)) import qualified Data.Map as M import Data.Maybe (fromJust) import Data.Type.Equality ((:~:)(..), testEquality) -import Brat.Syntax.Port (toEnd) -- Refine clauses from function definitions (and potentially future case statements) -- by processing each one in sequence. This will involve repeating tests for various @@ -60,12 +63,19 @@ solve :: forall m. Modey m ) solve _ [] = pure ([], []) solve my ((src, DontCare):p) = do - () <- case my of + case my of Kerny -> do ty <- typeOfSrc Kerny src unless (fromJust (copyable ty)) $ typeErr $ "Ignoring linear variable of type " ++ show ty - Braty -> pure () - solve my p + solve my p + Braty -> do + ty <- typeOfSrc Braty src + (tests, sol) <- solve my p + case ty of + Right _ -> pure (tests, sol) + -- Kinded things might be used to solve hopes. We pass them through so + -- that we can do the proper wiring in this case + Left _ -> pure (tests, ('_':portName src, (src, ty)):sol) solve my ((src, Bind x):p) = do ty <- typeOfSrc my src (tests, sol) <- solve my p @@ -77,38 +87,38 @@ solve my ((src, Lit tm):p) = do (Braty, Left Nat) | Num n <- tm -> do unless (n >= 0) $ typeErr "Negative Nat kind" - unifyNum (nConstant (fromIntegral n)) (nVar (VPar (toEnd src))) + mine <- mineToSolve + unifyNum mine (nConstant (fromIntegral n)) (nVar (VPar (toEnd src))) (Braty, Right ty) -> do - throwLeft (simpleCheck Braty ty tm) + simpleCheck Braty ty tm _ -> typeErr $ "Literal " ++ show tm ++ " isn't valid at this type" (tests, sol) <- solve my p pure ((src, PrimLitTest tm):tests, sol) solve my ((src, PCon c abs):p) = do ty <- typeOfSrc my src + mine <- mineToSolve case (my, ty) of - -- TODO: When solving constructors, we need to provide actual wiring to get - -- from the fully applied constructor to the bound pattern variables. - -- E.g. for cons(x, xs), we need to actually take apart a Vec to get the x - -- and xs to put in the environment (Kerny, ty) -> solveConstructor Kerny src (c, abs) ty p (Braty, Right ty) -> solveConstructor Braty src (c, abs) ty p (Braty, Left Nat) -> case c of -- Special case for 0, so that we can call `unifyNum` instead of pattern -- matching using what's returned from `natConstructors` PrefixName [] "zero" -> do - unifyNum (nVar (VPar (toEnd src))) nZero + unifyNum mine (nVar (VPar (toEnd src))) nZero p <- argProblems [] (normaliseAbstractor abs) p (tests, sol) <- solve my p pure ((src, PrimLitTest (Num 0)):tests, sol) _ -> case M.lookup c natConstructors of + -- This `relationToInner` is very sus - it doesn't do any wiring! Just (Just _, relationToInner) -> do - (node, [], kids@[(dangling, _)], _) <- next "unpacked_nat" Hypo (S0, Some (Zy :* S0)) - R0 -- we don't need to wire the src in; we just need the inner stuff + (node, [], kids@[(dangling, _)], _) <- next "natComponentHypo" Hypo (S0, Some (Zy :* S0)) + R0 (REx ("inner", Nat) R0) + -- unifyNum should do the wiring for us unifyNum + mine (nVar (VPar (ExEnd (end src)))) (relationToInner (nVar (VPar (toEnd dangling)))) - -- TODO also do wiring corresponding to relationToInner p <- argProblems [dangling] (normaliseAbstractor abs) p (tests, sol) <- solve my p -- When we get @-patterns, we shouldn't drop this anymore @@ -118,7 +128,7 @@ solve my ((src, PCon c abs):p) = do typeOfEnd :: Modey m -> End -> Checking (BinderType m) -typeOfEnd my e = req (TypeOf e) >>= \case +typeOfEnd my e = (req (TypeOf e) <&> fst) >>= \case EndType my' ty | Just Refl <- testEquality my my' -> case my' of Braty -> case ty of @@ -156,161 +166,12 @@ solveConstructor my src (c, abs) ty p = do tyArgKinds <- tlup (Brat, tycon) -- Constrain tyargs to match pats trackM $ unlines ["unifys",show lhss,show tyArgKinds, show tyargs] - unifys lhss (snd <$> tyArgKinds) tyargs + typesEq "pretending to be unifys" (snd <$> tyArgKinds) lhss tyargs + -- unifys lhss (snd <$> tyArgKinds) tyargs p <- argProblems (fst <$> patArgWires) (normaliseAbstractor abs) p (tests, sol) <- solve my p pure ((src, PrimCtorTest c tycon node patArgWires) : tests, sol) -unifys :: [Val Z] -> [TypeKind] -> [Val Z] -> Checking () -unifys [] [] [] = pure () -unifys (l:ls) (k:ks) (r:rs) = unify l k r *> unifys ls ks rs -unifys _ _ _ = error "jagged unifyArgs lists" - --- Unify two Braty types -unify :: Val Z -> TypeKind -> Val Z -> Checking () -unify l k r = do - -- Only complain normalised terms - (l, r) <- (,) <$> eval S0 l <*> eval S0 r - eqTest "unify" k l r >>= \case - Right () -> pure () - Left _ -> case (l, r, k) of - (VCon c args, VCon c' args', Star []) - | c == c' -> do - ks <- tlup (Brat, c) - unifys args (snd <$> ks) args' - (VCon c args, VCon c' args', Dollar []) - | c == c' -> do - ks <- tlup (Kernel, c) - unifys args (snd <$> ks) args' - (VNum l, VNum r, Nat) -> unifyNum l r - (VApp (VPar x) B0, v, _) -> instantiateMeta x v - (v, VApp (VPar x) B0, _) -> instantiateMeta x v - -- TODO: Handle function types - -- TODO: Postpone this problem instead of giving up. Stick it an a list of - -- equations that we hope are true and check them once we've processed - -- the whole `Problem`. - (l, r, _) -> err . UnificationError $ "Can't unify " ++ show l ++ " with " ++ show r - --- Solve a metavariable statically - don't do anything dynamic --- Once a metavariable is solved, we expect to not see it again in a normal form. -instantiateMeta :: End -> Val Z -> Checking () -instantiateMeta e val = do - throwLeft (doesntOccur e val) - defineEnd e val - - --- Need to keep track of which way we're solving - which side is known/unknown --- Things which are dynamically unknown must be Tgts - information flows from Srcs --- ...But we don't need to do any wiring here, right? -unifyNum :: NumVal (VVar Z) -> NumVal (VVar Z) -> Checking () -unifyNum (NumValue lup lgro) (NumValue rup rgro) - | lup <= rup = lhsFun00 lgro (NumValue (rup - lup) rgro) - | otherwise = lhsFun00 rgro (NumValue (lup - rup) lgro) - where - lhsFun00 :: Fun00 (VVar Z) -> NumVal (VVar Z) -> Checking () - lhsFun00 Constant0 num = demand0 num - lhsFun00 (StrictMonoFun sm) num = lhsStrictMono sm num - - lhsStrictMono :: StrictMono (VVar Z) -> NumVal (VVar Z) -> Checking () - lhsStrictMono (StrictMono 0 mono) num = lhsMono mono num - lhsStrictMono (StrictMono n mono) num = do - num <- demandEven num - lhsStrictMono (StrictMono (n - 1) mono) num - - lhsMono :: Monotone (VVar Z) -> NumVal (VVar Z) -> Checking () - lhsMono (Linear v) num = case v of - VPar e -> instantiateMeta e (VNum num) - _ -> case num of -- our only hope is to instantiate the RHS - NumValue 0 (StrictMonoFun (StrictMono 0 (Linear (VPar (ExEnd e))))) -> instantiateMeta (toEnd e) (VNum (nVar v)) - _ -> err . UnificationError $ "Couldn't instantiate variable " ++ show v - lhsMono (Full sm) (NumValue 0 (StrictMonoFun (StrictMono 0 (Full sm')))) - = lhsStrictMono sm (NumValue 0 (StrictMonoFun sm')) - lhsMono m@(Full _) (NumValue 0 gro) = lhsFun00 gro (NumValue 0 (StrictMonoFun (StrictMono 0 m))) - lhsMono (Full sm) (NumValue up gro) = do - smPred <- demandSucc sm - unifyNum (n2PowTimes 1 (nFull smPred)) (NumValue (up - 1) gro) - - demand0 :: NumVal (VVar Z) -> Checking () - demand0 (NumValue 0 Constant0) = pure () - demand0 n@(NumValue 0 (StrictMonoFun (StrictMono _ mono))) = case mono of - Linear (VPar e) -> instantiateMeta e (VNum (nConstant 0)) - Full sm -> demand0 (NumValue 0 (StrictMonoFun sm)) - _ -> err . UnificationError $ "Couldn't force " ++ show n ++ " to be 0" - demand0 n = err . UnificationError $ "Couldn't force " ++ show n ++ " to be 0" - - -- Complain if a number isn't a successor, else return its predecessor - demandSucc :: StrictMono (VVar Z) -> Checking (NumVal (VVar Z)) - -- 2^k * x - -- = 2^k * (y + 1) - -- = 2^k + 2^k * y - demandSucc (StrictMono k (Linear (VPar (ExEnd out)))) = do - y <- mkPred out - pure $ nPlus ((2 ^ k) - 1) $ n2PowTimes k y - -- 2^k * full(n + 1) - -- = 2^k * (1 + 2 * full(n)) - -- = 2^k + 2^(k + 1) * full(n) - demandSucc (StrictMono k (Full nPlus1)) = do - n <- demandSucc nPlus1 - pure $ nPlus ((2 ^ k) - 1) $ n2PowTimes (k + 1) $ nFull n - demandSucc n = err . UnificationError $ "Couldn't force " ++ show n ++ " to be a successor" - - -- Complain if a number isn't even, otherwise return half - demandEven :: NumVal (VVar Z) -> Checking (NumVal (VVar Z)) - demandEven n@(NumValue up gro) = case up `divMod` 2 of - (up, 0) -> NumValue up <$> evenGro gro - (up, 1) -> nPlus (up + 1) <$> oddGro gro - where - evenGro :: Fun00 (VVar Z) -> Checking (Fun00 (VVar Z)) - evenGro Constant0 = pure Constant0 - evenGro (StrictMonoFun (StrictMono 0 mono)) = case mono of - Linear (VPar (ExEnd out)) -> do - half <- mkHalf out - pure (StrictMonoFun (StrictMono 0 (Linear (VPar (toEnd half))))) - Linear _ -> err . UnificationError $ "Can't force " ++ show n ++ " to be even" - Full sm -> StrictMonoFun sm <$ demand0 (NumValue 0 (StrictMonoFun sm)) - evenGro (StrictMonoFun (StrictMono n mono)) = pure (StrictMonoFun (StrictMono (n - 1) mono)) - - -- Check a numval is odd, and return its rounded down half - oddGro :: Fun00 (VVar Z) -> Checking (NumVal (VVar Z)) - oddGro (StrictMonoFun (StrictMono 0 mono)) = case mono of - Linear (VPar (ExEnd out)) -> mkPred out >>= demandEven - Linear _ -> err . UnificationError $ "Can't force " ++ show n ++ " to be even" - -- full(n + 1) = 1 + 2 * full(n) - -- hence, full(n) is the rounded down half - Full sm -> nFull <$> demandSucc sm - oddGro _ = err . UnificationError $ "Can't force " ++ show n ++ " to be even" - - -- Add dynamic logic to compute half of a variable. - mkHalf :: OutPort -> Checking Src - mkHalf out = do - (_, [], [(const2,_)], _) <- next "const2" (Const (Num 2)) (S0, Some (Zy :* S0)) - R0 - (RPr ("value", TNat) R0) - (_, [(lhs,_),(rhs,_)], [(half,_)], _) <- next "div2" (ArithNode Div) (S0, Some (Zy :* S0)) - (RPr ("left", TNat) (RPr ("right", TNat) R0)) - (RPr ("out", TNat) R0) - wire (NamedPort out "numerator", TNat, lhs) - wire (const2, TNat, rhs) - req $ Define (toEnd out) (VNum (n2PowTimes 1 (nVar (VPar (toEnd half))))) - pure half - - - -- Add dynamic logic to compute the predecessor of a variable, and return that - -- predecessor. - -- The variable must be a non-zero nat!! - mkPred :: OutPort -> Checking (NumVal (VVar Z)) - mkPred out = do - (_, [], [(const1,_)], _) <- next "const1" (Const (Num 1)) (S0, Some (Zy :* S0)) - R0 - (RPr ("value", TNat) R0) - (_, [(lhs,_),(rhs,_)], [(pred,_)], _) <- next "minus1" (ArithNode Sub) (S0, Some (Zy :* S0)) - (RPr ("left", TNat) (RPr ("right", TNat) R0)) - (RPr ("out", TNat) R0) - wire (NamedPort out "", TNat, lhs) - wire (const1, TNat, rhs) - req $ Define (ExEnd out) (VNum (nPlus 1 (nVar (VPar (toEnd pred))))) - pure (nVar (VPar (toEnd pred))) - -- The variable must be a non-zero nat!! patVal :: ValPat -> [End] -> (Val Z, [End]) -- Nat variables will only be found in a `NumPat`, not a `ValPat` diff --git a/brat/Brat/Checker/Types.hs b/brat/Brat/Checker/Types.hs index 4daae795..52fedf99 100644 --- a/brat/Brat/Checker/Types.hs +++ b/brat/Brat/Checker/Types.hs @@ -5,7 +5,7 @@ module Brat.Checker.Types (Overs, Unders ,ChkConnectors, SynConnectors ,Mode(..), Modey(..) ,Env, VEnv, KEnv, EnvData - ,Store(..), EndType(..) + ,IsSkolem(..), Store(..), EndType(..) ,emptyEnv ,TypedHole(..), HoleTag(..), HoleData(..) ,initStore @@ -94,8 +94,11 @@ instance Show EndType where show (EndType Braty (Left k)) = show k show (EndType Braty (Right ty)) = show ty +data IsSkolem = SkolemConst | Definable + deriving (Eq, Show) + data Store = Store - { typeMap :: M.Map End EndType + { typeMap :: M.Map End (EndType, IsSkolem) , valueMap :: M.Map End (Val Z) } diff --git a/brat/Brat/Compile/Hugr.hs b/brat/Brat/Compile/Hugr.hs index 67f6413b..6c169733 100644 --- a/brat/Brat/Compile/Hugr.hs +++ b/brat/Brat/Compile/Hugr.hs @@ -10,7 +10,7 @@ module Brat.Compile.Hugr (compile) where import Brat.Constructors.Patterns (pattern CFalse, pattern CTrue) -import Brat.Checker.Monad (track, trackM, CheckingSig(..)) +import Brat.Checker.Monad (track, trackM, CheckingSig(..), CaptureSets) import Brat.Checker.Helpers (binderToValue) import Brat.Checker.Types (Store(..), VEnv) import Brat.Eval (eval, evalCTy, kindType) @@ -26,7 +26,6 @@ import Control.Monad.Freer import Data.Hugr import Hasochism -import Control.Exception (assert) import Control.Monad (unless) import Data.Aeson import Data.Bifunctor (first, second) @@ -54,6 +53,7 @@ type TypedPort = (PortId NodeId, HugrType) data CompilationState = CompilationState { bratGraph :: Graph -- the input BRAT Graph; should not be written + , capSets :: CaptureSets -- environments captured by Box nodes in previous , nameSupply :: Namespace , nodes :: M.Map NodeId (HugrOp NodeId) -- this node's id => HugrOp containing parent id , edges :: [(PortId NodeId, PortId NodeId)] @@ -72,8 +72,9 @@ data CompilationState = CompilationState , decls :: M.Map Name (NodeId, Bool) } -emptyCS g ns store = CompilationState +emptyCS g cs ns store = CompilationState { bratGraph = g + , capSets = cs , nameSupply = ns , nodes = M.empty , edges = [] @@ -107,7 +108,7 @@ addEdge e = do addNode :: String -> HugrOp NodeId -> Compile NodeId addNode name op = do id <- freshNode name - addOp op id + addOp (addMetadata [("id", show id)] op) id pure id type Compile = State CompilationState @@ -127,6 +128,7 @@ instance FreshMonad Compile where put (s { nameSupply = nsNew }) pure v + whoAmI = gets (fst . nameSupply) runCheckingInCompile :: Free CheckingSig t -> Compile t runCheckingInCompile (Ret t) = pure t @@ -225,7 +227,11 @@ compileArithNode parent op TFloat = addNode (show op ++ "_Float") $ OpCustom $ compileArithNode _ _ ty = error $ "compileArithNode: Unexpected type " ++ show ty renameAndSortHugr :: M.Map NodeId (HugrOp NodeId) -> [(PortId NodeId, PortId NodeId)] -> Hugr Int -renameAndSortHugr nodes edges = fmap update (Hugr (fst <$> sorted_nodes) (edges ++ orderEdges)) where +renameAndSortHugr nodes edges = indexMetadata $ fmap update (Hugr (fst <$> sorted_nodes) (edges ++ orderEdges)) where + indexMetadata :: Hugr Int -> Hugr Int + indexMetadata (Hugr ops edges) = Hugr [addMetadata [("index", show ix)] op | (ix, op) <- zip [0..] ops] edges + + sorted_nodes = let ([root], rest) = partition (\(n, nid) -> nid == getParent n) (swap <$> M.assocs nodes) in root : sort rest @@ -283,9 +289,9 @@ compileClauses parent ins ((matchData, rhs) :| clauses) = do testResult <- compileMatchSequence parent portTbl matchSeq -- Feed the test result into a conditional - makeConditional parent testResult [] [("didntMatch", didntMatch outTys) - ,("didMatch", didMatch outTys) - ] + makeConditional ("clause of " ++ show rhs) parent testResult [] [("didntMatch", didntMatch outTys) + ,("didMatch", didMatch outTys) + ] where didntMatch :: [HugrType] -> NodeId -> [TypedPort] -> Compile [TypedPort] didntMatch outTys parent ins = case nonEmpty clauses of @@ -296,8 +302,8 @@ compileClauses parent ins ((matchData, rhs) :| clauses) = do didMatch :: [HugrType] -> NodeId -> [TypedPort] -> Compile [TypedPort] didMatch outTys parent ins = gets bratGraph >>= \(ns,_) -> case ns M.! rhs of - BratNode (Box _venv src tgt) _ _ -> do - dfgId <- addNode "DidMatch_DFG" (OpDFG (DFG parent (FunctionType (snd <$> ins) outTys bratExts))) + BratNode (Box src tgt) _ _ -> do + dfgId <- addNode "DidMatch_DFG" (OpDFG (DFG parent (FunctionType (snd <$> ins) outTys bratExts) [])) compileBox (src, tgt) dfgId for_ (zip (fst <$> ins) (Port dfgId <$> [0..])) addEdge pure $ zip (Port dfgId <$> [0..]) outTys @@ -396,13 +402,14 @@ compileWithInputs parent name = gets compiled >>= (\case Prim (ext,op) -> do let n = ext ++ ('_':op) let [] = ins + -- TODO: Handle primitives which aren't functions let [(_, VFun Braty cty)] = outs boxSig@(inputTys, outputTys) <- compileSig Braty cty let boxFunTy = FunctionType inputTys outputTys bratExts ((Port loadConst _, _ty), ()) <- compileConstDfg parent n boxSig $ \dfgId -> do - ins <- addNodeWithInputs ("Inputs" ++ n) (OpIn (InputNode dfgId inputTys)) [] inputTys + ins <- addNodeWithInputs ("Inputs" ++ n) (OpIn (InputNode dfgId inputTys [("source", "Prim")])) [] inputTys outs <- addNodeWithInputs n (OpCustom (CustomOp dfgId ext op boxFunTy [])) ins outputTys - addNodeWithInputs ("Outputs" ++ n) (OpOut (OutputNode dfgId outputTys)) outs [] + addNodeWithInputs ("Outputs" ++ n) (OpOut (OutputNode dfgId outputTys [("source", "Prim")])) outs [] pure () pure $ default_edges loadConst @@ -441,19 +448,21 @@ compileWithInputs parent name = gets compiled >>= (\case Nothing -> error "Callee has been erased" -- We need to figure out if this thunk contains a brat- or a kernel-computation - (Box venv src tgt) -> case outs of + (Box src tgt) -> case outs of [(_, VFun Kerny cty)] -> default_edges . nodeId . fst <$> - compileKernBox parent name (assert (M.null venv) $ compileBox (src, tgt)) cty - [(_, VFun Braty cty)] -> compileBratBox parent name (venv, src, tgt) cty <&> - (\(partialNode, captures) -> Just (partialNode, 1, captures)) -- 1 is arbitrary, Box has no real inputs + compileKernBox parent name (compileBox (src, tgt)) cty + [(_, VFun Braty cty)] -> do + cs <- gets (M.findWithDefault M.empty name . capSets) + (partialNode, captures) <- compileBratBox parent name (cs, src, tgt) cty + pure $ Just (partialNode, 1, captures) -- 1 is arbitrary, Box has no real inputs outs -> error $ "Unexpected outs of box: " ++ show outs Source -> default_edges <$> do outs <- compilePorts outs - addNode "Input" (OpIn (InputNode parent outs)) + addNode "Input" (OpIn (InputNode parent outs [("source", "Source"), ("parent", show parent)])) Target -> default_edges <$> do ins <- compilePorts ins - addNode "Output" (OpOut (OutputNode parent ins)) + addNode "Output" (OpOut (OutputNode parent ins [("source", "Target")])) Id | Nothing <- hasPrefix ["checking", "globals", "decl"] name -> default_edges <$> do -- not a top-level decl, just compile it as an Id (TLDs handled in compileNode) @@ -469,10 +478,10 @@ compileWithInputs parent name = gets compiled >>= (\case PatternMatch cs -> default_edges <$> do ins <- compilePorts ins outs <- compilePorts outs - dfgId <- addNode "DidMatch_DFG" (OpDFG (DFG parent (FunctionType ins outs bratExts))) - inputNode <- addNode "PatternMatch.Input" (OpIn (InputNode dfgId ins)) + dfgId <- addNode "DidMatch_DFG" (OpDFG (DFG parent (FunctionType ins outs bratExts) [])) + inputNode <- addNode "PatternMatch.Input" (OpIn (InputNode dfgId ins [("source", "PatternMatch"), ("parent", show dfgId)])) ccOuts <- compileClauses dfgId (zip (Port inputNode <$> [0..]) ins) cs - addNodeWithInputs "PatternMatch.Output" (OpOut (OutputNode dfgId (snd <$> ccOuts))) ccOuts [] + addNodeWithInputs "PatternMatch.Output" (OpOut (OutputNode dfgId (snd <$> ccOuts) [("source", "PatternMatch"), ("parent", show dfgId)])) ccOuts [] pure dfgId ArithNode op -> default_edges <$> compileArithNode parent op (snd $ head ins) Selector _c -> error "Todo: selector" @@ -490,7 +499,7 @@ compileConstructor parent tycon con sig -- A boolean value is a tag which takes no inputs and produces an empty tuple -- This is the same thing that happens in Brat.Checker.Clauses to make the -- discriminator (makeRowTag) - addNode "bool.tag" (OpTag (TagOp parent (if b then 1 else 0) [[], []])) + addNode "bool.tag" (OpTag (TagOp parent (if b then 1 else 0) [[], []] [("hint", "bool")])) | otherwise = let name = "Constructor " ++ show tycon ++ "::" ++ show con in addNode name (constructorOp parent tycon con sig) where @@ -517,17 +526,17 @@ compileConstDfg :: NodeId -> String -> ([HugrType], [HugrType]) -> (NodeId -> Co compileConstDfg parent desc (inTys, outTys) contents = do st <- gets store g <- gets bratGraph + cs <- gets capSets + let funTy = FunctionType inTys outTys bratExts -- First, we fork off a new namespace - ((funTy, a), cs) <- desc -! do + (a, cs) <- desc -! do ns <- gets nameSupply - pure $ flip runState (emptyCS g ns st) $ do + pure $ flip runState (emptyCS g cs ns st) $ do -- make a DFG node at the root. We can't use `addNode` since the -- DFG needs itself as parent dfg_id <- freshNode ("Box_" ++ show desc) - a <- contents dfg_id - let funTy = FunctionType inTys outTys bratExts - addOp (OpDFG $ DFG dfg_id funTy) dfg_id - pure (funTy, a) + addOp (OpDFG $ DFG dfg_id funTy []) dfg_id + contents dfg_id let nestedHugr = renameAndSortHugr (nodes cs) (edges cs) let ht = HTFunc $ PolyFuncType [] funTy @@ -553,7 +562,7 @@ compileBratBox parent name (venv, src, tgt) cty = do let boxInnerSig = FunctionType allInputTys outputTys bratExts (templatePort, _) <- compileConstDfg parent ("BB" ++ show name) (allInputTys, outputTys) $ \dfgId -> do - src_id <- addNode ("LiftedCapturesInputs" ++ show name) (OpIn (InputNode dfgId allInputTys)) + src_id <- addNode ("LiftedCapturesInputs" ++ show name) (OpIn (InputNode dfgId allInputTys [("source", "compileBratBox")])) -- Now map ports in the BRAT Graph to their Hugr equivalents. -- Each captured value is read from an element of src_id, starting from 0 let lifted = [(src, Port src_id i) | ((src, _ty), i) <- zip params [0..]] @@ -625,12 +634,12 @@ compileMatchSequence parent portTable (MatchSequence {..}) = do testResult <- compilePrimTest parent typedPort primTest let testIx = length left let remainingMatchTests = MatchSequence (primTestOuts primTest ++ (second snd <$> others)) tests matchOutputs - ports <- makeConditional parent testResult (snd <$> others) + ports <- makeConditional ("matching " ++ show (src, primTest)) parent testResult (snd <$> others) [("didNotMatch", didNotMatchCase testIx sumTy) ,("didMatch", didMatchCase testIx (primTest, snd typedPort) remainingMatchTests sumTy)] case ports of - [port] -> pure port - _ -> error "Expected exactly one output port from makeConditional" + (port:_) -> pure port + _ -> error $ "Expected at least one output port from makeConditional: got\n " ++ show ports [] -> do -- Reorder into `matchOutputs` order @@ -656,7 +665,7 @@ compileMatchSequence parent portTable (MatchSequence {..}) = do -- Remember which port a src corresponds to let portTable = zip (fst <$> matchInputs) ins didAllTestsSucceed <- compileMatchSequence parent portTable ms - makeConditional parent didAllTestsSucceed [] + makeConditional ("all matched (" ++ show ix ++ ")") parent didAllTestsSucceed [] [("Undo", undo) ,("AllMatched", allMatched) ] @@ -691,8 +700,10 @@ compileMatchSequence parent portTable (MatchSequence {..}) = do makeRowTag "DidNotMatch" parent 0 sumTy ins makeRowTag :: String -> NodeId -> Int -> SumOfRows -> [TypedPort] -> Compile [TypedPort] -makeRowTag hint parent tag sor@(SoR sumRows) ins = assert (sumRows !! tag == (snd <$> ins)) $ - addNodeWithInputs (hint ++ "_Tag") (OpTag (TagOp parent tag sumRows)) ins [compileSumOfRows sor] +makeRowTag hint parent tag sor@(SoR sumRows) ins = + if sumRows !! tag == (snd <$> ins) + then addNodeWithInputs (hint ++ "_Tag") (OpTag (TagOp parent tag sumRows [("hint", hint), ("tag", show tag), ("row", show (sumRows!!tag))])) ins [compileSumOfRows sor] + else error $ "In makeRowTag " ++ hint ++ ", Elements " ++ show (snd <$> ins) ++ " do not match tag " ++ show tag ++ " of " ++ show sumRows getSumVariants :: HugrType -> [[HugrType]] getSumVariants (HTSum (SU (UnitSum n))) = replicate n [] @@ -710,19 +721,20 @@ addNodeWithInputs name op inWires outTys = do for_ (zip (fst <$> inWires) (Port nodeId <$> [0..])) addEdge pure $ zip (Port nodeId <$> [0..]) outTys -makeConditional :: NodeId -- Parent node id +makeConditional :: String -- Label + -> NodeId -- Parent node id -> TypedPort -- The discriminator -> [TypedPort] -- Other inputs -> [(String, NodeId -> [TypedPort] -> Compile [TypedPort])] -- Must be ordered -> Compile [TypedPort] -makeConditional parent discrim otherInputs cases = do +makeConditional lbl parent discrim otherInputs cases = do condId <- freshNode "Conditional" let rows = getSumVariants (snd discrim) outTyss <- for (zip (zip [0..] cases) rows) (\((ix, (name, f)), row) -> makeCase condId name ix (row ++ (snd <$> otherInputs)) f) unless (allRowsEqual outTyss) (error "Conditional output types didn't match") - let condOp = OpConditional (Conditional parent rows (snd <$> otherInputs) (head outTyss)) + let condOp = OpConditional (Conditional parent rows (snd <$> otherInputs) (head outTyss) [("label", lbl)]) addOp condOp condId addEdge (fst discrim, Port condId 0) traverse_ addEdge (zip (fst <$> otherInputs) (Port condId <$> [1..])) @@ -731,14 +743,12 @@ makeConditional parent discrim otherInputs cases = do makeCase :: NodeId -> String -> Int -> [HugrType] -> (NodeId -> [TypedPort] -> Compile [TypedPort]) -> Compile [HugrType] makeCase parent name ix tys f = do caseId <- freshNode name - inpId <- addNode ("Input_" ++ name) (OpIn (InputNode caseId tys)) + inpId <- addNode ("Input_" ++ name) (OpIn (InputNode caseId tys [("source", "makeCase." ++ show ix), ("context", lbl ++ "/" ++ name), ("parent", show parent)])) outs <- f caseId (zipWith (\offset ty -> (Port inpId offset, ty)) [0..] tys) let outTys = snd <$> outs - - outId <- addNode ("Output" ++ name) (OpOut (OutputNode caseId outTys)) + outId <- addNode ("Output" ++ name) (OpOut (OutputNode caseId outTys [("source", "makeCase")])) for_ (zip (fst <$> outs) (Port outId <$> [0..])) addEdge - - addOp (OpCase (ix, Case parent (FunctionType tys outTys bratExts))) caseId + addOp (OpCase (ix, Case parent (FunctionType tys outTys bratExts) [("name",lbl ++ "/" ++ name)])) caseId pure outTys allRowsEqual :: [[HugrType]] -> Bool @@ -806,7 +816,7 @@ compileModule venv = do -- to compute its value. bodies <- for decls (\(fnName, idNode) -> do (funTy, extra_call, body) <- analyseDecl idNode - defNode <- addNode (show fnName ++ "_def") (OpDefn $ FuncDefn moduleNode (show fnName) funTy) + defNode <- addNode (show fnName ++ "_def") (OpDefn $ FuncDefn moduleNode (show fnName) funTy []) registerFuncDef idNode (defNode, extra_call) pure (body defNode) ) @@ -829,7 +839,7 @@ compileModule venv = do let srcPortTys = [(srcPort, ty) | (srcPort, ty, In tgt _) <- es, tgt == idNode ] case srcPortTys of -- All top-level functions are compiled into Box-es, which should look like this: - [(Ex input 0, _)] | Just (BratNode (Box _ src tgt) _ outs) <- M.lookup input ns -> + [(Ex input 0, _)] | Just (BratNode (Box src tgt) _ outs) <- M.lookup input ns -> case outs of [(_, VFun Braty cty)] -> do (inTys, outTys) <- compileSig Braty cty @@ -851,8 +861,8 @@ compileModule venv = do withIO :: NodeId -> HugrType -> Compile TypedPort -> Compile () withIO parent output c = do - addNode "input" (OpIn (InputNode parent [])) - output <- addNode "output" (OpOut (OutputNode parent [output])) + addNode "input" (OpIn (InputNode parent [] [("source", "analyseDecl")])) + output <- addNode "output" (OpOut (OutputNode parent [output] [("source", "analyseDecl")])) wire <- c addEdge (fst wire, Port output 0) @@ -876,8 +886,8 @@ compileModule venv = do compileNoun :: [HugrType] -> [OutPort] -> NodeId -> Compile () compileNoun outs srcPorts parent = do - addNode "input" (OpIn (InputNode parent [])) - output <- addNode "output" (OpOut (OutputNode parent outs)) + addNode "input" (OpIn (InputNode parent [] [("source", "compileNoun")])) + output <- addNode "output" (OpOut (OutputNode parent outs [("source", "compileNoun")])) for_ (zip [0..] srcPorts) (\(outport, Ex src srcPort) -> compileWithInputs parent src >>= \case Just nodeId -> addEdge (Port nodeId srcPort, Port output outport) $> () @@ -887,13 +897,14 @@ compileNoun outs srcPorts parent = do compile :: Store -> Namespace -> Graph + -> CaptureSets -> VEnv -> BS.ByteString -compile store ns g venv +compile store ns g capSets venv = evalState (trackM "compileFunctions" *> compileModule venv *> trackM "dumpJSON" *> dumpJSON ) - (emptyCS g ns store) + (emptyCS g capSets ns store) diff --git a/brat/Brat/Compiler.hs b/brat/Brat/Compiler.hs index 3414bc85..093195be 100644 --- a/brat/Brat/Compiler.hs +++ b/brat/Brat/Compiler.hs @@ -23,7 +23,7 @@ import System.Exit (die) printDeclsHoles :: [FilePath] -> String -> IO () printDeclsHoles libDirs file = do env <- runExceptT $ loadFilename root libDirs file - (_, decls, holes, _, _) <- eitherIO env + (_, decls, holes, _, _, _) <- eitherIO env putStrLn "Decls:" print decls putStrLn "" @@ -56,7 +56,8 @@ printAST printRaw printAST file = do writeDot :: [FilePath] -> String -> String -> IO () writeDot libDirs file out = do env <- runExceptT $ loadFilename root libDirs file - (_, _, _, _, graph) <- eitherIO env + -- Discard captureSets; perhaps we could incorporate into the graph + (_, _, _, _, graph, _) <- eitherIO env writeFile out (toDotString graph) {- where @@ -74,10 +75,10 @@ compileFile :: [FilePath] -> String -> IO (Either CompilingHoles BS.ByteString) compileFile libDirs file = do let (checkRoot, newRoot) = split "checking" root env <- runExceptT $ loadFilename checkRoot libDirs file - (venv, _, holes, defs, outerGraph) <- eitherIO env + (venv, _, holes, defs, outerGraph, capSets) <- eitherIO env case holes of [] -> Right <$> evaluate -- turns 'error' into IO 'die' - (compile defs newRoot outerGraph venv) + (compile defs newRoot outerGraph capSets venv) hs -> pure $ Left (CompilingHoles hs) compileAndPrintFile :: [FilePath] -> String -> IO () diff --git a/brat/Brat/Dot.hs b/brat/Brat/Dot.hs index 9acc9645..17aed1fc 100644 --- a/brat/Brat/Dot.hs +++ b/brat/Brat/Dot.hs @@ -50,7 +50,7 @@ toDotString (ns,ws) = unpack . GV.printDotGraph $ GV.graphElemsToDot params vert getRefEdge :: Name' -> Node -> [(Name', Name', EdgeType)] getRefEdge x (BratNode (Eval (Ex y _)) _ _) = [(Name' y, x, EvalEdge)] getRefEdge x (KernelNode (Splice (Ex y _)) _ _) = [(Name' y, x, EvalEdge)] - getRefEdge x (BratNode (Box _ src _) _ _) = [(x, Name' src, SrcEdge)] + getRefEdge x (BratNode (Box src _) _ _) = [(x, Name' src, SrcEdge)] getRefEdge _ _ = [] -- Map all nodes in a box to the src node @@ -59,7 +59,7 @@ toDotString (ns,ws) = unpack . GV.printDotGraph $ GV.graphElemsToDot params vert where (g, toNode, toVert) = toGraph (ns, ws) f (_, node) m = case node of - BratNode (Box _ src tgt) _ _ -> + BratNode (Box src tgt) _ _ -> -- Find all nodes in the box spanned by src and tgt, i.e. all nodes -- reachable from src that can reach tgt let srcReaches = reachable g (fromJust (toVert src)) diff --git a/brat/Brat/Elaborator.hs b/brat/Brat/Elaborator.hs index 5a4ed219..2546dca3 100644 --- a/brat/Brat/Elaborator.hs +++ b/brat/Brat/Elaborator.hs @@ -91,7 +91,7 @@ elaborate (WC fc x) = do elaborate' :: Flat -> Either Error SomeRaw' elaborate' (FVar x) = pure $ SomeRaw' (RVar x) -elaborate' FHope = pure $ SomeRaw' RHope +elaborate' (FHope ident) = pure $ SomeRaw' (RHope ident) elaborate' (FArith op a b) = do (SomeRaw a) <- elaborate a (SomeRaw b) <- elaborate b diff --git a/brat/Brat/Eval.hs b/brat/Brat/Eval.hs index 3625c80b..d7ee14c6 100644 --- a/brat/Brat/Eval.hs +++ b/brat/Brat/Eval.hs @@ -2,6 +2,7 @@ module Brat.Eval (EvMode(..) ,ValPat(..) + ,NumEval(..) ,NumPat(..) ,apply ,applySem @@ -17,7 +18,9 @@ module Brat.Eval (EvMode(..) ,kindType ,numVal ,quote + ,quoteNum ,getNumVar + ,instantiateMeta ) where import Brat.Checker.Monad @@ -117,7 +120,7 @@ semLvl lvy = SApp (SLvl $ ny2int lvy) B0 -- note that typeEq is a kind of quote but that also does eta-expansion quote :: Ny lv -> Sem -> Checking (Val lv) -quote lvy (SNum num) = pure $ VNum (fmap (quoteVar lvy) num) +quote lvy (SNum num) = pure $ VNum (quoteNum lvy num) quote lvy (SCon nm args) = VCon nm <$> traverse (quote lvy) args quote lvy (SLam stk body) = do body <- sem (stk :<< semLvl lvy) body @@ -130,6 +133,9 @@ quoteCTy lvy my ga (ins :->> outs) = quoteRo my ga ins lvy >>= \case (ga', Some (ins' :* lvy')) -> quoteRo my ga' outs lvy' >>= \case (_, Some (outs' :* _)) -> pure (ins' :->> outs') +quoteNum :: Ny lv -> NumVal SVar -> NumVal (VVar lv) +quoteNum lvy num = fmap (quoteVar lvy) num + -- first number is next Lvl to use in Value -- require every Lvl in Sem is < n (converted by n - 1 - lvl), else must fail at runtime quoteVar :: Ny n -> SVar -> VVar n @@ -186,7 +192,7 @@ kindEq (TypeFor m xs) (TypeFor m' ys) | m == m' = kindListEq xs ys kindEq k k' = Left . TypeErr $ "Unequal kinds " ++ show k ++ " and " ++ show k' kindOf :: VVar Z -> Checking TypeKind -kindOf (VPar e) = req (TypeOf e) >>= \case +kindOf (VPar e) = (req (TypeOf e) <&> fst) >>= \case EndType Braty (Left k) -> pure k EndType my ty -> typeErr $ "End " ++ show e ++ " isn't a kind, it's type is " ++ case my of Braty -> show ty @@ -306,6 +312,7 @@ getNumVar _ = Nothing -- We can have bogus failures here because we're not normalising under lambdas -- N.B. the value argument is normalised. doesntOccur :: End -> Val n -> Either ErrorMsg () +-- ALAN merge could have been: doesntOccur e (VNum nv) = for_ (getNumVar nv) (collision e) doesntOccur e (VNum nv) = traverse_ (collision e) (getNumVar nv) doesntOccur e (VApp var args) = case var of VPar e' -> collision e e' *> traverse_ (doesntOccur e) args @@ -316,6 +323,12 @@ doesntOccur e (VFun my (ins :->> outs)) = case my of Braty -> doesntOccurRo my e ins *> doesntOccurRo my e outs Kerny -> doesntOccurRo my e ins *> doesntOccurRo my e outs +-- This should only be called after checking we have the right to solve the end +instantiateMeta :: String -> End -> Val Z -> Checking () +instantiateMeta lbl e val = do + throwLeft (doesntOccur e val) + defineEnd (lbl ++ "->instantiateMeta") e val + collision :: End -> End -> Either ErrorMsg () collision e v | e == v = Left . UnificationError $ show e ++ " is cyclic" diff --git a/brat/Brat/Graph.hs b/brat/Brat/Graph.hs index 50bad752..62c4619b 100644 --- a/brat/Brat/Graph.hs +++ b/brat/Brat/Graph.hs @@ -2,7 +2,6 @@ module Brat.Graph where -import Brat.Checker.Types (VEnv) import Brat.Naming import Brat.QualName import Brat.Syntax.Common @@ -35,8 +34,7 @@ data NodeType :: Mode -> Type where Const :: SimpleTerm -> NodeType a Eval :: OutPort -> NodeType Brat -- A computation on a wire Splice :: OutPort -> NodeType Kernel -- A computation (classical) to add to this kernel - Box :: VEnv -- Parameters that are in scope - -> Name -- Source node + Box :: Name -- Source node -> Name -- Target node -> NodeType Brat -- Graph in a box Source :: NodeType a -- For building.. diff --git a/brat/Brat/Load.hs b/brat/Brat/Load.hs index 56f65efc..75570454 100644 --- a/brat/Brat/Load.hs +++ b/brat/Brat/Load.hs @@ -24,7 +24,6 @@ import Brat.QualName import Util (duplicates,duplicatesWith) import Hasochism -import Control.Exception (assert) import Control.Monad (filterM, foldM, forM, forM_, unless) import Control.Monad.Except import Control.Monad.Trans.Class (lift) @@ -50,10 +49,12 @@ type VMod = (VEnv ,[(QualName, VDecl)] -- all symbols from all modules ,[TypedHole] -- for just the last module ,Store -- Ends declared & defined in the module - ,Graph) -- per function, first elem is name + ,Graph -- all functions in this module, nodes identified from first VEnv + ,CaptureSets -- for nodes in this module's Graph only + ) emptyMod :: VMod -emptyMod = (M.empty, [], [], initStore, (M.empty, [])) +emptyMod = (M.empty, [], [], initStore, (M.empty, []), M.empty) -- N.B. This should only be passed local functions -- If the decl is a function with pattern matching clauses, return the Name of @@ -67,7 +68,7 @@ checkDecl pre (VDecl FuncDecl{..}) to_define = (fnName -!) $ localFC fnLoc $ do -- We must have a row of nouns as the definition Nothing -> case fnBody of NoLhs body -> do - (((), ()), ((), rightUnders)) <- let ?my = Braty in check body ((), to_define) + (((), ()), ((), rightUnders)) <- let ?my = Braty in "$rhs" -! check body ((), to_define) case rightUnders of [] -> pure () _ -> localFC (fcOf body) $ @@ -92,7 +93,7 @@ checkDecl pre (VDecl FuncDecl{..}) to_define = (fnName -!) $ localFC fnLoc $ do Kerny -> wire (box_out, VFun my cty, thunk_in) [] -> err $ ExpectedThunk (showMode my) "No body" row -> err $ ExpectedThunk (showMode my) (showRow row) - Left body -> let ?my = Braty in check body ((), to_define) $> () + Left body -> let ?my = Braty in "$rhs" -! check body ((), to_define) $> () where getClauses :: FunBody Term Noun -> (Modey m, CTy m Z) @@ -138,7 +139,7 @@ loadStmtsWithEnv ns (venv, oldDecls, oldEndData) (fname, pre, stmts, cts) = addS -- * A map from names to VDecls (aka an Env) -- * Some overs and outs?? let (globalNS, newRoot) = split "globals" ns - (entries, (_holes, kcStore, kcGraph)) <- run venv initStore globalNS $ + (entries, (holes, kcStore, kcGraph, capSets)) <- run venv initStore globalNS $ withAliases aliases $ forM decls $ \d -> localFC (fnLoc d) $ do let name = PrefixName pre (fnName d) (thing, ins :->> outs, sig, prefix) <- case fnLocality d of @@ -154,16 +155,18 @@ loadStmtsWithEnv ns (venv, oldDecls, oldEndData) (fname, pre, stmts, cts) = addS (_, unders, overs, _) <- prefix -! next (show name) thing (S0, Some (Zy :* S0)) ins outs pure ((name, VDecl d{fnSig=sig}), (unders, overs)) trackM "finished kind checking" + unless (length holes == 0) $ error "Should be no holes from kind-checking" + unless (M.null capSets) $ error "Should be no captures from kind-checking" -- We used to check there were no holes from that, but for now we do not bother -- A list of local functions (read: with bodies) to define with checkDecl let to_define = M.fromList [ (name, unders) | ((name, VDecl decl), (unders, _)) <- entries, fnLocality decl == Local ] let vdecls = map fst entries -- Now generate environment mapping usernames to nodes in the graph venv <- pure $ venv <> M.fromList [(name, overs) | ((name, _), (_, overs)) <- entries] - ((), (holes, newEndData, graph)) <- run venv kcStore newRoot $ withAliases aliases $ do + ((), (holes, newEndData, graph, capSets)) <- run venv kcStore newRoot $ withAliases aliases $ do remaining <- "check_defs" -! foldM checkDecl' to_define vdecls - pure $ assert (M.null remaining) () -- all to_defines were defined - pure (venv, oldDecls <> vdecls, holes, oldEndData <> newEndData, kcGraph <> graph) + if M.null remaining then pure () else error $ "loadStmtsWithEnv: expected to define " ++ show (M.keys remaining) + pure (venv, oldDecls <> vdecls, holes, oldEndData <> newEndData, kcGraph <> graph, capSets) where checkDecl' :: M.Map QualName [(Tgt, BinderType Brat)] -> (QualName, VDecl) @@ -209,11 +212,10 @@ loadFiles ns (cwd :| extraDirs) fname contents = do let main = (cwd fname ++ ".brat", [], mainStmts, mainCts) pure (deps ++ [main]) Nothing -> throwError (SrcErr "" $ dumbErr (InternalError "Empty dependency graph")) - -- keep (as we fold) and then return only the graphs from the last file in the list + -- keep VEnv as we fold but discard holes, graph and captures except from the last file in the list liftEither $ foldM - (\(venv, decls, _, defs, _) -> loadStmtsWithEnv ns (venv, decls, defs)) + (\(venv, decls, _, defs, _, _) -> loadStmtsWithEnv ns (venv, decls, defs)) emptyMod --- (fname, [], M.empty, contents) allStmts' where -- builds a map from Import to (index in which discovered, module) diff --git a/brat/Brat/Naming.hs b/brat/Brat/Naming.hs index b1719526..c5804fde 100644 --- a/brat/Brat/Naming.hs +++ b/brat/Brat/Naming.hs @@ -45,4 +45,4 @@ instance Show Name where class Monad m => FreshMonad m where freshName :: String -> m Name (-!) :: String -> m a -> m a - + whoAmI :: m (Bwd (String, Int)) diff --git a/brat/Brat/Parser.hs b/brat/Brat/Parser.hs index 1b0e6513..e9ce29fe 100644 --- a/brat/Brat/Parser.hs +++ b/brat/Brat/Parser.hs @@ -413,9 +413,15 @@ atomExpr = simpleExpr <|> inBracketsFC Paren (unWC <$> expr) <|> var <|> fmap (const FUnderscore) <$> matchFC Underscore <|> fmap (const FIdentity) <$> matchFC Pipe - <|> fmap (const FHope) <$> matchFC Bang + <|> pHope +pHope :: Parser (WC Flat) +pHope = do + WC bangFC () <- matchFC Bang + maybeWCName <- optional simpleName + pure (maybe (WC bangFC (FHope "")) (\(WC identFC ident) -> WC (spanFC bangFC identFC) (FHope ident)) maybeWCName) + {- Infix operator precedence table (See Brat.Syntax.Common.Precedence) (loosest to tightest binding): => diff --git a/brat/Brat/Syntax/Common.hs b/brat/Brat/Syntax/Common.hs index f90dbed6..f393755d 100644 --- a/brat/Brat/Syntax/Common.hs +++ b/brat/Brat/Syntax/Common.hs @@ -34,6 +34,7 @@ module Brat.Syntax.Common (PortName, KINDY(..), DIRY(..), modily, + deModey, ArithOp(..), pattern Dollar, pattern Star, @@ -84,6 +85,10 @@ modily :: Modey m -> (MODEY m => t) -> t modily Braty t = t modily Kerny t = t +deModey :: Modey m -> Mode +deModey Braty = Brat +deModey Kerny = Kernel + instance TestEquality Modey where testEquality Braty Braty = Just Refl testEquality Kerny Kerny = Just Refl @@ -110,7 +115,7 @@ instance Eq ty => Eq (TypeRowElem ty) where Anon ty == Anon ty' = ty == ty' data TypeKind = TypeFor Mode [(PortName, TypeKind)] | Nat - deriving Eq + deriving (Eq, Ord) instance Show TypeKind where show (TypeFor m args) = let argsStr = if null args then "" else "(" ++ intercalate ", " (show <$> args) ++ ")" diff --git a/brat/Brat/Syntax/Concrete.hs b/brat/Brat/Syntax/Concrete.hs index 3e07bb44..10bcb2e0 100644 --- a/brat/Brat/Syntax/Concrete.hs +++ b/brat/Brat/Syntax/Concrete.hs @@ -22,7 +22,7 @@ type FEnv = ([FDecl], [RawAlias]) data Flat = FVar QualName - | FHope + | FHope String | FApp (WC Flat) (WC Flat) | FJuxt (WC Flat) (WC Flat) | FThunk (WC Flat) diff --git a/brat/Brat/Syntax/Core.hs b/brat/Brat/Syntax/Core.hs index c9dbd046..286b2f0f 100644 --- a/brat/Brat/Syntax/Core.hs +++ b/brat/Brat/Syntax/Core.hs @@ -49,7 +49,7 @@ data Term :: Dir -> Kind -> Type where Pull :: [PortName] -> WC (Term Chk k) -> Term Chk k Var :: QualName -> Term Syn Noun -- Look up in noun (value) env Identity :: Term Syn UVerb - Hope :: Term Chk Noun + Hope :: String -> Term Chk Noun Arith :: ArithOp -> WC (Term Chk Noun) -> WC (Term Chk Noun) -> Term Chk Noun Of :: WC (Term Chk Noun) -> WC (Term d Noun) -> Term d Noun @@ -117,7 +117,7 @@ instance Show (Term d k) where show (Var x) = show x show Identity = "|" - show Hope = "!" + show (Hope ident) = '!':ident -- Nested applications should be bracketed too, hence 4 instead of 3 show (fun :$: arg) = bracket PApp fun ++ ('(' : show arg ++ ")") show (tm ::: ty) = bracket PAnn tm ++ " :: " ++ show ty diff --git a/brat/Brat/Syntax/Port.hs b/brat/Brat/Syntax/Port.hs index 4b118576..878e1f7f 100644 --- a/brat/Brat/Syntax/Port.hs +++ b/brat/Brat/Syntax/Port.hs @@ -41,9 +41,14 @@ instance ToEnd InPort where instance ToEnd OutPort where toEnd = ExEnd +-- N.B. Ord is derived with In < Ex data End = InEnd InPort | ExEnd OutPort deriving (Eq, Ord) instance Show End where show (InEnd e) = show e show (ExEnd e) = show e + +endName :: End -> Name +endName (InEnd (In n _)) = n +endName (ExEnd (Ex n _)) = n diff --git a/brat/Brat/Syntax/Raw.hs b/brat/Brat/Syntax/Raw.hs index 62934f1b..956cc55f 100644 --- a/brat/Brat/Syntax/Raw.hs +++ b/brat/Brat/Syntax/Raw.hs @@ -71,7 +71,7 @@ data Raw :: Dir -> Kind -> Type where RPull :: [PortName] -> WC (Raw Chk k) -> Raw Chk k RVar :: QualName -> Raw Syn Noun RIdentity :: Raw Syn UVerb - RHope :: Raw Chk Noun + RHope :: String -> Raw Chk Noun RArith :: ArithOp -> WC (Raw Chk Noun) -> WC (Raw Chk Noun) -> Raw Chk Noun ROf :: WC (Raw Chk Noun) -> WC (Raw d Noun) -> Raw d Noun (:::::) :: WC (Raw Chk Noun) -> [RawIO] -> Raw Syn Noun @@ -103,7 +103,7 @@ instance Show (Raw d k) where = unwords ["let", show abs, "=", show xs, "in", show body] show (RNHole name) = '?':name show (RVHole name) = '?':name - show RHope = "!" + show (RHope ident) = '!':ident show (RSimple tm) = show tm show RPass = show "pass" show REmpty = "()" @@ -203,7 +203,7 @@ instance (Kindable k) => Desugarable (Raw d k) where -- TODO: holes need to know their arity for type checking desugar' (RNHole strName) = NHole . (strName,) <$> freshM strName desugar' (RVHole strName) = VHole . (strName,) <$> freshM strName - desugar' RHope = pure Hope + desugar' (RHope ident) = pure (Hope ident) desugar' RPass = pure Pass desugar' (RSimple simp) = pure $ Simple simp desugar' REmpty = pure Empty diff --git a/brat/Brat/Syntax/Value.hs b/brat/Brat/Syntax/Value.hs index 4bc71fcd..1af8b94e 100644 --- a/brat/Brat/Syntax/Value.hs +++ b/brat/Brat/Syntax/Value.hs @@ -53,6 +53,7 @@ data Inx :: N -> Type where VS :: Inx n -> Inx (S n) deriving instance Eq (Inx n) +deriving instance Ord (Inx n) instance Show (Inx n) where show = show . toNat @@ -61,6 +62,7 @@ instance Show (Inx n) where toNat VZ = 0 toNat (VS n) = 1 + toNat n + data AddR :: N -> N -> N -> Type where AddZ :: Ny out -> AddR out Z out AddS :: AddR out inn tot -> AddR out (S inn) (S tot) @@ -143,6 +145,7 @@ data VVar :: N -> Type where VPar :: End -> VVar n -- Has to be declared in the Store (for equality testing) VInx :: Inx n -> VVar n +deriving instance Ord (VVar n) deriving instance Show (VVar n) instance Eq (VVar n) where @@ -347,7 +350,7 @@ instance NumFun Monotone where calculate (Linear n) = n calculate (Full sm) = full (calculate sm) where - full n = 2 ^ n - 1 + full n = (2 ^ n) - 1 numValue = numValue . StrictMono 0 @@ -618,3 +621,45 @@ stkLen (zx :<< _) = Sy (stkLen zx) numValIsConstant :: NumVal (VVar Z) -> Maybe Integer numValIsConstant (NumValue up Constant0) = pure up numValIsConstant _ = Nothing + +flexes :: Val n -> [End] +flexes (VApp (VPar e) _) = [e] +flexes (VNum (NumValue 0 (StrictMonoFun (StrictMono 0 (Linear (VPar e)))))) = [e] +flexes _ = [] + +numVars :: NumVal (VVar Z) -> [End] +numVars nv = [e | VPar e <- vvars nv] + where + vvars :: NumVal a -> [a] + vvars = foldMap pure + +class DepEnds t where + depEnds :: t -> [End] + +instance DepEnds (NumVal (VVar n)) where + depEnds nv = [e | VPar e <- vvars nv] + where + vvars :: NumVal a -> [a] + vvars = foldMap pure + +instance DepEnds (Val n) where + depEnds (VNum nv) = depEnds nv + depEnds (VCon _ args) = depEnds args + depEnds (VLam body) = depEnds body + depEnds (VFun _ cty) = depEnds cty + depEnds (VApp (VPar e) args) = e : depEnds args + depEnds (VApp _ args) = depEnds args + +instance DepEnds t => DepEnds [t] where + depEnds = concatMap depEnds + +instance DepEnds t => DepEnds (Bwd t) where + depEnds = foldMap depEnds + +instance DepEnds (Ro m i j) where + depEnds R0 = [] + depEnds (RPr (_, ty) ro) = depEnds ty ++ depEnds ro + depEnds (REx _ ro) = depEnds ro + +instance DepEnds (CTy m n) where + depEnds (ss :->> ts) = depEnds ss ++ depEnds ts diff --git a/brat/Brat/Unelaborator.hs b/brat/Brat/Unelaborator.hs index 5ff57492..b06509f0 100644 --- a/brat/Brat/Unelaborator.hs +++ b/brat/Brat/Unelaborator.hs @@ -38,7 +38,7 @@ unelab _ _ (Con c args) = FCon c (unelab Chky Nouny <$> args) unelab _ _ (C (ss :-> ts)) = FFn (toRawRo ss :-> toRawRo ts) unelab _ _ (K cty) = FKernel $ fmap (\(p, ty) -> Named p (toRaw ty)) cty unelab _ _ Identity = FIdentity -unelab _ _ Hope = FHope +unelab _ _ (Hope ident) = FHope ident unelab _ _ FanIn = FFanIn unelab _ _ FanOut = FFanOut @@ -68,7 +68,7 @@ toRaw (Con c args) = RCon c (toRaw <$> args) toRaw (C (ss :-> ts)) = RFn (toRawRo ss :-> toRawRo ts) toRaw (K cty) = RKernel $ (\(p, ty) -> Named p (toRaw ty)) <$> cty toRaw Identity = RIdentity -toRaw Hope = RHope +toRaw (Hope ident) = RHope ident toRaw FanIn = RFanIn toRaw FanOut = RFanOut diff --git a/brat/Control/Monad/Freer.hs b/brat/Control/Monad/Freer.hs index ebb1e310..ed8b7455 100644 --- a/brat/Control/Monad/Freer.hs +++ b/brat/Control/Monad/Freer.hs @@ -1,24 +1,108 @@ -module Control.Monad.Freer (Free(..), req) where +module Control.Monad.Freer where + +import Brat.Syntax.Port (End) +import Brat.Syntax.Value (Val) +import Hasochism (N(..)) import Control.Monad ((>=>)) import Data.Kind (Type) +import qualified Data.Map as M +import qualified Data.Set as S + +-- A mapping of metavars to metavars, for a single problem: +-- * e -> Unstuck means e has been solved +-- * e -> Awaiting es means the problem's been transferred +-- * e not in news means no change to e +newtype News = News (M.Map End Stuck) + +updateEnd :: News -> End -> Stuck +updateEnd (News m) e = case M.lookup e m of + Nothing -> AwaitingAny (S.singleton e) + Just s -> s + +-- The RHS of the operation is the newer news +-- Invariant: The domains of these Newses are disjoint +instance Semigroup News where + (News m1) <> n2@(News m2) = News (m2 `M.union` (M.map (/// n2) m1)) + +instance Monoid News where + mempty = News M.empty + +data Stuck + = Unstuck + | AwaitingAny (S.Set End) + deriving Show + +instance Semigroup Stuck where + (AwaitingAny es1) <> (AwaitingAny es2) = AwaitingAny (S.union es1 es2) + _ <> _ = Unstuck + +instance Monoid Stuck where + mempty = AwaitingAny S.empty data Free (sig :: Type -> Type) (v :: Type) where Ret :: v -> Free sig v Req :: sig t -> (t -> Free sig v) -> Free sig v + Define :: String -> End -> Val Z -> (News -> Free sig v) -> Free sig v + Yield :: Stuck -> (News -> Free sig v) -> Free sig v + Fork :: String -> Free sig () -> Free sig v -> Free sig v instance Functor (Free sig) where fmap f (Ret v) = Ret (f v) fmap f (Req sig k) = Req sig (fmap f . k) + fmap f (Define lbl e v k) = Define lbl e v (fmap f . k) + fmap f (Yield st k) = Yield st (fmap f . k) + fmap f (Fork d par c) = Fork d par (fmap f c) + +class NewsWatcher t where + (///) :: t -> News -> t + +instance NewsWatcher Stuck where + Unstuck /// _ = Unstuck + (AwaitingAny es) /// n = foldMap (updateEnd n) es + +instance NewsWatcher (News -> t) where + f /// n = f . (n <>) + +instance NewsWatcher (Free sig v) where + Ret v /// _ = Ret v + Req sig k /// n = Req sig $ \v -> k v /// n + Define lbl e v k /// n = Define lbl e v (k /// n) + Yield st k /// n = Yield (st /// n) (k /// n) + Fork d par c /// n = Fork d (par /// n) (c /// n) instance Applicative (Free sig) where pure = Ret - (Ret f) <*> ma = fmap f ma - (Req sig k) <*> ma = Req sig ((<*> ma) . k) + + -- Left biased scheduling of commands: + -- First, get rid of Yield Unstuck + Yield Unstuck k <*> a = k mempty <*> a + f <*> Yield Unstuck k = f <*> k mempty + + -- Aggressively forward Forks + Fork d par c <*> ma = Fork d par (c <*> ma) + ma <*> Fork d par c = Fork d par (ma <*> c) + + -- Make progress on the left + Ret f <*> ma = fmap f ma + Req sig k <*> ma = Req sig ((<*> ma) . k) + Define lbl e v k1 <*> ma = Define lbl e v $ \n -> (k1 n) <*> (ma /// n) + + -- What happens when Yield is on the left + y <*> Ret v = fmap ($ v) y + y <*> Req sig k = Req sig $ \v -> y <*> k v + y1@(Yield st1 _) <*> y2@(Yield st2 _) = Yield (st1 <> st2) $ + \n -> (y1 /// n) <*> (y2 /// n) + y <*> Define lbl e v k = Define lbl e v $ \n -> (y /// n) <*> k n instance Monad (Free sig) where Ret v >>= k = k v Req r j >>= k = Req r (j >=> k) + Define lbl e v k1 >>= k2 = Define lbl e v (k1 >=> k2) + Yield st k1 >>= k2 = Yield st (k1 >=> k2) + --- equivalent to + -- Yield st k1 >>= k2 = Yield st (\n -> (k1 n) >>= k2) + Fork d par k1 >>= k2 = Fork d par (k1 >>= k2) req :: sig t -> Free sig t req s = Req s Ret diff --git a/brat/Data/Hugr.hs b/brat/Data/Hugr.hs index f3bb8075..d08e6418 100644 --- a/brat/Data/Hugr.hs +++ b/brat/Data/Hugr.hs @@ -239,6 +239,7 @@ data FuncDefn node = FuncDefn { parent :: node , name :: String , signature_ :: PolyFuncType + , metadata :: [(String, String)] } deriving (Eq, Functor, Show) instance Eq a => Ord (FuncDefn a) where @@ -249,6 +250,7 @@ instance ToJSON node => ToJSON (FuncDefn node) where ,"op" .= ("FuncDefn" :: Text) ,"name" .= name ,"signature" .= signature_ + ,"metadata" .= metadata ] data CustomConst where @@ -286,36 +288,41 @@ instance ToJSON node => ToJSON (ConstOp node) where data InputNode node = InputNode { parent :: node , types :: [HugrType] + , metadata :: [(String, String)] } deriving (Eq, Functor, Show) instance Eq a => Ord (InputNode a) where compare _ _ = EQ instance ToJSON node => ToJSON (InputNode node) where - toJSON (InputNode parent types) = object ["parent" .= parent - ,"op" .= ("Input" :: Text) - ,"types" .= types - ] + toJSON (InputNode parent types metadata) = object ["parent" .= parent + ,"op" .= ("Input" :: Text) + ,"types" .= types + ,"metadata" .= metadata + ] data OutputNode node = OutputNode { parent :: node , types :: [HugrType] + , metadata :: [(String, String)] } deriving (Eq, Functor, Show) instance Eq a => Ord (OutputNode a) where compare _ _ = EQ instance ToJSON node => ToJSON (OutputNode node) where - toJSON (OutputNode parent types) = object ["parent" .= parent - ,"op" .= ("Output" :: Text) - ,"types" .= types - ] + toJSON (OutputNode { .. }) = object ["parent" .= parent + ,"op" .= ("Output" :: Text) + ,"types" .= types + ,"metadata" .= metadata + ] data Conditional node = Conditional { parent :: node , sum_rows :: [[HugrType]] , other_inputs :: [HugrType] , outputs :: [HugrType] + , metadata :: [(String, String)] } deriving (Eq, Functor, Show) instance Eq a => Ord (Conditional a) where @@ -329,11 +336,13 @@ instance ToJSON node => ToJSON (Conditional node) where ,"other_inputs" .= other_inputs ,"outputs" .= outputs ,"extension_delta" .= ([] :: [Text]) + ,"metadata" .= metadata ] data Case node = Case { parent :: node , signature_ :: FunctionType + , metadata :: [(String, String)] } deriving (Eq, Functor, Show) instance Eq node => Ord (Case node) where @@ -343,6 +352,7 @@ instance ToJSON node => ToJSON (Case node) where toJSON (Case { .. }) = object ["op" .= ("Case" :: Text) ,"parent" .= parent ,"signature" .= signature_ + ,"metadata" .= metadata ] {- @@ -356,6 +366,7 @@ data Const = Const data DFG node = DFG { parent :: node , signature_ :: FunctionType + , metadata :: [(String, String)] } deriving (Eq, Functor, Show) instance Eq node => Ord (DFG node) where @@ -365,23 +376,26 @@ instance ToJSON node => ToJSON (DFG node) where toJSON (DFG { .. }) = object ["op" .= ("DFG" :: Text) ,"parent" .= parent ,"signature" .= signature_ + ,"metadata" .= metadata ] data TagOp node = TagOp { parent :: node , tag :: Int , variants :: [[HugrType]] + , metadata :: [(String, String)] } deriving (Eq, Functor, Show) instance Eq node => Ord (TagOp node) where compare _ _ = EQ instance ToJSON node => ToJSON (TagOp node) where - toJSON (TagOp parent tag variants) + toJSON (TagOp parent tag variants metadata) = object ["parent" .= parent ,"op" .= ("Tag" :: Text) ,"tag" .= tag ,"variants" .= variants + ,"metadata" .= metadata ] data MakeTupleOp node = MakeTupleOp @@ -591,6 +605,15 @@ data HugrOp node | OpNoop (NoopOp node) deriving (Eq, Functor, Ord, Show) +addMetadata :: [(String, String)] -> HugrOp node -> HugrOp node +addMetadata md (OpDFG (DFG { .. })) = OpDFG (DFG { metadata = metadata ++ md, .. }) +addMetadata md (OpCase (i, (Case { .. }))) = OpCase (i, (Case { metadata = metadata ++ md, .. })) +addMetadata md (OpIn (InputNode { .. })) = OpIn (InputNode { metadata = metadata ++ md, .. }) +addMetadata md (OpTag (TagOp { .. })) = OpTag (TagOp { metadata = metadata ++ md, .. }) +addMetadata md (OpDefn (FuncDefn { .. })) = OpDefn (FuncDefn { metadata = metadata ++ md, .. }) +addMetadata md (OpConditional (Conditional { .. })) = OpConditional (Conditional { metadata = metadata ++ md, .. }) +addMetadata _ op = op + instance ToJSON node => ToJSON (HugrOp node) where toJSON (OpMod op) = toJSON op toJSON (OpDefn op) = toJSON op diff --git a/brat/brat.cabal b/brat/brat.cabal index 3873bcf1..aded7927 100644 --- a/brat/brat.cabal +++ b/brat/brat.cabal @@ -69,6 +69,7 @@ library Brat.Checker.Helpers.Nodes, Brat.Checker.Monad, Brat.Checker.SolveHoles, + Brat.Checker.SolveNumbers, Brat.Checker.SolvePatterns, Brat.Checker.Types, Brat.Compile.Hugr, diff --git a/brat/examples/eatsfull.brat b/brat/examples/eatsfull.brat new file mode 100644 index 00000000..bce0d05a --- /dev/null +++ b/brat/examples/eatsfull.brat @@ -0,0 +1,4 @@ +eatsfull(n :: #, xs :: Vec(Bool, full(n))) -> Nat +eatsfull(n, _) = n +mkftwo :: Nat +mkftwo = eatsfull(!, [false,false,false]) diff --git a/brat/examples/eatsfullbis.brat b/brat/examples/eatsfullbis.brat new file mode 100644 index 00000000..2a94d1fc --- /dev/null +++ b/brat/examples/eatsfullbis.brat @@ -0,0 +1,6 @@ +eatsfull(n :: #, xs :: Vec(Bool, full(n))) -> Nat +eatsfull(n, _) = n +falses :: Vec(Bool, 3) +falses = [false, false, false] +mkftwo :: Nat +mkftwo = eatsfull(!, falses) diff --git a/brat/examples/infer.brat b/brat/examples/infer.brat index e10ee44e..f1eaf0bf 100644 --- a/brat/examples/infer.brat +++ b/brat/examples/infer.brat @@ -2,7 +2,52 @@ map(X :: *, Y :: *, { X -> Y }, List(X)) -> List(Y) map(_, _, _, []) = [] map(_, _, f, x ,- xs) = f(x) ,- map(!, !, f, xs) --- TODO: Make BRAT solve for the # kinded args mapVec(X :: *, Y :: *, { X -> Y }, n :: #, Vec(X, n)) -> Vec(Y, n) mapVec(_, _, _, _, []) = [] -mapVec(_, _, f, succ(n), x ,- xs) = f(x) ,- mapVec(!, !, f, n, xs) +mapVec(_, _, f, _, x ,- xs) = f(x) ,- mapVec(!, !, f, !, xs) + +--map(X :: *, Y :: *, { X -> Y }, List(X)) -> List(Y) +--map(_, _, _, []) = [] +--map(_, _, f, x ,- xs) = f(x) ,- map(!, !, f, xs) + +--mapVec(X :: *, Y :: *, { X -> Y }, n :: #, Vec(X, n)) -> Vec(Y, n) +--mapVec(_, _, _, _, []) = [] +--mapVec(_, _, f, n, x ,- xs) = f(x) ,- mapVec(!, !, f, !, xs) + +--length(X :: *, n :: #, Vec(X, n)) -> (m :: #) +--length(_, n, []) = n +--length(_, n, x ,- xs) = n + +-- The "succ" still being required in both of these cases is https://github.com/CQCL/brat/issues/35 + +-- While map above can infer the holes from the other arguments, +-- here we need to infer the holes (arguments) from the results: +-- repeat(X :: *, n :: #, x :: X) -> Vec(X, n) +-- repeat(_, 0, _) = [] +-- repeat(_, succ(_), x) = x ,- repeat(!, !, x) -- X can be inferred from x but n cannot +-- +-- mapFirst(X :: *, Y :: *, { X -> Y}, n :: #, Vec(X, n)) -> Vec(Y, n) +-- mapFirst(_, _, _, _, []) = [] +-- mapFirst(_, _, f, succ(_), x ,- _) = repeat(!, !, f(x)) -- first ! (X) is second _ (Y) +-- +-- isfull(n :: #) -> Bool +-- isfull(succ(doub(n))) = isfull(n) +-- isfull(0) = true +-- isfull(_) = false +-- +-- hasfulllen(n :: #, Vec(Bool, n)) -> Bool +-- hasfulllen(n, x ,- (xs =,= ys)) = hasfulllen(!, xs) +-- hasfulllen(_, []) = true +-- hasfulllen(_, _) = false +-- +-- eatsfull(n :: #, xs :: Vec(Bool, full(n))) -> Nat +-- eatsfull(n, _) = n +-- mkftwo :: Nat +-- mkftwo = eatsfull(!, [false,false,false]) +-- +-- eatsodd(n :: #, xs :: Vec(Bool, succ(doub(n)))) -> Nat +-- eatsodd(n, _) = n +-- mkotwo' :: Nat +-- mkotwo' = eatsodd(2, [false,false,false,false,false]) +-- mkotwo :: Nat +-- mkotwo = eatsodd(!, [false,false,false,false,false]) diff --git a/brat/examples/infer2.brat b/brat/examples/infer2.brat new file mode 100644 index 00000000..421e2eb7 --- /dev/null +++ b/brat/examples/infer2.brat @@ -0,0 +1,33 @@ +-- The "succ" still being required in both of these cases is https://github.com/CQCL/brat/issues/35 + +-- While some cases can infer the holes from the other arguments, +-- here we need to infer the holes (arguments) from the results: +repeat(X :: *, n :: #, x :: X) -> Vec(X, n) +repeat(_, 0, _) = [] +repeat(_, succ(_), x) = x ,- repeat(!, !, x) -- X can be inferred from x but n cannot + +mapFirst(X :: *, Y :: *, { X -> Y}, n :: #, Vec(X, n)) -> Vec(Y, n) +mapFirst(_, _, _, _, []) = [] +mapFirst(_, _, f, succ(_), x ,- _) = repeat(!, !, f(x)) -- first ! (X) is second _ (Y) + +isfull(n :: #) -> Bool +isfull(succ(doub(n))) = isfull(n) +isfull(0) = true +isfull(_) = false + +hasfulllen(n :: #, Vec(Bool, n)) -> Bool +hasfulllen(n, x ,- (xs =,= ys)) = hasfulllen(!, xs) +hasfulllen(_, []) = true +hasfulllen(_, _) = false + +eatsfull(n :: #, xs :: Vec(Bool, full(n))) -> Nat +eatsfull(n, _) = n +mkftwo :: Nat +mkftwo = eatsfull(!, [false,false,false]) + +eatsodd(n :: #, xs :: Vec(Bool, succ(doub(n)))) -> Nat +eatsodd(n, _) = n +mkotwo' :: Nat +mkotwo' = eatsodd(2, [false,false,false,false,false]) +mkotwo :: Nat +mkotwo = eatsodd(!, [false,false,false,false,false]) diff --git a/brat/examples/infer_thunks.brat b/brat/examples/infer_thunks.brat new file mode 100644 index 00000000..1030efc5 --- /dev/null +++ b/brat/examples/infer_thunks.brat @@ -0,0 +1,11 @@ +ext "to_float" to_float(i :: Int) -> Float + +id(X :: *, X) -> X +id(_, x) = x + +map(X :: *, Y :: *, { X -> Y }, List(X)) -> List(Y) +map(_, _, _, []) = [] +map(X, Y, f, x ,- xs) = f(x) ,- map(X, Y, f, xs) + +test :: List(Float) +test = map(!, !, {f => f(5)}, [to_float]) diff --git a/brat/examples/infer_thunks2.brat b/brat/examples/infer_thunks2.brat new file mode 100644 index 00000000..d9006b1a --- /dev/null +++ b/brat/examples/infer_thunks2.brat @@ -0,0 +1,11 @@ +ext "to_float" to_float(i :: Int) -> Float + +id(X :: *, X) -> X +id(_, x) = x + +map(X :: *, Y :: *, List(X), { X -> Y }) -> List(Y) +map(_, _, [], _) = [] +map(X, Y, x ,- xs, f) = f(x) ,- map(X, Y, xs, f) + +test :: List(Float) +test = map(!, !, [to_float], {f => f(5)}) diff --git a/brat/examples/lib/functional.brat b/brat/examples/lib/functional.brat index f8ccccab..1327ee5d 100644 --- a/brat/examples/lib/functional.brat +++ b/brat/examples/lib/functional.brat @@ -1,6 +1,6 @@ -- TODO: Fill this with holes once we can guess them map(X :: $, Y :: $, n :: #, f :: { X -o Y }) -> { Vec(X, n) -o Vec(Y, n) } -map(_, _, _, _) = { [] => [] } +map(_, _, 0, _) = { [] => [] } map(X, Y, succ(n), f) = { cons(x,xs) => cons(f(x), map(X, Y, n, f)(xs)) } fold(X :: $ diff --git a/brat/examples/map.brat b/brat/examples/map.brat new file mode 100644 index 00000000..db7b558d --- /dev/null +++ b/brat/examples/map.brat @@ -0,0 +1,3 @@ +map(X :: *, Y :: *, { X -> Y }, List(X)) -> List(Y) +map(_, _, _, []) = [] +map(_, _, f, x ,- xs) = f(x) ,- map(!, !, f, xs) diff --git a/brat/examples/smol.brat b/brat/examples/smol.brat new file mode 100644 index 00000000..d4d0ffcb --- /dev/null +++ b/brat/examples/smol.brat @@ -0,0 +1,11 @@ +foo(n :: #, Vec(Nat, 2 * n)) -> Vec(Nat, 4 * n) +foo(n, xs =%= ys) = goo(n, (xs =%= ys) =%= (ys =%= xs)) + +goo(n :: #, Vec(Nat, 4 * n)) -> Vec(Nat, 4 * n) +goo(_, xs) = xs + +--merge(n :: #, Vec(Nat, 2^n), Vec(Nat, 2^n)) -> Vec(Nat, 2^(n + 1)) +--merge(succ(n), xs, ys) = fix(succ(n), xs =%= ys) +-- +--fix(n :: #, Vec(Nat, 2^(n + 1))) -> Vec(Nat, 2^(n + 1)) +--fix(_, xs) = xs \ No newline at end of file diff --git a/brat/examples/unified.brat b/brat/examples/unified.brat index f04c167a..89a24d7d 100644 --- a/brat/examples/unified.brat +++ b/brat/examples/unified.brat @@ -1,30 +1,42 @@ -f(X :: *, n :: #, Vec(X, n)) -> Vec(X, n) -f(X, n, cons(x, xs)) = cons(x, xs) -f(X, n, []) = [] +--f(X :: *, n :: #, Vec(X, n)) -> Vec(X, n) +--f(X, n, cons(x, xs)) = cons(x, xs) +--f(X, n, []) = [] -vectorTail(X :: *, n :: #, Vec(X, succ(n))) -> Vec(X, n) -vectorTail(_, _, cons(_, xs)) = xs --- vectorTail(_, _, []) = ?l -- Fails (correctly) - -zipWith(X :: *, Y :: *, Z :: *, n :: #, f :: { X, Y -> Z }, Vec(X, n), Vec(Y, n)) -> Vec(Z, n) --- TODO: Fix port pulling for this -zipWith(_, _, _, _, _, [], []) = [] -zipWith(X, Y, Z, succ(n), f, cons(x,xs), cons(y,ys)) = cons(f(x,y), zipWith(X,Y,Z,n,f,xs,ys)) +-- vectorTail(X :: *, n :: #, Vec(X, succ(n))) -> Vec(X, n) +-- vectorTail(_, _, cons(_, xs)) = xs +-- -- vectorTail(_, _, []) = ?l -- Fails (correctly) +-- +-- zipWith(X :: *, Y :: *, Z :: *, n :: #, f :: { X, Y -> Z }, Vec(X, n), Vec(Y, n)) -> Vec(Z, n) +-- -- TODO: Fix port pulling for this +-- zipWith(_, _, _, _, _, [], []) = [] +-- zipWith(X, Y, Z, succ(n), f, cons(x,xs), cons(y,ys)) = cons(f(x,y), zipWith(X,Y,Z,n,f,xs,ys)) replicate(X :: *, n :: #, x :: X) -> Vec(X, n) replicate(_, 0, _) = [] replicate(X, succ(n), x) = cons(x, replicate(X, n, x)) -ap(X :: *, Y :: *, n :: #, fs :: Vec({ X -> Y }, n), xs :: Vec(X, n)) -> Vec(Y, n) -ap(_, _, _, [], []) = [] -ap(X, Y, succ(n), cons(f,fs), cons(x,xs)) = cons(f(x), ap(X, Y, n, fs, xs)) - -permute(X :: *, n :: #, Vec(X, n)) -> Vec(X, n) -permute(_, _, []) = [] -permute(_, _, [x]) = [x] -permute(X, succ(succ(n)), cons(x, cons(y, zs))) = cons(y, cons(x, permute(X, n, zs))) +-- ap(X :: *, Y :: *, n :: #, fs :: Vec({ X -> Y }, n), xs :: Vec(X, n)) -> Vec(Y, n) +-- ap(_, _, _, [], []) = [] +-- ap(X, Y, succ(n), cons(f,fs), cons(x,xs)) = cons(f(x), ap(X, Y, n, fs, xs)) +-- +-- permute(X :: *, n :: #, Vec(X, n)) -> Vec(X, n) +-- permute(_, _, []) = [] +-- permute(_, _, [x]) = [x] +-- permute(X, succ(succ(n)), cons(x, cons(y, zs))) = cons(y, cons(x, permute(X, n, zs))) +-- +-- swapFront(X :: *, n :: #, Vec(X, n)) -> Vec(X, n) +-- swapFront(_, _, []) = [] +-- swapFront(_, _, [x]) = [x] +-- swapFront(X, _, cons(x, cons(y, zs))) = cons(y, cons(x, zs)) +-- +-- filled(X :: *, n :: #, Vec(X, full(n))) -> Vec(X, full(n)) +-- filled(_, _, xsl =, x ,= xsr) = xsl =, x ,= xsr +-- +-- fullId(X :: *, n :: #, Vec(X, full(n))) -> Vec(X, full(n)) +-- fullId(_, _, [] =,= []) = [] +-- fullId(_, _, [] =, x ,= []) = [x] +-- fullId(_, succ(n), xl =, x ,= xr) = fullId(!, n, xl) =, x ,= fullId(!, n, xr) -swapFront(X :: *, n :: #, Vec(X, n)) -> Vec(X, n) -swapFront(_, _, []) = [] -swapFront(_, _, [x]) = [x] -swapFront(X, _, cons(x, cons(y, zs))) = cons(y, cons(x, zs)) +-- mapAndConquer(X :: *, Y :: *, n :: #, f :: { X -> Y }, Vec(X, succ(n))) -> Vec(Y, succ(n)) +-- mapAndConquer(_, _, doub(n), f, xsl =, x ,= xsr) = mapAndConquer(!, !, n, f, xsl) =, f(x) ,= mapAndConquer(!, !, n, f, xsr) +-- mapAndConquer(_, _, succ(doub(n)), f, xsl =,= xsr) = mapAndConquer(!, !, n, f, xsl) =,= mapAndConquer(!, !, n, f, xsr) diff --git a/brat/examples/vector_solve.brat b/brat/examples/vector_solve.brat new file mode 100644 index 00000000..a145ba5c --- /dev/null +++ b/brat/examples/vector_solve.brat @@ -0,0 +1,25 @@ +sameLength(T :: *, n :: #, Vec(T, n), Vec(T, n)) -> (m :: #) +sameLength(_, n, _, _) = n + +replicate(X :: *, n :: #, x :: X) -> Vec(X, n) +replicate(_, 0, _) = [] +replicate(X, succ(n), x) = cons(x, replicate(X, n, x)) + +foo :: (m :: #) +foo = let xs = replicate(Nat, !, 42) in sameLength(Nat, !, xs, xs =%= xs) + +fullTree(T :: *, n :: #, Vec(T, n)) -> Vec(T, 2^n - 1) +fullTree(_, _, []) = [] +fullTree(_, _, x ,- xs) = fullTree(!, !, xs) =, x ,= fullTree(!, !, xs) + +-- goo :: (m :: #) +-- goo = let xs = replicate(Nat, !, 42) in sameLength(Nat, !, xs, fullTree(!, !, xs)) + +hoo :: (n :: #), (m :: #) +hoo = let xs = replicate(Nat, !, 42) in sameLength(Nat, !, xs, xs =%= xs), sameLength(Nat, !, xs, fullTree(!, !, xs)) + +ioo :: (n :: #), (m :: #) +ioo = let xs = replicate(Nat, !, 42) in sameLength(Nat, !, xs, fullTree(!, !, xs)), sameLength(Nat, !, xs, xs =%= xs) + +joo :: (n :: #), (m :: #) +joo = let xs = replicate(Nat, !, 42) in sameLength(Nat, !, xs, fullTree(!, !, xs)), sameLength(Nat, !, xs, [5]) diff --git a/brat/lsp/Driver.hs b/brat/lsp/Driver.hs index 63f09d85..720a478b 100644 --- a/brat/lsp/Driver.hs +++ b/brat/lsp/Driver.hs @@ -115,7 +115,7 @@ loadVFile state _ msg = do -- vv env <- liftIO . runExceptT $ loadFiles Name.root (cwd :| []) (show fileName) file case env of - Right (_,newDecls,holes,_,_) -> do + Right (_,newDecls,holes,_,_,_) -> do old <- liftIO $ takeMVar state liftIO $ putMVar state (updateState (snd <$> newDecls, holes) old) allGood fileName diff --git a/brat/test/Main.hs b/brat/test/Main.hs index 29d3f78b..2c67e0cb 100644 --- a/brat/test/Main.hs +++ b/brat/test/Main.hs @@ -15,12 +15,59 @@ import Test.Substitution import Test.Syntax.Let import Test.TypeArith +import Brat.Checker.Monad +import Brat.Checker.Types (IsSkolem(..)) +import Brat.Syntax.Common +import Brat.Syntax.Value +import Brat.QualName +import Brat.Error +import Control.Monad.Freer +import qualified Data.Set as S +import Debug.Trace +import Test.Util +import Test.Tasty.HUnit (testCase) + +coroT1 :: Checking () +coroT1 = do + name <- req (Fresh "anything") + let e = InEnd $ In name 0 + req $ Declare e Braty (Left $ Star []) Definable + mkFork "t1" (req (ELup e) >>= \case + Just _ -> err $ InternalError "already defined" + Nothing -> defineEnd "test" e (VCon (PrefixName [] "nil") []) + ) + mkYield "coroT1" (S.singleton e) >> pure () + traceM "Yield continued" + v <- req $ ELup e + case v of + Just _ -> pure () + Nothing -> err $ InternalError "not defined" + +coroT2 :: Checking () +coroT2 = do + name <- req (Fresh "anything") + let e = InEnd $ In name 0 + req $ Declare e Braty (Left $ Star []) Definable + v <- do + mkYield "coroT2" (S.singleton e) + req $ ELup e + -- No way to execute this without a 'v' + mkFork "t2" $ defineEnd "test" e (VCon (PrefixName [] "nil") []) + err $ InternalError $ case v of + Nothing -> "ELup performed without waiting for Yield" -- true in next case too + Just _ -> "ELup returned value before being Defined" + + main = do failureTests <- getFailureTests checkingTests <- getCheckingTests parsingTests <- getParsingTests compilationTests <- setupCompilationTests graphTests <- getGraphTests + let coroTests = testGroup "coroutine" + [testCase "coroT1" $ assertChecking coroT1 + ,testCase "coroT2" $ assertCheckingFail "Typechecking blocked on" coroT2 + ] defaultMain $ testGroup "All" [graphTests ,failureTests ,checkingTests @@ -34,4 +81,5 @@ main = do ,abstractorTests ,compilationTests ,typeArithTests + ,coroTests ] diff --git a/brat/test/Test/Checking.hs b/brat/test/Test/Checking.hs index b576421a..8c8384b7 100644 --- a/brat/test/Test/Checking.hs +++ b/brat/test/Test/Checking.hs @@ -15,6 +15,9 @@ expectedCheckingFails = map ("examples" ) ["nested-abstractors.brat" ,"karlheinz.brat" ,"karlheinz_alias.brat" ,"hea.brat" + -- https://github.com/Quantinuum/brat/issues/92 + ,"repeated_app.brat" + ,"adder.brat" ] parseAndCheckXF :: [FilePath] -> [TestTree] @@ -28,5 +31,5 @@ parseAndCheck libDirs file = testCase (show file) $ do env <- runExceptT $ loadFilename root libDirs file case env of Left err -> assertFailure (show err) - Right (venv, nouns, holes, _, _) -> + Right (venv, nouns, holes, _, _, _) -> (length venv + length nouns + length holes > 0) @? "Should produce something" diff --git a/brat/test/Test/Compile/Hugr.hs b/brat/test/Test/Compile/Hugr.hs index f5d9d6a1..0f3d7bd9 100644 --- a/brat/test/Test/Compile/Hugr.hs +++ b/brat/test/Test/Compile/Hugr.hs @@ -23,6 +23,10 @@ invalidExamples = map ((++ ".brat") . ("examples" )) ,"app" ,"dollar_kind" ,"portpulling" + ,"eatsfull" -- Compiling hopes #96 + ,"map" -- Compiling hopes #96 + ,"infer_thunks" -- Weird: Mismatch between caller and callee signatures in map call + ,"infer_thunks2" -- Weird: Mismatch between caller and callee signatures in map call ,"repeated_app" -- missing coercions, https://github.com/quantinuum-dev/brat/issues/413 ,"thunks"] @@ -35,8 +39,11 @@ nonCompilingExamples = expectedCheckingFails ++ expectedParsingFails ++ ,"let" ,"patterns" ,"qft" + ,"infer" -- problems with undoing pattern tests + ,"infer2" -- problems with undoing pattern tests ,"fanout" -- Contains Selectors ,"vectorise" -- Generates MapFun nodes which aren't implemented yet + ,"vector_solve" -- Generates "Pow" nodes which aren't implemented yet ,"batcher-merge-sort" -- Generates MapFun nodes which aren't implemented yet -- Victims of #13 ,"arith" diff --git a/brat/test/Test/Graph.hs b/brat/test/Test/Graph.hs index 7a81ddf1..b5fe129f 100644 --- a/brat/test/Test/Graph.hs +++ b/brat/test/Test/Graph.hs @@ -21,7 +21,7 @@ mkGraphTest bratFile = do makeBratGraph :: String -> IO Graph makeBratGraph contents = runExceptT (loadFiles root includeDirs bratFile contents) >>= \case -- ns is a map so will already be sorted - Right (_, _, _, _, (ns, es)) -> pure (ns, sortOn endNames es) + Right (_, _, _, _, (ns, es), _) -> pure (ns, sortOn endNames es) Left err -> assertFailure (show err) endNames (inp, _, outp) = show inp ++ show outp diff --git a/brat/test/Test/Substitution.hs b/brat/test/Test/Substitution.hs index f9da1d3d..25aaed93 100644 --- a/brat/test/Test/Substitution.hs +++ b/brat/test/Test/Substitution.hs @@ -5,9 +5,9 @@ import Test.Tasty {- -- TODO: update to value scopes syntax import Brat.Checker.Monad +import Brat.Checker.SolveHoles import Brat.Checker.Types import Brat.Error -import Brat.Eval (typeEq) import Brat.Naming import Brat.QualName import Brat.Syntax.Common diff --git a/brat/test/Test/Util.hs b/brat/test/Test/Util.hs index 06e9db9a..4aecf26f 100644 --- a/brat/test/Test/Util.hs +++ b/brat/test/Test/Util.hs @@ -10,6 +10,7 @@ import Brat.Naming import qualified Data.Set as S import Test.Tasty import Test.Tasty.HUnit +import Data.List (isInfixOf) import Test.Tasty.ExpectedFailure runEmpty = run emptyEnv initStore root @@ -19,6 +20,12 @@ assertChecking m = case runEmpty $ localFC (FC (Pos 0 0) (Pos 0 0)) m of Right _ -> pure () Left err -> assertFailure (showError err) +assertCheckingFail :: Show a => String -> Checking a -> Assertion +assertCheckingFail needle m = case runEmpty $ localFC (FC (Pos 0 0) (Pos 0 0)) m of + Right res -> assertFailure ("Computation produced result " ++ show res ++ " when should have Thrown") + Left err -> let shown = showError err in + if isInfixOf needle shown then pure () else assertFailure ("Unexpected error " ++ shown) + expectFailForPaths :: [FilePath] -> (FilePath -> TestTree) -> [FilePath] -> [TestTree] expectFailForPaths xf makeTest paths = if S.null not_found then tests else error $ "Tried to XFAIL non-existent tests " ++ show not_found diff --git a/brat/test/golden/error/badvec.brat.golden b/brat/test/golden/error/badvec.brat.golden index 35e9fc33..f60758f4 100644 --- a/brat/test/golden/error/badvec.brat.golden +++ b/brat/test/golden/error/badvec.brat.golden @@ -2,9 +2,5 @@ Error in test/golden/error/badvec.brat on line 2: v3 = [1] ^^^ - Expected vector of length 3 -from the type: Vec(Int, 3) -but got vector: [1] -of length 1 - + Unification error: Couldn't force 2 to be 0 diff --git a/brat/test/golden/error/badvec2.brat.golden b/brat/test/golden/error/badvec2.brat.golden index 2029db69..6d897a48 100644 --- a/brat/test/golden/error/badvec2.brat.golden +++ b/brat/test/golden/error/badvec2.brat.golden @@ -2,9 +2,5 @@ Error in test/golden/error/badvec2.brat on line 2: v3 = nil ^^^ - Expected vector of length 3 -from the type: Vec(Int, 3) -but got vector: [] -of length 0 - + Unification error: Couldn't force 3 to be 0 diff --git a/brat/test/golden/error/badvec3.brat.golden b/brat/test/golden/error/badvec3.brat.golden index 76e928b2..94b04131 100644 --- a/brat/test/golden/error/badvec3.brat.golden +++ b/brat/test/golden/error/badvec3.brat.golden @@ -2,9 +2,5 @@ Error in test/golden/error/badvec3.brat on line 2: v3 = cons(1, nil) ^^^^^^^^^^^^ - Expected vector of length 0 -from the type: Vec(Int, 0) -but got vector: [1] -of length (> 0) - + Unification error: Couldn't force 1 + VPar In checking_check_defs_1_v3_$rhs_check'Con_$!_numpat2val_1 0 to be 0 diff --git a/brat/test/golden/error/badvec4.brat.golden b/brat/test/golden/error/badvec4.brat.golden index 7fe59dfd..13b202ae 100644 --- a/brat/test/golden/error/badvec4.brat.golden +++ b/brat/test/golden/error/badvec4.brat.golden @@ -2,9 +2,5 @@ Error in test/golden/error/badvec4.brat on line 2: v3 = [1,2] ^^^^^ - Expected vector of length 3 -from the type: Vec(Int, 3) -but got vector: [1,2] -of length 2 - + Unification error: Couldn't force 1 to be 0 diff --git a/brat/test/golden/error/fanin-dynamic-length.brat.golden b/brat/test/golden/error/fanin-dynamic-length.brat.golden index 0c4e0242..6c2d87eb 100644 --- a/brat/test/golden/error/fanin-dynamic-length.brat.golden +++ b/brat/test/golden/error/fanin-dynamic-length.brat.golden @@ -2,5 +2,5 @@ Error in test/golden/error/fanin-dynamic-length.brat on line 2: f(n) = { [\/] } ^^^^ - Type error: Can't fanout a Vec with non-constant length: VPar Ex checking_check_defs_1_f_f.box_2_lambda_fake_source 0 + Type error: Can't fanout a Vec with non-constant length: VPar Ex checking_check_defs_1_f_LambdaChk_7_checkClauses_1_lambda.0_rhs/in_1 0 diff --git a/brat/test/golden/error/fanout-dynamic-length.brat.golden b/brat/test/golden/error/fanout-dynamic-length.brat.golden index 4c87893c..0de3978a 100644 --- a/brat/test/golden/error/fanout-dynamic-length.brat.golden +++ b/brat/test/golden/error/fanout-dynamic-length.brat.golden @@ -2,5 +2,5 @@ Error in test/golden/error/fanout-dynamic-length.brat on line 2: f(n) = { [/\] } ^^^^ - Type error: Can't fanout a Vec with non-constant length: VPar Ex checking_check_defs_1_f_f.box_2_lambda_fake_source 0 + Type error: Can't fanout a Vec with non-constant length: VPar Ex checking_check_defs_1_f_LambdaChk_7_checkClauses_1_lambda.0_rhs/in_1 0 diff --git a/brat/test/golden/error/kbadvec.brat.golden b/brat/test/golden/error/kbadvec.brat.golden index 07a9e553..73424591 100644 --- a/brat/test/golden/error/kbadvec.brat.golden +++ b/brat/test/golden/error/kbadvec.brat.golden @@ -2,9 +2,5 @@ Error in test/golden/error/kbadvec.brat on line 2: triple = { b => [b] } ^^^ - Expected vector of length 3 -from the type: Vec(Bit, 3) -but got vector: [「b」] -of length 1 - + Unification error: Couldn't force 2 to be 0 diff --git a/brat/test/golden/error/kbadvec2.brat.golden b/brat/test/golden/error/kbadvec2.brat.golden index c70190e9..e245c2cb 100644 --- a/brat/test/golden/error/kbadvec2.brat.golden +++ b/brat/test/golden/error/kbadvec2.brat.golden @@ -2,9 +2,5 @@ Error in test/golden/error/kbadvec2.brat on line 2: triple = { b => nil } ^^^ - Expected vector of length 3 -from the type: Vec(Bit, 3) -but got vector: [] -of length 0 - + Unification error: Couldn't force 3 to be 0 diff --git a/brat/test/golden/error/kbadvec3.brat.golden b/brat/test/golden/error/kbadvec3.brat.golden index 97be8bec..aa22410d 100644 --- a/brat/test/golden/error/kbadvec3.brat.golden +++ b/brat/test/golden/error/kbadvec3.brat.golden @@ -2,9 +2,5 @@ Error in test/golden/error/kbadvec3.brat on line 2: constNil = { b => cons(1, nil) } ^^^^^^^^^^^^ - Expected vector of length 0 -from the type: Vec(Bit, 0) -but got vector: [1] -of length (> 0) - + Unification error: Couldn't force 1 + VPar In checking_check_defs_1_constNil_$rhs_check'Th_LambdaChk_7_checkClauses_1_$rhs_4_check'Con_$!_numpat2val_1 0 to be 0 diff --git a/brat/test/golden/error/remaining-nat-hopes.brat b/brat/test/golden/error/remaining-nat-hopes.brat new file mode 100644 index 00000000..e61eac34 --- /dev/null +++ b/brat/test/golden/error/remaining-nat-hopes.brat @@ -0,0 +1,8 @@ +show(n :: #) -> [] +show(_) = [] + +read([]) -> n :: # +read([]) = 42 + +bad :: [] +bad = let _ = read([]) in show(!) diff --git a/brat/test/golden/error/remaining-nat-hopes.brat.golden b/brat/test/golden/error/remaining-nat-hopes.brat.golden new file mode 100644 index 00000000..c1737905 --- /dev/null +++ b/brat/test/golden/error/remaining-nat-hopes.brat.golden @@ -0,0 +1,8 @@ +Error in test/golden/error/remaining-nat-hopes.brat on line 8: +bad = let _ = read([]) in show(!) + ^^^ + + Expected to work out values for these holes: + In checking_check_defs_1_bad_5_$rhs_$!_3 0 + + diff --git a/brat/test/golden/error/remaining_hopes.brat.golden b/brat/test/golden/error/remaining_hopes.brat.golden index 80d15436..ff53a23a 100644 --- a/brat/test/golden/error/remaining_hopes.brat.golden +++ b/brat/test/golden/error/remaining_hopes.brat.golden @@ -3,6 +3,6 @@ g = f(!) ^^^ Expected to work out values for these holes: - In checking_check_defs_1_g_1_Eval 0 + In checking_check_defs_1_g_3_$rhs_$!_1 0 diff --git a/brat/test/golden/error/vec_length.brat.golden b/brat/test/golden/error/vec_length.brat.golden index 6fda6b03..94f082ff 100644 --- a/brat/test/golden/error/vec_length.brat.golden +++ b/brat/test/golden/error/vec_length.brat.golden @@ -2,8 +2,5 @@ Error in test/golden/error/vec_length.brat on line 2: f(_, _, xs) = xs ^^ - Type mismatch when checking xs -Expected: (a1 :: Vec(VApp VPar Ex checking_check_defs_1_f_f.box_2_lambda_fake_source 0 B0, VPar Ex checking_check_defs_1_f_f.box_2_lambda_fake_source 1)) -But got: (xs :: Vec(VApp VPar Ex checking_check_defs_1_f_f.box_2_lambda_fake_source 0 B0, 1 + VPar Ex checking_check_defs_1_f_f.box_2_lambda_fake_source 1)) - + Unification error: Can't make Ex checking_check_defs_1_f_LambdaChk_7_checkClauses_1_lambda.0_rhs/in_1 1 = 1 + VPar Ex checking_check_defs_1_f_LambdaChk_7_checkClauses_1_lambda.0_rhs/in_1 1 diff --git a/brat/test/golden/error/vectorise1.brat.golden b/brat/test/golden/error/vectorise1.brat.golden index 570e060c..48596e5b 100644 --- a/brat/test/golden/error/vectorise1.brat.golden +++ b/brat/test/golden/error/vectorise1.brat.golden @@ -2,7 +2,7 @@ Error in test/golden/error/vectorise1.brat on line 2: bad1(n) = (n of (1, 2.0)), (n of 3) ^^^^^^^^ - Type error: Got: Vector of length VPar Ex checking_check_defs_1_bad1_bad1.box_2_lambda_fake_source 0 + Type error: Got: Vector of length VPar Ex checking_check_defs_1_bad1_$lhs_3_lambda_fake_source 0 Expected: empty row diff --git a/brat/test/golden/error/vectorise3.brat.golden b/brat/test/golden/error/vectorise3.brat.golden index 0b7c4871..7ad18984 100644 --- a/brat/test/golden/error/vectorise3.brat.golden +++ b/brat/test/golden/error/vectorise3.brat.golden @@ -3,5 +3,5 @@ f(_, _, n, f, xs) = (n of f)(xs) ^^^^^^^^^^^^ Type error: Expected function 「n」 of f() to consume all of its arguments (「xs」) - but found leftovers: (b1 :: Vec(VApp VPar Ex checking_check_defs_1_f_f.box_2_lambda_fake_source 0 B0, VPar Ex checking_check_defs_1_f_f.box_2_lambda_fake_source 2)) + but found leftovers: (b1 :: Vec(VApp VPar Ex checking_check_defs_1_f_$lhs_3_lambda_fake_source 0 B0, VPar Ex checking_check_defs_1_f_$lhs_3_lambda_fake_source 2)) diff --git a/brat/test/golden/graph/addN.brat.graph b/brat/test/golden/graph/addN.brat.graph index 31b411ac..84504c1e 100644 --- a/brat/test/golden/graph/addN.brat.graph +++ b/brat/test/golden/graph/addN.brat.graph @@ -1,15 +1,15 @@ Nodes: -(check_defs_1_addN_addN.box_2_lambda_11,BratNode (PatternMatch ((TestMatchData Braty (MatchSequence {matchInputs = [(NamedPort {end = Ex check_defs_1_addN_addN.box_2_lambda.0_setup/in_3 0, portName = "inp"},Int)], matchTests = [], matchOutputs = [(NamedPort {end = Ex check_defs_1_addN_addN.box_2_lambda.0_setup/in_3 0, portName = "inp"},Int)]}),check_defs_1_addN_addN.box_2_lambda.0_rhs_thunk_10) :| [])) [("inp",Int)] [("out",Int)]) -(check_defs_1_addN_addN.box_2_lambda.0_rhs_9_Eval,BratNode (Eval (Ex globals_prim_8_add 0)) [("a",Int),("b",Int)] [("c",Int)]) -(check_defs_1_addN_addN.box_2_lambda.0_rhs/in_7,BratNode Source [] [("n",Int)]) -(check_defs_1_addN_addN.box_2_lambda.0_rhs/out_8,BratNode Target [("out",Int)] []) -(check_defs_1_addN_addN.box_2_lambda.0_rhs_thunk_10,BratNode (Box (fromList []) check_defs_1_addN_addN.box_2_lambda.0_rhs/in_7 check_defs_1_addN_addN.box_2_lambda.0_rhs/out_8) [] [("thunk",{ (n :: Int) -> (out :: Int) })]) -(check_defs_1_addN_addN.box_2_lambda.0_setup/in_3,BratNode Source [] [("inp",Int)]) -(check_defs_1_addN_addN.box_2_lambda.0_setup/out_4,BratNode Target [("out",Int)] []) -(check_defs_1_addN_addN.box_2_lambda.0_setup_thunk_6,BratNode (Box (fromList []) check_defs_1_addN_addN.box_2_lambda.0_setup/in_3 check_defs_1_addN_addN.box_2_lambda.0_setup/out_4) [] [("thunk",{ (inp :: Int) -> (out :: Int) })]) +(check_defs_1_addN_LambdaChk_9_checkClauses_1_$lhs_lambda.0_setup/in,BratNode Source [] [("inp",Int)]) +(check_defs_1_addN_LambdaChk_9_checkClauses_1_$lhs_lambda.0_setup/out_1,BratNode Target [("out",Int)] []) +(check_defs_1_addN_LambdaChk_9_checkClauses_1_$lhs_lambda.0_setup_thunk_2,BratNode (Box check_defs_1_addN_LambdaChk_9_checkClauses_1_$lhs_lambda.0_setup/in check_defs_1_addN_LambdaChk_9_checkClauses_1_$lhs_lambda.0_setup/out_1) [] [("thunk",{ (inp :: Int) -> (out :: Int) })]) +(check_defs_1_addN_LambdaChk_9_checkClauses_1_$rhs_4_Eval,BratNode (Eval (Ex globals_prim_8_add 0)) [("a",Int),("b",Int)] [("c",Int)]) +(check_defs_1_addN_LambdaChk_9_checkClauses_1_lambda.0_rhs/in_1,BratNode Source [] [("n",Int)]) +(check_defs_1_addN_LambdaChk_9_checkClauses_1_lambda.0_rhs/out_2,BratNode Target [("out",Int)] []) +(check_defs_1_addN_LambdaChk_9_checkClauses_1_lambda.0_rhs_thunk_3,BratNode (Box check_defs_1_addN_LambdaChk_9_checkClauses_1_lambda.0_rhs/in_1 check_defs_1_addN_LambdaChk_9_checkClauses_1_lambda.0_rhs/out_2) [] [("thunk",{ (n :: Int) -> (out :: Int) })]) +(check_defs_1_addN_LambdaChk_9_lambda,BratNode (PatternMatch ((TestMatchData Braty (MatchSequence {matchInputs = [(NamedPort {end = Ex check_defs_1_addN_LambdaChk_9_checkClauses_1_$lhs_lambda.0_setup/in 0, portName = "inp"},Int)], matchTests = [], matchOutputs = [(NamedPort {end = Ex check_defs_1_addN_LambdaChk_9_checkClauses_1_$lhs_lambda.0_setup/in 0, portName = "inp"},Int)]}),check_defs_1_addN_LambdaChk_9_checkClauses_1_lambda.0_rhs_thunk_3) :| [])) [("inp",Int)] [("out",Int)]) (check_defs_1_addN_addN.box/in,BratNode Source [] [("inp",Int)]) (check_defs_1_addN_addN.box/out_1,BratNode Target [("out",Int)] []) -(check_defs_1_addN_addN.box_thunk_3,BratNode (Box (fromList []) check_defs_1_addN_addN.box/in check_defs_1_addN_addN.box/out_1) [] [("thunk",{ (inp :: Int) -> (out :: Int) })]) +(check_defs_1_addN_addN.box_thunk_2,BratNode (Box check_defs_1_addN_addN.box/in check_defs_1_addN_addN.box/out_1) [] [("thunk",{ (inp :: Int) -> (out :: Int) })]) (globals_Int_1,BratNode (Constructor Int) [] [("value",[])]) (globals_Int_5,BratNode (Constructor Int) [] [("value",[])]) (globals_Int_6,BratNode (Constructor Int) [] [("value",[])]) @@ -21,15 +21,15 @@ Nodes: (globals_prim_8_add,BratNode (Prim ("","add")) [] [("thunk",{ (a :: Int), (b :: Int) -> (c :: Int) })]) Wires: -(Ex check_defs_1_addN_addN.box/in 0,Int,In check_defs_1_addN_addN.box_2_lambda_11 0) -(Ex check_defs_1_addN_addN.box_2_lambda.0_rhs/in_7 0,Int,In check_defs_1_addN_addN.box_2_lambda.0_rhs_9_Eval 0) -(Ex check_defs_1_addN_addN.box_2_lambda.0_rhs_9_Eval 0,Int,In check_defs_1_addN_addN.box_2_lambda.0_rhs/out_8 0) -(Ex check_defs_1_addN_addN.box_2_lambda_11 0,Int,In check_defs_1_addN_addN.box/out_1 0) -(Ex check_defs_1_addN_addN.box_thunk_3 0,{ (inp :: Int) -> (out :: Int) },In globals_decl_13_addN 0) +(Ex check_defs_1_addN_LambdaChk_9_checkClauses_1_$rhs_4_Eval 0,Int,In check_defs_1_addN_LambdaChk_9_checkClauses_1_lambda.0_rhs/out_2 0) +(Ex check_defs_1_addN_LambdaChk_9_checkClauses_1_lambda.0_rhs/in_1 0,Int,In check_defs_1_addN_LambdaChk_9_checkClauses_1_$rhs_4_Eval 0) +(Ex check_defs_1_addN_LambdaChk_9_lambda 0,Int,In check_defs_1_addN_addN.box/out_1 0) +(Ex check_defs_1_addN_addN.box/in 0,Int,In check_defs_1_addN_LambdaChk_9_lambda 0) +(Ex check_defs_1_addN_addN.box_thunk_2 0,{ (inp :: Int) -> (out :: Int) },In globals_decl_13_addN 0) (Ex globals_Int_1 0,[],In globals___kcr_N 0) (Ex globals_Int_11 0,[],In globals___kcc_10 0) (Ex globals_Int_12 0,[],In globals___kcc_10 1) (Ex globals_Int_5 0,[],In globals___kcc_4 0) (Ex globals_Int_6 0,[],In globals___kcc_4 1) (Ex globals_Int_7 0,[],In globals___kcc_4 2) -(Ex globals_prim_2_N 0,Int,In check_defs_1_addN_addN.box_2_lambda.0_rhs_9_Eval 1) +(Ex globals_prim_2_N 0,Int,In check_defs_1_addN_LambdaChk_9_checkClauses_1_$rhs_4_Eval 1) diff --git a/brat/test/golden/graph/addN2.brat.graph b/brat/test/golden/graph/addN2.brat.graph index e23d7824..a481cd0d 100644 --- a/brat/test/golden/graph/addN2.brat.graph +++ b/brat/test/golden/graph/addN2.brat.graph @@ -1,15 +1,15 @@ Nodes: -(check_defs_1_addN_addN.box_2_lambda_11,BratNode (PatternMatch ((TestMatchData Braty (MatchSequence {matchInputs = [(NamedPort {end = Ex check_defs_1_addN_addN.box_2_lambda.0_setup/in_3 0, portName = "inp"},Int)], matchTests = [], matchOutputs = [(NamedPort {end = Ex check_defs_1_addN_addN.box_2_lambda.0_setup/in_3 0, portName = "inp"},Int)]}),check_defs_1_addN_addN.box_2_lambda.0_rhs_thunk_10) :| [])) [("inp",Int)] [("out",Int)]) -(check_defs_1_addN_addN.box_2_lambda.0_rhs_9_Eval,BratNode (Eval (Ex globals_prim_8_add 0)) [("a",Int),("b",Int)] [("c",Int)]) -(check_defs_1_addN_addN.box_2_lambda.0_rhs/in_7,BratNode Source [] [("n",Int)]) -(check_defs_1_addN_addN.box_2_lambda.0_rhs/out_8,BratNode Target [("out",Int)] []) -(check_defs_1_addN_addN.box_2_lambda.0_rhs_thunk_10,BratNode (Box (fromList []) check_defs_1_addN_addN.box_2_lambda.0_rhs/in_7 check_defs_1_addN_addN.box_2_lambda.0_rhs/out_8) [] [("thunk",{ (n :: Int) -> (out :: Int) })]) -(check_defs_1_addN_addN.box_2_lambda.0_setup/in_3,BratNode Source [] [("inp",Int)]) -(check_defs_1_addN_addN.box_2_lambda.0_setup/out_4,BratNode Target [("out",Int)] []) -(check_defs_1_addN_addN.box_2_lambda.0_setup_thunk_6,BratNode (Box (fromList []) check_defs_1_addN_addN.box_2_lambda.0_setup/in_3 check_defs_1_addN_addN.box_2_lambda.0_setup/out_4) [] [("thunk",{ (inp :: Int) -> (out :: Int) })]) +(check_defs_1_addN_LambdaChk_9_checkClauses_1_$lhs_lambda.0_setup/in,BratNode Source [] [("inp",Int)]) +(check_defs_1_addN_LambdaChk_9_checkClauses_1_$lhs_lambda.0_setup/out_1,BratNode Target [("out",Int)] []) +(check_defs_1_addN_LambdaChk_9_checkClauses_1_$lhs_lambda.0_setup_thunk_2,BratNode (Box check_defs_1_addN_LambdaChk_9_checkClauses_1_$lhs_lambda.0_setup/in check_defs_1_addN_LambdaChk_9_checkClauses_1_$lhs_lambda.0_setup/out_1) [] [("thunk",{ (inp :: Int) -> (out :: Int) })]) +(check_defs_1_addN_LambdaChk_9_checkClauses_1_$rhs_4_Eval,BratNode (Eval (Ex globals_prim_8_add 0)) [("a",Int),("b",Int)] [("c",Int)]) +(check_defs_1_addN_LambdaChk_9_checkClauses_1_lambda.0_rhs/in_1,BratNode Source [] [("n",Int)]) +(check_defs_1_addN_LambdaChk_9_checkClauses_1_lambda.0_rhs/out_2,BratNode Target [("out",Int)] []) +(check_defs_1_addN_LambdaChk_9_checkClauses_1_lambda.0_rhs_thunk_3,BratNode (Box check_defs_1_addN_LambdaChk_9_checkClauses_1_lambda.0_rhs/in_1 check_defs_1_addN_LambdaChk_9_checkClauses_1_lambda.0_rhs/out_2) [] [("thunk",{ (n :: Int) -> (out :: Int) })]) +(check_defs_1_addN_LambdaChk_9_lambda,BratNode (PatternMatch ((TestMatchData Braty (MatchSequence {matchInputs = [(NamedPort {end = Ex check_defs_1_addN_LambdaChk_9_checkClauses_1_$lhs_lambda.0_setup/in 0, portName = "inp"},Int)], matchTests = [], matchOutputs = [(NamedPort {end = Ex check_defs_1_addN_LambdaChk_9_checkClauses_1_$lhs_lambda.0_setup/in 0, portName = "inp"},Int)]}),check_defs_1_addN_LambdaChk_9_checkClauses_1_lambda.0_rhs_thunk_3) :| [])) [("inp",Int)] [("out",Int)]) (check_defs_1_addN_addN.box/in,BratNode Source [] [("inp",Int)]) (check_defs_1_addN_addN.box/out_1,BratNode Target [("out",Int)] []) -(check_defs_1_addN_addN.box_thunk_3,BratNode (Box (fromList []) check_defs_1_addN_addN.box/in check_defs_1_addN_addN.box/out_1) [] [("thunk",{ (inp :: Int) -> (out :: Int) })]) +(check_defs_1_addN_addN.box_thunk_2,BratNode (Box check_defs_1_addN_addN.box/in check_defs_1_addN_addN.box/out_1) [] [("thunk",{ (inp :: Int) -> (out :: Int) })]) (globals_Int_1,BratNode (Constructor Int) [] [("value",[])]) (globals_Int_5,BratNode (Constructor Int) [] [("value",[])]) (globals_Int_6,BratNode (Constructor Int) [] [("value",[])]) @@ -21,15 +21,15 @@ Nodes: (globals_prim_8_add,BratNode (Prim ("","add")) [] [("a1",{ (a :: Int), (b :: Int) -> (c :: Int) })]) Wires: -(Ex check_defs_1_addN_addN.box/in 0,Int,In check_defs_1_addN_addN.box_2_lambda_11 0) -(Ex check_defs_1_addN_addN.box_2_lambda.0_rhs/in_7 0,Int,In check_defs_1_addN_addN.box_2_lambda.0_rhs_9_Eval 0) -(Ex check_defs_1_addN_addN.box_2_lambda.0_rhs_9_Eval 0,Int,In check_defs_1_addN_addN.box_2_lambda.0_rhs/out_8 0) -(Ex check_defs_1_addN_addN.box_2_lambda_11 0,Int,In check_defs_1_addN_addN.box/out_1 0) -(Ex check_defs_1_addN_addN.box_thunk_3 0,{ (inp :: Int) -> (out :: Int) },In globals_decl_13_addN 0) +(Ex check_defs_1_addN_LambdaChk_9_checkClauses_1_$rhs_4_Eval 0,Int,In check_defs_1_addN_LambdaChk_9_checkClauses_1_lambda.0_rhs/out_2 0) +(Ex check_defs_1_addN_LambdaChk_9_checkClauses_1_lambda.0_rhs/in_1 0,Int,In check_defs_1_addN_LambdaChk_9_checkClauses_1_$rhs_4_Eval 0) +(Ex check_defs_1_addN_LambdaChk_9_lambda 0,Int,In check_defs_1_addN_addN.box/out_1 0) +(Ex check_defs_1_addN_addN.box/in 0,Int,In check_defs_1_addN_LambdaChk_9_lambda 0) +(Ex check_defs_1_addN_addN.box_thunk_2 0,{ (inp :: Int) -> (out :: Int) },In globals_decl_13_addN 0) (Ex globals_Int_1 0,[],In globals___kcr_N 0) (Ex globals_Int_11 0,[],In globals___kcc_10 0) (Ex globals_Int_12 0,[],In globals___kcc_10 1) (Ex globals_Int_5 0,[],In globals___kcc_4 0) (Ex globals_Int_6 0,[],In globals___kcc_4 1) (Ex globals_Int_7 0,[],In globals___kcc_4 2) -(Ex globals_prim_2_N 0,Int,In check_defs_1_addN_addN.box_2_lambda.0_rhs_9_Eval 1) +(Ex globals_prim_2_N 0,Int,In check_defs_1_addN_LambdaChk_9_checkClauses_1_$rhs_4_Eval 1) diff --git a/brat/test/golden/graph/cons.brat.graph b/brat/test/golden/graph/cons.brat.graph index cc61c7b8..06981276 100644 --- a/brat/test/golden/graph/cons.brat.graph +++ b/brat/test/golden/graph/cons.brat.graph @@ -1,11 +1,25 @@ Nodes: -(check_defs_1_three_1_cons,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 2))] [("value",Vec(Int, 3))]) -(check_defs_1_three_1_const_1,BratNode (Const 0) [] [("value",Int)]) -(check_defs_1_two_cons,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 1))] [("value",Vec(Int, 2))]) -(check_defs_1_two_cons_2,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 0))] [("value",Vec(Int, 1))]) -(check_defs_1_two_const_1,BratNode (Const 1) [] [("value",Int)]) -(check_defs_1_two_const_3,BratNode (Const 2) [] [("value",Int)]) -(check_defs_1_two_nil_4,BratNode (Constructor nil) [] [("value",Vec(Int, 0))]) +(check_defs_1_three_2_$rhs_check'Con_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) +(check_defs_1_three_2_$rhs_check'Con_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_three_2_$rhs_check'Con_cons_2,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 2))] [("value",Vec(Int, 3))]) +(check_defs_1_three_2_$rhs_check'Con_const_3,BratNode (Const 0) [] [("value",Int)]) +(check_defs_1_three_2_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1,BratNode (ArithNode Add) [("lhs",Nat),("rhs",Nat)] [("value",Nat)]) +(check_defs_1_three_2_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst,BratNode (Const 2) [] [("value",Nat)]) +(check_defs_1_three_2_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst_2,BratNode (Const 0) [] [("value",Nat)]) +(check_defs_1_two_$rhs_check'Con_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) +(check_defs_1_two_$rhs_check'Con_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_two_$rhs_check'Con_check'Con_4_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) +(check_defs_1_two_$rhs_check'Con_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_two_$rhs_check'Con_check'Con_4_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_two_$rhs_check'Con_check'Con_4_check'Con_4_nil_2,BratNode (Constructor nil) [] [("value",Vec(Int, 0))]) +(check_defs_1_two_$rhs_check'Con_check'Con_4_cons_2,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 0))] [("value",Vec(Int, 1))]) +(check_defs_1_two_$rhs_check'Con_check'Con_4_const_3,BratNode (Const 2) [] [("value",Int)]) +(check_defs_1_two_$rhs_check'Con_check'Con_4_typeEqsTail_1_buildConst_1,BratNode (Const 0) [] [("value",Nat)]) +(check_defs_1_two_$rhs_check'Con_cons_2,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 1))] [("value",Vec(Int, 2))]) +(check_defs_1_two_$rhs_check'Con_const_3,BratNode (Const 1) [] [("value",Int)]) +(check_defs_1_two_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1,BratNode (ArithNode Add) [("lhs",Nat),("rhs",Nat)] [("value",Nat)]) +(check_defs_1_two_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst,BratNode (Const 1) [] [("value",Nat)]) +(check_defs_1_two_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst_2,BratNode (Const 0) [] [("value",Nat)]) (globals_Int_2,BratNode (Constructor Int) [] [("value",[])]) (globals_Int_7,BratNode (Constructor Int) [] [("value",[])]) (globals_Vec_1,BratNode (Constructor Vec) [("X",[]),("n",Nat)] [("value",[])]) @@ -16,17 +30,24 @@ Nodes: (globals_decl_9_three,BratNode Id [("a1",Vec(Int, 3))] [("a1",Vec(Int, 3))]) Wires: -(Ex check_defs_1_three_1_cons 0,Vec(Int, 3),In globals_decl_9_three 0) -(Ex check_defs_1_three_1_const_1 0,Int,In check_defs_1_three_1_cons 0) -(Ex check_defs_1_two_cons 0,Vec(Int, 2),In globals_decl_4_two 0) -(Ex check_defs_1_two_cons_2 0,Vec(Int, 1),In check_defs_1_two_cons 1) -(Ex check_defs_1_two_const_1 0,Int,In check_defs_1_two_cons 0) -(Ex check_defs_1_two_const_3 0,Int,In check_defs_1_two_cons_2 0) -(Ex check_defs_1_two_nil_4 0,Vec(Int, 0),In check_defs_1_two_cons_2 1) +(Ex check_defs_1_three_2_$rhs_check'Con_cons_2 0,Vec(Int, 3),In globals_decl_9_three 0) +(Ex check_defs_1_three_2_$rhs_check'Con_const_3 0,Int,In check_defs_1_three_2_$rhs_check'Con_cons_2 0) +(Ex check_defs_1_three_2_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1 0,Nat,In check_defs_1_three_2_$rhs_check'Con_$!_numpat2val_1 0) +(Ex check_defs_1_three_2_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst 0,Nat,In check_defs_1_three_2_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1 0) +(Ex check_defs_1_three_2_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst_2 0,Nat,In check_defs_1_three_2_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1 1) +(Ex check_defs_1_two_$rhs_check'Con_check'Con_4_check'Con_4_nil_2 0,Vec(Int, 0),In check_defs_1_two_$rhs_check'Con_check'Con_4_cons_2 1) +(Ex check_defs_1_two_$rhs_check'Con_check'Con_4_cons_2 0,Vec(Int, 1),In check_defs_1_two_$rhs_check'Con_cons_2 1) +(Ex check_defs_1_two_$rhs_check'Con_check'Con_4_const_3 0,Int,In check_defs_1_two_$rhs_check'Con_check'Con_4_cons_2 0) +(Ex check_defs_1_two_$rhs_check'Con_check'Con_4_typeEqsTail_1_buildConst_1 0,Nat,In check_defs_1_two_$rhs_check'Con_check'Con_4_$!_numpat2val_1 0) +(Ex check_defs_1_two_$rhs_check'Con_cons_2 0,Vec(Int, 2),In globals_decl_4_two 0) +(Ex check_defs_1_two_$rhs_check'Con_const_3 0,Int,In check_defs_1_two_$rhs_check'Con_cons_2 0) +(Ex check_defs_1_two_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1 0,Nat,In check_defs_1_two_$rhs_check'Con_$!_numpat2val_1 0) +(Ex check_defs_1_two_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst 0,Nat,In check_defs_1_two_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1 0) +(Ex check_defs_1_two_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst_2 0,Nat,In check_defs_1_two_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1 1) (Ex globals_Int_2 0,[],In globals_Vec_1 0) (Ex globals_Int_7 0,[],In globals_Vec_6 0) (Ex globals_Vec_1 0,[],In globals___kca_two 0) (Ex globals_Vec_6 0,[],In globals___kca_three_5 0) (Ex globals_const_3 0,Nat,In globals_Vec_1 1) (Ex globals_const_8 0,Nat,In globals_Vec_6 1) -(Ex globals_decl_4_two 0,Vec(Int, 2),In check_defs_1_three_1_cons 1) +(Ex globals_decl_4_two 0,Vec(Int, 2),In check_defs_1_three_2_$rhs_check'Con_cons_2 1) diff --git a/brat/test/golden/graph/id.brat.graph b/brat/test/golden/graph/id.brat.graph index 16c379b7..8467bd30 100644 --- a/brat/test/golden/graph/id.brat.graph +++ b/brat/test/golden/graph/id.brat.graph @@ -1,22 +1,22 @@ Nodes: -(check_defs_1_main_thunk_3_lambda_10,KernelNode (PatternMatch ((TestMatchData Kerny (MatchSequence {matchInputs = [(NamedPort {end = Ex check_defs_1_main_thunk_3_lambda.0_setup/in_2 0, portName = "a"},Qubit)], matchTests = [], matchOutputs = [(NamedPort {end = Ex check_defs_1_main_thunk_3_lambda.0_setup/in_2 0, portName = "a"},Qubit)]}),check_defs_1_main_thunk_3_lambda.0_rhs_thunk_8) :| [])) [("a",Qubit)] [("b",Qubit)]) -(check_defs_1_main_thunk_3_lambda.0_rhs/in_6,KernelNode Source [] [("q",Qubit)]) -(check_defs_1_main_thunk_3_lambda.0_rhs/out_7,KernelNode Target [("b",Qubit)] []) -(check_defs_1_main_thunk_3_lambda.0_rhs_thunk_8,BratNode (Box (fromList []) check_defs_1_main_thunk_3_lambda.0_rhs/in_6 check_defs_1_main_thunk_3_lambda.0_rhs/out_7) [] [("thunk",{ (q :: Qubit) -o (b :: Qubit) })]) -(check_defs_1_main_thunk_3_lambda.0_setup/in_2,KernelNode Source [] [("a",Qubit)]) -(check_defs_1_main_thunk_3_lambda.0_setup/out_3,KernelNode Target [("b",Qubit)] []) -(check_defs_1_main_thunk_3_lambda.0_setup_thunk_4,BratNode (Box (fromList []) check_defs_1_main_thunk_3_lambda.0_setup/in_2 check_defs_1_main_thunk_3_lambda.0_setup/out_3) [] [("thunk",{ (a :: Qubit) -o (b :: Qubit) })]) -(check_defs_1_main_thunk/in,KernelNode Source [] [("a",Qubit)]) -(check_defs_1_main_thunk/out_1,KernelNode Target [("b",Qubit)] []) -(check_defs_1_main_thunk_thunk_2,BratNode (Box (fromList []) check_defs_1_main_thunk/in check_defs_1_main_thunk/out_1) [] [("thunk",{ (a :: Qubit) -o (b :: Qubit) })]) +(check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in,KernelNode Source [] [("a",Qubit)]) +(check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/out_1,KernelNode Target [("b",Qubit)] []) +(check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup_thunk_2,BratNode (Box check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/out_1) [] [("thunk",{ (a :: Qubit) -o (b :: Qubit) })]) +(check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/in_1,KernelNode Source [] [("q",Qubit)]) +(check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/out_2,KernelNode Target [("b",Qubit)] []) +(check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs_thunk_3,BratNode (Box check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/in_1 check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/out_2) [] [("thunk",{ (q :: Qubit) -o (b :: Qubit) })]) +(check_defs_1_main_$rhs_check'Th_LambdaChk_6_lambda,KernelNode (PatternMatch ((TestMatchData Kerny (MatchSequence {matchInputs = [(NamedPort {end = Ex check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in 0, portName = "a"},Qubit)], matchTests = [], matchOutputs = [(NamedPort {end = Ex check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in 0, portName = "a"},Qubit)]}),check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs_thunk_3) :| [])) [("a",Qubit)] [("b",Qubit)]) +(check_defs_1_main_$rhs_check'Th_thunk/in,KernelNode Source [] [("a",Qubit)]) +(check_defs_1_main_$rhs_check'Th_thunk/out_1,KernelNode Target [("b",Qubit)] []) +(check_defs_1_main_$rhs_check'Th_thunk_thunk_2,BratNode (Box check_defs_1_main_$rhs_check'Th_thunk/in check_defs_1_main_$rhs_check'Th_thunk/out_1) [] [("thunk",{ (a :: Qubit) -o (b :: Qubit) })]) (globals_Qubit_2,BratNode (Constructor Qubit) [] [("value",[])]) (globals_Qubit_4,BratNode (Constructor Qubit) [] [("value",[])]) (globals_decl_5_main,BratNode Id [("a1",{ (a :: Qubit) -o (b :: Qubit) })] [("a1",{ (a :: Qubit) -o (b :: Qubit) })]) Wires: -(Ex check_defs_1_main_thunk/in 0,Qubit,In check_defs_1_main_thunk_3_lambda_10 0) -(Ex check_defs_1_main_thunk_3_lambda.0_rhs/in_6 0,Qubit,In check_defs_1_main_thunk_3_lambda.0_rhs/out_7 0) -(Ex check_defs_1_main_thunk_3_lambda_10 0,Qubit,In check_defs_1_main_thunk/out_1 0) -(Ex check_defs_1_main_thunk_thunk_2 0,{ (a :: Qubit) -o (b :: Qubit) },In globals_decl_5_main 0) +(Ex check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/in_1 0,Qubit,In check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/out_2 0) +(Ex check_defs_1_main_$rhs_check'Th_LambdaChk_6_lambda 0,Qubit,In check_defs_1_main_$rhs_check'Th_thunk/out_1 0) +(Ex check_defs_1_main_$rhs_check'Th_thunk/in 0,Qubit,In check_defs_1_main_$rhs_check'Th_LambdaChk_6_lambda 0) +(Ex check_defs_1_main_$rhs_check'Th_thunk_thunk_2 0,{ (a :: Qubit) -o (b :: Qubit) },In globals_decl_5_main 0) (Ex globals_Qubit_2 0,[],In globals___kcr__1 0) (Ex globals_Qubit_4 0,[],In globals___kcr__3 0) diff --git a/brat/test/golden/graph/kernel.brat.graph b/brat/test/golden/graph/kernel.brat.graph index 26ad580e..e918270f 100644 --- a/brat/test/golden/graph/kernel.brat.graph +++ b/brat/test/golden/graph/kernel.brat.graph @@ -1,18 +1,32 @@ Nodes: -(check_defs_1_id3_thunk_3_lambda_14,KernelNode (PatternMatch ((TestMatchData Kerny (MatchSequence {matchInputs = [(NamedPort {end = Ex check_defs_1_id3_thunk_3_lambda.0_setup/in_6 0, portName = "a1"},Qubit),(NamedPort {end = Ex check_defs_1_id3_thunk_3_lambda.0_setup/in_6 1, portName = "b1"},Qubit),(NamedPort {end = Ex check_defs_1_id3_thunk_3_lambda.0_setup/in_6 2, portName = "c1"},Qubit)], matchTests = [], matchOutputs = [(NamedPort {end = Ex check_defs_1_id3_thunk_3_lambda.0_setup/in_6 0, portName = "a1"},Qubit),(NamedPort {end = Ex check_defs_1_id3_thunk_3_lambda.0_setup/in_6 1, portName = "b1"},Qubit),(NamedPort {end = Ex check_defs_1_id3_thunk_3_lambda.0_setup/in_6 2, portName = "c1"},Qubit)]}),check_defs_1_id3_thunk_3_lambda.0_rhs_thunk_12) :| [])) [("a1",Qubit),("b1",Qubit),("c1",Qubit)] [("a1",Vec(Qubit, 3))]) -(check_defs_1_id3_thunk_3_lambda.0_rhs_13_cons,KernelNode (Constructor cons) [("head",Qubit),("tail",Vec(Qubit, 2))] [("value",Vec(Qubit, 3))]) -(check_defs_1_id3_thunk_3_lambda.0_rhs_13_cons_1,KernelNode (Constructor cons) [("head",Qubit),("tail",Vec(Qubit, 1))] [("value",Vec(Qubit, 2))]) -(check_defs_1_id3_thunk_3_lambda.0_rhs_13_cons_2,KernelNode (Constructor cons) [("head",Qubit),("tail",Vec(Qubit, 0))] [("value",Vec(Qubit, 1))]) -(check_defs_1_id3_thunk_3_lambda.0_rhs_13_nil_3,KernelNode (Constructor nil) [] [("value",Vec(Qubit, 0))]) -(check_defs_1_id3_thunk_3_lambda.0_rhs/in_10,KernelNode Source [] [("q0",Qubit),("q1",Qubit),("q2",Qubit)]) -(check_defs_1_id3_thunk_3_lambda.0_rhs/out_11,KernelNode Target [("a1",Vec(Qubit, 3))] []) -(check_defs_1_id3_thunk_3_lambda.0_rhs_thunk_12,BratNode (Box (fromList []) check_defs_1_id3_thunk_3_lambda.0_rhs/in_10 check_defs_1_id3_thunk_3_lambda.0_rhs/out_11) [] [("thunk",{ (q0 :: Qubit), (q1 :: Qubit), (q2 :: Qubit) -o (a1 :: Vec(Qubit, 3)) })]) -(check_defs_1_id3_thunk_3_lambda.0_setup/in_6,KernelNode Source [] [("a1",Qubit),("b1",Qubit),("c1",Qubit)]) -(check_defs_1_id3_thunk_3_lambda.0_setup/out_7,KernelNode Target [("a1",Vec(Qubit, 3))] []) -(check_defs_1_id3_thunk_3_lambda.0_setup_thunk_8,BratNode (Box (fromList []) check_defs_1_id3_thunk_3_lambda.0_setup/in_6 check_defs_1_id3_thunk_3_lambda.0_setup/out_7) [] [("thunk",{ (a1 :: Qubit), (b1 :: Qubit), (c1 :: Qubit) -o (a1 :: Vec(Qubit, 3)) })]) -(check_defs_1_id3_thunk/in,KernelNode Source [] [("a1",Qubit),("b1",Qubit),("c1",Qubit)]) -(check_defs_1_id3_thunk/out_1,KernelNode Target [("a1",Vec(Qubit, 3))] []) -(check_defs_1_id3_thunk_thunk_2,BratNode (Box (fromList []) check_defs_1_id3_thunk/in check_defs_1_id3_thunk/out_1) [] [("thunk",{ (a1 :: Qubit), (b1 :: Qubit), (c1 :: Qubit) -o (a1 :: Vec(Qubit, 3)) })]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in,KernelNode Source [] [("a1",Qubit),("b1",Qubit),("c1",Qubit)]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/out_1,KernelNode Target [("a1",Vec(Qubit, 3))] []) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup_thunk_2,BratNode (Box check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/out_1) [] [("thunk",{ (a1 :: Qubit), (b1 :: Qubit), (c1 :: Qubit) -o (a1 :: Vec(Qubit, 3)) })]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_check'Con_4_nil_2,KernelNode (Constructor nil) [] [("value",Vec(Qubit, 0))]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_cons_2,KernelNode (Constructor cons) [("head",Qubit),("tail",Vec(Qubit, 0))] [("value",Vec(Qubit, 1))]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_typeEqsTail_1_buildConst_1,BratNode (Const 0) [] [("value",Nat)]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_cons_2,KernelNode (Constructor cons) [("head",Qubit),("tail",Vec(Qubit, 1))] [("value",Vec(Qubit, 2))]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_typeEqsTail_1_$!_1_Add_1,BratNode (ArithNode Add) [("lhs",Nat),("rhs",Nat)] [("value",Nat)]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_typeEqsTail_1_$!_1_buildConst,BratNode (Const 1) [] [("value",Nat)]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_typeEqsTail_1_$!_1_buildConst_2,BratNode (Const 0) [] [("value",Nat)]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_cons_2,KernelNode (Constructor cons) [("head",Qubit),("tail",Vec(Qubit, 2))] [("value",Vec(Qubit, 3))]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_typeEqsTail_1_$!_1_Add_1,BratNode (ArithNode Add) [("lhs",Nat),("rhs",Nat)] [("value",Nat)]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_typeEqsTail_1_$!_1_buildConst,BratNode (Const 2) [] [("value",Nat)]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_typeEqsTail_1_$!_1_buildConst_2,BratNode (Const 0) [] [("value",Nat)]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/in_1,KernelNode Source [] [("q0",Qubit),("q1",Qubit),("q2",Qubit)]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/out_2,KernelNode Target [("a1",Vec(Qubit, 3))] []) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs_thunk_3,BratNode (Box check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/in_1 check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/out_2) [] [("thunk",{ (q0 :: Qubit), (q1 :: Qubit), (q2 :: Qubit) -o (a1 :: Vec(Qubit, 3)) })]) +(check_defs_1_id3_$rhs_check'Th_LambdaChk_6_lambda,KernelNode (PatternMatch ((TestMatchData Kerny (MatchSequence {matchInputs = [(NamedPort {end = Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in 0, portName = "a1"},Qubit),(NamedPort {end = Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in 1, portName = "b1"},Qubit),(NamedPort {end = Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in 2, portName = "c1"},Qubit)], matchTests = [], matchOutputs = [(NamedPort {end = Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in 0, portName = "a1"},Qubit),(NamedPort {end = Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in 1, portName = "b1"},Qubit),(NamedPort {end = Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in 2, portName = "c1"},Qubit)]}),check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs_thunk_3) :| [])) [("a1",Qubit),("b1",Qubit),("c1",Qubit)] [("a1",Vec(Qubit, 3))]) +(check_defs_1_id3_$rhs_check'Th_thunk/in,KernelNode Source [] [("a1",Qubit),("b1",Qubit),("c1",Qubit)]) +(check_defs_1_id3_$rhs_check'Th_thunk/out_1,KernelNode Target [("a1",Vec(Qubit, 3))] []) +(check_defs_1_id3_$rhs_check'Th_thunk_thunk_2,BratNode (Box check_defs_1_id3_$rhs_check'Th_thunk/in check_defs_1_id3_$rhs_check'Th_thunk/out_1) [] [("thunk",{ (a1 :: Qubit), (b1 :: Qubit), (c1 :: Qubit) -o (a1 :: Vec(Qubit, 3)) })]) (globals_Qubit_2,BratNode (Constructor Qubit) [] [("value",[])]) (globals_Qubit_3,BratNode (Constructor Qubit) [] [("value",[])]) (globals_Qubit_4,BratNode (Constructor Qubit) [] [("value",[])]) @@ -22,18 +36,25 @@ Nodes: (globals_decl_9_id3,BratNode Id [("a1",{ (a1 :: Qubit), (b1 :: Qubit), (c1 :: Qubit) -o (a1 :: Vec(Qubit, 3)) })] [("a1",{ (a1 :: Qubit), (b1 :: Qubit), (c1 :: Qubit) -o (a1 :: Vec(Qubit, 3)) })]) Wires: -(Ex check_defs_1_id3_thunk/in 0,Qubit,In check_defs_1_id3_thunk_3_lambda_14 0) -(Ex check_defs_1_id3_thunk/in 1,Qubit,In check_defs_1_id3_thunk_3_lambda_14 1) -(Ex check_defs_1_id3_thunk/in 2,Qubit,In check_defs_1_id3_thunk_3_lambda_14 2) -(Ex check_defs_1_id3_thunk_3_lambda.0_rhs/in_10 0,Qubit,In check_defs_1_id3_thunk_3_lambda.0_rhs_13_cons 0) -(Ex check_defs_1_id3_thunk_3_lambda.0_rhs/in_10 1,Qubit,In check_defs_1_id3_thunk_3_lambda.0_rhs_13_cons_1 0) -(Ex check_defs_1_id3_thunk_3_lambda.0_rhs/in_10 2,Qubit,In check_defs_1_id3_thunk_3_lambda.0_rhs_13_cons_2 0) -(Ex check_defs_1_id3_thunk_3_lambda.0_rhs_13_cons 0,Vec(Qubit, 3),In check_defs_1_id3_thunk_3_lambda.0_rhs/out_11 0) -(Ex check_defs_1_id3_thunk_3_lambda.0_rhs_13_cons_1 0,Vec(Qubit, 2),In check_defs_1_id3_thunk_3_lambda.0_rhs_13_cons 1) -(Ex check_defs_1_id3_thunk_3_lambda.0_rhs_13_cons_2 0,Vec(Qubit, 1),In check_defs_1_id3_thunk_3_lambda.0_rhs_13_cons_1 1) -(Ex check_defs_1_id3_thunk_3_lambda.0_rhs_13_nil_3 0,Vec(Qubit, 0),In check_defs_1_id3_thunk_3_lambda.0_rhs_13_cons_2 1) -(Ex check_defs_1_id3_thunk_3_lambda_14 0,Vec(Qubit, 3),In check_defs_1_id3_thunk/out_1 0) -(Ex check_defs_1_id3_thunk_thunk_2 0,{ (a1 :: Qubit), (b1 :: Qubit), (c1 :: Qubit) -o (a1 :: Vec(Qubit, 3)) },In globals_decl_9_id3 0) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_check'Con_4_nil_2 0,Vec(Qubit, 0),In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_cons_2 1) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_cons_2 0,Vec(Qubit, 1),In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_cons_2 1) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_typeEqsTail_1_buildConst_1 0,Nat,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_$!_numpat2val_1 0) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_cons_2 0,Vec(Qubit, 2),In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_cons_2 1) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_typeEqsTail_1_$!_1_Add_1 0,Nat,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_$!_numpat2val_1 0) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_typeEqsTail_1_$!_1_buildConst 0,Nat,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_typeEqsTail_1_$!_1_Add_1 0) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_typeEqsTail_1_$!_1_buildConst_2 0,Nat,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_typeEqsTail_1_$!_1_Add_1 1) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_cons_2 0,Vec(Qubit, 3),In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/out_2 0) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_typeEqsTail_1_$!_1_Add_1 0,Nat,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_$!_numpat2val_1 0) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_typeEqsTail_1_$!_1_buildConst 0,Nat,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_typeEqsTail_1_$!_1_Add_1 0) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_typeEqsTail_1_$!_1_buildConst_2 0,Nat,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_typeEqsTail_1_$!_1_Add_1 1) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/in_1 0,Qubit,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_cons_2 0) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/in_1 1,Qubit,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_cons_2 0) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/in_1 2,Qubit,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_check'Con_check'Con_4_check'Con_4_cons_2 0) +(Ex check_defs_1_id3_$rhs_check'Th_LambdaChk_6_lambda 0,Vec(Qubit, 3),In check_defs_1_id3_$rhs_check'Th_thunk/out_1 0) +(Ex check_defs_1_id3_$rhs_check'Th_thunk/in 0,Qubit,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_lambda 0) +(Ex check_defs_1_id3_$rhs_check'Th_thunk/in 1,Qubit,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_lambda 1) +(Ex check_defs_1_id3_$rhs_check'Th_thunk/in 2,Qubit,In check_defs_1_id3_$rhs_check'Th_LambdaChk_6_lambda 2) +(Ex check_defs_1_id3_$rhs_check'Th_thunk_thunk_2 0,{ (a1 :: Qubit), (b1 :: Qubit), (c1 :: Qubit) -o (a1 :: Vec(Qubit, 3)) },In globals_decl_9_id3 0) (Ex globals_Qubit_2 0,[],In globals___kcr__1 0) (Ex globals_Qubit_3 0,[],In globals___kcr__1 1) (Ex globals_Qubit_4 0,[],In globals___kcr__1 2) diff --git a/brat/test/golden/graph/list.brat.graph b/brat/test/golden/graph/list.brat.graph index de1910c1..fc6e7300 100644 --- a/brat/test/golden/graph/list.brat.graph +++ b/brat/test/golden/graph/list.brat.graph @@ -1,22 +1,26 @@ Nodes: -(check_defs_1_xs_cons,BratNode (Constructor cons) [("head",Int),("tail",List(Int))] [("value",List(Int))]) -(check_defs_1_xs_cons_2,BratNode (Constructor cons) [("head",Int),("tail",List(Int))] [("value",List(Int))]) -(check_defs_1_xs_cons_4,BratNode (Constructor cons) [("head",Int),("tail",List(Int))] [("value",List(Int))]) -(check_defs_1_xs_const_1,BratNode (Const 1) [] [("value",Int)]) -(check_defs_1_xs_const_3,BratNode (Const 2) [] [("value",Int)]) -(check_defs_1_xs_const_5,BratNode (Const 3) [] [("value",Int)]) -(check_defs_1_xs_nil_6,BratNode (Constructor nil) [] [("value",List(Int))]) +(check_defs_1_xs_$rhs_check'Con_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_check'Con_4_nil_2,BratNode (Constructor nil) [] [("value",List(Int))]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_cons_2,BratNode (Constructor cons) [("head",Int),("tail",List(Int))] [("value",List(Int))]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_const_3,BratNode (Const 3) [] [("value",Int)]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2,BratNode (Constructor cons) [("head",Int),("tail",List(Int))] [("value",List(Int))]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_const_3,BratNode (Const 2) [] [("value",Int)]) +(check_defs_1_xs_$rhs_check'Con_cons_2,BratNode (Constructor cons) [("head",Int),("tail",List(Int))] [("value",List(Int))]) +(check_defs_1_xs_$rhs_check'Con_const_3,BratNode (Const 1) [] [("value",Int)]) (globals_Int_2,BratNode (Constructor Int) [] [("value",[])]) (globals_List_1,BratNode (Constructor List) [("listValue",[])] [("value",[])]) (globals_decl_3_xs,BratNode Id [("a1",List(Int))] [("a1",List(Int))]) Wires: -(Ex check_defs_1_xs_cons 0,List(Int),In globals_decl_3_xs 0) -(Ex check_defs_1_xs_cons_2 0,List(Int),In check_defs_1_xs_cons 1) -(Ex check_defs_1_xs_cons_4 0,List(Int),In check_defs_1_xs_cons_2 1) -(Ex check_defs_1_xs_const_1 0,Int,In check_defs_1_xs_cons 0) -(Ex check_defs_1_xs_const_3 0,Int,In check_defs_1_xs_cons_2 0) -(Ex check_defs_1_xs_const_5 0,Int,In check_defs_1_xs_cons_4 0) -(Ex check_defs_1_xs_nil_6 0,List(Int),In check_defs_1_xs_cons_4 1) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_check'Con_4_nil_2 0,List(Int),In check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_cons_2 1) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_cons_2 0,List(Int),In check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2 1) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_const_3 0,Int,In check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_cons_2 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2 0,List(Int),In check_defs_1_xs_$rhs_check'Con_cons_2 1) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_const_3 0,Int,In check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2 0) +(Ex check_defs_1_xs_$rhs_check'Con_cons_2 0,List(Int),In globals_decl_3_xs 0) +(Ex check_defs_1_xs_$rhs_check'Con_const_3 0,Int,In check_defs_1_xs_$rhs_check'Con_cons_2 0) (Ex globals_Int_2 0,[],In globals_List_1 0) (Ex globals_List_1 0,[],In globals___kca_xs 0) diff --git a/brat/test/golden/graph/num.brat.graph b/brat/test/golden/graph/num.brat.graph index e9645cc6..23ffb004 100644 --- a/brat/test/golden/graph/num.brat.graph +++ b/brat/test/golden/graph/num.brat.graph @@ -1,17 +1,17 @@ Nodes: -(check_defs_1_m_1_const_1,BratNode (Const -3) [] [("value",Int)]) -(check_defs_1_m_1_doub,BratNode (Constructor doub) [("value",Int)] [("value",Int)]) -(check_defs_1_n_const_1,BratNode (Const 2) [] [("value",Nat)]) -(check_defs_1_n_succ,BratNode (Constructor succ) [("value",Nat)] [("value",Nat)]) +(check_defs_1_m_2_$rhs_check'Con_const_2,BratNode (Const -3) [] [("value",Int)]) +(check_defs_1_m_2_$rhs_check'Con_doub_1,BratNode (Constructor doub) [("value",Int)] [("value",Int)]) +(check_defs_1_n_$rhs_check'Con_const_2,BratNode (Const 2) [] [("value",Nat)]) +(check_defs_1_n_$rhs_check'Con_succ_1,BratNode (Constructor succ) [("value",Nat)] [("value",Nat)]) (globals_Int_4,BratNode (Constructor Int) [] [("value",[])]) (globals_Nat_1,BratNode (Constructor Nat) [] [("value",[])]) (globals_decl_2_n,BratNode Id [("a1",Nat)] [("a1",Nat)]) (globals_decl_5_m,BratNode Id [("a1",Int)] [("a1",Int)]) Wires: -(Ex check_defs_1_m_1_const_1 0,Int,In check_defs_1_m_1_doub 0) -(Ex check_defs_1_m_1_doub 0,Int,In globals_decl_5_m 0) -(Ex check_defs_1_n_const_1 0,Nat,In check_defs_1_n_succ 0) -(Ex check_defs_1_n_succ 0,Nat,In globals_decl_2_n 0) +(Ex check_defs_1_m_2_$rhs_check'Con_const_2 0,Int,In check_defs_1_m_2_$rhs_check'Con_doub_1 0) +(Ex check_defs_1_m_2_$rhs_check'Con_doub_1 0,Int,In globals_decl_5_m 0) +(Ex check_defs_1_n_$rhs_check'Con_const_2 0,Nat,In check_defs_1_n_$rhs_check'Con_succ_1 0) +(Ex check_defs_1_n_$rhs_check'Con_succ_1 0,Nat,In globals_decl_2_n 0) (Ex globals_Int_4 0,[],In globals___kca_m_3 0) (Ex globals_Nat_1 0,[],In globals___kca_n 0) diff --git a/brat/test/golden/graph/one.brat.graph b/brat/test/golden/graph/one.brat.graph index 2a7e1081..29d4122f 100644 --- a/brat/test/golden/graph/one.brat.graph +++ b/brat/test/golden/graph/one.brat.graph @@ -1,8 +1,8 @@ Nodes: -(check_defs_1_one_const,BratNode (Const 1) [] [("value",Int)]) +(check_defs_1_one_$rhs_const,BratNode (Const 1) [] [("value",Int)]) (globals_Int_1,BratNode (Constructor Int) [] [("value",[])]) (globals_decl_2_one,BratNode Id [("n",Int)] [("n",Int)]) Wires: -(Ex check_defs_1_one_const 0,Int,In globals_decl_2_one 0) +(Ex check_defs_1_one_$rhs_const 0,Int,In globals_decl_2_one 0) (Ex globals_Int_1 0,[],In globals___kca_one 0) diff --git a/brat/test/golden/graph/pair.brat.graph b/brat/test/golden/graph/pair.brat.graph index ef826479..88e697ab 100644 --- a/brat/test/golden/graph/pair.brat.graph +++ b/brat/test/golden/graph/pair.brat.graph @@ -1,9 +1,13 @@ Nodes: -(check_defs_1_xs_cons,BratNode (Constructor cons) [("head",Int),("tail",[Bool])] [("value",[Int,Bool])]) -(check_defs_1_xs_cons_2,BratNode (Constructor cons) [("head",Bool),("tail",[])] [("value",[Bool])]) -(check_defs_1_xs_const_1,BratNode (Const 1) [] [("value",Int)]) -(check_defs_1_xs_nil_4,BratNode (Constructor nil) [] [("value",[])]) -(check_defs_1_xs_true_3,BratNode (Constructor true) [] [("value",Bool)]) +(check_defs_1_xs_$rhs_check'Con_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_xs_$rhs_check'Con_$!_pat2val_1,BratNode Id [("",[])] [("",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_$!_pat2val_1,BratNode Id [("",[])] [("",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_3_true_1,BratNode (Constructor true) [] [("value",Bool)]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_nil_1,BratNode (Constructor nil) [] [("value",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2,BratNode (Constructor cons) [("head",Bool),("tail",[])] [("value",[Bool])]) +(check_defs_1_xs_$rhs_check'Con_cons_2,BratNode (Constructor cons) [("head",Int),("tail",[Bool])] [("value",[Int,Bool])]) +(check_defs_1_xs_$rhs_check'Con_const_3,BratNode (Const 1) [] [("value",Int)]) (globals_Bool_4,BratNode (Constructor Bool) [] [("value",[])]) (globals_Int_2,BratNode (Constructor Int) [] [("value",[])]) (globals_cons_1,BratNode (Constructor cons) [("head",[]),("tail",[])] [("value",[])]) @@ -12,11 +16,11 @@ Nodes: (globals_nil_5,BratNode (Constructor nil) [] [("value",[])]) Wires: -(Ex check_defs_1_xs_cons 0,[Int,Bool],In globals_decl_6_xs 0) -(Ex check_defs_1_xs_cons_2 0,[Bool],In check_defs_1_xs_cons 1) -(Ex check_defs_1_xs_const_1 0,Int,In check_defs_1_xs_cons 0) -(Ex check_defs_1_xs_nil_4 0,[],In check_defs_1_xs_cons_2 1) -(Ex check_defs_1_xs_true_3 0,Bool,In check_defs_1_xs_cons_2 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_3_true_1 0,Bool,In check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_nil_1 0,[],In check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2 1) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2 0,[Bool],In check_defs_1_xs_$rhs_check'Con_cons_2 1) +(Ex check_defs_1_xs_$rhs_check'Con_cons_2 0,[Int,Bool],In globals_decl_6_xs 0) +(Ex check_defs_1_xs_$rhs_check'Con_const_3 0,Int,In check_defs_1_xs_$rhs_check'Con_cons_2 0) (Ex globals_Bool_4 0,[],In globals_cons_3 0) (Ex globals_Int_2 0,[],In globals_cons_1 0) (Ex globals_cons_1 0,[],In globals___kca_xs 0) diff --git a/brat/test/golden/graph/rx.brat.graph b/brat/test/golden/graph/rx.brat.graph index 14afc93b..e3ff04df 100644 --- a/brat/test/golden/graph/rx.brat.graph +++ b/brat/test/golden/graph/rx.brat.graph @@ -1,20 +1,20 @@ Nodes: -(check_defs_1_main_2_thunk_3_lambda_11,KernelNode (PatternMatch ((TestMatchData Kerny (MatchSequence {matchInputs = [(NamedPort {end = Ex check_defs_1_main_2_thunk_3_lambda.0_setup/in_3 0, portName = "a"},Qubit)], matchTests = [], matchOutputs = [(NamedPort {end = Ex check_defs_1_main_2_thunk_3_lambda.0_setup/in_3 0, portName = "a"},Qubit)]}),check_defs_1_main_2_thunk_3_lambda.0_rhs_thunk_9) :| [])) [("a",Qubit)] [("b",Qubit)]) -(check_defs_1_main_2_thunk_3_lambda.0_rhs_10_Splice,KernelNode (Splice (Ex globals_decl_18_xish 0)) [("rxa",Qubit)] [("rxb",Qubit)]) -(check_defs_1_main_2_thunk_3_lambda.0_rhs/in_7,KernelNode Source [] [("q",Qubit)]) -(check_defs_1_main_2_thunk_3_lambda.0_rhs/out_8,KernelNode Target [("b",Qubit)] []) -(check_defs_1_main_2_thunk_3_lambda.0_rhs_thunk_9,BratNode (Box (fromList []) check_defs_1_main_2_thunk_3_lambda.0_rhs/in_7 check_defs_1_main_2_thunk_3_lambda.0_rhs/out_8) [] [("thunk",{ (q :: Qubit) -o (b :: Qubit) })]) -(check_defs_1_main_2_thunk_3_lambda.0_setup/in_3,KernelNode Source [] [("a",Qubit)]) -(check_defs_1_main_2_thunk_3_lambda.0_setup/out_4,KernelNode Target [("b",Qubit)] []) -(check_defs_1_main_2_thunk_3_lambda.0_setup_thunk_5,BratNode (Box (fromList []) check_defs_1_main_2_thunk_3_lambda.0_setup/in_3 check_defs_1_main_2_thunk_3_lambda.0_setup/out_4) [] [("thunk",{ (a :: Qubit) -o (b :: Qubit) })]) -(check_defs_1_main_2_thunk/in,KernelNode Source [] [("a",Qubit)]) -(check_defs_1_main_2_thunk/out_1,KernelNode Target [("b",Qubit)] []) -(check_defs_1_main_2_thunk_thunk_2,BratNode (Box (fromList []) check_defs_1_main_2_thunk/in check_defs_1_main_2_thunk/out_1) [] [("thunk",{ (a :: Qubit) -o (b :: Qubit) })]) -(check_defs_1_nums_const,BratNode (Const 1) [] [("value",Int)]) -(check_defs_1_nums_const_1,BratNode (Const 2) [] [("value",Int)]) -(check_defs_1_nums_const_2,BratNode (Const 3) [] [("value",Int)]) -(check_defs_1_xish_1_Eval,BratNode (Eval (Ex globals_prim_7_Rx 0)) [("th",Float)] [("a1",{ (rxa :: Qubit) -o (rxb :: Qubit) })]) -(check_defs_1_xish_1_const_1,BratNode (Const 30.0) [] [("value",Float)]) +(check_defs_1_main_3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in,KernelNode Source [] [("a",Qubit)]) +(check_defs_1_main_3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/out_1,KernelNode Target [("b",Qubit)] []) +(check_defs_1_main_3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup_thunk_2,BratNode (Box check_defs_1_main_3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in check_defs_1_main_3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/out_1) [] [("thunk",{ (a :: Qubit) -o (b :: Qubit) })]) +(check_defs_1_main_3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_Splice,KernelNode (Splice (Ex globals_decl_18_xish 0)) [("rxa",Qubit)] [("rxb",Qubit)]) +(check_defs_1_main_3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/in_1,KernelNode Source [] [("q",Qubit)]) +(check_defs_1_main_3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/out_2,KernelNode Target [("b",Qubit)] []) +(check_defs_1_main_3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs_thunk_3,BratNode (Box check_defs_1_main_3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/in_1 check_defs_1_main_3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/out_2) [] [("thunk",{ (q :: Qubit) -o (b :: Qubit) })]) +(check_defs_1_main_3_$rhs_check'Th_LambdaChk_6_lambda,KernelNode (PatternMatch ((TestMatchData Kerny (MatchSequence {matchInputs = [(NamedPort {end = Ex check_defs_1_main_3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in 0, portName = "a"},Qubit)], matchTests = [], matchOutputs = [(NamedPort {end = Ex check_defs_1_main_3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in 0, portName = "a"},Qubit)]}),check_defs_1_main_3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs_thunk_3) :| [])) [("a",Qubit)] [("b",Qubit)]) +(check_defs_1_main_3_$rhs_check'Th_thunk/in,KernelNode Source [] [("a",Qubit)]) +(check_defs_1_main_3_$rhs_check'Th_thunk/out_1,KernelNode Target [("b",Qubit)] []) +(check_defs_1_main_3_$rhs_check'Th_thunk_thunk_2,BratNode (Box check_defs_1_main_3_$rhs_check'Th_thunk/in check_defs_1_main_3_$rhs_check'Th_thunk/out_1) [] [("thunk",{ (a :: Qubit) -o (b :: Qubit) })]) +(check_defs_1_nums_$rhs_const,BratNode (Const 1) [] [("value",Int)]) +(check_defs_1_nums_$rhs_const_1,BratNode (Const 2) [] [("value",Int)]) +(check_defs_1_nums_$rhs_const_2,BratNode (Const 3) [] [("value",Int)]) +(check_defs_1_xish_1_$rhs_Eval,BratNode (Eval (Ex globals_prim_7_Rx 0)) [("th",Float)] [("a1",{ (rxa :: Qubit) -o (rxb :: Qubit) })]) +(check_defs_1_xish_1_$rhs_const_1,BratNode (Const 30.0) [] [("value",Float)]) (globals_Float_2,BratNode (Constructor Float) [] [("value",[])]) (globals_Int_9,BratNode (Constructor Int) [] [("value",[])]) (globals_Int_10,BratNode (Constructor Int) [] [("value",[])]) @@ -31,16 +31,16 @@ Nodes: (globals_prim_7_Rx,BratNode (Prim ("","Rx")) [] [("thunk",{ (th :: Float) -> (a1 :: { (rxa :: Qubit) -o (rxb :: Qubit) }) })]) Wires: -(Ex check_defs_1_main_2_thunk/in 0,Qubit,In check_defs_1_main_2_thunk_3_lambda_11 0) -(Ex check_defs_1_main_2_thunk_3_lambda.0_rhs/in_7 0,Qubit,In check_defs_1_main_2_thunk_3_lambda.0_rhs_10_Splice 0) -(Ex check_defs_1_main_2_thunk_3_lambda.0_rhs_10_Splice 0,Qubit,In check_defs_1_main_2_thunk_3_lambda.0_rhs/out_8 0) -(Ex check_defs_1_main_2_thunk_3_lambda_11 0,Qubit,In check_defs_1_main_2_thunk/out_1 0) -(Ex check_defs_1_main_2_thunk_thunk_2 0,{ (a :: Qubit) -o (b :: Qubit) },In globals_decl_24_main 0) -(Ex check_defs_1_nums_const 0,Int,In globals_decl_12_nums 0) -(Ex check_defs_1_nums_const_1 0,Int,In globals_decl_12_nums 1) -(Ex check_defs_1_nums_const_2 0,Int,In globals_decl_12_nums 2) -(Ex check_defs_1_xish_1_Eval 0,{ (rxa :: Qubit) -o (rxb :: Qubit) },In globals_decl_18_xish 0) -(Ex check_defs_1_xish_1_const_1 0,Float,In check_defs_1_xish_1_Eval 0) +(Ex check_defs_1_main_3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_Splice 0,Qubit,In check_defs_1_main_3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/out_2 0) +(Ex check_defs_1_main_3_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/in_1 0,Qubit,In check_defs_1_main_3_$rhs_check'Th_LambdaChk_6_checkClauses_1_$rhs_4_Splice 0) +(Ex check_defs_1_main_3_$rhs_check'Th_LambdaChk_6_lambda 0,Qubit,In check_defs_1_main_3_$rhs_check'Th_thunk/out_1 0) +(Ex check_defs_1_main_3_$rhs_check'Th_thunk/in 0,Qubit,In check_defs_1_main_3_$rhs_check'Th_LambdaChk_6_lambda 0) +(Ex check_defs_1_main_3_$rhs_check'Th_thunk_thunk_2 0,{ (a :: Qubit) -o (b :: Qubit) },In globals_decl_24_main 0) +(Ex check_defs_1_nums_$rhs_const 0,Int,In globals_decl_12_nums 0) +(Ex check_defs_1_nums_$rhs_const_1 0,Int,In globals_decl_12_nums 1) +(Ex check_defs_1_nums_$rhs_const_2 0,Int,In globals_decl_12_nums 2) +(Ex check_defs_1_xish_1_$rhs_Eval 0,{ (rxa :: Qubit) -o (rxb :: Qubit) },In globals_decl_18_xish 0) +(Ex check_defs_1_xish_1_$rhs_const_1 0,Float,In check_defs_1_xish_1_$rhs_Eval 0) (Ex globals_Float_2 0,[],In globals___kcc_1 0) (Ex globals_Int_10 0,[],In globals___kca_nums_8 1) (Ex globals_Int_11 0,[],In globals___kca_nums_8 2) diff --git a/brat/test/golden/graph/swap.brat.graph b/brat/test/golden/graph/swap.brat.graph index 8372d6db..f0c3319e 100644 --- a/brat/test/golden/graph/swap.brat.graph +++ b/brat/test/golden/graph/swap.brat.graph @@ -1,14 +1,14 @@ Nodes: -(check_defs_1_main_thunk_3_lambda_10,KernelNode (PatternMatch ((TestMatchData Kerny (MatchSequence {matchInputs = [(NamedPort {end = Ex check_defs_1_main_thunk_3_lambda.0_setup/in_2 0, portName = "a"},Qubit),(NamedPort {end = Ex check_defs_1_main_thunk_3_lambda.0_setup/in_2 1, portName = "b"},Qubit)], matchTests = [], matchOutputs = [(NamedPort {end = Ex check_defs_1_main_thunk_3_lambda.0_setup/in_2 0, portName = "a"},Qubit),(NamedPort {end = Ex check_defs_1_main_thunk_3_lambda.0_setup/in_2 1, portName = "b"},Qubit)]}),check_defs_1_main_thunk_3_lambda.0_rhs_thunk_8) :| [])) [("a",Qubit),("b",Qubit)] [("b",Qubit),("a",Qubit)]) -(check_defs_1_main_thunk_3_lambda.0_rhs/in_6,KernelNode Source [] [("q0",Qubit),("q1",Qubit)]) -(check_defs_1_main_thunk_3_lambda.0_rhs/out_7,KernelNode Target [("b",Qubit),("a",Qubit)] []) -(check_defs_1_main_thunk_3_lambda.0_rhs_thunk_8,BratNode (Box (fromList []) check_defs_1_main_thunk_3_lambda.0_rhs/in_6 check_defs_1_main_thunk_3_lambda.0_rhs/out_7) [] [("thunk",{ (q0 :: Qubit), (q1 :: Qubit) -o (b :: Qubit), (a :: Qubit) })]) -(check_defs_1_main_thunk_3_lambda.0_setup/in_2,KernelNode Source [] [("a",Qubit),("b",Qubit)]) -(check_defs_1_main_thunk_3_lambda.0_setup/out_3,KernelNode Target [("b",Qubit),("a",Qubit)] []) -(check_defs_1_main_thunk_3_lambda.0_setup_thunk_4,BratNode (Box (fromList []) check_defs_1_main_thunk_3_lambda.0_setup/in_2 check_defs_1_main_thunk_3_lambda.0_setup/out_3) [] [("thunk",{ (a :: Qubit), (b :: Qubit) -o (b :: Qubit), (a :: Qubit) })]) -(check_defs_1_main_thunk/in,KernelNode Source [] [("a",Qubit),("b",Qubit)]) -(check_defs_1_main_thunk/out_1,KernelNode Target [("b",Qubit),("a",Qubit)] []) -(check_defs_1_main_thunk_thunk_2,BratNode (Box (fromList []) check_defs_1_main_thunk/in check_defs_1_main_thunk/out_1) [] [("thunk",{ (a :: Qubit), (b :: Qubit) -o (b :: Qubit), (a :: Qubit) })]) +(check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in,KernelNode Source [] [("a",Qubit),("b",Qubit)]) +(check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/out_1,KernelNode Target [("b",Qubit),("a",Qubit)] []) +(check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup_thunk_2,BratNode (Box check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/out_1) [] [("thunk",{ (a :: Qubit), (b :: Qubit) -o (b :: Qubit), (a :: Qubit) })]) +(check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/in_1,KernelNode Source [] [("q0",Qubit),("q1",Qubit)]) +(check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/out_2,KernelNode Target [("b",Qubit),("a",Qubit)] []) +(check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs_thunk_3,BratNode (Box check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/in_1 check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/out_2) [] [("thunk",{ (q0 :: Qubit), (q1 :: Qubit) -o (b :: Qubit), (a :: Qubit) })]) +(check_defs_1_main_$rhs_check'Th_LambdaChk_6_lambda,KernelNode (PatternMatch ((TestMatchData Kerny (MatchSequence {matchInputs = [(NamedPort {end = Ex check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in 0, portName = "a"},Qubit),(NamedPort {end = Ex check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in 1, portName = "b"},Qubit)], matchTests = [], matchOutputs = [(NamedPort {end = Ex check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in 0, portName = "a"},Qubit),(NamedPort {end = Ex check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_$lhs_lambda.0_setup/in 1, portName = "b"},Qubit)]}),check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs_thunk_3) :| [])) [("a",Qubit),("b",Qubit)] [("b",Qubit),("a",Qubit)]) +(check_defs_1_main_$rhs_check'Th_thunk/in,KernelNode Source [] [("a",Qubit),("b",Qubit)]) +(check_defs_1_main_$rhs_check'Th_thunk/out_1,KernelNode Target [("b",Qubit),("a",Qubit)] []) +(check_defs_1_main_$rhs_check'Th_thunk_thunk_2,BratNode (Box check_defs_1_main_$rhs_check'Th_thunk/in check_defs_1_main_$rhs_check'Th_thunk/out_1) [] [("thunk",{ (a :: Qubit), (b :: Qubit) -o (b :: Qubit), (a :: Qubit) })]) (globals_Qubit_2,BratNode (Constructor Qubit) [] [("value",[])]) (globals_Qubit_3,BratNode (Constructor Qubit) [] [("value",[])]) (globals_Qubit_5,BratNode (Constructor Qubit) [] [("value",[])]) @@ -16,13 +16,13 @@ Nodes: (globals_decl_7_main,BratNode Id [("a1",{ (a :: Qubit), (b :: Qubit) -o (b :: Qubit), (a :: Qubit) })] [("a1",{ (a :: Qubit), (b :: Qubit) -o (b :: Qubit), (a :: Qubit) })]) Wires: -(Ex check_defs_1_main_thunk/in 0,Qubit,In check_defs_1_main_thunk_3_lambda_10 0) -(Ex check_defs_1_main_thunk/in 1,Qubit,In check_defs_1_main_thunk_3_lambda_10 1) -(Ex check_defs_1_main_thunk_3_lambda.0_rhs/in_6 0,Qubit,In check_defs_1_main_thunk_3_lambda.0_rhs/out_7 1) -(Ex check_defs_1_main_thunk_3_lambda.0_rhs/in_6 1,Qubit,In check_defs_1_main_thunk_3_lambda.0_rhs/out_7 0) -(Ex check_defs_1_main_thunk_3_lambda_10 0,Qubit,In check_defs_1_main_thunk/out_1 0) -(Ex check_defs_1_main_thunk_3_lambda_10 1,Qubit,In check_defs_1_main_thunk/out_1 1) -(Ex check_defs_1_main_thunk_thunk_2 0,{ (a :: Qubit), (b :: Qubit) -o (b :: Qubit), (a :: Qubit) },In globals_decl_7_main 0) +(Ex check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/in_1 0,Qubit,In check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/out_2 1) +(Ex check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/in_1 1,Qubit,In check_defs_1_main_$rhs_check'Th_LambdaChk_6_checkClauses_1_lambda.0_rhs/out_2 0) +(Ex check_defs_1_main_$rhs_check'Th_LambdaChk_6_lambda 0,Qubit,In check_defs_1_main_$rhs_check'Th_thunk/out_1 0) +(Ex check_defs_1_main_$rhs_check'Th_LambdaChk_6_lambda 1,Qubit,In check_defs_1_main_$rhs_check'Th_thunk/out_1 1) +(Ex check_defs_1_main_$rhs_check'Th_thunk/in 0,Qubit,In check_defs_1_main_$rhs_check'Th_LambdaChk_6_lambda 0) +(Ex check_defs_1_main_$rhs_check'Th_thunk/in 1,Qubit,In check_defs_1_main_$rhs_check'Th_LambdaChk_6_lambda 1) +(Ex check_defs_1_main_$rhs_check'Th_thunk_thunk_2 0,{ (a :: Qubit), (b :: Qubit) -o (b :: Qubit), (a :: Qubit) },In globals_decl_7_main 0) (Ex globals_Qubit_2 0,[],In globals___kcr__1 0) (Ex globals_Qubit_3 0,[],In globals___kcr__1 1) (Ex globals_Qubit_5 0,[],In globals___kcr__4 0) diff --git a/brat/test/golden/graph/two.brat.graph b/brat/test/golden/graph/two.brat.graph index cdb6a0c8..1ae2fcc4 100644 --- a/brat/test/golden/graph/two.brat.graph +++ b/brat/test/golden/graph/two.brat.graph @@ -1,7 +1,7 @@ Nodes: -(check_defs_1_one_const,BratNode (Const 1) [] [("value",Int)]) -(check_defs_1_two_1_Eval,BratNode (Eval (Ex globals_prim_5_add 0)) [("a",Int),("b",Int)] [("c",Int)]) -(check_defs_1_two_1_const_1,BratNode (Const 1) [] [("value",Int)]) +(check_defs_1_one_$rhs_const,BratNode (Const 1) [] [("value",Int)]) +(check_defs_1_two_1_$rhs_Eval,BratNode (Eval (Ex globals_prim_5_add 0)) [("a",Int),("b",Int)] [("c",Int)]) +(check_defs_1_two_1_$rhs_const_1,BratNode (Const 1) [] [("value",Int)]) (globals_Int_2,BratNode (Constructor Int) [] [("value",[])]) (globals_Int_3,BratNode (Constructor Int) [] [("value",[])]) (globals_Int_4,BratNode (Constructor Int) [] [("value",[])]) @@ -12,12 +12,12 @@ Nodes: (globals_prim_5_add,BratNode (Prim ("","add")) [] [("thunk",{ (a :: Int), (b :: Int) -> (c :: Int) })]) Wires: -(Ex check_defs_1_one_const 0,Int,In globals_decl_8_one 0) -(Ex check_defs_1_two_1_Eval 0,Int,In globals_decl_11_two 0) -(Ex check_defs_1_two_1_const_1 0,Int,In check_defs_1_two_1_Eval 0) +(Ex check_defs_1_one_$rhs_const 0,Int,In globals_decl_8_one 0) +(Ex check_defs_1_two_1_$rhs_Eval 0,Int,In globals_decl_11_two 0) +(Ex check_defs_1_two_1_$rhs_const_1 0,Int,In check_defs_1_two_1_$rhs_Eval 0) (Ex globals_Int_10 0,[],In globals___kca_two_9 0) (Ex globals_Int_2 0,[],In globals___kcc_1 0) (Ex globals_Int_3 0,[],In globals___kcc_1 1) (Ex globals_Int_4 0,[],In globals___kcc_1 2) (Ex globals_Int_7 0,[],In globals___kca_one_6 0) -(Ex globals_decl_8_one 0,Int,In check_defs_1_two_1_Eval 1) +(Ex globals_decl_8_one 0,Int,In check_defs_1_two_1_$rhs_Eval 1) diff --git a/brat/test/golden/graph/vec.brat.graph b/brat/test/golden/graph/vec.brat.graph index 844bd6c8..63d51b0b 100644 --- a/brat/test/golden/graph/vec.brat.graph +++ b/brat/test/golden/graph/vec.brat.graph @@ -1,24 +1,45 @@ Nodes: -(check_defs_1_xs_cons,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 2))] [("value",Vec(Int, 3))]) -(check_defs_1_xs_cons_2,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 1))] [("value",Vec(Int, 2))]) -(check_defs_1_xs_cons_4,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 0))] [("value",Vec(Int, 1))]) -(check_defs_1_xs_const_1,BratNode (Const 0) [] [("value",Int)]) -(check_defs_1_xs_const_3,BratNode (Const 1) [] [("value",Int)]) -(check_defs_1_xs_const_5,BratNode (Const 2) [] [("value",Int)]) -(check_defs_1_xs_nil_6,BratNode (Constructor nil) [] [("value",Vec(Int, 0))]) +(check_defs_1_xs_$rhs_check'Con_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) +(check_defs_1_xs_$rhs_check'Con_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_$!_numpat2val_1,BratNode Id [("",Nat)] [("",Nat)]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_check'Con_4_$!_pat2val,BratNode Id [("",[])] [("",[])]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_check'Con_4_nil_2,BratNode (Constructor nil) [] [("value",Vec(Int, 0))]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_cons_2,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 0))] [("value",Vec(Int, 1))]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_const_3,BratNode (Const 2) [] [("value",Int)]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_typeEqsTail_1_buildConst_1,BratNode (Const 0) [] [("value",Nat)]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 1))] [("value",Vec(Int, 2))]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_const_3,BratNode (Const 1) [] [("value",Int)]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_typeEqsTail_1_$!_1_Add_1,BratNode (ArithNode Add) [("lhs",Nat),("rhs",Nat)] [("value",Nat)]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_typeEqsTail_1_$!_1_buildConst,BratNode (Const 1) [] [("value",Nat)]) +(check_defs_1_xs_$rhs_check'Con_check'Con_4_typeEqsTail_1_$!_1_buildConst_2,BratNode (Const 0) [] [("value",Nat)]) +(check_defs_1_xs_$rhs_check'Con_cons_2,BratNode (Constructor cons) [("head",Int),("tail",Vec(Int, 2))] [("value",Vec(Int, 3))]) +(check_defs_1_xs_$rhs_check'Con_const_3,BratNode (Const 0) [] [("value",Int)]) +(check_defs_1_xs_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1,BratNode (ArithNode Add) [("lhs",Nat),("rhs",Nat)] [("value",Nat)]) +(check_defs_1_xs_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst,BratNode (Const 2) [] [("value",Nat)]) +(check_defs_1_xs_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst_2,BratNode (Const 0) [] [("value",Nat)]) (globals_Int_2,BratNode (Constructor Int) [] [("value",[])]) (globals_Vec_1,BratNode (Constructor Vec) [("X",[]),("n",Nat)] [("value",[])]) (globals_const_3,BratNode (Const 3) [] [("value",Nat)]) (globals_decl_4_xs,BratNode Id [("a1",Vec(Int, 3))] [("a1",Vec(Int, 3))]) Wires: -(Ex check_defs_1_xs_cons 0,Vec(Int, 3),In globals_decl_4_xs 0) -(Ex check_defs_1_xs_cons_2 0,Vec(Int, 2),In check_defs_1_xs_cons 1) -(Ex check_defs_1_xs_cons_4 0,Vec(Int, 1),In check_defs_1_xs_cons_2 1) -(Ex check_defs_1_xs_const_1 0,Int,In check_defs_1_xs_cons 0) -(Ex check_defs_1_xs_const_3 0,Int,In check_defs_1_xs_cons_2 0) -(Ex check_defs_1_xs_const_5 0,Int,In check_defs_1_xs_cons_4 0) -(Ex check_defs_1_xs_nil_6 0,Vec(Int, 0),In check_defs_1_xs_cons_4 1) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_check'Con_4_nil_2 0,Vec(Int, 0),In check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_cons_2 1) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_cons_2 0,Vec(Int, 1),In check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2 1) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_const_3 0,Int,In check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_cons_2 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_typeEqsTail_1_buildConst_1 0,Nat,In check_defs_1_xs_$rhs_check'Con_check'Con_4_check'Con_4_$!_numpat2val_1 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2 0,Vec(Int, 2),In check_defs_1_xs_$rhs_check'Con_cons_2 1) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_const_3 0,Int,In check_defs_1_xs_$rhs_check'Con_check'Con_4_cons_2 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_typeEqsTail_1_$!_1_Add_1 0,Nat,In check_defs_1_xs_$rhs_check'Con_check'Con_4_$!_numpat2val_1 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_typeEqsTail_1_$!_1_buildConst 0,Nat,In check_defs_1_xs_$rhs_check'Con_check'Con_4_typeEqsTail_1_$!_1_Add_1 0) +(Ex check_defs_1_xs_$rhs_check'Con_check'Con_4_typeEqsTail_1_$!_1_buildConst_2 0,Nat,In check_defs_1_xs_$rhs_check'Con_check'Con_4_typeEqsTail_1_$!_1_Add_1 1) +(Ex check_defs_1_xs_$rhs_check'Con_cons_2 0,Vec(Int, 3),In globals_decl_4_xs 0) +(Ex check_defs_1_xs_$rhs_check'Con_const_3 0,Int,In check_defs_1_xs_$rhs_check'Con_cons_2 0) +(Ex check_defs_1_xs_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1 0,Nat,In check_defs_1_xs_$rhs_check'Con_$!_numpat2val_1 0) +(Ex check_defs_1_xs_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst 0,Nat,In check_defs_1_xs_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1 0) +(Ex check_defs_1_xs_$rhs_check'Con_typeEqsTail_1_$!_1_buildConst_2 0,Nat,In check_defs_1_xs_$rhs_check'Con_typeEqsTail_1_$!_1_Add_1 1) (Ex globals_Int_2 0,[],In globals_Vec_1 0) (Ex globals_Vec_1 0,[],In globals___kca_xs 0) (Ex globals_const_3 0,Nat,In globals_Vec_1 1) diff --git a/brat/tools/validate.sh b/brat/tools/validate.sh index d2d90975..2a4342a0 100755 --- a/brat/tools/validate.sh +++ b/brat/tools/validate.sh @@ -12,7 +12,7 @@ declare -a FAILED_TEST_MSGS UNEXPECTED_PASSES= NUM_FAILURES=0 -for json in test/compilation/output/*.json; do +for json in $(find test/compilation/output -maxdepth 1 -name "*.json"); do echo Validating "$json" RESULT=$(cat "$json" | hugr_validator 2>&1) if [ $? -ne 0 ]; then @@ -22,7 +22,7 @@ for json in test/compilation/output/*.json; do fi done -for invalid_json in test/compilation/output/*.json.invalid; do +for invalid_json in $(find test/compilation/output -maxdepth 1 -name "*.json.invalid"); do if (hugr_validator < $invalid_json 2>/dev/null > /dev/null); then UNEXPECTED_PASSES="$UNEXPECTED_PASSES $invalid_json" fi @@ -51,4 +51,4 @@ if [ "$UNEXPECTED_PASSES" != "" ]; then echo -e $RED "There were unexpected passes: $UNEXPECTED_PASSES" $NO_COLOUR RESULT=1 fi -exit $RESULT \ No newline at end of file +exit $RESULT diff --git a/hugr_extension/src/defs.rs b/hugr_extension/src/defs.rs index e1b8bf7d..f1683a70 100644 --- a/hugr_extension/src/defs.rs +++ b/hugr_extension/src/defs.rs @@ -9,10 +9,11 @@ use hugr::{ ExtensionId, OpDef, SignatureError, SignatureFromArgs, SignatureFunc, }, ops::NamedOp, + std_extensions::arithmetic::int_types::INT_TYPES, std_extensions::collections::list_type, types::{ - type_param::TypeParam, FuncValueType, PolyFuncTypeRV, Type, TypeArg, TypeBound, TypeEnum, - TypeRV, + type_param::TypeParam, FuncValueType, PolyFuncTypeRV, Signature, Type, + TypeArg, TypeBound, TypeEnum, TypeRV, }, }; @@ -23,6 +24,10 @@ use strum::ParseError; use crate::ctor::Ctor; +lazy_static! { + static ref U64: Type = INT_TYPES[6].clone(); +} + /// Brat extension operation definitions. #[derive(Clone, Debug, PartialEq, Eq, Sequence)] #[allow(missing_docs)] @@ -35,6 +40,7 @@ pub enum BratOpDef { Panic, Ctor(BratCtor), PrimCtorTest(BratCtor), + Lluf, Replicate, } @@ -50,6 +56,7 @@ impl NamedOp for BratOpDef { Panic => "Panic".into(), Ctor(ctor) => format_smolstr!("Ctor::{}", ctor.name()), PrimCtorTest(ctor) => format_smolstr!("PrimCtorTest::{}", ctor.name()), + Lluf => "Lluf".into(), Replicate => "Replicate".into(), } } @@ -69,6 +76,7 @@ impl FromStr for BratOpDef { ["Panic"] => Ok(BratOpDef::Panic), ["Ctor", ctor] => Ok(BratOpDef::Ctor(BratCtor::from_str(ctor)?)), ["PrimCtorTest", ctor] => Ok(BratOpDef::PrimCtorTest(BratCtor::from_str(ctor)?)), + ["Lluf"] => Ok(BratOpDef::Lluf), ["Replicate"] => Ok(BratOpDef::Replicate), _ => Err(ParseError::VariantNotFound), } @@ -132,6 +140,7 @@ impl MakeOpDef for BratOpDef { ) .into() } + Lluf => Signature::new(vec![U64.clone()], vec![U64.clone()]).into(), Replicate => PolyFuncTypeRV::new( [TypeParam::Type { b: TypeBound::Copyable, diff --git a/hugr_extension/src/ops.rs b/hugr_extension/src/ops.rs index d35b935e..ee1159dc 100644 --- a/hugr_extension/src/ops.rs +++ b/hugr_extension/src/ops.rs @@ -43,6 +43,8 @@ pub enum BratOp { ctor: BratCtor, args: Vec, }, + // The inverse operation of "full" on Nats + Lluf, Replicate(TypeArg), } @@ -58,6 +60,7 @@ impl NamedOp for BratOp { Panic { .. } => "Panic".into(), Ctor { ctor, .. } => format_smolstr!("Ctor::{}", ctor.name()), PrimCtorTest { ctor, .. } => format_smolstr!("PrimCtorTest::{}", ctor.name()), + Lluf => "Lluf".into(), Replicate(_) => "Replicate".into(), } } @@ -137,6 +140,7 @@ impl MakeExtensionOp for BratOp { ctor, args: ext_op.args().to_vec(), }), + BratOpDef::Lluf => Ok(BratOp::Lluf), BratOpDef::Replicate => Ok(BratOp::Replicate(ext_op.args()[0].clone())), } } @@ -175,6 +179,7 @@ impl MakeExtensionOp for BratOp { } BratOp::Ctor { args, .. } => args.clone(), BratOp::PrimCtorTest { args, .. } => args.clone(), + BratOp::Lluf => vec![], BratOp::Replicate(arg) => vec![arg.clone()], } }