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