colorless 2.2.4 → 2.2.5

raw patch · 12 files changed

+173/−51 lines, 12 filesdep +text-conversions

Dependencies added: text-conversions

Files

• README.md +2/−2
• colorless.cabal +5/−1
• library/Colorless/Client.hs +3/−1
• library/Colorless/Client/Exchange.hs +65/−0
• library/Colorless/Endpoint.hs +1/−0
• library/Colorless/Imports.hs +13/−0
• library/Colorless/Server.hs +3/−1
• library/Colorless/Server/Exchange.hs +43/−0
• library/Colorless/Server/Expr.hs +2/−3
• library/Colorless/Types.hs +32/−34
• library/Colorless/Val.hs +2/−8
• package.yaml +2/−1

@@ -1,4 +1,4 @@-# colorless-haskell+# colorless -This is the Haskell colorless library which includes the server-side runtime.+This is the Haskell colorless library which includes the server-side runtime and client-side query language. It's meant to be used in conjunction with the command line [code generator](https://github.com/jxv/colorless).

@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack  name:           colorless-version:        2.2.4+version:        2.2.5 synopsis:       Colorless description:    Colorless category:       Web@@ -36,15 +36,19 @@     , random     , scientific     , text+    , text-conversions     , unordered-containers     , vector   exposed-modules:       Colorless.Ast       Colorless.Client+      Colorless.Client.Exchange       Colorless.Client.Expr       Colorless.Endpoint+      Colorless.Imports       Colorless.Prim       Colorless.Server+      Colorless.Server.Exchange       Colorless.Server.Expr       Colorless.Types       Colorless.Val

@@ -1,9 +1,11 @@ module Colorless.Client   ( module Colorless.Types-  , module Colorless.Client.Expr   , module Colorless.Val+  , module Colorless.Client.Expr+  , module Colorless.Client.Exchange   ) where  import Colorless.Val import Colorless.Types import Colorless.Client.Expr hiding (unsafeExpr, unsafeWrapExpr, unsafeStructExpr, unsafeEnumeralExpr, unsafeRef, unsafeStmt, unsafePath, exprJSON)+import Colorless.Client.Exchange

@@ -0,0 +1,65 @@+module Colorless.Client.Exchange+  ( Request(..)+  , Response(..)+  , ResponseError(..)+  ) where++import Control.Monad (mzero)+import Data.Aeson (Value(..), FromJSON(..), ToJSON(..), object, (.=), (.:))+import Data.Text (Text)++import Colorless.Types (RuntimeError, HasType(..), Version(..))+import Colorless.Ast (ToAst(..))+import Colorless.Client.Expr (Expr, exprJSON)++data Request meta a = Request+  { colorless :: Version+  , version :: Version+  , meta :: meta+  , query :: Expr a+  }++instance (ToJSON meta, ToAst a, HasType a) => ToJSON (Request meta a) where+  toJSON Request{colorless, version, meta, query} = object+    [ "colorless" .= colorless+    , "version" .= version+    , "meta" .= meta+    , "query" .= exprJSON query+    ]++data ResponseError err+  = ResponseError'Service err+  | ResponseError'Runtime RuntimeError+  deriving (Eq, Show)++instance (FromJSON err, HasType err) => FromJSON (ResponseError err) where+  parseJSON (Object o) = do+    tag <- o .: "tag"+    case tag :: Text of+      "Service" -> ResponseError'Service <$> o .: "service"+      "Runtime" -> ResponseError'Runtime <$> o .: "runtime"+      _ -> mzero+  parseJSON _ = mzero++instance ToJSON err => ToJSON (ResponseError err) where+  toJSON = \case+    ResponseError'Service m -> object [ "tag" .= String "Service", "service" .= m ]+    ResponseError'Runtime m -> object [ "tag" .= String "Runtime", "runtime" .= m ]++data Response err a+  = Response'Error (ResponseError err)+  | Response'Success a+  deriving (Show, Eq)++instance (FromJSON err, HasType err, FromJSON a, HasType a) => FromJSON (Response err a) where+  parseJSON (Object o) = do+    tag <- o .: "tag"+    case tag :: Text of+      "Success" -> Response'Success <$> o .: "success"+      "Error" -> Response'Error <$> o .: "error"+      _ -> mzero+  parseJSON _ = mzero++instance (ToJSON err, ToJSON a) => ToJSON (Response err a) where+  toJSON (Response'Error m) = object [ "tag" .= String "Error", "error" .= m ]+  toJSON (Response'Success m) = object [ "tag" .= String "Success", "success" .= m ]

@@ -14,6 +14,7 @@ import Data.Map (Map)  import Colorless.Types+import Colorless.Server.Exchange  runColorlessSingleton   :: (MonadIO m, RuntimeThrower m)

