TypeInfo.hs

-- |
--  Copied from <http://haskell.1045720.n5.nabble.com/Deriving-Read-with-Template-Haskell-Re-automatic-instances-for-pretty-printing-and-parsing-td3197647.html>, and modified a bit.
-- 
--   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 GTA.Util.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)])])
type TypeInfo = (Name, [TyVarBndr], [(Name, [(Maybe Name, Type)])])

-- |
--   Returns type information of a given 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 $ (name d, paramsA d, termsA d)
           d@(NewtypeD _ _ _ _ _) ->
            return $ (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
-}