diff --git a/Data/HList.hs b/Data/HList.hs --- a/Data/HList.hs +++ b/Data/HList.hs @@ -22,7 +22,7 @@ module Control.Monad, module Control.Monad.ST, module Control.Monad.Fix, - module GHC.IOBase, +-- module GHC.IOBase, -- module DeepNarrow, -- module Nominal, -- module New, @@ -48,7 +48,7 @@ import Control.Monad import Control.Monad.ST import Control.Monad.Fix -import GHC.IOBase hiding (stToIO, writeIORef, readIORef, newIORef, IORef,unsafeIOToST,unsafeSTToIO) +--import GHC.IOBase hiding (stToIO, writeIORef, readIORef, newIORef, IORef,unsafeIOToST,unsafeSTToIO) infixr 9 # (#) :: (HasField l r v) => r -> l -> v diff --git a/Data/HList/GhcSyntax.hs b/Data/HList/GhcSyntax.hs --- a/Data/HList/GhcSyntax.hs +++ b/Data/HList/GhcSyntax.hs @@ -27,6 +27,14 @@ type e :*: l = HCons e l +{-| + + (.*.) -- Add a field to a record. Analagous to (++) for + lists. + + record .*. field1 + .*. field2 +--} (.*.) :: HExtend e l l' => e -> l -> l' (.*.) = hExtend @@ -41,26 +49,95 @@ type l :=: v = LVPair l v infixr 4 .=. +{-| + + (.=.) -- Create a value with the given label. Analagous to a data + constructor such as 'Just', 'Left', or 'Right'. Higher fixity + than record-modification operations like (.*.), (.-.), etc. to + support expression like the below w/o parentheses: + + label1 .=. value1 .*. + label2 .=. value2 .*. + emptyRecord + +--} (.=.) :: l -> v -> LVPair l v l .=. v = newLVPair l v -infixr 3 .!. +infixr 9 .!. +{-| + (.!.) -- Lookup a value in a record, by its label. Analagous to (!!), the + list indexing operation. Highest fixity, like (!!). + + record1 .*. label1 .=. record2 .!. label1 + .*. label2 .=. record2 .!. label2 +--} (.!.) :: (HasField l r v) => r -> l -> v r .!. l = hLookupByLabel l r -infixl 1 .-. +infixl 2 .-. +{-| + (.-.) -- Remove a field from a record. At the same + level as other record modification options (.*.). Analagous + to (\\) in lists. + + record1 .-. label1 + + label1 .=. value1 .*. + label2 .=. value2 .-. + label2 .*. + emptyRecord + + label1 .=. value1 .-. + label1 .*. + label2 .=. value2 .*. + emptyRecord + + record1 .*. label1 .=. record2 .!. label1 + .*. label2 .=. record2 .!. label2 + .-. label1 +--} r .-. l = hDeleteAtLabel l r -infixl 1 .@. +infixl 2 .@. +{-| + (.@.) -- Update a field with a particular value. Another record-level + operation, so it has the same fixity as (.*.) and (.-.). No + real list analogue, since there is no Prelude defined + update. + + record1 .@. label1 .=. value1 + + record1 .@. label1 .=. record2 .!. label1 + + record1 .*. label1 .=. record2 .!. label1 + .*. label2 .=. record2 .!. label2 + .@. label1 .=. value2 +-} r .@. f@(LVPair v) = hUpdateAtLabel (labelLVPair f) v r -infixr 1 .^. +infixr 2 .^. +{-| + + (.^.) -- This is a variation on updating (according to GhcRecord.hs), + so use the same fixity as (.\@.). +-} f@(LVPair v) .^. r = hUnproxyLabel (labelLVPair f) v r -infixr 1 .<. +infixr 2 .<. +{-| + (.<.) -- Another variation on update, so give it the same fixity as (.\@.). + +-} f@(LVPair v) .<. r = hTPupdateAtLabel (labelLVPair f) v r -infixl 1 .<++. +infixl 2 .<++. +{-| + (.<++.) -- Similar to list append, so give this slightly lower fixity than + (.*.), so we can write: + + record1 .*. field1 .<++. record2 .*. field2 +-} r .<++. r' = hLeftUnion r r' @@ -73,6 +150,10 @@ type e :+: l = HCons (Proxy e) l +{-| + (.+.) -- Type-indexed rows append. Very similar to .*., so + keep the same fixity. +-} e .+. r = hExtend (toProxy e) r diff --git a/Data/HList/HListPrelude.hs b/Data/HList/HListPrelude.hs --- a/Data/HList/HListPrelude.hs +++ b/Data/HList/HListPrelude.hs @@ -268,7 +268,7 @@ instance HMap f HNil HNil where - hMap _ HNil = HNil + hMap _ _ = HNil instance ( Apply f x y, @@ -276,7 +276,7 @@ ) => HMap f (HCons x xs) (HCons y ys) where - hMap f (HCons x xs) = HCons (apply f x) (hMap f xs) + hMap f ~(HCons x xs) = HCons (apply f x) (hMap f xs) {-----------------------------------------------------------------------------} @@ -295,7 +295,7 @@ ) => HMapOut f (HCons e l) e' where - hMapOut f (HCons e l) = apply f e : hMapOut f l + hMapOut f ~(HCons e l) = apply f e : hMapOut f l {-----------------------------------------------------------------------------} diff --git a/Data/HList/Record.hs b/Data/HList/Record.hs --- a/Data/HList/Record.hs +++ b/Data/HList/Record.hs @@ -29,7 +29,7 @@ -- labels is erased. -- Field of label l with value type v -newtype LVPair l v = LVPair { valueLVPair :: v } +newtype LVPair l v = LVPair { valueLVPair :: v } deriving Eq -- Label accessor labelLVPair :: LVPair l v -> l @@ -38,7 +38,7 @@ newLVPair :: l -> v -> LVPair l v newLVPair _ = LVPair -newtype Record r = Record r +newtype Record r = Record r deriving Eq -- Build a record @@ -56,32 +56,57 @@ class HRLabelSet ps instance HRLabelSet HNil instance HRLabelSet (HCons x HNil) -instance ( HEq l1 l2 HFalse - , HRLabelSet (HCons (LVPair l2 v2) r) - , HRLabelSet (HCons (LVPair l1 v1) r) +instance ( HEq l1 l2 leq + , HRLabelSet' l1 v1 l2 v2 leq r ) => HRLabelSet (HCons (LVPair l1 v1) (HCons (LVPair l2 v2) r)) +class HRLabelSet' l1 v1 l2 v2 leq r +instance ( HRLabelSet (HCons (LVPair l2 v2) r) + , HRLabelSet (HCons (LVPair l1 v1) r) + ) => HRLabelSet' l1 v1 l2 v2 HFalse r +instance ( Fail (DuplicatedLabel l1) ) => HRLabelSet' l1 v1 l2 v2 HTrue r + {- instance (HZip ls vs ps, HLabelSet ls) => HRLabelSet ps -} class HLabelSet ls instance HLabelSet HNil -instance (HMember x ls HFalse, HLabelSet ls) - => HLabelSet (HCons x ls) +instance (HMember x ls xmem, HLabelSet' x ls xmem) => HLabelSet (HCons x ls) +class HLabelSet' x ls xmem +instance HLabelSet ls => HLabelSet' x ls HFalse +data DuplicatedLabel l = DuplicatedLabel l +instance Fail (DuplicatedLabel x) => HLabelSet' x ls HTrue + -- Construct the (phantom) list of labels of the record. --- This is a type-level only function +-- This is a purely type-level function. class RecordLabels r ls | r -> ls instance RecordLabels HNil HNil instance RecordLabels r' ls => RecordLabels (HCons (LVPair l v) r') (HCons l ls) -recordLabels :: RecordLabels r ls => r -> ls -recordLabels = undefined +recordLabels' :: RecordLabels r ls => r -> ls +recordLabels' r = undefined +recordLabels :: RecordLabels r ls => Record r -> ls +recordLabels (Record r) = recordLabels' r +-- Construct the list of values of the record. +class RecordValues r ls | r -> ls + where recordValues' :: r -> ls +instance RecordValues HNil HNil + where recordValues' _ = HNil +instance RecordValues r' vs + => RecordValues (HCons (LVPair l v) r') (HCons v vs) + where recordValues' ~(HCons (LVPair v) r') = HCons v (recordValues' r') + +recordValues :: RecordValues r vs => Record r -> vs +recordValues (Record r) = recordValues' r + + + {-----------------------------------------------------------------------------} -- A Show instance to appeal to normal records @@ -159,7 +184,7 @@ where hLookupByLabel l (Record r) = v where - ls = recordLabels r + ls = recordLabels' r n = hFind l ls (LVPair v) = hLookupByHNat n r @@ -201,7 +226,7 @@ -- Update operation hUpdateAtLabel l v (Record r) = Record r' where - n = hFind l (recordLabels r) + n = hFind l (recordLabels' r) r' = hUpdateAtHNat n (newLVPair l v) r @@ -305,7 +330,7 @@ where hLeftUnion (Record r) (Record (HCons f r')) = r'' where - b = hMember (labelLVPair f) (recordLabels r) + b = hMember (labelLVPair f) (recordLabels' r) r''' = hLeftUnionBool b r f r'' = hLeftUnion (Record r''') (Record r') @@ -380,4 +405,39 @@ ul' = hExtend f2 ul ur' = hExtend f2 ur +{-----------------------------------------------------------------------------} +-- Rearranges a record by labels. Returns the record r, rearranged such that +-- the labels are in the order given by ls. (recordLabels r) must be a +-- permutation of ls. +hRearrange :: (HLabelSet ls, HRearrange ls r r') => ls -> Record r -> Record r' +hRearrange ls (Record r) = Record $ hRearrange2 ls r +-- Helper class for hRearrange +class HRearrange ls r r' | ls r -> r' where + hRearrange2 :: ls -> r -> r' + +instance HRearrange HNil HNil HNil where + hRearrange2 _ _ = HNil + +instance (H2ProjectByLabels (HCons l HNil) r rin rout, + HRearrange' l ls rin rout r') => + HRearrange (HCons l ls) r r' where + hRearrange2 ~(HCons l ls) r = hRearrange2' l ls rin rout + where (rin, rout) = h2projectByLabels (HCons l HNil) r + +-- Helper class 2 for hRearrange +class HRearrange' l ls rin rout r' | l ls rin rout -> r' where + hRearrange2' :: l -> ls -> rin -> rout -> r' +instance HRearrange ls rout r' => + HRearrange' l ls (HCons (LVPair l v) HNil) rout (HCons (LVPair l v) r') where + hRearrange2' _ ls (HCons lv@(LVPair v) HNil) rout = HCons (LVPair v `asTypeOf` lv) (hRearrange2 ls rout) + +data ExtraField l = ExtraField +data FieldNotFound l = FieldNotFound + +instance Fail (FieldNotFound l) => + HRearrange' l ls HNil rout (FieldNotFound l) where + hRearrange2' _ _ _ _ = FieldNotFound +instance Fail (ExtraField l) => + HRearrange HNil (HCons (LVPair l v) a) (ExtraField l) where + hRearrange2 _ _ = ExtraField diff --git a/Data/HList/Variant.hs b/Data/HList/Variant.hs --- a/Data/HList/Variant.hs +++ b/Data/HList/Variant.hs @@ -65,7 +65,7 @@ mkVariant x y (Record v) = Variant v' where - n = hFind x (recordLabels v) + n = hFind x (recordLabels' v) ms = hMaybied v v' = hUpdateAtHNat n (newLVPair x (Just y)) ms @@ -82,7 +82,7 @@ unVariant x (Variant v) = y where - n = hFind x (recordLabels v) + n = hFind x (recordLabels' v) LVPair y = hLookupByHNat n v diff --git a/HList.cabal b/HList.cabal --- a/HList.cabal +++ b/HList.cabal @@ -1,5 +1,5 @@ Name: HList -Version: 0.1.1 +Version: 0.2 Category: Data Synopsis: Heterogeneous lists Description: HList is a record system providing strongly typed heterogenous lists, records, @@ -10,7 +10,7 @@ Keean Schupke (Imperial College, London) Maintainer: oleg@pobox.com -Data-files: README, keyword-arguments.lhs +Data-files: README Cabal-version: >= 1.4 Tested-With: GHC==6.8.2 Build-Depends: base >= 3 && < 5 diff --git a/README b/README --- a/README +++ b/README @@ -13,10 +13,10 @@ $ darcs get --partial http://darcs.haskell.org/HList/ The code works --- within the limits exercised in the source files --- -for both GHC (6.4) and Hugs (Nov 2003). See the Makefile for ways of -running test cases. +for both GHC (6.4) and Hugs (Nov 2003). See the +examples/Makefile for ways of running test cases. -One may run "make test" to check the distribution. +One may run "cd examples; make test" to check the distribution. -Last updated; February 08, 2006 +See ChangeLog for updates. diff --git a/keyword-arguments.lhs b/keyword-arguments.lhs deleted file mode 100644 --- a/keyword-arguments.lhs +++ /dev/null @@ -1,440 +0,0 @@ -From oleg-at-okmij.org Fri Aug 13 14:58:35 2004 -To: haskell@haskell.org -Subject: Keyword arguments -From: oleg-at-pobox.com -Message-ID: <20040813215834.F1FF3AB7E@Adric.metnet.navy.mil> -Date: Fri, 13 Aug 2004 14:58:34 -0700 (PDT) -Status: OR - - -We show the Haskell implementation of keyword arguments, which goes -well beyond records (e.g., in permitting the re-use of -labels). Keyword arguments indeed look just like regular, positional -arguments. However, keyword arguments may appear in any -order. Furthermore, one may associate defaults with some keywords; the -corresponding arguments may then be omitted. It is a type error to -omit a required keyword argument. The latter property is in stark -contrast with the conventional way of emulating keyword arguments via -records. Also in marked contrast with records, keyword labels may be -reused throughout the code with no restriction; the same label may be -associated with arguments of different types in different -functions. Labels of Haskell records may not be re-used. Our solution -is essentially equivalent to keyword arguments of DSSSL Scheme or -labels of OCaml. - -Keyword argument functions are naturally polyvariadic: Haskell does -support varargs! Keyword argument functions may be polymorphic. As -usual, functions with keyword arguments may be partially applied. On -the downside, sometimes one has to specify the type of the return -value of the function (if the keyword argument function has no -signature -- the latter is the norm, see below) -- provided that the -compiler cannot figure the return type out on its own. This is usually -only the case when we use keyword functions at the top level (GHCi -prompt). - -Our solution requires no special extensions to Haskell and works with -the existing Haskell compilers; it is tested on GHC 6.0.1. The -overlapping instances extension is not necessary (albeit it is -convenient). - -The gist of our implementation is the realization that the type of a -function is a polymorphic collection of its argument types -- a -collection that we can traverse. This message thus illustrates a -limited form of the reflection on a function. - - -Our implementation is a trivial extension of the strongly-typed -polymorphic open records described in - http://homepages.cwi.nl/~ralf/HList/ - -In fact, the implementation relies on the HList library. To run the -code (which this message is), one needs to download the HList library -from the above site. - -The HList paper discusses the issue of labels in some detail. The -paper gives three different representations. One of them needs no -overlapping instances and is very portable. In this message, we chose -a representation that relies on generic type equality and therefore -needs overlapping instances as implemented in GHC. Again, this is -merely an outcome of our non-deterministic choice. It should be -emphasized that other choices are possible, which do not depend on -overlapping instances at all. Please see the HList paper for details. - -> {-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-} -> {-# OPTIONS -fallow-overlapping-instances #-} -> -> module KW where -> -> import FakePrelude hiding (TypeEq,typeEq,proxyEq,TypeCast,typeCast) -> import TypeEqGeneric2 -> import TypeCastGeneric2 -> import HListPrelude - - -We will be using an example inspired by a graphics toolkit -- the area -which really benefits from keyword arguments. We first define our -labels and useful datatypes - -> data Color = Color -> data Size = Size -> data Origin = Origin -> data RaisedBorder = RaisedBorder -> -> data CommonColor = Red | Green | Blue deriving Show -> data RGBColor = RGBColor Int Int Int deriving Show - -and two functions: - -> make_square Size n Origin (x0,y0) Color (color::CommonColor) = -> unwords ["Square:", show n, "at", show (x0,y0), show color] ++ "\n" -> -> make_rect Size (nx,ny) Origin (x0,y0) Color (color::RGBColor) -> RaisedBorder border = -> unwords ["Rectangle:", show (nx,ny), "at", show (x0,y0), -> show color, if border then "raised border" else ""] ++ "\n" - - -We are not interested in really drawing squares and rectangles -here. Therefore, make_square and make_rect return a String, which we -can regard as a ``command'' to be passed to a low-level graphics -library. The functions make_square and make_rect are genuine functions -and can be used as such. They are not keyword argument functions, yet, -but they set the stage. These functions can be considered an -`interface' for the keyword argument functions. We should note that -the functions are polymorphic: for example, `Size' can be any -showable. We must also emphasize the re-use of the labels: The Color -of a square is the value of the enumerated type CommonColor. OTH, the -color of the rectangle is given as an RGB triple. The sizes of the -square and of the rectangle are specified differently too, the same -label notwithstanding. - -Once the user wrote the functions such as make_square and make_rect, -he can _automatically_ convert them to their keyword -alternatives. This transformation is done by a function 'kw'. The user -should pass the positional-argument function (`labeled' as above), -and an HList of default values for some of the labels. The latter may -be HNil if all keyword arguments are required. - -The first example (no defaults) - -> tests1 :: String = -> kw make_square HNil Size (1::Int) Origin (0::Int,10::Int) Color Red - -we can permute the arguments at wish - -> tests2 :: String = -> kw make_square HNil Color Red Size (1::Int) Origin (0::Int,10::Int) - -we can also assign a name to a keyword function, or partially apply it: - -> tests3 = let f x = kw make_square HNil Color Red x -> in "here: " ++ f Origin (0::Int,10::Int) Size (1::Int) - -The dummy argument 'x' is merely to avoid the monomorphic -restriction. The following is a more interesting example, with the -defaults: - -> tests4 = let defaults = Origin .*. (0::Int,10::Int) .*. -> RaisedBorder .*. True .*. -> HNil -> in kw make_square defaults Size (1::Int) Color Red ++ -> kw make_rect defaults Color (RGBColor 0 10 255) -> Size (1.0::Float, 2.0::Float) - -The argument RaisedBorder is not given, and so the default value is -used. Of course, we can override the default: - -> tests5 = let defaults = Origin .*. (0::Int,10::Int) .*. -> RaisedBorder .*. True .*. -> HNil -> sq x = kw make_square defaults Color x -> re x = kw make_rect defaults x -> in sq Red Size (1::Int) ++ -> re Color (RGBColor 0 10 255) -> RaisedBorder False -> Size (1.0::Float, 2.0::Float) - -We have reshuffled a few arguments, just for fun. As you can see, the -function `kw make_rect defaults' is polyvariadic indeed. We chose to -partially apply 'Color' to the function `kw make_square defaults' -- -so that the function `sq' is positional in its first argument, and -keyword in the rest. - -If we omit a required argument, we get a type error: - -] testse1 = let f x = kw make_square HNil Color Red x -] in "here: " ++ f Origin (0::Int,10::Int) - - Couldn't match `ErrReqdArgNotFound Size' against `[Char]' - Expected type: ErrReqdArgNotFound Size - Inferred type: [Char] ... - -The error message seems reasonably clear. Likewise we get an error -message if we pass to a keyword function an argument it does not expect: - -] testse2 = let f x = kw make_square HNil Color Red x -] in "here: " ++ f Origin (0::Int,10::Int) Size (1::Int) -] RaisedBorder False - - No instances for (Fail (ErrUnexpectedKW RaisedBorder), - KWApply [Char] (HCons RaisedBorder (:*: Bool HNil)) [Char]) - arising from use of `f' at ... - In the second argument of `(++)', namely - `f Origin (0 :: Int, 10 :: Int) Size (1 :: Int) RaisedBorder False' - - -The function 'kw' receives the appropriately labeled function (such -as make_square) and the HList with default values. The function 'kw' -is polymorphic; the overloading is resolved based on the type of the -user function *and* on the type of its continuation. The continuation -indicates if a keyword argument is forthcoming, or not. In the latter -case, 'kw' checks to see if the supplied defaults can provide the -values of the still missing arguments. We see therefore that a -function type is more than it may appear -- the type of a function is -truly a heterogeneous, type level collection! The function 'kw' -traverses that collection, thus performing a limited form of -reflection on Haskell functions. - - -Implementation Outline - -One of the key tools of the implementation is 'kwapply', which applies -a function to a polymorphic collection of that function's arguments. -The order of the arguments in the collection is irrelevant. The -contraption kwapply can handle polymorphic functions with arbitrary -number of labeled arguments. - -For example, if we define - -> f1 Size n = show n -> f2 Size n Color m = unwords ["size:", show n, "color:", show m] -> f3 Origin x Color m Size n = -> unwords ["origin:", show x, "size:", show n, "color:",show m] - -then we can run - -> katest1 = kwapply f1 (Size .*. () .*. HNil) -> katest11 = kwapply f1 (Size .*. "Large" .*. HNil) -> -> katest2 = kwapply f2 (Size .*. (1::Int) .*. Color .*. Red .*. HNil) -> katest21 = kwapply f2 (Color .*. Red .*. Size .*. (1::Int) .*. HNil) -> -> katest3 = kwapply f3 (Size .*. (1::Int) .*. Origin .*. (2.0::Float) .*. -> Color .*. Red .*. HNil) - -Another key contraption is - -> reflect_fk:: (ReflectFK fn kws) => fn -> Arg kws HNil -> reflect_fk _ = Arg HNil - -that reflects on a user-supplied function. It converts the *type* of a -user function to a collection of keywords required by that -function. This and the previous contraptions may be used to define an -`extended' version of some user function that takes more arguments -- -without the need to enumerate all arguments of the original -function. We thus infringe on the area of object and module systems. - -The rest of the implementation is just to convert `kw fn defaults' -into the application of kwapply. - - - -The rest of the implementation - -We should note that all implementation is written in the -continuation-passing style (CPS) -- at the term level and especially -at the _typeclass level_. One of the reasons is to avoid relying on -overlapping instances: we compare types with a predicate `TypeEq x y -hbool', obtain the type-level boolean, and dispatch to two -non-overlapping instances of an auxiliary, continuation class. One -instance handles HTrue, and the other the HFalse alternative. Please -see the HList paper for more discussion of this technique. - -The other, equally important reason for the thorough CPS of the -typeclasses is to control the order of evaluation of constraints and -their functional dependencies. The sole reason is to produce -informative error messages. The order of constraints is irrelevant -when all the constraints are satisfied. However, if the user omitted a -required keyword, many of the constraints below will fail. If a -'wrong' constraint fails first, we get a totally off-the-wall error -message that gives us no clue whatsoever about the problem. By tightly -constraining the order via CPS, we are able to force the typechecker -to give informative error messages. - - -Preliminaries - -> -- A bit of syntax sugar for HLists -> infixr 1 :*: -> infixr 1 .*. -> type e :*: l = HCons e l -> (.*.) = HCons - - -Errors - -> data ErrReqdArgNotFound x -> data ErrUnexpectedKW x -> data Trace x - -All our keywords must be registered - -> class IsKeyFN t flag | t-> flag -> instance IsKeyFN (Color->a->b) HTrue -> instance IsKeyFN (Size->a->b) HTrue -> instance IsKeyFN (Origin->a->b) HTrue -> instance IsKeyFN (RaisedBorder->a->b) HTrue -> instance TypeCast HFalse flag => IsKeyFN t flag - -The implementation of KWApply - -> class KWApply f arg_values r | f arg_values -> r where -> kwapply:: f -> arg_values -> r -> -> instance KWApply r HNil r where -> kwapply f _ = f -> -> instance (TypeEq kw kw' flag, -> KWApply' flag (kw->a->f') (kw' :*: a' :*: tail) r) -> => KWApply (kw->a->f') (kw' :*: a' :*: tail) r where -> kwapply = kwapply' (undefined::flag) -> -> class KWApply' flag f arg_values r | flag f arg_values -> r where -> kwapply':: flag -> f -> arg_values -> r -> -> instance (TypeCast v' v, KWApply f' tail r) -> => KWApply' HTrue (kw->v->f') (kw :*: v' :*: tail) r where -> kwapply' _ f (HCons kw (HCons v' tail)) = -> kwapply (f kw (typeCast v')) tail -> -> -- Rotate the arg list ... -> instance (HAppend tail (kw :*: v :*: HNil) l', -> KWApply f l' r) -> => KWApply' HFalse f (kw :*: v :*: tail) r where -> kwapply' _ f (HCons kw (HCons v tail)) = -> kwapply f (hAppend tail (kw .*. v .*. HNil)) - -The datatype Arg below is to maintain the state of keyword -accumulation: which keywords we need, and which keyword and values we -have already got. -arg_types is the phantom HList of keywords that are yet to be satisfied. -arg_values is the HList (kw .*. kw_value .*. etc) -of already found keywords and their values. - -> newtype Arg arg_types arg_values = Arg arg_values deriving Show - -Reflection on a function: -Given a function, return the type list of its keywords - -> class ReflectFK f kws | f -> kws -> instance (IsKeyFN f flag, ReflectFK' flag f kws) => ReflectFK f kws -> class ReflectFK' flag f kws | flag f -> kws -> instance ReflectFK rest kws => ReflectFK' HTrue (kw->a->rest) (HCons kw kws) -> instance ReflectFK' HFalse f HNil - --- :t reflect_fk (undefined::Size->Int->Color->CommonColor->String) --- :t reflect_fk (undefined::Size->Int->()->Int) - -The main class: collect and apply the keyword arguments - -> class KW f arg_desc arg_def r where -> kwdo :: f -> arg_desc -> arg_def -> r -> -> instance (IsKeyFN r rflag, -- Fail (Trace (arg_desc,r)), -> KW' rflag f arg_desc arg_def r) -> => KW f arg_desc arg_def r where -> kwdo = kw' (undefined::rflag) -> -> class KW' rflag f arg_desc arg_def r where -> kw' :: rflag -> f -> arg_desc -> arg_def -> r - -If the continuation r does not promise any more keyword -arguments, apply the defaults - -> instance KWMerge arg_needed arg_values arg_def f r -> => KW' HFalse f (Arg arg_needed arg_values) arg_def r where -> kw' _ f args_given arg_def = kwmerge args_given arg_def f - -Otherwise, collect the supplied keyword and its value, and recurse for -more: - -> instance KWAcc arg_desc kw a f arg_def r -> => KW' HTrue f arg_desc arg_def (kw->a->r) where -> kw' _ f arg_desc arg_def kw a = kwaccum arg_desc kw a f arg_def - - -Add the needed arguments from arg_def to arg_values and continue -with kwapply. -That is, we try to satisfy the missing arguments from the defaults. -It will be a type error if some required arguments are missing - -> class KWMerge arg_needed arg_values arg_def f r | -> arg_needed arg_values arg_def f -> r where -> kwmerge:: Arg arg_needed arg_values -> arg_def -> f -> r -> -> instance KWApply f arg_values r -> => KWMerge HNil arg_values arg_def f r where -> kwmerge (Arg arg_values) _ f = kwapply f arg_values -> -> instance KWMerge' kw arg_def atail arg_values arg_def f r -> => KWMerge (HCons kw atail) arg_values arg_def f r where -> kwmerge (Arg arg_values) arg_def = -> kwmerge' (undefined::kw) arg_def -> ((Arg arg_values)::Arg atail arg_values) arg_def -> -> class KWMerge' kw list atail arg_values arg_def f r | -> kw list atail arg_values arg_def f -> r where -> kwmerge':: kw -> list -> (Arg atail arg_values) -> arg_def -> f -> r -> -> instance Fail (ErrReqdArgNotFound kw) -> => KWMerge' kw HNil atail arg_values arg_def f -> (ErrReqdArgNotFound kw) where -> kwmerge' = undefined -> instance (TypeEq kw kw' flag, -> KWMerge'' flag kw (kw' :*: etc) atail arg_values arg_def f r) -> => KWMerge' kw (kw' :*: etc) atail arg_values arg_def f r where -> kwmerge' = kwmerge'' (undefined::flag) -> -> class KWMerge'' flag kw list atail arg_values arg_def f r | -> flag kw list atail arg_values arg_def f -> r where -> kwmerge'':: flag -> kw -> list -> (Arg atail arg_values) -> arg_def -> -> f -> r -> instance KWMerge atail (kw :*: v :*: arg_values) arg_def f r -> => KWMerge'' HTrue kw (kw :*: v :*: tail) -> atail arg_values arg_def f r where -> kwmerge'' _ _ (HCons kw (HCons v _)) (Arg arg_values) = -> kwmerge ((Arg (kw .*. v .*. arg_values)):: -> (Arg atail (kw :*: v :*: arg_values))) -> instance KWMerge' kw tail atail arg_values arg_def f r -> => KWMerge'' HFalse kw (kw' :*: v' :*: tail) -> atail arg_values arg_def f r where -> kwmerge'' _ kw (HCons _ (HCons _ tail)) = kwmerge' kw tail - -Add the real argument to the Arg structure, and continue - -> class KWAcc arg_desc kw a f arg_def r where -> kwaccum:: arg_desc -> kw -> a -> f -> arg_def -> r -> -> instance (HDelete kw arg_types arg_types', -> KW f (Arg arg_types' (kw :*: a :*: arg_values)) arg_def r) -> => KWAcc (Arg arg_types arg_values) kw a f arg_def r where -> kwaccum (Arg arg_values) kw a f = -> kwdo f (Arg (kw .*. a .*. arg_values):: -> Arg arg_types' (kw :*: a :*: arg_values)) - -Delete e from l to yield l' The element e must occur in l - -> class HDelete e l l' | e l -> l' -> instance Fail (ErrUnexpectedKW e) => HDelete e HNil HNil -> instance (TypeEq e e' flag, HDelete' flag e (HCons e' tail) l') -> => HDelete e (HCons e' tail) l' -> class HDelete' flag e l l' | flag e l -> l' -> instance HDelete' HTrue e (HCons e tail) tail -> instance HDelete e tail tail' -> => HDelete' HFalse e (HCons e' tail) (HCons e' tail') - -Finally, - -> kw f = kwdo f (reflect_fk f) - -