]> gerrit.simantics Code Review - simantics/platform.git/blob - bundles/org.simantics.scl.db/scl/Simantics/GShow.scl
Selection view tab for managing issue validations
[simantics/platform.git] / bundles / org.simantics.scl.db / scl / Simantics / GShow.scl
1 module {
2     features = [edo]
3 }
4
5 include "Simantics/DB" hiding (resourceId)
6 import "http://www.simantics.org/Layer0-1.1" as L0
7 import "http://www.simantics.org/Modeling-1.2" as MOD
8 import "StringBuilder" as StringBuilder
9
10 class GShow a where
11     "Converts a value to string in a read transtion."
12     gshow :: Resource -> a -> <Proc,ReadGraph> String
13     "Appends the string representation of the value to the string builder in a read transaction."
14     gappend :: Resource -> StringBuilder.T -> a -> <Proc,ReadGraph> StringBuilder.T
15     graphPrecedence :: a -> Integer
16     
17     gshow ctx v = StringBuilder.toString (gappend ctx StringBuilder.new v)
18     gappend ctx sb v = StringBuilder.appendString sb $ gshow ctx v
19     graphPrecedence v = 0
20
21 instance (GShow a) => GShow (Par a) where
22     gappend ctx sb (Par outerPrec v) = do
23         prec = graphPrecedence v
24         if prec > outerPrec
25         then do
26             sb << "("
27             gappend ctx sb v
28             sb << ")"
29         else gappend ctx sb v
30                               
31 instance GShow String where
32     gappend _ = (<+)
33
34 instance GShow Integer where
35     gshow _ = show
36     graphPrecedence v = if v >= 0 then 0 else 100
37
38 instance GShow Long where
39     gshow _ = show
40     graphPrecedence v = if v >= 0 then 0 else 100
41
42 instance GShow Float where
43     gshow _ = show
44     graphPrecedence v = if v >= 0 then 0 else 100
45
46 instance GShow Double where
47     gshow _ = show
48     graphPrecedence v = if v >= 0 then 0 else 100
49
50 instance GShow Boolean where
51     gshow _ = show
52
53 instance GShow DoubleArray where
54     gappend _ sb v = sb << "toDoubleArray " <+ fromDoubleArray v
55     graphPrecedence v = 1
56
57 importJava "org.simantics.utils.bytes.Base64" where
58     @JavaName encode
59     encodeBase64 :: ByteArray -> String
60     @JavaName decode
61     decodeBase64 :: String -> ByteArray
62
63 instance GShow ByteArray where
64     gappend _ sb v = sb << "decodeBase64 " <+ (encodeBase64 v)
65     graphPrecedence v = 1
66     
67 @private
68 importJava "org.simantics.db.layer0.util.ExtendedUris" where
69     getPrimaryFunctionalReference :: Resource -> <ReadGraph> Maybe (Resource,Resource)
70     getSecondaryFunctionalReference :: Resource -> <ReadGraph> Maybe (Resource,Resource)
71
72 data ResourceId =
73     NamedChildOf ResourceId String
74   | PropertyOf ResourceId String
75   | AbsoluteUri String
76   | ContextRelativeUri String
77
78 @private
79 importJava "gnu.trove.set.hash.THashSet" where
80     data ResourceSet
81     @JavaName "<init>"
82     createResourceSet :: () -> /*<Proc> not necessary in our case*/ ResourceSet
83     @JavaName add
84     addResourceSet :: ResourceSet -> Resource -> /*<Proc> not necessary in our case*/ Boolean
85
86 resourceId :: Resource -> Resource -> <ReadGraph> Maybe ResourceId
87 resourceId ctx r = loop r
88    where
89     guardSet = createResourceSet ()
90     loop r = if addResourceSet guardSet r 
91       then 
92         (guard (r == ctx) >> return (ContextRelativeUri "")) 
93         `morelse`
94         (guard (r == getRootLibrary ()) >> return (AbsoluteUri "http:/"))
95         `morelse`
96         (edo
97             (p,rel) <- getPrimaryFunctionalReference r
98             path <- loop p
99             relName <- possibleNameOf rel
100             return $ simplifyResourceIdHead $ PropertyOf path relName
101         )
102         `morelse`
103         (edo
104             p <- possibleObject r L0.PartOf
105             path <- loop p
106             name <- possibleNameOf r
107             return $ simplifyResourceIdHead $ NamedChildOf path name
108         )
109         `morelse`
110         (edo
111             (p,rel) <- getSecondaryFunctionalReference r
112             path <- loop p
113             relName <- possibleNameOf rel
114             return $ simplifyResourceIdHead $ PropertyOf path relName
115         )
116         `morelse`
117         Nothing
118       else Nothing
119
120 @private
121 importJava "org.simantics.databoard.util.URIStringUtils" where
122     escape :: String -> String
123
124 simplifyResourceIdHead (NamedChildOf (AbsoluteUri uri) name) = AbsoluteUri (uri + "/" + escape name)  
125 simplifyResourceIdHead (NamedChildOf (ContextRelativeUri uri) name) = ContextRelativeUri (uri + "/" + escape name)
126 simplifyResourceIdHead (PropertyOf (AbsoluteUri uri) name) = AbsoluteUri (uri + "#" + escape name)  
127 simplifyResourceIdHead (PropertyOf (ContextRelativeUri uri) name) = ContextRelativeUri (uri + "#" + escape name)
128 simplifyResourceIdHead id = id
129
130 instance Show ResourceId where
131     sb <+ NamedChildOf parent name = sb << "fromJust (possibleResourceChild " <+ Par 0 parent << " " <+ name << ")"
132     sb <+ ContextRelativeUri uri = sb << "modelResource " <+ uri
133     sb <+ AbsoluteUri uri = sb << "resource " <+ uri
134     
135     precedence _ = 1
136
137 instance GShow Resource where
138     gappend ctx sb r = sb <+ fromJust (resourceId ctx r)
139     graphPrecedence v = 1
140
141 instance (GShow a) => GShow [a] where
142     gappend ctx sb l = do
143         len = length l
144         loop i = if i < len 
145                  then do 
146                      if (i>0) then sb << ", " else sb
147                      gappend ctx sb (l!i)
148                      loop (i+1)
149                  else sb << "]"
150         sb << "[" 
151         loop 0
152
153 instance GShow () where
154     gshow _ _ = "()"
155
156 instance (GShow a, GShow b) => GShow (a, b) where
157     gappend ctx sb (x, y) = do
158         sb << "(" 
159         gappend ctx sb x 
160         sb << ", " 
161         gappend ctx sb y 
162         sb << ")"
163
164 instance (GShow a, GShow b, GShow c) => GShow (a, b, c) where
165     gappend ctx sb (x, y, z) = do
166         sb << "(" 
167         gappend ctx sb x 
168         sb << ", " 
169         gappend ctx sb y
170         sb << ", " 
171         gappend ctx sb z 
172         sb << ")"
173
174 instance (GShow a, GShow b, GShow c, GShow d) => GShow (a, b, c, d) where
175     gappend ctx sb (x, y, z, w) = do
176         sb << "(" 
177         gappend ctx sb x 
178         sb << ", " 
179         gappend ctx sb y
180         sb << ", " 
181         gappend ctx sb z 
182         sb << ", " 
183         gappend ctx sb w
184         sb << ")"
185
186 instance (GShow a) => GShow (Maybe a) where
187     gappend ctx sb Nothing = sb << "Nothing"
188     gappend ctx sb (Just x) = do
189         sb << "Just "
190         gappend ctx sb (Par 0 x)
191     graphPrecedence (Just x) = 1
192     graphPrecedence Nothing = 0
193
194 instance (GShow a, GShow b) => GShow (Either a b) where
195     gappend ctx sb (Left x) = do
196         sb << "Left "
197         gappend ctx sb (Par 0 x)
198     gappend ctx sb (Right x) = do
199         sb << "Right "
200         gappend ctx sb (Par 0 x)    
201     graphPrecedence _ = 1