module Data.Generics.Aliases (
-- * Combinators to \"make\" generic functions via cast
- mkT, mkQ, mkM, mkF, mkB,
- extT, extQ, extM, extF, extB,
+ mkT, mkQ, mkM, mkMp, mkB,
+ extT, extQ, extM, extMp, extB,
-- * Type synonyms for generic function types
GenericT,
orElse,
-- * Function combinators on generic functions
- recoverF,
+ recoverMp,
recoverQ,
- choiceF,
+ choiceMp,
choiceQ
) where
-- | Make a generic monadic transformation for MonadPlus;
-- use \"const mzero\" (i.e., failure) instead of return as default.
--
-mkF :: ( MonadPlus m,
- Typeable a,
- Typeable b,
- Typeable (m a),
- Typeable (m b)
- )
+mkMp :: ( MonadPlus m,
+ Typeable a,
+ Typeable b,
+ Typeable (m a),
+ Typeable (m b)
+ )
=> (b -> m b) -> a -> m a
-mkF = maybe (const mzero) id . cast
+mkMp = maybe (const mzero) id . cast
-- | Make a generic builder;
-- | Extend a generic MonadPlus transformation by a type-specific case
-extF :: ( MonadPlus m,
- Typeable a,
- Typeable b,
- Typeable (m a),
- Typeable (m b)
- )
+extMp :: ( MonadPlus m,
+ Typeable a,
+ Typeable b,
+ Typeable (m a),
+ Typeable (m b)
+ )
=> (a -> m a) -> (b -> m b) -> a -> m a
-extF = extM
+extMp = extM
-}
-- | Choice for monadic transformations
-choiceF :: MonadPlus m => GenericM m -> GenericM m -> GenericM m
-choiceF f g x = f x `mplus` g x
+choiceMp :: MonadPlus m => GenericM m -> GenericM m -> GenericM m
+choiceMp f g x = f x `mplus` g x
-- | Choice for monadic queries
-- | Recover from the failure of monadic transformation by identity
-recoverF :: MonadPlus m => GenericM m -> GenericM m
-recoverF f = f `choiceF` return
+recoverMp :: MonadPlus m => GenericM m -> GenericM m
+recoverMp f = f `choiceMp` return
-- | Recover from the failure of monadic query by a constant
-- * Generic maps defined in terms of gfoldl
gmapT,
gmapQ,
- gmapL,
+ gmapQl,
+ gmapQr,
gmapM,
- gmapF,
+ gmapMp,
-- * Generic unfolding defined in terms of gfoldl and fromConstr
gunfoldM -- :: Monad m => ... -> m a
{-
-The combinators gmapT, gmapQ, gmapL, gmapM, gmapF can all be defined
-in terms of gfoldl. We provide corresponding default definitions
-leaving open the opportunity to provide datatype-specific definitions.
+The combinators gmapT, gmapQ, gmapM, ... can all be defined in terms
+of gfoldl. We provide corresponding default definitions leaving open
+the opportunity to provide datatype-specific definitions.
(The inclusion of the gmap combinators as members of class Data allows
the programmer or the compiler to derive specialised, and maybe more
k (ID c) x = ID (c (f x))
- -- | A generic query with monoid-like operators
- gmapQ :: (r -> r -> r) -> r -> (forall a. Data a => a -> r) -> a -> r
- gmapQ o r f = unCONST . gfoldl k z
+ -- | A generic query with a left-associative binary operator
+ gmapQl :: (r -> r' -> r) -> r -> (forall a. Data a => a -> r') -> a -> r
+ gmapQl o r f = unCONST . gfoldl k z
where
k c x = CONST $ (unCONST c) `o` f x
z _ = CONST r
+{-
- -- | A generic query that processes the immediate subterms and returns a list
- gmapL :: (forall a. Data a => a -> u) -> a -> [u]
+In the definition of gmapQ? combinators, we use phantom type
+constructors for the "c" in the type of "gfoldl" because the result
+type of a query does not involve the (polymorphic) type of the term
+argument. In the definition of gmapQl we simply use the plain constant
+type constructor because gfoldl is left-associative anyway and so it
+is readily suited to fold a left-associative binary operation over the
+immediate subterms. In the definition of gmapQr, extra effort is
+needed. We use a higher-order accumulation trick to mediate between
+left-associative constructor application vs. right-associative binary
+operation (e.g., (:)). When the query is meant to compute a value of
+type r, then the result type withing generic folding is r -> r. So the
+result of folding is a function to which we finally pass the right
+unit.
- -- Use a phantom + function datatype constructor QL (see below),
- -- to instantiate the type constructor c in the type of gfoldl,
- -- and perform injections QL and projections unQL accordingly.
- --
- gmapL f x = unQL (gfoldl k (const (QL id)) x) []
+-}
+
+ -- | A generic query with a right-associative binary operator
+ gmapQr :: (r' -> r -> r) -> r -> (forall a. Data a => a -> r') -> a -> r
+ gmapQr o r f x = unQr (gfoldl k (const (Qr id)) x) r
where
- k (QL c) x = QL (\rs -> c (f x : rs))
+ k (Qr c) x = Qr (\r -> c (f x `o` r))
+
+ -- | A generic query that processes the immediate subterms and returns a list
+ gmapQ :: (forall a. Data a => a -> u) -> a -> [u]
+ gmapQ f = gmapQr (:) [] f
-- | A generic monadic transformation that maps over the immediate subterms
-- | Transformation of at least one immediate subterm does not fail
- gmapF :: MonadPlus m => (forall a. Data a => a -> m a) -> a -> m a
+ gmapMp :: MonadPlus m => (forall a. Data a => a -> m a) -> a -> m a
- -- Use a datatype constructor F (see below)
- -- to instantiate the type constructor c in the type of gfoldl.
- --
- gmapF f x = unFAIL (gfoldl k z x) >>= \(x',b) ->
- if b then return x' else mzero
+{-
+
+The type constructor that we use here simply keeps track of the fact
+if we already succeeded for an immediate subterm; see Mp below. To
+this end, we couple the monadic computation with a Boolean.
+
+-}
+
+ gmapMp f x = unMp (gfoldl k z x) >>= \(x',b) ->
+ if b then return x' else mzero
where
- z g = FAIL (return (g,False))
- k (FAIL c) x
- = FAIL ( c >>= \(h,b) ->
+ z g = Mp (return (g,False))
+ k (Mp c) x
+ = Mp ( c >>= \(h,b) ->
(f x >>= \x' -> return (h x',True))
`mplus` return (h x, b)
)
newtype ID x = ID { unID :: x }
--- | The constant type constructor needed for the definition of gmapQ
+-- | The constant type constructor needed for the definition of gmapQl
newtype CONST c a = CONST { unCONST :: c }
--- | A phantom datatype constructor used in definition of gmapL;
--- the function-typed component is needed to mediate between
--- left-associative constructor application vs. right-associative lists.
---
-newtype QL r a = QL { unQL :: [r] -> [r] }
+-- | The type constructor used in definition of gmapQr
+newtype Qr r a = Qr { unQr :: r -> r }
--- | A pairing type constructor needed for the definition of gmapF;
--- we keep track of the fact if a subterm was ever transformed successfully.
-newtype FAIL m x = FAIL { unFAIL :: m (x, Bool) }
+-- | The type constructor used in definition of gmapMp
+newtype Mp m x = Mp { unMp :: m (x, Bool) }
stringCon :: DataType -> String -> Maybe Constr
stringCon (DataType cs) str = worker cs
where
+ worker [] = Nothing
worker (c:cs) =
case c of
(DataConstr _ str' _) -> if str == str'
--
gmapT f [] = []
gmapT f (x:xs) = (f x:f xs)
- gmapL f [] = []
- gmapL f (x:xs) = [f x,f xs]
+-- gmapL f [] = []
+-- gmapL f (x:xs) = [f x,f xs]
gmapM f [] = return []
gmapM f (x:xs) = f x >>= \x' -> f xs >>= \xs' -> return (x':xs')
-- | Count the number of immediate subterms of the given term
glength :: GenericQ Int
-glength = length . gmapL (const ())
+glength = length . gmapQ (const ())
-- | Determine the number of all suitable nodes in a given term
-- at the root of the term. The transformation fails if "f" fails
-- everywhere, say succeeds nowhere.
--
-somewhere f x = f x `mplus` gmapF (somewhere f) x
+somewhere f x = f x `mplus` gmapMp (somewhere f) x
-- | Summarise all nodes in top-down, left-to-right order
everything :: (r -> r -> r) -> GenericQ r -> GenericQ r
-- Apply f to x to summarise top-level node;
--- use gmapL to recurse into immediate subterms;
+-- use gmapQ to recurse into immediate subterms;
-- use ordinary foldl to reduce list of intermediate results
--
everything k f x
- = foldl k (f x) (gmapL (everything k f) x)
+ = foldl k (f x) (gmapQ (everything k f) x)
-- | Get a list of all entities that meet a predicate
-- 3rd argument f updates the sythesised data according to the given term
--
synthesize :: s -> (s -> s -> s) -> GenericQ (s -> s) -> GenericQ s
-synthesize z o f x = f x (foldr o z (gmapL (synthesize z o f) x))
+synthesize z o f x = f x (foldr o z (gmapQ (synthesize z o f) x))
gshow = ( \t ->
"("
++ conString (toConstr t)
- ++ concat (gmapL ((++) " " . gshow) t)
+ ++ concat (gmapQ ((++) " " . gshow) t)
++ ")"
) `extQ` (show :: String -> String)
-- | The type constructor for gunfold a la ReadS from the Prelude;
-- we don't use lists here for simplicity but only maybes.
--
-newtype GRead a = GRead (String -> Maybe (a, String))
+newtype GRead a = GRead (String -> Maybe (a, String)) deriving Typeable
unGRead (GRead x) = x
-{-
+
-- | Turn GRead into a monad.
instance Monad GRead where
return x = GRead (\s -> Just (x, s))
(GRead f) >>= g = GRead (\s ->
maybe Nothing
(\(a,s') -> unGRead (g a) s')
- f s
+ (f s)
)
--}
+
+instance MonadPlus GRead where
+ mzero = GRead (\_ -> Nothing)
+ mplus = undefined
+
+
+-- | Special parsing operators
+trafo f = GRead (\s -> Just ((), f s))
+query f = GRead (\s -> if f s then Just ((), s) else Nothing)
+
-- | Generic read: an alternative to \"deriving Read\"
-gread :: GenericB Maybe
+gread :: Data a => String -> Maybe (a, String)
{-
This is a read operation which insists on prefix notation. (The
-Haskell 98 read deals with infix operators as well. We will be able to
-deal with such special cases as well as sonn as we include fixity
-information into the definition of "Constr".) We use gunfold to
-"parse" the input. To be precise, gunfold is used for all result types
-except String. The type-specific case for String uses basic String
-read. Another source of customisation would be to properly deal with
-infix operators subject to the capture of that information in the
-definition of Constr. The "gread" combinator properly checks the
-validity of constructors before invoking gunfold in order to rule
-out run-time errors.
+Haskell 98 read deals with infix operators subject to associativity
+and precedence as well.) We use gunfoldM to "parse" the input. To be
+precise, gunfoldM is used for all types except String. The
+type-specific case for String uses basic String read.
-}
-gread = undefined
-{-
-gdefault `extB` scase
+gread = unGRead gread'
where
- -- a specific case for strings
- scase s = case reads s of
- [x::(String,String)] -> Just x
- _ -> Nothing
-
- -- the generic default of gread
- gdefault s = undefined
-
--}
-
+ gread' :: GenericB GRead
+ gread' = gdefault `extB` scase
+
+ where
+
+ -- a specific case for strings
+ scase = GRead ( \s -> case reads s of
+ [x::(String,String)] -> Just x
+ _ -> Nothing
+ )
+
+ -- the generic default for gread
+ gdefault =
+ do
+ trafo $ dropWhile ((==) ' ')
+ query $ not . (==) ""
+ query $ (==) '(' . head
+ trafo $ tail
+ trafo $ dropWhile ((==) ' ')
+ str <- parseConstr
+ con <- str2con str
+ x <- gunfoldM con gread'
+ trafo $ dropWhile ((==) ' ')
+ query $ not . (==) ""
+ query $ (==) ')' . head
+ trafo $ tail
+ return x
+
+ where
+ -- Turn string into constructor driven by gdefault's type
+ str2con = maybe mzero return
+ .
+ ( stringCon -- look up constructor at hand
+ $ dataTypeOf -- get handle on all constructurs
+ $ undefinedType -- turn type value into undefined
+ $ paraType -- get a handle on a in m a
+ $ gdefault -- use as type argument
+ )
{-
+ foo =
do s' <- return $ dropWhile ((==) ' ') s
guard (not (s' == ""))
guard (head s' == '(')
- (c,s'') <- prefixConstr (dropWhile ((==) ' ') (tail s'))
+ (c,s'') <- parseConstr (dropWhile ((==) ' ') (tail s'))
u <- return undefined
dt <- return $ dataTypeOf u
case stringCon dt c of
- Nothing -> error "Generics: gread failed"
+ Nothing -> error "Data.Generics.String: gread failed"
Just c' ->
gunfoldm c' gread
guard (not (s''' == ""))
guard (head s''' == ')')
return (a, tail s''')
+-}
+ -- Get a Constr's string at the front of an input string
+ parseConstr :: GRead String
- -- To force two types to be the same
- constrainTypes :: a -> a -> ()
- constrainTypes _ _ = ()
-
- -- Argument f for unfolding
- f :: Data a => GRead (a -> b) -> GRead b
- f x = GRead (\s -> do (r,s') <- unGRead x s
- (t,s'') <- gread s'
- return (r t,s''))
-
- -- Argument z for unfolding
- z :: forall g. g -> GRead g
- z g = GRead (\s -> return (g,s))
-
+ parseConstr = GRead ( \s -> case s of
- -- Get Constr at front of string
- prefixConstr :: String -> Maybe (Constr, String)
+ -- Infix operators are prefixed in parantheses
+ ('(':s) -> case break ((==) ')') s of
+ (s'@(_:_),(')':s'')) -> Just ("(" ++ s' ++ ")", s'')
+ _ -> Nothing
- -- Assume an infix operators in parantheses
- prefixConstr ('(':s)
- = case break ((==) ')') s of
- (s'@(_:_),(')':s'')) -> Just (Constr ("(" ++ s' ++ ")"), s'')
- _ -> Nothing
+ -- Special treatment of multiple token constructors
+ ('[':']':s) -> Just ("[]",s)
- -- Special treatment of multiple token constructors
- prefixConstr ('[':']':s) = Just (Constr "[]",s)
+ -- Try lex for ordinary constructor and basic datatypes
+ s -> case lex s of
+ [(s'@(_:_),s'')] -> Just (s',s'')
+ _ -> Nothing
- -- Try lex for ordinary constructor and basic datatypes
- prefixConstr s
- = case lex s of
- [(s'@(_:_),s'')] -> Just (Constr s',s'')
- _ -> Nothing
+ )
--}
\ No newline at end of file
-- * Twin mapping combinators
tmapT,
- tmapQ,
+ tmapQl,
tmapM,
-- * Prime examples of twin traversal
tfoldl k z t xs ys = case gfoldl k' z' ys of { TWIN _ c -> c }
where
- l = gmapL (\x -> Generic' (t x)) xs
+ l = gmapQ (\x -> Generic' (t x)) xs
k' (TWIN (r:rs) c) y = TWIN rs (k c (unGeneric' r y))
z' f = TWIN l (z f)
z = ID
-tmapQ :: (r -> r -> r)
- -> r
- -> GenericQ (GenericQ r)
- -> GenericQ (GenericQ r)
-tmapQ o r f x y = unCONST $ tfoldl k z f' x y
+tmapQl :: (r -> r -> r)
+ -> r
+ -> GenericQ (GenericQ r)
+ -> GenericQ (GenericQ r)
+tmapQl o r f x y = unCONST $ tfoldl k z f' x y
where
f' x y = CONST $ f x y
k (CONST c) (CONST x) = CONST (c `o` x)
newtype ID x = ID { unID :: x }
--- The constant type constructor needed for the definition of tmapQ
+-- The constant type constructor needed for the definition of tmapQl
newtype CONST c a = CONST { unCONST :: c }
where
geq' :: forall a b. (Data a, Data b) => a -> b -> Bool
geq' x y = and [ (toConstr x == toConstr y)
- , tmapQ (\b1 b2 -> and [b1,b2]) True geq' x y
+ , tmapQl (\b1 b2 -> and [b1,b2]) True geq' x y
]
-- See if a is reachable from immediate subterms of a kind of b
recurse :: b -> Bool
recurse = or
- . gmapL ( typeReachableFrom a
+ . gmapQ ( typeReachableFrom a
. typeValOf
)
withType, -- :: a -> TypeVal a -> a
argType, -- :: (a -> b) -> TypeVal a
resType, -- :: (a -> b) -> TypeVal b
+ paraType, -- :: t a -> TypeVal a
TypeFun -- functions on types
) where
resType _ = typeVal
+-- | The parameter type of type constructor
+paraType :: t a -> TypeVal a
+paraType _ = typeVal
+
+
-- Type functions,
-- i.e., functions mapping types to values
--
projects / haskell-directory.git / commitdiff