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

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