module Language.Haskell.TypeTree.Datatype where
import Data.Data
import Data.Maybe
import Language.Haskell.TH
import Prelude.Compat
data Binding
= Bound { unBinding :: Name }
| Unbound { unBinding :: Name }
deriving (Show, Ord, Eq, Data)
class IsDatatype a where
asDatatype :: a -> Q (Binding, [Type])
instance IsDatatype Name where
asDatatype n = pure (guess n, [])
instance IsDatatype TypeQ where
asDatatype = fmap unwrap
unwrap :: Type -> (Binding, [Type])
unwrap = go
where
go (ConT x) = (Bound x, [])
go (VarT y) = (Unbound y, [])
go (ForallT _ _ x) = go x
go (AppT x y) =
let (hd, args) = go x
in (hd, args ++ [y])
go ListT = (Bound ''[], [])
go ArrowT = (Bound ''(->), [])
go (TupleT n) = (Bound (tupleTypeName n), [])
go (UnboxedTupleT n) = (Bound (unboxedTupleTypeName n), [])
go (SigT t _k) = go t
go z = error $ show z
guess n
| isNothing (nameSpace n) = Unbound n
| otherwise = Bound n