module Telescope.Asdf.Node where

import Data.Maybe (fromMaybe)
import Data.Scientific (Scientific)
import Data.String (IsString (..))
import Data.Text (Text, pack, unpack)
import Data.Text qualified as T
import Telescope.Asdf.NDArray.Types
import Telescope.Data.Parser
import Text.Read (readMaybe)


-- | Specify a schema using 'schema' from 'ToAsdf'
newtype SchemaTag = SchemaTag (Maybe Text)
  deriving newtype (Semigroup SchemaTag
SchemaTag
Semigroup SchemaTag =>
SchemaTag
-> (SchemaTag -> SchemaTag -> SchemaTag)
-> ([SchemaTag] -> SchemaTag)
-> Monoid SchemaTag
[SchemaTag] -> SchemaTag
SchemaTag -> SchemaTag -> SchemaTag
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: SchemaTag
mempty :: SchemaTag
$cmappend :: SchemaTag -> SchemaTag -> SchemaTag
mappend :: SchemaTag -> SchemaTag -> SchemaTag
$cmconcat :: [SchemaTag] -> SchemaTag
mconcat :: [SchemaTag] -> SchemaTag
Monoid, NonEmpty SchemaTag -> SchemaTag
SchemaTag -> SchemaTag -> SchemaTag
(SchemaTag -> SchemaTag -> SchemaTag)
-> (NonEmpty SchemaTag -> SchemaTag)
-> (forall b. Integral b => b -> SchemaTag -> SchemaTag)
-> Semigroup SchemaTag
forall b. Integral b => b -> SchemaTag -> SchemaTag
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: SchemaTag -> SchemaTag -> SchemaTag
<> :: SchemaTag -> SchemaTag -> SchemaTag
$csconcat :: NonEmpty SchemaTag -> SchemaTag
sconcat :: NonEmpty SchemaTag -> SchemaTag
$cstimes :: forall b. Integral b => b -> SchemaTag -> SchemaTag
stimes :: forall b. Integral b => b -> SchemaTag -> SchemaTag
Semigroup, SchemaTag -> SchemaTag -> Bool
(SchemaTag -> SchemaTag -> Bool)
-> (SchemaTag -> SchemaTag -> Bool) -> Eq SchemaTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SchemaTag -> SchemaTag -> Bool
== :: SchemaTag -> SchemaTag -> Bool
$c/= :: SchemaTag -> SchemaTag -> Bool
/= :: SchemaTag -> SchemaTag -> Bool
Eq)


instance Show SchemaTag where
  show :: SchemaTag -> String
show (SchemaTag Maybe Text
Nothing) = String
""
  show (SchemaTag (Just Text
t)) = Text -> String
unpack Text
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":"


schemaTag :: String -> SchemaTag
schemaTag :: String -> SchemaTag
schemaTag = Maybe Text -> SchemaTag
SchemaTag (Maybe Text -> SchemaTag)
-> (String -> Maybe Text) -> String -> SchemaTag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> (String -> Text) -> String -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack


instance IsString SchemaTag where
  fromString :: String -> SchemaTag
fromString String
s = Maybe Text -> SchemaTag
SchemaTag (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
s)


-- | A Node is a 'Value' with an optional 'SchemaTag' and 'Anchor'
data Node = Node
  { Node -> SchemaTag
schema :: SchemaTag
  , Node -> Maybe Anchor
anchor :: Maybe Anchor
  , Node -> Value
value :: Value
  }
  deriving (Node -> Node -> Bool
(Node -> Node -> Bool) -> (Node -> Node -> Bool) -> Eq Node
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Node -> Node -> Bool
== :: Node -> Node -> Bool
$c/= :: Node -> Node -> Bool
/= :: Node -> Node -> Bool
Eq)


instance Show Node where
  show :: Node -> String
show (Node SchemaTag
st Maybe Anchor
_ Value
v) = SchemaTag -> String
forall a. Show a => a -> String
show SchemaTag
st String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
v
instance IsString Node where
  fromString :: String -> Node
fromString String
s = SchemaTag -> Maybe Anchor -> Value -> Node
Node SchemaTag
forall a. Monoid a => a
mempty Maybe Anchor
forall a. Maybe a
Nothing (Value -> Node) -> Value -> Node
forall a b. (a -> b) -> a -> b
$ Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
s


-- | All allowed node values. We can't use Aeson's Value, because it doesn't support tags, binary data, or references
data Value
  = Bool !Bool
  | Number !Scientific
  | Integer !Integer
  | String !Text
  | -- | RawBinary !ByteString
    NDArray !NDArrayData
  | Array ![Node]
  | Object !Object
  | Reference !JSONReference
  | Alias !Anchor
  | Null
  deriving (Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Value -> ShowS
showsPrec :: Int -> Value -> ShowS
$cshow :: Value -> String
show :: Value -> String
$cshowList :: [Value] -> ShowS
showList :: [Value] -> ShowS
Show, Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
/= :: Value -> Value -> Bool
Eq)


