open-adt (empty) → 1.0
raw patch · 6 files changed
+553/−0 lines, 6 filesdep +basedep +constraintsdep +recursion-schemes
Dependencies added: base, constraints, recursion-schemes, row-types, template-haskell
Files
- LICENSE +27/−0
- lib/Data/OpenADT.hs +25/−0
- lib/Data/OpenADT/TH.hs +128/−0
- lib/Data/OpenADT/VarF.hs +215/−0
- lib/Data/OpenADT/VariantsF.hs +96/−0
- open-adt.cabal +62/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright 2018 Jordan Woehr++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.
+ lib/Data/OpenADT.hs view
@@ -0,0 +1,25 @@+-- |+-- Module : Data.OpenADT+-- Copyright : Copyright (c) Jordan Woehr, 2018+-- License : BSD+-- Maintainer : Jordan Woehr+-- Stability : experimental+--+-- This module defines the 'OpenADT' type, which is an algebraic data type+-- with constructors defined by its argument's row type.++module Data.OpenADT+ ( module Data.OpenADT+ , module Data.OpenADT.TH+ , module Data.OpenADT.VarF+ , module Data.OpenADT.VariantsF+ )+where++import Data.Functor.Foldable ( Fix(..) )+import Data.OpenADT.TH+import Data.OpenADT.VarF+import Data.OpenADT.VariantsF++-- | A algebraic data type that can have constructors added and removed.+type OpenADT r = Fix (VarF r)
+ lib/Data/OpenADT/TH.hs view
@@ -0,0 +1,128 @@+-- |+-- Module : Data.OpenADT.TH+-- Copyright : Copyright (c) Jordan Woehr, 2018+-- License : BSD+-- Maintainer : Jordan Woehr+-- Stability : experimental+--+-- This module exports template haskell functions for generating tedious+-- boilerplate.++{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}++module Data.OpenADT.TH+ ( mkVarPattern+ )+where++import Control.Monad ( replicateM )+import Data.Functor.Foldable ( Fix(..) )+import Data.List ( foldl'+ , init+ )++import Language.Haskell.TH++import Data.Row ( Label(..) )+import Data.Row.Variants ( pattern IsJust+ , view+ )+import Data.OpenADT.VarF ( OpenAlg+ , VarF(..)+ )++-- | Create patterns for a variant constructor.+--+-- For example, for the type FooF with the constructor FooF':+--+-- > data FooF a x = FooF' a x+-- > $(mkVarPattern ''FooF "foo" "Foo" "FooF")+--+-- A pattern similar to the following will be generated:+--+-- > pattern FooF :: (OpenAlg r "foo" (FooF a) v) => a -> v -> VarF r v+-- > pattern FooF a v <- VarF (view (Label :: Label "foo") -> Just (FooF' a v))+-- >+-- > pattern Foo :: (OpenAlg r "foo" (FooF a) (OpenADT r))+-- > => a -> OpenADT r -> OpenADT r+-- > where FooF a v = VarF (IsJust (Label :: Label "foo") (FooF' a v))+-- > pattern Foo a v = Fix (FooF a v)+mkVarPattern :: Name -- ^ The 'Name' of the type to create patterns for.+ -> String -- ^ The label in the variant the constructor will have.+ -> String -- ^ The name of the fixed pattern.+ -> String -- ^ The name of the unfixed pattern.+ -> Q [Dec]+mkVarPattern tyName rowLabel pName pfName = do+ let patName = mkName pName+ let patFName = mkName pfName+ let rowLabelT = return $ LitT (StrTyLit rowLabel)++ TyConI dec <- reify tyName+ let (conBndrs, conArgTs, conName) = case dec of+ DataD _ _ tvs _ [NormalC n argTs] _ ->+ (tvs, fmap (return . snd) argTs, n)+ NewtypeD _ _ tvs _ (NormalC n argTs) _ ->+ (tvs, fmap (return . snd) argTs, n)+ _ -> error "Expected newtype or data declaration with one constructor."++ args <- replicateM (length conArgTs) (newName "a")++ let conTvs = fmap bndrToVar conBndrs+ -- Init should not fail because the types should be functors, thus+ -- always have > 0 variables+ let appliedTyCon = return $ foldl' AppT (ConT tyName) (init conTvs)+ let argsP = fmap VarP args+ let appliedConExp = return $ foldl' AppE (ConE conName) (fmap VarE args)+ let appliedPatF = return $ ConP patFName (fmap VarP args)+ let appliedConPat = return $ ConP conName (fmap VarP args)++ r <- newName "r" -- row type variable+ let tvV = return $ bndrToVar (last conBndrs) -- variant type variable+ let tvR = varT r+ let adtR = [t| Fix (VarF $tvR) |]++ let patBndrsF = PlainTV r : conBndrs+ let patBndrs = PlainTV r : conBndrs+ let patTypeCtxF = [t| ( OpenAlg $tvR $rowLabelT $appliedTyCon $tvV ) |]+ let patTypeCtx = [t| ( OpenAlg $tvR $rowLabelT $appliedTyCon $adtR+ , $tvV ~ $adtR ) |]+ let patRetTypeF = [t| VarF $tvR $tvV |]+ let patTypeTypeF = foldr funApp patRetTypeF conArgTs+ let patTypeType = foldr (\x a -> do+ x' <- x+ v' <- tvV+ if x' == v' then funApp adtR a else funApp x a+ ) adtR conArgTs++ patTypeF <- forallT patBndrsF ((: []) <$> patTypeCtxF) patTypeTypeF+ patType <- forallT patBndrs ((: []) <$> patTypeCtx) patTypeType++ patBody <-+ [p| VarF (view (Label :: Label $rowLabelT) -> Just $appliedConPat) |]++ patClause <- [| VarF (IsJust (Label :: Label $rowLabelT) $appliedConExp) |]++ fixedPatF <- [p| Fix $appliedPatF |]++ return+ [ PatSynSigD patFName patTypeF+ , PatSynD patFName+ (PrefixPatSyn args)+ (ExplBidir [Clause argsP (NormalB patClause) []])+ patBody+ , PatSynSigD patName patType+ , PatSynD patName (PrefixPatSyn args) ImplBidir fixedPatF+ ]++bndrName :: TyVarBndr -> Name+bndrName (PlainTV n ) = n+bndrName (KindedTV n _) = n++bndrToVar :: TyVarBndr -> Type+bndrToVar = VarT . bndrName++-- a -> b -> (a -> b)+funApp :: Q Type -> Q Type -> Q Type+funApp a b = appT (appT arrowT a) b
+ lib/Data/OpenADT/VarF.hs view
@@ -0,0 +1,215 @@+-- |+-- Module : Data.OpenADT.VarF+-- Copyright : Copyright (c) Jordan Woehr, 2018+-- License : BSD+-- Maintainer : Jordan Woehr+-- Stability : experimental+--+-- This module defines the 'VarF' type and related functions and instances.+-- This type wraps a variant of types that have all had the same type applied+-- to them. Most often this will be a variant constructed with a row of+-- functors.++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.OpenADT.VarF where++import Control.Arrow ( (+++) )+import Data.Constraint+import Data.Functor.Classes+import Data.Functor.Const+import Data.Functor.Product+import Data.Maybe ( fromMaybe )+import Data.Proxy+import Data.Row+import Data.Row.Internal+import Data.Row.Variants++-- | Apply a type to a 'Row'.+type family ApplyRow (x :: *) (r :: Row (* -> *)) :: Row * where+ ApplyRow x ('R lt) = 'R (ApplyLT x lt)++-- | Apply a type to each element of an 'LT'.+type family ApplyLT (x :: *) (r :: [LT (* -> *)]) :: [LT *] where+ ApplyLT _ '[] = '[]+ ApplyLT x (l ':-> f ': fs) = ((l ':-> f x) ': ApplyLT x fs)++-- | A newtype that wraps a variant. The variant is a row made up of+-- __(* -> *)__ that all have the type __x__ applied to them with 'ApplyRow'.+newtype VarF (r :: Row (* -> *)) x = VarF { unVarF :: Var (ApplyRow x r) }++deriving instance Forall (ApplyRow x r) Eq => Eq (VarF r x)+deriving instance Forall (ApplyRow x r) Show => Show (VarF r x)++-- | A helper for writing functions with 'metamorph''. This type reverses the+-- argument order of 'VarF' so the 'Row' parameter is last.+newtype VarF' x (r :: Row (* -> *)) = VarF' { unVarF' :: Var (ApplyRow x r) }++-- | A helper for writing functions with 'metamorph''. This type wraps an+-- __f a__ but takes the type arguments in the order __a f__.+newtype FlipApp (a :: *) (f :: * -> *) = FlipApp (f a)++-- | Apply a function to the variant within a 'VarF'.+--+-- @since 1.0.0+mapVarF :: (Var (ApplyRow x u) -> Var (ApplyRow x v)) -> VarF u x -> VarF v x+mapVarF f (VarF v) = VarF (f v)++-- | This function is useful for implementing functions that are used as+-- catamorphisms, and sometimes 'VarF' instances. The function applies its+-- first argument to whatever variant is wrapped by __VarF r x__ provided all+-- elements of the row __r__ are constrained by __c__.+--+-- For an example, see the 'Show1' instance implementation.+--+-- @since 1.0.0+varFAlg+ :: forall (c :: (* -> *) -> Constraint) (r :: Row (* -> *)) (x :: *) (y :: *)+ . (Forall r c)+ => (forall f . (c f) => f x -> y)+ -> VarF r x+ -> y+varFAlg f =+ getConst+ . metamorph' @_ @r @c @(VarF' x) @(Const y) @(FlipApp x) Proxy+ doNil+ doUncons+ doCons+ . VarF'+ . unVarF+ where+ doNil = impossible . unVarF'++ doUncons l = (FlipApp +++ VarF') . flip trial l . unVarF'++ doCons+ :: forall ℓ τ ρ+ . (c τ)+ => Label ℓ+ -> Either (FlipApp x τ) (Const y ( 'R ρ))+ -> Const y ( 'R (ℓ ':-> τ ': ρ))+ doCons _ (Left (FlipApp v)) = Const (f v)+ doCons _ (Right (Const y)) = Const y++-- | The same as 'varFAlg', but with the constraint fixed to 'Unconstrained1'.+--+-- @since 1.0.0+varFAlg'+ :: forall (r :: Row (* -> *)) (x :: *) (y :: *)+ . (Forall r Unconstrained1)+ => (forall f . (Unconstrained1 f) => f x -> y)+ -> VarF r x+ -> y+varFAlg' = varFAlg @Unconstrained1 @r @x @y++-- | RowFromTo fs b := for (l,a) in fs; SUM [ l :-> (a -> b) ]+type family RowFromTo (a :: Row *) (b :: *) :: Row * where+ RowFromTo ('R r) b = 'R (RowFromToR r b)++-- | 'RowFromTo' over a list of 'LT'.+type family RowFromToR (a :: [LT *]) (b :: *) :: [LT *] where+ RowFromToR '[] x = '[]+ RowFromToR (l ':-> a ': rs) b = l ':-> (a -> b) ': RowFromToR rs b++-- | Given a record of functions, use those functions to remove the+-- corresponding rows from the input. Type errors will ensue if the record+-- contains fields of the output variant.+--+-- @since 1.0.0+reduceVarF+ :: forall r s t x r' s' t'+ . ( t ≈ r .\\ s+ , r' ~ ApplyRow x r+ , s' ~ ApplyRow x s+ , s' ≈ r' .\\ t'+ , t' ≈ r' .\\ s'+ , Disjoint s' t'+ , Switch t' (RowFromTo t' (VarF s x)) (VarF s x)+ )+ => Rec (RowFromTo t' (VarF s x))+ -> VarF r x+ -> VarF s x+reduceVarF f (VarF v) = case multiTrial @t' @r' v of+ Left x -> caseon f x+ Right x -> VarF x++instance Forall r Functor => Functor (VarF r) where+ fmap :: forall a b. (a -> b) -> VarF r a -> VarF r b+ fmap f = VarF . unVarF' . go . VarF' . unVarF++ where+ go = metamorph' @_ @r @Functor @(VarF' a) @(VarF' b) @(FlipApp a)+ Proxy doNil doUncons doCons++ doNil = impossible . unVarF'++ doUncons l = (FlipApp +++ VarF') . flip trial l . unVarF'++ doCons :: forall l f s. (KnownSymbol l, Functor f)+ => Label l+ -> Either (FlipApp a f) (VarF' b ('R s))+ -> VarF' b ('R (l ':-> f ': s))+ doCons l (Left (FlipApp x)) = VarF' $ unsafeMakeVar l $ f <$> x+ doCons _ (Right (VarF' v)) = VarF' $ unsafeInjectFront v++instance Forall r Eq1 => Eq1 (VarF r) where+ liftEq :: forall a b. (a -> b -> Bool) -> VarF r a -> VarF r b -> Bool+ liftEq f (VarF x) (VarF y) = fromMaybe False $ getConst $ metamorph' @_ @r @Eq1+ @(Product (VarF' a) (VarF' b)) @(Const (Maybe Bool)) @(Const (Maybe Bool))+ Proxy doNil doUncons doCons (Pair (VarF' x) (VarF' y))++ where doNil :: Product (VarF' a) (VarF' b) Empty+ -> Const (Maybe Bool) (Empty :: Row (* -> *))+ doNil _ = Const Nothing++ doUncons :: forall ℓ τ ρ. (KnownSymbol ℓ, Eq1 τ)+ => Label ℓ+ -> Product (VarF' a) (VarF' b) ('R (ℓ ':-> τ ': ρ))+ -> Either (Const (Maybe Bool) τ)+ (Product (VarF' a) (VarF' b) ('R ρ))+ doUncons l (Pair (VarF' r1) (VarF' r2)) =+ case (trial r1 l, trial r2 l) of+ (Left u, Left v) -> Left $ Const $ Just $ liftEq f u v+ (Right u, Right v) -> Right $ Pair (VarF' u) (VarF' v)+ _ -> Left $ Const Nothing++ doCons :: forall ℓ (τ :: * -> *) ρ+ . Label ℓ+ -> Either (Const (Maybe Bool) τ) (Const (Maybe Bool) ('R ρ))+ -> Const (Maybe Bool) ('R (ℓ ':-> τ ': ρ))+ doCons _ (Left (Const w)) = Const w+ doCons _ (Right (Const w)) = Const w++instance Forall r Show1 => Show1 (VarF r) where+ liftShowsPrec ::+ forall a. (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> VarF r a -> ShowS+ liftShowsPrec sa sl p =+ let f :: forall f. (Show1 f) => f a -> ShowS+ f x = showParen (p > 10) (showString "VarF " . liftShowsPrec sa sl p x)+ in varFAlg @Show1 @r @a @ShowS f++-- | A type constraint synonym for convenience that can be used in, for+-- example, patterns. The variables __r__ (representing a Row) and __v__+-- (representing the type applied to __f__) are generally left abstract. The+-- variable __l__ is the label corresponding to __f v__.+--+-- The order of variables are in the same order as the equality constraint+-- in the synonym, making it easy to remember.+--+-- @since 1.0.0+type OpenAlg r l f v = ( ApplyRow v r .! l ≈ f v+ , AllUniqueLabels (ApplyRow v r)+ )
+ lib/Data/OpenADT/VariantsF.hs view
@@ -0,0 +1,96 @@+-- |+-- Module : Data.OpenADT.VariantsF+-- Copyright : Copyright (c) Jordan Woehr, 2018+-- License : BSD+-- Maintainer : Jordan Woehr+-- Stability : experimental+--+-- This module lifts functions from row-types on 'Var' to the 'VarF' type. All+-- functions in this module are named as their row-types version with an __F__+-- appended.++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Data.OpenADT.VariantsF where++import Control.Arrow ( (+++) )+import Data.String ( IsString )+import Data.Row+import Data.Row.Variants+import Data.Row.Internal ( Unconstrained1 )++import Data.OpenADT.VarF++-- | Like 'diversify' but specialised for 'VarF'.+--+-- @since 1.0.0+diversifyF+ :: forall r' x r+ . (ApplyRow x r .\/ ApplyRow x r' ≈ ApplyRow x (r .\/ r'))+ => VarF r x+ -> VarF (r .\/ r') x+diversifyF = mapVarF $ diversify @(ApplyRow x r') @(ApplyRow x r)++-- | Like 'trial' but specialised for 'VarF'.+--+-- @since 1.0.0+trialF+ :: (ApplyRow x r .- l ≈ ApplyRow x (r .- l), KnownSymbol l)+ => VarF r x+ -> Label l+ -> Either (ApplyRow x r .! l) (VarF (r .- l) x)+trialF v l = (id +++ VarF) (trial (unVarF v) l)++-- | Like 'multiTrial' but specialised for 'VarF'.+--+-- @since 1.0.0+multiTrialF+ :: forall u v x+ . ( ApplyRow x v .\\ ApplyRow x u ≈ ApplyRow x (v .\\ u)+ , AllUniqueLabels (ApplyRow x u)+ , Forall (ApplyRow x (v .\\ u)) Unconstrained1+ )+ => VarF v x+ -> Either (VarF u x) (VarF (v .\\ u) x)+multiTrialF = (VarF +++ VarF) . multiTrial . unVarF++-- | Like 'erase' but specialised for 'VarF'.+--+-- @since 1.0.0+eraseF+ :: forall c r x b+ . Forall (ApplyRow x r) c+ => (forall a . c a => a -> b)+ -> VarF r x+ -> b+eraseF f = snd @String . eraseWithLabelsF @c f++-- | Like 'eraseWithLabels' but specialised for 'VarF'.+--+-- @since 1.0.0+eraseWithLabelsF+ :: forall c r x s b+ . (Forall (ApplyRow x r) c, IsString s)+ => (forall a . c a => a -> b)+ -> VarF r x+ -> (s, b)+eraseWithLabelsF f = eraseWithLabels @c f . unVarF++-- | Like 'caseon' but specialised for 'VarF'.+--+-- @since 1.0.0+caseonF :: (Switch (ApplyRow x v) r y) => Rec r -> VarF v x -> y+caseonF r = caseon r . unVarF++-- | Like 'switch' but specialised for 'VarF'.+--+-- @since 1.0.0+switchF :: (Switch (ApplyRow x v) r y) => VarF v x -> Rec r -> y+switchF v = switch (unVarF v)
+ open-adt.cabal view
@@ -0,0 +1,62 @@+name: open-adt+version: 1.0+cabal-version: >= 1.10+category: Data+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: Copyright (c) 2018 Jordan Woehr+maintainer: Jordan Woehr+homepage: https://github.com/woehr/open-adt+bug-reports: https://github.com/woehr/open-adt/issues++synopsis: Open algebraic data types.++description: This library, built upon row-types, provides types and functions+ for variants of various functors that all have the same type+ applied to them. This is very similar to, and inspired by,+ <https://github.com/haskus/haskus-utils haskus-utils-variant>.+ At the time of writing, the compile-time performance of+ haskus-utils-variant is poor for variants with many fields, which+ should be improved in this package by using row-types.+ .+ The main types of interest in this package are 'VarF' and+ 'OpenADT'. 'VarF' wraps a variant of functors, all over the same+ type, and provides a functor instance that fmaps over whatever+ the variant is. 'OpenADT' is the fixed-point type of 'VarF',+ which allows for recursive structures to be created.+ .+ A convenience function, 'mkVarPattern' from 'Data.OpenADT.TH',+ generates patterns that can be used as constructors for variants.+ The key aspect of these patterns is that they are polymorphic+ in the type of the row, allowing them to be used as constructors+ for any open algebraic data type that includes a particular+ constructor.+ .+ For examples, see the 'Data.OpenADT.Tutorial' module.++tested-with: GHC == 8.2.1, GHC == 8.2.2,+ GHC == 8.4.1, GHC == 8.4.2, GHC == 8.4.3++source-repository head+ type: git+ location: https://github.com/woehr/open-adt++library+ build-depends: base >= 4.9 && < 5+ , constraints >= 0.8 && < 1+ , recursion-schemes >= 5 && < 6+ , row-types >= 0.2.3 && < 1+ , template-haskell >= 2.12 && < 3++ exposed-modules: Data.OpenADT+ Data.OpenADT.TH+ Data.OpenADT.VarF+ Data.OpenADT.VariantsF++ default-language: Haskell2010+ hs-source-dirs: lib+ ghc-options: -Wall+ -Wcompat+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates