Data/Generics/Strings.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Data.Generics.Strings
   4 -- Copyright   :  (c) The University of Glasgow, CWI 2001--2003
   5 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  experimental
   9 -- Portability :  non-portable
  10 --
  11 -- "Scrap your boilerplate" --- Generic programming in Haskell
  12 -- See <http://www.cs.vu.nl/boilerplate/>.
  13 --
  14 -----------------------------------------------------------------------------
  15
  16 module Data.Generics.Strings (
  17
  18         -- * Generic operations for string representations of terms
  19         gshow,
  20         gread
  21
  22  ) where
  23
  24 ------------------------------------------------------------------------------
  25
  26 import Control.Monad
  27 import Data.Maybe
  28 import Data.Typeable
  29 import Data.Generics.Basics
  30 import Data.Generics.Aliases
  31
  32
  33
  34 -- | Generic show: an alternative to \"deriving Show\"
  35 gshow :: Data a => a -> String
  36
  37 -- This is a prefix-show using surrounding "(" and ")",
  38 -- where we recurse into subterms with gmapQ.
  39 --
  40 gshow = ( \t ->
  41                 "("
  42              ++ conString (toConstr t)
  43              ++ concat (gmapQ ((++) " " . gshow) t)
  44              ++ ")"
  45         ) `extQ` (show :: String -> String)
  46
  47
  48 -- | The type constructor for gunfold a la ReadS from the Prelude;
  49 --   we don't use lists here for simplicity but only maybes.
  50 --
  51 newtype GRead a = GRead (String -> Maybe (a, String)) deriving Typeable
  52 unGRead (GRead x) = x
  53
  54
  55 -- | Turn GRead into a monad.
  56 instance Monad GRead where
  57   return x = GRead (\s -> Just (x, s))
  58   (GRead f) >>= g = GRead (\s ->
  59                              maybe Nothing
  60                                    (\(a,s') -> unGRead (g a) s')
  61                                    (f s)
  62                           )
  63
  64 instance MonadPlus GRead where
  65  mzero = GRead (\_ -> Nothing)
  66  mplus = undefined
  67
  68
  69 -- | Special parsing operators
  70 trafo f = GRead (\s -> Just ((), f s))
  71 query f = GRead (\s -> if f s then Just ((), s) else Nothing)
  72
  73
  74 -- | Generic read: an alternative to \"deriving Read\"
  75 gread :: Data a => String -> Maybe (a, String)
  76
  77 {-
  78
  79 This is a read operation which insists on prefix notation.  (The
  80 Haskell 98 read deals with infix operators subject to associativity
  81 and precedence as well.) We use gunfoldM to "parse" the input. To be
  82 precise, gunfoldM is used for all types except String. The
  83 type-specific case for String uses basic String read.
  84
  85 -}
  86
  87
  88 gread = unGRead gread'
  89
  90  where
  91
  92   gread' :: Data a => GRead a
  93   gread' = gdefault `extB` scase
  94
  95    where
  96
  97     -- a specific case for strings
  98     scase :: GRead String
  99     scase = GRead ( \s -> case reads s of
 100                             [x::(String,String)] -> Just x
 101                             _ -> Nothing
 102                   )
 103
 104     -- the generic default for gread
 105     gdefault :: Data a => GRead a
 106     gdefault =
 107       do
 108                 -- Drop "    (   "
 109         trafo $  dropWhile ((==) ' ')           -- Discard leading space
 110         query $  not . (==) ""                  -- Check result is not empty
 111         query $  (==) '(' . head                -- ...and that it begins with (
 112         trafo $  tail                           -- Discard the '('
 113         trafo $  dropWhile ((==) ' ')           -- ...and following white space
 114
 115                 -- Do the real work
 116         str   <- parseConstr                    -- Get a lexeme for the constructor
 117         con   <- str2con str                    -- Convert it to a Constr (may fail)
 118         x     <- gunfoldM con gread'            -- Read the children
 119
 120                 -- Drop "    )"
 121         trafo $  dropWhile ((==) ' ')
 122         query $  not . (==) ""
 123         query $  (==) ')' . head
 124         trafo $  tail
 125         return x
 126
 127      where
 128        get_data_type :: GRead a -> DataType
 129        get_data_type (thing :: GRead a) = dataTypeOf (typeVal::a)
 130
 131        str2con :: String -> GRead Constr
 132         -- Turn string into constructor driven by gdefault's type,
 133         -- failing in the monad if it isn't a constructor of this data type
 134        str2con = maybe mzero return . stringCon (get_data_type gdefault)
 135
 136 {-
 137   foo =
 138     do s' <- return $ dropWhile ((==) ' ') s
 139        guard (not (s' == ""))
 140        guard (head s' == '(')
 141        (c,s'')  <- parseConstr (dropWhile ((==) ' ') (tail s'))
 142        u  <- return undefined
 143        dt <- return $ dataTypeOf u
 144        case stringCon dt c of
 145         Nothing -> error "Data.Generics.String: gread failed"
 146         Just c' ->
 147           gunfoldm c' gread
 148
 149        guard ( or [ maxConIndex (dataTypeOf u) == 0
 150                   , c `elem` constrsOf u
 151                   ]
 152              )
 153        (a,s''') <- unGRead (gunfold f z c) s''
 154        _ <- return $ constrainTypes a u
 155        guard (not (s''' == ""))
 156        guard (head s''' == ')')
 157        return (a, tail s''')
 158 -}
 159
 160   -- Get a Constr's string at the front of an input string
 161   parseConstr :: GRead String
 162
 163   parseConstr = GRead ( \s -> case s of
 164
 165     -- Infix operators are prefixed in parantheses
 166     ('(':s) -> case break ((==) ')') s of
 167                  (s'@(_:_),(')':s'')) -> Just ("(" ++ s' ++ ")", s'')
 168                  _ -> Nothing
 169
 170     -- Special treatment of multiple token constructors
 171     ('[':']':s) -> Just ("[]",s)
 172
 173     -- Try lex for ordinary constructor and basic datatypes
 174     s -> case lex s of
 175            [(s'@(_:_),s'')] -> Just (s',s'')
 176            _ -> Nothing
 177
 178     )
 179