instance IsString Value where
  fromString :: String -> Value
fromString = Text -> Value
String (Text -> Value) -> (String -> Text) -> String -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack
instance Semigroup Value where
  String Text
a <> :: Value -> Value -> Value
<> String Text
b = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b
  Array [Node]
as <> Array [Node]
bs = [Node] -> Value
Array ([Node] -> Value) -> [Node] -> Value
forall a b. (a -> b) -> a -> b
$ [Node]
as [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node]
bs
  Object Object
as <> Object Object
bs = Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Object
as Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> Object
bs
  Value
Null <> Value
b = Value
b
  Value
a <> Value
Null = Value
a
  Value
a <> Value
_ = Value
a
instance Monoid Value where
  mempty :: Value
mempty = Value
Null


type Key = Text
type Object = [(Key, Node)]


-- | Makes a node from a value
fromValue :: Value -> Node
fromValue :: Value -> Node
fromValue = SchemaTag -> Maybe Anchor -> Value -> Node
Node SchemaTag
forall a. Monoid a => a
mempty Maybe Anchor
forall a. Maybe a
Nothing


-- | Root Object with all anchors resolved
newtype Tree = Tree Object
  deriving newtype (NonEmpty Tree -> Tree
Tree -> Tree -> Tree
(Tree -> Tree -> Tree)
-> (NonEmpty Tree -> Tree)
-> (forall b. Integral b => b -> Tree -> Tree)
-> Semigroup Tree
forall b. Integral b => b -> Tree -> Tree
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Tree -> Tree -> Tree
<> :: Tree -> Tree -> Tree
$csconcat :: NonEmpty Tree -> Tree
sconcat :: NonEmpty Tree -> Tree
$cstimes :: forall b. Integral b => b -> Tree -> Tree
stimes :: forall b. Integral b => b -> Tree -> Tree
Semigroup, Semigroup Tree
Tree
Semigroup Tree =>
Tree -> (Tree -> Tree -> Tree) -> ([Tree] -> Tree) -> Monoid Tree
[Tree] -> Tree
Tree -> Tree -> Tree
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Tree
mempty :: Tree
$cmappend :: Tree -> Tree -> Tree
mappend :: Tree -> Tree -> Tree
$cmconcat :: [Tree] -> Tree
mconcat :: [Tree] -> Tree
Monoid, Int -> Tree -> ShowS
[Tree] -> ShowS
Tree -> String
(Int -> Tree -> ShowS)
-> (Tree -> String) -> ([Tree] -> ShowS) -> Show Tree
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Tree -> ShowS
showsPrec :: Int -> Tree -> ShowS
$cshow :: Tree -> String
show :: Tree -> String
$cshowList :: [Tree] -> ShowS
showList :: [Tree] -> ShowS
Show)


-- always $ref: uri#path
data JSONReference = JSONReference
  { JSONReference -> Text
uri :: Text
  , JSONReference -> JSONPointer
pointer :: JSONPointer
  }
  deriving (JSONReference -> JSONReference -> Bool
(JSONReference -> JSONReference -> Bool)
-> (JSONReference -> JSONReference -> Bool) -> Eq JSONReference
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JSONReference -> JSONReference -> Bool
== :: JSONReference -> JSONReference -> Bool
$c/= :: JSONReference -> JSONReference -> Bool
/= :: JSONReference -> JSONReference -> Bool
Eq)
instance Show JSONReference where
  show :: JSONReference -> String
show JSONReference
ref = Text -> String
unpack JSONReference
ref.uri String -> ShowS
forall a. [a] -> [a] -> [a]
++ JSONPointer -> String
forall a. Show a => a -> String
show JSONReference
ref.pointer


jsonReference :: Text -> JSONReference
jsonReference :: Text -> JSONReference
jsonReference Text
t =
  let (Text
uri, Text
rest) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"#" Text
t
   in Text -> JSONPointer -> JSONReference
JSONReference Text
uri (Text -> JSONPointer
jsonPointer Text
rest)


jsonPointer :: Text -> JSONPointer
jsonPointer :: Text -> JSONPointer
jsonPointer Text
t =
  let segs :: [Text]
segs = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#') Text
t
   in Path -> JSONPointer
JSONPointer (Path -> JSONPointer) -> Path -> JSONPointer
forall a b. (a -> b) -> a -> b
$ [Ref] -> Path
Path ((Text -> Ref) -> [Text] -> [Ref]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Ref
ref [Text]
segs)
 where
  ref :: Text -> Ref
  ref :: Text -> Ref
