{-# LANGUAGE OverloadedStrings, TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Data.Greskell.Greskell
(
Greskell,
ToGreskell(..),
toGremlin,
toGremlinLazy,
string,
true,
false,
list,
single,
number,
value,
valueInt,
gvalue,
gvalueInt,
unsafeGreskell,
unsafeGreskellLazy,
unsafeFunCall,
unsafeMethodCall
) where
import Data.Aeson (Value)
import qualified Data.Aeson as Aeson
import Data.Bifunctor (bimap)
import Data.Foldable (toList)
import qualified Data.HashMap.Lazy as HM
import Data.Monoid (Monoid(..))
import Data.Ratio (numerator, denominator, Rational)
import Data.Scientific (Scientific, coefficient, base10Exponent)
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import Data.List (intersperse)
import Data.Text (Text, pack, unpack)
import qualified Data.Text.Lazy as TL
import Data.Greskell.GraphSON (GValue, GValueBody(..), nonTypedGValue)
newtype Greskell a = Greskell { unGreskell :: TL.Text }
deriving (Show,Eq,Ord)
instance IsString a => IsString (Greskell a) where
fromString = Greskell . TL.pack . escapeDQuotes
instance Functor Greskell where
fmap _ = Greskell . unGreskell
instance Num a => Num (Greskell a) where
(+) = biOp "+"
(-) = biOp "-"
(*) = biOp "*"
negate (Greskell a) = Greskell ("-" <> paren a)
abs (Greskell a) = Greskell ("java.lang.Math.abs" <> paren a)
signum (Greskell a) = Greskell ("java.lang.Long.signum" <> paren a)
fromInteger val = Greskell (TL.pack $ show val)
instance Fractional a => Fractional (Greskell a) where
(/) = biOp "/"
recip (Greskell a) = Greskell ("1.0/" <> paren a)
fromRational rat = Greskell $ scriptOf numerator <> ".0/" <> scriptOf denominator
where
scriptOf accessor = TL.pack $ show $ accessor rat
instance IsString a => Semigroup (Greskell a) where
(<>) = biOp "+"
instance IsString a => Monoid (Greskell a) where
mempty = fromString ""
mappend = (<>)
class ToGreskell a where
type GreskellReturn a
toGreskell :: a -> Greskell (GreskellReturn a)
instance ToGreskell (Greskell a) where
type GreskellReturn (Greskell a) = a
toGreskell = id
biOp :: TL.Text -> Greskell a -> Greskell a -> Greskell a
biOp operator (Greskell a) (Greskell b) = Greskell (paren a <> operator <> paren b)
paren :: TL.Text -> TL.Text
paren t = "(" <> t <> ")"
escapeDQuotes :: String -> String
escapeDQuotes orig = ('"' : (esc =<< orig)) ++ "\""
where
esc c = case c of
'\n' -> "\\n"
'\r' -> "\\r"
'\t' -> "\\t"
'\\' -> "\\\\"
'"' -> "\\\""
'$' -> "\\$"
x -> [x]
unsafeGreskell :: Text
-> Greskell a
unsafeGreskell = Greskell . TL.fromStrict
unsafeGreskellLazy :: TL.Text
-> Greskell a
unsafeGreskellLazy = Greskell
string :: Text -> Greskell Text
string = fromString . unpack
true :: Greskell Bool
true = unsafeGreskell "true"
false :: Greskell Bool
false = unsafeGreskell "false"
list :: [Greskell a] -> Greskell [a]
list gs = unsafeGreskellLazy $ ("[" <> TL.intercalate "," gs_txt <> "]")
where
gs_txt = map toGremlinLazy gs
single :: Greskell a -> Greskell [a]
single g = list [g]
number :: Scientific -> Greskell Scientific
number = unsafeGreskell . pack . show
value :: Value -> Greskell Value
value Aeson.Null = unsafeGreskellLazy "null"
value (Aeson.Bool b) = unsafeToValue (if b then true else false)
value (Aeson.Number sci) = unsafeToValue $ number sci
value (Aeson.String s) = unsafeToValue $ string s
value (Aeson.Array v) = unsafeToValue $ list $ map value $ toList v
value (Aeson.Object obj)
| HM.null obj = unsafeGreskellLazy "[:]"
| otherwise = unsafeGreskellLazy $ toGroovyMap $ HM.toList obj
where
toGroovyMap pairs = "[" <> TL.intercalate "," (map toPairText pairs) <> "]"
toPairText (key, val) = (toGremlinLazy $ string key) <> ":" <> (toGremlinLazy $ value val)
valueInt :: Integral a => a -> Greskell Value
valueInt n = fmap toValue $ fromIntegral n
where
toValue :: Integer -> Value
toValue = const Aeson.Null
gvalue :: Value -> Greskell GValue
gvalue = fmap phantomToGValue . value
where
phantomToGValue _ = nonTypedGValue $ GNull
gvalueInt :: Integral a => a -> Greskell GValue
gvalueInt n = fmap toGValue $ fromIntegral n
where
toGValue :: Integer -> GValue
toGValue = const $ nonTypedGValue $ GNull
unsafeToValue :: Greskell a -> Greskell Value
unsafeToValue = fmap (const Aeson.Null)
toGremlin :: ToGreskell a => a -> Text
toGremlin = TL.toStrict . unGreskell . toGreskell
toGremlinLazy :: ToGreskell a => a -> TL.Text
toGremlinLazy = unGreskell . toGreskell
unsafeFunCallText :: Text -> [Text] -> Text
unsafeFunCallText fun_name args = fun_name <> "(" <> args_g <> ")"
where
args_g = mconcat $ intersperse "," args
unsafeFunCall :: Text
-> [Text]
-> Greskell a
unsafeFunCall fun_name args = unsafeGreskell $ unsafeFunCallText fun_name args
unsafeMethodCall :: Greskell a
-> Text
-> [Text]
-> Greskell b
unsafeMethodCall target name args = unsafeGreskell ("(" <> toGremlin target <> ")." <> unsafeFunCallText name args)