polysemy-methodology (empty) → 0.1.0.0
raw patch · 5 files changed
+279/−0 lines, 5 filesdep +basedep +polysemydep +polysemy-plugin
Dependencies added: base, polysemy, polysemy-plugin, polysemy-zoo
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- README.md +27/−0
- polysemy-methodology.cabal +38/−0
- src/Polysemy/Methodology.hs +179/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for polysemy-methodology++## v0.1.0.0++* Set of domain modelling tools for polysemy.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Daniel Firth (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,27 @@+# polysemy-methodology++polysemy-methodology provides an algebra for domain modelling in polysemy.++A simple program might look something like this:++```+prog :: Members '[ Input a+ , Methodology a b+ , Output b]+prog = input @a >>= process @a @b >>= output @b+```++That is, this program transforms an `Input a` into an `Output b` by way of a+`Methodology a b` that turns `a` into `b`. We can then type apply `a` and `b`+and connect this to `main`.++If we have a solution readily available, we can consume a `Methodology` by+running one of the interpreters `runMethodologyPure` or `runMethodologySem`.++Otherwise, we can use the other interpreters in this package to break the+problem down into components or branches and solve each section separately.+Each interpreter will produce a new set of `Methodology`s to be solved.++This allows you to work up a solution to a domain problem backwards, by running+the program you intend to solve directly and using holes to guide the+requirements.
+ polysemy-methodology.cabal view
@@ -0,0 +1,38 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.2.+--+-- see: https://github.com/sol/hpack++name: polysemy-methodology+version: 0.1.0.0+synopsis: Domain modelling algebra for polysemy+category: Polysemy+author: Daniel Firth+maintainer: dan.firth@homotopic.tech+copyright: 2020 Daniel Firth+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://gitlab.com/homotopic-tech/polysemy-methodology++library+ exposed-modules:+ Polysemy.Methodology+ other-modules:+ Paths_polysemy_methodology+ hs-source-dirs:+ src+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+ build-depends:+ base >=4.7 && <5+ , polysemy+ , polysemy-plugin+ , polysemy-zoo+ default-language: Haskell2010
+ src/Polysemy/Methodology.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}+module Polysemy.Methodology where++import Polysemy+import Polysemy.KVStore+import Polysemy.Input+import Polysemy.Output+import Polysemy.Several++-- | A `Methodology` generalises a semantic process from `b` to `c`.+data Methodology b c m a where+ Process :: b -> Methodology b c m c++makeSem ''Methodology++-- | Run a `Methodology` using a pure function.+runMethodologyPure :: forall b c r a. (b -> c) -> Sem (Methodology b c ': r) a -> Sem r a +runMethodologyPure f = interpret \case+ Process b -> return $ f b++-- | Run a `Methodology' using a monadic function with effects in `r`.+runMethodologySem :: forall b c r a. (b -> Sem r c) -> Sem (Methodology b c ': r) a -> Sem r a+runMethodologySem f = interpret \case+ Process b -> f b++-- | Cut a `Methodology` into two pieces at a midpoint.+cutMethodology :: forall b c d r a.+ Members '[ Methodology b c+ , Methodology c d] r+ => Sem (Methodology b d ': r) a+ -> Sem r a+cutMethodology = interpret \case+ Process b -> process @b @c b >>= process @c @d++-- | Cut a `Methodology` into three pieces using two cuts.+cutMethodology3 :: forall b c d e r a.+ Members '[ Methodology b c+ , Methodology c d+ , Methodology d e] r+ => Sem (Methodology b e ': r) a+ -> Sem r a+cutMethodology3 = interpret \case+ Process b -> process @b @c b >>= process @c @d >>= process @d @e++-- | Divide a `Methodology` into two components using a `Methodology` that accepts a pair.`+divideMethodology :: forall b c c' d r a.+ Members '[ Methodology b c+ , Methodology b c'+ , Methodology (c, c') d] r+ => Sem (Methodology b d ': r) a+ -> Sem r a+divideMethodology = interpret \case+ Process b -> do+ c <- process @b @c b+ c' <- process @b @c' b+ process @(c, c') @d (c, c')++-- | Decide between two `Methodology`s using a `Methodology` that computes an `Either`.+decideMethodology :: forall b c c' d r a.+ Members '[ Methodology b (Either c c')+ , Methodology c d+ , Methodology c' d+ ] r+ => Sem (Methodology b d ': r) a+ -> Sem r a+decideMethodology = interpret \case+ Process b -> do+ k <- process @b @(Either c c') b+ case k of+ Left c -> process @c @d c+ Right c' -> process @c' @d c'++-- | Tee the output of a `Methodology`, introducing a new `Output` effect to be handled.+teeMethodologyOutput :: forall b c r a.+ Members '[Output c, Methodology b c] r+ => Sem r a+ -> Sem r a+teeMethodologyOutput = intercept \case+ Process b -> do+ k <- process @b @c b+ output @c k+ return k++-- | Make a `Methodology` depend on an additional input, introducing a new `Input` effect to be handled.+plugMethodologyInput :: forall b c d r a.+ Members '[Input b, Methodology (b, c) d] r+ => Sem (Methodology c d ': r) a+ -> Sem r a+plugMethodologyInput = interpret \case+ Process b -> do+ k <- input @b+ process @(b, c) @d (k, b)++-- | Run a `Methodology` as a `KVStore`, using the input as a key and the output as the value.+runMethodologyAsKVStore :: forall k v r a.+ Members '[KVStore k v] r+ => Sem (Methodology k (Maybe v) ': r) a+ -> Sem r a+runMethodologyAsKVStore = interpret \case+ Process k -> lookupKV k++-- | Run a `Methodology` as a `KVStore`, with a default value for lookup failure.+runMethodologyAsKVStoreWithDefault :: forall k v r a.+ Members '[KVStore k v] r+ => v+ -> Sem (Methodology k v ': r) a+ -> Sem r a+runMethodologyAsKVStoreWithDefault d = interpret \case+ Process k -> do+ z <- lookupKV k+ case z of + Just a -> return a+ Nothing -> return d++-- | Decompose a `Methodology` into several components to be recombined. This is `cutMethodology` specialised to `HList`.+decomposeMethodology :: forall b f c r a.+ Members ' [Methodology b (HList f)+ , Methodology (HList f) c] r+ => Sem (Methodology b c ': r) a+ -> Sem r a+decomposeMethodology = cutMethodology @b @(HList f) @c++-- | Decompose a `Methodology` into several components over three sections with two cuts.+decomposeMethodology3 :: forall b f g c r a.+ Members '[ Methodology b (HList f)+ , Methodology (HList f) (HList g)+ , Methodology (HList g) c] r+ => Sem (Methodology b c ': r) a+ -> Sem r a+decomposeMethodology3 = cutMethodology3 @b @(HList f) @(HList g) @c++-- | Factor a `Methodology` decomposed over an `HList` in the result by a `Methodology` to the first variable.+separateMethodologyInitial :: forall b x xs r a.+ Members '[ Methodology b (HList xs)+ , Methodology b x] r+ => Sem (Methodology b (HList (x ': xs)) ': r) a+ -> Sem r a+separateMethodologyInitial = interpret \case+ Process b -> do+ k <- process @b @x b+ k' <- process @b @(HList xs) b+ return $ k ::: k'++-- | Finish an `HList` separated `Methodology` by consuming it for no effect.+endMethodologyInitial :: Sem (Methodology b (HList '[]) ': r) a+ -> Sem r a+endMethodologyInitial = interpret \case+ Process _ -> return HNil++-- | Factor a `Methodology` decomposed over an `HList` in the source by a `Methodology` from the first variable. Assumes the result is a `Monoid`.+separateMethodologyTerminal :: forall x xs c r a.+ (Monoid c,+ Members '[ Methodology (HList xs) c+ , Methodology x c] r)+ => Sem (Methodology (HList (x ': xs)) c ': r) a+ -> Sem r a+separateMethodologyTerminal = interpret \case+ Process (b ::: bs) -> do+ k <- process @x @c b+ k' <- process @(HList xs) @c bs+ return $ k <> k'++-- | Finalise an `HList` separated `Methodology` in the source by returning the `Monoid` unit.+endMethodologyTerminal :: Monoid c+ => Sem (Methodology (HList (x ': xs)) c ': r) a+ -> Sem r a+endMethodologyTerminal = interpret \case+ Process _ -> return mempty