tedious-web (empty) → 0.2.1.2
raw patch · 16 files changed
+2018/−0 lines, 16 filesdep +aesondep +basedep +data-defaultsetup-changed
Dependencies added: aeson, base, data-default, data-default-instances-containers, effectful-core, extra, generic-lens, haskell-src-meta, hspec, http-types, insert-ordered-containers, lens, megaparsec, mtl, opaleye, openapi3, persistent, postgresql-simple, product-profunctors, profunctors, raw-strings-qq, resource-pool, tagged, tedious-web, template-haskell, text, time, tuple, unordered-containers, webgear-core
Files
- CHANGELOG.md +17/−0
- LICENSE +26/−0
- README.md +120/−0
- Setup.hs +2/−0
- app/Lib.hs +46/−0
- app/Main.hs +38/−0
- src/Tedious.hs +12/−0
- src/Tedious/Entity.hs +102/−0
- src/Tedious/Handler.hs +547/−0
- src/Tedious/Orphan.hs +43/−0
- src/Tedious/Parser.hs +648/−0
- src/Tedious/Quasi.hs +15/−0
- src/Tedious/Tutorial.hs +46/−0
- src/Tedious/Util.hs +33/−0
- tedious-web.cabal +189/−0
- test/Spec.hs +134/−0
+ CHANGELOG.md view
@@ -0,0 +1,17 @@+# Changelog for `tedious-web`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.2.1.1 - 2024-07-19++* Write ABNF rules for the parser.++## 0.2.1.2 - 2024-07-19++* Added ABNF definition for tedious QuasiQuote.
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2024 Wonder Bear++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. 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.++3. 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.
+ README.md view
@@ -0,0 +1,120 @@+# tedious-web++A user-friendly web development tool that can easily define multiple interrelated data types, automatically generate common type class instances, provide some convenience for web development.++## Pros & Cons++### Pros:+* Can easily define multiple interrelated data types.+* Instances of Show, Eq, Generic, Default ([data-default](https://hackage.haskell.org/package/data-default)), ToJSON ([aeson](https://hackage.haskell.org/package/aeson)), FromJSON ([aeson](https://hackage.haskell.org/package/aeson)), ToSchema ([openapi](https://hackage.haskell.org/package/openapi3)) are created by default.+* The table definition of the data type in the style of [opaleye](https://hackage.haskell.org/package/opaleye) will be created easily.+* Database migration statements based on [persistent](https://hackage.haskell.org/package/persistent) can also be easily generated.+* Field types support type variables.++### Cons:+* Do not support sum type.+* Do not support complex requirements.++## Example++```haskell+[tedious|++Person table t_persion deriving Exception -- optional comment of type+ id `ID` Int64 (Maybe (Field SqlInt8), Field SqlInt8) PersonToUpd+ firstName `first name` Text `John` ("first_name", Field SqlText) !UniquePersonName PersonToAdd PersonToUpd?+ lastName `second name` Text `Smith` ("first_name", Field SqlText) !UniquePersonName PersonToAdd PersonToUpd?+ age Int `10` (Field SqlInt4) PersonToAdd -- optional comment of field A+ address `home address` Text? (Maybe (Field SqlText), Field SqlText) PersonToAdd+ profession Text? `teacher` ("profes", Maybe (Field SqlText), Field SqlText) PersonToAdd+ hobby Text? (Maybe (Field SqlText), Field SqlText) PersonToAdd PersonToUpd?+ score `(English, Mathematic)` ((Int, Int))+ other a++|]+```++will generate:++```haskell+data Person+ = Person { _personId :: Int64,+ _personFirstName :: Text,+ _personLastName :: Text,+ _personAge :: Int,+ _personAddress :: (Maybe Text),+ _personProfession :: (Maybe Text),+ _personHobby :: (Maybe Text),+ _personScore :: (Int, Int)+ }++deriving instance Exception Person+deriving stock instance Show Person+deriving stock instance Eq Person+deriving stock instance Generic Person+deriving instance Default Person+instance ToJSON Person where ...+instance FromJSON Person where ...+instance ToSchema Person where ...++data PersonToAdd+ = PersonToAdd { _personToAddFirstName :: Text,+ _personToAddLastName :: Text,+ _personToAddAge :: Int,+ _personToAddAddress :: (Maybe Text),+ _personToAddProfession :: (Maybe Text),+ _personToAddHobby :: (Maybe Text)+ }++deriving instance Exception PersonToAdd+deriving stock instance Show PersonToAdd+deriving stock instance Eq PersonToAdd+deriving stock instance Generic PersonToAdd+deriving instance Default PersonToAdd+instance ToJSON PersonToAdd where ...+instance FromJSON PersonToAdd where ...+instance ToSchema PersonToAdd where ...++data PersonToUpd+ = PersonToUpd { _personToUpdId :: Int64,+ _personToUpdFirstName :: (Maybe Text),+ _personToUpdLastName :: (Maybe Text),+ _personToUpdHobby :: (Maybe Text)+ }++deriving instance Exception PersonToUpd+deriving stock instance Show PersonToUpd+deriving stock instance Eq PersonToUpd+deriving stock instance Generic PersonToUpd+deriving instance Default PersonToUpd+instance ToJSON PersonToUpd where ...+instance FromJSON PersonToUpd where ...+instance ToSchema PersonToUpd where ...++personTable :: Table ( Maybe (Field SqlInt8), + Field SqlText, + Field SqlText, + Field SqlInt4, + Maybe (Field SqlText), + Maybe (Field SqlText), + Mayb(Field SqlText)+ ) + ( Field SqlInt8,+ Field SqlText,+ Field SqlText,+ Field SqlInt4,+ Field SqlText,+ Field SqlText,+ Field SqlText+ )+personTable = ...++tediousPersistString :: String+tediousPersistString = ...+```++You can use tediousPersistString to do migration in another module like this:++```haskell+share [mkPersist sqlSettings, mkMigrate "migrateAll"] $(quoteExp persistUpperCase tediousPersistString)+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Lib.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}++module Lib where++import Control.Exception (Exception)+import Data.Int (Int64)+import Data.Profunctor.Product+import Data.Text (Text)+import Data.Time (UTCTime)+import GHC.Generics (Generic)+import Opaleye (Field, FieldNullable, SqlText, SqlTimestamptz)+import Opaleye.SqlTypes (SqlInt8, SqlInt4)+import Tedious (tedious)++[tedious|+ Dog table dog deriving Exception -- dog+ id `ID` Int64 (Maybe (Field SqlInt8), Field SqlInt8)+ firstName `first name` Text `Wang` ("first_name", Field SqlText) !UniqueDog DogA DogC Dog_:a+ secondName `second name` Text `Ji Rong` ("second_name", Maybe (Field SqlText), Field SqlText) !UniqueDog DogA Dog_:b?+ address `home address` Text `Beijing` (Maybe (Field Text), Field Text) DogA Dog_:c -- where the dog is live in+ master `master's name` Text (Field Text) !UniqueDogMaster default=`'the lord'` DogA DogB? -- master+ masterAge `master's age` Int `26` DogC -- age of dog's master+ 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+ createdAt `creation time` UTCTime ("cteated_at", Maybe (FieldNullable SqlTimestamptz), FieldNullable SqlTimestamptz) default=`CURRENT_TIMESTAMP` DogB DogC?++ Cat table (public, cat)+ id `ID` Int64 (Maybe (Field SqlInt8), Field SqlInt8)+ name Text (Maybe (Field Text), Field Text) !UniqueCat CatA CatC+ master Text? (Maybe (FieldNullable Text), FieldNullable Text) CatA CatB?+ age Int (Field SqlInt4) default=`0` CatA CatB?+ hobby (Maybe Text)? (Maybe (FieldNullable Text), FieldNullable Text) CatC? CatB+ color Text (Maybe (Field Text), Field Text) !UniqueCat CatB CatC+ mind a?++ Page+ index `page index` Int `1`+ size `page size` Int `10`++|]
+ app/Main.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Main where++import Data.Aeson.Text (encodeToLazyText)+import Data.OpenApi (toSchema)+import Data.OpenApi.Internal.Utils (encodePretty)+import Data.Proxy (Proxy (..))+import Data.Tagged (Tagged)+import Data.Text (Text)+import Data.Text.Lazy (unpack)+import Data.Text.Lazy.Encoding (decodeUtf8)+import Data.Time (UTCTime)+import Lib hiding (Dog, Cat)+import Database.Persist.TH (share, mkPersist, sqlSettings, mkMigrate, persistUpperCase)+import Language.Haskell.TH.Quote (quoteExp)++share [mkPersist sqlSettings, mkMigrate "migrateAll"] $(quoteExp persistUpperCase tediousPersistString)++main :: IO ()+main = return ()++testToJson :: IO ()+testToJson = putStrLn . unpack . encodeToLazyText $ Just ("hello" :: String)++testToSchema :: IO ()+testToSchema = do+ putStrLn . unpack . decodeUtf8 . encodePretty $ toSchema (Proxy :: Proxy (Tagged "hello" Int))+ -- putStrLn . unpack . decodeUtf8 . encodePretty $ toSchema (Proxy :: Proxy Page)
+ src/Tedious.hs view
@@ -0,0 +1,12 @@+module Tedious+ ( module Tedious.Quasi,+ module Tedious.Util,+ module Tedious.Entity,+ module Tedious.Handler,+ )+where++import Tedious.Entity+import Tedious.Handler+import Tedious.Quasi+import Tedious.Util
+ src/Tedious/Entity.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Tedious.Entity where++import Control.Exception (Exception)+import Control.Lens (makeLenses, (&), (.~), (<&>), (?~), (^.))+import Data.Aeson (ToJSON (..), FromJSON (..))+import Data.Aeson qualified as A+import Data.Aeson.TH (deriveJSON)+import Data.Default (Default (..))+import Data.HashMap.Strict.InsOrd (fromList)+import Data.Int (Int64)+import Data.OpenApi (HasExample (..), HasProperties (..), HasRequired (..), HasTitle (..), HasType (..), OpenApiType (..), ToSchema, declareSchemaRef, genericDeclareNamedSchema)+import Data.OpenApi qualified as O+import Data.OpenApi.Internal.Schema (named)+import Data.Profunctor.Product+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import Data.Time (UTCTime)+import Effectful (Eff)+import Effectful.Error.Dynamic (Error, runErrorWith)+import GHC.Generics (Generic)+import Numeric.Natural (Natural)+import Opaleye (Field, FieldNullable, SqlInt8, SqlText, SqlTimestamptz)+import Tedious.Quasi (tedious)+import Tedious.Util (schemaOptions, toJSONOptions, trimPrefixName_)++[tedious|+Page+ index `页码` Natural `1`+ size `每页条数` Natural `10`++PageO+ page `分页` Page+ total `总数` Natural+ data `数据` a++PageI+ page `分页` Page?+ filter `过滤` a?++Rep+ code `错误码` Natural+ message `消息` Text+ data `数据` a?++Err deriving Exception+ code Natural+ message Text++SysAdmin+ name Text+ pass Text++SysUser+ name Text (Field SqlText)+ pass Text (Field SqlText)++SysOper+ id `ID` Int64 (Maybe (Field SqlInt8), Field SqlInt8)+ user `人员` Text? (Maybe (FieldNullable SqlText), FieldNullable SqlText)+ name `名称` Text (Field SqlText) SysOper'+ target `目标` Text (Field SqlText) SysOper'+ content `内容` Text? (Maybe (FieldNullable SqlText), FieldNullable SqlText) SysOper'+ time `时间` UTCTime (Field SqlTimestamptz)+|]++fillPage :: Page -> Natural -> b -> PageO b+fillPage page total v =+ PageO+ { _pageOPage = page,+ _pageOTotal = total,+ _pageOData = v+ }++--++repOk :: Rep a+repOk = Rep 0 "ok" Nothing++rep :: a -> Rep a+rep d = Rep 0 "ok" (Just d)++repErr :: Natural -> Text -> Rep a+repErr c m = Rep c m Nothing++repErr' :: Err -> Rep a+repErr' e = Rep (e ^. errCode) (e ^. errMessage) Nothing++repErrNotSupport :: Rep a+repErrNotSupport = repErr 500 "not supported yet"++catchRep :: Eff (Error Err : es) (Rep a) -> Eff es (Rep a)+catchRep = runErrorWith (const $ return . repErr')++--++type SysOperTargetName = Text
+ src/Tedious/Handler.hs view
@@ -0,0 +1,547 @@+{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE Arrows #-} + +module Tedious.Handler ( + withDoc, + withDoc', + errorHandler, + authFail, + audit, + list, + list', + get, + get', + add, + add', + dup, + dup', + upd, + upd', + del +) where + +import Control.Arrow (returnA) +import Control.Lens ((^.)) +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Pool (Pool, withResource) +import Data.Profunctor.Product.Default (Default) +import Data.Text (Text, pack) +import Data.Time (getCurrentTime) +import Data.Tuple.All (Sel1 (..)) +import Database.PostgreSQL.Simple (Connection) +import Effectful (Eff, IOE, MonadIO (..), (:>)) +import Effectful.Error.Dynamic (throwError) +import Effectful.Reader.Dynamic (Reader, asks) +import Network.HTTP.Types qualified as HTTP +import Opaleye (DefaultFromField, Delete (Delete, dReturning, dTable, dWhere), Field, FromFields, Insert (Insert, iOnConflict, iReturning, iRows, iTable), Order, Select, SqlBool, SqlInt8, Table, Unpackspec, Update (Update, uReturning, uTable, uUpdateWith, uWhere), countRows, limit, offset, orderBy, rCount, rReturning, runDelete, runInsert, runSelect, runUpdate, selectTable, sqlStrictText, sqlUTCTime, toNullable, where_, (.==)) +import Opaleye.Internal.Table (tableIdentifier) +import Tedious.Entity (Err (Err), Page (Page), PageI (_pageIFilter, _pageIPage), PageO (PageO), Rep, SysOper' (..), SysOperTargetName, catchRep, fillPage, pageIndex, pageSize, rep, repErr, repOk, sysOperTable) +import WebGear.Core (BasicAuthError (..), Body, Description, Gets, Handler (arrM, setDescription, setSummary), HasTrait (from), HaveTraits, JSON (JSON), Middleware, PathVar, PlainText (..), Request, RequestHandler, RequiredResponseHeader, Response, Sets, StdHandler, Summary, With, pick, requestBody, respondA, (<<<)) + +withDoc :: (Handler h m) => Summary -> Description -> Middleware h ts ts +withDoc summ desc handler = setDescription desc <<< setSummary summ <<< handler + +withDoc' :: (Handler h m) => Summary -> Middleware h ts ts +withDoc' summ handler = setSummary summ <<< handler + +errorHandler :: + ( Show e, + StdHandler h m, + Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep ())] + ) => + h (Request `With` ts, e) Response +errorHandler = proc (_, err) -> respondA HTTP.ok200 JSON -< (repErr 1 (pack . show $ err) :: Rep ()) + +-- authFail :: +-- ( StdHandler h App, +-- Sets h '[RequiredResponseHeader "WWW-Authenticate" Text] +-- ) => +-- h (Request `With` ts, BasicAuthError ()) Response +-- authFail = respondUnauthorized "Basic" "MyRealm" + +authFail :: + ( StdHandler h (Eff es) + ) => + h (Request `With` ts, BasicAuthError ()) Response +authFail = proc (_request, err) -> case err of + BasicAuthAttributeError () -> + respondA HTTP.forbidden403 PlainText -< "Forbidden" :: Text + _ -> + respondA HTTP.unauthorized401 PlainText -< "Unauthorized" :: Text + +audit :: + forall eff env es h ts. -- eff effects (app env) arrow traits + ( Reader env :> es, + IOE :> es, + eff ~ Eff es, + StdHandler h eff + ) => + (env -> Pool Connection) -> + Maybe Text -> + (RequestHandler h ts, SysOper') -> + RequestHandler h ts +audit envPool user (handler, oper) = + proc request -> do + res <- handler -< request + arrM + ( const $ do + now <- liftIO getCurrentTime + pool <- asks envPool + liftIO . withResource pool $ \conn -> do + runInsert + conn + Insert + { iTable = sysOperTable, + iRows = + [ ( Nothing, + toNullable . sqlStrictText <$> user, + sqlStrictText . _sysOper'Name $ oper, + sqlStrictText . _sysOper'Target $ oper, + toNullable . sqlStrictText <$> _sysOper'Content oper, + sqlUTCTime now + ) + ], + iReturning = rReturning (const ()), + iOnConflict = Nothing + } + ) + -< + () + returnA -< res + +list :: + forall i d f ids wfs rfs r eff env es h ts. -- (record id) data (data filter) [id] (table write fields) (table read fields) (table record) eff effects (app env) arrow traits + ( ids ~ [i], + Integral i, + DefaultFromField SqlInt8 i, + Default Unpackspec rfs rfs, + Default FromFields rfs r, + Reader env :> es, + IOE :> es, + eff ~ Eff es, + StdHandler h eff, + Gets h '[Body JSON (PageI f)], + Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep (PageO [d])), Body JSON (Rep ())] + ) => + (env -> Pool Connection) -> + Table wfs rfs -> + (Maybe f -> rfs -> Field SqlBool) -> + Order rfs -> + (r -> d) -> + (RequestHandler h ts, SysOper') +list envPool tbl flt ord r2d = + let handler = requestBody @(PageI f) JSON errorHandler $ + proc request -> do + let pageI = pick @(Body JSON (PageI f)) $ from request + res <- + arrM + ( \pageI -> catchRep $ do + let mPage = _pageIPage pageI + pool <- asks envPool + (rs, cs) <- liftIO . withResource pool $ + \conn -> do + let sel = do + r <- selectTable tbl + where_ $ flt (_pageIFilter pageI) r + pure r + let sel' = case mPage of + Nothing -> sel + Just page -> limit (fromIntegral $ page ^. pageSize) . offset (fromIntegral $ (page ^. pageIndex - 1) * (page ^. pageSize)) . orderBy ord $ sel + rs <- runSelect conn sel' + cs <- runSelect conn . countRows $ selectTable tbl + return (rs, fromIntegral <$> (cs :: ids)) + let count = fromMaybe 0 (listToMaybe cs) + let pageO = case mPage of + Nothing -> PageO (Page 1 count) count + Just page -> fillPage page count + return . rep . pageO $ r2d <$> rs + ) + -< + pageI + respondA HTTP.ok200 JSON -< res + sysOper = SysOper' "list" (pack . show . tableIdentifier $ tbl) Nothing + in (handler, sysOper) + +list' :: + forall i d f ids rfs r eff env es h ts. -- (record id) data (data filter) [id] (table read fields) (table record) eff effects (app env) arrow traits + ( ids ~ [i], + Integral i, + DefaultFromField SqlInt8 i, + Default FromFields rfs r, + Reader env :> es, + IOE :> es, + eff ~ Eff es, + StdHandler h eff, + Gets h '[Body JSON (PageI f)], + Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep (PageO [d])), Body JSON (Rep ())] + ) => + SysOperTargetName -> + (env -> Pool Connection) -> + Select rfs -> + (Maybe f -> rfs -> Field SqlBool) -> + Order rfs -> + (r -> d) -> + (RequestHandler h ts, SysOper') +list' tName envPool sel flt ord r2d = + let handler = requestBody @(PageI f) JSON errorHandler $ + proc request -> do + let pageI = pick @(Body JSON (PageI f)) $ from request + res <- + arrM + ( \pageI -> catchRep $ do + let mPage = _pageIPage pageI + pool <- asks envPool + (rs, cs) <- liftIO . withResource pool $ + \conn -> do + let sel_ = do + r <- sel + where_ $ flt (_pageIFilter pageI) r + pure r + let sel' = case mPage of + Nothing -> sel_ + Just page -> limit (fromIntegral $ page ^. pageSize) . offset (fromIntegral $ (page ^. pageIndex - 1) * (page ^. pageSize)) . orderBy ord $ sel_ + rs <- runSelect conn sel' + cs <- runSelect conn . countRows $ sel + return (rs, fromIntegral <$> (cs :: ids)) + let count = fromMaybe 0 (listToMaybe cs) + let pageO = case mPage of + Nothing -> PageO (Page 1 count) count + Just page -> fillPage page count + return . rep . pageO $ r2d <$> rs + ) + -< + pageI + respondA HTTP.ok200 JSON -< res + sysOper = SysOper' "list" tName Nothing + in (handler, sysOper) + +get :: + forall i fi d wfs rfs r eff env es h ts. -- (record id) (field id) data (table write fields) (table read fields) (table record) eff effects (app env) arrow traits + ( Default Unpackspec rfs rfs, + Default FromFields rfs r, + Sel1 rfs (Field fi), + Reader env :> es, + IOE :> es, + eff ~ Eff es, + StdHandler h eff, + HaveTraits '[PathVar "id" i] ts, + Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep (Maybe d))] + ) => + (env -> Pool Connection) -> + Table wfs rfs -> + (i -> Field fi) -> + (r -> d) -> + (RequestHandler h ts, SysOper') +get envPool tbl idf r2d = + 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 <- selectTable tbl + where_ $ sel1 r .== idf tid + pure r + pure . listToMaybe $ r2d <$> rs + ) + -< + tid + respondA HTTP.ok200 JSON -< rep md + sysOper = SysOper' "get" (pack . show . tableIdentifier $ tbl) Nothing + 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, + IOE :> es, + eff ~ Eff es, + StdHandler h eff, + HaveTraits '[PathVar "id" i] ts, + Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep (Maybe d))] + ) => + SysOperTargetName -> + (env -> Pool Connection) -> + Select rfs -> + (i -> Field fi) -> + (r -> d) -> + (RequestHandler h ts, SysOper') +get' tName envPool sel idf r2d = + 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 + ) + -< + tid + respondA HTTP.ok200 JSON -< rep md + sysOper = SysOper' "get" tName Nothing + in (handler, sysOper) + +add :: + forall i fi a wfs rfs eff env es h ts. -- (record id) (field id) (data to add) (table write fields) (table read fields) eff effects (app env) arrow traits + ( Sel1 rfs (Field fi), + DefaultFromField fi i, + Reader env :> es, + IOE :> es, + eff ~ Eff es, + StdHandler h eff, + Gets h '[Body JSON a], + Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep i), Body JSON (Rep ())] + ) => + (env -> Pool Connection) -> + Table wfs rfs -> + (a -> [wfs]) -> + (RequestHandler h ts, SysOper') +add envPool tbl a2t = + let handler = requestBody @a JSON errorHandler $ + proc request -> do + let toAdd = pick @(Body JSON a) $ from request + rep_ <- + arrM + ( \toAdd -> catchRep $ do + pool <- asks envPool + ids <- liftIO . withResource pool $ \conn -> do + runInsert + conn + Insert + { iTable = tbl, + iRows = a2t toAdd, + iReturning = rReturning sel1, + iOnConflict = Nothing + } + maybe (throwError $ Err 1 "insert failure") (return . rep) (listToMaybe ids) + ) + -< + toAdd + respondA HTTP.ok200 JSON -< (rep_ :: Rep i) + sysOper = SysOper' "add" (pack . show . tableIdentifier $ tbl) Nothing + in (handler, sysOper) + +add' :: + forall i a eff env es h ts. -- (record id) (data to add) eff effects (app env) arrow traits + ( Reader env :> es, + IOE :> es, + eff ~ Eff es, + StdHandler h eff, + Gets h '[Body JSON a], + Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep i), Body JSON (Rep ())] + ) => + SysOperTargetName -> + (env -> Pool Connection) -> + (Connection -> a -> IO i) -> + (RequestHandler h ts, SysOper') +add' tName envPool oper = + let handler = requestBody @a JSON errorHandler $ + proc request -> do + let toAdd = pick @(Body JSON a) $ from request + rep_ <- + arrM + ( \toAdd -> catchRep $ do + pool <- asks envPool + liftIO . withResource pool $ \conn -> rep <$> oper conn toAdd + ) + -< + toAdd + respondA HTTP.ok200 JSON -< rep_ + sysOper = SysOper' "add" tName Nothing + in (handler, sysOper) + +dup :: + forall i fi wfs rfs r eff env es h ts. -- (record id) (field id) (table write fields) (table read fields) (table record) eff effects (app env) arrow traits + ( Default Unpackspec rfs rfs, + Default FromFields rfs r, + Sel1 rfs (Field fi), + DefaultFromField fi i, + Reader env :> es, + IOE :> es, + eff ~ Eff es, + StdHandler h eff, + HaveTraits '[PathVar "id" i] ts, + Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep i), Body JSON (Rep ())] + ) => + (env -> Pool Connection) -> + Table wfs rfs -> + (i -> Field fi) -> + (r -> wfs) -> + (RequestHandler h ts, SysOper') +dup envPool tbl idf r2t = + let handler = proc request -> do + let tid = pick @(PathVar "id" i) $ from request + tid_ <- + arrM + ( \tid -> catchRep $ do + pool <- asks envPool + ids <- liftIO . withResource pool $ + \conn -> do + rs <- runSelect conn $ do + r <- selectTable tbl + where_ $ sel1 r .== idf tid + pure r + runInsert + conn + Insert + { iTable = tbl, + iRows = r2t <$> rs, + iReturning = rReturning sel1, + iOnConflict = Nothing + } + maybe (throwError $ Err 1 "duplicate failure") (return . rep) (listToMaybe ids) + ) + -< + tid + respondA HTTP.ok200 JSON -< (tid_ :: Rep i) + sysOper = SysOper' "dup" (pack . show . tableIdentifier $ tbl) Nothing + in (handler, sysOper) + +dup' :: + forall i eff env es h ts. -- (record id) eff effects (app env) arrow traits + ( Reader env :> es, + IOE :> es, + eff ~ Eff es, + StdHandler h eff, + HaveTraits '[PathVar "id" i] ts, + Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep i), Body JSON (Rep ())] + ) => + SysOperTargetName -> + (env -> Pool Connection) -> + (Connection -> i -> IO i) -> + (RequestHandler h ts, SysOper') +dup' tName envPool oper = + let handler = proc request -> do + let tid = pick @(PathVar "id" i) $ from request + rep_ <- + arrM + ( \(tid, oper_) -> catchRep $ do + pool <- asks envPool + liftIO . withResource pool $ + \conn -> rep <$> oper_ conn tid + ) + -< + (tid, oper) + respondA HTTP.ok200 JSON -< rep_ + sysOper = SysOper' "dup" tName Nothing + in (handler, sysOper) + +upd :: + forall i fi u wfs rfs d r eff env es h ts. -- (record id) (field id) update (table write fields) (table read fields) data (table record) eff effects (app env) arrow traits + ( Sel1 rfs (Field fi), + Default FromFields rfs r, + Reader env :> es, + IOE :> es, + eff ~ Eff es, + StdHandler h eff, + HaveTraits '[PathVar "id" i] ts, + Gets h '[Body JSON u], + Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep d), Body JSON (Rep ())] + ) => + (env -> Pool Connection) -> + Table wfs rfs -> + (i -> Field fi) -> + (u -> (rfs -> wfs)) -> + (r -> d) -> + (RequestHandler h ts, SysOper') +upd envPool tbl idf u2t r2d = + let handler = requestBody @u JSON errorHandler $ + proc request -> do + let tid = pick @(PathVar "id" i) $ from request + let toUpd = pick @(Body JSON u) $ from request + ru <- + arrM + ( \(tid, toUpd) -> catchRep $ do + pool <- asks envPool + ru <- liftIO . withResource pool $ \conn -> do + runUpdate + conn + Update + { uTable = tbl, + uUpdateWith = u2t toUpd, + uWhere = (.== idf tid) . sel1, + uReturning = rReturning id + } + maybe (throwError $ Err 1 "insert failure") (return . rep . r2d) (listToMaybe ru) + ) + -< + (tid, toUpd) + respondA HTTP.ok200 JSON -< (ru :: Rep d) + sysOper = SysOper' "upd" (pack . show . tableIdentifier $ tbl) Nothing + in (handler, sysOper) + +upd' :: + forall i u d eff env es h ts. -- (record id) update data eff effects (app env) arrow traits + ( Reader env :> es, + IOE :> es, + eff ~ Eff es, + StdHandler h eff, + HaveTraits '[PathVar "id" i] ts, + Gets h '[Body JSON u], + Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep d), Body JSON (Rep ())] + ) => + SysOperTargetName -> + (env -> Pool Connection) -> + (Connection -> i -> u -> IO d) -> + (RequestHandler h ts, SysOper') +upd' tName envPool oper = + let handler = requestBody @u JSON errorHandler $ + proc request -> do + let tid = pick @(PathVar "id" i) $ from request + let toUpd = pick @(Body JSON u) $ from request + ru <- + arrM + ( \(tid, toUpd) -> catchRep $ do + pool <- asks envPool + liftIO . withResource pool $ \conn -> rep <$> oper conn tid toUpd + ) + -< + (tid, toUpd) + respondA HTTP.ok200 JSON -< (ru :: Rep d) + sysOper = SysOper' "upd" tName Nothing + in (handler, sysOper) + +del :: + forall i fi wfs rfs eff env es h ts. -- (record id) (field id) (table write fields) (table read fields) eff effects (app env) arrow traits + ( Sel1 rfs (Field fi), + Reader env :> es, + IOE :> es, + eff ~ Eff es, + StdHandler h eff, + HaveTraits '[PathVar "id" i] ts, + Sets h '[RequiredResponseHeader "Content-Type" Text, Body JSON (Rep Text), Body JSON (Rep ())] + ) => + (env -> Pool Connection) -> + Table wfs rfs -> + (i -> Field fi) -> + (RequestHandler h ts, SysOper') +del envPool tbl idf = + let handler = proc request -> do + let tid = pick @(PathVar "id" i) $ from request + r <- + arrM + ( \tid -> do + pool <- asks envPool + c <- liftIO . withResource pool $ + \conn -> + runDelete conn $ + Delete + { dTable = tbl, + dWhere = (.== idf tid) . sel1, + dReturning = rCount + } + pure $ if c == 1 then repOk else repErr 1 "delete failure" + ) + -< + tid + respondA HTTP.ok200 JSON -< (r :: Rep Text) + sysOper = SysOper' "get" (pack . show . tableIdentifier $ tbl) Nothing + in (handler, sysOper)
+ src/Tedious/Orphan.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE KindSignatures #-}++module Tedious.Orphan () where++import Control.Lens ((?~))+import Data.Default (Default (..))+import Data.Function ((&))+import Data.OpenApi (HasTitle (..), ToSchema, declareSchema)+import Data.OpenApi.Internal.Schema (unnamed)+import Data.OpenApi.Schema (ToSchema (..))+import Data.Proxy (Proxy (..))+import Data.Tagged (Tagged)+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder qualified as TLB+import Data.Time (UTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.Typeable (typeRep)+import GHC.Base (Symbol)+import GHC.TypeLits (KnownSymbol, Natural)++instance forall s b. (KnownSymbol s, ToSchema b) => ToSchema (Tagged (s :: Symbol) b) where+ declareNamedSchema _ = do+ _schema <- declareSchema (Proxy :: Proxy b)+ return . unnamed $ _schema & title ?~ (T.pack . init . tail . show . typeRep $ (Proxy :: Proxy s))++instance Default T.Text where+ def = T.empty++instance Default TL.Text where+ def = TL.empty++instance Default TLB.Builder where+ def = mempty++instance Default Bool where+ def = False++instance Default Natural where+ def = 0++instance Default UTCTime where+ def = posixSecondsToUTCTime 0
+ src/Tedious/Parser.hs view
@@ -0,0 +1,648 @@+{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Tedious.Parser where + +import Control.Lens (declareLensesWith, lensRules) +import Control.Lens qualified as L +import Control.Monad (join, when) +import Control.Monad.Cont (MonadCont (..), evalContT) +import Control.Monad.Trans (lift) +import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToEncoding, genericToJSON) +import Data.Aeson qualified as A +import Data.Char (isAlphaNum, isLowerCase, isPrint, isUpperCase) +import Data.Default (Default (..)) +import Data.Function as F +import Data.Functor (void, (<&>)) +import Data.HashMap.Strict qualified as HM +import Data.HashMap.Strict.InsOrd qualified as IHM +import Data.List.Extra (snoc) +import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe) +import Data.OpenApi (HasExample (..), HasProperties (..), HasRequired (..), HasTitle (..), HasType (..), OpenApiType (..), ToSchema, declareSchemaRef) +import Data.OpenApi qualified as O +import Data.OpenApi.Internal.Schema (named) +import Data.Proxy (Proxy (..)) +import Data.Tuple.All (Curry (..), Sel1 (sel1), Sel3 (sel3), Sel4 (sel4), Sel5 (sel5)) +import Data.Void (Void) +import GHC.Generics (Generic (..), Rep) +import Language.Haskell.Meta (parseType) +import Language.Haskell.TH +import Opaleye (table, tableField, tableWithSchema) +import Opaleye.Table (Table) +import Tedious.Orphan () +import Tedious.Util (lowerFirst, toJSONOptions, trimPrefixName_, upperFirst) +import Text.Megaparsec (MonadParsec (takeWhile1P, takeWhileP, try), Parsec, between, empty, errorBundlePretty, optional, parse, (<|>)) +import Text.Megaparsec qualified as M +import Text.Megaparsec.Char qualified as MC +import Text.Megaparsec.Char.Lexer qualified as MCL + +type TypName = String + +type BasTypName = String + +type DevTypName = String + +type ExtTypName = String + +type FldName = String + +type FldLabel = String -- openapi label + +type FldTypS = String + +type FldSamp = String -- openapi example + +type FldTypVar = String + +type TblSchema = String + +type TblName = String + +type TblFldOName = String + +type TblFldOTypSW = String + +type TblFldOTypSR = String + +type FldBasIsMaybe = Bool + +type FldExtIsMaybe = Bool + +type FldExtVar = String + +type TblFldIsPrimary = Bool + +type TblFldUnique = String + +type TblFldDefault = String + +type TblUniqueName = String + +type TypInfo = (TypName, [DevTypName], RepTediousFields) + +type RepTediousFields = [(FldName, Maybe FldLabel, FldTyp, FldExtIsMaybe, Maybe FldExtVar)] + +type RepOpaleye = [(TblFldOName, (FldTypS, FldBasIsMaybe), TblFldOTypSW, TblFldOTypSR)] + +type RepPersistTyp = (BasTypName, TblPrimary, [TblUnique], [(FldName, FldTypS, FldBasIsMaybe, Maybe TblFldDefault)]) + +-- + +data Combo + = Combo + BasTypName -- base type name + (Maybe TblInfo) -- table name + (Maybe [DevTypName]) -- derivings + deriving stock (Eq, Show, Generic) + +data TblInfo = TblInfoQualified TblSchema TblName | TblInfoUnQualified TblName + deriving stock (Eq, Show, Generic) + +data ComboAttr = ComboTblInfo TblInfo | ComboDevTyp [DevTypName] + deriving stock (Eq, Show, Generic) + +data Field + = Field + (FldName, Maybe FldLabel) -- (field name, 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) + +data FldTyp + = FldTypNormal FldTypS FldBasIsMaybe (Maybe FldSamp) (Maybe TblFld) -- type of field on base type, field is maybe or not, example value in openapi schema, table field info + | FldTypPoly FldTypVar FldBasIsMaybe + deriving stock (Eq, Show, Generic) + +data TblFld = TblFld TblFldOpaleye TblFldIsPrimary [TblFldUnique] (Maybe TblFldDefault) + deriving stock (Eq, Show, Generic) + +data ExtTyp = ExtTypNormal ExtTypName FldExtIsMaybe | ExtTypPoly ExtTypName FldExtVar FldExtIsMaybe + deriving stock (Eq, Show, Generic) + +data TblFldOpaleye + = TblFldOR TblFldOTypSR -- omit field name, write type and read type are same. eg. (Field Text) + | TblFldOWR TblFldOTypSW TblFldOTypSR -- omit field name, write type and read type are diff. eg. (Maybe (Field Text), Field Text) + | TblFldONR TblFldOName TblFldOTypSR -- write type and read type are same. eg. ("field_name", Field Text) + | TblFldONWR TblFldOName TblFldOTypSW TblFldOTypSR -- write type and read type are diff. eg. ("field_name", Maybe (Field Text), Field Text) + deriving stock (Eq, Show, Generic) + +newtype TblPrimary = TblPrimary [FldName] + deriving stock (Eq, Show, Generic) + +data TblUnique = TblUnique TblUniqueName [FldName] + deriving stock (Eq, Show, Generic) + +data TediousTyp = TediousTyp Combo [Field] + deriving stock (Eq, Show, Generic) + +-- + +type Parser = Parsec Void String + +lineComment :: Parser () +lineComment = MCL.skipLineComment "--" + +sc :: Parser () +sc = MCL.space (void $ M.some (MC.char ' ' <|> MC.char '\t')) lineComment empty + +scn :: Parser () +scn = MCL.space MC.space1 lineComment empty + +lexeme :: Parser a -> Parser a +lexeme = MCL.lexeme sc + +isNameChar :: Char -> Bool +isNameChar c = isAlphaNum c || c == '_' || c == '\'' + +pName :: Parser String +pName = lexeme pName_ + +pName_ :: Parser String +pName_ = takeWhile1P Nothing isNameChar + +pNameLower :: Parser String +pNameLower = lexeme pNameLower_ + +pNameLower_ :: Parser String +pNameLower_ = (<>) <$> takeWhile1P Nothing isLowerCase <*> takeWhileP Nothing isNameChar + +pNameUpper :: Parser String +pNameUpper = lexeme pNameUpper_ + +pNameUpper_ :: Parser String +pNameUpper_ = (<>) <$> takeWhile1P Nothing isUpperCase <*> takeWhileP Nothing isNameChar + +string :: String -> Parser String +string = lexeme . MC.string + +symbol :: String -> Parser String +symbol = MCL.symbol sc + +parens :: Parser a -> Parser a +parens = between (symbol "(") (symbol ")") + +parens_ :: Parser a -> Parser a +parens_ = between (symbol "(") (MC.char ')') + +parens' :: Parser String -> Parser String +parens' p = join <$> sequence [pure "(", between (symbol "(") (symbol ")") p, pure ")"] + +parens'_ :: Parser String -> Parser String +parens'_ p = join <$> sequence [pure "(", between (symbol "(") (MC.char ')') p, pure ")"] + +brackets :: Parser a -> Parser a +brackets = between (symbol "[") (symbol "]") + +brackets_ :: Parser a -> Parser a +brackets_ = between (symbol "[") (MC.char ']') + +brackets' :: Parser String -> Parser String +brackets' p = join <$> sequence [pure "[", between (symbol "[") (symbol "]") p, pure "]"] + +brackets'_ :: Parser String -> Parser String +brackets'_ p = join <$> sequence [pure "[", between (symbol "[") (MC.char ']') p, pure "]"] + +quotes :: Parser a -> Parser a +quotes = between (symbol "\"") (symbol "\"") + +quotes_ :: Parser a -> Parser a +quotes_ = between (symbol "\"") (MC.char '\"') + +backQuotes :: Parser a -> Parser a +backQuotes = between (symbol "`") (symbol "`") + +backQuotes_ :: Parser a -> Parser a +backQuotes_ = between (symbol "`") (MC.char '`') + +backQuoteString :: Parser String +backQuoteString = lexeme . backQuotes $ takeWhileP Nothing (\c -> isPrint c && c /= '`') + +pTblInfo :: Parser TblInfo +pTblInfo = string "table" *> (parens (TblInfoQualified <$> pName <*> (symbol "," *> pName)) <|> (TblInfoUnQualified <$> pName)) + +pDevTyp :: Parser [DevTypName] +pDevTyp = string "deriving" *> lexeme (M.some pNameUpper) + +pComboAttr :: Parser ComboAttr +pComboAttr = (ComboTblInfo <$> pTblInfo) <|> (ComboDevTyp <$> pDevTyp) + +pComboAttrs :: Parser (Maybe TblInfo, Maybe [DevTypName]) +pComboAttrs = do + attrs <- M.many pComboAttr + let attrTblName = listToMaybe $ mapMaybe (\case (ComboTblInfo tblInfo) -> Just tblInfo; _ -> Nothing) attrs + let attrDevTyp = listToMaybe $ mapMaybe (\case (ComboDevTyp devTyps) -> Just devTyps; _ -> Nothing) attrs + pure (attrTblName, attrDevTyp) + +pCombo :: Parser Combo +pCombo = uncurryN . Combo <$> pNameUpper <*> pComboAttrs + +pFldName :: Parser FldName +pFldName = pNameLower + +pFldTitle :: Parser FldLabel +pFldTitle = backQuoteString + +pFldNameAndTitle :: Parser (FldName, Maybe FldLabel) +pFldNameAndTitle = (,) <$> pFldName <*> optional pFldTitle + +pFldTypS :: Parser FldTypS +pFldTypS = try (parens protoTypS) <|> protoTypS + where + protoTypS = try arrayTypS <|> try tupleTypS <|> comboTypS + arrayTypS = brackets' (lexeme pFldTypS) + tupleTypS = parens' $ unwords <$> ((:) <$> lexeme pFldTypS <*> M.many tuplePart) + comboTypS = unwords <$> ((<>) <$> M.some pNameUpper <*> M.many pFldTypS) + tuplePart = unwords <$> ((:) <$> symbol "," <*> (pure <$> lexeme pFldTypS)) + +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 "?") + +pTblFldUnique :: Parser TblFldUnique +pTblFldUnique = lexeme $ MC.char '!' *> pNameUpper + +pTblFldDefault :: Parser String +pTblFldDefault = lexeme $ (<>) <$> MC.string "default=" *> backQuoteString + +pTblFld :: Parser TblFld +pTblFld = + pFldP (parens_ (TblFldOR <$> pFldO)) + <|> pFldP (parens_ (TblFldOWR <$> (pFldM <|> pFldO) <*> (symbol "," *> pFldO))) + <|> pFldP (parens_ (TblFldONR <$> quotes pName <*> (symbol "," *> (pFldM <|> pFldO)))) + <|> pFldP (parens_ (TblFldONWR <$> quotes pName <*> (symbol "," *> (pFldM <|> pFldO)) <*> (symbol "," *> pFldO))) + 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) + +pExtName :: Parser ExtTyp +pExtName = try (ExtTypPoly <$> pNameUpper_ <*> (MC.char ':' *> pNameLower_) <*> pOccur "?") <|> (ExtTypNormal <$> pNameUpper_ <*> pOccur "?") + +pField :: Parser Field +pField = Field <$> pFldNameAndTitle <*> pFldTyp <*> M.many pExtName + +pTediousTyp :: Parser TediousTyp +pTediousTyp = MCL.indentBlock scn $ do + combo <- pCombo + return $ MCL.IndentSome Nothing (return . TediousTyp combo) pField + +pTediousTyps :: Parser [TediousTyp] +pTediousTyps = M.many pTediousTyp + +-- + +defIns :: [String] +defIns = ["Eq", "Show", "Generic", "Default", "ToJSON", "FromJSON", "ToSchema"] + +repTediousTyp :: TediousTyp -> (HM.HashMap TypName RepTediousFields, [DevTypName]) +repTediousTyp (TediousTyp (Combo basTypName _ devs) flds) = + let hm = defBase basTypName (flds <&> (\(Field _fldNameLabel _fldTyp _) -> (_fldNameLabel, _fldTyp))) HM.empty + in (defExts flds hm, filter (`notElem` defIns) (fromMaybe empty devs)) + where + defBase _basTypName tuples = + HM.insert + _basTypName + ( tuples + <&> ( \((_fldName, _mFldTitle), _fldTyp) -> case _fldTyp of + FldTypPoly _fldExtVar _fldExtIsM -> (_fldName, _mFldTitle, _fldTyp, _fldExtIsM, Just _fldExtVar) + _ -> (_fldName, _mFldTitle, _fldTyp, False, Nothing) + ) + ) + defExts [] m = m + defExts (Field _ _ [] : ds) m = defExts ds m + defExts (Field (_fldName, _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' + procExtTyp extTyp = case extTyp of + ExtTypNormal _extTypName _fldExtIsM -> (_extTypName, _fldExtIsM, Nothing) + ExtTypPoly _extTypName _fldExtVar _fldExtIsM -> (_extTypName, _fldExtIsM, Just _fldExtVar) + +repOpaleye :: [Field] -> RepOpaleye +repOpaleye = mapMaybe go + where + go (Field (_fldName, _) _fldTyp _) = case _fldTyp of + FldTypNormal _fldTypS _fldBasIsM _ _mTblFld -> case _mTblFld of + Nothing -> Nothing + Just (TblFld _tblFld _ _ _) -> case _tblFld of + TblFldOR _tblFldTypSR -> Just (_fldName, (_fldTypS, _fldBasIsM), _tblFldTypSR, _tblFldTypSR) + TblFldOWR _tblFldTypSW _tblFldTypSR -> Just (_fldName, (_fldTypS, _fldBasIsM), _tblFldTypSW, _tblFldTypSR) + TblFldONR _tblFldName _tblFldTypSR -> Just (_tblFldName, (_fldTypS, _fldBasIsM), _tblFldTypSR, _tblFldTypSR) + TblFldONWR _tblFldName _tblFldTypSW _tblFldTypSR -> Just (_tblFldName, (_fldTypS, _fldBasIsM), _tblFldTypSW, _tblFldTypSR) + _ -> Nothing + +repPersistTyp :: TediousTyp -> RepPersistTyp +repPersistTyp (TediousTyp (Combo basTypName _ _) flds) = + let primaryCons = TblPrimary (genPrimaryCons flds) + uniqueCons = genUniqueCons flds [] + persistFlds = mapMaybe genPersistFld flds + in (basTypName, primaryCons, uniqueCons, persistFlds) + where + genPrimaryCons = mapMaybe extractPrimary + 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 + FldTypNormal _fldTypS _fldBasIsM _ _mTblFld -> case _mTblFld of + Nothing -> genUniqueCons _flds uCons + Just (TblFld _ _ uNames _) -> genUniqueCons _flds (extractUnique _fldName uNames uCons) + _ -> [] + extractUnique _fldName [] uCons = uCons + extractUnique _fldName (uName : uNames) uCons = extractUnique _fldName uNames (extractUniqueOne _fldName uName uCons []) + extractUniqueOne _fldName uName [] uCons = reverse (TblUnique uName [_fldName] : uCons) + extractUniqueOne _fldName uName (uCon@(TblUnique uConName uConFlds) : uCons_) uCons = + 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 + FldTypNormal _fldTypS _fldBasIsM _ _mTblFld -> case _mTblFld of + Nothing -> Nothing + Just (TblFld _ _ _ _def) -> + if _fldName == "id" && _fldTypS == "Int64" + then Nothing + else Just (_fldName, wrapperParens _fldTypS, _fldBasIsM, _def) + _ -> Nothing + wrapperParens s = + if length (words s) > 1 + then "(" <> s <> ")" + else s + +strPersistTyp :: RepPersistTyp -> Maybe String +strPersistTyp (basTypName, TblPrimary pNames, uCons, tblFlds) = + let primaryLine = if null pNames then Nothing else Just . unwords $ "Primary" : pNames + uniqueLines = uCons <&> (\(TblUnique uConName uConFlds) -> unwords $ ("Unique" <> uConName) : uConFlds) + tblFldLines = + tblFlds + <&> ( \(fldName, fldTypS, fldBasIsMaybe, mTblFldDef) -> + unwords . catMaybes $ [Just fldName, Just fldTypS, if fldBasIsMaybe then Just "Maybe" else Nothing, ("default=" <>) <$> mTblFldDef] + ) + in if null tblFldLines + then Nothing + else Just . unlines $ pure basTypName <> (indent 1 <$> catMaybes ((Just <$> tblFldLines) <> pure primaryLine <> (Just <$> uniqueLines))) + where + indent n s = replicate n '\t' <> s + +decTedious :: + String -> + Q [Dec] +decTedious str = do + let tts = case parse pTediousTyps "" str of + Left b -> error ("parse pTedious : " <> errorBundlePretty b) + Right tts_ -> tts_ + let repTts = tts <&> repTediousTyp + let reps = repTts >>= (\(m, devs) -> HM.toList m <&> (\(n, flds) -> (n, devs, flds))) + tediousTypDecs <- join <$> mapM repDec reps + opaleyeDecs <- join <$> mapM decOpaleye tts + persistDecs <- decPersist tts + return (tediousTypDecs <> opaleyeDecs <> persistDecs) + where + repDec :: TypInfo -> Q [Dec] + repDec typInfo = do + _decBasic <- decBasic typInfo + _decShow <- decShow typInfo + _decEq <- decEq typInfo + _decGeneric <- decGeneric typInfo + _decDefault <- decDefault typInfo + _decJSON <- decJSON typInfo + _decToSchema <- decToSchema typInfo + _decLens <- dropWhile isDataD <$> declareLensesWith lensRules (pure _decBasic) + _decStandaloneDerivs <- decStandaloneDerivs typInfo + pure $ _decBasic <> _decShow <> _decEq <> _decGeneric <> _decDefault <> _decJSON <> _decToSchema <> _decLens <> _decStandaloneDerivs + +decBasic :: TypInfo -> Q [Dec] +decBasic (typName, _, flds) = do + let name = mkName typName + let vbs = + flds + <&> ( \(_fldName, _, _fldTyp, _fldExtIsM, _mFldExtVar) -> + let _fldT = case _mFldExtVar of + Nothing -> case _fldTyp of + FldTypNormal _fldTypS _fldBasIsM _ _mTblFld -> pure $ strToTyp _fldTypS (_fldBasIsM || _fldExtIsM) + FldTypPoly _fldTypVar _fldBasIsM -> pure $ varToTyp _fldTypVar _fldBasIsM + Just _fldExtVar -> pure $ varToTyp _fldExtVar _fldExtIsM + in varBangType (mkName $ "_" <> lowerFirst typName <> upperFirst _fldName) (bangType (bang noSourceUnpackedness noSourceStrictness) _fldT) + ) + let bndrs = [plainTV (mkName _fldExtVar) | _fldExtVar <- mapMaybe sel5 flds] + let dec = + if length vbs == 1 + then + newtypeD mempty name bndrs Nothing (recC name vbs) [] + else + dataD mempty name bndrs Nothing [recC name vbs] [] + pure <$> dec + +decStandaloneDerivs :: TypInfo -> Q [Dec] +decStandaloneDerivs (typName, _devClsNames, flds) = + return $ + _devClsNames + <&> ( \_devClsName -> + let _fldExtVars = mapMaybe sel5 flds + preds = [AppT (ConT (mkName _devClsName)) (VarT (mkName _fldExtVar)) | _fldExtVar <- _fldExtVars] + in StandaloneDerivD Nothing preds (AppT (ConT (mkName _devClsName)) (typWithVars typName _fldExtVars)) + ) + +decShow :: TypInfo -> Q [Dec] +decShow (typName, _, flds) = + let _fldExtVars = mapMaybe sel5 flds + preds = [AppT (ConT ''Show) (VarT (mkName _fldExtVar)) | _fldExtVar <- _fldExtVars] + in pure . pure $ StandaloneDerivD (Just StockStrategy) preds (AppT (ConT ''Show) (typWithVars typName _fldExtVars)) + +decEq :: TypInfo -> Q [Dec] +decEq (typName, _, flds) = + let _fldExtVars = mapMaybe sel5 flds + preds = [AppT (ConT ''Eq) (VarT (mkName _fldExtVar)) | _fldExtVar <- _fldExtVars] + in pure . pure $ StandaloneDerivD (Just StockStrategy) preds (AppT (ConT ''Eq) (typWithVars typName _fldExtVars)) + +decGeneric :: TypInfo -> Q [Dec] +decGeneric (typName, _, flds) = + pure . pure $ StandaloneDerivD (Just StockStrategy) [] (AppT (ConT ''Generic) (typWithVars typName (mapMaybe sel5 flds))) + +decDefault :: TypInfo -> Q [Dec] +decDefault (typName, _, flds) = + let _fldExtVars = mapMaybe sel5 flds + preds = [AppT (ConT ''Default) (VarT (mkName _fldExtVar)) | _fldExtVar <- _fldExtVars] + in pure . pure $ StandaloneDerivD Nothing preds (AppT (ConT ''Default) (typWithVars typName _fldExtVars)) + +decJSON :: TypInfo -> Q [Dec] +decJSON (typName, _devClsNames, flds) = do + let _fldExtVars = mapMaybe sel5 flds + let _typ = typWithVars typName _fldExtVars + decToJSON <- do + eToJ <- [|genericToJSON toJSONOptions {A.fieldLabelModifier = trimPrefixName_ typName}|] + let fToJ = FunD 'A.toJSON [Clause [] (NormalB eToJ) []] + eToE <- [|genericToEncoding toJSONOptions {A.fieldLabelModifier = trimPrefixName_ typName}|] + let fToE = FunD 'A.toEncoding [Clause [] (NormalB eToE) []] + let preds = + [ [ AppT (ConT ''Generic) _typ, + AppT (AppT (AppT (ConT ''A.GToJSON') (ConT ''A.Value)) (ConT ''A.Zero)) (AppT (ConT ''Rep) _typ), + AppT (AppT (AppT (ConT ''A.GToJSON') (ConT ''A.Encoding)) (ConT ''A.Zero)) (AppT (ConT ''Rep) _typ) + ] + | _fldExtVar <- _fldExtVars + ] + return $ InstanceD Nothing (join preds) (AppT (ConT ''ToJSON) _typ) [fToJ, fToE] + decFromJSON <- do + e <- [|genericParseJSON toJSONOptions {A.fieldLabelModifier = trimPrefixName_ typName}|] + let preds = + [ [ AppT (ConT ''Generic) _typ, + AppT (AppT (ConT ''A.GFromJSON) (ConT ''A.Zero)) (AppT (ConT ''Rep) _typ) + -- AppT (ConT ''FromJSON) (VarT (mkName _fldExtVar)) + ] + | _fldExtVar <- _fldExtVars + ] + return $ InstanceD Nothing (join preds) (AppT (ConT ''FromJSON) (typWithVars typName _fldExtVars)) [FunD 'A.parseJSON [Clause [] (NormalB e) []]] + pure [decToJSON, decFromJSON] + +decToSchema :: TypInfo -> Q [Dec] +decToSchema (typName, _devClsNames, flds) = do + let name = mkName typName + 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)) + ] + | _fldExtVar <- _fldExtVars + ] + let tuples = + ( \(_fldName, _mFldTitle, _fldTyp, _fldExtIsM, _mFldExtVar) -> do + let (_fldT, _mFldS) = case _mFldExtVar of + Nothing -> case _fldTyp of + FldTypNormal _fldTypS _fldBasIsM _mFldSamp _mTblFld -> (strToTyp _fldTypS (_fldBasIsM || _fldExtIsM), _mFldSamp) + FldTypPoly _fldTypVar _fldBasIsM -> (varToTyp _fldTypVar _fldBasIsM, Nothing) + Just _fldExtVar -> (varToTyp _fldExtVar _fldExtIsM, Nothing) + let sigProxy = SigE (ConE 'Proxy) (AppT (ConT ''Proxy) _fldT) + (_fldName, _mFldTitle, _fldT, isMaybeTyp _fldT, _mFldS, AppE (VarE 'declareSchemaRef) sigProxy) + ) + <$> flds + let bindStmts = tuples <&> (\(_fldName, _, _, _, _, _schemaRefExp) -> bindS (varP (mkName $ fldSchemaName _fldName)) (pure _schemaRefExp)) + let u1 = uInfixE (varE 'type_) (varE '(L.?~)) (conE 'OpenApiObject) + let u2 = + uInfixE + (varE 'properties) + (varE '(L..~)) + ( appE + (varE 'IHM.fromList) + ( listE $ + tuples + <&> ( \(_fldName, _mFldTitle, _, _, _, _fldBasIsM) -> + tupE [stringE _fldName, uInfixE (varE (mkName $ fldSchemaName _fldName)) (varE '(<&>)) (uInfixE (varE 'title) (varE '(L..~)) [|_mFldTitle|])] + ) + ) + ) + let u3 = uInfixE (varE 'required) (varE '(L..~)) (listE $ stringE . sel1 <$> filter (not . sel4) tuples) + let sampTup = + tupE $ + tuples + <&> ( \(_, _, _fldTyp, _isMaybeFldTyp, _mFldSamp, _) -> + case _mFldSamp of + Nothing -> sigE (varE 'def) (pure _fldTyp) + Just _fldSamp -> sigE (appE (varE 'read) (stringE _fldSamp)) (pure _fldTyp) + ) + let samp = appE (appE (varE 'uncurryN) (conE name)) sampTup + let u4 = uInfixE (varE 'example) (varE '(L.?~)) (appE (varE 'toJSON) samp) + let pureStmt = + noBindS + ( appE + (varE 'return) + ( appE + (appE (varE 'named) (stringE typName)) + (uInfixE (uInfixE (uInfixE (uInfixE (varE 'mempty) (varE '(F.&)) u1) (varE '(F.&)) u2) (varE '(F.&)) u3) (varE '(F.&)) u4) + ) + ) + pure <$> instanceD (pure preds) (appT (conT ''ToSchema) (pure (typWithVars typName _fldExtVars))) [funD 'O.declareNamedSchema [clause [wildP] (normalB (doE $ bindStmts <> [pureStmt])) []]] + +decOpaleye :: TediousTyp -> Q [Dec] +decOpaleye (TediousTyp (Combo basTypName mTblInfo _) flds) = evalContT $ do + callCC $ \exit -> do + let funbasTypName = lowerFirst basTypName <> "Table" + let tblFlds = repOpaleye flds + when (null tblFlds) $ exit mempty + let wTyps = (`strToTyp` False) . sel3 <$> tblFlds + let wFlds = genSigFields wTyps Nothing + let vTyps = (`strToTyp` False) . sel4 <$> tblFlds + let vFlds = genSigFields vTyps Nothing + sig <- lift $ sigD (mkName funbasTypName) (appT (appT (conT ''Table) wFlds) vFlds) + let nFlds = sel1 <$> tblFlds + let eFlds = appE (varE 'tableField) . litE . stringL <$> nFlds + fun <- + lift $ + funD + (mkName funbasTypName) + [ clause + [] + ( normalB + ( appE + (appTable basTypName mTblInfo) + (appE (varE (mkName $ "p" <> (show . length $ nFlds))) (genFunFields eFlds)) + ) + ) + [] + ] + return [sig, fun] + where + genSigFields (t : ts) Nothing = genSigFields ts (Just $ if null ts then t else AppT (TupleT $ length ts + 1) t) + genSigFields (t : ts) (Just t') = genSigFields ts (Just (AppT t' t)) + genSigFields [] (Just t') = return t' + genSigFields [] Nothing = return $ ConT ''() + genFunFields es | length es > 1 = tupE es + genFunFields [e] = parensE e + genFunFields _ = fail "makeTable : empty flds" + appTable basTypName_ mTblInfo_ = case mTblInfo_ of + Nothing -> appE (varE 'table) (litE (stringL basTypName_)) + Just (TblInfoQualified tblSchema_ tblName_) -> appE (appE (varE 'tableWithSchema) (litE (stringL tblSchema_))) (litE (stringL tblName_)) + Just (TblInfoUnQualified tblName_) -> appE (varE 'table) (litE (stringL tblName_)) + +decPersist :: [TediousTyp] -> Q [Dec] +decPersist tts = do + let unboundEntityDefs = unlines $ mapMaybe (strPersistTyp . repPersistTyp) tts + let name_ = mkName "tediousPersistString" + sigD_ <- sigD name_ (conT ''String) + valD_ <- valD (varP name_) (normalB (litE (stringL unboundEntityDefs))) [] + pure [sigD_, valD_] + +strToTyp :: String -> Bool -> Type +strToTyp s m = + let ot = either (error "decTedious: cannot parse field type") id (parseType s) + in if m then AppT (ConT ''Maybe) ot else ot + +varToTyp :: String -> Bool -> Type +varToTyp s m = + let ot = VarT (mkName s) + in if m then AppT (ConT ''Maybe) ot else ot + +typWithVars :: TypName -> [FldExtVar] -> Type +typWithVars name = go (ConT (mkName name)) + where + go t [] = t + go t (var : vars) = go (AppT t (VarT (mkName var))) vars + +isMaybeTyp :: Type -> Bool +isMaybeTyp (AppT (ConT c) _) + | c == ''Maybe = True + | otherwise = False +isMaybeTyp _ = False + +isDataD :: Dec -> Bool +isDataD DataD {} = True +isDataD NewtypeD {} = True +isDataD _ = False + +fldSchemaName :: FldName -> String +fldSchemaName = ("schema" <>) . upperFirst + +-- + +{- +> :set -XTemplateHaskell +> $(stringE . show =<< reify ''Hello) +> parseTest pName "Hello" +-}
+ src/Tedious/Quasi.hs view
@@ -0,0 +1,15 @@+module Tedious.Quasi ( + tedious +) where + +import Tedious.Parser (decTedious) +import Language.Haskell.TH.Quote (QuasiQuoter (..)) + +tedious :: QuasiQuoter +tedious = + QuasiQuoter + { quoteExp = error "tedious cannot be used as exp", + quotePat = error "tedious cannot be used as pat", + quoteType = error "tedious cannot be used as type", + quoteDec = decTedious + }
+ src/Tedious/Tutorial.hs view
@@ -0,0 +1,46 @@+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 +-} +
+ src/Tedious/Util.hs view
@@ -0,0 +1,33 @@+module Tedious.Util + ( upperFirst, + lowerFirst, + trimPrefixName, + trimPrefixName_, + toJSONOptions, + schemaOptions + ) +where + +import Control.Lens (Ixed (..), (%~)) +import Data.Char (toLower, toUpper) +import Data.Aeson (Options, defaultOptions) +import qualified Data.Aeson as A +import Data.OpenApi (fromAesonOptions, SchemaOptions) + +upperFirst :: String -> String +upperFirst = ix 0 %~ toUpper + +lowerFirst :: String -> String +lowerFirst = ix 0 %~ toLower + +trimPrefixName :: String -> String -> String +trimPrefixName name = lowerFirst . drop (length name) + +trimPrefixName_ :: String -> String -> String +trimPrefixName_ name = lowerFirst . drop 1 . drop (length name) + +toJSONOptions :: Options +toJSONOptions = defaultOptions {A.allNullaryToStringTag = False, A.sumEncoding = A.UntaggedValue, A.constructorTagModifier = map toLower, A.fieldLabelModifier = drop 1, A.omitNothingFields = True} + +schemaOptions :: SchemaOptions +schemaOptions = fromAesonOptions toJSONOptions
+ tedious-web.cabal view
@@ -0,0 +1,189 @@+cabal-version: 2.2+name: tedious-web+version: 0.2.1.2+license: BSD-3-Clause+license-file: LICENSE+copyright: 2024 WonderBear+maintainer: ximengwuheng@163.com+author: WonderBear+homepage: https://github.com/xiongxiong/tedious-web#readme+bug-reports: https://github.com/xiongxiong/tedious-web/issues+synopsis: Easily define multiple interrelated data types+description:+ A user-friendly web development tool that can easily define multiple interrelated data types++category: Web+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/xiongxiong/tedious-web++library+ exposed-modules:+ Tedious+ Tedious.Entity+ Tedious.Handler+ Tedious.Quasi+ Tedious.Tutorial+ Tedious.Util++ hs-source-dirs: src+ other-modules:+ Tedious.Orphan+ Tedious.Parser+ Paths_tedious_web++ autogen-modules: Paths_tedious_web+ default-language: Haskell2010+ default-extensions:+ DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies+ FlexibleContexts FlexibleInstances GADTs ImportQualifiedPost+ InstanceSigs LambdaCase MultiWayIf NamedFieldPuns OverloadedLabels+ OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables+ TemplateHaskell TypeApplications TypeFamilies TypeOperators+ ViewPatterns++ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wmissing-export-lists+ -Wmissing-home-modules -Wno-orphans -Wpartial-fields+ -Wredundant-constraints++ build-depends:+ aeson >=2.1.2.1 && <2.2,+ base >=4.7 && <5,+ data-default >=0.7.1.1 && <0.8,+ data-default-instances-containers >=0.0.1 && <0.1,+ effectful-core >=2.3.0.1 && <2.4,+ extra >=1.7.14 && <1.8,+ generic-lens >=2.2.2.0 && <2.3,+ haskell-src-meta >=0.8.13 && <0.9,+ http-types >=0.12.4 && <0.13,+ insert-ordered-containers >=0.2.5.3 && <0.3,+ lens >=5.2.3 && <5.3,+ megaparsec >=9.5.0 && <9.6,+ mtl >=2.3.1 && <2.4,+ opaleye >=0.10.3.0 && <0.11,+ openapi3 >=3.2.4 && <3.3,+ persistent >=2.14.6.1 && <2.15,+ postgresql-simple >=0.7.0.0 && <0.8,+ product-profunctors >=0.11.1.1 && <0.12,+ profunctors >=5.6.2 && <5.7,+ resource-pool >=0.4.0.0 && <0.5,+ tagged >=0.8.8 && <0.9,+ template-haskell >=2.20.0.0 && <2.21,+ text >=2.0.2 && <2.1,+ time >=1.12.2 && <1.13,+ tuple >=0.3.0.2 && <0.4,+ unordered-containers >=0.2.20 && <0.3,+ webgear-core >=1.3.0 && <1.4++executable tedious-web-exe+ main-is: Main.hs+ hs-source-dirs: app+ other-modules:+ Lib+ Paths_tedious_web++ autogen-modules: Paths_tedious_web+ default-language: Haskell2010+ default-extensions:+ DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies+ FlexibleContexts FlexibleInstances GADTs ImportQualifiedPost+ InstanceSigs LambdaCase MultiWayIf NamedFieldPuns OverloadedLabels+ OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables+ TemplateHaskell TypeApplications TypeFamilies TypeOperators+ ViewPatterns++ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wmissing-export-lists+ -Wmissing-home-modules -Wno-orphans -Wpartial-fields+ -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N++ build-depends:+ aeson >=2.1.2.1 && <2.2,+ base >=4.7 && <5,+ data-default >=0.7.1.1 && <0.8,+ data-default-instances-containers >=0.0.1 && <0.1,+ effectful-core >=2.3.0.1 && <2.4,+ extra >=1.7.14 && <1.8,+ generic-lens >=2.2.2.0 && <2.3,+ haskell-src-meta >=0.8.13 && <0.9,+ http-types >=0.12.4 && <0.13,+ insert-ordered-containers >=0.2.5.3 && <0.3,+ lens >=5.2.3 && <5.3,+ megaparsec >=9.5.0 && <9.6,+ mtl >=2.3.1 && <2.4,+ opaleye >=0.10.3.0 && <0.11,+ openapi3 >=3.2.4 && <3.3,+ persistent >=2.14.6.1 && <2.15,+ postgresql-simple >=0.7.0.0 && <0.8,+ product-profunctors >=0.11.1.1 && <0.12,+ profunctors >=5.6.2 && <5.7,+ raw-strings-qq >=1.1 && <1.2,+ resource-pool >=0.4.0.0 && <0.5,+ tagged >=0.8.8 && <0.9,+ tedious-web,+ template-haskell >=2.20.0.0 && <2.21,+ text >=2.0.2 && <2.1,+ time >=1.12.2 && <1.13,+ tuple >=0.3.0.2 && <0.4,+ unordered-containers >=0.2.20 && <0.3,+ webgear-core >=1.3.0 && <1.4++test-suite tedious-web-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test+ other-modules: Paths_tedious_web+ autogen-modules: Paths_tedious_web+ default-language: Haskell2010+ default-extensions:+ DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies+ FlexibleContexts FlexibleInstances GADTs ImportQualifiedPost+ InstanceSigs LambdaCase MultiWayIf NamedFieldPuns OverloadedLabels+ OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables+ TemplateHaskell TypeApplications TypeFamilies TypeOperators+ ViewPatterns++ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wmissing-export-lists+ -Wmissing-home-modules -Wno-orphans -Wpartial-fields+ -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N++ build-depends:+ aeson >=2.1.2.1 && <2.2,+ base >=4.7 && <5,+ data-default >=0.7.1.1 && <0.8,+ data-default-instances-containers >=0.0.1 && <0.1,+ effectful-core >=2.3.0.1 && <2.4,+ extra >=1.7.14 && <1.8,+ generic-lens >=2.2.2.0 && <2.3,+ haskell-src-meta >=0.8.13 && <0.9,+ hspec >=2.11.8 && <2.12,+ http-types >=0.12.4 && <0.13,+ insert-ordered-containers >=0.2.5.3 && <0.3,+ lens >=5.2.3 && <5.3,+ megaparsec >=9.5.0 && <9.6,+ mtl >=2.3.1 && <2.4,+ opaleye >=0.10.3.0 && <0.11,+ openapi3 >=3.2.4 && <3.3,+ persistent >=2.14.6.1 && <2.15,+ postgresql-simple >=0.7.0.0 && <0.8,+ product-profunctors >=0.11.1.1 && <0.12,+ profunctors >=5.6.2 && <5.7,+ resource-pool >=0.4.0.0 && <0.5,+ tagged >=0.8.8 && <0.9,+ tedious-web,+ template-haskell >=2.20.0.0 && <2.21,+ text >=2.0.2 && <2.1,+ time >=1.12.2 && <1.13,+ tuple >=0.3.0.2 && <0.4,+ unordered-containers >=0.2.20 && <0.3,+ webgear-core >=1.3.0 && <1.4
+ test/Spec.hs view
@@ -0,0 +1,134 @@+import Tedious.Parser+import Test.Hspec+import Text.Megaparsec (parse)++main :: IO ()+main = hspec tests++tests :: Spec+tests = describe "Tedious.Parser" $ do+ it "pCombo should work" $ do+ parse pCombo "" "Dog"+ `shouldBe` Right (Combo "Dog" Nothing Nothing)+ parse pCombo "" "Dog table dog"+ `shouldBe` Right (Combo "Dog" (Just (TblInfoUnQualified "dog")) Nothing)+ parse pCombo "" "Dog table (public, dog)"+ `shouldBe` Right (Combo "Dog" (Just (TblInfoQualified "public" "dog")) Nothing)+ parse pCombo "" "Dog deriving Show Eq"+ `shouldBe` Right (Combo "Dog" Nothing (Just ["Show", "Eq"]))+ parse pCombo "" "Dog table dog deriving Show Eq"+ `shouldBe` Right (Combo "Dog" (Just (TblInfoUnQualified "dog")) (Just ["Show", "Eq"]))+ parse pCombo "" "Dog table (public, dog) deriving Show Eq"+ `shouldBe` Right (Combo "Dog" (Just (TblInfoQualified "public" "dog")) (Just ["Show", "Eq"]))+ parse pCombo "" "Dog table dog deriving Show Eq"+ `shouldBe` Right (Combo "Dog" (Just (TblInfoUnQualified "dog")) (Just ["Show", "Eq"]))+ parse pCombo "" "Dog deriving Show Eq table dog"+ `shouldBe` Right (Combo "Dog" (Just (TblInfoUnQualified "dog")) (Just ["Show", "Eq"]))+ it "pFldTypS should work" $ do+ parse pFldTypS "" "Text"+ `shouldBe` Right "Text"+ parse pFldTypS "" "(Text)"+ `shouldBe` Right "(Text)"+ parse pFldTypS "" "(Text, Int)"+ `shouldBe` Right "(Text, Int)"+ parse pFldTypS "" "(Text, (Text, Int))"+ `shouldBe` Right "(Text, (Text, Int))"+ parse pFldTypS "" "[Text]"+ `shouldBe` Right "[Text]"+ parse pFldTypS "" "Maybe Text"+ `shouldBe` Right "Maybe Text"+ parse pFldTypS "" "Maybe [Text]"+ `shouldBe` Right "Maybe [Text]"+ parse pFldTypS "" "Maybe (Maybe [Int])"+ `shouldBe` Right "Maybe (Maybe [Int])"+ it "pOccur should work" $ do+ parse (pOccur "?") "" ""+ `shouldBe` Right False+ parse (pOccur "?") "" "?"+ `shouldBe` Right True+ it "pFldTyp should work" $ do+ parse pFldTyp "" "a"+ `shouldBe` Right (FldTypPoly "a")+ parse pFldTyp "" "Text? `bing`"+ `shouldBe` Right (FldTypNormal "Text" True (Just "bing") Nothing)+ parse pFldTyp "" "Text `bing`"+ `shouldBe` Right (FldTypNormal "Text" False (Just "bing") Nothing)+ parse pFldTyp "" "(Text)"+ `shouldBe` Right (FldTypNormal "Text" False Nothing Nothing)+ parse pFldTyp "" "[Text]?"+ `shouldBe` Right (FldTypNormal "[Text]" True Nothing Nothing)+ parse pFldTyp "" "((Text, Text))"+ `shouldBe` Right (FldTypNormal "(Text, Text)" False Nothing Nothing)+ parse pFldTyp "" "((Text, (Text, Maybe Text)))"+ `shouldBe` Right (FldTypNormal "(Text, (Text, Maybe Text))" False Nothing Nothing)+ parse pFldTyp "" "(Maybe Text)"+ `shouldBe` Right (FldTypNormal "Maybe Text" False Nothing Nothing)+ parse pFldTyp "" "(Maybe [Text])"+ `shouldBe` Right (FldTypNormal "Maybe [Text]" False Nothing Nothing)+ parse pFldTyp "" "(Maybe (Maybe [Int]))"+ `shouldBe` Right (FldTypNormal "Maybe (Maybe [Int])" False Nothing Nothing)+ it "pTblFld should work" $ do+ parse pTblFld "" "(Field SqlInt8)"+ `shouldBe` Right (TblFld (TblFldOR "Field SqlInt8") False [] Nothing)+ parse pTblFld "" "(Field SqlInt8, Field SqlInt8)"+ `shouldBe` Right (TblFld (TblFldOWR "Field SqlInt8" "Field SqlInt8") False [] Nothing)+ parse pTblFld "" "(\"name\", Field SqlInt8)"+ `shouldBe` Right (TblFld (TblFldONR "name" "Field SqlInt8") False [] Nothing)+ parse pTblFld "" "(\"name\", Field SqlInt8, Field SqlInt8)"+ `shouldBe` Right (TblFld (TblFldONWR "name" "Field SqlInt8" "Field SqlInt8") False [] Nothing)+ parse pTblFld "" "(Field SqlInt8)#"+ `shouldBe` Right (TblFld (TblFldOR "Field SqlInt8") True [] Nothing)+ parse pTblFld "" "(Field SqlInt8)# default=`3`"+ `shouldBe` Right (TblFld (TblFldOR "Field SqlInt8") True [] (Just "3"))+ parse pTblFld "" "(Field SqlInt8)# !UniqueOne"+ `shouldBe` Right (TblFld (TblFldOR "Field SqlInt8") True ["UniqueOne"] Nothing)+ parse pTblFld "" "(Field SqlInt8)# !UniqueOne !UniqueTwo"+ `shouldBe` Right (TblFld (TblFldOR "Field SqlInt8") True ["UniqueOne", "UniqueTwo"] Nothing)+ parse pTblFld "" "(Field SqlInt8) !UniqueOne !UniqueTwo"+ `shouldBe` Right (TblFld (TblFldOR "Field SqlInt8") False ["UniqueOne", "UniqueTwo"] Nothing)+ parse pTblFld "" "(Field SqlInt8)# !UniqueOne !UniqueTwo default=`3`"+ `shouldBe` Right (TblFld (TblFldOR "Field SqlInt8") True ["UniqueOne", "UniqueTwo"] (Just "3"))+ parse pTblFld "" "(Field SqlInt8) default=`3`"+ `shouldBe` Right (TblFld (TblFldOR "Field SqlInt8") False [] (Just "3"))+ it "pField should work" $ do+ parse pField "" "firstName `first name` Text `Wang` (\"first_name\", Field SqlText) !UniqueDog !UniqueDogMaster DogA DogC"+ `shouldBe` Right (Field ("firstName", Just "first name") (FldTypNormal "Text" False (Just "Wang") (Just (TblFld (TblFldONR "first_name" "Field SqlText") False ["UniqueDog", "UniqueDogMaster"] Nothing))) [ExtTypNormal "DogA" False, ExtTypNormal "DogC" False])+ parse pField "" "color `dog's color` ((Text, Text, Text)) DogB DogC"+ `shouldBe` Right (Field ("color", Just "dog's color") (FldTypNormal "(Text, Text, Text)" False Nothing Nothing) [ExtTypNormal "DogB" False, ExtTypNormal "DogC" False])+ it "repPersistTyp should work" $ do+ repPersistTyp (TediousTyp (Combo "Dog" Nothing Nothing) [Field ("name", Nothing) (FldTypNormal "Text" False Nothing (Just (TblFld (TblFldOR "Field SqlInt8") True ["One"] (Just "'dog'")))) []])+ `shouldBe` ("Dog", TblPrimary ["name"], [TblUnique "One" ["name"]], [("name", "Text", False, Just "'dog'")])+ repPersistTyp+ ( TediousTyp+ (Combo "Dog" Nothing Nothing)+ [ Field ("name", Nothing) (FldTypNormal "Text" False Nothing (Just (TblFld (TblFldOR "Field SqlInt8") True ["One"] (Just "'dog'")))) [],+ Field ("work", Nothing) (FldTypNormal "Text" False Nothing (Just (TblFld (TblFldOR "Field SqlInt8") True ["One"] (Just "'work'")))) []+ ]+ )+ `shouldBe` ( "Dog",+ TblPrimary ["name", "work"],+ [TblUnique "One" ["name", "work"]],+ [ ("name", "Text", False, Just "'dog'"),+ ("work", "Text", False, Just "'work'")+ ]+ )+ it "strPersistTyp should work" $ do+ strPersistTyp ("Dog", TblPrimary ["name"], [TblUnique "One" ["name"]], [("name", "Text", False, Just "'dog'")])+ `shouldBe` Just "Dog\n\tname Text default='dog'\n\tPrimary name\n\tUniqueOne name\n"+ strPersistTyp ( "Dog",+ TblPrimary ["name", "work"],+ [TblUnique "One" ["name", "work"]],+ [ ("name", "Text", False, Just "'dog'"),+ ("work", "Text", False, Just "'work'")+ ]+ )+ `shouldBe` Just "Dog\n\tname Text default='dog'\n\twork Text default='work'\n\tPrimary name work\n\tUniqueOne name work\n"+ strPersistTyp ( "Dog",+ TblPrimary ["name", "work"],+ [TblUnique "One" ["name", "work"], TblUnique "Two" ["work", "data"]],+ [ ("name", "Text", False, Just "'dog'"),+ ("work", "Text", False, Just "'work'"),+ ("data", "Text", False, Just "'data'")+ ]+ )+ `shouldBe` Just "Dog\n\tname Text default='dog'\n\twork Text default='work'\n\tdata Text default='data'\n\tPrimary name work\n\tUniqueOne name work\n\tUniqueTwo work data\n"