From 48f71b55b424d8602975c065039f263b30f07a53 Mon Sep 17 00:00:00 2001 From: Roly Perera Date: Mon, 2 Oct 2023 17:26:07 +0200 Subject: [PATCH] =?UTF-8?q?=F0=9F=A7=A9=20[unconsolidate]:=20Newtype=20gun?= =?UTF-8?q?k=20for=20ProgCxt.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/App/Fig.purs | 12 ++++++------ src/EvalGraph.purs | 12 ++++++------ src/Graph/Slice.purs | 3 +-- src/Module.purs | 16 ++++++++-------- src/Val.purs | 5 ++++- test/Many.purs | 6 +++--- test/Util.purs | 6 +++--- 7 files changed, 31 insertions(+), 29 deletions(-) diff --git a/src/App/Fig.purs b/src/App/Fig.purs index a5c3104f3..e475b4787 100644 --- a/src/App/Fig.purs +++ b/src/App/Fig.purs @@ -39,7 +39,7 @@ import SExpr (Expr(..), Module(..), RecDefs, VarDefs) as S import SExpr (desugarModuleFwd) import Trace (Trace) import Util (MayFail, type (×), type (+), (×), absurd, error, orElse, successful) -import Val (class Ann, Env, Val(..), append_inv, (<+>)) +import Val (class Ann, Env, ProgCxt(..), Val(..), append_inv, (<+>)) import Web.Event.EventTarget (eventListener) data View @@ -193,10 +193,10 @@ linkResult x γ0 γ e1 e2 t1 _ v1 = do loadFig :: forall m. MonadAff m => MonadError Error m => FigSpec -> m Fig loadFig spec@{ file } = do -- TODO: not every example should run with this dataset. - { progCxt } × xv :: GraphConfig GraphImpl × _ <- + { progCxt: ProgCxt { γ } } × xv :: GraphConfig GraphImpl × _ <- openDefaultImports >>= openDatasetAs (File "example/linking/renewables") "data" let - γ0 = botOf <$> progCxt.γ + γ0 = botOf <$> γ xv0 = botOf <$> xv s' <- open file let s0 = botOf s' @@ -211,12 +211,12 @@ loadLinkFig spec@{ file1, file2, dataFile, x } = do let dir = File "linking/" name1 × name2 = (dir <> file1) × (dir <> file2) - -- the views share an ambient environment γ0 as well as dataset - { progCxt } × xv :: GraphConfig GraphImpl × _ <- + -- views share an ambient environment γ0 as well as dataset + { progCxt: ProgCxt { γ } } × xv :: GraphConfig GraphImpl × _ <- openDefaultImports >>= openDatasetAs (File "example/" <> dir <> dataFile) x s1' × s2' <- (×) <$> open name1 <*> open name2 let - γ0 = botOf <$> progCxt.γ + γ0 = botOf <$> γ xv0 = botOf <$> xv s1 = botOf s1' s2 = botOf s2' diff --git a/src/EvalGraph.purs b/src/EvalGraph.purs index 54f004ec2..b39ec3913 100644 --- a/src/EvalGraph.purs +++ b/src/EvalGraph.purs @@ -34,13 +34,13 @@ import Pretty (prettyP) import Primitive (string, intPair) import Util (type (×), check, error, orElse, successful, throw, with, (×)) import Util.Pair (unzip) as P -import Val (DictRep(..), Env, ForeignOp'(..), MatrixRep(..), ProgramCxt, Val, for, lookup', restrict, (<+>)) +import Val (DictRep(..), Env, ForeignOp'(..), MatrixRep(..), ProgCxt(..), Val, for, lookup', restrict, (<+>)) import Val (Val(..), Fun(..)) as V type GraphConfig g = { g :: g , n :: Int - , progCxt :: ProgramCxt Vertex + , progCxt :: ProgCxt Vertex } {-# Matching #-} @@ -188,15 +188,15 @@ graphGC => GraphConfig g -> Raw Expr -> m (GraphEval g) -graphGC { g, n, progCxt } e = do +graphGC { g, n, progCxt: ProgCxt { γ } } e = do (g' × _) × eα × vα <- runWithGraphAllocT (g × n) do eα <- alloc e - vα <- eval progCxt.γ eα S.empty + vα <- eval γ eα S.empty pure (eα × vα) let - dom = vertices eα `union` foldMap vertices progCxt.γ + dom = vertices eα `union` foldMap vertices γ fwd αs = vertices (fwdSlice αs g') `intersection` vertices vα bwd αs = vertices (bwdSlice αs g') `intersection` sinks g' trace (show (S.size $ sinks g' `S.difference` dom) <> " sinks not in inputs.") \_ -> - pure { gc: GC { fwd, bwd }, γα: progCxt.γ, eα, g: g', vα } + pure { gc: GC { fwd, bwd }, γα: γ, eα, g: g', vα } diff --git a/src/Graph/Slice.purs b/src/Graph/Slice.purs index f349d576c..0ed959026 100644 --- a/src/Graph/Slice.purs +++ b/src/Graph/Slice.purs @@ -3,13 +3,12 @@ module Graph.Slice where import Prelude hiding (add) import Control.Monad.Rec.Class (Step(..), tailRecM) -import Data.Foldable (class Foldable) import Data.List (List(..), (:)) import Data.List as L import Data.Map (Map) import Data.Map (insert, empty, lookup, delete) as M import Data.Maybe (maybe) -import Data.Set (Set, empty, insert, member, singleton, unions, difference) +import Data.Set (Set, empty, insert, singleton, difference) import Data.Tuple (fst) import Graph (class Graph, Edge, Vertex, inEdges, inEdges', outN, sinks, op) import Graph.GraphWriter (WithGraph, extend, runWithGraph) diff --git a/src/Module.purs b/src/Module.purs index 87610e83f..27ea5e37a 100644 --- a/src/Module.purs +++ b/src/Module.purs @@ -29,7 +29,7 @@ import SExpr (Expr) as S import SExpr (desugarModuleFwd) import Util (type (×), mapLeft, (×)) import Util.Parse (SParser) -import Val (Env, ProgramCxt, (<+>)) +import Val (Env, ProgCxt(..), (<+>)) -- Mainly serve as documentation newtype File = File String @@ -58,17 +58,17 @@ parseProgram folder file = open :: forall m. MonadAff m => MonadError Error m => File -> m (S.Expr Unit) open = parseProgram (Folder "fluid/example") -loadModule :: forall m. MonadAff m => MonadGraphAlloc m => File -> ProgramCxt Vertex -> m (ProgramCxt Vertex) -loadModule file { mods, γ } = do +loadModule :: forall m. MonadAff m => MonadGraphAlloc m => File -> ProgCxt Vertex -> m (ProgCxt Vertex) +loadModule file (ProgCxt { mods, γ }) = do src <- loadFile (Folder "fluid/lib") file mod <- parse src module_ >>= desugarModuleFwd >>= traverseModule (const fresh) γ' <- eval_module γ mod empty - pure $ { mods: mod : mods, γ: γ <+> γ' } + pure $ ProgCxt { mods: mod : mods, γ: γ <+> γ' } -defaultImports :: forall m. MonadAff m => MonadGraphAlloc m => m (ProgramCxt Vertex) +defaultImports :: forall m. MonadAff m => MonadGraphAlloc m => m (ProgCxt Vertex) defaultImports = do γ <- traverse alloc primitives - loadModule (File "prelude") { mods: Nil, γ } + loadModule (File "prelude") (ProgCxt { mods: Nil, γ }) >>= loadModule (File "graphics") >>= loadModule (File "convolution") @@ -79,11 +79,11 @@ openDefaultImports = do -- | Evaluate dataset in context of existing graph config openDatasetAs :: forall m g. MonadAff m => MonadError Error m => Graph g => File -> Var -> GraphConfig g -> m (GraphConfig g × Env Vertex) -openDatasetAs file x { g, n, progCxt } = do +openDatasetAs file x { g, n, progCxt: progCxt@(ProgCxt { γ }) } = do s <- parseProgram (Folder "fluid") file (g' × n') × xv <- runWithGraphAllocT (g × n) do e <- desug s eα <- alloc e - D.singleton x <$> eval progCxt.γ eα empty + D.singleton x <$> eval γ eα empty pure ({ g: g', n: n', progCxt } × xv) diff --git a/src/Val.purs b/src/Val.purs index 27349337a..a300c88ee 100644 --- a/src/Val.purs +++ b/src/Val.purs @@ -11,6 +11,7 @@ import Data.Bitraversable (bitraverse) import Data.Exists (Exists) import Data.Foldable (class Foldable, foldl, foldrDefault, foldMapDefaultL) import Data.List (List(..), (:), zipWith) +import Data.Newtype (class Newtype) import Data.Set (Set, empty, fromFoldable, intersection, member, singleton, toUnfoldable, union) import Data.Traversable (class Traversable, sequenceDefault, traverse) import DataType (Ctr) @@ -72,7 +73,9 @@ lookup' :: forall a m. MonadThrow Error m => Var -> Dict a -> m a lookup' x γ = lookup x γ # orElse ("variable " <> x <> " not found") -- Bunch of loaded modules. -type ProgramCxt a = { mods :: List (Module a), γ :: Env a } +newtype ProgCxt a = ProgCxt { mods :: List (Module a), γ :: Env a } + +derive instance Newtype (ProgCxt a) _ -- Want a monoid instance but needs a newtype append :: forall a. Env a -> Endo (Env a) diff --git a/test/Many.purs b/test/Many.purs index f6a1b042f..290348ed0 100644 --- a/test/Many.purs +++ b/test/Many.purs @@ -10,7 +10,7 @@ import Effect.Aff (Aff) import Module (File(..), Folder(..), loadFile, open, openDatasetAs, openDefaultImports) import Test.Util (TestBwdSpec, TestLinkSpec, TestSpec, TestWithDatasetSpec, averageRows, checkPretty, testWithSetup) import Util (type (×), (×), successful) -import Val ((<+>)) +import Val (ProgCxt(..), (<+>)) many :: Array TestSpec -> Int -> Array (String × Aff BenchRow) many specs iter = zip (specs <#> _.file) (specs <#> one) @@ -39,10 +39,10 @@ withDatasetMany specs iter = zip (specs <#> _.file) (specs <#> withDatasetOne) where withDatasetOne { dataset, file } = do -- TODO: make progCxt consistent with addition of xv - gconfig@{ progCxt: { γ } } × xv <- openDefaultImports >>= openDatasetAs (File dataset) "data" + gconfig@{ progCxt: ProgCxt r@{ γ } } × xv <- openDefaultImports >>= openDatasetAs (File dataset) "data" expr <- open (File file) rows <- replicateM iter $ - testWithSetup file expr gconfig { progCxt { γ = γ <+> xv } } + testWithSetup file expr gconfig { progCxt = ProgCxt r{ γ = γ <+> xv } } { δv: identity, fwd_expect: mempty, bwd_expect: mempty } pure $ averageRows rows diff --git a/test/Util.purs b/test/Util.purs index cec4a6f0c..68f9726f0 100644 --- a/test/Util.purs +++ b/test/Util.purs @@ -33,7 +33,7 @@ import Pretty (class Pretty, prettyP) import SExpr (Expr) as SE import Test.Spec.Assertions (fail) import Util (MayFailT, successful, (×)) -import Val (Val(..), class Ann) +import Val (class Ann, ProgCxt(..), Val(..)) type TestConfig = { δv :: Selector Val @@ -65,7 +65,7 @@ testParse s = do lift $ fail "not equal" testTrace :: Raw SE.Expr -> GraphConfig GraphImpl -> TestConfig -> MayFailT Aff TraceRow -testTrace s { progCxt } { δv, bwd_expect, fwd_expect } = do +testTrace s { progCxt: ProgCxt { γ } } { δv, bwd_expect, fwd_expect } = do -- | Desugaring Galois connections for Unit and Boolean type selections GC desug <- desugGC s GC desug𝔹 <- desugGC s @@ -73,7 +73,7 @@ testTrace s { progCxt } { δv, bwd_expect, fwd_expect } = do -- | Eval let e = desug.fwd s t_eval1 <- preciseTime - { gc: GC eval, v } <- traceGC (erase <$> progCxt.γ) e + { gc: GC eval, v } <- traceGC (erase <$> γ) e t_eval2 <- preciseTime -- | Backward