module Data.Derive.From(makeFrom) where
import Language.Haskell
import Data.Derive.Internal.Derivation
makeFrom :: Derivation
makeFrom = derivationCustom "From" $ \(_,d) -> Right $ concatMap (makeFromCtor d) $ dataDeclCtors d
makeFromCtor :: DataDecl -> CtorDecl -> [Decl]
makeFromCtor d c = [TypeSig sl [name from] typ, FunBind $ match : [defMatch | length (dataDeclCtors d) > 1]]
where
n = ctorDeclName c
from = "from" ++ n
typ = TyFun (dataDeclType d)
(tyTuple $ map (fromBangType . snd) $ ctorDeclFields c)
match = Match sl (name from) [pat] Nothing (UnGuardedRhs rhs) (BDecls [])
pat = (length vars == 0 ? id $ PParen) $ PApp (qname n) (map pVar vars)
vars = take (length $ ctorDeclFields c) $ map ((:) 'x' . show) [1..]
rhs = valTuple $ map var vars
defMatch = Match sl (name from) [PWildCard] Nothing (UnGuardedRhs err) (BDecls [])
err = App (var "error") $ Lit $ String $ from ++ " failed, not a " ++ n
tyTuple [] = TyCon $ Special UnitCon
tyTuple [x] = x
tyTuple xs = TyTuple Boxed xs
valTuple [] = Con $ Special UnitCon
valTuple [x] = x
valTuple xs = Tuple Boxed xs