Deriving Read with Template Haskell (Re: automatic instances for pretty printing and parsing)

Johannes Waldmann wrote:

> I use Text.PrettyPrint.HughesPJ and
> Text.ParserCombinators.Parsec heavily so I made
> some DrIFT rules for deriving the "obvious" instances for
>
> class ToDoc  a where toDoc :: a -> Doc
> class Reader a where readerPrec :: Int -> Parser a
>
> Perhaps someone has solved a similar problem before.

  I was looking for the same thing because I didn't like the way derived
instances of Read depend on whether I define my datatypes in prefix,
infix or record form. I ended up writing my own Read derivation using
Template Haskell. Here it is. Basically it can read prefix, infix or
record syntax where applicable. It is based on ReadPrec, not Parsec though.

  Some further notes and questions:

1. Instead of Read I actually use another class, Parse, which is a clone
of Read. The reason is that I wanted to have new instances for some
standard types that already have their Read instances defined. This
introduces some hackery and requires you to use
-fallow-overlapping-instances. If you don't like it, it should be quite
easy to go back to Read.

2. My instance context derivation is very primitive: I simply repeat all
the field types in the context, say

   > data T a b = T1 Int | T2 (a b) (Maybe b)
   > instance (Parse Int, Parse (a b), Parse (Maybe b)) => Parse (T a b)

  The result is that you need -fallow-undecidable-instances to chew
through all that :) Here a question: are there any pitfalls about
writing such instances that I don't currently see?

  Any feedback, improvements, fixes, etc. always welcome!

Cheers,
  Misha

