module Language.Haskell.DTC.Class
( dataToClassWith
, dataToClass
) where
import Data.Char
import Data.Maybe
import Language.Haskell.Syntax
import Language.Haskell.DTC.Mod
dataToClassWith :: String -> HsDecl -> HsDecl
dataToClassWith str (HsDataDecl loc ctx x_T xs_v xs_C xs_Q)
= let methods = concatMap (method str xs_v x_T) xs_C
in HsClassDecl loc ctx x_T [HsIdent str] methods
dataToClassWith _ d = d
dataToClass :: HsDecl -> HsDecl
dataToClass = dataToClassWith "t"
(->>) :: HsType -> HsType -> HsType
t1 ->> t2 = HsTyFun t1 t2
(.>>) :: HsType -> HsType -> HsType
t1 .>> t2 = HsTyApp t1 t2
hsTyTuple :: [HsType] -> HsType
hsTyTuple [t] = t
hsTyTuple xs = HsTyTuple xs
replaceType :: HsName -> String -> HsType -> HsType
replaceType name new (HsTyFun t1 t2) = HsTyFun (replaceType name new t1) (replaceType name new t2)
replaceType name new (HsTyTuple xs) = HsTyTuple $ map (replaceType name new) xs
replaceType name new (HsTyApp t1 t2) = HsTyApp (replaceType name new t1) (replaceType name new t2)
replaceType name new (HsTyVar name') = if name == name' then HsTyVar $ HsIdent new
else HsTyVar name'
replaceType name new (HsTyCon qname) =
HsTyCon $
case qname of
Qual m name' -> if name == name' then Qual m $ HsIdent new
else Qual m name'
UnQual name' -> if name == name' then UnQual $ HsIdent new
else UnQual name'
x -> x
constructor :: String -> [HsName] -> HsName -> HsConDecl -> HsDecl
constructor str xs_v x_T (HsConDecl loc name xs) =
constructor_ str loc name xs_v x_T xs
constructor str xs_v x_T (HsRecDecl loc name xs) =
constructor_ str loc name xs_v x_T (map snd xs)
constructor_ :: String -> SrcLoc -> HsName -> [HsName]
-> HsName -> [HsBangType] -> HsDecl
constructor_ str loc name xs_v x_T xs =
HsTypeSig loc [modifyHsName (\(n:ns) -> toLower n : ns) name]
(HsQualType [] $
foldr (->>)
(foldl (.>>)
(HsTyVar $ HsIdent str)
(map HsTyVar xs_v) )
(map (replaceType x_T str . unBangType) xs)
)
deconstructor :: String -> [HsName] -> HsName -> HsConDecl -> [HsDecl]
deconstructor str xs_v x_T (HsConDecl loc name xs) =
if length xs > 0
then [ HsTypeSig loc [modifyHsName ("from"++) name]
(HsQualType [] $
foldl (.>>)
(HsTyVar $ HsIdent str)
(map HsTyVar xs_v)
->>
(hsTyTuple $ map (replaceType x_T str . unBangType) xs)
)
]
else [ ]
deconstructor str xs_v x_T (HsRecDecl loc name xs) =
map (\(ys,t) ->
HsTypeSig loc [head ys]
(HsQualType [] $
foldl (.>>)
(HsTyVar $ HsIdent str)
(map HsTyVar xs_v)
->>
(replaceType x_T str $ unBangType t)
)
) xs
method :: String -> [HsName] -> HsName -> HsConDecl -> [HsDecl]
method str xs x_T dec = constructor str xs x_T dec : deconstructor str xs x_T dec