@@ -0,0 +1,13 @@+module Colorless.Imports+  ( module Data.Map+  , module Control.Monad.IO.Class+  , module Data.Aeson+  , module Data.Text+  , module Data.Text.Conversions+  ) where++import Data.Map (Map, fromList, toList, empty, size)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Aeson (ToJSON(..), FromJSON(..), object, (.=), (.:), Value(..), decode)+import Data.Text (Text)+import Data.Text.Conversions (ToText(..), FromText(..))

@@ -1,9 +1,11 @@ module Colorless.Server   ( module Colorless.Types-  , module Colorless.Server.Expr   , module Colorless.Val+  , module Colorless.Server.Expr+  , module Colorless.Server.Exchange   ) where  import Colorless.Val (ToVal(..), FromVal(..), getMember, fromValFromJson, combineObjects) import Colorless.Types import Colorless.Server.Expr+import Colorless.Server.Exchange

@@ -0,0 +1,43 @@+module Colorless.Server.Exchange+  ( Request(..)+  , Response(..)+  , ResponseError(..)+  ) where++import Control.Monad (mzero)+import Data.Aeson (Value(..), FromJSON(..), ToJSON(..), object, (.=), (.:))++import Colorless.Types (RuntimeError)++data Request = Request+  { meta :: Value+  , query :: Value+  } deriving (Show, Eq)++instance FromJSON Request where+  parseJSON (Object o) = Request+    <$> o .: "meta"+    <*> o .: "query"+  parseJSON _ = mzero++instance ToJSON Request where+  toJSON Request{meta,query} = object [ "meta" .= meta, "query" .= query ]++data ResponseError+  = ResponseError'Service Value+  | ResponseError'Runtime RuntimeError+  deriving (Eq, Show)++instance ToJSON ResponseError where+  toJSON = \case+    ResponseError'Service m -> object [ "tag" .= String "Service", "service" .= m ]+    ResponseError'Runtime m -> object [ "tag" .= String "Runtime", "runtime" .= m ]++data Response+  = Response'Error ResponseError+  | Response'Success Value+  deriving (Show, Eq)++instance ToJSON Response where+  toJSON (Response'Error m) = object [ "tag" .= String "Error", "error" .= m ]+  toJSON (Response'Success m) = object [ "tag" .= String "Success", "success" .= m ]

@@ -293,7 +293,7 @@   UnVal'UnWrap UnWrap{w} -> do     w' <- eval w envRef     case w' of-      Expr'Val (Val'Const c) -> return $ Expr'Val $ Val'ApiVal $ ApiVal'Wrap $ Wrap c+      Expr'Val (Val'Const c) -> return $ Expr'Val $ Val'Const c       _ -> runtimeThrow RuntimeError'IncompatibleType    UnVal'UnEnumeral UnEnumeral{tag,m} -> do@@ -326,7 +326,6 @@     _ -> runtimeThrow RuntimeError'IncompatibleType  getterApiVal :: (MonadIO m, RuntimeThrower m) => [Text] -> ApiVal -> Eval m (Expr m)-getterApiVal ("w":path) (ApiVal'Wrap (Wrap w)) = getter path (Expr'Val (Val'Const w)) getterApiVal (mName:path) (ApiVal'Struct Struct{m}) =   case Map.lookup (MemberName mName) m of     Nothing -> runtimeThrow RuntimeError'IncompatibleType@@ -672,4 +671,4 @@   ApiCall'Hollow n -> Map.lookup n hollow   ApiCall'Struct n s -> join $ ($ Val'ApiVal (ApiVal'Struct s)) <$> Map.lookup n struct   ApiCall'Enumeration n e -> join $ ($ Val'ApiVal (ApiVal'Enumeral e)) <$> Map.lookup n enumeration-  ApiCall'Wrap n w -> join $ ($ Val'ApiVal (ApiVal'Wrap w)) <$> Map.lookup n wrap+  ApiCall'Wrap n (Wrap w) -> join $ ($ Val'Const w) <$> Map.lookup n wrap

