1 {-# LANGUAGE TemplateHaskell, OverloadedStrings #-} 2 module Databrary.Model.AssetSegment.SQL 3 ( excerptRow 4 , makeExcerpt 5 , selectAssetSegment 6 , selectContainerAssetSegment 7 -- , selectAssetAssetSegment 8 ) where 9 10 import Data.Maybe (fromMaybe) 11 import qualified Language.Haskell.TH as TH 12 13 import Databrary.Model.SQL.Select 14 import Databrary.Model.Release.Types 15 import Databrary.Model.Segment 16 import Databrary.Model.Volume.Types 17 import Databrary.Model.Volume.SQL 18 import Databrary.Model.Container.Types 19 import Databrary.Model.Container.SQL 20 import Databrary.Model.Asset.Types 21 import Databrary.Model.Asset.SQL 22 import Databrary.Model.AssetSlot.Types 23 import Databrary.Model.AssetSlot.SQL 24 import Databrary.Model.AssetSegment.Types 25 26 excerptTuple :: Segment -> Maybe Release -> (Segment, Maybe Release) 27 excerptTuple = (,) 28 29 excerptRow :: Selector -- ^ @('Segment', Maybe 'Release')@ 30 excerptRow = selectColumns 'excerptTuple "excerpt" ["segment", "release"] 31 32 makeExcerpt :: AssetSlot -> Segment -> Maybe (Segment, Maybe Release) -> AssetSegment 33 makeExcerpt a s = newAssetSegment a s . fmap (uncurry $ newExcerpt a) 34 35 makeAssetSegment :: Segment -> Maybe Segment -> Maybe (Segment, Maybe Release) -> Asset -> Container -> AssetSegment 36 makeAssetSegment as ss e a c = makeExcerpt sa ss' e where 37 sa = makeSlotAsset a c as 38 ss' = fromMaybe emptySegment ss -- should not happen 39 40 selectAssetContainerAssetSegment :: TH.Name -- ^ @'Segment'@ 41 -> Selector -- ^ @'Asset' -> 'Container' -> 'AssetSegment'@ 42 selectAssetContainerAssetSegment seg = selectJoin 'makeAssetSegment 43 [ slotAssetRow 44 , crossJoin 45 $ selector ("LATERAL (VALUES (slot_asset.segment * ${" ++ nameRef seg ++ "})) AS asset_segment (segment)") 46 $ SelectColumn "asset_segment" "segment" 47 -- asset_segment.segment <@ excerpt.segment == the range of the segment is contained in the range of the excerpt 48 , maybeJoinOn "slot_asset.asset = excerpt.asset AND asset_segment.segment <@ excerpt.segment" 49 excerptRow 50 ] 51 52 makeContainerAssetSegment :: (Asset -> Container -> AssetSegment) -> AssetRow -> Container -> AssetSegment 53 makeContainerAssetSegment f ar c = f (Asset ar $ containerVolume c) c 54 55 selectContainerAssetSegment :: TH.Name -- ^ @'Segment'@ 56 -> Selector -- ^ @'Container' -> 'AssetSegment'@ 57 selectContainerAssetSegment seg = selectJoin 'makeContainerAssetSegment 58 [ selectAssetContainerAssetSegment seg 59 , joinOn "slot_asset.asset = asset.id" 60 selectAssetRow -- XXX volumes match? 61 ] 62 63 {- 64 makeAssetAssetSegment :: (Asset -> Container -> AssetSegment) -> (Volume -> Container) -> Asset -> AssetSegment 65 makeAssetAssetSegment f cf a = f a (cf (assetVolume a)) 66 67 selectAssetAssetSegment :: TH.Name -- ^ @'Segment'@ 68 -> Selector -- ^ @'Container' -> 'AssetSegment'@ 69 selectAssetAssetSegment seg = selectJoin 'makeAssetAssetSegment 70 [ selectAssetContainerAssetSegment seg 71 , joinOn "slot_asset.container = container.id" 72 selectVolumeContainer -- XXX volumes match? 73 ] 74 -} 75 76 makeVolumeAssetSegment :: (Asset -> Container -> AssetSegment) -> AssetRow -> (Volume -> Container) -> Volume -> AssetSegment 77 makeVolumeAssetSegment f ar cf v = f (Asset ar v) (cf v) 78 79 selectVolumeAssetSegment :: TH.Name -- ^ @'Segment'@ 80 -> Selector -- ^ @'Volume' -> 'AssetSegment'@ 81 selectVolumeAssetSegment seg = selectJoin 'makeVolumeAssetSegment 82 [ selectAssetContainerAssetSegment seg 83 , joinOn "slot_asset.asset = asset.id" 84 selectAssetRow 85 , joinOn "slot_asset.container = container.id AND asset.volume = container.volume" 86 selectVolumeContainer 87 ] 88 89 selectAssetSegment :: TH.Name -- ^ @'Identity'@ 90 -> TH.Name -- ^ @'Segment'@ 91 -> Selector -- ^ @'AssetSegment'@ 92 selectAssetSegment ident seg = selectJoin '($) 93 [ selectVolumeAssetSegment seg 94 , joinOn "asset.volume = volume.id" 95 $ selectVolume ident 96 ]