-
Notifications
You must be signed in to change notification settings - Fork 19
/
Copy pathPrint.hs
147 lines (102 loc) · 3.69 KB
/
Print.hs
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
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
{- |
Module : ./CSMOF/Print.hs
Description : pretty printing for CSMOF
Copyright : (c) Daniel Calegari Universidad de la Republica, Uruguay 2013
License : GPLv2 or higher, see LICENSE.txt
Maintainer : dcalegar@fing.edu.uy
Stability : provisional
Portability : portable
-}
module CSMOF.Print where
import CSMOF.As
import Common.Doc
import Common.DocUtils
instance Pretty Metamodel where
pretty (Metamodel nam ele mode) =
text "metamodel" <+> text nam <+> lbrace
$++$ space <+> space <+> foldr (($++$) . pretty) empty ele
$+$ rbrace
$++$ foldr (($+$) . pretty) empty mode
instance Show Metamodel where
show m = show $ pretty m
instance Pretty NamedElement where
pretty (NamedElement _ _ nes) = pretty nes
instance Show NamedElement where
show m = show $ pretty m
instance Pretty TypeOrTypedElement where
pretty (TType typ) = pretty typ
pretty (TTypedElement _) = empty -- Do not show properties at top level but inside classes
instance Show TypeOrTypedElement where
show m = show $ pretty m
instance Pretty Type where
pretty (Type _ sub) = pretty sub
instance Show Type where
show m = show $ pretty m
instance Pretty DataTypeOrClass where
pretty (DDataType dat) = pretty dat
pretty (DClass cla) = pretty cla
instance Show DataTypeOrClass where
show m = show $ pretty m
instance Pretty Datatype where
pretty (Datatype sup) =
text "datatype" <+> text (namedElementName (typeSuper sup))
instance Show Datatype where
show m = show $ pretty m
instance Pretty Class where
pretty (Class sup isa supC own) =
text (if isa then "abstract class" else "class")
<+> text (namedElementName (typeSuper sup))
<+> (case supC of
[] -> lbrace
_ : _ -> text "extends"
<+> foldr ( (<+>) . text . namedElementName . typeSuper . classSuperType) empty supC
<+> lbrace)
$+$ space <+> space <+> foldr (($+$) . pretty) empty own
$+$ rbrace
instance Show Class where
show m = show $ pretty m
instance Pretty TypedElement where
pretty (TypedElement _ _ sub) = pretty sub
instance Show TypedElement where
show m = show $ pretty m
instance Pretty Property where
pretty (Property sup mul opp _) =
text "property" <+> text (namedElementName (typedElementSuper sup))
<> pretty mul
<+> colon <+> text (namedElementName (typeSuper (typedElementType sup)))
<+> (case opp of
Just n -> text "oppositeOf" <+> text (namedElementName (typedElementSuper (propertySuper n)))
Nothing -> empty)
instance Show Property where
show m = show $ pretty m
instance Pretty MultiplicityElement where
pretty (MultiplicityElement low upp _) =
lbrack <> pretty low <> comma
<> (if upp == -1
then text "*"
else pretty upp)
<> rbrack
instance Show MultiplicityElement where
show m = show $ pretty m
-- Model part of CSMOF
instance Pretty Model where
pretty (Model mon obj lin mode) =
text "model" <+> text mon
<+> text "conformsTo" <+> text (metamodelName mode) <+> lbrace
$++$ space <+> space <+> foldr (($+$) . pretty) empty obj
$++$ space <+> space <+> foldr (($+$) . pretty) empty lin
$+$ rbrace
instance Show Model where
show m = show $ pretty m
instance Pretty Object where
pretty (Object on ot _) =
text "object " <> text on
<+> colon <+> text (namedElementName (typeSuper ot))
instance Show Object where
show m = show $ pretty m
instance Pretty Link where
pretty (Link lt sou tar _) =
text "link" <+> text (namedElementName (typedElementSuper (propertySuper lt)))
<> lparen <> text (objectName sou) <> comma <> text (objectName tar) <> rparen $+$ empty
instance Show Link where
show m = show $ pretty m