src/Rel8/Table/Name.hs · rel8

on f0744d2 help sign in

55 lines 1.5 kB history raw

1{-# language FlexibleContexts #-}

2{-# language NamedFieldPuns #-}

3{-# language ScopedTypeVariables #-}

4{-# language TypeApplications #-}

5{-# language TypeFamilies #-}

6{-# language ViewPatterns #-}

8module Rel8.Table.Name

9 ( namesFromLabels

10 , namesFromLabelsWith

11 , showLabels

12 , showNames

13 )

14where

16-- base

17import Data.Foldable ( fold )

18import Data.Functor.Const ( Const( Const ), getConst )

19import Data.List.NonEmpty ( NonEmpty, intersperse )

20import Prelude

22-- casing

23import Text.Casing ( quietSnake )

25-- rel8

26import Rel8.Kind.Labels ( renderLabels )

27import Rel8.Schema.Context ( Name( Name ) )

28import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )

29import Rel8.Schema.Spec ( SSpec(..) )

30import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )

33namesFromLabels :: Table Name a => a

34namesFromLabels = namesFromLabelsWith go

35 where

36 go = fold . intersperse "/" . fmap quietSnake

39namesFromLabelsWith :: Table Name a

40 => (NonEmpty String -> String) -> a

41namesFromLabelsWith f = fromColumns $ htabulate $ \field ->

42 case hfield hspecs field of

43 SSpec {labels} -> Name (f (renderLabels labels))

46showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]

47showLabels _ = getConst $

48 htabulateA @(Columns a) $ \field -> case hfield hspecs field of

49 SSpec {labels} -> Const [renderLabels labels]

52showNames :: forall a. Table Name a => a -> [String]

53showNames (toColumns -> names) = getConst $

54 htabulateA @(Columns a) $ \field -> case hfield names field of

55 Name name -> Const [name]