{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
module MiniLight.Loader.Internal.Resolver where

import Control.Applicative
import Control.Monad
import Data.Aeson hiding (Result)
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Scientific (fromFloatDigits)
import qualified Data.Vector as V
import GHC.Generics (Generic)
import MiniLight.Loader.Internal.Types
import Text.Trifecta

data Expr
  = None
  | Ref T.Text  -- ^ reference syntax: ${ref:...}
  | Var T.Text  -- ^ variable syntax: ${var:...}
  | Op T.Text Expr Expr  -- ^ expr operator: +, -, *, /
  | Constant Value  -- ^ constants (string or number or null)
  | Symbol T.Text  -- ^ token symbol
  | App Expr [Expr]  -- ^ function application ($func(a,b,c))
  deriving (Expr -> Expr -> Bool
(Expr -> Expr -> Bool) -> (Expr -> Expr -> Bool) -> Eq Expr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Expr -> Expr -> Bool
$c/= :: Expr -> Expr -> Bool
== :: Expr -> Expr -> Bool
$c== :: Expr -> Expr -> Bool
Eq, Int -> Expr -> ShowS
[Expr] -> ShowS
Expr -> String
(Int -> Expr -> ShowS)
-> (Expr -> String) -> ([Expr] -> ShowS) -> Show Expr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Expr] -> ShowS
$cshowList :: [Expr] -> ShowS
show :: Expr -> String
$cshow :: Expr -> String
showsPrec :: Int -> Expr -> ShowS
$cshowsPrec :: Int -> Expr -> ShowS
Show, (forall x. Expr -> Rep Expr x)
-> (forall x. Rep Expr x -> Expr) -> Generic Expr
forall x. Rep Expr x -> Expr
forall x. Expr -> Rep Expr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Expr x -> Expr
$cfrom :: forall x. Expr -> Rep Expr x
Generic)

instance ToJSON Expr
instance FromJSON Expr

parser :: Parser Expr
parser :: Parser Expr
parser = Parser Expr -> Parser Expr
forall (m :: * -> *) a. Parsing m => m a -> m a
try Parser Expr
reference Parser Expr -> Parser Expr -> Parser Expr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Expr -> Parser Expr
forall (m :: * -> *) a. Parsing m => m a -> m a
try Parser Expr
variable Parser Expr -> Parser Expr -> Parser Expr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Expr -> Parser Expr
forall (m :: * -> *) a. Parsing m => m a -> m a
try (Char -> Parser Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char '$' Parser Char -> Parser Expr -> Parser Expr
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Expr -> Parser Expr
forall (m :: * -> *) a. TokenParsing m => m a -> m a
braces Parser Expr
expr)
 where
  expr :: Parser Expr
expr  = Parser Expr -> Parser (Expr -> Expr -> Expr) -> Expr -> Parser Expr
forall (m :: * -> *) a.
Alternative m =>
m a -> m (a -> a -> a) -> a -> m a
chainl Parser Expr
expr1 Parser (Expr -> Expr -> Expr)
op1 Expr
None
  expr1 :: Parser Expr
expr1 = Parser Expr -> Parser (Expr -> Expr -> Expr) -> Expr -> Parser Expr
forall (m :: * -> *) a.
Alternative m =>
m a -> m (a -> a -> a) -> a -> m a
chainl Parser Expr
expr2 Parser (Expr -> Expr -> Expr)
op2 Expr
None
  expr2 :: Parser Expr
expr2 =
    Parser Expr -> Parser Expr
forall (m :: * -> *) a. TokenParsing m => m a -> m a
parens Parser Expr
expr
      Parser Expr -> Parser Expr -> Parser Expr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Expr -> Parser Expr
forall (m :: * -> *) a. Parsing m => m a -> m a
try Parser Expr
apply
      Parser Expr -> Parser Expr -> Parser Expr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Expr -> Parser Expr
forall (m :: * -> *) a. Parsing m => m a -> m a
try Parser Expr
parameter
      Parser Expr -> Parser Expr -> Parser Expr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Expr -> Parser Expr
forall (m :: * -> *) a. Parsing m => m a -> m a
try Parser Expr
reference
      Parser Expr -> Parser Expr -> Parser Expr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Expr -> Parser Expr
forall (m :: * -> *) a. Parsing m => m a -> m a
try Parser Expr
variable
      Parser Expr -> Parser Expr -> Parser Expr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Expr -> Parser Expr
