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