Inital commit - v0.1.0.0

.gitignore

+.stack-work/
+*~
\ No newline at end of file

ChangeLog.md

+# Changelog for polysemy-methodology
+
+## v0.1.0.0
+
+* Set of domain modelling tools for polysemy.

LICENSE

+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

+# 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.

package.yaml

+name:                polysemy-methodology
+version:             0.1.0.0
+license:             MIT
+git:                 https://gitlab.com/homotopic-tech/polysemy-methodology
+author:              "Daniel Firth"
+maintainer:          "dan.firth@homotopic.tech"
+copyright:           "2020 Daniel Firth"
+
+extra-source-files:
+- README.md
+- ChangeLog.md
+
+synopsis:            Domain modelling algebra for polysemy
+category:            Polysemy
+
+dependencies:
+- base >= 4.7 && < 5
+- polysemy
+- polysemy-plugin
+- polysemy-zoo
+
+library:
+  source-dirs: src

polysemy-methodology.cabal

+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
+
+library
+  exposed-modules:
+      Polysemy.Methodology
+  other-modules:
+      Paths_polysemy_methodology
+  hs-source-dirs:
+      src
+  build-depends:
+      base >=4.7 && <5
+    , polysemy
+    , polysemy-plugin
+    , polysemy-zoo
+  default-language: Haskell2010

src/Polysemy/Methodology.hs

+{-# 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

stack.yaml

+resolver: nightly-2020-10-28
+packages:
+- .
+extra-deps:
+- compact-0.2.0.0
+- polysemy-plugin-0.2.5.1
+- polysemy-zoo-0.7.0.1
+- ghc-tcplugins-extra-0.3.2

stack.yaml.lock

+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages:
+- completed:
+    hackage: compact-0.2.0.0@sha256:9c5785bdc178ea6cf8f514ad35a78c64220e3cdb22216534e4cf496765551c7e,2345
+    pantry-tree:
+      size: 546
+      sha256: 6f7da573fbcddc109e1521edc07f1b34d7506473a3930074453e829daf901d71
+  original:
+    hackage: compact-0.2.0.0
+- completed:
+    hackage: polysemy-plugin-0.2.5.1@sha256:61c6c0aad2852377aa5d5a8f9639a437905e3a6f0e2a99a41e96fb231dc86836,2952
+    pantry-tree:
+      size: 1232
+      sha256: 9720d9a1675c7ac3e2635b8c9f002f7ab0764eb60738a3405603cb33bdffc493
+  original:
+    hackage: polysemy-plugin-0.2.5.1
+- completed:
+    hackage: polysemy-zoo-0.7.0.1@sha256:60c2921df95f61d43222a75adde4f330e9510320b416132838a354cd81b4bcc5,3846
+    pantry-tree:
+      size: 2979
+      sha256: af39e295a7831e6bca01fa78df6c538cb6f1dfb339d118056fd0d9c314925726
+  original:
+    hackage: polysemy-zoo-0.7.0.1
+- completed:
+    hackage: ghc-tcplugins-extra-0.3.2@sha256:1bbfd4449c3669a31618ea0ebc5d00d980a53988daad3b6218bab5c8cdff268d,1687
+    pantry-tree:
+      size: 331
+      sha256: 4b16989344380c912e476dc232cc58264837b498e31a8bf16a17092ba6c1cfb9
+  original:
+    hackage: ghc-tcplugins-extra-0.3.2
+snapshots:
+- completed:
+    size: 543560
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/10/28.yaml
+    sha256: e6926f04392e58a8ac3745cfa05b48392f38934a0dbec4dcf408e201f9584560
+  original: nightly-2020-10-28