{-

copied from: 
  http://haskell.1045720.n5.nabble.com/Deriving-Read-with-Template-Haskell-Re-automatic-instances-for-pretty-printing-and-parsing-td3197647.html

modified.

-}


{-|
  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)])])

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
-}