ref Text
s = Ref -> Maybe Ref -> Ref
forall a. a -> Maybe a -> a
fromMaybe (Text -> Ref
Child Text
s) (Maybe Ref -> Ref) -> Maybe Ref -> Ref
forall a b. (a -> b) -> a -> b
$ do
    Int
n <- String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
unpack Text
s)
    Ref -> Maybe Ref
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ref -> Maybe Ref) -> Ref -> Maybe Ref
forall a b. (a -> b) -> a -> b
$ Int -> Ref
Index Int
n


newtype JSONPointer = JSONPointer Path
  deriving (JSONPointer -> JSONPointer -> Bool
(JSONPointer -> JSONPointer -> Bool)
-> (JSONPointer -> JSONPointer -> Bool) -> Eq JSONPointer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JSONPointer -> JSONPointer -> Bool
== :: JSONPointer -> JSONPointer -> Bool
$c/= :: JSONPointer -> JSONPointer -> Bool
/= :: JSONPointer -> JSONPointer -> Bool
Eq)
instance Show JSONPointer where
  show :: JSONPointer -> String
show (JSONPointer Path
ps) = String
"#/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Path -> String
forall a. Show a => a -> String
show Path
ps


newtype Anchor = Anchor {Anchor -> Text
anchor :: Text}
  deriving (Anchor -> Anchor -> Bool
(Anchor -> Anchor -> Bool)
-> (Anchor -> Anchor -> Bool) -> Eq Anchor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Anchor -> Anchor -> Bool
== :: Anchor -> Anchor -> Bool
$c/= :: Anchor -> Anchor -> Bool
/= :: Anchor -> Anchor -> Bool
Eq)
  deriving newtype (String -> Anchor
(String -> Anchor) -> IsString Anchor
forall a. (String -> a) -> IsString a
$cfromString :: String -> Anchor
fromString :: String -> Anchor
IsString, Int -> Anchor -> ShowS
[Anchor] -> ShowS
Anchor -> String
(Int -> Anchor -> ShowS)
-> (Anchor -> String) -> ([Anchor] -> ShowS) -> Show Anchor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Anchor -> ShowS
showsPrec :: Int -> Anchor -> ShowS
$cshow :: Anchor -> String
show :: Anchor -> String
$cshowList :: [Anchor] -> ShowS
showList :: [Anchor] -> ShowS
Show)


newtype Anchors = Anchors [(Anchor, Value)]
  deriving (Int -> Anchors -> ShowS
[Anchors] -> ShowS
Anchors -> String
(Int -> Anchors -> ShowS)
-> (Anchors -> String) -> ([Anchors] -> ShowS) -> Show Anchors
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Anchors -> ShowS
showsPrec :: Int -> Anchors -> ShowS
$cshow :: Anchors -> String
show :: Anchors -> String
$cshowList :: [Anchors] -> ShowS
showList :: [Anchors] -> ShowS
Show, Anchors -> Anchors -> Bool
(Anchors -> Anchors -> Bool)
-> (Anchors -> Anchors -> Bool) -> Eq Anchors
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Anchors -> Anchors -> Bool
== :: Anchors -> Anchors -> Bool
$c/= :: Anchors -> Anchors -> Bool
/= :: Anchors -> Anchors -> Bool
Eq)
  deriving newtype (Semigroup Anchors
Anchors
Semigroup Anchors =>
Anchors
-> (Anchors -> Anchors -> Anchors)
-> ([Anchors] -> Anchors)
-> Monoid Anchors
[Anchors] -> Anchors
Anchors -> Anchors -> Anchors
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Anchors
mempty :: Anchors
$cmappend :: Anchors -> Anchors -> Anchors
mappend :: Anchors -> Anchors -> Anchors
$cmconcat :: [Anchors] -> Anchors
mconcat :: [Anchors] -> Anchors
Monoid, NonEmpty Anchors -> Anchors
Anchors -> Anchors -> Anchors
(Anchors -> Anchors -> Anchors)
-> (NonEmpty Anchors -> Anchors)
-> (forall b. Integral b => b -> Anchors -> Anchors)
-> Semigroup Anchors
forall b. Integral b => b -> Anchors -> Anchors
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Anchors -> Anchors -> Anchors
<> :: Anchors -> Anchors -> Anchors
$csconcat :: NonEmpty Anchors -> Anchors
sconcat :: NonEmpty Anchors -> Anchors
$cstimes :: forall b. Integral b => b -> Anchors -> Anchors
stimes :: forall b. Integral b => b -> Anchors -> Anchors
Semigroup)