diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/lib/Data/EDN/Extra.hs b/lib/Data/EDN/Extra.hs new file mode 100644 --- /dev/null +++ b/lib/Data/EDN/Extra.hs @@ -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 diff --git a/lib/RON/Schema.hs b/lib/RON/Schema.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Schema.hs @@ -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 diff --git a/lib/RON/Schema/EDN.hs b/lib/RON/Schema/EDN.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Schema/EDN.hs @@ -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 ...)" + +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 ...)" + +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 ... ...)" + + 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) diff --git a/lib/RON/Schema/TH.hs b/lib/RON/Schema/TH.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Schema/TH.hs @@ -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] diff --git a/prelude/Prelude.hs b/prelude/Prelude.hs new file mode 100644 --- /dev/null +++ b/prelude/Prelude.hs @@ -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 ?: diff --git a/ron-schema.cabal b/ron-schema.cabal new file mode 100644 --- /dev/null +++ b/ron-schema.cabal @@ -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 +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