-- | Class definition from a data declaration.
module Language.Haskell.DTC.Class
   ( dataToClassWith
   , dataToClass
     ) where

import Data.Char
import Data.Maybe
import Language.Haskell.Syntax

import Language.Haskell.DTC.Mod

-- | Transform a data declaration to a class definition.
-- The 'String' argument will be the name of the type variable of the class definition.
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

-- | Transform a data declaration to a class definition.
-- Equivalent to @dataToClassWith \"t\"@.
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