ron-schema (empty) → 0.5
raw patch · 7 files changed
+979/−0 lines, 7 filesdep +basedep +bytestringdep +containers
Dependencies added: base, bytestring, containers, hedn, integer-gmp, megaparsec, mtl, ron, ron-rdt, template-haskell, text, transformers
Files
- LICENSE +29/−0
- lib/Data/EDN/Extra.hs +48/−0
- lib/RON/Schema.hs +122/−0
- lib/RON/Schema/EDN.hs +228/−0
- lib/RON/Schema/TH.hs +316/−0
- prelude/Prelude.hs +164/−0
- ron-schema.cabal +72/−0
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2018, Yuriy Syrovetskiy+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++* Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ lib/Data/EDN/Extra.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.EDN.Extra (+ decodeMultiDoc,+ isTagged,+ parseList,+ parseSymbol',+ withNoPrefix,+ withSymbol',+) where++import qualified Data.EDN.AST.Lexer as EdnAst+import qualified Data.EDN.AST.Parser as EdnAst+import qualified Data.EDN.AST.Types as EdnAst+import Data.EDN.Class.Parser (Parser)+import qualified Text.Megaparsec as Mpc++import Data.EDN (EDNList, FromEDN, Tagged (NoTag, Tagged),+ TaggedValue, Value (List), parseEDNv, withNoTag,+ withSymbol)++withNoPrefix :: MonadFail m => (Text -> m a) -> Text -> Text -> m a+withNoPrefix f prefix name = case prefix of+ "" -> f name+ _ -> fail "Expected no prefix"++withSymbol' :: (Text -> Parser a) -> TaggedValue -> Parser a+withSymbol' = withNoTag . withSymbol . withNoPrefix++parseSymbol' :: TaggedValue -> Parser Text+parseSymbol' = withSymbol' pure++isTagged :: Tagged t a -> Bool+isTagged = \case+ NoTag {} -> False+ Tagged{} -> True++parseMultiDoc :: EdnAst.Parser [TaggedValue]+parseMultiDoc = EdnAst.dropWS *> many EdnAst.parseTagged <* Mpc.eof++decodeMultiDoc :: MonadFail m => String -> Text -> m [TaggedValue]+decodeMultiDoc sourceName+ = either (fail . Mpc.errorBundlePretty) pure+ . Mpc.parse parseMultiDoc sourceName++parseList :: FromEDN a => EDNList -> Parser a+parseList = parseEDNv . List
+ lib/RON/Schema.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module RON.Schema (+ CaseTransform (..),+ Declaration (..),+ Field (..),+ Opaque (..),+ OpaqueAnnotations (..),+ RonType (..),+ Schema,+ Stage (..),+ StructAnnotations (..),+ StructLww (..),+ TAtom (..),+ TComposite (..),+ TEnum (..),+ TObject (..),+ TypeExpr (..),+ TypeName,+ UseType,+ defaultOpaqueAnnotations,+ defaultStructAnnotations,+ opaqueAtoms,+ opaqueAtoms_,+ opaqueObject,+) where++import qualified Data.Text as Text++data Stage = Parsed | Resolved++type TypeName = Text++data TypeExpr = Use TypeName | Apply TypeName [TypeExpr]+ deriving (Show)++data TAtom = TAInteger | TAString+ deriving (Show)++data RonType+ = TAtom TAtom+ | TComposite TComposite+ | TObject TObject+ | TOpaque Opaque+ deriving (Show)++data TComposite+ = TOption RonType+ | TEnum TEnum+ deriving (Show)++data TEnum = Enum {enumName :: Text, enumItems :: [Text]}+ deriving (Show)++data TObject+ = TORSet RonType+ | TRga RonType+ | TStructLww (StructLww 'Resolved)+ | TVersionVector+ deriving (Show)++data StructLww stage = StructLww+ { structName :: Text+ , structFields :: Map Text (Field stage)+ , structAnnotations :: StructAnnotations+ }+deriving instance Show (UseType stage) => Show (StructLww stage)++data StructAnnotations = StructAnnotations+ { saHaskellFieldPrefix :: Text+ , saHaskellFieldCaseTransform :: Maybe CaseTransform+ }+ deriving (Show)++defaultStructAnnotations :: StructAnnotations+defaultStructAnnotations = StructAnnotations+ {saHaskellFieldPrefix = Text.empty, saHaskellFieldCaseTransform = Nothing}++data CaseTransform = TitleCase+ deriving (Show)++newtype Field stage = Field{fieldType :: UseType stage}+deriving instance Show (UseType stage) => Show (Field stage)++type family UseType (stage :: Stage) where+ UseType 'Parsed = TypeExpr+ UseType 'Resolved = RonType++data Declaration stage =+ DEnum TEnum | DOpaque Opaque | DStructLww (StructLww stage)+deriving instance Show (UseType stage) => Show (Declaration stage)++type family Schema (stage :: Stage) where+ Schema 'Parsed = [Declaration 'Parsed]+ Schema 'Resolved = Map TypeName (Declaration 'Resolved)++newtype OpaqueAnnotations = OpaqueAnnotations{oaHaskellType :: Maybe Text}+ deriving (Show)++defaultOpaqueAnnotations :: OpaqueAnnotations+defaultOpaqueAnnotations = OpaqueAnnotations{oaHaskellType = Nothing}++data Opaque = Opaque+ { opaqueIsObject :: Bool+ , opaqueName :: Text+ , opaqueAnnotations :: OpaqueAnnotations+ }+ deriving (Show)++opaqueObject :: Text -> OpaqueAnnotations -> RonType+opaqueObject name = TOpaque . Opaque True name++opaqueAtoms :: Text -> OpaqueAnnotations -> RonType+opaqueAtoms name = TOpaque . Opaque False name++opaqueAtoms_ :: Text -> RonType+opaqueAtoms_ name = TOpaque $ Opaque False name defaultOpaqueAnnotations
+ lib/RON/Schema/EDN.hs view
@@ -0,0 +1,228 @@+{-# OPTIONS -Wno-orphans #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module RON.Schema.EDN (readSchema) where++import Data.EDN (FromEDN, Tagged (NoTag, Tagged),+ Value (List, Symbol), mapGetSymbol, parseEDN,+ renderText, unexpected, withList, withMap, withNoTag)+import Data.EDN.Class.Parser (parseM)+import Data.EDN.Extra (decodeMultiDoc, isTagged, parseList,+ parseSymbol', withNoPrefix, withSymbol')+import Data.Map.Strict ((!?))+import qualified Data.Map.Strict as Map+import qualified Data.Text as Text++import RON.Schema++readSchema :: MonadFail m => String -> Text -> m (Schema 'Resolved)+readSchema sourceName source = do+ parsed <- parseSchema sourceName source+ env <- (`execStateT` Env{userTypes=Map.empty}) $ do+ collectDeclarations parsed+ validateTypeUses parsed+ pure $ evalSchema env++newtype Env = Env{userTypes :: Map TypeName (Declaration 'Parsed)}+ deriving (Show)++data RonTypeF = Type0 RonType | Type1 (RonType -> RonType)++prelude :: Map TypeName RonTypeF+prelude = Map.fromList+ [ ("Boole",+ Type0 $+ opaqueAtoms "Boole" OpaqueAnnotations{oaHaskellType = Just "Bool"})+ , ("Day", Type0 day)+ , ("Integer", Type0 $ TAtom TAInteger)+ , ("RgaString", Type0 $ TObject $ TRga char)+ , ("String", Type0 $ TAtom TAString)+ , ("VersionVector", Type0 $ TObject TVersionVector)+ , ("Option", Type1 $ TComposite . TOption)+ , ("ORSet", Type1 $ TObject . TORSet)+ ]+ where+ char = opaqueAtoms "Char" OpaqueAnnotations{oaHaskellType = Just "Char"}+ day = opaqueAtoms_ "Day"++instance FromEDN (Declaration 'Parsed) where+ parseEDN = withNoTag . withList $ \case+ func : args -> (`withSymbol'` func) $ \case+ "enum" -> DEnum <$> parseList args+ "opaque" -> DOpaque <$> parseList args+ "struct_lww" -> DStructLww <$> parseList args+ name -> fail $ "unknown declaration " ++ Text.unpack name+ [] -> fail "empty declaration"++instance FromEDN TEnum where+ parseEDN = withNoTag . withList $ \case+ name : items -> Enum+ <$> parseSymbol' name+ <*> traverse parseSymbol' items+ [] -> fail+ "Expected declaration in the form\+ \ (enum <name:symbol> <item:symbol>...)"++instance FromEDN Opaque where+ parseEDN = withNoTag . withList $ \case+ kind : name : annotations ->+ (`withSymbol'` kind) $ \case+ "atoms" -> go False+ "object" -> go True+ _ -> fail "opaque kind must be either atoms or object"+ where+ go isObject =+ Opaque isObject <$> parseSymbol' name <*> parseAnnotations+ parseAnnotations = case annotations of+ [] -> pure defaultOpaqueAnnotations+ _ -> fail "opaque annotations are not implemented yet"+ _ -> fail+ "Expected declaration in the form\+ \ (opaque <kind:symbol> <name:symbol> <annotations>...)"++rememberDeclaration+ :: (MonadFail m, MonadState Env m) => Declaration 'Parsed -> m ()+rememberDeclaration decl = do+ env@Env{userTypes} <- get+ if name `Map.member` userTypes then+ fail $ "duplicate declaration of type " ++ Text.unpack name+ else+ put env {userTypes = Map.insert name decl userTypes}+ where+ name = declarationName decl++declarationName :: Declaration stage -> TypeName+declarationName = \case+ DEnum Enum {enumName } -> enumName+ DOpaque Opaque {opaqueName} -> opaqueName+ DStructLww StructLww{structName} -> structName++instance FromEDN (StructLww 'Parsed) where+ parseEDN = withNoTag . withList $ \case+ name : body -> do+ let (annotations, fields) = span isTagged body+ StructLww+ <$> parseSymbol' name+ <*> parseFields fields+ <*> parseList annotations+ [] -> fail+ "Expected declaration in the form\+ \ (struct_lww <name:symbol> <annotations>... <fields>...)"++ where++ parseFields = \case+ [] -> pure mempty+ nameAsTagged : typeAsTagged : cont -> do+ name <- parseSymbol' nameAsTagged+ typ <- parseEDN typeAsTagged+ Map.insert name (Field typ) <$> parseFields cont+ [f] ->+ fail $ "field " ++ Text.unpack (renderText f) ++ " must have type"++instance FromEDN StructAnnotations where+ parseEDN = withNoTag . withList $ \annTaggedValues -> do+ annValues <- traverse unwrapTag annTaggedValues+ case lookup "haskell" annValues of+ Nothing -> pure defaultStructAnnotations+ Just annValue -> withMap go annValue+ where+ unwrapTag = \case+ Tagged prefix tag value -> let+ name = case prefix of+ "" -> tag+ _ -> prefix <> "/" <> tag+ in pure (name, value)+ NoTag _ -> fail "annotation must be a tagged value"+ go m = do+ saHaskellFieldPrefix <- mapGetSymbol "field_prefix" m <|> pure ""+ saHaskellFieldCaseTransform <-+ optional $ mapGetSymbol "field_case" m+ pure StructAnnotations{..}++instance FromEDN CaseTransform where+ parseEDN = withSymbol' $ \case+ "title" -> pure TitleCase+ _ -> fail "unknown case transformation"++parseSchema :: MonadFail m => String -> Text -> m (Schema 'Parsed)+parseSchema sourceName source = do+ values <- decodeMultiDoc sourceName source+ parseM (traverse parseEDN) values++instance FromEDN TypeExpr where+ parseEDN = withNoTag $ \case+ Symbol prefix name -> withNoPrefix (pure . Use) prefix name+ List values -> do+ exprs <- traverse parseEDN values+ case exprs of+ [] -> fail "empty type expression"+ f : args -> case f of+ Use typ -> pure $ Apply typ args+ Apply{} ->+ fail "type function must be a name, not expression"+ value -> value `unexpected` "type symbol or expression"++collectDeclarations :: (MonadFail m, MonadState Env m) => Schema 'Parsed -> m ()+collectDeclarations = traverse_ rememberDeclaration++validateTypeUses :: (MonadFail m, MonadState Env m) => Schema 'Parsed -> m ()+validateTypeUses = traverse_ $ \case+ DEnum _ -> pure ()+ DOpaque _ -> pure ()+ DStructLww StructLww{structFields} ->+ for_ structFields $ \(Field typeExpr) -> validateExpr typeExpr+ where+ validateName name = do+ Env{userTypes} <- get+ unless+ (name `Map.member` userTypes || name `Map.member` prelude)+ (fail $ "unknown type name " ++ Text.unpack name)+ validateExpr = \case+ Use name -> validateName name+ Apply name args -> do+ validateName name+ for_ args validateExpr++evalSchema :: Env -> Schema 'Resolved+evalSchema env = fst <$> userTypes' where+ Env{userTypes} = env+ userTypes' = evalDeclaration <$> userTypes++ evalDeclaration :: Declaration 'Parsed -> (Declaration 'Resolved, RonTypeF)+ evalDeclaration = \case+ DEnum t -> (DEnum t, Type0 $ TComposite $ TEnum t)+ DOpaque t -> (DOpaque t, Type0 $ TOpaque t)+ DStructLww StructLww{..} -> let+ structFields' =+ (\(Field typeExpr) -> Field $ evalType typeExpr)+ <$> structFields+ struct = StructLww{structFields = structFields', ..}+ in (DStructLww struct, Type0 $ TObject $ TStructLww struct)++ getType :: TypeName -> RonTypeF+ getType typ+ = (prelude !? typ)+ <|> (snd <$> userTypes' !? typ)+ ?: error "type is validated but not found"++ evalType = \case+ Use typ -> case getType typ of+ Type0 t0 -> t0+ Type1 _ -> error "type arity mismatch"+ Apply typ args -> applyType typ $ evalType <$> args++ applyType name args = case getType name of+ Type0 _ -> error "type arity mismatch"+ Type1 t1 -> case args of+ [a] -> t1 a+ _ -> error+ $ Text.unpack name ++ " expects 1 argument, got "+ ++ show (length args)
+ lib/RON/Schema/TH.hs view
@@ -0,0 +1,316 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module RON.Schema.TH(+ module X,+ mkReplicated,+ mkReplicated',+) where++import Prelude hiding (lift)++import qualified Data.ByteString.Char8 as BSC+import Data.Char (toTitle)+import qualified Data.Map.Strict as Map+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Language.Haskell.TH (Exp (VarE), Loc (Loc), bindS, conE, conP,+ conT, doE, lamCaseE, listE, noBindS,+ normalB, recC, recConE, sigD, varE, varP,+ varT)+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter), quoteDec,+ quoteExp, quotePat, quoteType)+import Language.Haskell.TH.Syntax (dataToPatQ, liftData, liftString)++import RON.Data (Replicated (..), ReplicatedAsObject (..),+ ReplicatedAsPayload (..), getObjectStateChunk,+ objectEncoding)+import RON.Data.LWW (lwwType)+import qualified RON.Data.LWW as LWW+import RON.Data.ORSet (ORSet (..), ObjectORSet (..))+import RON.Data.RGA (RGA (..))+import RON.Data.VersionVector (VersionVector)+import RON.Error (MonadE, errorContext, throwErrorString)+import RON.Event (ReplicaClock)+import RON.Schema as X+import qualified RON.Schema.EDN as EDN+import RON.Types (Object (Object), UUID)+import RON.Util (Instance (Instance))+import qualified RON.UUID as UUID++-- | QuasiQuoter to generate Haskell types from RON-Schema+mkReplicated :: HasCallStack => QuasiQuoter+mkReplicated = QuasiQuoter{quoteDec, quoteExp = e, quotePat = e, quoteType = e}+ where+ e = error "declaration only"+ quoteDec source = do+ Loc{loc_filename} <- TH.location+ schema <- EDN.readSchema loc_filename $ Text.pack source+ mkReplicated' schema++-- | Generate Haskell types from RON-Schema+mkReplicated' :: HasCallStack => Schema 'Resolved -> TH.DecsQ+mkReplicated' = fmap fold . traverse fromDecl where+ fromDecl decl = case decl of+ DEnum e -> mkEnum e+ DOpaque _ -> pure []+ DStructLww s -> mkReplicatedStructLww s++-- | Type-directing newtype+fieldWrapperC :: RonType -> Maybe TH.Name+fieldWrapperC typ = case typ of+ TAtom _ -> Nothing+ TComposite _ -> Nothing+ TObject t -> case t of+ TORSet a+ | isObjectType a -> Just 'ObjectORSet+ | otherwise -> Just 'ORSet+ TRga _ -> Just 'RGA+ TStructLww _ -> Nothing+ TVersionVector -> Nothing+ TOpaque _ -> Nothing++mkGuideType :: RonType -> TH.TypeQ+mkGuideType typ = case typ of+ TAtom _ -> view+ TComposite _ -> view+ TObject t -> case t of+ TORSet a+ | isObjectType a -> wrap ''ObjectORSet a+ | otherwise -> wrap ''ORSet a+ TRga a -> wrap ''RGA a+ TStructLww _ -> view+ TVersionVector -> view+ TOpaque _ -> view+ where+ view = mkViewType typ+ wrap w item = [t| $(conT w) $(mkGuideType item) |]++data Field' = Field'+ { field'Name :: Text+ , field'RonName :: UUID+ , field'Type :: RonType+ , field'Var :: TH.Name+ }++mkReplicatedStructLww :: HasCallStack => StructLww 'Resolved -> TH.DecsQ+mkReplicatedStructLww struct = do+ fields <- for (Map.assocs structFields) $ \(field'Name, Field{fieldType}) ->+ case UUID.mkName . BSC.pack $ Text.unpack field'Name of+ Just field'RonName -> do+ field'Var <- TH.newName $ Text.unpack field'Name+ pure Field'{field'Type = fieldType, ..}+ Nothing -> fail $+ "Field name is not representable in RON: " ++ show field'Name+ dataType <- mkDataType+ [instanceReplicated] <- mkInstanceReplicated+ [instanceReplicatedAsObject] <- mkInstanceReplicatedAsObject fields+ accessors <- fold <$> traverse mkAccessors fields+ pure $+ dataType : instanceReplicated : instanceReplicatedAsObject : accessors+ where++ StructLww{structName, structFields, structAnnotations} = struct++ StructAnnotations{saHaskellFieldPrefix, saHaskellFieldCaseTransform} =+ structAnnotations++ name = mkNameT structName++ structT = conT name++ objectT = [t| Object $structT |]++ mkDataType = TH.dataD (TH.cxt []) name [] Nothing+ [recC name+ [ TH.varBangType (mkNameT $ mkHaskellFieldName fieldName) $+ TH.bangType (TH.bang TH.sourceNoUnpack TH.sourceStrict) viewType+ | (fieldName, Field fieldType) <- Map.assocs structFields+ , let viewType = mkViewType fieldType+ ]]+ []++ mkInstanceReplicated = [d|+ instance Replicated $structT where+ encoding = objectEncoding+ |]++ mkInstanceReplicatedAsObject fields = do+ obj <- TH.newName "obj"+ frame <- TH.newName "frame"+ ops <- TH.newName "ops"+ let fieldsToUnpack =+ [ bindS var [|+ LWW.viewField+ $(liftData field'RonName) $(varE ops) $(varE frame)+ |]+ | Field'{field'Type, field'Var, field'RonName} <- fields+ , let+ fieldP = varP field'Var+ var = maybe fieldP (\w -> conP w [fieldP]) $+ fieldWrapperC field'Type+ ]+ let getObjectImpl = doE+ $ let1S [p| Object _ $(varP frame) |] (varE obj)+ : bindS (varP ops) [| getObjectStateChunk $(varE obj) |]+ : fieldsToUnpack+ ++ [noBindS [| pure $consE |]]+ [d| instance ReplicatedAsObject $structT where+ objectOpType = lwwType+ newObject $consP = LWW.newObject $fieldsToPack+ getObject $(varP obj) =+ errorContext $(liftText errCtx) $getObjectImpl+ |]+ where+ fieldsToPack = listE+ [ [| ($(liftData field'RonName), Instance $var) |]+ | Field'{field'Type, field'Var, field'RonName} <- fields+ , let+ fieldVarE = varE field'Var+ var = case fieldWrapperC field'Type of+ Nothing -> fieldVarE+ Just con -> [| $(conE con) $fieldVarE |]+ ]+ errCtx = "getObject @" <> structName <> ":\n"+ consE = recConE name+ [ pure (fieldName, VarE field'Var)+ | Field'{field'Name, field'Var} <- fields+ , let fieldName = mkNameT $ mkHaskellFieldName field'Name+ ]+ consP = conP name [varP field'Var | Field'{field'Var} <- fields]++ mkHaskellFieldName base = saHaskellFieldPrefix <> base' where+ base' = case saHaskellFieldCaseTransform of+ Nothing -> base+ Just TitleCase -> case Text.uncons base of+ Nothing -> base+ Just (b, baseTail) -> Text.cons (toTitle b) baseTail++ mkAccessors field' = do+ a <- varT <$> TH.newName "a"+ m <- varT <$> TH.newName "m"+ let assignF =+ [ sigD assign [t|+ (ReplicaClock $m, MonadE $m, MonadState $objectT $m)+ => $fieldViewType -> $m ()+ |]+ , valDP assign+ [| LWW.assignField $(liftData field'RonName) . $guide |]+ ]+ readF =+ [ sigD read [t|+ (MonadE $m, MonadState $objectT $m) => $m $fieldViewType+ |]+ , valDP read+ [| $unguide <$> LWW.readField $(liftData field'RonName) |]+ ]+ zoomF =+ [ sigD zoom [t|+ MonadE $m+ => StateT (Object $(mkGuideType field'Type)) $m $a+ -> StateT $objectT $m $a+ |]+ , valDP zoom [| LWW.zoomField $(liftData field'RonName) |]+ ]+ sequenceA $ assignF ++ readF ++ zoomF+ where+ Field'{field'Name, field'RonName, field'Type} = field'+ fieldViewType = mkViewType field'Type+ assign = mkNameT $ mkHaskellFieldName field'Name <> "_assign"+ read = mkNameT $ mkHaskellFieldName field'Name <> "_read"+ zoom = mkNameT $ mkHaskellFieldName field'Name <> "_zoom"+ guidedX = case fieldWrapperC field'Type of+ Just w -> conP w [x]+ Nothing -> x+ where+ x = varP $ TH.mkName "x"+ unguide = [| \ $guidedX -> x |]+ guide = case fieldWrapperC field'Type of+ Just w -> conE w+ Nothing -> [| identity |]++mkNameT :: Text -> TH.Name+mkNameT = TH.mkName . Text.unpack++mkViewType :: HasCallStack => RonType -> TH.TypeQ+mkViewType = \case+ TAtom atom -> case atom of+ TAInteger -> [t| Int64 |]+ TAString -> [t| Text |]+ TComposite t -> case t of+ TEnum Enum{enumName} -> conT $ mkNameT enumName+ TOption u -> [t| Maybe $(mkViewType u) |]+ TObject t -> case t of+ TORSet item -> wrapList item+ TRga item -> wrapList item+ TStructLww StructLww{structName} -> conT $ mkNameT structName+ TVersionVector -> [t| VersionVector |]+ TOpaque Opaque{opaqueName, opaqueAnnotations} -> let+ OpaqueAnnotations{oaHaskellType} = opaqueAnnotations+ in conT $ mkNameT $ fromMaybe opaqueName oaHaskellType+ where+ wrapList a = [t| [$(mkViewType a)] |]++valD :: TH.PatQ -> TH.ExpQ -> TH.DecQ+valD pat body = TH.valD pat (normalB body) []++valDP :: TH.Name -> TH.ExpQ -> TH.DecQ+valDP = valD . varP++isObjectType :: RonType -> Bool+isObjectType = \case+ TAtom _ -> False+ TComposite _ -> False+ TObject _ -> True+ TOpaque Opaque{opaqueIsObject} -> opaqueIsObject++mkEnum :: TEnum -> TH.DecsQ+mkEnum Enum{enumName, enumItems} = do+ itemsUuids <- for enumItems $ \item -> do+ uuid <- UUID.mkName $ Text.encodeUtf8 item+ pure (mkNameT item, uuid)+ dataType <- mkDataType+ [instanceReplicated] <- mkInstanceReplicated+ [instanceReplicatedAsPayload] <- mkInstanceReplicatedAsPayload itemsUuids+ pure [dataType, instanceReplicated, instanceReplicatedAsPayload]++ where++ typeName = conT $ mkNameT enumName++ mkDataType = TH.dataD (TH.cxt []) (mkNameT enumName) [] Nothing+ [TH.normalC (mkNameT item) [] | item <- enumItems] []++ mkInstanceReplicated = [d|+ instance Replicated $typeName where+ encoding = payloadEncoding+ |]++ mkInstanceReplicatedAsPayload itemsUuids = [d|+ instance ReplicatedAsPayload $typeName where+ toPayload = toPayload . $toUuid+ fromPayload = fromPayload >=> $fromUuid+ |]+ where+ toUuid = lamCaseE+ [match (conP name []) (liftData uuid) | (name, uuid) <- itemsUuids]+ fromUuid = lamCaseE+ $ [ match (liftDataP uuid) [| pure $(conE name) |]+ | (name, uuid) <- itemsUuids+ ]+ ++ [match+ TH.wildP+ [| throwErrorString "expected one of enum items" |]]+ liftDataP = dataToPatQ $ const Nothing+ match pat body = TH.match pat (normalB body) []++liftText :: Text -> TH.ExpQ+liftText t = [| Text.pack $(liftString $ Text.unpack t) |]++let1S :: TH.PatQ -> TH.ExpQ -> TH.StmtQ+let1S pat exp = TH.letS [valD pat exp]
+ prelude/Prelude.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}++module Prelude (+ module X,+ fmapL,+ foldr1,+ identity,+ lastDef,+ maximumDef,+ maxOn,+ minOn,+ show,+ whenJust,+ (?:),+) where++-- base+import Control.Applicative as X (Alternative, Applicative, liftA2,+ many, optional, pure, some, (*>),+ (<*), (<*>), (<|>))+import Control.Exception as X (Exception, catch, evaluate, throwIO)+import Control.Monad as X (Monad, filterM, guard, unless, void, when,+ (<=<), (=<<), (>=>), (>>=))+import Control.Monad.Fail as X (MonadFail, fail)+import Control.Monad.IO.Class as X (MonadIO, liftIO)+import Data.Bifunctor as X (bimap)+import Data.Bool as X (Bool (False, True), not, otherwise, (&&), (||))+import Data.Char as X (Char, chr, ord, toLower, toUpper)+import Data.Coerce as X (Coercible, coerce)+import Data.Data as X (Data)+import Data.Either as X (Either (Left, Right), either)+import Data.Eq as X (Eq, (/=), (==))+import Data.Foldable as X (Foldable, and, asum, fold, foldMap, foldl',+ foldr, for_, length, minimumBy, null, or,+ toList, traverse_)+import Data.Function as X (const, flip, on, ($), (.))+import Data.Functor as X (Functor, fmap, ($>), (<$), (<$>))+import Data.Functor.Identity as X (Identity)+import Data.Int as X (Int, Int16, Int32, Int64, Int8)+import Data.IORef as X (IORef, atomicModifyIORef', newIORef,+ readIORef, writeIORef)+import Data.List as X (filter, genericLength, intercalate, isPrefixOf,+ isSuffixOf, lookup, map, partition, repeat,+ replicate, sortBy, sortOn, span, splitAt, take,+ takeWhile, unlines, unwords, zip, (++))+import Data.List.NonEmpty as X (NonEmpty ((:|)), nonEmpty)+import Data.Maybe as X (Maybe (Just, Nothing), catMaybes, fromMaybe,+ listToMaybe, maybe, maybeToList)+import Data.Monoid as X (Last (Last), Monoid, mempty)+import Data.Ord as X (Down (Down), Ord, Ordering (EQ, GT, LT),+ compare, comparing, max, min, (<), (<=), (>),+ (>=))+import Data.Ratio as X ((%))+import Data.Semigroup as X (Semigroup, sconcat, (<>))+import Data.String as X (String)+import Data.Traversable as X (for, sequence, sequenceA, traverse)+import Data.Tuple as X (fst, snd, uncurry)+import Data.Typeable as X (Typeable)+import Data.Word as X (Word, Word16, Word32, Word64, Word8)+import GHC.Enum as X (Bounded, Enum, fromEnum, maxBound, minBound,+ pred, succ, toEnum)+import GHC.Err as X (error, undefined)+import GHC.Exts as X (Double)+import GHC.Generics as X (Generic)+import GHC.Integer as X (Integer)+import GHC.Num as X (Num, negate, subtract, (*), (+), (-))+import GHC.Real as X (Integral, fromIntegral, mod, realToFrac, round,+ (^), (^^))+import GHC.Stack as X (HasCallStack)+import System.IO as X (FilePath, IO)+import Text.Show as X (Show)++#ifdef VERSION_bytestring+import Data.ByteString as X (ByteString)+#endif++#ifdef VERSION_containers+import Data.Map.Strict as X (Map)+#endif++#ifdef VERSION_deepseq+import Control.DeepSeq as X (NFData, force)+#endif++#ifdef VERSION_filepath+import System.FilePath as X ((</>))+#endif++#ifdef VERSION_hashable+import Data.Hashable as X (Hashable, hash)+#endif++#ifdef VERSION_mtl+import Control.Monad.Except as X (ExceptT, MonadError, catchError,+ liftEither, runExceptT, throwError)+import Control.Monad.Reader as X (ReaderT (ReaderT), ask, reader,+ runReaderT)+import Control.Monad.State.Strict as X (MonadState, State, StateT,+ evalState, evalStateT,+ execStateT, get, gets,+ modify', put, runState,+ runStateT, state)+import Control.Monad.Trans as X (MonadTrans, lift)+import Control.Monad.Writer.Strict as X (MonadWriter, WriterT,+ runWriterT, tell)+#endif++#ifdef VERSION_text+import Data.Text as X (Text)+#endif++#ifdef VERSION_time+import Data.Time as X (UTCTime)+#endif++#ifdef VERSION_unordered_containers+import Data.HashMap.Strict as X (HashMap)+#endif++--------------------------------------------------------------------------------++import qualified Data.Foldable+import Data.List (last, maximum)+import Data.String (IsString, fromString)+import qualified Text.Show++fmapL :: (a -> b) -> Either a c -> Either b c+fmapL f = either (Left . f) Right++foldr1 :: (a -> a -> a) -> NonEmpty a -> a+foldr1 = Data.Foldable.foldr1++identity :: a -> a+identity x = x++lastDef :: a -> [a] -> a+lastDef def = list' def last++list' :: b -> ([a] -> b) -> [a] -> b+list' onEmpty onNonEmpty = \case+ [] -> onEmpty+ xs -> onNonEmpty xs++maximumDef :: Ord a => a -> [a] -> a+maximumDef def = list' def maximum++maxOn :: Ord b => (a -> b) -> a -> a -> a+maxOn f x y = if f x < f y then y else x++minOn :: Ord b => (a -> b) -> a -> a -> a+minOn f x y = if f x < f y then x else y++show :: (Show a, IsString s) => a -> s+show = fromString . Text.Show.show++whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()+whenJust m f = maybe (pure ()) f m++-- | An infix form of 'fromMaybe' with arguments flipped.+(?:) :: Maybe a -> a -> a+maybeA ?: b = fromMaybe b maybeA+{-# INLINABLE (?:) #-}+infixr 0 ?:
+ ron-schema.cabal view
@@ -0,0 +1,72 @@+cabal-version: 2.2++name: ron-schema+version: 0.5++bug-reports: https://github.com/ff-notes/ron/issues+category: Distributed Systems, Protocol, Database+copyright: 2018-2019 Yuriy Syrovetskiy+homepage: https://github.com/ff-notes/ron+license: BSD-3-Clause+license-file: LICENSE+maintainer: Yuriy Syrovetskiy <haskell@cblp.su>+synopsis: RON-Schema++description:+ Replicated Object Notation (RON), data types (RDT), and RON-Schema+ .+ Typical usage:+ .+ > import RON.Data+ > import RON.Schema.TH+ > import RON.Storage.IO as Storage+ >+ > [mkReplicated|+ > (struct_lww Note+ > active Boole+ > text RgaString)+ > |]+ >+ > instance Collection Note where+ > collectionName = "note"+ >+ > main :: IO ()+ > main = do+ > let dataDir = "./data/"+ > h <- Storage.newHandle dataDir+ > runStorage h $ do+ > obj <- newObject+ > Note{active = True, text = "Write a task manager"}+ > createDocument obj++build-type: Simple++common language+ build-depends: base >= 4.10 && < 4.13, integer-gmp+ default-extensions: MonadFailDesugaring StrictData+ default-language: Haskell2010+ hs-source-dirs: prelude+ other-modules: Prelude++library+ import: language+ build-depends:+ -- global+ bytestring,+ containers,+ hedn >= 0.2 && < 0.3,+ megaparsec,+ mtl,+ template-haskell,+ text,+ transformers,+ -- project+ ron,+ ron-rdt+ exposed-modules:+ RON.Schema+ RON.Schema.TH+ other-modules:+ Data.EDN.Extra+ RON.Schema.EDN+ hs-source-dirs: lib