git.iko.soy/semi-iso-optics
on master help sign in
swap
de16c6d37 ahead, 0 behind
.github/workflows/haskell.ymlnew file+22
since splitsnapshots
unifiedsplit
@@ -0,0 +1,22 @@
1+name: Haskell CI
2+
3+on: [pull_request]
4+
5+jobs:
6+ build:
7+
8+ runs-on: ubuntu-latest
9+
10+ steps:
11+ - uses: actions/checkout@v1
12+ - name: Install Stack
13+ run: |
14+ wget -qO- https://get.haskellstack.org/ | sh
15+
16+ - name: Build
17+ run: |
18+ stack build --fast --pedantic --ghc-options '-j'
19+
20+ - name: Weeder
21+ run: |
22+ curl -sSL https://raw.github.com/ndmitchell/weeder/master/misc/run.sh | sh -s . --build
.gitignore+15−38
@@ -1,47 +1,24 @@
1−# Created by https://www.gitignore.io
2−
3−### Haskell ###
4dist
1dist
2+dist-*
5cabal-dev
3cabal-dev
6*.o
4*.o
7*.hi
5*.hi
6+*.hie
8*.chi
7*.chi
9*.chs.h
8*.chs.h
10−.virtualenv
9+*.dyn_o
10+*.dyn_hi
11+.hpc
11.hsenv
12.hsenv
12.cabal-sandbox/
13.cabal-sandbox/
13cabal.sandbox.config
14cabal.sandbox.config
14−cabal.config
15+*.prof
15−
16+*.aux
16−
17+*.hp
17−### Emacs ###
18+*.eventlog
18−# -*- mode: gitignore; -*-
19+.stack-work/
19−*~
20+cabal.project.local
20−\#*\#
21+cabal.project.local~
21−/.emacs.desktop
22+.HTF/
22−/.emacs.desktop.lock
23+.ghc.environment.*
23−*.elc
24+*.cabal
24−auto-save-list
25−tramp
26−.\#*
27−
28−# Org-mode
29−.org-id-locations
30−*_archive
31−
32−# flymake-mode
33−*_flymake.*
34−
35−# eshell files
36−/eshell/history
37−/eshell/lastdir
38−
39−# elpa packages
40−/elpa/
41−
42−# reftex files
43−*.rel
44−
45−# AUCTeX auto folder
46−/auto/
47−
.travis.ymlnew file+132
@@ -0,0 +1,132 @@
1+# This Travis job script has been generated by a script via
2+#
3+# runghc make_travis_yml_2.hs 'semi-iso.cabal'
4+#
5+# For more information, see https://github.com/haskell-CI/haskell-ci
6+#
7+language: c
8+sudo: false
9+
10+git:
11+ submodules: false # whether to recursively clone submodules
12+
13+cache:
14+ directories:
15+ - $HOME/.cabal/packages
16+ - $HOME/.cabal/store
17+
18+before_cache:
19+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
20+ # remove files that are regenerated by 'cabal update'
21+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*
22+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json
23+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache
24+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar
25+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx
26+
27+ - rm -rfv $HOME/.cabal/packages/head.hackage
28+
29+matrix:
30+ include:
31+ - compiler: "ghc-8.6.1"
32+ env: GHCHEAD=true
33+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.6.1], sources: [hvr-ghc]}}
34+ - compiler: "ghc-8.4.3"
35+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
36+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}
37+ - compiler: "ghc-8.2.2"
38+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
39+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.2.2], sources: [hvr-ghc]}}
40+ - compiler: "ghc-8.0.2"
41+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
42+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.0.2], sources: [hvr-ghc]}}
43+
44+ allow_failures:
45+ - compiler: "ghc-8.6.1"
46+
47+before_install:
48+ - HC=${CC}
49+ - HCPKG=${HC/ghc/ghc-pkg}
50+ - unset CC
51+ - ROOTDIR=$(pwd)
52+ - mkdir -p $HOME/.local/bin
53+ - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"
54+ - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))
55+ - echo $HCNUMVER
56+
57+install:
58+ - cabal --version
59+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
60+ - BENCH=${BENCH---enable-benchmarks}
61+ - TEST=${TEST---enable-tests}
62+ - HADDOCK=${HADDOCK-true}
63+ - UNCONSTRAINED=${UNCONSTRAINED-true}
64+ - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}
65+ - GHCHEAD=${GHCHEAD-false}
66+ - travis_retry cabal update -v
67+ - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"
68+ - rm -fv cabal.project cabal.project.local
69+ # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage
70+ - |
71+ if $GHCHEAD; then
72+ sed -i 's/-- allow-newer: .*/allow-newer: *:base/' ${HOME}/.cabal/config
73+ for pkg in $($HCPKG list --simple-output); do pkg=$(echo $pkg | sed 's/-[^-]*$//'); sed -i "s/allow-newer: /allow-newer: *:$pkg, /" ${HOME}/.cabal/config; done
74+
75+ echo 'repository head.hackage' >> ${HOME}/.cabal/config
76+ echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config
77+ echo ' secure: True' >> ${HOME}/.cabal/config
78+ echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config
79+ echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config
80+ echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config
81+ echo ' key-threshold: 3' >> ${HOME}/.cabal.config
82+
83+ grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'
84+
85+ cabal new-update head.hackage -v
86+ fi
87+ - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'
88+ - "printf 'packages: \".\"\\n' > cabal.project"
89+ - touch cabal.project.local
90+ - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- semi-iso | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"
91+ - cat cabal.project || true
92+ - cat cabal.project.local || true
93+ - if [ -f "./configure.ac" ]; then
94+ (cd "." && autoreconf -i);
95+ fi
96+ - rm -f cabal.project.freeze
97+ - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all
98+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all
99+ - rm -rf .ghc.environment.* "."/dist
100+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
101+
102+# Here starts the actual work to be performed for the package under test;
103+# any command which exits with a non-zero exit code causes the build to fail.
104+script:
105+ # test that source-distributions can be generated
106+ - (cd "." && cabal sdist)
107+ - mv "."/dist/semi-iso-*.tar.gz ${DISTDIR}/
108+ - cd ${DISTDIR} || false
109+ - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
110+ - "printf 'packages: semi-iso-*/*.cabal\\n' > cabal.project"
111+ - touch cabal.project.local
112+ - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- semi-iso | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"
113+ - cat cabal.project || true
114+ - cat cabal.project.local || true
115+ # this builds all libraries and executables (without tests/benchmarks)
116+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
117+
118+ # build & run tests, build benchmarks
119+ - cabal new-build -w ${HC} ${TEST} ${BENCH} all
120+
121+ # cabal check
122+ - (cd semi-iso-* && cabal check)
123+
124+ # haddock
125+ - rm -rf ./dist-newstyle
126+ - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi
127+
128+ # Build without installed constraints for packages in global-db
129+ - if $UNCONSTRAINED; then rm -f cabal.project.local; echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks all; else echo "Not building without installed constraints"; fi
130+
131+# REGENDATA ["semi-iso.cabal"]
132+# EOF
Data/SemiIsoFunctor.hsdeleted−171
@@ -1,171 +0,0 @@
1−{-# LANGUAGE TypeFamilies #-}
2−{-# LANGUAGE PatternSynonyms #-}
3−{- |
4−Module : Data.SemiIsoFunctor
5−Description : Functors from the category of semi-isomoprihsms to Hask.
6−Copyright : (c) Paweł Nowak
7−License : MIT
8−
9−Maintainer : Paweł Nowak <pawel834@gmail.com>
10−Stability : experimental
11−
12−Defines a functor from the category of semi-isomoprihsms to Hask.
13−
14−The most interesting property of that class is that it can be
15−instantiated by both covariant (like Parser) and contravariant (like Printer)
16−functors. Therefore it can be used as a common interface to unify
17−parsing and pretty printing.
18−-}
19−module Data.SemiIsoFunctor where
20−
21−import Control.Lens.Cons
22−import Control.Lens.Empty
23−import Control.Lens.SemiIso
24−import Data.Tuple.Morph
25−
26−infixl 3 /|/
27−infixl 4 /$/, ~$/, /$~, ~$~
28−infixl 5 /*/, /*, */
29−infixl 1 //=
30−infixr 1 =//
31−
32−-- | A functor from the category of semi-isomorphisms to Hask.
33−--
34−-- It is both covariant and contravariant in its single arugment.
35−--
36−-- The contravariant map is used by default to provide compatibility with
37−-- Prisms (otherwise you would have to reverse them in most cases).
38−--
39−-- Instances should satisfy laws:
40−--
41−-- > simap id = id
42−-- > simap (f . g) = simap g . simap f
43−-- > simap = simapCo . fromSemi
44−-- > simapCo = simap . fromSemi
45−class SemiIsoFunctor f where
46− -- | The contravariant map.
47− simap :: ASemiIso' a b -> f b -> f a
48− simap = simapCo . rev
49−
50− -- | The covariant map.
51− simapCo :: ASemiIso' a b -> f a -> f b
52− simapCo = simap . rev
53−
54− {-# MINIMAL simap | simapCo #-}
55−
56−-- | A infix operator for 'simap'.
57−(/$/) :: SemiIsoFunctor f => ASemiIso' a b -> f b -> f a
58−(/$/) = simap
59−
60−-- | > ai /$~ f = ai . morphed /$/ f
61−--
62−-- This operator handles all the hairy stuff with uncurried application:
63−-- it reassociates the argument tuple and removes unnecessary (or adds necessary)
64−-- units to match the function type. You don't have to use @/*@ and @*/@ with this
65−-- operator.
66−(/$~) :: (SemiIsoFunctor f, HFoldable b', HFoldable b,
67− HUnfoldable b', HUnfoldable b, Rep b' ~ Rep b)
68− => ASemiIso' a b' -> f b -> f a
69−-- TODO GHC 7.10: haddock doesn't work with pattern synynonyms yet
70−-- (SemiIso f g) /$~ h = semiIso f g . morphed /$/ h
71−ai /$~ h = withSemiIso ai $ \f g -> semiIso f g . morphed /$/ h
72−
73−-- | > ai ~$/ f = morphed . ai /$/ f
74−(~$/) :: (SemiIsoFunctor f, HFoldable a', HFoldable a,
75− HUnfoldable a', HUnfoldable a, Rep a' ~ Rep a)
76− => ASemiIso' a' b -> f b -> f a
77−-- TODO GHC 7.10: haddock doesn't work with pattern synynonyms yet
78−--(SemiIso f g) ~$/ h = morphed . semiIso f g /$/ h
79−ai ~$/ h = withSemiIso ai $ \f g -> morphed . semiIso f g /$/ h
80−
81−-- | > ai ~$~ f = morphed . ai . morphed /$/ f
82−(~$~) :: (SemiIsoFunctor f,
83− HFoldable a, HUnfoldable a,
84− HFoldable b, HUnfoldable b,
85− HFoldable b', HUnfoldable b',
86− Rep b' ~ Rep b, Rep b' ~ Rep a)
87− => ASemiIso b' b' b' b' -> f b -> f a
88−-- TODO GHC 7.10: haddock doesn't work with pattern synynonyms yet
89−--(SemiIso f g) ~$~ h = morphed . semiIso f g . morphed /$/ h
90−ai ~$~ h = withSemiIso ai $ \f g -> morphed . semiIso f g . morphed /$/ h
91−
92−-- | Equivalent of 'Applicative' for 'SemiIsoFunctor'.
93−--
94−-- However, this class implements uncurried application, unlike
95−-- 'Control.Applicative' which gives you curried application.
96−--
97−-- Instances should satisfy laws:
98−--
99−-- > TODO (they should be fine)
100−class SemiIsoFunctor f => SemiIsoApply f where
101− siunit :: f ()
102− siunit = sipure id
103−
104− sipure :: ASemiIso' a () -> f a
105− sipure ai = ai /$/ siunit
106−
107− sipureCo :: ASemiIso' () a -> f a
108− sipureCo ai = ai `simapCo` siunit
109−
110− (/*/) :: f a -> f b -> f (a, b)
111−
112− (/*) :: f a -> f () -> f a
113− f /* g = unit /$/ f /*/ g
114−
115− (*/) :: f () -> f b -> f b
116− f */ g = unit . swapped /$/ f /*/ g
117−
118− {-# MINIMAL (siunit | sipure), (/*/) #-}
119−
120−-- | Equivalent of 'Alternative' for 'SemiIsoFunctor'.
121−--
122−-- @f a@ should form a monoid with identity 'siempty' and binary
123−-- operation '/|/'.
124−class SemiIsoApply f => SemiIsoAlternative f where
125− siempty :: f a
126− (/|/) :: f a -> f a -> f a
127−
128− sisome :: f a -> f [a]
129− sisome v = _Cons /$/ v /*/ simany v
130−
131− simany :: f a -> f [a]
132− simany v = sisome v /|/ sipure _Empty
133−
134− {-# MINIMAL siempty, (/|/) #-}
135−
136−-- | An analogue of 'Monad' for 'SemiIsoFunctor'.
137−--
138−-- Because of the 'no throwing away' rule bind has to \"return\"
139−-- both @a@ and @b@.
140−class SemiIsoApply m => SemiIsoMonad m where
141− (//=) :: m a -> (a -> m b) -> m (a, b)
142− m //= f = swapped /$/ (f =// m)
143−
144− (=//) :: (b -> m a) -> m b -> m (a, b)
145− f =// m = swapped /$/ (m //= f)
146−
147− {-# MINIMAL (//=) | (=//) #-}
148−
149−-- | A SemiIsoMonad with fixed point operator.
150−class SemiIsoMonad m => SemiIsoFix m where
151− sifix :: (a -> m a) -> m a
152− sifix f = dup /$/ (f =//= f)
153− where dup = semiIso (\a -> Right (a, a)) (Right . fst)
154−
155− -- | Fixed point combined with bind, it's so symmetric!
156− (=//=) :: (a -> m b) -> (b -> m a) -> m (a, b)
157− f =//= g = sifix (\(a, b) -> g b /*/ f a)
158−
159− {-# MINIMAL sifix | (=//=) #-}
160−
161−-- | Equivalent of 'sequence'.
162−--
163−-- Note that it is not possible to write sequence_, because
164−-- you cannot void a SemiIsoFunctor.
165−sisequence :: SemiIsoApply f => [f a] -> f [a]
166−sisequence [] = sipure _Empty
167−sisequence (x:xs) = _Cons /$/ x /*/ sisequence xs
168−
169−-- | Equivalent of 'replicateM'.
170−sireplicate :: SemiIsoApply f => Int -> f a -> f [a]
171−sireplicate n f = sisequence (replicate n f)
LICENSE+1
@@ -1,4 +1,5 @@
1Copyright (c) 2014 Paweł Nowak
1Copyright (c) 2014 Paweł Nowak
2+Copyright (c) 2019 Ilya Kostyuchenko
2
3
3Permission is hereby granted, free of charge, to any person obtaining
4Permission is hereby granted, free of charge, to any person obtaining
4a copy of this software and associated documentation files (the
5a copy of this software and associated documentation files (the
package.yamlnew file+44
@@ -0,0 +1,44 @@
1+name: semi-iso
2+version: 0.1.0.0
3+github: "ilyakooo0/semi-iso-optics"
4+license: MIT
5+author: "Ilya Kostyuchenko"
6+maintainer: "ilyakooo0@gmail.com"
7+copyright: "2019 Ilya Kostyuchenko, 2014 Paweł Nowak"
8+
9+extra-source-files: []
10+
11+# Metadata used when publishing your package
12+# synopsis: Short description of your package
13+# category: Web
14+
15+# To avoid duplicated efforts in documentation and dealing with the
16+# complications of embedding Haddock markup inside cabal files, it is
17+# common to point users to the README.md file.
18+description: Please see the README on GitHub at <https://github.com/ilyakooo0/semi-iso-optics#readme>
19+
20+dependencies:
21+- base >= 4.7 && < 5
22+- profunctors
23+- lens
24+
25+library:
26+ source-dirs: src
27+ exposed-modules:
28+ - Control.Lens.SemiIso
29+ - Control.Lens.Internal.SemiIso
30+ - Control.SIArrow
31+ - Control.Category.Reader
32+ - Control.Category.Structures
33+ - Data.Profunctor.Exposed
34+ - Control.Tuple.Morph
35+ ghc-options:
36+ - -Wall
37+ - -Wincomplete-uni-patterns
38+ - -Wincomplete-record-updates
39+ - -Wpartial-fields
40+ - -Werror=missing-home-modules
41+ - -Wmissing-home-modules
42+ - -Widentities
43+ - -Wredundant-constraints
44+ - -Wmissing-export-lists
semi-iso.cabaldeleted−29
@@ -1,29 +0,0 @@
1−name: semi-iso
2−version: 0.4.0.0
3−synopsis: Weakened partial isomorphisms that work with lenses.
4−description: Semi-isomorphisms are partial isomorphisms with weakened iso laws.
5− And they work with Iso and Prism from @lens@!
6− .
7− See first "Control.Lens.SemiIso" for semi-isomoprhisms.
8− After that look at "Data.SemiIsoFunctor".
9−license: MIT
10−license-file: LICENSE
11−author: Paweł Nowak
12−maintainer: Paweł Nowak <pawel834@gmail.com>
13−copyright: Paweł Nowak 2014
14−category: Control, Data
15−build-type: Simple
16−cabal-version: >=1.10
17−
18−source-repository head
19− type: git
20− location: git@github.com:Pawel834/semi-iso.git
21−
22−library
23− exposed-modules: Control.Lens.SemiIso
24− Control.Lens.Internal.SemiIso
25− Data.SemiIsoFunctor
26− Data.Profunctor.Exposed
27− build-depends: base >= 4 && < 5, profunctors, transformers, lens, tuple-morph
28− default-language: Haskell2010
29− ghc-options: -Wall
src/Control/Category/Reader.hsnew file+51
@@ -0,0 +1,51 @@
1+{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{- |
4+Module : Control.Category.Reader
5+Description : Reader category transformer.
6+Copyright : (c) Paweł Nowak
7+License : MIT
8+
9+Maintainer : Paweł Nowak <pawel834@gmail.com>
10+Stability : experimental
11+
12+Provides a Reader category transformer.
13+-}
14+module Control.Category.Reader (
15+ ReaderCT(..)
16+ ) where
17+
18+import Control.Arrow
19+import Control.Category
20+import Control.Category.Structures
21+import Control.Lens.Iso
22+import Control.Lens.SemiIso
23+import Control.SIArrow
24+import Prelude hiding (id, (.))
25+
26+newtype ReaderCT env cat a b = ReaderCT { runReaderCT :: env -> cat a b }
27+
28+instance CatTrans (ReaderCT env) where
29+ clift = ReaderCT . const
30+
31+instance Category cat => Category (ReaderCT env cat) where
32+ id = clift id
33+ ReaderCT f . ReaderCT g = ReaderCT $ \x -> f x . g x
34+
35+instance Arrow cat => Arrow (ReaderCT env cat) where
36+ arr f = ReaderCT $ \_ -> arr f
37+ ReaderCT f *** ReaderCT g = ReaderCT $ \x -> f x *** g x
38+
39+instance ArrowChoice cat => ArrowChoice (ReaderCT env cat) where
40+ ReaderCT f +++ ReaderCT g = ReaderCT $ \x -> f x +++ g x
41+
42+instance ArrowZero cat => ArrowZero (ReaderCT env cat) where
43+ zeroArrow = clift zeroArrow
44+
45+instance ArrowPlus cat => ArrowPlus (ReaderCT env cat) where
46+ ReaderCT f <+> ReaderCT g = ReaderCT $ \x -> f x <+> g x
47+
48+instance SIArrow cat => SIArrow (ReaderCT env cat) where
49+ siarr = clift . siarr
50+ sibind ai = ReaderCT $ \env -> sibind
51+ (iso id (flip runReaderCT env) . cloneSemiIso ai . iso (flip runReaderCT env) id)
src/Control/Category/Structures.hsnew file+31
@@ -0,0 +1,31 @@
1+{-# LANGUAGE TypeFamilies #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE ConstraintKinds #-}
4+{- |
5+Module : Control.Category.Structures
6+Description : Structures in a category.
7+Copyright : (c) Paweł Nowak
8+License : MIT
9+
10+Maintainer : Paweł Nowak <pawel834@gmail.com>
11+Stability : experimental
12+
13+This module defines some basic structures in a category in a more fine-grained
14+way then "Control.Arrow".
15+
16+Unfortunately names in this module clash with "Control.Arrow".
17+-}
18+module Control.Category.Structures
19+ ( CatTrans(..)
20+ ) where
21+
22+import Control.Category
23+import Prelude hiding (id, (.))
24+
25+
26+-- | A category transformer.
27+class CatTrans t where
28+ -- | Lift an arrow from the base category.
29+ clift :: Category cat => cat a b -> t cat a b
30+
31+ {-# MINIMAL clift #-}
Control/Lens/Internal/SemiIso.hs → src/Control/Lens/Internal/SemiIso.hsrenamed+5−3
@@ -9,7 +9,9 @@ License : MIT
9Maintainer : Paweł Nowak <pawel834@gmail.com>
9Maintainer : Paweł Nowak <pawel834@gmail.com>
10Stability : experimental
10Stability : experimental
11-}
11-}
12−module Control.Lens.Internal.SemiIso where
12+module Control.Lens.Internal.SemiIso
13+ ( Retail(..)
14+ ) where
13
15
14import Control.Monad
16import Control.Monad
15import Data.Profunctor
17import Data.Profunctor
@@ -25,9 +27,9 @@ instance Profunctor (Retail s t) where
25 rmap f (Retail l r) = Retail l (fmap f . r)
27 rmap f (Retail l r) = Retail l (fmap f . r)
26
28
27instance Choice (Retail s t) where
29instance Choice (Retail s t) where
28− left' (Retail as st) = Retail
30+ left' (Retail as st) = Retail
29 (either as (\_ -> Left "semi-iso failed")) (fmap Left . st)
31 (either as (\_ -> Left "semi-iso failed")) (fmap Left . st)
30− right' (Retail as st) = Retail
32+ right' (Retail as st) = Retail
31 (either (\_ -> Left "semi-iso failed") as) (fmap Right . st)
33 (either (\_ -> Left "semi-iso failed") as) (fmap Right . st)
32
34
33-- Proof of 'Exposed' laws:
35-- Proof of 'Exposed' laws:
Control/Lens/SemiIso.hs → src/Control/Lens/SemiIso.hsrenamed+131−35
@@ -4,6 +4,8 @@
4{-# LANGUAGE ViewPatterns #-}
4{-# LANGUAGE ViewPatterns #-}
5{-# LANGUAGE PatternSynonyms #-}
5{-# LANGUAGE PatternSynonyms #-}
6{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleContexts #-}
7+
8+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
7{- |
9{- |
8Module : Control.Lens.SemiIso
10Module : Control.Lens.SemiIso
9Description : Semi-isomorphisms.
11Description : Semi-isomorphisms.
@@ -33,7 +35,7 @@ Our semi-isomorphisms will obey weakened laws:
33
35
34When you see an "Either String a", the String is usually an error message.
36When you see an "Either String a", the String is usually an error message.
35
37
36−Disclaimer: the name "semi-isomorphism" is fictitious and made up for this library.
38+Disclaimer: the name "semi-isomorphism" is fictitious and made up for this library.
37Any resemblance to known mathematical objects of the same name is purely coincidental.
39Any resemblance to known mathematical objects of the same name is purely coincidental.
38-}
40-}
39module Control.Lens.SemiIso (
41module Control.Lens.SemiIso (
@@ -48,6 +50,11 @@ module Control.Lens.SemiIso (
48
50
49 -- * Constructing semi-isos.
51 -- * Constructing semi-isos.
50 semiIso,
52 semiIso,
53+ cloneSemiIso,
54+
55+ -- * Reified semi-isos.
56+ ReifiedSemiIso'(..),
57+ reifySemiIso,
51
58
52 -- * Consuming semi-isos.
59 -- * Consuming semi-isos.
53 apply,
60 apply,
@@ -60,12 +67,14 @@ module Control.Lens.SemiIso (
60 swapped,
67 swapped,
61 associated,
68 associated,
62 morphed,
69 morphed,
70+ reorderMorphed,
63 constant,
71 constant,
64 exact,
72 exact,
73+ bifiltered,
74+ alwaysFailing,
65
75
66 -- * Semi-isos for numbers.
76 -- * Semi-isos for numbers.
67 _Negative,
77 _Negative,
68− _Positive,
69
78
70 -- * Transforming semi-isos.
79 -- * Transforming semi-isos.
71 rev,
80 rev,
@@ -92,24 +101,26 @@ module Control.Lens.SemiIso (
92 ) where
101 ) where
93
102
94import Control.Arrow
103import Control.Arrow
104+import Control.Category
95import Control.Lens.Internal.SemiIso
105import Control.Lens.Internal.SemiIso
96import Control.Lens.Iso
106import Control.Lens.Iso
107+import Control.Tuple.Morph
97import Data.Foldable
108import Data.Foldable
98import Data.Functor.Identity
109import Data.Functor.Identity
99import Data.Profunctor.Exposed
110import Data.Profunctor.Exposed
100import Data.Traversable
111import Data.Traversable
101−import Data.Tuple.Morph
112+import Prelude hiding (id, (.))
102
113
103-- | A semi-isomorphism is a partial isomorphism with weakened laws.
114-- | A semi-isomorphism is a partial isomorphism with weakened laws.
104−--
115+--
105-- Should satisfy laws:
116-- Should satisfy laws:
106−--
117+--
107-- > apply i >=> unapply i >=> apply i = apply i
118-- > apply i >=> unapply i >=> apply i = apply i
108-- > unapply i >=> apply i >=> unapply i = unapply i
119-- > unapply i >=> apply i >=> unapply i = unapply i
109--
120--
110-- Every 'Prism' is a 'SemiIso'.
121-- Every 'Prism' is a 'SemiIso'.
111-- Every 'Iso' is a 'Prism'.
122-- Every 'Iso' is a 'Prism'.
112−type SemiIso s t a b = forall p f. (Exposed (Either String) p, Traversable f)
123+type SemiIso s t a b = forall p f. (Exposed (Either String) p, Traversable f)
113 => p a (f b) -> p s (f t)
124 => p a (f b) -> p s (f t)
114
125
115-- | Non-polymorphic variant of 'SemiIso'.
126-- | Non-polymorphic variant of 'SemiIso'.
@@ -123,12 +134,70 @@ type ASemiIso' s a = ASemiIso s s a a
123
134
124-- | A nice pattern synonym for SemiIso's. Gives you the two functions, just like
135-- | A nice pattern synonym for SemiIso's. Gives you the two functions, just like
125-- 'viewSemiIso' or 'fromSemiIso'.
136-- 'viewSemiIso' or 'fromSemiIso'.
137+pattern SemiIso
138+ :: (s -> Either String a)
139+ -> (b -> Either String t)
140+ -> ASemiIso s t a b
126pattern SemiIso sa bt <- (viewSemiIso -> (sa, bt))
141pattern SemiIso sa bt <- (viewSemiIso -> (sa, bt))
127
142
143+-- | A semi-iso stored in a container.
144+newtype ReifiedSemiIso' s a = ReifiedSemiIso' { runSemiIso :: SemiIso' s a }
145+
146+instance Category ReifiedSemiIso' where
147+ id = ReifiedSemiIso' id
148+ ReifiedSemiIso' f . ReifiedSemiIso' g = ReifiedSemiIso' (g . f)
149+
150+instance Arrow ReifiedSemiIso' where
151+ arr f = ReifiedSemiIso' $ semiIso (Right . f) (const $ Left "oh no")
152+ -- TODO: pattern synonyms dont work here for some reason
153+ first (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
154+ ReifiedSemiIso' $ cloneSemiIso $
155+ semiIso (runKleisli $ first $ Kleisli f)
156+ (runKleisli $ first $ Kleisli g)
157+
158+ second (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
159+ ReifiedSemiIso' $ cloneSemiIso $
160+ semiIso (runKleisli $ second $ Kleisli f)
161+ (runKleisli $ second $ Kleisli g)
162+
163+ ReifiedSemiIso' ai *** ReifiedSemiIso' ai' = ReifiedSemiIso' $
164+ withSemiIso ai $ \f g -> withSemiIso ai' $ \f' g' ->
165+ semiIso (runKleisli $ Kleisli f *** Kleisli f')
166+ (runKleisli $ Kleisli g *** Kleisli g')
167+
168+instance ArrowChoice ReifiedSemiIso' where
169+ left (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
170+ ReifiedSemiIso' $ cloneSemiIso $
171+ semiIso (runKleisli $ left $ Kleisli f)
172+ (runKleisli $ left $ Kleisli g)
173+
174+ right (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
175+ ReifiedSemiIso' $ cloneSemiIso $
176+ semiIso (runKleisli $ right $ Kleisli f)
177+ (runKleisli $ right $ Kleisli g)
178+
179+ ReifiedSemiIso' ai +++ ReifiedSemiIso' ai' = ReifiedSemiIso' $
180+ withSemiIso ai $ \f g -> withSemiIso ai' $ \f' g' ->
181+ semiIso (runKleisli $ Kleisli f +++ Kleisli f')
182+ (runKleisli $ Kleisli g +++ Kleisli g')
183+
184+instance ArrowZero ReifiedSemiIso' where
185+ zeroArrow = ReifiedSemiIso' $ alwaysFailing "zeroArrow"
186+
187+instance ArrowPlus ReifiedSemiIso' where
188+ ReifiedSemiIso' ai <+> ReifiedSemiIso' ai' = ReifiedSemiIso' $
189+ withSemiIso ai $ \f g -> withSemiIso ai' $ \f' g' ->
190+ semiIso (runKleisli $ Kleisli f <+> Kleisli f')
191+ (runKleisli $ Kleisli g <+> Kleisli g')
192+
128-- | Constructs a semi isomorphism from a pair of functions that can
193-- | Constructs a semi isomorphism from a pair of functions that can
129-- fail with an error message.
194-- fail with an error message.
130semiIso :: (s -> Either String a) -> (b -> Either String t) -> SemiIso s t a b
195semiIso :: (s -> Either String a) -> (b -> Either String t) -> SemiIso s t a b
131−semiIso sa bt = merge . dimap sa (sequenceA . fmap bt) . expose
196+semiIso sa bt = merge . dimap sa (traverse bt) . expose
197+
198+-- | Clones a semi-iso.
199+cloneSemiIso :: ASemiIso s t a b -> SemiIso s t a b
200+cloneSemiIso (SemiIso sa bt) = semiIso sa bt
132
201
133-- | Applies the 'SemiIso'.
202-- | Applies the 'SemiIso'.
134apply :: ASemiIso s t a b -> s -> Either String a
203apply :: ASemiIso s t a b -> s -> Either String a
@@ -139,8 +208,8 @@ unapply :: ASemiIso s t a b -> b -> Either String t
139unapply (SemiIso _ bt) = bt
208unapply (SemiIso _ bt) = bt
140
209
141-- | Extracts the two functions that characterize the 'SemiIso'.
210-- | Extracts the two functions that characterize the 'SemiIso'.
142−withSemiIso :: ASemiIso s t a b
211+withSemiIso :: ASemiIso s t a b
143− -> ((s -> Either String a) -> (b -> Either String t) -> r)
212+ -> ((s -> Either String a) -> (b -> Either String t) -> r)
144 -> r
213 -> r
145withSemiIso ai k = case ai (Retail Right (Right . Identity)) of
214withSemiIso ai k = case ai (Retail Right (Right . Identity)) of
146 Retail sa bt -> k sa (rmap (runIdentity . sequenceA) bt)
215 Retail sa bt -> k sa (rmap (runIdentity . sequenceA) bt)
@@ -149,6 +218,10 @@ withSemiIso ai k = case ai (Retail Right (Right . Identity)) of
149viewSemiIso :: ASemiIso s t a b -> (s -> Either String a, b -> Either String t)
218viewSemiIso :: ASemiIso s t a b -> (s -> Either String a, b -> Either String t)
150viewSemiIso ai = withSemiIso ai (,)
219viewSemiIso ai = withSemiIso ai (,)
151
220
221+-- | Reifies a semi-iso.
222+reifySemiIso :: ASemiIso' s a -> ReifiedSemiIso' s a
223+reifySemiIso ai = ReifiedSemiIso' $ cloneSemiIso ai
224+
152-- | A trivial isomorphism between a and (a, ()).
225-- | A trivial isomorphism between a and (a, ()).
153unit :: Iso' a (a, ())
226unit :: Iso' a (a, ())
154unit = iso (, ()) fst
227unit = iso (, ()) fst
@@ -161,9 +234,20 @@ associated = iso (\(a, (b, c)) -> ((a, b), c)) (\((a, b), c) -> (a, (b, c)))
161-- types (ignoring units!) read from left to right are the same.
234-- types (ignoring units!) read from left to right are the same.
162--
235--
163-- This is implemented using 'Data.Tuple.Morph.morph' from 'tuple-morph'.
236-- This is implemented using 'Data.Tuple.Morph.morph' from 'tuple-morph'.
164−morphed :: (HFoldable a, HUnfoldable a, HFoldable b, HUnfoldable b, Rep a ~ Rep b)
237+morphed :: (TupleMorphable a c, TupleMorphable b c)
165 => Iso' a b
238 => Iso' a b
166−morphed = iso morph morph
239+morphed = iso morphTuples morphTuples
240+
241+-- | Like @morphed@ but also reorders elements if uniquely defined.
242+reorderMorphed
243+ :: ( TupleMorphable a b
244+ , TupleMorphable c d
245+ , ReorderList b d
246+ , ReorderList d b
247+ , CheckListsForTupleIso b d
248+ , CheckListsForTupleIso d b)
249+ => Iso' a c
250+reorderMorphed = iso morphReorderTuples morphReorderTuples
167
251
168-- | \-> Always returns the argument.
252-- | \-> Always returns the argument.
169--
253--
@@ -177,42 +261,54 @@ morphed = iso morph morph
177constant :: a -> SemiIso' () a
261constant :: a -> SemiIso' () a
178constant x = semiIso (\_ -> Right x) (\_ -> Right ())
262constant x = semiIso (\_ -> Right x) (\_ -> Right ())
179
263
180−-- | \-> Always returns the argument.
264+-- | \-> Filters out all values not equal to the argument.
181--
265--
182−-- \<- Filters out all values not equal to the argument.
266+-- \<- Always returns the argument.
183−exact :: Eq a => a -> SemiIso' () a
267+exact :: Eq a => a -> SemiIso' a ()
184exact x = semiIso f g
268exact x = semiIso f g
185 where
269 where
186− f _ = Right x
187− g y | x == y = Right ()
270+ f y | x == y = Right ()
188 | otherwise = Left "exact: not equal"
271 | otherwise = Left "exact: not equal"
272+ g _ = Right x
273+
274+-- | Like 'filtered' but checks the predicate in both ways.
275+bifiltered :: (a -> Bool) -> SemiIso' a a
276+bifiltered p = semiIso check check
277+ where check x | p x = Right x
278+ | otherwise = Left "bifiltered: predicate failed"
189
279
190−_Negative :: Num a => SemiIso' a a
280+-- | A semi-iso that fails in both directions.
191−_Negative = undefined
281+alwaysFailing :: String -> SemiIso s t a b
282+alwaysFailing msg = semiIso (\_ -> Left msg) (\_ -> Left msg)
192
283
284+-- | \-> Matches only negative numbers, turns it into a positive one.
285+--
286+-- \<- Matches only positive numbers, turns it into a negative one.
193−_Positive :: Num a => SemiIso' a a
287+_Negative :: Real a => SemiIso' a a
194−_Positive = undefined
288+_Negative = semiIso f g
289+ where
290+ f x | x < 0 = Right (-x)
291+ | otherwise = Left "_Negative: apply expected a negative number"
292+ g x | x >= 0 = Right (-x)
293+ | otherwise = Left "_Negative: unapply expected a positive number"
195
294
196-- | Reverses a 'SemiIso'.
295-- | Reverses a 'SemiIso'.
197rev :: ASemiIso s t a b -> SemiIso b a t s
296rev :: ASemiIso s t a b -> SemiIso b a t s
198rev ai = withSemiIso ai $ \l r -> semiIso r l
297rev ai = withSemiIso ai $ \l r -> semiIso r l
199
298
200−-- | A product of SemiIso's.
299+-- | A product of semi-isos.
201−prod :: ASemiIso s t a b -> ASemiIso s' t' a' b'
300+prod :: ASemiIso' s a -> ASemiIso' t b -> SemiIso' (s, t) (a, b)
202− -> SemiIso (s, s') (t, t') (a, a') (b, b')
301+prod a b = runSemiIso (reifySemiIso a *** reifySemiIso b)
203−prod (SemiIso sa bt) (SemiIso sa' bt') = semiIso
204− (runKleisli (Kleisli sa *** Kleisli sa'))
205− (runKleisli (Kleisli bt *** Kleisli bt'))
206
302
207−-- | In the non-polymorphic case uses an @SemiIso a ()@ to construct a
303+-- | Uses an @SemiIso' a ()@ to construct a @SemiIso' (a, b) b@,
208−-- @SemiIso (a, b) b@, i.e. eliminates the first pair element.
304+-- i.e. eliminates the first pair element.
209−elimFirst :: ASemiIso s' t' () () -> SemiIso (s', t) (t', t) t t
305+elimFirst :: ASemiIso' s () -> SemiIso' (s, t) t
210elimFirst ai = swapped . elimSecond ai
306elimFirst ai = swapped . elimSecond ai
211
307
212−-- | In the non-polymorphic case uses an @SemiIso b ()@ to construct a
308+-- | Uses an @SemiIso b ()@ to construct a @SemiIso (a, b) a@,
213−-- @SemiIso (a, b) a@, i.e. eliminates the second pair element.
309+-- i.e. eliminates the second pair element.
214−elimSecond :: ASemiIso s' t' () () -> SemiIso (t, s') (t, t') t t
310+elimSecond :: ASemiIso' s () -> SemiIso' (t, s) t
215−elimSecond ai = prod id ai . rev unit
311+elimSecond ai = runSemiIso (second $ reifySemiIso ai) . rev unit
216
312
217-- | Transforms the semi-iso so that applying it in both directions never fails,
313-- | Transforms the semi-iso so that applying it in both directions never fails,
218-- but instead catches any errors and returns them as an @Either String a@.
314-- but instead catches any errors and returns them as an @Either String a@.
@@ -307,7 +403,7 @@ bifoldr = bifoldr_ . attemptAp_
307
403
308-- | Constructs a bidirectional fold. Works with prisms.
404-- | Constructs a bidirectional fold. Works with prisms.
309--
405--
310−-- \-> Right unfolds using the (->) part of the given semi-iso, until it fails.
406+-- \-> Right unfolds using the (->) part of the given semi-iso, until it fails.
311-- It should produce a non-empty list.
407-- It should produce a non-empty list.
312--
408--
313-- \<- Right folds a non-empty list using the (<-) part of the given semi-iso.
409-- \<- Right folds a non-empty list using the (<-) part of the given semi-iso.
@@ -324,7 +420,7 @@ bifoldl = bifoldl_ . attemptAp_
324
420
325-- | Constructs a bidirectional fold. Works with prisms.
421-- | Constructs a bidirectional fold. Works with prisms.
326--
422--
327−-- \-> Left unfolds using the (->) part of the given semi-iso, until it fails.
423+-- \-> Left unfolds using the (->) part of the given semi-iso, until it fails.
328-- It should produce a non-empty list.
424-- It should produce a non-empty list.
329--
425--
330-- \<- Left folds a non-empty list using the (<-) part of the given semi-iso.
426-- \<- Left folds a non-empty list using the (<-) part of the given semi-iso.
src/Control/SIArrow.hsnew file+194
@@ -0,0 +1,194 @@
1+{-# LANGUAGE RankNTypes #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE ConstraintKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{- |
7+Module : Control.SIArrow
8+Description : Categories of reversible computations.
9+Copyright : (c) Paweł Nowak
10+License : MIT
11+
12+Maintainer : Paweł Nowak <pawel834@gmail.com>
13+Stability : experimental
14+
15+Categories of reversible computations.
16+-}
17+module Control.SIArrow (
18+ -- * Arrow.
19+ SIArrow(..),
20+ (^>>), (>>^), (^<<), (<<^),
21+ (#>>), (>>#), (#<<), (<<#),
22+
23+ -- * Functor and applicative.
24+ (/$/), (/$~), (/$<~>), (/*/), (/*), (*/),
25+
26+ -- * Signaling errors.
27+ sifail, (/?/),
28+
29+ -- * Combinators.
30+ sisequence,
31+ sisequence_,
32+ sireplicate,
33+ sireplicate_
34+ ) where
35+
36+import Control.Arrow
37+import Control.Category
38+import Control.Lens.Cons
39+import Control.Lens.Empty
40+import Control.Lens.Iso
41+import Control.Lens.SemiIso
42+import Control.Monad
43+import Control.Tuple.Morph
44+import Prelude hiding (id, (.))
45+
46+infixr 1 #>>, #<<
47+infixr 1 >>#, <<#
48+infixl 4 /$/, /$~
49+infixl 5 /*/, */, /*
50+infixl 3 /?/
51+
52+-- | A category equipped with an embedding 'siarr' from @SemiIso@ into @cat@ and some
53+-- additional structure.
54+--
55+-- SIArrow abstracts categories of reversible computations
56+-- (with reversible side effects).
57+--
58+-- The category @cat@ should contain @SemiIso@ as a sort of
59+-- \"subcategory of pure computations\".
60+class (Arrow cat, ArrowChoice cat, ArrowPlus cat) => SIArrow cat where
61+ -- | Allows you to lift a SemiIso into @cat@. The resulting arrow should be
62+ -- in some sense minimal or \"pure\", similiar to 'pure', 'return' and
63+ -- 'arr' from "Control.Category".
64+ siarr :: ASemiIso' a b -> cat a b
65+ siarr = sipure . rev
66+
67+ -- | Reversed version of 'siarr'.
68+ --
69+ -- Use this where you would use 'pure'.
70+ sipure :: ASemiIso' b a -> cat a b
71+ sipure = siarr . rev
72+
73+ -- | Allows a computation to depend on a its input value.
74+ --
75+ -- I am not sure if this is the right way to get that ArrowApply or Monad
76+ -- like power. It seems quite easy to break the parser/pretty-printer inverse
77+ -- guarantee using this. On the other hand we have to be careful only when
78+ -- constructing the SemiIso using 'iso'/'semiIso' - and with an invalid SemiIso
79+ -- we could break everything anyway using 'siarr'.
80+ sibind :: ASemiIso a (cat a b) (cat a b) b -> cat a b
81+
82+ -- | @sisome v@ repeats @v@ as long as possible, but no less then once.
83+ sisome :: cat () b -> cat () [b]
84+ sisome v = _Cons /$/ v /*/ simany v
85+
86+ -- | @simany v@ repeats @v@ as long as possible.
87+ simany :: cat () b -> cat () [b]
88+ simany v = sisome v <+> sipure _Empty
89+
90+ {-# MINIMAL (siarr | sipure), sibind #-}
91+
92+instance MonadPlus m => SIArrow (Kleisli m) where
93+ siarr ai = Kleisli $ either fail return . apply ai
94+ sibind ai = Kleisli $ \a -> either fail (($ a) . runKleisli) $ apply ai a
95+
96+instance SIArrow ReifiedSemiIso' where
97+ siarr = reifySemiIso
98+ sibind ai = ReifiedSemiIso' $
99+ semiIso (\a -> apply ai a >>= flip apply a . runSemiIso)
100+ (\b -> unapply ai b >>= flip unapply b . runSemiIso)
101+
102+-- | Composes a reversed SemiIso with an arrow.
103+(#>>) :: SIArrow cat => ASemiIso' b a -> cat b c -> cat a c
104+f #>> a = a . sipure f
105+
106+-- | Composes an arrow with a reversed SemiIso.
107+(>>#) :: SIArrow cat => cat a b -> ASemiIso' c b -> cat a c
108+a >># f = sipure f . a
109+
110+-- | Composes a reversed SemiIso with an arrow, backwards.
111+(#<<) :: SIArrow cat => ASemiIso' c b -> cat a b -> cat a c
112+f #<< a = sipure f . a
113+
114+-- | Composes an arrow with a reversed SemiIso, backwards.
115+(<<#) :: SIArrow cat => cat b c -> ASemiIso' b a -> cat a c
116+a <<# f = a . sipure f
117+
118+-- | Postcomposes an arrow with a reversed SemiIso.
119+-- The analogue of '<$>' and synonym for '#<<'.
120+(/$/) :: SIArrow cat => ASemiIso' b' b -> cat a b -> cat a b'
121+(/$/) = (#<<)
122+
123+-- | Convenient fmap.
124+--
125+-- > ai /$~ f = ai . morphed /$/ f
126+--
127+-- This operator handles all the hairy stuff with uncurried application:
128+-- it reassociates the argument tuple and removes unnecessary (or adds necessary)
129+-- units to match the function type. You don't have to use @/*@ and @*/@ with this
130+-- operator.
131+(/$~) :: (SIArrow cat, TupleMorphable b u, TupleMorphable b' u)
132+ => ASemiIso' a b' -> cat c b -> cat c a
133+ai /$~ h = cloneSemiIso ai . morphed /$/ h
134+
135+-- | Like @/$~@ but also reorders elements if uniquely defined.
136+(/$<~>)
137+ :: ( SIArrow cat
138+ , TupleMorphable b u
139+ , TupleMorphable b' v
140+ , ReorderList u v
141+ , ReorderList v u
142+ , CheckListsForTupleIso u v
143+ , CheckListsForTupleIso v u)
144+ => ASemiIso' a b' -> cat c b -> cat c a
145+ai /$<~> h = cloneSemiIso ai . reorderMorphed /$/ h
146+
147+-- | The product of two arrows with duplicate units removed. Side effect are
148+-- sequenced from left to right.
149+--
150+-- The uncurried analogue of '<*>'.
151+(/*/) :: SIArrow cat => cat () b -> cat () c -> cat () (b, c)
152+a /*/ b = siarr unit >>> (a *** b)
153+
154+-- | The product of two arrows, where the second one has no input and no output
155+-- (but can have side effects), with duplicate units removed. Side effect are
156+-- sequenced from left to right.
157+--
158+-- The uncurried analogue of '<*'.
159+(/*) :: SIArrow cat => cat () a -> cat () () -> cat () a
160+f /* g = unit /$/ f /*/ g
161+
162+-- | The product of two arrows, where the first one has no input and no output
163+-- (but can have side effects), with duplicate units removed. Side effect are
164+-- sequenced from left to right.
165+--
166+-- The uncurried analogue of '*>'.
167+(*/) :: SIArrow cat => cat () () -> cat () a -> cat () a
168+f */ g = unit . swapped /$/ f /*/ g
169+
170+-- | An arrow that fails with an error message.
171+sifail :: SIArrow cat => String -> cat a b
172+sifail = siarr . alwaysFailing
173+
174+-- | Provides an error message in the case of failure.
175+(/?/) :: SIArrow cat => cat a b -> String -> cat a b
176+f /?/ msg = f <+> sifail msg
177+
178+-- | Equivalent of 'sequence'.
179+sisequence :: SIArrow cat => [cat () a] -> cat () [a]
180+sisequence [] = sipure _Empty
181+sisequence (x:xs) = _Cons /$/ x /*/ sisequence xs
182+
183+-- | Equivalent of 'sequence_', restricted to units.
184+sisequence_ :: SIArrow cat => [cat () ()] -> cat () ()
185+sisequence_ [] = sipure _Empty
186+sisequence_ (x:xs) = unit /$/ x /*/ sisequence_ xs
187+
188+-- | Equivalent of 'replicateM'.
189+sireplicate :: SIArrow cat => Int -> cat () a -> cat () [a]
190+sireplicate n f = sisequence (replicate n f)
191+
192+-- | Equivalent of 'replicateM_', restricted to units.
193+sireplicate_ :: SIArrow cat => Int -> cat () () -> cat () ()
194+sireplicate_ n f = sisequence_ (replicate n f)
src/Control/Tuple/Morph.hsnew file+305
@@ -0,0 +1,305 @@
1+{-# LANGUAGE
2+ PolyKinds,
3+ DataKinds,
4+ TypeOperators,
5+ GADTs,
6+ FunctionalDependencies,
7+ TypeFamilies,
8+ FlexibleInstances,
9+ UndecidableInstances,
10+ PatternSynonyms,
11+ RankNTypes,
12+ AllowAmbiguousTypes,
13+ TypeApplications,
14+ ScopedTypeVariables,
15+ ConstraintKinds,
16+ FlexibleContexts
17+ #-}
18+
19+{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-redundant-constraints #-}
20+
21+module Control.Tuple.Morph
22+ ( morphTuples
23+ , morphReorderTuples
24+ , morphPickTuples
25+ , TupleMorphable
26+ , CheckListsForTupleIso
27+ , ReorderList
28+ ) where
29+
30+import Data.Proxy
31+import GHC.Generics
32+import GHC.TypeLits hiding (Nat)
33+import Data.Kind
34+
35+
36+morphTuples :: (TupleMorphable a c, TupleMorphable b c) => a -> b
37+morphTuples = morph . unmorph
38+
39+morphPickTuples
40+ :: ( TupleMorphable a b
41+ , TupleMorphable c d
42+ , ReorderList b d )
43+ => a
44+ -> c
45+morphPickTuples = morph . hReorder Proxy . unmorph
46+
47+type CheckListsForTupleIso b d
48+ = EqOrError (Length b) (Length d)
49+ ('Text "Not isomorphic tuple contents:"
50+ ':$$: 'Text " " ':<>: 'ShowType b
51+ ':$$: 'Text " " ':<>: 'ShowType d)
52+
53+morphReorderTuples
54+ :: ( TupleMorphable a b
55+ , TupleMorphable c d
56+ , ReorderList b d
57+ , CheckListsForTupleIso b d)
58+ => a
59+ -> c
60+morphReorderTuples = morph . hReorder Proxy . unmorph
61+
62+type family EqOrError a b e :: Constraint where
63+ EqOrError a a _ = a ~ a
64+ EqOrError _ _ e = TypeError e
65+
66+
67+-- # Nat
68+
69+data Nat where
70+ S :: Nat -> Nat
71+ Z :: Nat
72+
73+
74+-- # HList
75+
76+data HList (ts :: [*]) where
77+ HCons :: t -> HList tt -> HList (t ': tt)
78+ HNil :: HList '[]
79+
80+infixr 5 :+
81+pattern (:+) :: (ts ~ (t : tt)) => t -> HList tt -> HList ts
82+pattern (:+) a b = HCons a b
83+
84+-- ## Taking
85+
86+class TakeableList (n :: Nat) aa bb | n aa -> bb where
87+ hTake :: Proxy n -> HList aa -> HList bb
88+
89+instance TakeableList 'Z a '[] where
90+ hTake _ _ = HNil
91+
92+instance (TakeableList n aa bb', bb ~ (a ': bb'))
93+ => TakeableList ('S n) (a ': aa) bb where
94+ hTake (Proxy :: Proxy ('S n)) (a :+ aa) = a :+ hTake @n Proxy aa
95+
96+-- ## Dropping
97+
98+class DroppableList (n :: Nat) (aa :: [*]) (bb :: [*]) | n aa -> bb where
99+ hDrop :: Proxy n -> HList aa -> HList bb
100+
101+instance DroppableList 'Z aa aa where
102+ hDrop _ aa = aa
103+
104+instance (DroppableList n aa bb) => DroppableList ('S n) (a ': aa) bb where
105+ hDrop (Proxy :: Proxy ('S n)) (_ :+ aa) = hDrop @n Proxy aa
106+
107+-- ## Appending
108+
109+infixr 4 ++:
110+class AppendableList aa bb cc | aa bb -> cc where
111+ (++:) :: HList aa -> HList bb -> HList (aa ++ bb)
112+
113+instance AppendableList '[] bb bb where
114+ HNil ++: bb = bb
115+
116+instance
117+ ( AppendableList aa bb cc
118+ , cc ~ (aa ++ bb)
119+ , ((a ': aa) ++ bb) ~ (a ': cc))
120+ => AppendableList (a ': aa) bb (a ': cc) where
121+ (a :+ aa) ++: bb = a :+ (aa ++: bb)
122+
123+-- ## Finding
124+
125+class FindableList ts t where
126+ hFind :: HList ts -> t
127+
128+instance {-# OVERLAPPING #-}
129+ (NotFindableList ts t)
130+ => FindableList (t ': ts) t where
131+ hFind (t :+ _) = t
132+
133+instance
134+ (TEq a t ~ 'False, FindableList ts a)
135+ => FindableList (t ': ts) a where
136+ hFind (_ :+ ts) = hFind ts
137+
138+instance
139+ (TypeError
140+ ('Text "Could not find type " ':<>: 'ShowType a ':<>: 'Text " in tuple."))
141+ => FindableList '[] a where
142+ hFind = error "oh no"
143+
144+class NotFindableList ts t
145+
146+instance {-# OVERLAPPING #-}
147+ (TypeError
148+ ('Text "Type " ':<>: 'ShowType t ':<>: 'Text " is not unique in tuple."))
149+ => NotFindableList (t ': ts) t
150+
151+instance (NotFindableList ts a) => NotFindableList (t ': ts) a
152+
153+instance NotFindableList '[] a
154+
155+class ReorderList as bs where
156+ hReorder :: Proxy bs -> HList as -> HList bs
157+
158+instance (FindableList as b, ReorderList as bs) => ReorderList as (b ': bs) where
159+ hReorder _ as = hFind as :+ hReorder (Proxy @bs) as
160+
161+instance ReorderList as '[] where
162+ hReorder _ _ = HNil
163+
164+type family TEq a b :: Bool where
165+ TEq a a = 'True
166+ TEq a b = 'False
167+
168+-- ## Other
169+
170+type family (++) (as :: [k]) (bs :: [k]) :: [k] where
171+ (++) a '[] = a
172+ (++) '[] b = b
173+ (++) (a ': as) bs = a ': (as ++ bs)
174+
175+type family Length (aa :: [k]) :: Nat where
176+ Length '[] = 'Z
177+ Length (a ': aa) = 'S (Length aa)
178+
179+
180+-- # Morphing
181+
182+class TupleMorphable t th | t -> th where
183+ unmorph :: t -> HList th
184+ morph :: HList th -> t
185+
186+instance (IsMophableTuple t ~ flag, TupleMorphable' t th flag) => TupleMorphable t th where
187+ unmorph = unmorph' (Proxy @flag)
188+ morph = morph' (Proxy @flag)
189+
190+-- ## Implementation
191+
192+class TupleMorphable' t th (flag :: Bool) | t flag -> th where
193+ unmorph' :: Proxy flag -> t -> HList th
194+ morph' :: Proxy flag -> HList th -> t
195+
196+instance TupleMorphable' t '[t] 'False where
197+ unmorph' _ t = t :+ HNil
198+ morph' _ (t :+ HNil) = t
199+
200+instance (GenericTupleMorphable (Rep t) th, Generic t) => TupleMorphable' t th 'True where
201+ unmorph' _ = genericUnmorph . from
202+ morph' _ = to . genericMorph
203+
204+-- ### Generics
205+
206+class GenericTupleMorphable f th | f -> th where
207+ genericUnmorph :: f p -> HList th
208+ genericMorph :: HList th -> f p
209+
210+instance (GenericTupleMorphable f t) => GenericTupleMorphable (M1 i c f) t where
211+ genericUnmorph = genericUnmorph . unM1
212+ genericMorph = M1 . genericMorph
213+
214+instance (TupleMorphable c t) => GenericTupleMorphable (K1 i c) t where
215+ genericUnmorph = unmorph . unK1
216+ genericMorph = K1 . morph
217+
218+instance GenericTupleMorphable U1 '[] where
219+ genericUnmorph _ = HNil
220+ genericMorph _ = U1
221+
222+type CanTakeDrop a b c =
223+ ( TakeableList (Length a) c a
224+ , DroppableList (Length a) c b
225+ , c ~ (a ++ b)
226+ )
227+
228+instance
229+ ( GenericTupleMorphable f a
230+ , GenericTupleMorphable g b
231+ , AppendableList a b c
232+ , CanTakeDrop a b c)
233+ => GenericTupleMorphable (f :*: g) c where
234+ genericUnmorph (a :*: b) = genericUnmorph a ++: genericUnmorph b
235+ genericMorph cc = genericMorph aa :*: genericMorph bb
236+ where
237+ aa = hTake @(Length a) Proxy cc
238+ bb = hDrop @(Length a) Proxy cc
239+
240+-- ## Other
241+
242+type family (IsMophableTuple t) :: Bool where
243+ IsMophableTuple () = 'True
244+ IsMophableTuple (a, b) = 'True
245+ IsMophableTuple (a, b, c) = 'True
246+ IsMophableTuple (a, b, c, d) = 'True
247+ IsMophableTuple (a, b, c, d, e) = 'True
248+ IsMophableTuple (a, b, c, d, e, f) = 'True
249+ IsMophableTuple (a, b, c, d, e, f, g) = 'True
250+ IsMophableTuple (a, b, c, d, e, f, g, h) = 'True
251+ IsMophableTuple (a, b, c, d, e, f, g, h, i) = 'True
252+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j) = 'True
253+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k) = 'True
254+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l) = 'True
255+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m) = 'True
256+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = 'True
257+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = 'True
258+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = 'True
259+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) = 'True
260+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) = 'True
261+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) = 'True
262+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) = 'True
263+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) = 'True
264+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) = 'True
265+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) = 'True
266+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) = 'True
267+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y) = 'True
268+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z) = 'True
269+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1) = 'True
270+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1) = 'True
271+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1) = 'True
272+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1) = 'True
273+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1) = 'True
274+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1) = 'True
275+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1) = 'True
276+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1) = 'True
277+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1) = 'True
278+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1) = 'True
279+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1) = 'True
280+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1) = 'True
281+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1) = 'True
282+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1) = 'True
283+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1) = 'True
284+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1) = 'True
285+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1) = 'True
286+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1) = 'True
287+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1) = 'True
288+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1) = 'True
289+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1) = 'True
290+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1) = 'True
291+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1) = 'True
292+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1) = 'True
293+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1) = 'True
294+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1) = 'True
295+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2) = 'True
296+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2) = 'True
297+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2) = 'True
298+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2) = 'True
299+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2) = 'True
300+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2) = 'True
301+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2) = 'True
302+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2) = 'True
303+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2) = 'True
304+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2) = 'True
305+ IsMophableTuple c = 'False
Data/Profunctor/Exposed.hs → src/Data/Profunctor/Exposed.hsrenamed+11−9
@@ -1,5 +1,5 @@
1{-# LANGUAGE FunctionalDependencies #-}
1{-# LANGUAGE FunctionalDependencies #-}
2−{-# LANGUAGE MultiParamTypeClasses #-}
2+
3{- |
3{- |
4Module : Data.Profunctor.Exposed
4Module : Data.Profunctor.Exposed
5Description : Exposes Kleisli category structure beneath a profunctor.
5Description : Exposes Kleisli category structure beneath a profunctor.
@@ -9,18 +9,20 @@ License : MIT
9Maintainer : Paweł Nowak <pawel834@gmail.com>
9Maintainer : Paweł Nowak <pawel834@gmail.com>
10Stability : experimental
10Stability : experimental
11-}
11-}
12−module Data.Profunctor.Exposed where
12+module Data.Profunctor.Exposed
13+ ( Exposed(..)
14+ ) where
13
15
14import Data.Profunctor
16import Data.Profunctor
15
17
16-- | Exposes structure of a Kleisli category beneath a profunctor.
18-- | Exposes structure of a Kleisli category beneath a profunctor.
17−--
19+--
18-- Should obey laws:
20-- Should obey laws:
19−--
21+--
20−-- > merge . rmap return = id
22+-- prop> merge . rmap return = id
21−-- > lmap return . expose = id
23+-- prop> lmap return . expose = id
22−-- > rmap (>>= f) = merge . rmap (fmap f)
24+-- prop> rmap (>>= f) = merge . rmap (fmap f)
23−-- > lmap (fmap f) . expose = expose . lmap f
25+-- prop> lmap (fmap f) . expose = expose . lmap f
24class (Monad m, Profunctor p) => Exposed m p | p -> m where
26class (Monad m, Profunctor p) => Exposed m p | p -> m where
25 expose :: p a b -> p (m a) b
27 expose :: p a b -> p (m a) b
26− merge :: p a (m b) -> p a b
28+ merge :: p a (m b) -> p a b
stack.yamlnew file+69
@@ -0,0 +1,69 @@
1+# This file was automatically generated by 'stack init'
2+#
3+# Some commonly used options have been documented as comments in this file.
4+# For advanced use and comprehensive documentation of the format, please see:
5+# https://docs.haskellstack.org/en/stable/yaml_configuration/
6+
7+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
8+# A snapshot resolver dictates the compiler version and the set of packages
9+# to be used for project dependencies. For example:
10+#
11+# resolver: lts-3.5
12+# resolver: nightly-2015-09-21
13+# resolver: ghc-7.10.2
14+#
15+# The location of a snapshot can be provided as a file or url. Stack assumes
16+# a snapshot provided as a file might change, whereas a url resource does not.
17+#
18+# resolver: ./custom-snapshot.yaml
19+# resolver: https://example.com/snapshots/2018-01-01.yaml
20+resolver: lts-14.6
21+
22+# User packages to be built.
23+# Various formats can be used as shown in the example below.
24+#
25+# packages:
26+# - some-directory
27+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
28+# subdirs:
29+# - auto-update
30+# - wai
31+packages:
32+- .
33+# Dependency packages to be pulled from upstream that are not in the resolver.
34+# These entries can reference officially published versions as well as
35+# forks / in-progress versions pinned to a git hash. For example:
36+#
37+# extra-deps:
38+# - acme-missiles-0.3
39+# - git: https://github.com/commercialhaskell/stack.git
40+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
41+#
42+# extra-deps: []
43+
44+# Override default flag values for local packages and extra-deps
45+# flags: {}
46+
47+# Extra package databases containing global packages
48+# extra-package-dbs: []
49+
50+# Control whether we use the GHC we find on the path
51+# system-ghc: true
52+#
53+# Require a specific version of stack, using version ranges
54+# require-stack-version: -any # Default
55+# require-stack-version: ">=2.1"
56+#
57+# Override the architecture used by stack, especially useful on Windows
58+# arch: i386
59+# arch: x86_64
60+#
61+# Extra directories used by stack for building
62+# extra-include-dirs: [/path/to/dir]
63+# extra-lib-dirs: [/path/to/dir]
64+#
65+# Allow a newer minor version of GHC than the snapshot specifies
66+# compiler-check: newer-minor
67+
68+ghc-options:
69+ "$locals": -ddump-to-file -ddump-hi -fwarn-unused-binds -fwarn-unused-imports