bundles/org.simantics.scl.db/scl/Simantics/GShow.scl

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