packages feed

tedious-web 0.2.1.2 → 0.2.1.4

raw patch · 7 files changed

+89/−90 lines, 7 files

Files

app/Lib.hs view
@@ -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)
src/Tedious/Entity.hs view
@@ -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
src/Tedious/Handler.hs view
@@ -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
src/Tedious/Parser.hs view
@@ -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
           ]
src/Tedious/Quasi.hs view
@@ -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
− src/Tedious/Tutorial.hs 
@@ -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
--}
-
tedious-web.cabal view
@@ -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