summaryrefslogtreecommitdiff
path: root/src/Data/DocRecord/OptParse.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Data/DocRecord/OptParse.hs')
-rw-r--r--src/Data/DocRecord/OptParse.hs156
1 files changed, 156 insertions, 0 deletions
diff --git a/src/Data/DocRecord/OptParse.hs b/src/Data/DocRecord/OptParse.hs
new file mode 100644
index 0000000..5384895
--- /dev/null
+++ b/src/Data/DocRecord/OptParse.hs
@@ -0,0 +1,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