{-# LANGUAGE CPP #-}

-- | The core types of Fixplate.
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

--------------------------------------------------------------------------------

-- | The attribute of the root node.
attribute :: Attr f a -> a
attribute = attr . unFix
  
-- | A function forgetting all the attributes from an annotated tree.
forget :: Functor f => Attr f a -> Mu f
forget = Fix . fmap forget . unAnn . unFix

--------------------------------------------------------------------------------

-- | The fixed-point type.
newtype Mu f = Fix { unFix :: f (Mu f) }

-- | Annotated functors.
data Ann f a b  =  Ann 
  { attr  :: a           -- ^ the annotation
  , unAnn :: f b         -- ^ the original functor
  }

-- | Annotated fixed-point type.
type Attr f a   =  Mu (Ann f a)

--------------------------------------------------------------------------------

-- | \"Functorised\" versions of standard type classes. 
-- If you have your a structure functor, for example
--
-- > Expr e 
-- >   = Kst Int 
-- >   | Var String 
-- >   | Add e e 
-- >   deriving (Eq,Ord,Read,Show,Functor,Foldable,Traversable)
--
-- you should make it an instance of these, so that the 
-- fixed-point type @Mu Expr@ can be an instance of
-- @Eq@, @Ord@ and @Show@. Doing so is very easy:
--
-- > instance EqF   Expr where equalF     = (==)
-- > instance OrdF  Expr where compareF   = compare
-- > instance ShowF Expr where showsPrecF = showsPrec
--
-- The @Read@ instance depends on whether we are using GHC or not.
-- The Haskell98 version is
--
-- > instance ReadF Expr where readsPrecF = readsPrec
--
-- while the GHC version is
--
-- > instance ReadF Expr where readPrecF  = readPrec
--
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
            
--------------------------------------------------------------------------------

-- | NOTE: The 'EqF' instance for annotations compares both the annotations and the original part. 
instance (Eq a, EqF f) => EqF (Ann f a) where 
  equalF (Ann a x) (Ann b y) = a == b && equalF x y

-- | NOTE: The 'OrdF' instance for annotations first compares the /annotations/, and then 
-- the functor part. If this is not the desired behaviour (it's not clear to me at the moment
-- what is the good default here), you can use the standard newtype trick to define a new
-- behaviour.
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)
 
--------------------------------------------------------------------------------

-- | A newtype wrapper around @Attr f a@ so that we can make @Attr f@ 
-- an instance of Functor, Foldable and Traversable. This is necessary
-- since Haskell does not allow partial application of type synonyms.
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)

--------------------------------------------------------------------------------