{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Generics.Text
-- Copyright   :  (c) The University of Glasgow, CWI 2001--2003
-- License     :  BSD-style (see the LICENSE file)
-- 
-- Maintainer  :  generics@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable (uses Data.Generics.Basics)
--
-- \"Scrap your boilerplate\" --- Generic programming in Haskell 
-- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module
-- provides generic operations for text serialisation of terms.
--
-----------------------------------------------------------------------------

module Data.Generics.Text (

    -- * Generic show
    gshow, gshows,

    -- * Generic read
    gread

 ) where

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

#ifdef __HADDOCK__
import Prelude
#endif
import Control.Monad
import Data.Data
import Data.Generics.Aliases
import Text.ParserCombinators.ReadP
import Text.Read.Lex

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


-- | Generic show: an alternative to \"deriving Show\"
--
-- @since 0.1.0.0
gshow :: Data a => a -> String
gshow :: forall a. Data a => a -> String
gshow a
x = a -> ShowS
forall a. Data a => a -> ShowS
gshows a
x String
""

-- | Generic shows
--
-- @since 0.2
gshows :: Data a => a -> ShowS

-- This is a prefix-show using surrounding "(" and ")",
-- where we recurse into subterms with gmapQ.
gshows :: forall a. Data a => a -> ShowS
gshows = ( \a
t ->
                Char -> ShowS
showChar Char
'('
              ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
showString (String -> ShowS) -> (a -> String) -> a -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constr -> String
showConstr (Constr -> String) -> (a -> Constr) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Constr
forall a. Data a => a -> Constr
toConstr (a -> ShowS) -> a -> ShowS
forall a b. (a -> b) -> a -> b
$ a
t)
              ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id ([ShowS] -> ShowS) -> (a -> [ShowS]) -> a -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Data a => a -> ShowS) -> a -> [ShowS]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
forall u. (forall d. Data d => d -> u) -> a -> [u]
gmapQ ((Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (ShowS -> ShowS) -> (d -> ShowS) -> d -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> ShowS
forall a. Data a => a -> ShowS
gshows) (a -> ShowS) -> a -> ShowS
forall a b. (a -> b) -> a -> b
$ a
t)
              ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
')'
         ) (a -> ShowS) -> (String -> ShowS) -> a -> ShowS
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (String -> ShowS
forall a. Show a => a -> ShowS
shows :: String -> ShowS)


-- | Generic read: an alternative to \"deriving Read\"
--
-- @since 0.1.0.0
gread :: Data a => ReadS a

{-

This is a read operation which insists on prefix notation.  (The
Haskell 98 read deals with infix operators subject to associativity
and precedence as well.) We use fromConstrM to "parse" the input. To be
precise, fromConstrM is used for all types except String. The
type-specific case for String uses basic String read.

-}

gread :: forall a. Data a => ReadS a
gread = ReadP a -> ReadS a
forall a. ReadP a -> ReadS a
readP_to_S ReadP a
forall a'. Data a' => ReadP a'
gread'

 where

  -- Helper for recursive read
  gread' :: Data a' => ReadP a'
  gread' :: forall a'. Data a' => ReadP a'
gread' = ReadP a'
allButString ReadP a' -> ReadP String -> ReadP a'
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
m a -> m b -> m a
`extR` ReadP String
stringCase

   where

    -- A specific case for strings
    stringCase :: ReadP String
    stringCase :: ReadP String
stringCase = ReadS String -> ReadP String
forall a. ReadS a -> ReadP a
readS_to_P ReadS String
forall a. Read a => ReadS a
reads

    -- Determine result type
    myDataType :: DataType
myDataType = a' -> DataType
forall a. Data a => a -> DataType
dataTypeOf (ReadP a' -> a'
forall a''. ReadP a'' -> a''
getArg ReadP a'
allButString)
     where
      getArg :: ReadP a'' -> a''
      getArg :: forall a''. ReadP a'' -> a''
getArg = ReadP a'' -> a''
forall a. HasCallStack => a
undefined

    -- The generic default for gread
    allButString :: ReadP a'
allButString =
      do
                -- Drop "  (  "
         ReadP ()
skipSpaces                     -- Discard leading space
         Char
_ <- Char -> ReadP Char
char Char
'('                  -- Parse '('
         ReadP ()
skipSpaces                     -- Discard following space

                -- Do the real work
         String
str  <- ReadP String
parseConstr            -- Get a lexeme for the constructor
         Constr
con  <- String -> ReadP Constr
str2con String
str            -- Convert it to a Constr (may fail)
         a'
x    <- (forall a'. Data a' => ReadP a') -> Constr -> ReadP a'
forall (m :: * -> *) a.
(Monad m, Data a) =>
(forall d. Data d => m d) -> Constr -> m a
fromConstrM ReadP d
forall a'. Data a' => ReadP a'
gread' Constr
con -- Read the children

                -- Drop "  )  "
         ReadP ()
skipSpaces                     -- Discard leading space
         Char
_ <- Char -> ReadP Char
char Char
')'                  -- Parse ')'
         ReadP ()
skipSpaces                     -- Discard following space

         a' -> ReadP a'
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return a'
x

    -- Turn string into constructor driven by the requested result type,
    -- failing in the monad if it isn't a constructor of this data type
    str2con :: String -> ReadP Constr
    str2con :: String -> ReadP Constr
str2con = ReadP Constr
-> (Constr -> ReadP Constr) -> Maybe Constr -> ReadP Constr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReadP Constr
forall a. ReadP a
forall (m :: * -> *) a. MonadPlus m => m a
mzero Constr -> ReadP Constr
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return
            (Maybe Constr -> ReadP Constr)
-> (String -> Maybe Constr) -> String -> ReadP Constr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataType -> String -> Maybe Constr
readConstr DataType
myDataType

    -- Get a Constr's string at the front of an input string
    parseConstr :: ReadP String
    parseConstr :: ReadP String
parseConstr =
               String -> ReadP String
string String
"[]"     -- Compound lexeme "[]"
          ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
<++  String -> ReadP String
string String
"()"     -- singleton "()"
          ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
<++  ReadP String
infixOp         -- Infix operator in parantheses
          ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
<++  ReadP String
hsLex           -- Ordinary constructors and literals

    -- Handle infix operators such as (:)
    infixOp :: ReadP String
    infixOp :: ReadP String
infixOp = do Char
c1  <- Char -> ReadP Char
char Char
'('
                 String
str <- (Char -> Bool) -> ReadP String
munch1 (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(==) Char
')')
                 Char
c2  <- Char -> ReadP Char
char Char
')'
                 String -> ReadP String
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ReadP String) -> String -> ReadP String
forall a b. (a -> b) -> a -> b
$ [Char
c1] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
c2]