chore(pandoc): add more tests
This commit is contained in:
Steffen Jost
commit
e63a3af926
@ -172,9 +172,8 @@ pjTableQuery (printJob `E.LeftOuterJoin` recipient
|
||||
E.on $ printJob E.^. PrintJobQualification E.==. quali E.?. QualificationId
|
||||
return (printJob, recipient, sender, course, quali)
|
||||
|
||||
mkPJTable :: DB (FormResult (PJTableAction, Set PrintJobId), Widget)
|
||||
mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget)
|
||||
mkPJTable = do
|
||||
now <- liftIO getCurrentTime
|
||||
currentRoute <- fromMaybe (error "mkPJTable called from 404-handler") <$> liftHandler getCurrentRoute -- albeit we do know the route here
|
||||
let
|
||||
dbtSQLQuery = pjTableQuery
|
||||
@ -183,11 +182,11 @@ mkPJTable = do
|
||||
dbtColonnade = mconcat
|
||||
[ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^? resultPrintJob . _entityVal . _printJobAcknowledged)
|
||||
, sortable (Just "pj-name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n
|
||||
, sortable (Just "pj-id") (i18nCell MsgPrintJobId) $ \( view $ resultPrintJob . _entityKey -> k) -> numCell k
|
||||
, sortable (Just "pj-id") (i18nCell MsgPrintJobId) $ \( view $ resultPrintJob . _entityKey -> k) -> textCell (tshow k)
|
||||
, sortable (Just "pj-created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t
|
||||
, sortable (Just "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t
|
||||
, sortable (Just "pj-recipient") (i18nCell MsgPrintRecipient) $ \(preview $ resultRecipient . _entityVal -> u) -> maybeCell u $ cellHasUserLink AdminUserR
|
||||
, sortable (Just "pj-sender") (i18nCell MsgPrintSender) $ \(preview $ resultSender . _entityVal -> u) -> maybeCell u $ cellHasUserLink AdminUserR
|
||||
, sortable (Just "pj-recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
|
||||
, sortable (Just "pj-sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR
|
||||
, sortable (Just "pj-course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell
|
||||
, sortable (Just "pj-qualification")(i18nCell MsgPrintQualification) $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell
|
||||
]
|
||||
@ -233,8 +232,8 @@ mkPJTable = do
|
||||
, dbParamsFormResult = id
|
||||
, dbParamsFormIdent = def
|
||||
}
|
||||
postprocess :: FormResult (First PJTableAction, DBFormResult PrintJobId Bool PJTableData)
|
||||
-> FormResult ( PJTableAction, Set PrintJobId)
|
||||
postprocess :: FormResult (First PJTableActionData, DBFormResult PrintJobId Bool PJTableData)
|
||||
-> FormResult ( PJTableActionData, Set PrintJobId)
|
||||
postprocess inp = do
|
||||
(First (Just act), jobMap) <- inp
|
||||
let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
|
||||
@ -245,13 +244,11 @@ getPrintCenterR, postPrintCenterR :: Handler Html
|
||||
getPrintCenterR = postPrintCenterR
|
||||
postPrintCenterR = do
|
||||
_currentRoute <- fromMaybe (error "printCenterR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
|
||||
(_pjRes, _pjTable) <- runDB $ do
|
||||
let _acts :: Map PJTableAction (AForm Handler PJTableActionData)
|
||||
_acts = mconcat
|
||||
[ singletonMap PJActAcknowledge $ pure PJActAcknowledgeData
|
||||
]
|
||||
error "TODO: continue here"
|
||||
(_pjRes, _pjTable) <- runDB mkPJTable
|
||||
-- actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
|
||||
-- TODO: continue here
|
||||
-- formResult pjRes $ \case
|
||||
-- (PJActAcknowledgeData, pjIds) -> error "continue here"
|
||||
siteLayoutMsg MsgMenuApc $ do
|
||||
setTitleI MsgMenuApc
|
||||
$(widgetFile "print-center")
|
||||
|
||||
@ -55,18 +55,18 @@ makePDF wopts doc = do
|
||||
texopts = []
|
||||
bs2pandocError = over _Left (P.PandocMakePDFError . decodeUtf8 . LBS.toStrict)
|
||||
|
||||
-- | Modify the Meta-Block of Pandoc
|
||||
-- This could be a lens?
|
||||
appMeta :: (P.Meta -> P.Meta) -> P.Pandoc -> P.Pandoc
|
||||
appMeta f (P.Pandoc m bs) = P.Pandoc (f m) bs
|
||||
-- appMeta f = _Meta %~ f
|
||||
|
||||
_Meta :: Lens' P.Pandoc P.Meta
|
||||
_Meta = lens mg mp
|
||||
where
|
||||
mg (P.Pandoc m _) = m
|
||||
mp (P.Pandoc _ b) m = P.Pandoc m b
|
||||
|
||||
-- | Modify the Meta-Block of Pandoc
|
||||
appMeta :: (P.Meta -> P.Meta) -> P.Pandoc -> P.Pandoc
|
||||
appMeta f (P.Pandoc m bs) = P.Pandoc (f m) bs
|
||||
-- appMeta f = _Meta %~ f -- lens version. Not sure this is better
|
||||
|
||||
-- Add tests for applyMetas, if ever needed
|
||||
-- applyMetas :: (P.HasMeta p, Foldable t, P.ToMetaValue a) => t (Text, a) -> p -> p
|
||||
-- applyMetas metas doc = Fold.foldr (uncurry P.setMeta) doc metas
|
||||
|
||||
|
||||
@ -7,32 +7,36 @@ import Utils.Print
|
||||
import qualified Data.Map.Lazy as Map
|
||||
|
||||
import Text.Pandoc
|
||||
import Text.Pandoc.Arbitrary
|
||||
import Text.Pandoc.Arbitrary ()
|
||||
|
||||
-- For Lens Check _Meta required:
|
||||
--instance CoArbitrary Inline
|
||||
--instance CoArbitrary MetaValue
|
||||
--instance CoArbitrary Meta
|
||||
--instance Function Inline
|
||||
--instance Function MetaValue
|
||||
--instance Function Meta
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
spec = -- do
|
||||
describe "addMeta" $ do
|
||||
it "should overwrite existing settings" $ do
|
||||
metaOverwrite <- arbitrary
|
||||
pd <- arbitrary
|
||||
(metaOverwrite, pd) <- generate arbitrary
|
||||
let (Pandoc newMeta _) = addMeta metaOverwrite pd
|
||||
Map.toList newMeta `shouldContain` Map.toList metaOverwrite
|
||||
Map.toList (unMeta newMeta) `shouldContain` Map.toList (unMeta metaOverwrite)
|
||||
|
||||
it "should preserve untouched settings" $ do
|
||||
metaOverwrite <- arbitrary
|
||||
pd <- arbitrary
|
||||
(metaOverwrite, pd) <- generate arbitrary
|
||||
let
|
||||
(Pandoc keptMeta _) = pd
|
||||
(Pandoc newMeta _) = addMeta metaOverwrite pd
|
||||
Map.toList newMeta `shouldContain` Map.toList (keptMeta `Map.difference` metaOverwrite)
|
||||
|
||||
Map.toList (unMeta newMeta) `shouldContain` Map.toList (unMeta keptMeta `Map.difference` unMeta metaOverwrite)
|
||||
|
||||
it "should preserve document block" $ do
|
||||
metaOverwrite <- arbitrary
|
||||
pd <- arbitrary
|
||||
let
|
||||
(Pandoc _ oldBlocks) = pd
|
||||
(Pandoc - newBlocks) = addMeta metaOverwrite pd
|
||||
oldBlocks `shouldBe` newBlocks
|
||||
(metaOverwrite, pd) <- generate arbitrary
|
||||
let
|
||||
(Pandoc _ oldBlocks) = pd
|
||||
(Pandoc _ newBlocks) = addMeta metaOverwrite pd
|
||||
oldBlocks `shouldBe` newBlocks
|
||||
|
||||
describe "_Meta" . it "is a lens" . property $ isLens _Meta
|
||||
-- describe "_Meta" . it "is a lens" . property $ isLens _Meta
|
||||
Reference in New Issue
Block a user