module {
    features = [edo]
}

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`
        (edo
            (p,rel) <- getPrimaryFunctionalReference r
            path <- loop p
            relName <- possibleNameOf rel
            return $ simplifyResourceIdHead $ PropertyOf path relName
        )
        `morelse`
        (edo
            p <- possibleObject r L0.PartOf
            path <- loop p
            name <- possibleNameOf r
            return $ simplifyResourceIdHead $ NamedChildOf path name
        )
        `morelse`
        (edo
            (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