git.iko.soy/semi-iso-optics
on master help sign in
swap
de16c6d23 ahead, 0 behind
16 files changed+880−297
since splitsnapshots
unifiedsplit
.github/workflows/haskell.yml+22 .gitignore+15−38 .travis.yml+132 Control/Category/Structures.hs−68 Control/SIArrow.hs−125 LICENSE+1 package.yaml+44 semi-iso.cabal−30 Control/Category/Reader.hs → src/Control/Category/Reader.hs+14−6 src/Control/Category/Structures.hs+31 Control/Lens/Internal/SemiIso.hs → src/Control/Lens/Internal/SemiIso.hs+5−3 Control/Lens/SemiIso.hs → src/Control/Lens/SemiIso.hs+41−22 src/Control/SIArrow.hs+194 src/Control/Tuple/Morph.hs+305 Data/Profunctor/Exposed.hs → src/Data/Profunctor/Exposed.hs+7−5 stack.yaml+69
.github/workflows/haskell.ymlnew file+22
@@ -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 ###
41dist
2+dist-*
53cabal-dev
64*.o
75*.hi
6+*.hie
87*.chi
98*.chs.h
10−.virtualenv
9+*.dyn_o
10+*.dyn_hi
11+.hpc
1112.hsenv
1213.cabal-sandbox/
1314cabal.sandbox.config
14−cabal.config
15−
16−
17−### Emacs ###
18−# -*- mode: gitignore; -*-
19−*~
20−\#*\#
21−/.emacs.desktop
22−/.emacs.desktop.lock
23−*.elc
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−
15+*.prof
16+*.aux
17+*.hp
18+*.eventlog
19+.stack-work/
20+cabal.project.local
21+cabal.project.local~
22+.HTF/
23+.ghc.environment.*
24+*.cabal
.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
Control/Category/Structures.hsdeleted−68
@@ -1,68 +0,0 @@
1−{-# LANGUAGE TypeFamilies #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{- |
4−Module : Control.Category.Structures
5−Description : Structures in a category.
6−Copyright : (c) Paweł Nowak
7−License : MIT
8−
9−Maintainer : Paweł Nowak <pawel834@gmail.com>
10−Stability : experimental
11−
12−-}
13−module Control.Category.Structures where
14−
15−import Control.Arrow (Kleisli(..))
16−import qualified Control.Arrow as BadArrow
17−import Control.Category
18−import Control.Monad
19−import Prelude hiding (id, (.))
20−
21−infixl 3 ***
22−infixl 2 +++
23−infixl 3 /+/
24−
25−class Category cat => Products cat where
26− first :: cat a b -> cat (a, c) (b, c)
27− first a = a *** id
28−
29− second :: cat a b -> cat (c, a) (c, b)
30− second a = id *** a
31−
32− (***) :: cat a b -> cat c d -> cat (a, c) (b, d)
33− a *** b = first a >>> second b
34−
35− {-# MINIMAL (***) | first, second #-}
36−
37−instance Monad m => Products (Kleisli m) where
38− (***) = (BadArrow.***)
39−
40−class Category cat => Coproducts cat where
41− left :: cat a b -> cat (Either a c) (Either b c)
42− left a = a +++ id
43−
44− right :: cat a b -> cat (Either c a) (Either c b)
45− right a = id +++ a
46−
47− (+++) :: cat a b -> cat c d -> cat (Either a c) (Either b d)
48− a +++ b = left a >>> right b
49−
50− {-# MINIMAL (+++) | left, right #-}
51−
52−instance Monad m => Coproducts (Kleisli m) where
53− (+++) = (BadArrow.+++)
54−
55−class Category cat => CatPlus cat where
56− cempty :: cat a b
57− (/+/) :: cat a b -> cat a b -> cat a b
58−
59− {-# MINIMAL cempty, (/+/) #-}
60−
61−instance MonadPlus m => CatPlus (Kleisli m) where
62− cempty = BadArrow.zeroArrow
63− (/+/) = (BadArrow.<+>)
64−
65−class CategoryTrans t where
66− clift :: Category cat => cat a b -> t cat a b
67−
68− {-# MINIMAL clift #-}
Control/SIArrow.hsdeleted−125
@@ -1,125 +0,0 @@
1−{-# LANGUAGE TypeFamilies #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{- |
4−Module : Control.SIArrow
5−Description : Semi-iso arrows.
6−Copyright : (c) Paweł Nowak
7−License : MIT
8−
9−Maintainer : Paweł Nowak <pawel834@gmail.com>
10−Stability : experimental
11−
12−-}
13−module Control.SIArrow where
14−
15−import Control.Arrow (Kleisli(..))
16−import Control.Category
17−import Control.Category.Structures
18−import Control.Lens.Cons
19−import Control.Lens.Empty
20−import Control.Lens.SemiIso
21−import Control.Monad
22−import Data.Tuple.Morph
23−import Prelude hiding (id, (.))
24−
25−infixr 1 ^>>, >>^
26−infixr 1 ^<<, <<^
27−infixl 4 /$/, /$~, ~$/, ~$~
28−infixl 5 /*/, */, /*
29−
30−-- Categories.
31−
32−class (Products cat, Coproducts cat, CatPlus cat) => SIArrow cat where
33− siarr :: ASemiIso' a b -> cat a b
34−
35− sipure :: ASemiIso' b a -> cat a b
36− sipure = siarr . rev
37−
38− sisome :: cat () b -> cat () [b]
39− sisome v = _Cons /$/ v /*/ simany v
40−
41− simany :: cat () b -> cat () [b]
42− simany v = sisome v /+/ sipure _Empty
43−
44− {-# MINIMAL siarr #-}
45−
46−instance MonadPlus m => SIArrow (Kleisli m) where
47− siarr ai = Kleisli $ either fail return . apply ai
48−
49−instance SIArrow ReifiedSemiIso' where
50− siarr = reifySemiIso
51−
52−(^>>) :: SIArrow cat => ASemiIso' a b -> cat b c -> cat a c
53−f ^>> a = a . siarr f
54−
55−(>>^) :: SIArrow cat => cat a b -> ASemiIso' b c -> cat a c
56−a >>^ f = siarr f . a
57−
58−(^<<) :: SIArrow cat => ASemiIso' b c -> cat a b -> cat a c
59−f ^<< a = siarr f . a
60−
61−(<<^) :: SIArrow cat => cat b c -> ASemiIso' a b -> cat a c
62−a <<^ f = a . siarr f
63−
64−(/$/) :: SIArrow cat => ASemiIso' b' b -> cat a b -> cat a b'
65−ai /$/ f = sipure ai . f
66−
67−-- | > ai /$~ f = ai . morphed /$/ f
68−--
69−-- This operator handles all the hairy stuff with uncurried application:
70−-- it reassociates the argument tuple and removes unnecessary (or adds necessary)
71−-- units to match the function type. You don't have to use @/*@ and @*/@ with this
72−-- operator.
73−(/$~) :: (SIArrow cat, HFoldable b', HFoldable b,
74− HUnfoldable b', HUnfoldable b, Rep b' ~ Rep b)
75− => ASemiIso' a b' -> cat c b -> cat c a
76−ai /$~ h = cloneSemiIso ai . morphed /$/ h
77−
78−-- | > ai ~$/ f = morphed . ai /$/ f
79−(~$/) :: (SIArrow cat, HFoldable a', HFoldable a,
80− HUnfoldable a', HUnfoldable a, Rep a' ~ Rep a)
81− => ASemiIso' a' b -> cat c b -> cat c a
82−ai ~$/ h = morphed . cloneSemiIso ai /$/ h
83−
84−-- | > ai ~$~ f = morphed . ai . morphed /$/ f
85−(~$~) :: (SIArrow cat,
86− HFoldable a, HUnfoldable a,
87− HFoldable b, HUnfoldable b,
88− HFoldable b', HUnfoldable b',
89− Rep b' ~ Rep b, Rep b' ~ Rep a)
90− => ASemiIso b' b' b' b' -> cat c b -> cat c a
91−ai ~$~ h = morphed . cloneSemiIso ai . morphed /$/ h
92−
93−(/*/) :: SIArrow cat => cat () b -> cat () c -> cat () (b, c)
94−a /*/ b = unit ^>> (a *** b)
95−
96−(/*) :: SIArrow cat => cat () a -> cat () () -> cat () a
97−f /* g = unit /$/ f /*/ g
98−
99−(*/) :: SIArrow cat => cat () () -> cat () a -> cat () a
100−f */ g = unit . swapped /$/ f /*/ g
101−
102−sifail :: SIArrow cat => String -> cat a b
103−sifail = siarr . alwaysFailing
104−
105−-- | Provides an error message in the case of failure.
106−(/?/) :: SIArrow cat => cat a b -> String -> cat a b
107−f /?/ msg = f /+/ sifail msg
108−
109−-- | Equivalent of 'sequence'.
110−sisequence :: SIArrow cat => [cat () a] -> cat () [a]
111−sisequence [] = sipure _Empty
112−sisequence (x:xs) = _Cons /$/ x /*/ sisequence xs
113−
114−-- | Equivalent of 'sequence_', restricted to units.
115−sisequence_ :: SIArrow cat => [cat () ()] -> cat () ()
116−sisequence_ [] = sipure _Empty
117−sisequence_ (x:xs) = unit /$/ x /*/ sisequence_ xs
118−
119−-- | Equivalent of 'replicateM'.
120−sireplicate :: SIArrow cat => Int -> cat () a -> cat () [a]
121−sireplicate n f = sisequence (replicate n f)
122−
123−-- | Equivalent of 'replicateM_', restricted to units.
124−sireplicate_ :: SIArrow cat => Int -> cat () () -> cat () ()
125−sireplicate_ n f = sisequence_ (replicate n f)
LICENSE+1
@@ -1,4 +1,5 @@
11Copyright (c) 2014 Paweł Nowak
2+Copyright (c) 2019 Ilya Kostyuchenko
23
34Permission is hereby granted, free of charge, to any person obtaining
45a 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−30
@@ -1,30 +0,0 @@
1−name: semi-iso
2−version: 1.0.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 have a look at "Control.SIArrow".
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− Control.SIArrow
26− Control.Category.Reader
27− Data.Profunctor.Exposed
28− build-depends: base >= 4 && < 5, profunctors, transformers, lens, tuple-morph
29− default-language: Haskell2010
30− ghc-options: -Wall
Control/Category/Reader.hs → src/Control/Category/Reader.hsrenamed+14−6
@@ -15,29 +15,37 @@ module Control.Category.Reader (
1515 ReaderCT(..)
1616 ) where
1717
18+import Control.Arrow
1819import Control.Category
1920import Control.Category.Structures
21+import Control.Lens.Iso
22+import Control.Lens.SemiIso
2023import Control.SIArrow
2124import Prelude hiding (id, (.))
2225
2326newtype ReaderCT env cat a b = ReaderCT { runReaderCT :: env -> cat a b }
2427
25−instance CategoryTrans (ReaderCT env) where
28+instance CatTrans (ReaderCT env) where
2629 clift = ReaderCT . const
2730
2831instance Category cat => Category (ReaderCT env cat) where
2932 id = clift id
3033 ReaderCT f . ReaderCT g = ReaderCT $ \x -> f x . g x
3134
32−instance Products cat => Products (ReaderCT env cat) where
35+instance Arrow cat => Arrow (ReaderCT env cat) where
36+ arr f = ReaderCT $ \_ -> arr f
3337 ReaderCT f *** ReaderCT g = ReaderCT $ \x -> f x *** g x
3438
35−instance Coproducts cat => Coproducts (ReaderCT env cat) where
39+instance ArrowChoice cat => ArrowChoice (ReaderCT env cat) where
3640 ReaderCT f +++ ReaderCT g = ReaderCT $ \x -> f x +++ g x
3741
38−instance CatPlus cat => CatPlus (ReaderCT env cat) where
39− cempty = clift cempty
40− ReaderCT f /+/ ReaderCT g = ReaderCT $ \x -> f x /+/ g x
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
4147
4248instance SIArrow cat => SIArrow (ReaderCT env cat) where
4349 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
99Maintainer : Paweł Nowak <pawel834@gmail.com>
1010Stability : experimental
1111-}
12−module Control.Lens.Internal.SemiIso where
12+module Control.Lens.Internal.SemiIso
13+ ( Retail(..)
14+ ) where
1315
1416import Control.Monad
1517import Data.Profunctor
@@ -25,9 +27,9 @@ instance Profunctor (Retail s t) where
2527 rmap f (Retail l r) = Retail l (fmap f . r)
2628
2729instance Choice (Retail s t) where
28− left' (Retail as st) = Retail
30+ left' (Retail as st) = Retail
2931 (either as (\_ -> Left "semi-iso failed")) (fmap Left . st)
30− right' (Retail as st) = Retail
32+ right' (Retail as st) = Retail
3133 (either (\_ -> Left "semi-iso failed") as) (fmap Right . st)
3234
3335-- Proof of 'Exposed' laws:
Control/Lens/SemiIso.hs → src/Control/Lens/SemiIso.hsrenamed+41−22
@@ -4,6 +4,8 @@
44{-# LANGUAGE ViewPatterns #-}
55{-# LANGUAGE PatternSynonyms #-}
66{-# LANGUAGE FlexibleContexts #-}
7+
8+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
79{- |
810Module : Control.Lens.SemiIso
911Description : Semi-isomorphisms.
@@ -33,7 +35,7 @@ Our semi-isomorphisms will obey weakened laws:
3335
3436When you see an "Either String a", the String is usually an error message.
3537
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.
3739Any resemblance to known mathematical objects of the same name is purely coincidental.
3840-}
3941module Control.Lens.SemiIso (
@@ -65,6 +67,7 @@ module Control.Lens.SemiIso (
6567 swapped,
6668 associated,
6769 morphed,
70+ reorderMorphed,
6871 constant,
6972 exact,
7073 bifiltered,
@@ -97,28 +100,27 @@ module Control.Lens.SemiIso (
97100 bifoldl1_
98101 ) where
99102
100−import Control.Arrow (Kleisli(..))
103+import Control.Arrow
101104import Control.Category
102−import Control.Category.Structures
103105import Control.Lens.Internal.SemiIso
104106import Control.Lens.Iso
107+import Control.Tuple.Morph
105108import Data.Foldable
106109import Data.Functor.Identity
107110import Data.Profunctor.Exposed
108111import Data.Traversable
109−import Data.Tuple.Morph
110112import Prelude hiding (id, (.))
111113
112114-- | A semi-isomorphism is a partial isomorphism with weakened laws.
113−--
115+--
114116-- Should satisfy laws:
115−--
117+--
116118-- > apply i >=> unapply i >=> apply i = apply i
117119-- > unapply i >=> apply i >=> unapply i = unapply i
118120--
119121-- Every 'Prism' is a 'SemiIso'.
120122-- Every 'Iso' is a 'Prism'.
121−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)
122124 => p a (f b) -> p s (f t)
123125
124126-- | Non-polymorphic variant of 'SemiIso'.
@@ -132,6 +134,10 @@ type ASemiIso' s a = ASemiIso s s a a
132134
133135-- | A nice pattern synonym for SemiIso's. Gives you the two functions, just like
134136-- 'viewSemiIso' or 'fromSemiIso'.
137+pattern SemiIso
138+ :: (s -> Either String a)
139+ -> (b -> Either String t)
140+ -> ASemiIso s t a b
135141pattern SemiIso sa bt <- (viewSemiIso -> (sa, bt))
136142
137143-- | A semi-iso stored in a container.
@@ -141,7 +147,8 @@ instance Category ReifiedSemiIso' where
141147 id = ReifiedSemiIso' id
142148 ReifiedSemiIso' f . ReifiedSemiIso' g = ReifiedSemiIso' (g . f)
143149
144−instance Products ReifiedSemiIso' where
150+instance Arrow ReifiedSemiIso' where
151+ arr f = ReifiedSemiIso' $ semiIso (Right . f) (const $ Left "oh no")
145152 -- TODO: pattern synonyms dont work here for some reason
146153 first (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
147154 ReifiedSemiIso' $ cloneSemiIso $
@@ -158,7 +165,7 @@ instance Products ReifiedSemiIso' where
158165 semiIso (runKleisli $ Kleisli f *** Kleisli f')
159166 (runKleisli $ Kleisli g *** Kleisli g')
160167
161−instance Coproducts ReifiedSemiIso' where
168+instance ArrowChoice ReifiedSemiIso' where
162169 left (ReifiedSemiIso' ai) = withSemiIso ai $ \f g ->
163170 ReifiedSemiIso' $ cloneSemiIso $
164171 semiIso (runKleisli $ left $ Kleisli f)
@@ -174,18 +181,19 @@ instance Coproducts ReifiedSemiIso' where
174181 semiIso (runKleisli $ Kleisli f +++ Kleisli f')
175182 (runKleisli $ Kleisli g +++ Kleisli g')
176183
177−instance CatPlus ReifiedSemiIso' where
178− cempty = ReifiedSemiIso' $ alwaysFailing "cempty"
184+instance ArrowZero ReifiedSemiIso' where
185+ zeroArrow = ReifiedSemiIso' $ alwaysFailing "zeroArrow"
179186
180− ReifiedSemiIso' ai /+/ ReifiedSemiIso' ai' = ReifiedSemiIso' $
187+instance ArrowPlus ReifiedSemiIso' where
188+ ReifiedSemiIso' ai <+> ReifiedSemiIso' ai' = ReifiedSemiIso' $
181189 withSemiIso ai $ \f g -> withSemiIso ai' $ \f' g' ->
182− semiIso (runKleisli $ Kleisli f /+/ Kleisli f')
183− (runKleisli $ Kleisli g /+/ Kleisli g')
190+ semiIso (runKleisli $ Kleisli f <+> Kleisli f')
191+ (runKleisli $ Kleisli g <+> Kleisli g')
184192
185193-- | Constructs a semi isomorphism from a pair of functions that can
186194-- fail with an error message.
187195semiIso :: (s -> Either String a) -> (b -> Either String t) -> SemiIso s t a b
188−semiIso sa bt = merge . dimap sa (sequenceA . fmap bt) . expose
196+semiIso sa bt = merge . dimap sa (traverse bt) . expose
189197
190198-- | Clones a semi-iso.
191199cloneSemiIso :: ASemiIso s t a b -> SemiIso s t a b
@@ -200,8 +208,8 @@ unapply :: ASemiIso s t a b -> b -> Either String t
200208unapply (SemiIso _ bt) = bt
201209
202210-- | Extracts the two functions that characterize the 'SemiIso'.
203−withSemiIso :: ASemiIso s t a b
204− -> ((s -> Either String a) -> (b -> Either String t) -> r)
211+withSemiIso :: ASemiIso s t a b
212+ -> ((s -> Either String a) -> (b -> Either String t) -> r)
205213 -> r
206214withSemiIso ai k = case ai (Retail Right (Right . Identity)) of
207215 Retail sa bt -> k sa (rmap (runIdentity . sequenceA) bt)
@@ -226,9 +234,20 @@ associated = iso (\(a, (b, c)) -> ((a, b), c)) (\((a, b), c) -> (a, (b, c)))
226234-- types (ignoring units!) read from left to right are the same.
227235--
228236-- This is implemented using 'Data.Tuple.Morph.morph' from 'tuple-morph'.
229−morphed :: (HFoldable a, HUnfoldable a, HFoldable b, HUnfoldable b, Rep a ~ Rep b)
237+morphed :: (TupleMorphable a c, TupleMorphable b c)
230238 => Iso' a b
231−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
232251
233252-- | \-> Always returns the argument.
234253--
@@ -289,7 +308,7 @@ elimFirst ai = swapped . elimSecond ai
289308-- | Uses an @SemiIso b ()@ to construct a @SemiIso (a, b) a@,
290309-- i.e. eliminates the second pair element.
291310elimSecond :: ASemiIso' s () -> SemiIso' (t, s) t
292−elimSecond ai = runSemiIso (id *** reifySemiIso ai) . rev unit
311+elimSecond ai = runSemiIso (second $ reifySemiIso ai) . rev unit
293312
294313-- | Transforms the semi-iso so that applying it in both directions never fails,
295314-- but instead catches any errors and returns them as an @Either String a@.
@@ -384,7 +403,7 @@ bifoldr = bifoldr_ . attemptAp_
384403
385404-- | Constructs a bidirectional fold. Works with prisms.
386405--
387−-- \-> 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.
388407-- It should produce a non-empty list.
389408--
390409-- \<- Right folds a non-empty list using the (<-) part of the given semi-iso.
@@ -401,7 +420,7 @@ bifoldl = bifoldl_ . attemptAp_
401420
402421-- | Constructs a bidirectional fold. Works with prisms.
403422--
404−-- \-> 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.
405424-- It should produce a non-empty list.
406425--
407426-- \<- 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+7−5
@@ -1,5 +1,5 @@
11{-# LANGUAGE FunctionalDependencies #-}
2−{-# LANGUAGE MultiParamTypeClasses #-}
2+
33{- |
44Module : Data.Profunctor.Exposed
55Description : Exposes Kleisli category structure beneath a profunctor.
@@ -9,18 +9,20 @@ License : MIT
99Maintainer : Paweł Nowak <pawel834@gmail.com>
1010Stability : experimental
1111-}
12−module Data.Profunctor.Exposed where
12+module Data.Profunctor.Exposed
13+ ( Exposed(..)
14+ ) where
1315
1416import Data.Profunctor
1517
1618-- | Exposes structure of a Kleisli category beneath a profunctor.
17−--
19+--
1820-- Should obey laws:
19−--
21+--
2022-- prop> merge . rmap return = id
2123-- prop> lmap return . expose = id
2224-- prop> rmap (>>= f) = merge . rmap (fmap f)
2325-- prop> lmap (fmap f) . expose = expose . lmap f
2426class (Monad m, Profunctor p) => Exposed m p | p -> m where
2527 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