1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
|
-- | Derives @Show@. This is as defined by the Haskell report, except
-- there is no support for infix constructors. If you attempt to
-- derive @Show@ for a data type with infix constructors, the
-- constructors are handled as if they were prefix constructors, using
-- the @(@/consym/@)@ syntax.
module Data.Derive.Show(makeShow) where
{-
import Prelude
example :: Custom
instance Show a => Show (Sample a) where
showsPrec p (First) = $(show 0)
showsPrec p (Second x1 x2) = $(show 1)
showsPrec p (Third x1) = $(show 2)
test :: Sample
instance Show a => Show (Sample a) where
showsPrec _ First = showString "First"
showsPrec p (Second x1 x2) = showParen (p > 10) $ showString "Second " . showsPrec 11 x1 . showChar ' ' . showsPrec 11 x2
showsPrec p (Third x1) = showParen (p > 10) $ showString "Third " . showsPrec 11 x1
test :: Computer
instance Show Computer where
showsPrec _ (Laptop x1 x2) =
showString "Laptop {weight = " . showsPrec 0 x1 . showString ", speed = " . showsPrec 0 x2 . showChar '}'
showsPrec _ (Desktop x1) =
showString "Desktop {speed = " . showsPrec 0 x1 . showChar '}'
test :: (:*:)
instance (Show a, Show b) => Show ((:*:) a b) where
showsPrec p ((:*:) x1 x2) = showParen (p > 10) $ showString "(:*:) " . showsPrec 11 x1 . showChar ' ' . showsPrec 11 x2
-}
import Data.List
import Data.Derive.DSL.HSE
import qualified Language.Haskell as H
-- GENERATED START
import Data.Derive.DSL.DSL
import Data.Derive.Internal.Derivation
makeShow :: Derivation
makeShow = derivationCustomDSL "Show" custom $
List [Instance ["Show"] "Show" (List [App "InsDecl" (List [App
"FunBind" (List [MapCtor (App "Match" (List [App "Ident" (List [
String "showsPrec"]),List [App "PVar" (List [App "Ident" (List [
String "p"])]),App "PParen" (List [App "PApp" (List [App "UnQual"
(List [App "Ident" (List [CtorName])]),MapField (App "PVar" (List
[App "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])]
)]))])])],App "Nothing" (List []),App "UnGuardedRhs" (List [App
"SpliceExp" (List [App "ParenSplice" (List [App "App" (List [App
"Var" (List [App "UnQual" (List [App "Ident" (List [String "show"]
)])]),App "Lit" (List [App "Int" (List [CtorIndex])])])])])]),App
"BDecls" (List [List []])]))])])])]
-- GENERATED STOP
-- Left is a literal string, Right is a variable
custom = customSplice splice
splice :: FullDataDecl -> Exp -> Exp
splice d (H.App x (H.Lit (H.Int y))) | x ~= "show" = combine $ compress $
if fields then customFields c else customPlain c
where
fields = any (not . null . fst) (ctorDeclFields c)
c = dataDeclCtors (snd d) !! fromInteger y
out (Left [x]) = H.App (var "showChar") (H.Lit $ H.Char x)
out (Left xs ) = H.App (var "showString") (H.Lit $ H.String xs)
out (Right x) = apps (var "showsPrec") [H.Lit $ H.Int (fields ? 0 $ 11), var $ 'x' : show x]
compress (Left x:Left y:z) = compress $ Left (x++y) : z
compress (x:y) = x : compress y
compress [] = []
paren = InfixApp (H.App (var "showParen") (Paren $ InfixApp (var "p") (qvop ">") (H.Lit $ H.Int 10))) (qvop "$")
combine xs = (fields || or [' ' `notElem` x | Left x <- xs] ? id $ paren) $
foldr1 (\x y -> InfixApp x (qvop ".") y) $ map out xs
customPlain :: CtorDecl -> [Either String Int]
customPlain c = intersperse (Left " ") $ Left (ctorDeclName c) : map Right [1..length (ctorDeclFields c)]
customFields :: CtorDecl -> [Either String Int]
customFields c = Left (ctorDeclName c ++ " {") : concat (intersperse [Left ", "] xs) ++ [Left "}"]
where xs = [[Left (n ++ " = "), Right i] | (i,(n,t)) <- zip [1..] $ ctorDeclFields c]
|