forall (m :: * -> *) a. Parsing m => m a -> m a
try Parser Expr
number
      Parser Expr -> Parser Expr -> Parser Expr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Expr -> Parser Expr
forall (m :: * -> *) a. Parsing m => m a -> m a
try Parser Expr
strlit

  -- low precedence infixl operator group
  op1 :: Parser (Expr -> Expr -> Expr)
op1       = Text -> Expr -> Expr -> Expr
Op "+" (Expr -> Expr -> Expr)
-> Parser Text -> Parser (Expr -> Expr -> Expr)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
forall (m :: * -> *). TokenParsing m => Text -> m Text
textSymbol "+" Parser (Expr -> Expr -> Expr)
-> Parser (Expr -> Expr -> Expr) -> Parser (Expr -> Expr -> Expr)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Expr -> Expr -> Expr
Op "-" (Expr -> Expr -> Expr)
-> Parser Text -> Parser (Expr -> Expr -> Expr)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
forall (m :: * -> *). TokenParsing m => Text -> m Text
textSymbol "-"

  -- high precedence infixl operator group
  op2 :: Parser (Expr -> Expr -> Expr)
op2       = Text -> Expr -> Expr -> Expr
Op "*" (Expr -> Expr -> Expr)
-> Parser Text -> Parser (Expr -> Expr -> Expr)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
forall (m :: * -> *). TokenParsing m => Text -> m Text
textSymbol "*" Parser (Expr -> Expr -> Expr)
-> Parser (Expr -> Expr -> Expr) -> Parser (Expr -> Expr -> Expr)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Expr -> Expr -> Expr
Op "/" (Expr -> Expr -> Expr)
-> Parser Text -> Parser (Expr -> Expr -> Expr)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Text
forall (m :: * -> *). TokenParsing m => Text -> m Text
textSymbol "/"

  reference :: Parser Expr
reference = Char -> Parser Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char '$' Parser Char -> Parser Expr -> Parser Expr
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> do
    Parser Expr -> Parser Expr
forall (m :: * -> *) a. TokenParsing m => m a -> m a
braces (Parser Expr -> Parser Expr) -> Parser Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
forall (m :: * -> *). CharParsing m => Text -> m Text
text "ref:" Parser Text -> Parser Expr -> Parser Expr
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((String -> Expr) -> Parser String -> Parser Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Expr
Ref (Text -> Expr) -> (String -> Text) -> String -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (Parser Char -> Parser String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser Char
forall (m :: * -> *). CharParsing m => m Char
letter Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser Char
forall (m :: * -> *). CharParsing m => String -> m Char
oneOf ".")))
  variable :: Parser Expr
variable = Char -> Parser Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char '$' Parser Char -> Parser Expr -> Parser Expr
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> do
    Parser Expr -> Parser Expr
forall (m :: * -> *) a. TokenParsing m => m a -> m a
braces (Parser Expr -> Parser Expr) -> Parser Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
forall (m :: * -> *). CharParsing m => Text -> m Text
text "var:" Parser Text -> Parser Expr -> Parser Expr
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((String -> Expr) -> Parser String -> Parser Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Expr
Var (Text -> Expr) -> (String -> Text) -> String -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (Parser Char -> Parser String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser Char
forall (m :: * -> *). CharParsing m => m Char
letter Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser Char
forall (m :: * -> *). CharParsing m => String -> m Char
oneOf ".")))
  number :: Parser Expr
number = (Either Integer Double -> Expr)
-> Parser (Either Integer Double) -> Parser Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Value -> Expr
Constant (Value -> Expr)
-> (Either Integer Double -> Value)
-> Either Integer Double
-> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Value
Number (Scientific -> Value)
-> (Either Integer Double -> Scientific)
-> Either Integer Double
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Scientific)
-> (Double -> Scientific) -> Either Integer Double -> Scientific
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Integer -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral Double -> Scientific
forall a. RealFloat a => a -> Scientific
fromFloatDigits)
                Parser (Either Integer Double)
forall (m :: * -> *). TokenParsing m => m (Either Integer Double)
integerOrDouble
  strlit :: Parser Expr
strlit    = (Text -> Expr) -> Parser Text -> Parser Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Value -> Expr
Constant (Value -> Expr) -> (Text -> Value) -> Text -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
String) (Parser Text -> Parser Expr) -> Parser Text -> Parser Expr
forall a b. (a -> b) -> a -> b
$ Parser Text
forall (m :: * -> *) s. (TokenParsing m, IsString s) => m s
stringLiteral

  parameter :: Parser Expr
