summaryrefslogtreecommitdiff
path: root/src/Data/DocRecord/OptParse.hs
blob: 53848957f7a89527173e93790e926f887012362f (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}

module Data.DocRecord.OptParse
  (RecFromCLI(..), FieldFromCLI
  ,RecordUsableWithCLI
  ,SourceTag(..)
  ,SourcedDocField
  ,rmTags,tagWithDefaultSource,tagWithYamlSource

  ,parseRecFromCLI
  )
where

import           Control.Lens
import           Data.Bifunctor      (first)
import           Data.DocRecord
import qualified Data.HashMap.Strict as HM
import qualified Data.Text           as T
import           Data.Text.Encoding  (decodeUtf8, encodeUtf8)
import qualified Data.Vinyl.Functor  as F
import           Data.Yaml           (FromJSON, ToJSON)
import qualified Data.Yaml           as Y
import           GHC.TypeLits        (Symbol)
import           Options.Applicative


data Marker = Flag | Regular | None

type family MarkerOf a where
  MarkerOf MD   = None
  MarkerOf Bool = Flag
  MarkerOf a    = Regular

-- | Identifies the source of a value in the configuration, so that we can be
-- sure to override the right values with the right values.
--
-- The Ord instance makes it so CLI overrides YAML and YAML overrides Default.
data SourceTag = Default | YAML | CLI
  deriving (Eq, Ord, Show)

instance Monoid SourceTag where
  mempty = Default

instance Semigroup SourceTag where
  a <> b = if a > b then a else b

instance NamedFieldTag SourceTag where
  defaultTag = Default
  tagFromDoc _ = Default

-- | A DocField with a Source tag attached
type SourcedDocField = Tagged SourceTag `F.Compose` DocField

rmTags :: (RMap r) => Rec SourcedDocField r -> Rec DocField r
rmTags r = (\(F.Compose (Tagged _ x)) -> x) <<$>> r

tagWithDefaultSource :: (RMap rs) => Rec DocField rs -> Rec SourcedDocField rs
tagWithDefaultSource r = F.Compose . Tagged Default <<$>> r

tagWithYamlSource :: (RMap rs) => Rec DocField rs -> Rec SourcedDocField rs
tagWithYamlSource r = F.Compose . Tagged YAML <<$>> r


-- | Is satisfied when every field of a 'DocRec' @rs@ is transformable from & to
-- JSON and gettable from the CLI.
type RecordUsableWithCLI rs =
  ( RecFromCLI (Rec (Tagged SourceTag `F.Compose` DocField) rs)
  , ToJSONFields rs, FromJSON (Rec PossiblyEmptyField rs)
  , RMap rs, RApply rs )

class (FromJSON (Snd r), m ~ MarkerOf (Snd r)) => FieldFromCLI_ m r where
  fieldFromCLI
    :: (NamedField f, FieldWithTag T.Text f, FieldWithTag SourceTag f)
    => String
    -> f r
    -> Parser (f r)

instance (FromJSON a, ToJSON a, MarkerOf a ~ Regular, ShowPath s) => FieldFromCLI_ Regular (s:|:a) where
  fieldFromCLI flagName field =
    option reader
     (  long flagName
     <> help (T.unpack $ field^.fieldTag)
     <> case field^.rfield of
          Nothing -> mempty
          Just x  -> value field <> showDefaultWith (const $ showJson x))
    where
      reader = eitherReader $ \string -> do
        newVal <- first show <$> Y.decodeEither' . encodeUtf8 . T.pack $ string
        return $ field & rfield .~ Just newVal
                       & fieldTag .~ CLI
                         -- We set the source of the new value so this field has
                         -- a higher priority than the equivalent field coming
                         -- from the Yaml file
      showJson = T.unpack . decodeUtf8 . Y.encode

instance (ShowPath s) => FieldFromCLI_ Flag (s:|:Bool) where
  fieldFromCLI flagName field =
    flag defState flipState
        (  long (flagPrefix++flagName)
        <> help (docPrefix ++ (T.unpack $ field^.fieldTag)))
    where (isOn, (defState, flipState)) = case field^.rfield of
            Nothing  -> (False, states False)
            Just val -> (val, states val)
          states v = ( field & rfield .~ Just v  -- Default value. We keep the same value source.
                     , field & rfield .~ Just (not v)
                             & fieldTag .~ CLI -- Flipped value. We set the new
                                               -- value source.
                     )
          (flagPrefix, docPrefix) = if isOn then ("no-", "Deactivate: ") else ("", "")

instance (FromJSON a, MarkerOf a ~ None) => FieldFromCLI_ None (s:|:a) where
  fieldFromCLI _ _ = empty

type FieldFromCLI a = FieldFromCLI_ (MarkerOf (Snd a)) a

class RecFromCLI a where
  parseRecFromCLI_ :: HM.HashMap [T.Text] String -> a -> Parser a
  allPaths :: a -> [[T.Text]]

instance RecFromCLI (Rec (f :: PathWithType [Symbol] * -> *) '[]) where
  parseRecFromCLI_ _ _ = pure RNil
  allPaths _           = []

instance (NamedField f, FieldWithTag T.Text f, FieldWithTag SourceTag f
         , FieldFromCLI (s:|:t), RecFromCLI (Rec f rs), ShowPath s)
  => RecFromCLI (Rec f ((s:|:t) ': rs)) where
  parseRecFromCLI_ fieldNames (f1 :& rest) = (:&)
    <$> (   fieldFromCLI (fieldNames HM.! fieldPathList f1) f1
        <|> pure f1 )
    <*> parseRecFromCLI_ fieldNames rest
  allPaths (f1 :& rest) = fieldPathList f1 : allPaths rest

parseRecFromCLI
  :: forall (rs :: [PathWithType [Symbol] *]) f. (RecFromCLI (Rec f rs))
  => Rec f rs -> Parser (Rec f rs)
parseRecFromCLI defaultRec = parseRecFromCLI_ disambMap defaultRec
  where
    disambMap = HM.fromList $ concatMap (disambOn 1) $ ambiguousOn 1 $ allPaths defaultRec
    nameOn n = reverse . take n . reverse
    ambiguousOn n paths =
      HM.elems $ HM.fromListWith (++) $
        map (\p -> (nameOn n p, [p])) paths
    disambOn n [uniq] = [(uniq, T.unpack $ T.intercalate (T.pack "-") $ nameOn n uniq)]
    disambOn n ps     = concatMap (disambOn (n+1)) $ ambiguousOn (n+1) ps