higher-order-open-union (empty) → 0.1.0.0

raw patch · 11 files changed

+332/−0 lines, 11 filesdep +basedep +freer-base-classesdep +higher-order-open-unionsetup-changed

Dependencies added: base, freer-base-classes, higher-order-open-union

Files

• CHANGELOG.md +11/−0
• LICENSE +26/−0
• README.md +7/−0
• Setup.hs +2/−0
• app/Main.hs +6/−0
• higher-order-open-union.cabal +76/−0
• src/Control/HigherOpenUnion.hs +102/−0
• src/Data/HigherFunctor.hs +70/−0
• src/Data/TypeElem.hs +24/−0
• src/Lib.hs +6/−0
• test/Spec.hs +2/−0

@@ -0,0 +1,11 @@+# Changelog for `higher-order-open-union`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD

@@ -0,0 +1,26 @@+Copyright 2025 Yoshikuni Jujo++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1.  Redistributions of source code must retain the above copyright notice, this+    list of conditions and the following disclaimer.++2.  Redistributions in binary form must reproduce the above copyright notice,+    this list of conditions and the following disclaimer in the documentation+    and/or other materials provided with the distribution.++3.  Neither the name of the copyright holder nor the names of its contributors+    may be used to endorse or promote products derived from this software+    without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,7 @@+# higher-order-open-union++This package used by package yaftee.++```Haskell+type Eff effs = Data.HigherFunctor.H (Control.HigherOpenUnion.U effs)+```

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,6 @@+module Main (main) where++import Lib++main :: IO ()+main = someFunc

@@ -0,0 +1,76 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.38.1.+--+-- see: https://github.com/sol/hpack++name:           higher-order-open-union+version:        0.1.0.0+synopsis:       This package is used by package yaftee+description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/higher-order-open-union#readme>+category:       Control+homepage:       https://github.com/YoshikuniJujo/higher-order-open-union#readme+bug-reports:    https://github.com/YoshikuniJujo/higher-order-open-union/issues+author:         Yoshikuni Jujo+maintainer:     yoshikuni.jujo@gmail.com+copyright:      (c) 2025 Yoshikuni Jujo+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+extra-doc-files:+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/YoshikuniJujo/higher-order-open-union++library+  exposed-modules:+      Control.HigherOpenUnion+      Data.HigherFunctor+      Data.TypeElem+      Lib+  other-modules:+      Paths_higher_order_open_union+  autogen-modules:+      Paths_higher_order_open_union+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      base >=4.7 && <5+    , freer-base-classes ==0.1.*+  default-language: Haskell2010++executable higher-order-open-union-exe+  main-is: Main.hs+  other-modules:+      Paths_higher_order_open_union+  autogen-modules:+      Paths_higher_order_open_union+  hs-source-dirs:+      app+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , freer-base-classes ==0.1.*+    , higher-order-open-union+  default-language: Haskell2010++test-suite higher-order-open-union-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_higher_order_open_union+  autogen-modules:+      Paths_higher_order_open_union+  hs-source-dirs:+      test+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , freer-base-classes ==0.1.*+    , higher-order-open-union+  default-language: Haskell2010

@@ -0,0 +1,102 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.HigherOpenUnion (++	-- * TYPES++	U, HT, Member, Base, FromFirst(..),++	-- * INJECTION++	inj, injBase, injh,++	-- * PROJECTION++	prj, decomp, extract, extracth,++	-- * WEAKEN++	weaken,++	-- * NON DET AND FAIL++	NonDet(..), Fail(..)++	) where++import Control.Monad.Freer.NonDetable qualified as NonDetable+import Control.Monad.Freer.Failable qualified as Failable+import Data.Kind+import Data.TypeElem+import Unsafe.Coerce++-- * TYPES++data U (hs :: [HT]) (f :: Type -> Type -> Type -> Type) i o a =+	forall h . U Word (h f i o a)++type HT = (Type -> Type -> Type -> Type) -> Type -> Type -> Type -> Type++data FromFirst t (f :: Type -> Type -> Type -> Type) i o a+	= forall x . FromFirst (t x) (x -> a)++-- * INJECTION++inj :: forall t hs (f :: Type -> Type -> Type -> Type) i o a .+	Member (FromFirst t) hs => t a -> U hs f i o a+inj = U (unP (elemNo :: P (FromFirst t) hs)) . (`FromFirst` id)++injBase :: forall t hs (f :: Type -> Type -> Type -> Type) i o a .+	Base (FromFirst t) hs => t a -> U hs f i o a+injBase = U (unP (elemNoBase :: P (FromFirst t) hs)) . (`FromFirst` id)++injh :: forall h hs f i o a . Member h hs => h f i o a -> U hs f i o a+injh = U $ unP (elemNo :: P h hs)++-- * PROJECTION++prj :: forall h hs f i o a . Member h hs => U hs f i o a -> Maybe (h f i o a)+prj (U i hx)+	| i == unP (elemNo :: P h hs) = Just $ unsafeCoerce hx+	| otherwise = Nothing++decomp :: U (h ': hs) f i o a -> Either (U hs f i o a) (h f i o a)+decomp (U 0 hx) = Right $ unsafeCoerce hx+decomp (U i hx) = Left $ U (i - 1) hx++extract :: Functor t => U '[FromFirst t] f i o a -> t a+extract (U _ hx) = case (unsafeCoerce hx) of FromFirst tx k -> k <$> tx++extracth :: U '[h] f i o a -> h f i o a+extracth (U _ hx) = unsafeCoerce hx++-- * WEAKEN++weaken :: U hs f i o a -> U (any ': hs) f i o a+weaken (U n a) = U (n + 1) a++-- * NON DET AND FAIL++instance Member (FromFirst NonDet) effs => NonDetable.N (U effs f i o) where+	mz = inj (NonDetable.mz @NonDet); mp = inj (NonDetable.mp @NonDet)++data NonDet a where MZero :: NonDet a; MPlus :: NonDet Bool++deriving instance Show (NonDet a)++instance NonDetable.N NonDet where mz = MZero; mp = MPlus++instance Member Fail effs => Failable.F (U effs f i o) where+	fail = injh . Fail++data Fail (f :: Type -> Type -> Type -> Type) i o a where+	Fail :: forall f a i o . String -> Fail f i o a+	FailCatch :: forall f a i o .+		f i o a -> (String -> f i o a) -> Fail f i o a

