diff --git a/app/Lib.hs b/app/Lib.hs --- a/app/Lib.hs +++ b/app/Lib.hs @@ -27,7 +27,7 @@ age `dog's age` Int `8` DogA DogB? hobby `dog's hobby` (Maybe Text)? `Just "meat"` (FieldNullable Text) DogC? DogB color `dog's color` ((Text, Text, Text)) DogB DogC - friends `dog's friends` [Text] DogC + *friends `dog's friends` [Text] DogC createdAt `creation time` UTCTime ("cteated_at", Maybe (FieldNullable SqlTimestamptz), FieldNullable SqlTimestamptz) default=`CURRENT_TIMESTAMP` DogB DogC? Cat table (public, cat) diff --git a/src/Tedious/Entity.hs b/src/Tedious/Entity.hs --- a/src/Tedious/Entity.hs +++ b/src/Tedious/Entity.hs @@ -66,7 +66,7 @@ name `名称` Text (Field SqlText) SysOper' target `目标` Text (Field SqlText) SysOper' content `内容` Text? (Maybe (FieldNullable SqlText), FieldNullable SqlText) SysOper' - time `时间` UTCTime (Field SqlTimestamptz) + time `时间` UTCTime (Maybe (Field SqlTimestamptz), Field SqlTimestamptz) default=`CURRENT_TIMESTAMP` |] fillPage :: Page -> Natural -> b -> PageO b diff --git a/src/Tedious/Handler.hs b/src/Tedious/Handler.hs --- a/src/Tedious/Handler.hs +++ b/src/Tedious/Handler.hs @@ -85,7 +85,6 @@ res <- handler -< request arrM ( const $ do - now <- liftIO getCurrentTime pool <- asks envPool liftIO . withResource pool $ \conn -> do runInsert @@ -98,7 +97,7 @@ sqlStrictText . _sysOper'Name $ oper, sqlStrictText . _sysOper'Target $ oper, toNullable . sqlStrictText <$> _sysOper'Content oper, - sqlUTCTime now + Nothing ) ], iReturning = rReturning (const ()), @@ -253,10 +252,8 @@ in (handler, sysOper) get' :: - forall i fi d rfs r eff env es h ts. -- (record id) (field id) data (table read fields) (table record) eff effects (app env) arrow traits - ( Default FromFields rfs r, - Sel1 rfs (Field fi), - Reader env :> es, + forall i d eff env es h ts. -- (record id) data eff effects (app env) arrow traits + ( Reader env :> es, IOE :> es, eff ~ Eff es, StdHandler h eff, @@ -265,23 +262,17 @@ ) => SysOperTargetName -> (env -> Pool Connection) -> - Select rfs -> - (i -> Field fi) -> - (r -> d) -> + (Connection -> i -> IO (Maybe d)) -> (RequestHandler h ts, SysOper') -get' tName envPool sel idf r2d = +get' tName envPool sel = let handler = proc request -> do let tid = pick @(PathVar "id" i) $ from request (md :: Maybe d) <- arrM ( \tid -> do pool <- asks envPool - rs <- liftIO . withResource pool $ - \conn -> runSelect conn $ do - r <- sel - where_ $ sel1 r .== idf tid - pure r - pure . listToMaybe $ r2d <$> rs + liftIO . withResource pool $ + \conn -> sel conn tid ) -< tid diff --git a/src/Tedious/Parser.hs b/src/Tedious/Parser.hs --- a/src/Tedious/Parser.hs +++ b/src/Tedious/Parser.hs @@ -46,6 +46,8 @@ type FldName = String +type FldBasOptional = Bool + type FldLabel = String -- openapi label type FldTypS = String @@ -103,7 +105,7 @@ data Field = Field - (FldName, Maybe FldLabel) -- (field name, field label used in openapi schema) + (FldName, FldBasOptional, Maybe FldLabel) -- (field name, appear in base type or not, field label used in openapi schema) FldTyp -- field type [ExtTyp] -- (name of ext type which has this field, the field of the ext type is maybe or not) deriving stock (Eq, Show, Generic) @@ -242,9 +244,19 @@ pFldTitle :: Parser FldLabel pFldTitle = backQuoteString -pFldNameAndTitle :: Parser (FldName, Maybe FldLabel) -pFldNameAndTitle = (,) <$> pFldName <*> optional pFldTitle +pOccur :: String -> Parser Bool +pOccur s = (True <$ symbol s) <|> pure False +pOccur_ :: String -> Parser Bool +pOccur_ s = lexeme $ (True <$ symbol s) <|> pure False + +pFldNameAndTitle :: Parser (FldName, FldBasOptional, Maybe FldLabel) +pFldNameAndTitle = do + _fldBasOptional <- pOccur "*" + _fldName <- pFldName + _mFldLabel <- optional pFldTitle + pure (_fldName, _fldBasOptional, _mFldLabel) + pFldTypS :: Parser FldTypS pFldTypS = try (parens protoTypS) <|> protoTypS where @@ -257,11 +269,8 @@ pFldSamp :: Parser FldSamp pFldSamp = backQuoteString -pOccur :: String -> Parser Bool -pOccur s = lexeme $ (True <$ symbol s) <|> pure False - pFldTyp :: Parser FldTyp -pFldTyp = try (FldTypNormal <$> (pNameUpper_ <|> parens_ pFldTypS <|> brackets'_ pFldTypS) <*> pOccur "?" <*> optional pFldSamp <*> optional pTblFld) <|> (FldTypPoly <$> pNameLower_ <*> pOccur "?") +pFldTyp = try (FldTypNormal <$> (pNameUpper_ <|> parens_ pFldTypS <|> brackets'_ pFldTypS) <*> pOccur_ "?" <*> optional pFldSamp <*> optional pTblFld) <|> (FldTypPoly <$> pNameLower_ <*> pOccur_ "?") pTblFldUnique :: Parser TblFldUnique pTblFldUnique = lexeme $ MC.char '!' *> pNameUpper @@ -278,10 +287,10 @@ where pFldO = unwords <$> (((<>) . pure <$> (symbol "FieldNullable" <|> symbol "Field")) <*> (pure <$> pNameUpper)) pFldM = unwords <$> ((<>) . pure <$> symbol "Maybe" <*> (pure <$> parens' pFldO)) - pFldP p = try (TblFld <$> p <*> pOccur "#" <*> M.many pTblFldUnique <*> optional pTblFldDefault) + pFldP p = try (TblFld <$> p <*> pOccur_ "#" <*> M.many pTblFldUnique <*> optional pTblFldDefault) pExtName :: Parser ExtTyp -pExtName = try (ExtTypPoly <$> pNameUpper_ <*> (MC.char ':' *> pNameLower_) <*> pOccur "?") <|> (ExtTypNormal <$> pNameUpper_ <*> pOccur "?") +pExtName = try (ExtTypPoly <$> pNameUpper_ <*> (MC.char ':' *> pNameLower_) <*> pOccur_ "?") <|> (ExtTypNormal <$> pNameUpper_ <*> pOccur_ "?") pField :: Parser Field pField = Field <$> pFldNameAndTitle <*> pFldTyp <*> M.many pExtName @@ -307,18 +316,22 @@ defBase _basTypName tuples = HM.insert _basTypName - ( tuples - <&> ( \((_fldName, _mFldTitle), _fldTyp) -> case _fldTyp of + ( mapMaybe + ( \((_fldName, _fldBasOptional, _mFldTitle), _fldTyp) -> + if _fldBasOptional + then Nothing + else Just $ case _fldTyp of FldTypPoly _fldExtVar _fldExtIsM -> (_fldName, _mFldTitle, _fldTyp, _fldExtIsM, Just _fldExtVar) _ -> (_fldName, _mFldTitle, _fldTyp, False, Nothing) - ) + ) + tuples ) defExts [] m = m defExts (Field _ _ [] : ds) m = defExts ds m - defExts (Field (_fldName, _mFldTitle) _fldTyp (extTyp : extTyps) : _flds) m = + defExts (Field (_fldName, _fldBasOptional, _mFldTitle) _fldTyp (extTyp : extTyps) : _flds) m = let (_extTypName, _fldExtIsM, _mFldExtVar) = procExtTyp extTyp m' = HM.insert _extTypName (snoc (HM.lookupDefault [] _extTypName m) (_fldName, _mFldTitle, _fldTyp, _fldExtIsM, _mFldExtVar)) m - in defExts (Field (_fldName, _mFldTitle) _fldTyp extTyps : _flds) m' + in defExts (Field (_fldName, _fldBasOptional, _mFldTitle) _fldTyp extTyps : _flds) m' procExtTyp extTyp = case extTyp of ExtTypNormal _extTypName _fldExtIsM -> (_extTypName, _fldExtIsM, Nothing) ExtTypPoly _extTypName _fldExtVar _fldExtIsM -> (_extTypName, _fldExtIsM, Just _fldExtVar) @@ -326,7 +339,7 @@ repOpaleye :: [Field] -> RepOpaleye repOpaleye = mapMaybe go where - go (Field (_fldName, _) _fldTyp _) = case _fldTyp of + go (Field (_fldName, _, _) _fldTyp _) = case _fldTyp of FldTypNormal _fldTypS _fldBasIsM _ _mTblFld -> case _mTblFld of Nothing -> Nothing Just (TblFld _tblFld _ _ _) -> case _tblFld of @@ -344,13 +357,13 @@ in (basTypName, primaryCons, uniqueCons, persistFlds) where genPrimaryCons = mapMaybe extractPrimary - extractPrimary (Field (_fldName, _) _fldTyp _) = case _fldTyp of + extractPrimary (Field (_fldName, _, _) _fldTyp _) = case _fldTyp of FldTypNormal _fldTypS _fldBasIsM _ _mTblFld -> case _mTblFld of Nothing -> Nothing Just (TblFld _ isPrimary _ _def) -> if isPrimary then Just _fldName else Nothing _ -> Nothing genUniqueCons [] uCons = uCons - genUniqueCons ((Field (_fldName, _) _fldTyp _) : _flds) uCons = case _fldTyp of + genUniqueCons ((Field (_fldName, _, _) _fldTyp _) : _flds) uCons = case _fldTyp of FldTypNormal _fldTypS _fldBasIsM _ _mTblFld -> case _mTblFld of Nothing -> genUniqueCons _flds uCons Just (TblFld _ _ uNames _) -> genUniqueCons _flds (extractUnique _fldName uNames uCons) @@ -362,7 +375,7 @@ if uName == uConName then reverse uCons_ <> (TblUnique uConName (snoc uConFlds _fldName) : uCons) else extractUniqueOne _fldName uName uCons_ (uCon : uCons) - genPersistFld (Field (_fldName, _) _fldTyp _) = case _fldTyp of + genPersistFld (Field (_fldName, _, _) _fldTyp _) = case _fldTyp of FldTypNormal _fldTypS _fldBasIsM _ _mTblFld -> case _mTblFld of Nothing -> Nothing Just (TblFld _ _ _ _def) -> @@ -506,9 +519,9 @@ let _fldExtVars = mapMaybe sel5 flds let preds = join - [ [ AppT (ConT ''Default) (VarT (mkName _fldExtVar)) - , AppT (ConT ''ToJSON) (VarT (mkName _fldExtVar)) - , AppT (ConT ''ToSchema) (VarT (mkName _fldExtVar)) + [ [ AppT (ConT ''Default) (VarT (mkName _fldExtVar)), + AppT (ConT ''ToJSON) (VarT (mkName _fldExtVar)), + AppT (ConT ''ToSchema) (VarT (mkName _fldExtVar)) ] | _fldExtVar <- _fldExtVars ] diff --git a/src/Tedious/Quasi.hs b/src/Tedious/Quasi.hs --- a/src/Tedious/Quasi.hs +++ b/src/Tedious/Quasi.hs @@ -5,6 +5,49 @@ import Tedious.Parser (decTedious) import Language.Haskell.TH.Quote (QuasiQuoter (..)) +{-| +QuasiQuote tedious' ABNF: + tedious_str = *WSP indent_block + indent_block = type_info 1*type_field + type_info = type_name *type_attr [comment] end_of_line + type_name = name_upper + type_attr = 1*WSP (type_attr_table / type_attr_deriv) + type_attr_table = "table" 1*WSP table_info + table_info = table_name / "(" *WSP table_schema *WSP "," *WSP table_name *WSP ")" + table_schema = name + table_name = name + type_attr_deriv = "deriving" 1*(1*WSP name_upper) + type_field = 1*WSP field_name [field_desc] field_table *ext_type [comment] end_of_line + field_name = name_lower + field_desc = 1*WSP "`" *VCHAR "`" + field_table = 1*WSP (field_type / field_type_var) + field_type = (field_type_paren / field_type_proto) ["?"] [field_samp] [opaleye_type] ["#"] *table_unique + field_type_paren = "(" *WSP field_type_proto *WSP ")" + field_type_proto = field_type_array / field_type_tuple / field_type_combo + field_type_array = "[" *WSP field_type_proto *WSP "]" + field_type_tuple = "(" *WSP field_type_proto *field_type_tuple_part *WSP ")" + field_type_tuple_part = *WSP "," *WSP field_type_proto + field_type_combo = field_type_plain *(1*WSP field_type_proto) + field_type_plain = name_upper *(1*WSP name_upper) + field_type_var = name_lower ["?"] + field_samp = 1*WSP "`" *VCHAR "`" + opaleye_type = 1*WSP "(" *WSP opaleye_r / opaleye_nr / opaleye_wr / opaleye_nwr *WSP ")" + opaleye_r = field_type_combo + opaleye_nr = DQUOTE *VCHAR DQUOTE *WSP "," *WSP field_type_combo + opaleye_wr = field_type_combo *WSP "," *WSP field_type_combo + opaleye_nwr = DQUOTE *VCHAR DQUOTE *WSP "," *WSP field_type_combo *WSP "," *WSP field_type_combo + table_unique = 1*WSP "!" name + ext_type = 1*WSP name_upper [ext_type_var] + ext_type_var = ":" name_lower + char_name = ALPHA / DIGIT / "_" / "'" + alpha_upper = A-Z + alpha_lower = a-z + name = 1*char_name + name_upper = alpha_upper 1*char_name + name_lower = alpha_lower 1*char_name + comment = "-" "-" *VCHAR + end_of_line = *WSP 1*CRLF +-} tedious :: QuasiQuoter tedious = QuasiQuoter diff --git a/src/Tedious/Tutorial.hs b/src/Tedious/Tutorial.hs deleted file mode 100644 --- a/src/Tedious/Tutorial.hs +++ /dev/null @@ -1,46 +0,0 @@ -module Tedious.Tutorial () where - -{-| -QuasiQuote tedious' ABNF: - tedious_str = *WSP indent_block - indent_block = type_info 1*type_field - type_info = type_name *type_attr [comment] end_of_line - type_name = name_upper - type_attr = 1*WSP (type_attr_table / type_attr_deriv) - type_attr_table = "table" 1*WSP table_info - table_info = table_name / "(" *WSP table_schema *WSP "," *WSP table_name *WSP ")" - table_schema = name - table_name = name - type_attr_deriv = "deriving" 1*(1*WSP name_upper) - type_field = 1*WSP field_name [field_desc] field_table *ext_type [comment] end_of_line - field_name = name_lower - field_desc = 1*WSP "`" *VCHAR "`" - field_table = 1*WSP (field_type / field_type_var) - field_type = (field_type_paren / field_type_proto) ["?"] [field_samp] [opaleye_type] ["#"] *table_unique - field_type_paren = "(" *WSP field_type_proto *WSP ")" - field_type_proto = field_type_array / field_type_tuple / field_type_combo - field_type_array = "[" *WSP field_type_proto *WSP "]" - field_type_tuple = "(" *WSP field_type_proto *field_type_tuple_part *WSP ")" - field_type_tuple_part = *WSP "," *WSP field_type_proto - field_type_combo = field_type_plain *(1*WSP field_type_proto) - field_type_plain = name_upper *(1*WSP name_upper) - field_type_var = name_lower ["?"] - field_samp = 1*WSP "`" *VCHAR "`" - opaleye_type = 1*WSP "(" *WSP opaleye_r / opaleye_nr / opaleye_wr / opaleye_nwr *WSP ")" - opaleye_r = field_type_combo - opaleye_nr = DQUOTE *VCHAR DQUOTE *WSP "," *WSP field_type_combo - opaleye_wr = field_type_combo *WSP "," *WSP field_type_combo - opaleye_nwr = DQUOTE *VCHAR DQUOTE *WSP "," *WSP field_type_combo *WSP "," *WSP field_type_combo - table_unique = 1*WSP "!" name - ext_type = 1*WSP name_upper [ext_type_var] - ext_type_var = ":" name_lower - char_name = ALPHA / DIGIT / "_" / "'" - alpha_upper = A-Z - alpha_lower = a-z - name = 1*char_name - name_upper = alpha_upper 1*char_name - name_lower = alpha_lower 1*char_name - comment = "-" "-" *VCHAR - end_of_line = *WSP 1*CRLF --} - diff --git a/tedious-web.cabal b/tedious-web.cabal --- a/tedious-web.cabal +++ b/tedious-web.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: tedious-web -version: 0.2.1.2 +version: 0.2.1.4 license: BSD-3-Clause license-file: LICENSE copyright: 2024 WonderBear @@ -14,9 +14,8 @@ category: Web build-type: Simple -extra-source-files: - README.md - CHANGELOG.md +extra-source-files: README.md +extra-doc-files: CHANGELOG.md source-repository head type: git @@ -28,7 +27,6 @@ Tedious.Entity Tedious.Handler Tedious.Quasi - Tedious.Tutorial Tedious.Util hs-source-dirs: src