@@ -4,9 +4,7 @@   , Major(..)   , Minor(..)   , Pull(..)-  , Request(..)-  , Response(..)-  , ResponseError(..)+  , pullAddress   , RuntimeError(..)   , RuntimeThrower(..)   , Options(..)@@ -25,6 +23,7 @@ import Control.Monad (mzero) import Data.Aeson import Data.Text (Text)+import Data.Text.Conversions (toText) import Data.String (IsString(..)) import Data.Scientific import Data.Proxy@@ -46,11 +45,14 @@  data Pull = Pull   { protocol :: Text-  , address :: Text+  , host :: Text   , path :: Text   , port :: Int   } deriving (Show, Eq) +pullAddress :: Pull -> Text+pullAddress Pull{port,host,protocol,path} = mconcat [protocol, "://", host, ":", toText $ show port,  path]+ data Version = Version   { major :: Major   , minor :: Minor@@ -59,17 +61,6 @@ instance ToJSON Version instance FromJSON Version -data Request = Request-  { meta :: Value-  , query :: Value-  } deriving (Show, Eq)--instance FromJSON Request where-  parseJSON (Object o) = Request-    <$> o .: "meta"-    <*> o .: "query"-  parseJSON _ = mzero- data RuntimeError   = RuntimeError'UnparsableFormat   | RuntimeError'UnrecognizedCall@@ -116,24 +107,31 @@     where       e s = object [ "tag" .= String s ] -data ResponseError-  = ResponseError'Service Value-  | ResponseError'Runtime RuntimeError-  deriving (Eq, Show)--instance ToJSON ResponseError where-  toJSON = \case-    ResponseError'Service m -> object [ "tag" .= String "Service", "service" .= m ]-    ResponseError'Runtime m -> object [ "tag" .= String "Runtime", "runtime" .= m ]--data Response-  = Response'Error ResponseError-  | Response'Success Value-  deriving (Show, Eq)--instance ToJSON Response where-  toJSON (Response'Error m) = object [ "tag" .= String "Error", "error" .= m ]-  toJSON (Response'Success m) = object [ "tag" .= String "Success", "success" .= m ]+instance FromJSON RuntimeError where+  parseJSON (Object o) = do+    tag <- o .: "tag"+    case tag :: Text of+      "UnparsableFormat" -> pure RuntimeError'UnparsableFormat+      "UnrecognizedCall" -> pure RuntimeError'UnrecognizedCall+      "VariableLimit" -> pure RuntimeError'VariableLimit+      "UnknownVariable" -> RuntimeError'UnknownVariable <$> o .: "name"+      "IncompatibleType" -> pure RuntimeError'IncompatibleType+      "TooFewArguments" -> pure RuntimeError'TooFewArguments+      "TooManyArguments" -> pure RuntimeError'TooManyArguments+      "NoApiVersion" -> pure RuntimeError'NoApiVersion+      "NoColorlessVersion" -> pure RuntimeError'NoColorlessVersion+      "ApiMajorVersionTooHigh" -> pure RuntimeError'ApiMajorVersionTooHigh+      "ApiMajorVersionTooLow" -> pure RuntimeError'ApiMajorVersionTooLow+      "ApiMinorVersionTooHigh" -> pure RuntimeError'ApiMinorVersionTooHigh+      "ColorlessMajorVersionTooHigh" -> pure RuntimeError'ColorlessMajorVersionTooHigh+      "ColorlessMajorVersionTooLow" -> pure RuntimeError'ColorlessMajorVersionTooLow+      "ColorlessMinorVersionTooHigh" -> pure RuntimeError'ColorlessMinorVersionTooHigh+      "UnparsableMeta" -> pure RuntimeError'UnparsableMeta+      "UnparsableQuery" -> pure RuntimeError'UnparsableQuery+      "NoImplementation" -> pure RuntimeError'NoImplementation+      "NotMember" -> pure RuntimeError'NotMember+      _ -> mzero+  parseJSON _ = mzero  class Monad m => RuntimeThrower m where   runtimeThrow :: RuntimeError -> m a@@ -148,7 +146,7 @@ --  newtype Symbol = Symbol Text-  deriving (Show, Eq, Ord, FromJSON, ToJSON, ToJSONKey, FromJSONKey,  IsString)+  deriving (Show, Eq, Ord, FromJSON, ToJSON, ToJSONKey, FromJSONKey, IsString)  data Type = Type   { n :: TypeName

@@ -54,29 +54,23 @@     v@Object{} -> Val'ApiVal <$> parseJSON v  data ApiVal-  = ApiVal'Wrap Wrap-  | ApiVal'Struct Struct+  = ApiVal'Struct Struct   | ApiVal'Enumeral Enumeral   deriving (Show, Eq)  instance ToJSON ApiVal where   toJSON = \case-    ApiVal'Wrap w -> toJSON w     ApiVal'Struct s -> toJSON s     ApiVal'Enumeral e -> toJSON e  instance FromJSON ApiVal where   parseJSON v =-    (ApiVal'Wrap <$> parseJSON v) <|>     (ApiVal'Enumeral <$> parseJSON v) <|>     (ApiVal'Struct <$> parseJSON v)  data Wrap = Wrap   { w :: Const-  } deriving (Show, Eq, Generic)--instance ToJSON Wrap-instance FromJSON Wrap+  } deriving (Show, Eq)  data Struct = Struct   { m :: Map MemberName Val

@@ -1,5 +1,5 @@ name: colorless-version: '2.2.4'+version: '2.2.5' category: Web synopsis: Colorless description: Colorless@@ -42,6 +42,7 @@   - random   - scientific   - text+  - text-conversions   - unordered-containers   - vector   source-dirs: library