parameter = Char -> Parser Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char '$' Parser Char -> Parser Expr -> Parser Expr
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> do
    (String -> Expr) -> Parser String -> Parser Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Expr
Symbol (Text -> Expr) -> (String -> Text) -> String -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (Parser String -> Parser Expr) -> Parser String -> Parser Expr
forall a b. (a -> b) -> a -> b
$ (:) (Char -> ShowS) -> Parser Char -> Parser ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char
forall (m :: * -> *). CharParsing m => m Char
letter Parser ShowS -> Parser String -> Parser String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Char -> Parser String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser Char
forall (m :: * -> *). CharParsing m => m Char
letter Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char
forall (m :: * -> *). CharParsing m => m Char
digit)
  apply :: Parser Expr
apply = do
    Expr
func <- Parser Expr
parameter
    [Expr]
exps <-
      Parser [Expr] -> Parser [Expr]
forall (m :: * -> *) a. TokenParsing m => m a -> m a
parens
      (Parser [Expr] -> Parser [Expr]) -> Parser [Expr] -> Parser [Expr]
forall a b. (a -> b) -> a -> b
$       [Expr] -> Parser [Expr] -> Parser [Expr]
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option []
      (Parser [Expr] -> Parser [Expr]) -> Parser [Expr] -> Parser [Expr]
forall a b. (a -> b) -> a -> b
$       ([Expr] -> [Expr]) -> Parser [Expr] -> Parser [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Expr -> Bool) -> [Expr] -> [Expr]
forall a. (a -> Bool) -> [a] -> [a]
filter (Expr -> Expr -> Bool
forall a. Eq a => a -> a -> Bool
/= Expr
None))
      (Parser [Expr] -> Parser [Expr]) -> Parser [Expr] -> Parser [Expr]
forall a b. (a -> b) -> a -> b
$       Parser [Expr] -> Parser [Expr]
forall (m :: * -> *) a. Parsing m => m a -> m a
try
      (Parser [Expr] -> Parser [Expr]) -> Parser [Expr] -> Parser [Expr]
forall a b. (a -> b) -> a -> b
$       (:)
      (Expr -> [Expr] -> [Expr])
-> Parser Expr -> Parser ([Expr] -> [Expr])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>     Parser Expr
expr
      Parser ([Expr] -> [Expr]) -> Parser [Expr] -> Parser [Expr]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>     Parser Expr
expr
      Parser Expr -> Parser Char -> Parser [Expr]
forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
`sepBy` (Char -> Parser Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char ',')
    Expr -> Parser Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ Expr -> [Expr] -> Expr
App Expr
func [Expr]
exps

data Context = Context {
  Context -> Vector (Either Int Text)
path :: V.Vector (Either Int T.Text),
  Context -> Object
variables :: Object,
  Context -> Object
values :: HM.HashMap T.Text Value
}

emptyContext :: Context
emptyContext :: Context
emptyContext = Vector (Either Int Text) -> Object -> Object -> Context
Context Vector (Either Int Text)
forall a. Vector a
V.empty Object
forall k v. HashMap k v
HM.empty Object
forall k v. HashMap k v
HM.empty

getAt :: Value -> [Either Int T.Text] -> Either T.Text Value
getAt :: Value -> [Either Int Text] -> Either Text Value
getAt = Value -> [Either Int Text] -> Either Text Value
go
 where
  go :: Value -> [Either Int Text] -> Either Text Value
go value :: Value
value        [] = Value -> Either Text Value
forall a b. b -> Either a b
Right Value
value
  go (Object obj :: Object
obj) (Right key :: Text
key:ps :: [Either Int Text]
ps) | Text
key Text -> Object -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
`HM.member` Object
obj = Value -> [Either Int Text] -> Either Text Value
go (Object
obj Object -> Text -> Value
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> v
HM.! Text
key) [Either Int Text]
ps
  go (Array  arr :: Array
arr) (Left  i :: Int
i  :ps :: [Either Int Text]
ps) | 0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Array -> Int
forall a. Vector a -> Int
V.length Array
arr = Value -> [Either Int Text] -> Either Text Value
go (Array
arr Array -> Int -> Value
forall a. Vector a -> Int -> a
V.! Int
i) [Either Int Text]
ps
  go v :: Value
