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 | isIdent n = [TypeSig () [name from] typ, FunBind () $ match : [defMatch | length (dataDeclCtors d) > 1]]
| otherwise = []
where
n = ctorDeclName c
from = "from" ++ n
typ = TyFun () (dataDeclType d)
(tyTuple $ map snd $ ctorDeclFields c)
match = Match () (name from) [pat] (UnGuardedRhs () rhs) Nothing
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 () (name from) [PWildCard ()] (UnGuardedRhs () err) Nothing
err = App () (var "error") $ Lit () $ let s = from ++ " failed, not a " ++ n in String () s (show s)
tyTuple [] = TyCon () $ Special () $ UnitCon ()
tyTuple [x] = x
tyTuple xs = TyTuple () Boxed xs
valTuple [] = Con () $ Special () $ UnitCon ()
valTuple [x] = x
valTuple xs = Tuple () Boxed xs