generic_printing.hs

-- Adapted from http://chrisdone.com/posts/data-typeable

recordShow :: Data a => a -> ShowS                                                                                                                                                                                                             
recordShow = render `extQ` (shows :: String -> ShowS) where                                                                                                                                                                                    
  render t                                                                                                                                                                                                                                     
    | isTuple = drop 1 . tupleSlots                                                                                                                                                                                                            
    | isNull = drop 1 . showChar ' '                                                                                                                                                                                                           
    | isList = drop 1 . listSlots                                                                                                                                                                                                              
    | isAlgRepConstr t = showString $ getConstr $ (show $ printRecord t)                                                                                                                                                                       
    | otherwise = showString . showConstr .toConstr $ t                                                                                                                                                                                        
   where                                                                                                                                                                                                                                       
     getConstr = showString $ showConstr .toConstr $ t                                                                                                                                                                                         
     isList =  constructor ""  == "(:)"                                                                                                                                                                                                        
     constructor = showString . showConstr . toConstr $ t                                                                                                                                                                                      
     listSlots = Prelude.foldr (.) id . (gmapQ ((showString ":" .) . recordShow)) $ t                                                                                                                                                          
     tupleSlots = Prelude.foldr (.) id . (gmapQ ((showString ";" .) . recordShow)) $ t                                                                                                                                                         
     isNull = constructor "" == "[]"                                                                                                                                                                                                           
     isTuple = constructor "" == "(,)"                                                                                                                                                                                                         
                                                                                                                                                                                                                                               
printRecord x =                                                                                                                                                                                                                                
  let l = (gmapQ (recordShow) x) in                                                                                                                                                                                                            
    Prelude.map ($ "") l                                                                                                                                                                                                                       
                                                                                                                                                                                                                                               
sprint :: String -> ShowS                                                                                                                                                                                                                      
sprint = shows                                                                                                                                                                                                                                 
                                                                                                                                                                                                                                               
isAlgRepConstr t = case (dataTypeRep . dataTypeOf $ t) of                                                                                                                                                                                      
  AlgRep [_] -> True                                                                                                                                                                                                                           
  _ -> False