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

{-# 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 <[email protected]>
  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 <[email protected]>
  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
-}