@@ -0,0 +1,70 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.HigherFunctor (Loose(..), TightI(..), TightO(..), Tight(..)) where++import Prelude hiding (map)+import Control.HigherOpenUnion++class Loose h where+	map :: (forall i o x . f i o x -> g i o (t x)) ->+		(forall x . x -> t x) -> h f i' o' x' -> h g i' o' (t x')+	default map :: Tight h => (forall i o x . f i o x -> g i o (t x)) ->+		(forall x . x -> t x) -> h f i' o' x' -> h g i' o' (t x')+	map = mapT++instance Loose (FromFirst t)+instance Loose (U '[])++instance (Loose h, Loose (U hs)) => Loose (U (h ': hs)) where+	map f g u = case decomp u of+		Left u' -> weaken $ map f g u'+		Right h -> injh $ map f g h++class TightI h where+	mapI :: (forall o x . f i o x -> g i' o (t x)) ->+		(forall x . x -> t x) -> h f i o' x' -> h g i' o' (t x')+	default mapI :: Tight h => (forall o x . f i o x -> g i' o (t x)) ->+		(forall x . x -> t x) -> h f i o' x' -> h g i' o' (t x')+	mapI = mapT++instance TightI (FromFirst t)+instance TightI (U '[])++instance (TightI h, TightI (U hs)) => TightI (U (h ': hs)) where+	mapI f g u = case decomp u of+		Left u' -> weaken $ mapI f g u'+		Right h -> injh $ mapI f g h++class TightO h where+	mapO :: (forall i x . f i o x -> g i o' (t x)) ->+		(forall x . x -> t x) -> h f i' o x' -> h g i' o' (t x')+	default mapO :: Tight h => (forall i x . f i o x -> g i o' (t x)) ->+		(forall x . x -> t x) -> h f i' o x' -> h g i' o' (t x')+	mapO = mapT++instance TightO (FromFirst t)+instance TightO (U '[])++instance (TightO h, TightO (U hs)) => TightO (U (h ': hs)) where+	mapO f g u = case decomp u of+		Left u' -> weaken $ mapO f g u'+		Right h -> injh $ mapO f g h++class Tight h where+	mapT :: (f i o x -> g i' o' y) -> (x -> y) -> h f i o x -> h g i' o' y++instance Tight (FromFirst t) where+	mapT _ g (FromFirst x k) = FromFirst x (g . k)++instance Tight (U '[]) where mapT _ _ _ = error "bad"++instance (Tight h, Tight (U hs)) => Tight (U (h ': hs)) where+	mapT f g u = case decomp u of+		Left u' -> weaken $ mapT f g u'+		Right h -> injh $ mapT f g h

@@ -0,0 +1,24 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.TypeElem (P, unP, Member, elemNo, Base, elemNoBase) where++newtype P t ts = P { unP :: Word } deriving Show++class Member (t :: k) (ts :: [k]) where elemNo :: P t ts++instance Member t (t ': ts) where elemNo = P 0++instance {-# OVERLAPPABLE #-} Member t ts => Member t (_t' ': ts) where+	elemNo = P $ 1 + unP (elemNo :: P t ts)++class Base (t :: k) (ts :: [k]) where elemNoBase :: P t ts++instance Base t '[t] where elemNoBase = P 0++instance {-# OVERLAPPABLE #-} Base t ts => Base t (_t' ': ts) where+	elemNoBase = P $ 1 + unP (elemNoBase :: P t ts)

@@ -0,0 +1,6 @@+module Lib+    ( someFunc+    ) where++someFunc :: IO ()+someFunc = putStrLn "someFunc"

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"