v (p :: Either Int Text
p:_) =
    Text -> Either Text Value
forall a b. a -> Either a b
Left
      (Text -> Either Text Value) -> Text -> Either Text Value
forall a b. (a -> b) -> a -> b
$  "TypeError: path `"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Either Int Text -> String
forall a. Show a => a -> String
show Either Int Text
p)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "` is missing in `"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Value -> String
forall a. Show a => a -> String
show Value
v)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "`"

normalize
  :: V.Vector (Either Int T.Text) -> [Either Int T.Text] -> [Either Int T.Text]
normalize :: Vector (Either Int Text) -> [Either Int Text] -> [Either Int Text]
normalize path1 :: Vector (Either Int Text)
path1 ts :: [Either Int Text]
ts = Vector (Either Int Text) -> [Either Int Text]
forall a. Vector a -> [a]
V.toList Vector (Either Int Text)
path1' [Either Int Text] -> [Either Int Text] -> [Either Int Text]
forall a. [a] -> [a] -> [a]
++ (Either Int Text -> Bool) -> [Either Int Text] -> [Either Int Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\v :: Either Int Text
v -> Either Int Text
v Either Int Text -> Either Int Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Either Int Text
forall a b. b -> Either a b
Right "") [Either Int Text]
ts
 where
  depth :: Int
depth  = [Either Int Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Either Int Text] -> Int) -> [Either Int Text] -> Int
forall a b. (a -> b) -> a -> b
$ (Either Int Text -> Bool) -> [Either Int Text] -> [Either Int Text]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\v :: Either Int Text
v -> Either Int Text
v Either Int Text -> Either Int Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Either Int Text
forall a b. b -> Either a b
Right "") [Either Int Text]
ts
  path1' :: Vector (Either Int Text)