{-# OPTIONS -fth -fallow-undecidable-instances -fallow-overlapping-instances #-}

import Parse
import DeriveParse

data T a = T a | TC (T a) deriving Show
$(deriveParse ''T)

data TAB a b = AB | TABC (a b) deriving Show
$(deriveParse ''TAB)

data Swap a b = Stop a | Step (Swap b a) deriving Show
$(deriveParse ''Swap)

data TI = I | TI `TIC` TI deriving Show
$(deriveParse ''TI)

infix 5 :$
data TI' = TI :$ TI deriving Show
$(deriveParse ''TI')

data TR = R | TRC {rec1 :: TR, rec2 :: TR, rec3 :: TR} deriving Show
$(deriveParse ''TR)

test :: IO ()
test = do
  -- first the new Parse intances
  print (parse "TC (TC (T 1)) " :: T Int)
  print (parse "TABC (T 3) " :: TAB T Int)
  print (parse " Step (Stop True)" :: Swap Int Bool)
  print (parse "I :$ I" :: TI')
  print (parse "I :$ I `TIC` I" :: TI')
  print (parse "(:$) I (TIC I I)" :: TI')
  print (parse "TRC {rec3 = R, rec2 = R, rec1 = TRC R R R}" :: TR)

  -- now the instances derived from Read

  print (parse "T ['h', 'e', 'l', 'l', 'o']" :: T String)
  print (parse "T \"hello\"" :: T String)
  print (parse "(Just I, [I, I])" :: (Maybe TI, [TI]))

main = test
{-# OPTIONS -fth -cpp #-}

{-|
  Module      :  DeriveParse

  Maintainer  :  Misha Aizatulin <[hidden email]>
  Portability :  non-portable (Template Haskell)

  Automatic derivation of 'Parse' instances. The derived instances
  read prefix, infix and record forms, where possible.

  Because context derivation is rather primitive, you will need
  @-fallow-undecidable-instances@ in most cases.
-}

module DeriveParse (deriveParse) where

import Parse
import TypeInfo

import Control.Monad
import Language.Haskell.TH
import Language.Haskell.TH.Ppr (appPrec)

import GHC.Read (parens)
import Text.Read
import Text.ParserCombinators.ReadP hiding (choice)

deriveParse :: Name -> Q [Dec]

#ifndef __HADDOCK__

deriveParse name = do
  (_, params, cons) <- typeInfo name
  body <- [d| parsePrec = parens (choice $(listE (concat $ map mkConParsers cons)) )|]
  return [InstanceD (cxt ''Parse cons) (instanceType ''Parse  params) body,
          InstanceD (cxt ''Parse cons) (instanceType ''Parse' params) []]

  where
    {-
      We simply repeat all the field types in the context, for instance

      > data T a b = T1 Int | T2 (a b) (Maybe b)
      > instance (Parse Int, Parse (a b), Parse (Maybe b)) => Parse (T a b)
    -}
    cxt className cons = -- filter (/= instanceType className params)
      [(ConT className) `AppT` t | (_, terms) <- cons, (_, t) <- terms]

    instanceType className params =
      ((ConT className) `AppT` (foldl1 AppT $ (ConT name):(map VarT params)))

    mkConParsers (con, terms) = -- let
        -- arity        = length terms
        [mkPrefixConParser con terms]
     ++ if arity == 2 then
        [mkInfixConParser con terms]
        else []
     ++ if and ((arity /= 0):[name /= Nothing | (name, _) <- terms]) then
        [mkRecordConParser con terms]
        else []
     where arity = length terms

    mkPrefixConParser con terms = do
      x <- replicateM (length terms) mkFieldParser
      let (parseParams, vars) = unzip x
      [| $(precFun)
         $(doE $
               parseCon
            ++ parseParams
            ++ [noBindS [|return $(appsE $ (conE con):vars)|]]) |]
      where
        precFun | length terms == 0 = [| id |]
                | otherwise         = [| prec appPrec |]
        parseCon = case lexeme conName of
                (Just (Ident _))  -> [parseLex 'Ident conName]
                (Just (Symbol _)) -> [parseLex 'Punc "(",
                                      parseLex 'Symbol conName,
                                      parseLex 'Punc ")"]
        conName = show $ simpleName con

    mkFieldParser = do
      a <- newName "a"
      return (bindS (varP a) [| step parsePrec |], varE a)

    mkInfixConParser con _ = do
      (DataConI _ _ _ (Fixity fixity _)) <- reify con
      appE [|prec fixity|] $
        doE $
            [bindS (varP $ mkName "a") [|step parsePrec|]]
         ++ parseCon
         ++ [bindS (varP $ mkName "b") [|step parsePrec|],
             noBindS [|return ($(conE con) $(dyn "a") $(dyn "b"))|]]
      where
        parseCon = case lexeme conName of
                (Just (Symbol _)) -> [parseLex 'Symbol conName]
                (Just (Ident  _)) ->
                    [parseLex 'Punc "`",
                     parseLex 'Ident conName,
                     parseLex 'Punc "`"]
        conName = show $ simpleName con

    mkRecordConParser con terms = doE
      [
        parseLex 'Ident (show $ simpleName con),
        parseLex 'Punc  "{",
        bindS (varP $ mkName "updates")
          [|flip (liftReset3 sepBy) comma $ choice
              $(listE (map mkFieldUpdateParser terms)) |],
        parseLex 'Punc  "}",
        noBindS [|return (foldr ($) $(recConE con emptyFields) $(updatesE))|]
      ]
      where
        emptyFields = [return (name, VarE $ mkName "undefined")| (Just name, _) <- terms]
        updatesE    = varE $ mkName "updates"

    mkFieldUpdateParser (Just field, _) = doE $
          parseFieldName
      ++ [parseLex 'Punc  "=",
          bindS (varP $ mkName "a") [|parsePrec|],
          noBindS [|return (\t ->
                              $(recUpdE [|t|] [return (field, VarE $ mkName "a")])) |]]
      where
        parseFieldName = case lexeme fieldName of
                (Just (Ident _))  -> [parseLex 'Ident fieldName]
                (Just (Symbol _)) -> [parseLex 'Punc "(",
                                      parseLex 'Symbol fieldName,
                                      parseLex 'Punc ")"]
        fieldName = show $ simpleName field

    {-
       for instance
       @parseLex 'Ident "a"@ ~> @Ident "a" <- lexP@
     -}
    parseLex name str =
      bindS (conP name [litP (StringL str)]) [|lexP|]

#endif

comma :: ReadPrec ()
comma = do
  Punc "," <- lexP
  return ()

lexeme :: String -> Maybe Lexeme
lexeme s =
  case [ x | (x,"") <- readPrec_to_S lexP minPrec s ] of
    [x] -> Just x
    _ -> Nothing

{-
  This or similar function I think should be provided by "ReadPrec" authors.
-}
liftReset3 :: (ReadP a -> ReadP b -> ReadP c)
              -> ReadPrec a -> ReadPrec b -> ReadPrec c
liftReset3 f a b = lift $ f (readPrec_to_P a 0) (readPrec_to_P b 0)

{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-}

{-|
  Module      :  Parse

  Maintainer  :  Misha Aizatulin <[hidden email]>
  Portability :  non-portable (undecidable and overlapping instances)

  'Parse' is a clone of 'Read'. The reason we introduce a new class
  is to create new instances for some library datatypes that already
  have a 'Read' instance.
-}

module Parse (Parse(..), Parse', parse, parseEither) where

import Text.Read
import Text.ParserCombinators.ReadP
import GHC.Read (list)

class Parse a where
  parsePrec     :: ReadPrec a

  parseListPrec :: ReadPrec [a]
  parseListPrec = list parsePrec

{-|
  This class is a bit of a hack. We want to reuse existing
  instances of 'Read' and be able to derive 'Parse' from them.
  On the other hand, consider the standard instance

  >  instance (Read a, Read b) => Read (a, b)

  If we are to reuse it, then we have to derive @'Read' a@ from
  @'Parse' a@ and same for @b@. So the naive way would be

  >  instance Read a => Parse a
  >  instance Parse a => Read a

  but this would introduce a loop. To break it, we create a synonym

  >  instance Read a => Parse a
  >  instance Parse' a => Read a

  Every time you define an instance of 'Parse' per hand, you also should define
  'Parse''. This is what @deriveParse@ does as well. Please tell me if this hack
  fails for you.
-}
class Parse a => Parse' a

instance Read a => Parse a where
  parsePrec     = readPrec
  parseListPrec = readListPrec

instance Parse' a => Read a where
  readPrec     = parsePrec
  readListPrec = parseListPrec

instance Parse a => Parse [a] where
  parsePrec = parseListPrec

{-|
  Gives an error if there isn't a unique parse.
-}
parse :: Parse a => String -> a
parse s =
  case parseEither s of
    Right x -> x
    Left  e -> error e

parseEither :: Parse a => String -> Either String a
parseEither s =
  case [ x | (x,"") <- readPrec_to_S parse' minPrec s ] of
    [x] -> Right x
    [] -> Left "parse: no parse"
    _ -> Left "parse: ambiguous parse"
  where
    parse' = do
      x <- parsePrec
      lift skipSpaces
      return x


{-|
  Observing a structure of a datatype in a uniform way no matter
  whether it was defined in infix, prefix or record form.

  This code is based on the @Derive@ module from the SYB3 code distribution,
  (C) 2005, Ralf Laemmel and Simon Peyton Jones, see
  <http://homepages.cwi.nl/~ralf/syb3/code.html>.
-}

module TypeInfo (TypeInfo, typeInfo, simpleName) where

import Language.Haskell.TH

{-|
  The first part is the name, the second - a list of type parameters,
  the third - a list of constructors. For each constructor we have a name
  and a list describing constructor fields.
-}
type TypeInfo = (Name, [Name], [(Name, [(Maybe Name, Type)])])

typeInfo :: Name -> Q TypeInfo
typeInfo name = do
  info' <- reify name
  case info' of
    TyConI d -> typeInfo' ((return d) :: Q Dec)
    _        -> error ("typeInfo: can't be used on anything but a type " ++
                       "constructor of an algebraic data type")

typeInfo' :: DecQ -> Q TypeInfo
typeInfo' m =
     do d <- m
        case d of
           d@(DataD _ _ _ _ _) ->
            return $ (simpleName $ name d, paramsA d, termsA d)
           d@(NewtypeD _ _ _ _ _) ->
            return $ (simpleName $ name d, paramsA d, termsA d)
           _ -> error ("typeInfo': not a data type declaration: " ++ show d)

     where
        paramsA (DataD _ _ ps _ _) = ps
        paramsA (NewtypeD _ _ ps _ _) = ps

        termsA (DataD _ _ _ cs _) = map termA cs
        termsA (NewtypeD _ _ _ c _) = [ termA c ]

        termA (NormalC c xs)        = (c, map (\x -> (Nothing, snd x)) xs)
        termA (RecC c xs)           = (c, map (\(n, _, t) -> (Just n, t)) xs)
        termA (InfixC t1 c t2)      = (c, [(Nothing, snd t1), (Nothing, snd t2)])

        name (DataD _ n _ _ _)      = n
        name (NewtypeD _ n _ _ _)   = n
        name d                      = error $ show d

{-|
  Apply 'nameBase' to the name.
-}
simpleName :: Name -> Name
simpleName = mkName . nameBase
{-
   -- this breaks names like :$
   let s = nameBase nm
   in case dropWhile (/=':') s of
        []          -> mkName s
        _:[]        -> mkName s
        _:t         -> mkName t
-}

_______________________________________________
template-haskell mailing list
[hidden email]
http://www.haskell.org/mailman/listinfo/template-haskell