--- /dev/null
+include "Simantics/DB" hiding (resourceId)\r
+import "http://www.simantics.org/Layer0-1.1" as L0\r
+import "http://www.simantics.org/Modeling-1.2" as MOD\r
+import "StringBuilder" as StringBuilder\r
+\r
+class GShow a where\r
+ "Converts a value to string in a read transtion."\r
+ gshow :: Resource -> a -> <Proc,ReadGraph> String\r
+ "Appends the string representation of the value to the string builder in a read transaction."\r
+ gappend :: Resource -> StringBuilder.T -> a -> <Proc,ReadGraph> StringBuilder.T\r
+ graphPrecedence :: a -> Integer\r
+ \r
+ gshow ctx v = StringBuilder.toString (gappend ctx StringBuilder.new v)\r
+ gappend ctx sb v = StringBuilder.appendString sb $ gshow ctx v\r
+ graphPrecedence v = 0\r
+\r
+instance (GShow a) => GShow (Par a) where\r
+ gappend ctx sb (Par outerPrec v) = do\r
+ prec = graphPrecedence v\r
+ if prec > outerPrec\r
+ then do\r
+ sb << "("\r
+ gappend ctx sb v\r
+ sb << ")"\r
+ else gappend ctx sb v\r
+ \r
+instance GShow String where\r
+ gappend _ = (<+)\r
+\r
+instance GShow Integer where\r
+ gshow _ = show\r
+ graphPrecedence v = if v >= 0 then 0 else 100\r
+\r
+instance GShow Long where\r
+ gshow _ = show\r
+ graphPrecedence v = if v >= 0 then 0 else 100\r
+\r
+instance GShow Float where\r
+ gshow _ = show\r
+ graphPrecedence v = if v >= 0 then 0 else 100\r
+\r
+instance GShow Double where\r
+ gshow _ = show\r
+ graphPrecedence v = if v >= 0 then 0 else 100\r
+\r
+instance GShow Boolean where\r
+ gshow _ = show\r
+\r
+instance GShow DoubleArray where\r
+ gappend _ sb v = sb << "toDoubleArray " <+ fromDoubleArray v\r
+ graphPrecedence v = 1\r
+\r
+importJava "org.simantics.utils.bytes.Base64" where\r
+ @JavaName encode\r
+ encodeBase64 :: ByteArray -> String\r
+ @JavaName decode\r
+ decodeBase64 :: String -> ByteArray\r
+\r
+instance GShow ByteArray where\r
+ gappend _ sb v = sb << "decodeBase64 " <+ (encodeBase64 v)\r
+ graphPrecedence v = 1\r
+ \r
+@private\r
+importJava "org.simantics.db.layer0.util.ExtendedUris" where\r
+ getPrimaryFunctionalReference :: Resource -> <ReadGraph> Maybe (Resource,Resource)\r
+ getSecondaryFunctionalReference :: Resource -> <ReadGraph> Maybe (Resource,Resource)\r
+\r
+data ResourceId =\r
+ NamedChildOf ResourceId String\r
+ | PropertyOf ResourceId String\r
+ | AbsoluteUri String\r
+ | ContextRelativeUri String\r
+\r
+@private\r
+importJava "gnu.trove.set.hash.THashSet" where\r
+ data ResourceSet\r
+ @JavaName "<init>"\r
+ createResourceSet :: () -> /*<Proc> not necessary in our case*/ ResourceSet\r
+ @JavaName add\r
+ addResourceSet :: ResourceSet -> Resource -> /*<Proc> not necessary in our case*/ Boolean\r
+\r
+resourceId :: Resource -> Resource -> <ReadGraph> Maybe ResourceId\r
+resourceId ctx r = loop r\r
+ where\r
+ guardSet = createResourceSet ()\r
+ loop r = if addResourceSet guardSet r \r
+ then \r
+ (guard (r == ctx) >> return (ContextRelativeUri "")) \r
+ `morelse`\r
+ (guard (r == getRootLibrary ()) >> return (AbsoluteUri "http:/"))\r
+ `morelse`\r
+ (mdo\r
+ (p,rel) <- getPrimaryFunctionalReference r\r
+ path <- loop p\r
+ relName <- possibleNameOf rel\r
+ return $ simplifyResourceIdHead $ PropertyOf path relName\r
+ )\r
+ `morelse`\r
+ (mdo\r
+ p <- possibleObject r L0.PartOf\r
+ path <- loop p\r
+ name <- possibleNameOf r\r
+ return $ simplifyResourceIdHead $ NamedChildOf path name\r
+ )\r
+ `morelse`\r
+ (mdo\r
+ (p,rel) <- getSecondaryFunctionalReference r\r
+ path <- loop p\r
+ relName <- possibleNameOf rel\r
+ return $ simplifyResourceIdHead $ PropertyOf path relName\r
+ )\r
+ `morelse`\r
+ Nothing\r
+ else Nothing\r
+\r
+@private\r
+importJava "org.simantics.databoard.util.URIStringUtils" where\r
+ escape :: String -> String\r
+\r
+simplifyResourceIdHead (NamedChildOf (AbsoluteUri uri) name) = AbsoluteUri (uri + "/" + escape name) \r
+simplifyResourceIdHead (NamedChildOf (ContextRelativeUri uri) name) = ContextRelativeUri (uri + "/" + escape name)\r
+simplifyResourceIdHead (PropertyOf (AbsoluteUri uri) name) = AbsoluteUri (uri + "#" + escape name) \r
+simplifyResourceIdHead (PropertyOf (ContextRelativeUri uri) name) = ContextRelativeUri (uri + "#" + escape name)\r
+simplifyResourceIdHead id = id\r
+\r
+instance Show ResourceId where\r
+ sb <+ NamedChildOf parent name = sb << "fromJust (possibleResourceChild " <+ Par 0 parent << " " <+ name << ")"\r
+ sb <+ ContextRelativeUri uri = sb << "modelResource " <+ uri\r
+ sb <+ AbsoluteUri uri = sb << "resource " <+ uri\r
+ \r
+ precedence _ = 1\r
+\r
+instance GShow Resource where\r
+ gappend ctx sb r = sb <+ fromJust (resourceId ctx r)\r
+ graphPrecedence v = 1\r
+\r
+instance (GShow a) => GShow [a] where\r
+ gappend ctx sb l = do\r
+ len = length l\r
+ loop i = if i < len \r
+ then do \r
+ if (i>0) then sb << ", " else sb\r
+ gappend ctx sb (l!i)\r
+ loop (i+1)\r
+ else sb << "]"\r
+ sb << "[" \r
+ loop 0\r
+\r
+instance GShow () where\r
+ gshow _ _ = "()"\r
+\r
+instance (GShow a, GShow b) => GShow (a, b) where\r
+ gappend ctx sb (x, y) = do\r
+ sb << "(" \r
+ gappend ctx sb x \r
+ sb << ", " \r
+ gappend ctx sb y \r
+ sb << ")"\r
+\r
+instance (GShow a, GShow b, GShow c) => GShow (a, b, c) where\r
+ gappend ctx sb (x, y, z) = do\r
+ sb << "(" \r
+ gappend ctx sb x \r
+ sb << ", " \r
+ gappend ctx sb y\r
+ sb << ", " \r
+ gappend ctx sb z \r
+ sb << ")"\r
+\r
+instance (GShow a, GShow b, GShow c, GShow d) => GShow (a, b, c, d) where\r
+ gappend ctx sb (x, y, z, w) = do\r
+ sb << "(" \r
+ gappend ctx sb x \r
+ sb << ", " \r
+ gappend ctx sb y\r
+ sb << ", " \r
+ gappend ctx sb z \r
+ sb << ", " \r
+ gappend ctx sb w\r
+ sb << ")"\r
+\r
+instance (GShow a) => GShow (Maybe a) where\r
+ gappend ctx sb Nothing = sb << "Nothing"\r
+ gappend ctx sb (Just x) = do\r
+ sb << "Just "\r
+ gappend ctx sb (Par 0 x)\r
+ graphPrecedence (Just x) = 1\r
+ graphPrecedence Nothing = 0\r
+\r
+instance (GShow a, GShow b) => GShow (Either a b) where\r
+ gappend ctx sb (Left x) = do\r
+ sb << "Left "\r
+ gappend ctx sb (Par 0 x)\r
+ gappend ctx sb (Right x) = do\r
+ sb << "Right "\r
+ gappend ctx sb (Par 0 x) \r
+ graphPrecedence _ = 1\r
Code Review / simantics / platform.git / blobdiff