module Language.Haskell.TH.TypeGraph.Shape
(
Field
, constructorFields
, FieldType(..)
, fieldType
, constructorFieldTypes
, fPos
, fName
, fType
, foldShape
) where
import Data.Generics (Data)
import Data.Typeable (Typeable)
import Language.Haskell.Exts.Syntax ()
import Language.Haskell.TH
import Language.Haskell.TH.Desugar ()
import Language.Haskell.TH.PprLib (ptext)
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.TypeGraph.Prelude (unReifyName)
import Language.Haskell.TH.TypeGraph.Expand (E)
type Field = ( Name,
Name,
Either Int
Name
)
constructorFields :: Name -> Con -> [Field]
constructorFields tname (ForallC _ _ con) = constructorFields tname con
constructorFields tname (NormalC cname fields) = map (\(i, _) -> (tname, cname, Left i)) (zip ([1..] :: [Int]) fields)
constructorFields tname (RecC cname fields) = map (\ (fname, _, _typ) -> (tname, cname, Right fname)) fields
constructorFields tname (InfixC (_, _lhs) cname (_, _rhs)) = [(tname, cname, Left 1), (tname, cname, Left 2)]
instance Ppr Field where
ppr (tname, cname, field) = ptext $
"field " ++
show (unReifyName tname) ++ "." ++
either (\ n -> show (unReifyName cname) ++ "[" ++ show n ++ "]") (\ f -> show (unReifyName f)) field
instance Ppr (Maybe Field, E Type) where
ppr (mf, typ) = ptext $ pprint typ ++ maybe "" (\fld -> " (field " ++ pprint fld ++ ")") mf
instance Ppr (Maybe Field, Type) where
ppr (mf, typ) = ptext $ pprint typ ++ " (unexpanded)" ++ maybe "" (\fld -> " (field " ++ pprint fld ++ ")") mf
data FieldType = Positional Int StrictType | Named VarStrictType deriving (Eq, Ord, Show, Data, Typeable)
fieldType :: FieldType -> Type
fieldType (Positional _ (_, ftype)) = ftype
fieldType (Named (_, _, ftype)) = ftype
instance Ppr FieldType where
ppr (Positional x _) = ptext $ show x
ppr (Named (x, _, _)) = ptext $ nameBase x
fPos :: FieldType -> Either Int Name
fPos = fName
fName :: FieldType -> Either Int Name
fName (Positional x _) = Left x
fName (Named (x, _, _)) = Right x
fType :: FieldType -> Type
fType (Positional _ (_, x)) = x
fType (Named (_, _, x)) = x
foldShape :: Monad m =>
([(Con, [FieldType])] -> m r)
-> (Con -> [FieldType] -> m r)
-> ([Con] -> m r)
-> (Con -> FieldType -> m r)
-> [Con] -> m r
foldShape dataFn recordFn enumFn wrapperFn cons =
case zip cons (map constructorFieldTypes cons) :: [(Con, [FieldType])] of
[(con, [fld])] ->
wrapperFn con fld
[(con, flds)] ->
recordFn con flds
pairs | all (== 0) (map (length . snd) pairs) ->
enumFn (map fst pairs)
pairs ->
dataFn pairs
constructorFieldTypes :: Con -> [FieldType]
constructorFieldTypes (ForallC _ _ con) = constructorFieldTypes con
constructorFieldTypes (NormalC _ ts) = map (uncurry Positional) (zip [1..] ts)
constructorFieldTypes (RecC _ ts) = map Named ts
constructorFieldTypes (InfixC t1 _ t2) = [Positional 1 t1, Positional 2 t2]