module Data.Generics.Fixplate.Base where
import Control.Applicative
import Control.Monad (liftM)
import Data.Foldable
import Data.Traversable
import Prelude hiding (foldl,foldr,mapM,mapM_,concat,concatMap)
import Text.Show
import Text.Read
import Data.Generics.Fixplate.Misc
attribute :: Attr f a -> a
attribute = attr . unFix
forget :: Functor f => Attr f a -> Mu f
forget = Fix . fmap forget . unAnn . unFix
newtype Mu f = Fix { unFix :: f (Mu f) }
data Ann f a b = Ann { attr :: a , unAnn :: f b }
type Attr f a = Mu (Ann f a)
class EqF f where equalF :: Eq a => f a -> f a -> Bool
class EqF f => OrdF f where compareF :: Ord a => f a -> f a -> Ordering
class ShowF f where showsPrecF :: Show a => Int -> f a -> ShowS
class ReadF f where
#ifdef __GLASGOW_HASKELL__
readPrecF :: Read a => ReadPrec (f a)
#else
readsPrecF :: Read a => Int -> ReadS (f a)
#endif
instance EqF f => Eq (Mu f) where Fix x == Fix y = equalF x y
instance OrdF f => Ord (Mu f) where compare (Fix x) (Fix y) = compareF x y
instance ShowF f => Show (Mu f) where
showsPrec d (Fix x) = showParen (d>app_prec)
$ showString "Fix "
. showsPrecF (app_prec+1) x
instance ReadF f => Read (Mu f) where
#ifdef __GLASGOW_HASKELL__
readPrec = parens $
(prec app_prec $ do
{ Ident "Fix" <- lexP
; m <- step readPrecF
; return (Fix m)
})
#else
readsPrec d r = readParen (d > app_prec)
(\r -> [ (Fix m, t)
| ("Fix", s) <- lex r
, (m,t) <- readsPrecF (app_prec+1) s]) r
#endif
instance (Eq a, EqF f) => EqF (Ann f a) where
equalF (Ann a x) (Ann b y) = a == b && equalF x y
instance (Ord a, OrdF f) => OrdF (Ann f a) where
compareF (Ann a x) (Ann b y) = case compare a b of
LT -> LT
GT -> GT
EQ -> compareF x y
instance (Show a, ShowF f) => ShowF (Ann f a) where
showsPrecF d (Ann a t)
= showParen (d>app_prec)
$ showString "Ann "
. (showsPrec (app_prec+1) a)
. showChar ' '
. (showsPrecF (app_prec+1) t)
instance (Read a, ReadF f) => ReadF (Ann f a) where
#ifdef __GLASGOW_HASKELL__
readPrecF = parens $
(prec app_prec $ do
{ Ident "Ann" <- lexP
; x <- step readPrec
; m <- step readPrecF
; return (Ann x m)
})
#else
readsPrecF d r = readParen (d > app_prec)
(\r -> [ (Ann x m, u)
| ("Ann", s) <- lex r
, (x,t) <- readsPrec (app_prec+1) s]) r
, (m,u) <- readsPrecF (app_prec+1) t]) r
#endif
instance Functor f => Functor (Ann f a) where
fmap f (Ann attr t) = Ann attr (fmap f t)
instance Foldable f => Foldable (Ann f a) where
foldl f x (Ann _ t) = foldl f x t
foldr f x (Ann _ t) = foldr f x t
instance Traversable f => Traversable (Ann f a) where
traverse f (Ann x t) = Ann x <$> traverse f t
mapM f (Ann x t) = liftM (Ann x) (mapM f t)
newtype Attrib f a = Attrib { unAttrib :: Attr f a }
instance (ShowF f, Show a) => Show (Attrib f a) where
showsPrec d (Attrib x)
= showParen (d>app_prec)
$ showString "Attrib "
. (showsPrec (app_prec+1) x)
instance Functor f => Functor (Attrib f) where
fmap h (Attrib y) = Attrib (go y) where
go (Fix (Ann x t)) = Fix $ Ann (h x) (fmap go t)
instance Foldable f => Foldable (Attrib f) where
foldl h a (Attrib y) = go a y where go b (Fix (Ann x t)) = foldl go (h b x) t
foldr h a (Attrib y) = go y a where go (Fix (Ann x t)) b = h x (foldr go b t)
instance Traversable f => Traversable (Attrib f) where
traverse h (Attrib y) = Attrib <$> go y where
go (Fix (Ann x t)) = Fix <$> (Ann <$> h x <*> traverse go t)