path1' = Int -> Vector (Either Int Text) -> Vector (Either Int Text)
forall a. Int -> Vector a -> Vector a
V.take (Vector (Either Int Text) -> Int
forall a. Vector a -> Int
V.length Vector (Either Int Text)
path1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Vector (Either Int Text)
path1

eval :: Context -> Value -> Expr -> Either T.Text Value
eval :: Context -> Value -> Expr -> Either Text Value
eval ctx :: Context
ctx target :: Value
target = Expr -> Either Text Value
go
 where
  go :: Expr -> Either Text Value
go None = Value -> Either Text Value
forall a b. b -> Either a b
Right ""
  go (Ref path' :: Text
path') =
    (Text -> Either Text Value)
-> (Value -> Either Text Value)
-> Either Text Value
-> Either Text Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Either Text Value
forall a b. a -> Either a b
Left (Text -> Either Text Value)
-> (Text -> Text) -> Text -> Either Text Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (("Error in `${ref:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "}`\n") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)) Value -> Either Text Value
forall a b. b -> Either a b
Right
      (Either Text Value -> Either Text Value)
-> Either Text Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ Value -> [Either Int Text] -> Either Text Value
getAt Value
target (Vector (Either Int Text) -> [Either Int Text] -> [Either Int Text]
normalize (Context -> Vector (Either Int Text)
path Context
ctx) (Text -> [Either Int Text]
convertPath Text
path'))
  go (Var path' :: Text
path') =
    (Text -> Either Text Value)
-> (Value -> Either Text Value)
-> Either Text Value
-> Either Text Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Either Text Value
forall a b. a -> Either a b
Left (Text -> Either Text Value)
-> (Text -> Text) -> Text -> Either Text Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (("Error in `${var:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "}`\n") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)) Value -> Either Text Value
forall a b. b -> Either a b
Right
      (Either Text Value -> Either Text Value)
-> Either Text Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ Value -> [Either Int Text] -> Either Text Value
getAt (Object -> Value
Object (Context -> Object
variables Context
ctx)) (Vector (Either Int Text) -> [Either Int Text] -> [Either Int Text]
normalize Vector (Either Int Text)
forall a. Vector a
V.empty (Text -> [Either Int Text]
convertPath Text
path'))
  go (Op "+" e1 :: Expr
e1 e2 :: Expr
e2) = (Scientific -> Scientific -> Scientific)
-> Expr -> Expr -> Either Text Value
runOp Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
(+) Expr
e1 Expr
e2
  go (Op "-" e1 :: Expr
e1 e2 :: Expr
e2) = (Scientific -> Scientific -> Scientific)
-> Expr -> Expr -> Either Text Value
runOp (-) Expr
e1 Expr
e2
  go (Op "*" e1 :: Expr
e1 e2 :: Expr
e2) = (Scientific -> Scientific -> Scientific)
-> Expr -> Expr -> Either Text Value
runOp Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
(*) Expr
e1 Expr
e2
  go (Op "/" e1 :: Expr
e1 e2 :: Expr
e2) = (Scientific -> Scientific -> Scientific)
-> Expr -> Expr -> Either Text Value
runOp Scientific -> Scientific -> Scientific
forall a. Fractional a => a -> a -> a
(/) Expr
e1 Expr
e2
  go (Symbol t :: Text
t) =
    Either Text Value
-> (Value -> Either Text Value) -> Maybe Value -> Either Text Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text Value
forall a b. a -> Either a b
Left (Text -> Either Text Value) -> Text -> Either Text Value
forall a b. (a -> b) -> a -> b
$ "Symbol not defined: `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "`") Value -> Either Text Value
forall a b. b -> Either a b
Right
      (Maybe Value -> Either Text Value)
-> Maybe Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
t
      (Object -> Maybe Value) -> Object -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Context -> Object
values Context
ctx
  go expr :: Expr
expr = Text -> Either Text Value
forall a b. a -> Either a b
Left (Text -> Either Text Value) -> Text -> Either Text Value
forall a b. (a -> b) -> a -> b
$ "Illegal expression: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Expr -> String
forall a. Show a => a -> String
show Expr
expr)

  runOp :: (Scientific -> Scientific -> Scientific)
-> Expr -> Expr -> Either Text Value
runOp op :: Scientific -> Scientific -> Scientific
op e1 :: Expr
e1 e2 :: Expr
e2 =
    (Scientific -> Value)
-> Either Text Scientific -> Either Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Scientific -> Value
Number
      (Either Text Scientific -> Either Text Value)
-> Either Text Scientific -> Either Text Value
forall a b. (a -> b) -> a -> b
$   Either Text (Either Text Scientific) -> Either Text Scientific
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
      (Either Text (Either Text Scientific) -> Either Text Scientific)
-> Either Text (Either Text Scientific) -> Either Text Scientific
forall a b. (a -> b) -> a -> b
$   (\x :: Value
x y :: Value
y -> Scientific -> Scientific -> Scientific
op (Scientific -> Scientific -> Scientific)
-> Either Text Scientific -> Either Text (Scientific -> Scientific)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either Text Scientific
asNumber Value
x Either Text (Scientific -> Scientific)
-> Either Text Scientific -> Either Text Scientific
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either Text Scientific
asNumber Value
y)
      (Value -> Value -> Either Text Scientific)
-> Either Text Value
-> Either Text (Value -> Either Text Scientific)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> Either Text Value
go Expr
e1
      Either Text (Value -> Either Text Scientific)
-> Either Text Value -> Either Text (Either Text Scientific)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> Either Text Value
go Expr
e2

  asNumber :: Value -> Either Text Scientific
asNumber (Number x :: Scientific
x) = Scientific -> Either Text Scientific
forall a b. b -> Either a b
Right Scientific
x
  asNumber x :: Value
x          = Text -> Either Text Scientific
forall a b. a -> Either a b
Left (Text -> Either Text Scientific) -> Text -> Either Text Scientific
forall a b. (a -> b) -> a -> b
$ "Not a number: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Value -> String
forall a. Show a => a -> String
show Value
x)

convertPath :: T.Text -> [Either Int T.Text]
convertPath :: Text -> [Either Int Text]
convertPath =
  (Text -> Either Int Text) -> [Text] -> [Either Int Text]
forall a b. (a -> b) -> [a] -> [b]
map (\t :: Text
t -> (Text -> Either Int Text)
-> (Integer -> Either Int Text)
-> Either Text Integer
-> Either Int Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\_ -> Text -> Either Int Text
forall a b. b -> Either a b
Right Text
t) (Int -> Either Int Text
forall a b. a -> Either a b
Left (Int -> Either Int Text)
-> (Integer -> Int) -> Integer -> Either Int Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Either Text Integer -> Either Int Text)
-> Either Text Integer -> Either Int Text
forall a b. (a -> b) -> a -> b
$ Parser Integer -> Text -> Either Text Integer
forall a. Parser a -> Text -> Either Text a
parseText Parser Integer
index Text
t)
    ([Text] -> [Either Int Text])
-> (Text -> [Text]) -> Text -> [Either Int Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
T.splitOn "."
    (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\t :: Text
t -> if Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Bool -> Bool
&& Text -> Char
T.head Text
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.' then Text -> Text
T.tail Text
t else Text
t)
  where index :: Parser Integer
index = Char -> Parser Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char '[' Parser Char -> Parser Integer -> Parser Integer
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Integer
forall (m :: * -> *). TokenParsing m => m Integer
natural Parser Integer -> Parser Char -> Parser Integer
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char ']'

convert :: Context -> Value -> T.Text -> Either T.Text Value
convert :: Context -> Value -> Text -> Either Text Value
convert ctx :: Context
ctx target :: Value
target t :: Text
t =
  (Text -> Either Text Value)
-> (Expr -> Either Text Value)
-> Either Text Expr
-> Either Text Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\_ -> Value -> Either Text Value
forall a b. b -> Either a b
Right (Value -> Either Text Value) -> Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
t) (Context -> Value -> Expr -> Either Text Value
eval Context
ctx Value
target) (Either Text Expr -> Either Text Value)
-> Either Text Expr -> Either Text Value
forall a b. (a -> b) -> a -> b
$ Parser Expr -> Text -> Either Text Expr
forall a. Parser a -> Text -> Either Text a
parseText Parser Expr
parser Text
t

parseText :: Parser a -> T.Text -> Either T.Text a
parseText :: Parser a -> Text -> Either Text a
parseText parser :: Parser a
parser =
  (ErrInfo -> Either Text a)
-> (a -> Either Text a) -> Result a -> Either Text a
forall b a. (ErrInfo -> b) -> (a -> b) -> Result a -> b
foldResult (Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a)
-> (ErrInfo -> Text) -> ErrInfo -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (ErrInfo -> String) -> ErrInfo -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrInfo -> String
forall a. Show a => a -> String
show) a -> Either Text a
forall a b. b -> Either a b
Right
    (Result a -> Either Text a)
-> (Text -> Result a) -> Text -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> Delta -> ByteString -> Result a
forall a. Parser a -> Delta -> ByteString -> Result a
parseByteString Parser a
parser Delta
forall a. Monoid a => a
mempty
    (ByteString -> Result a)
-> (Text -> ByteString) -> Text -> Result a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TE.encodeUtf8

resolveWith :: Context -> Value -> Either T.Text Value
resolveWith :: Context -> Value -> Either Text Value
resolveWith ctx :: Context
ctx target :: Value
target = Context -> Value -> Either Text Value
go Context
ctx Value
target
 where
  go :: Context -> Value -> Either Text Value
go ctx :: Context
ctx (Object obj :: Object
obj)
    | "_vars" Text -> Object -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
`HM.member` Object
obj
    = let vars :: Value
vars = Object
obj Object -> Text -> Value
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> v
HM.! "_vars"
      in  Context -> Value -> Either Text Value
go
            ( Context
ctx
              { variables :: Object
variables = Object -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
HM.union ((\(Object o :: Object
o) -> Object
o) (Value -> Object) -> Value -> Object
forall a b. (a -> b) -> a -> b
$ Value
vars) (Context -> Object
variables Context
ctx)
              }
            )
            (Object -> Value
Object (Text -> Object -> Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete "_vars" Object
obj))
    | Bool
otherwise
    = (Object -> Value) -> Either Text Object -> Either Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Object -> Value
Object (Either Text Object -> Either Text Value)
-> Either Text Object -> Either Text Value
forall a b. (a -> b) -> a -> b
$ HashMap Text (Either Text Value) -> Either Text Object
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (HashMap Text (Either Text Value) -> Either Text Object)
-> HashMap Text (Either Text Value) -> Either Text Object
forall a b. (a -> b) -> a -> b
$ (Text -> Value -> Either Text Value)
-> Object -> HashMap Text (Either Text Value)
forall k v1 v2. (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2
HM.mapWithKey
      (\key :: Text
key -> Context -> Value -> Either Text Value
go (Context
ctx { path :: Vector (Either Int Text)
path = Vector (Either Int Text)
-> Either Int Text -> Vector (Either Int Text)
forall a. Vector a -> a -> Vector a
V.snoc (Context -> Vector (Either Int Text)
path Context
ctx) (Text -> Either Int Text
forall a b. b -> Either a b
Right Text
key) }))
      Object
obj
  go ctx :: Context
ctx (Array arr :: Array
arr) = (Array -> Value) -> Either Text Array -> Either Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Array -> Value
Array (Either Text Array -> Either Text Value)
-> Either Text Array -> Either Text Value
forall a b. (a -> b) -> a -> b
$ Vector (Either Text Value) -> Either Text Array
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Vector (Either Text Value) -> Either Text Array)
-> Vector (Either Text Value) -> Either Text Array
forall a b. (a -> b) -> a -> b
$ (Int -> Value -> Either Text Value)
-> Array -> Vector (Either Text Value)
forall a b. (Int -> a -> b) -> Vector a -> Vector b
V.imap
    (\i :: Int
i -> Context -> Value -> Either Text Value
go (Context
ctx { path :: Vector (Either Int Text)
path = Vector (Either Int Text)
-> Either Int Text -> Vector (Either Int Text)
forall a. Vector a -> a -> Vector a
V.snoc (Context -> Vector (Either Int Text)
path Context
ctx) (Int -> Either Int Text
forall a b. a -> Either a b
Left Int
i) }))
    Array
arr
  go ctx :: Context
ctx (String t :: Text
t) = Context -> Value -> Text -> Either Text Value
convert Context
ctx Value
target Text
t
  go _   (Number n :: Scientific
n) = Value -> Either Text Value
forall a b. b -> Either a b
Right (Value -> Either Text Value) -> Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ Scientific -> Value
Number Scientific
n
  go _   (Bool   b :: Bool
b) = Value -> Either Text Value
forall a b. b -> Either a b
Right (Value -> Either Text Value) -> Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
Bool Bool
b
  go _   Null       = Value -> Either Text Value
forall a b. b -> Either a b
Right Value
Null

-- | Interpret a JSON value, and unsafely apply fromRight
resolve :: Value -> Value
resolve :: Value -> Value
resolve = (\(Right a :: Value
a) -> Value
a) (Either Text Value -> Value)
-> (Value -> Either Text Value) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Value -> Either Text Value
resolveWith Context
emptyContext

-- | Create 'AppConfig' value from JSON value
parseAppConfig :: Value -> Either T.Text AppConfig
parseAppConfig :: Value -> Either Text AppConfig
parseAppConfig = Context -> Value -> Either Text AppConfig
conf (Vector (Either Int Text) -> Object -> Object -> Context
Context Vector (Either Int Text)
forall a. Vector a
V.empty Object
forall k v. HashMap k v
HM.empty Object
forall k v. HashMap k v
HM.empty)
 where
  conf :: Context -> Value -> Either T.Text AppConfig
  conf :: Context -> Value -> Either Text AppConfig
conf ctx :: Context
ctx (Object obj :: Object
obj) | "app" Text -> Object -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
`HM.member` Object
obj =
    let
      ctx' :: Context
ctx' = Context -> (Value -> Context) -> Maybe Value -> Context
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        Context
ctx
        ( \vars :: Value
vars -> Context
ctx
          { variables :: Object
variables = Object -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
HM.union ((\(Object o :: Object
o) -> Object
o) Value
vars) (Context -> Object
variables Context
ctx)
          }
        )
        (Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup "_vars" Object
obj)
    in
      (Vector ComponentConfig -> AppConfig)
-> Either Text (Vector ComponentConfig) -> Either Text AppConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\v :: Vector ComponentConfig
v -> Vector ComponentConfig -> Vector Text -> AppConfig
AppConfig Vector ComponentConfig
v Vector Text
forall a. Vector a
V.empty) (Either Text (Vector ComponentConfig) -> Either Text AppConfig)
-> Either Text (Vector ComponentConfig) -> Either Text AppConfig
forall a b. (a -> b) -> a -> b
$ Context -> Value -> Either Text (Vector ComponentConfig)
app Context
ctx' (Object
obj Object -> Text -> Value
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> v
HM.! "app")
  conf _ (Object obj :: Object
obj) =
    Text -> Either Text AppConfig
forall a b. a -> Either a b
Left (Text -> Either Text AppConfig) -> Text -> Either Text AppConfig
forall a b. (a -> b) -> a -> b
$ "path `app` is missing in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Value -> String
forall a. Show a => a -> String
show (Object -> Value
Object Object
obj))
  conf _ ast :: Value
ast = Text -> Either Text AppConfig
forall a b. a -> Either a b
Left (Text -> Either Text AppConfig) -> Text -> Either Text AppConfig
forall a b. (a -> b) -> a -> b
$ "Invalid format: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Value -> String
forall a. Show a => a -> String
show Value
ast)

  app :: Context -> Value -> Either T.Text (V.Vector ComponentConfig)
  app :: Context -> Value -> Either Text (Vector ComponentConfig)
app ctx :: Context
ctx (Array vec :: Array
vec) = (Value -> Either Text ComponentConfig)
-> Array -> Either Text (Vector ComponentConfig)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
V.mapM (Context -> Value -> Either Text ComponentConfig
component Context
ctx) Array
vec
  app _   ast :: Value
ast         = Text -> Either Text (Vector ComponentConfig)
forall a b. a -> Either a b
Left (Text -> Either Text (Vector ComponentConfig))
-> Text -> Either Text (Vector ComponentConfig)
forall a b. (a -> b) -> a -> b
$ "Invalid format: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Value -> String
forall a. Show a => a -> String
show Value
ast)

  component :: Context -> Value -> Either T.Text ComponentConfig
  component :: Context -> Value -> Either Text ComponentConfig
component ctx :: Context
ctx (Object obj :: Object
obj) | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Text -> Object -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
`HM.member` Object
obj) ["type", "properties"] = do
    let
      ctx' :: Context
ctx' = Context -> (Value -> Context) -> Maybe Value -> Context
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        Context
ctx
        ( \vars :: Value
vars -> Context
ctx
          { variables :: Object
variables = Object -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
HM.union ((\(Object o :: Object
o) -> Object
o) Value
vars) (Context -> Object
variables Context
ctx)
          }
        )
        (Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup "_vars" Object
obj)

    Value
nameValue <- Context -> Value -> Either Text Value
resolveWith Context
ctx' (Object
obj Object -> Text -> Value
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> v
HM.! "type")
    case Value
nameValue of
      String name :: Text
name -> do
        Value
props <- Context -> Value -> Either Text Value
resolveWith Context
ctx' (Object
obj Object -> Text -> Value
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> v
HM.! "properties")
        Maybe (HashMap Text Hook)
hooks <-
          Maybe (Either Text (HashMap Text Hook))
-> Either Text (Maybe (HashMap Text Hook))
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
            (Maybe (Either Text (HashMap Text Hook))
 -> Either Text (Maybe (HashMap Text Hook)))
-> Maybe (Either Text (HashMap Text Hook))
-> Either Text (Maybe (HashMap Text Hook))
forall a b. (a -> b) -> a -> b
$ ((Value -> Either Text (HashMap Text Hook))
-> Maybe Value -> Maybe (Either Text (HashMap Text Hook))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Object o :: Object
o) -> (Value -> Either Text Hook)
-> Object -> Either Text (HashMap Text Hook)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> Either Text Hook
toHook Object
o) (Maybe Value -> Maybe (Either Text (HashMap Text Hook)))
-> Maybe Value -> Maybe (Either Text (HashMap Text Hook))
forall a b. (a -> b) -> a -> b
$ Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup "hooks" Object
obj)
        ComponentConfig -> Either Text ComponentConfig
forall a b. b -> Either a b
Right (ComponentConfig -> Either Text ComponentConfig)
-> ComponentConfig -> Either Text ComponentConfig
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe Text
-> Value
-> Maybe (HashMap Text Hook)
-> ComponentConfig
ComponentConfig Text
name
                                ((Value -> Text) -> Maybe Value -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(String s :: Text
s) -> Text
s) (Maybe Value -> Maybe Text) -> Maybe Value -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup "id" Object
obj)
                                Value
props
                                Maybe (HashMap Text Hook)
hooks
      _ -> Text -> Either Text ComponentConfig
forall a b. a -> Either a b
Left (Text -> Either Text ComponentConfig)
-> Text -> Either Text ComponentConfig
forall a b. (a -> b) -> a -> b
$ "Invalid format: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Value -> String
forall a. Show a => a -> String
show Value
nameValue)
  component _ ast :: Value
ast = Text -> Either Text ComponentConfig
forall a b. a -> Either a b
Left (Text -> Either Text ComponentConfig)
-> Text -> Either Text ComponentConfig
forall a b. (a -> b) -> a -> b
$ "Invalid format: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Value -> String
forall a. Show a => a -> String
show Value
ast)