summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorYvesPares <>2019-10-09 10:16:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-10-09 10:16:00 (GMT)
commit9068121cca98d841d9f254d60803b15a64270283 (patch)
tree65e50aff0b3ca90ed3b5e98a29449281547d469b
version 0.1.0.0HEAD0.1.0.0master
-rw-r--r--LICENSE21
-rw-r--r--docrecords.cabal72
-rw-r--r--src/Data/DocRecord.hs1006
-rw-r--r--src/Data/DocRecord/OptParse.hs156
-rw-r--r--test/DocTest.hs5
5 files changed, 1260 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..2b55c2c
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) 2018 Tweag I/O, NovaDiscovery
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE. \ No newline at end of file
diff --git a/docrecords.cabal b/docrecords.cabal
new file mode 100644
index 0000000..30bbac2
--- /dev/null
+++ b/docrecords.cabal
@@ -0,0 +1,72 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.32.0.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: b0bb83f0bd44ebb20879007dea8da366c5a1668a9a5d5d064664ed64ee55675d
+
+name: docrecords
+version: 0.1.0.0
+synopsis: Vinyl-based records with hierarchical field names, default values and documentation
+description: Implements the DocRec type, which is a record (in the vinyl sense) where each
+ field has an optional value and a docstring. The names of the fields are
+ type-level lists of Symbols, acting as paths. This makes docrecords
+ hierarchical. Addionally, we provide the code to read docrecords from JSON
+ files and derive CLI parsers to override the records read from
+ files. docrecords is part of the porcupine ecosystem. See the README at
+ <https://github.com/tweag/porcupine#README.md>
+category: Data, Records, JSON, CLI, Options, Parsing
+homepage: https://github.com/tweag/porcupine#readme
+bug-reports: https://github.com/tweag/porcupine/issues
+maintainer: Yves Parès <yves.pares@tweag.io>
+copyright: 2018 EURL Tweag, NovaDiscovery
+license: MIT
+license-file: LICENSE
+build-type: Simple
+
+source-repository head
+ type: git
+ location: https://github.com/tweag/porcupine
+
+library
+ exposed-modules:
+ Data.DocRecord
+ Data.DocRecord.OptParse
+ other-modules:
+ Paths_docrecords
+ hs-source-dirs:
+ src
+ ghc-options: -Wall
+ build-depends:
+ aeson
+ , base >=4.10 && <5
+ , data-default
+ , lens
+ , optparse-applicative
+ , text
+ , unordered-containers
+ , vinyl >=0.11
+ , yaml
+ default-language: Haskell2010
+
+test-suite doctest
+ type: exitcode-stdio-1.0
+ main-is: DocTest.hs
+ other-modules:
+ Paths_docrecords
+ hs-source-dirs:
+ test
+ ghc-options: -Wall
+ build-depends:
+ aeson
+ , base >=4.10 && <5
+ , data-default
+ , doctest
+ , lens
+ , optparse-applicative
+ , text
+ , unordered-containers
+ , vinyl >=0.11
+ , yaml
+ default-language: Haskell2010
diff --git a/src/Data/DocRecord.hs b/src/Data/DocRecord.hs
new file mode 100644
index 0000000..1ce4a01
--- /dev/null
+++ b/src/Data/DocRecord.hs
@@ -0,0 +1,1006 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -Wall #-}
+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- FIXME: shouldn't need this
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : "Data.DocRecord"
+--
+-- This modules provides extensible records where each field includes a
+-- documentation.
+--
+-----------------------------------------------------------------------------
+
+module Data.DocRecord
+ (
+ -- * Examples
+ -- $setup
+ -- * Re-Exports
+ module Data.Vinyl.Core
+ , module Data.Vinyl.Lens
+ , module Data.Vinyl.Derived
+ , module Data.Vinyl.Curry
+ , type (++)
+ , type AllFst, type AllSnd
+ -- * Types
+ , PathWithType(..)
+ , FieldWithTag, fieldTag
+ , Field(..)
+ , Tagged(..)
+ , WithDoc
+ , PossiblyEmpty(..)
+ , PossiblyEmptyField
+ , pattern PEField
+ , type DocField
+ , pattern DocField
+ , DocRec
+ , FieldTypes
+ , IdentityField
+ , NamedField(..)
+ , NamedFieldTag(..)
+ , MissingValueReason(..)
+ , IntermediaryLevel
+ , FlattenedLevel
+ , HasField, Includes, EquivalentTo
+ , type Difference, type Intersection
+ , ToJSONFields
+ , RecBijection(..)
+ , ShowPath(..)
+ , ApplyRec(..)
+ , MD(..)
+ , type Fst
+ , type Snd
+ -- * Utils
+ , removeDoc
+ , withoutDef
+ , getPossiblyEmpty
+ , chooseHighestPriority
+ , fld
+ , runcurryF
+ , runcurryAF
+ , docField
+ , itmLevel
+ , fieldPath
+ , fieldPathList
+ , fieldFromDef
+ , fieldNoDef
+ , singleton
+ , useDef
+ , fromJSONAs
+ , (^^.), (^^?), (^^?!), (%%~), (..~)
+ , renamedAs
+ , rsubset, rcast, rreplace
+ , rcastAs, rsplit, rsplitFrom, rdifference, rintersection
+ , PrefixPath(..), rinclude, (-.)
+ , rdrill
+ , rsplitDrill
+ , rfoldSubset
+ , funder
+ , runder
+ , (-/)
+ , withSameFields
+ , (&:)
+ , recFrom
+ , invertRecBij, (<<|>>), bijectField, bijectField', renameField, addConstField
+ , bijectUnder
+ , showDocumentation
+ ) where
+
+import Control.Applicative
+import qualified Control.Category as Cat
+import qualified Control.Lens as L
+import Data.Aeson
+import Data.Default
+import qualified Data.HashMap.Strict as HM
+import Data.Maybe (fromMaybe)
+import Data.Proxy
+import qualified Data.Text as T
+import Data.Typeable
+import Data.Vinyl.Core
+import Data.Vinyl.Curry
+import Data.Vinyl.Derived hiding (HasField, rfield, (=:))
+import qualified Data.Vinyl.Functor as F
+import Data.Vinyl.Lens (RElem, RSubset, rlens)
+import qualified Data.Vinyl.Lens as VL
+import Data.Vinyl.TypeLevel hiding (Fst, Snd)
+import GHC.Exts (Constraint)
+import GHC.TypeLits (ErrorMessage (..), KnownSymbol, Symbol,
+ TypeError, symbolVal)
+
+-- $setup
+-- Here is an example of use:
+--
+-- >>> :set -XDataKinds -XTypeApplications -XOverloadedStrings
+-- >>> import Data.Function ((&))
+-- >>> import qualified Data.Text.IO as T
+-- >>> import Data.Aeson (toJSON)
+-- >>> let age = docField @"age" @Int 12 "This is the field giving the age"
+-- >>> let size = docField @"size" @Double 130 "This is the field giving the size (in cm)"
+-- >>> let name = fieldNoDef @"name" @String "This is the field giving the name"
+-- >>> let defaultPerson = age :& name :& size :& RNil
+-- >>> let namedDefault = name ..~ "Bernard" $ defaultPerson
+-- >>> defaultPerson
+-- {age =: 12
+-- , name (empty: NoDefault)
+-- , size =: 130.0
+-- }
+--
+-- A DocRec can be serialized/deserialized to/from Json or Yaml.
+--
+-- >>> let j = toJSON namedDefault
+-- >>> j
+-- Object (fromList [("size",Number 130.0),("age",Number 12.0),("name",String "Bernard")])
+--
+-- >>> fromJSONAs defaultPerson j
+-- Success {age =: 12
+-- , name =: "Bernard"
+-- , size =: 130.0
+-- }
+
+-- | Explains why a fields contains no value
+data MissingValueReason = NoDefault | MissingValueInJSON
+ deriving (Show, Eq, Ord)
+
+-- | Wraps a field so that it can have no value
+newtype PossiblyEmpty a = PE (Either MissingValueReason a)
+ deriving (Functor, Applicative)
+
+instance (Eq a) => Eq (PossiblyEmpty a) where
+ PE (Right a) == PE (Right b) = a == b
+ PE (Left _) == PE (Left _) = True
+ _ == _ = False
+instance Ord a => Ord (PossiblyEmpty a) where
+ PE (Right a) `compare` PE (Right b) = a `compare` b
+ PE (Left _) `compare` PE (Left _) = EQ
+ _ `compare` _ = LT
+instance (Show (f (s:|:a)), ShowPath s)
+ => Show (PossiblyEmpty (f (s:|:a))) where
+ show x = case x of
+ PE (Right a) -> show a
+ PE (Left r) ->
+ T.unpack (showPath (Proxy @s)) ++ " (empty: " ++ show r ++ ")\n"
+instance (Semigroup a) => Semigroup (PossiblyEmpty a) where
+ PE (Right x) <> PE (Right y) = PE $ Right $ x<>y
+ PE (Left _) <> PE (Right x) = PE $ Right x
+ PE (Right x) <> PE (Left _) = PE $ Right x
+ PE (Left x) <> PE (Left y) = PE $ Left $ max x y
+instance (Semigroup a) => Monoid (PossiblyEmpty a) where
+ mempty = PE (Left NoDefault)
+
+
+-- | Wraps a field and gives it some tag
+data Tagged tag a = Tagged { tagFromTagged :: tag
+ , valueFromTagged :: a }
+
+-- | Wraps a field and gives it some documentation
+type WithDoc = Tagged T.Text
+
+instance (Eq a) => Eq (Tagged tag a) where
+ Tagged _ a == Tagged _ b = a == b
+instance (Ord a) => Ord (Tagged tag a) where
+ Tagged _ a `compare` Tagged _ b = a `compare` b
+instance (Show a) => Show (Tagged tag a) where
+ show (Tagged _ a) = show a
+-- | The tag is right-biased
+instance (Semigroup a) => Semigroup (Tagged tag a) where
+ Tagged _ x <> Tagged tag y = Tagged tag (x<>y)
+instance (Monoid tag, Monoid a) => Monoid (Tagged tag a) where
+ mempty = Tagged mempty mempty
+instance Functor (Tagged tag) where
+ fmap f (Tagged d a) = Tagged d (f a)
+instance (Monoid tag) => Applicative (Tagged tag) where
+ pure = Tagged mempty
+ Tagged t1 f <*> Tagged t2 x = Tagged (t1<>t2) (f x)
+
+-- | When two fields are tagged with an Ord, return the field with the highest
+-- one. Right field is returned if both tags are equal.
+chooseHighestPriority
+ :: Ord a
+ => F.Compose (Tagged a) (F.Compose (Tagged T.Text) f) x
+ -> F.Compose (Tagged a) (F.Compose (Tagged T.Text) f) x
+ -> F.Compose (Tagged a) (F.Compose (Tagged T.Text) f) x
+chooseHighestPriority (F.Compose (Tagged s1 (F.Compose (Tagged doc1 f1))))
+ (F.Compose (Tagged s2 (F.Compose (Tagged doc2 f2)))) =
+ if s2 >= s1
+ then F.Compose (Tagged s2 (F.Compose (Tagged doc f2)))
+ else F.Compose (Tagged s1 (F.Compose (Tagged doc f1)))
+ where -- DocRecords parsed from json don't contain any doc, so we have to
+ -- take care of which tag we select for documentation
+ doc | doc1 == "" = doc2
+ | otherwise = doc1
+
+-- | Just a type-level tuple, for easier to read type signatures
+data PathWithType a b = a :|: b
+
+-- | The most basic field. We don't use ElField from vinyl so we can use the
+-- PathWithType kind instead of tuple and paths instead of just names.
+data Field (pathAndType :: ( PathWithType [Symbol] * )) where
+ Field :: (ShowPath s) => !t -> Field (s :|: t)
+
+deriving instance (Eq a) => Eq (Field (s:|:a))
+deriving instance (Ord a) => Ord (Field (s:|:a))
+instance (Show t, ShowPath s) => Show (Field (s:|:t)) where
+ show (Field x) =
+ T.unpack (showPath (Proxy @s)) ++ " =: " ++ show x ++ "\n"
+
+instance (Semigroup t) => Semigroup (Field (s :|: t)) where
+ Field a <> Field b = Field $ a<>b
+instance (ShowPath s, Monoid t) => Monoid (Field (s :|: t)) where
+ mempty = Field mempty
+
+-- instance (Show (f (g a))) => Show (F.Compose f g a) where
+-- show (F.Compose x) = show x
+
+type PossiblyEmptyField = F.Compose PossiblyEmpty Field
+
+peToMb :: (NamedField field, ShowPath s) => Either r (field (s:|:a)) -> Maybe a
+peToMb (Left _) = Nothing
+peToMb (Right f) = f L.^. rfield
+
+peFromMb
+ :: (ShowPath s, NamedField field)
+ => Maybe a -> Either MissingValueReason (field (s ':|: a))
+peFromMb Nothing = Left NoDefault
+peFromMb (Just x) = Right $ fromValue x
+
+pattern PEField
+ :: ( NamedField f, ShowPath s)
+ => Maybe a -> F.Compose PossiblyEmpty f (s:|:a)
+pattern PEField v <- F.Compose (PE (peToMb -> v)) where
+ PEField v = F.Compose (PE (peFromMb v))
+
+type DocField = F.Compose WithDoc PossiblyEmptyField
+
+removeDoc :: F.Compose WithDoc f st -> f st
+removeDoc (F.Compose (Tagged _ x)) = x
+
+withoutDef :: F.Compose WithDoc (F.Compose PossiblyEmpty f) st
+ -> F.Compose WithDoc (F.Compose PossiblyEmpty f) st
+withoutDef (DocField doc _) = DocField doc (Left NoDefault)
+
+getPossiblyEmpty
+ :: F.Compose PossiblyEmpty f st -> Either MissingValueReason (f st)
+getPossiblyEmpty (F.Compose (PE x)) = x
+
+pattern DocField :: T.Text
+ -> Either MissingValueReason (g x)
+ -> F.Compose WithDoc (F.Compose PossiblyEmpty g) x
+pattern DocField doc mbf = F.Compose (Tagged doc (F.Compose (PE mbf)))
+
+-- | A extensible record of documented fields with values
+type DocRec = Rec DocField
+
+-- | To forget the field paths and get only the field types
+type family FieldTypes rs where
+ FieldTypes '[] = '[]
+ FieldTypes ((s:|:t) : rs) = t : FieldTypes rs
+
+fieldPathList :: forall st p. (ShowPath (Fst st)) => p st -> [T.Text]
+fieldPathList _ = showPathList (Proxy @(Fst st))
+
+fieldPath :: forall st p. (ShowPath (Fst st)) => p st -> T.Text
+fieldPath _ = showPath (Proxy @(Fst st))
+
+class ShowPath p where
+ showPathList :: proxy p -> [T.Text]
+ showPath :: proxy p -> T.Text
+ showPath p = T.intercalate (T.pack ".") (showPathList p)
+instance ShowPath '[] where
+ showPathList _ = []
+instance (ShowPath ps, KnownSymbol p) => ShowPath (p ': ps) where
+ showPathList _ = T.pack (symbolVal (Proxy @p)) : showPathList (Proxy @ps)
+
+-- | Creates missing levels of the json tree upon traversing
+jsonAtPath :: [T.Text] -> L.Lens' (Maybe Value) (Maybe Value)
+jsonAtPath [] f x = f x
+jsonAtPath (p:ps) f val = rebuild <$> recur
+ where
+ (obj, recur) = case val of
+ Just (Object o) -> (o, jsonAtPath ps f $ HM.lookup p o)
+ _ -> (HM.empty, jsonAtPath ps f $ Just $ Object HM.empty)
+ rebuild Nothing = Just $ Object $ HM.delete p obj
+ rebuild (Just v) = Just $ Object $ HM.insert p v obj
+
+instance FromJSON (Rec PossiblyEmptyField '[]) where
+ parseJSON (Object _) = pure RNil
+ parseJSON _ = mempty
+instance (FromJSON t, FromJSON (Rec PossiblyEmptyField rs), ShowPath s)
+ => FromJSON (Rec PossiblyEmptyField ((s:|:t) ': rs)) where
+ parseJSON v = rebuild <$> parseField (L.view (jsonAtPath p) (Just v))
+ <*> parseJSON @(Rec PossiblyEmptyField rs) v
+ where p = showPathList (Proxy @s)
+ rebuild mbV rest = F.Compose (PE (Field <$> mbV)) :& rest
+ parseField mbX = if x == Null -- We allow unexisting values
+ then parsing <|> pure (Left MissingValueInJSON)
+ else parsing -- But not values with a bad type
+ where parsing = Right <$> parseJSON x
+ x = fromMaybe Null mbX
+
+-- | Just sets the docstrings to empty
+instance (RMap rs, FromJSON (Rec PossiblyEmptyField rs)) => FromJSON (Rec DocField rs) where
+ parseJSON v = rmap toDoc <$> parseJSON v
+ where toDoc = F.Compose . Tagged ""
+
+-- | Just a shortcut to fix the record type that we are expecting in return
+--
+-- >>> let (Success p) = fromJSONAs defaultPerson j
+-- >>> p
+-- {age =: 12
+-- , name =: "Bernard"
+-- , size =: 130.0
+-- }
+--
+-- @
+-- ^^^ At this step (when pattern matching on Success)
+-- we can re-order the fields of defaultPerson
+-- or even get just a subset of them
+-- @
+--
+fromJSONAs :: (FromJSON x) => x -> Value -> Result x
+fromJSONAs _ = fromJSON
+
+type family Fst a where
+ Fst (a:|:b) = a
+type family Snd a where
+ Snd (a:|:b) = b
+type family AllFst c p :: Constraint where
+ AllFst c (r ': rs) = (c (Fst r), AllFst c rs)
+ AllFst c '[] = ()
+type family AllSnd c p :: Constraint where
+ AllSnd c (r ': rs) = (c (Snd r), AllSnd c rs)
+ AllSnd c '[] = ()
+
+instance (ToJSON `AllSnd` rs, ShowPath `AllFst` rs)
+ => ToJSON (Rec PossiblyEmptyField rs) where
+ toJSON RNil = Object mempty
+ toJSON x = into (Object mempty) x --object . toPairs
+ where
+ into :: forall rs'. (ToJSON `AllSnd` rs', ShowPath `AllFst` rs')
+ => Value -> Rec PossiblyEmptyField rs' -> Value
+ into o RNil = o
+ into o (field@(F.Compose (PE innerField)) :& fs) = into
+ (fromMaybe (error "Should not happen!") $
+ L.set (jsonAtPath $ fieldPathList field)
+ (Just $ case innerField of
+ Right (Field v) -> toJSON v
+ Left _ -> Null)
+ (Just o))
+ fs
+
+-- | Just ignores the docstrings
+instance (RMap rs, ToJSON `AllSnd` rs, ShowPath `AllFst` rs)
+ => ToJSON (Rec DocField rs) where
+ toJSON = toJSON . rmap removeDoc
+
+-- | A shortcut to ensure all fields in list are convertible to JSON
+type ToJSONFields fields =
+ (ToJSON `AllSnd` fields, Typeable `AllSnd` fields, ShowPath `AllFst` fields)
+
+-- | Displays all the field names, types, and documentation contained in a record
+--
+-- >>> T.putStrLn $ showDocumentation 20 defaultPerson
+-- age :: Int : This is the field giving the age
+-- name :: [Char] : This is the field giving the name
+-- size :: Double : This is the field giving the size (in cm)
+showDocumentation
+ :: forall rs field. (ShowPath `AllFst` rs, Typeable `AllSnd` rs)
+ => Int -- ^ Character limit for types
+ -> Rec (F.Compose WithDoc field) rs
+ -> T.Text
+showDocumentation charLimit (f :& fs) =
+ showF f <> case fs of
+ (_ :& _) -> "\n" <> showDocumentation charLimit fs
+ RNil -> ""
+ where
+ showF :: forall r. (ShowPath (Fst r), Typeable (Snd r))
+ => F.Compose WithDoc field r -> T.Text
+ showF (F.Compose (Tagged doc _)) =
+ showPath (Proxy @(Fst r))
+ <> " :: " <> T.pack (cap $ show $ typeRep $ Proxy @(Snd r))
+ <> " : " <> doc
+ cap x | length x >= charLimit = take charLimit x ++ "..."
+ | otherwise = x
+showDocumentation _ RNil = ""
+
+-- | Redefines @rfield@ and @(=:)@ from Data.Vinyl.Derived so they can work over
+-- different kinds of fields.
+class NamedField field where
+ -- | Lens to the payload of a field
+ rfield :: (ShowPath s) => L.Lens (field (s :|: a)) (field (s :|: b)) (Maybe a) (Maybe b)
+
+ -- | Construct a NamedField from a value
+ fromValue :: (ShowPath s) => a -> field (s :|: a)
+
+ -- | Transform the value inside the field if there is one
+ mapField :: (ShowPath s)
+ => (t -> t') -> field (s:|:t) -> field (s:|:t')
+ mapField = L.over (rfield . L._Just)
+ {-# INLINE mapField #-}
+
+ -- | Shorthand to create a NamedField with a single field, using a DocField as
+ -- an example.
+ (=:) :: (ShowPath s) => DocField (s :|: a) -> a -> Rec field '[ s :|: a ]
+ infixl 7 =:
+ _ =: x = fromValue x :& RNil
+ {-# INLINE (=:) #-}
+
+ changePath :: (ShowPath s') => field (s:|:a) -> field (s':|:a)
+
+type family FieldDirectlyContainsTag tag field where
+ FieldDirectlyContainsTag tag (F.Compose (Tagged tag) f) = True
+ FieldDirectlyContainsTag _ _ = False
+
+-- | Extra argument to avoid overlapping instances
+class (hasTag ~ FieldDirectlyContainsTag tag field) => FieldWithTag_ tag field hasTag where
+ -- | Retrieves or modifies a tag (documentation, source...) within a field
+ fieldTag :: L.Traversal' (field r) tag
+
+-- | Tells whether 'fieldTag' can be used on a Field
+type FieldWithTag tag field = FieldWithTag_ tag field (FieldDirectlyContainsTag tag field)
+
+-- | Change the name of a field from the name of another
+renamedAs :: (ShowPath s', NamedField f) => proxy (s':|:a) -> f (s:|:a) -> f (s':|:a)
+renamedAs _ = changePath
+
+instance NamedField Field where
+ rfield f (Field v) = Field . fromM <$> f (Just v)
+ where fromM (Just v') = v'
+ fromM _ = error "Cannot remove a Field's value!"
+ {-# INLINE rfield #-}
+ fromValue = Field
+ changePath (Field v) = Field v
+
+instance (NamedField f) => NamedField (F.Compose PossiblyEmpty f) where
+ rfield f (F.Compose (PE field)) = F.Compose . PE <$> inspect field
+ where
+ inspect (Right inner) = rebuild NoDefault (setInner inner) <$> f (L.view rfield inner)
+ inspect (Left r) = rebuild r fromValue <$> f Nothing
+ setInner inner x = L.set rfield (Just x) inner
+ rebuild reason _ Nothing = Left reason
+ rebuild _ updInner (Just x) = Right $ updInner x
+ fromValue = F.Compose . PE . Right . fromValue
+ changePath (F.Compose (PE x)) = F.Compose $ PE $ case x of
+ Left r -> Left r
+ Right f -> Right $ changePath f
+
+instance (FieldWithTag tag g)
+ => FieldWithTag_ tag (F.Compose PossiblyEmpty g) False where
+ fieldTag fn (F.Compose (PE (Right f))) =
+ F.Compose . PE . Right <$> fieldTag fn f
+ fieldTag _ field = pure field
+
+-- | Tells the default tag to apply when creating a Field with 'fromValue'
+class NamedFieldTag tag where
+ -- | Tells the default tag to apply when creating a Field with 'fromValue'
+ defaultTag :: tag
+ -- | Permits to possibly keep the doc when setting a field
+ tagFromDoc :: T.Text -> tag
+
+instance NamedFieldTag T.Text where
+ defaultTag = ""
+ tagFromDoc = id
+
+instance (NamedField f, NamedFieldTag tag) => NamedField (F.Compose (Tagged tag) f) where
+ rfield = (\f (F.Compose (Tagged d x)) ->
+ F.Compose . Tagged d <$> f x) . rfield
+ {-# INLINE rfield #-}
+ fromValue = F.Compose . Tagged defaultTag . fromValue
+ changePath (F.Compose (Tagged d x)) = F.Compose (Tagged d (changePath x))
+ -- | We redefine (=:) so as to keep the doc:
+ F.Compose (Tagged d _) =: v = F.Compose (Tagged (tagFromDoc d) (fromValue v)) :& RNil
+
+instance FieldWithTag_ tag Field False where
+ fieldTag _ f = pure f
+
+instance FieldWithTag_ tag (F.Compose (Tagged tag) f) True where
+ fieldTag fn (F.Compose (Tagged d x)) = rebuild <$> fn d
+ where
+ rebuild d' = F.Compose (Tagged d' x)
+
+instance (FieldWithTag tag f, FieldDirectlyContainsTag tag (F.Compose (Tagged tag') f) ~ False)
+ => FieldWithTag_ tag (F.Compose (Tagged tag') f) False where
+ fieldTag fn (F.Compose (Tagged t f)) = F.Compose . Tagged t <$> fieldTag fn f
+
+-- | Turns a function (a -> b -> ... -> r) to (Field (s1:|:a) -> Field (s2:|:b)
+-- -> ... r) so that it can be used with 'runcurry', 'runcurryA', etc.
+class OnFields ts f1 f2 | ts f1 -> f2 where
+ onFields :: f1 -> f2
+instance OnFields '[] a a where
+ onFields x = x
+instance (OnFields ts f1 f2) =>
+ OnFields ((s:|:a) : ts) (a -> f1) (Field (s:|:a) -> f2) where
+ onFields f (Field x) = onFields @ts (f x)
+
+runcurryF :: forall ts f1 f a. (OnFields ts f1 (CurriedF f ts a))
+ => f1 -> Rec f ts -> a
+runcurryF = runcurry . onFields @ts
+
+runcurryAF :: forall ts f1 f g a. (Applicative f, OnFields ts f1 (CurriedF g ts a))
+ => f1 -> Rec (F.Compose f g) ts -> f a
+runcurryAF = runcurryA . onFields @ts
+
+-- | Replaces RIndex from vinyl to show an explicit error message
+type family RIndex' r1 rs1 (r :: k) (rs :: [k]) :: Nat where
+ RIndex' r1 rs1 r (r ': rs) = 'Z
+ RIndex' r1 rs1 r (notR ': rs) = 'S (RIndex' r1 rs1 r rs)
+ RIndex' r1 rs1 r rs = TypeError
+ (Text "Field " :<>: ShowType r1 :<>: Text " is not present in record " :<>: ShowType rs1)
+
+-- | Tells whether rs contains Field f. It replaces vinyl's (∈) to provide
+-- better error messages
+class (RElem f rs (RIndex' f rs f rs)) => rs `HasField` f
+instance (RElem f (r ': rs) (RIndex' f (r ': rs) f (r ': rs))) => (r ': rs) `HasField` f
+
+-- | Replaces RImage from vinyl to show an explicit error message
+-- type family RImage' rs1 ss1 (rs :: [k]) (ss :: [k]) :: [Nat] where
+-- RImage' rs1 ss1 (r ': rs) ss = RIndex' rs1 ss1 r ss ': RImage' rs1 ss1 rs ss
+-- RImage' rs1 ss1 '[] ss = TypeError
+
+type family RImage' rs1 ss1 (rs :: [k]) (ss :: [k]) :: [Nat] where
+ RImage' rs1 ss1 '[] ss = '[]
+ RImage' rs1 ss1 (r ': rs) ss = RIndex' r ss r ss ': RImage' rs1 ss1 rs ss
+
+-- | Tells whether rs contains Field f. It replaces vinyl's (⊆) to provide
+-- better error messages
+class (RSubset rs ss (RImage' rs ss rs ss)) => ss `Includes` rs
+instance ss `Includes` '[]
+instance (RSubset (r ': rs) ss (RImage' (r ': rs) ss (r ': rs) ss)) => ss `Includes` (r ': rs)
+
+-- | Just a version of 'VL.rsubset' that uses the 'Includes' constraint, for
+-- better error messages
+rsubset :: (Functor g, ss `Includes` rs) => (Rec f rs -> g (Rec f rs)) -> Rec f ss -> g (Rec f ss)
+rsubset = VL.rsubset
+
+-- | Just a version of 'VL.rcast' that uses the 'Includes' constraint, for
+-- better error messages
+rcast :: (ss `Includes` rs) => Rec f ss -> Rec f rs
+rcast = VL.rcast
+
+-- | Just a version of 'VL.rcast' that uses the 'Includes' constraint, for
+-- better error messages
+rreplace :: (ss `Includes` rs) => Rec f rs -> Rec f ss -> Rec f ss
+rreplace = VL.rreplace
+
+-- | Replaces vinyl REquivalent to provide better error messages
+type rs `EquivalentTo` ss = (rs `Includes` ss, ss `Includes` rs)
+
+-- | Lens for getting a field's value inside some NamedField. Shortcut for
+-- @rlens f . rfield@
+fld :: forall s a rs field proxy.
+ (NamedField field, rs `HasField` (s:|:a), ShowPath s)
+ => proxy (s:|:a)
+ -> L.Lens' (Rec field rs) (Maybe a)
+fld _ = VL.rlens @(s:|:a) . rfield
+
+-- | @r ^^. n@ is just a shortcut for @r ^. fld n . _Just@. Since the field can be empty
+-- it requires it to be a Monoid
+(^^.) :: (NamedField field, rs `HasField` (s:|:t), ShowPath s, Monoid t)
+ => Rec field rs -> proxy (s:|:t) -> t
+record ^^. field = record L.^. fld field . L._Just
+infixl 8 ^^.
+
+-- | @r ^^? n@ is just a shortcut for @r ^. fld n@
+-- >>> let v2 = namedDefault & age %%~ (+1)
+-- >>> v2^^?age
+-- Just 13
+--
+(^^?) :: (NamedField field, rs `HasField` (s:|:t), ShowPath s)
+ => Rec field rs -> proxy (s:|:t) -> (Maybe t)
+record ^^? field = record L.^. fld field
+infixl 8 ^^?
+
+-- | @r ^^?! n@ is just a shortcut for @r ^?! fld n . L._Just@. It fails if
+-- the field doesn't contain a value.
+-- >>> let v2 = namedDefault & age %%~ (+1)
+-- >>> v2^^?!age
+-- 13
+--
+(^^?!) :: (NamedField field, rs `HasField` (s:|:t), ShowPath s)
+ => Rec field rs -> proxy (s:|:t) -> t
+record ^^?! field = record L.^?! fld field . L._Just
+infixl 8 ^^?!
+
+-- | @n %%~ f@ is just a shortcut for @fld n . _Just %~ f@. You can use it to set nested
+-- records. For instance, @myPerson & parent%%~age..~30@ sets to 30 the age of
+-- the parent in the object myPerson.
+(%%~) :: (NamedField field, rs `HasField` (s:|:t), ShowPath s)
+ => proxy (s:|:t) -> (t -> t) -> Rec field rs -> Rec field rs
+field %%~ f = fld field . L._Just L.%~ f
+infixr 4 %%~
+
+-- | @n ..~ v@ is just a shortcut for @fld n .~ Just v@
+--
+-- >>> name ..~ "Bernard" $ defaultPerson
+-- {age =: 12
+-- , name =: "Bernard"
+-- , size =: 130.0
+-- }
+(..~) :: (NamedField field, rs `HasField` (s:|:t), ShowPath s)
+ => proxy (s:|:t) -> t -> Rec field rs -> Rec field rs
+field ..~ v = fld field L..~ Just v
+infixr 4 ..~
+
+-- | A record with just an anonymous field. Useful when only the position of the
+-- field is important
+singleton :: (NamedField f) => t -> Rec f '[ ('[]:|:t ) ]
+singleton x = fromValue x :& RNil
+
+-- | Directly use a default value as part of a record. Will fail if @f@ doesn't
+-- have a default value
+useDef :: (NamedField f, ShowPath s) => DocField (s:|:t) -> Rec f '[ (s:|:t) ]
+useDef f = f =: (f L.^?! rfield . L._Just)
+
+-- | Used to create a field template
+docField :: forall s t. (KnownSymbol s) => t -> T.Text -> DocField ('[s]:|:t)
+docField defVal doc = DocField doc $ Right $ Field defVal
+
+-- | Used to create an intermediary field
+itmLevel
+ :: forall s rs. (KnownSymbol s)
+ => T.Text -> DocRec rs -> IntermediaryLevel '[s] rs
+itmLevel doc content = ItmLvl $ DocField doc $ Right $ Field content
+
+-- | Used to create a field from a default
+fieldFromDef
+ :: forall s t. (KnownSymbol s, Default t)
+ => T.Text -> DocField ('[s]:|:t)
+fieldFromDef = docField def
+
+-- | Used to create a field that will not have a default value
+fieldNoDef :: forall s t. T.Text -> DocField ('[s]:|:t)
+fieldNoDef doc = DocField doc $ Left NoDefault
+
+type family DeleteIn a b where
+ DeleteIn t (t ': ts) = DeleteIn t ts
+ DeleteIn t (t' ': ts) = t' : DeleteIn t ts
+ DeleteIn t '[] = '[]
+
+type family Difference a b where
+ Difference ts' (t ': ts) = Difference (DeleteIn t ts') ts
+ Difference ts' '[] = ts'
+
+-- | Splits a record in two parts by using an existing record type.
+rcastAs
+ :: (rs `Includes` selected)
+ => p selected -> Rec f rs -> Rec f selected
+rcastAs _ r = rcast r
+
+-- | Splits a record in two parts.
+rsplit
+ :: (rs `Includes` selected, rs `Includes` (rs `Difference` selected))
+ => Rec f rs -> (Rec f selected, Rec f (rs `Difference` selected))
+rsplit r = (rcast r, rcast r)
+
+-- | Splits a record in two parts by using an existing record type.
+rsplitFrom
+ :: (rs `Includes` selected, rs `Includes` (rs `Difference` selected))
+ => p selected -> Rec f rs -> (Rec f selected, Rec f (rs `Difference` selected))
+rsplitFrom _ r = rsplit r
+
+-- | "Subtracts" one record from another. In other term, splits a record in two
+-- parts by selecting the fields from an existing record
+rdifference
+ :: (rs `Includes` selected, rs `Includes` (rs `Difference` selected))
+ => Rec f rs -> p selected -> Rec f (rs `Difference` selected)
+rdifference r _ = rcast r
+
+type a `Intersection` b = a `Difference` (a `Difference` b)
+
+-- | Returns (fields only in a, values in a of fields in both, values in b of
+-- fields in both, fields only in b)
+rintersection
+ :: (a `Includes` (a `Difference` b)
+ ,a `Includes` (a `Intersection` b)
+ ,b `Includes` (b `Intersection` a)
+ ,b `Includes` (b `Difference` a))
+ => Rec f a -> Rec f b -> ( Rec f (a `Difference` b), Rec f (a `Intersection` b)
+ , Rec f (b `Intersection` a), Rec f (b `Difference` a) )
+rintersection a b = (rcast a, rcast a, rcast b, rcast b)
+
+class PrefixPath (s::[Symbol]) rs where
+ type s `PrefixingAll` rs :: [PathWithType [Symbol] *]
+ prefixPath :: (NamedField f) => Rec f rs -> Rec f (s `PrefixingAll` rs)
+instance PrefixPath s '[] where
+ type s `PrefixingAll` '[] = '[]
+ prefixPath _ = RNil
+instance (PrefixPath s ps, ShowPath (s++p1)) => PrefixPath s ( (p1:|:t) : ps) where
+ type s `PrefixingAll` ( (p1:|:t) : ps) = ( (s++p1:|:t) : s `PrefixingAll` ps)
+ prefixPath (f :& fs) = (changePath f) :& prefixPath @s fs
+
+-- | Used to indicate that a field contains no useful value, only metadata (doc)
+data MD = MD
+
+instance Eq MD where
+ _ == _ = True
+instance Ord MD where
+ compare _ _ = EQ
+instance ToJSON MD where
+ toJSON _ = Null
+instance FromJSON MD where
+ parseJSON _ = pure MD
+instance Show MD where
+ show _ = "<just_doc>"
+
+newtype IntermediaryLevel_ a = ItmLvl (DocField a)
+
+-- | Used to indicate "virtual" fields, that won't be directly filled with data
+-- but will be used by 'rinclude', 'rdrill', '(-.)' and '(-/)' to pinpoint a
+-- subrecord in the hierarchy and indicate what this subrecord is meant to
+-- contain
+type IntermediaryLevel s rs = IntermediaryLevel_ (s:|:DocRec rs)
+
+-- | Transforming the type of an IntermediaryLevel into a regular record
+type FlattenedLevel s rs = s `PrefixingAll` rs
+
+-- | Flatten a field of records into a record by altering the path of each
+-- subfield
+rinclude
+ :: forall s rs. (PrefixPath s rs, ShowPath s)
+ => IntermediaryLevel s rs -> DocRec (FlattenedLevel s rs)
+rinclude (ItmLvl (DocField _ (Left r))) =
+ error $ "rinclude: Trying to flatten an empty field (" ++ show r ++ ")!"
+rinclude (ItmLvl (DocField _doc (Right (Field r)))) = prefixPath @s r
+
+-- | Is a class so we can compose both 'IntermediaryLevel's and 'DocField's
+class ComposableNesting f lvl2 where
+ -- | Appends together two fields in a nested fashion. Will build either a
+ -- final DocField or another IntermediaryLevel, depending on the second
+ -- argument.
+ (-.) :: (NestedLvlConstraints rs f p lvl2, ShowPath (s++p))
+ => IntermediaryLevel s rs -> f (p:|:lvl2) -> NestedLvl s f p lvl2
+ infixr 9 -.
+
+type family NestedLvl s f p lvl2 where
+ NestedLvl s IntermediaryLevel_ p (DocRec rs') = IntermediaryLevel (s++p) rs'
+ NestedLvl s f p t = f ((s++p):|:t)
+
+type family NestedLvlConstraints rs f p lvl2 :: Constraint where
+ NestedLvlConstraints rs IntermediaryLevel_ p (DocRec rs') =
+ ( rs `Includes` (p `PrefixingAll` rs') )
+ NestedLvlConstraints rs f p t =
+ ( rs `HasField` (p:|:t) )
+
+instance ComposableNesting IntermediaryLevel_ (DocRec rs') where
+ _ -. ItmLvl f = ItmLvl $ changePath f
+
+instance (NamedField f) => ComposableNesting f t where
+ _ -. f = changePath f
+
+-- | A version of '(-.)' for when you don't have an 'IntermediaryLevel' to use
+-- as prefix and just want a single-symbol prefix
+funder :: forall s p t. ( ShowPath (s ': p) )
+ => DocField (p:|:t) -> DocField ((s ': p) :|: t)
+funder = changePath
+
+-- | A version of '(-.)' for altering the paths of a whole record at once
+(-/) :: forall s rs selected f.
+ (rs `Includes` selected, PrefixPath s selected, NamedField f)
+ => IntermediaryLevel s rs -> Rec f selected -> Rec f (s `PrefixingAll` selected)
+_ -/ r = prefixPath @s r
+infixr 6 -/
+
+-- | A version of '(-/)' for when you don't have an 'IntermediaryLevel' to use
+-- as prefix and just want a single-symbol prefix
+runder :: forall s selected f. (PrefixPath '[s] selected, NamedField f)
+ => Rec f selected -> Rec f ('[s] `PrefixingAll` selected)
+runder r = prefixPath @'[s] r
+
+type family Strip s src where
+ Strip (a ': as) (a ': bs) = Strip as bs
+ Strip (a ': as) (b ': bs) = b ': bs
+ Strip as bs = bs
+
+class UnprefixPath (s::[Symbol]) rs where
+ type s `UnprefixingAll` rs :: [PathWithType [Symbol] *]
+ unprefixPath :: (NamedField f) => Rec f rs -> Rec f (s `UnprefixingAll` rs)
+instance UnprefixPath s '[] where
+ type s `UnprefixingAll` '[] = '[]
+ unprefixPath _ = RNil
+instance (UnprefixPath s ps, ShowPath (Strip s p1))
+ => UnprefixPath s ( (p1:|:t) : ps) where
+ type s `UnprefixingAll` ( (p1:|:t) : ps) =
+ ( (Strip s p1 :|: t) : s `UnprefixingAll` ps)
+ unprefixPath (f :& fs) = changePath f :& unprefixPath @s fs
+
+-- | Selects a subrecord from a record @r@, using an 'IntermediaryLevel'. (This
+-- 'IntermediaryLevel' has normally originally been passed to 'rinclude' to
+-- obtain @r@)
+rdrill :: forall s inner outer f.
+ ( inner ~ (s `UnprefixingAll` (s `PrefixingAll` inner))
+ -- This is always the case, but GHC doesn't have the proof of that
+ , UnprefixPath s (s `PrefixingAll` inner)
+ , outer `Includes` (s `PrefixingAll` inner)
+ , NamedField f )
+ => IntermediaryLevel s inner
+ -> Rec f outer
+ -> Rec f inner
+rdrill _ outer = unprefixPath @s (rcast outer :: Rec f (s `PrefixingAll` inner))
+
+-- | Combines a drill and a split
+rsplitDrill :: forall s inner outer f.
+ ( inner ~ (s `UnprefixingAll` (s `PrefixingAll` inner))
+ -- This is always the case, but GHC doesn't have the proof of that
+ , UnprefixPath s (s `PrefixingAll` inner)
+ , outer `Includes` (s `PrefixingAll` inner)
+ , outer `Includes` (outer `Difference` (FlattenedLevel s inner))
+ , NamedField f )
+ => IntermediaryLevel s inner
+ -> Rec f outer
+ -> (Rec f inner, Rec f (outer `Difference` (FlattenedLevel s inner)))
+rsplitDrill il outer = (rdrill il outer, rcast outer)
+
+-- | Merges a whole subset of the tree to a single field
+rfoldSubset
+ :: forall outer' inner outer p t proxy f.
+ ( outer `Includes` inner
+ , ((p:|:t) ': outer) `Includes` outer')
+ => proxy inner -- ^ The list of fields to target
+ -> (Rec f inner -> f (p:|:t))
+ -> Rec f outer
+ -> Rec f outer'
+rfoldSubset _ f r = rcast $ f (rcast r) :& r
+
+-- | Just a helper to fix some types
+withSameFields :: Rec f rs -> Rec g rs -> t -> t
+withSameFields _ _ x = x
+
+type IdentityField = F.Identity
+
+-- | Just a shortcut to build identity records (i.e. simple heterogeneous
+-- lists. Useful for applying different function over different fields of a
+-- record with 'ApplyRec'
+(&:) :: t -> Rec IdentityField ts -> Rec IdentityField (t ': ts)
+x &: r = F.Identity x :& r
+infixr 5 &:
+
+-- | Applies a record of functions to a record of data. It's a bit like the
+-- (<<*>>) operator from vinyl but it permits to change the type of the fields,
+-- which (<<$>>) from vinyl doesn't.
+class ApplyRec fns fields results | fns fields -> results where
+ appRec :: (NamedField f) => Rec F.Identity fns -> Rec f fields -> Rec f results
+
+instance ApplyRec '[] a a where
+ appRec RNil r = r
+
+instance (ApplyRec fns fields results, ShowPath s)
+ => ApplyRec ( (a -> b) : fns ) ((s:|:a) : fields) ((s:|:b) : results) where
+ appRec (F.Identity f :& fns) (field :& fields) =
+ L.over (rfield . L._Just) f field :& appRec fns fields
+
+-- | Whether the first field of a record should be ignored when constructing it
+type family FirstFieldSkipped rs where
+ FirstFieldSkipped ((s:|:MD) : rs) = 'True
+ FirstFieldSkipped a = 'False
+
+class (skipFirst ~ FirstFieldSkipped rs)
+ => BuildRecFrom f rs (acc::[PathWithType [Symbol] *]) skipFirst where
+ type RecCtor f rs acc skipFirst
+ buildRecFrom_ :: Rec f acc -> DocRec rs -> RecCtor f rs acc skipFirst
+
+instance BuildRecFrom f '[] acc 'False where
+ type RecCtor f '[] acc 'False = Rec f acc
+ buildRecFrom_ acc RNil = acc
+ {-# INLINE buildRecFrom_ #-}
+
+instance ( BuildRecFrom f rs (acc ++ '[s:|:a]) (FirstFieldSkipped rs)
+ , FirstFieldSkipped ((s:|:a):rs) ~ 'False
+ , NamedField f, ShowPath s )
+ => BuildRecFrom f ((s:|:a) : rs) acc 'False where
+ type RecCtor f ((s:|:a) : rs) acc 'False =
+ a -> RecCtor f rs (acc ++ '[s:|:a]) (FirstFieldSkipped rs)
+ buildRecFrom_ acc (r :& rs) a = buildRecFrom_ (acc <+> r =: a) rs
+ -- The append at the of the record makes it quadratic in comlexity. It's not
+ -- great, it could me made to be linear.
+ {-# INLINE buildRecFrom_ #-}
+
+instance ( BuildRecFrom f rs (acc++'[s:|:MD]) (FirstFieldSkipped rs)
+ , NamedField f, ShowPath s )
+ => BuildRecFrom f ((s:|:MD) : rs) acc 'True where
+ type RecCtor f ((s:|:MD) : rs) acc 'True =
+ RecCtor f rs (acc ++ '[s:|:MD]) (FirstFieldSkipped rs)
+ buildRecFrom_ acc (_ :& rs) = buildRecFrom_ (acc <+> fromValue @f @s MD :& RNil) rs
+ {-# INLINE buildRecFrom_ #-}
+
+-- | Generic construct for records. It takes as many arguments as the example
+-- DocRec contains fields, except for MD fields which are skipped.
+recFrom :: forall f rs. (BuildRecFrom f rs '[] (FirstFieldSkipped rs))
+ => DocRec rs -> RecCtor f rs '[] (FirstFieldSkipped rs)
+recFrom = buildRecFrom_ @f RNil
+{-# INLINE recFrom #-}
+
+-- | Transforms a 'Rec f as' into a 'Rec f bs' and the other way around. This is
+-- exactly like an Iso from Lens, but using an Iso makes it harder to implement
+-- (<<|>>). Maybe in the future we'll get back to regular Lenses and Isos
+-- (because this way composition of Isos and Lenses together is done for us and
+-- behaves sanely. Plus we get plain old function composition instead of having
+-- to import Control.Category).
+-- This could be done by making bijectField/addConstField etc
+data RecBijection f as bs = RecBijection
+ { applyRecBij :: Rec f as -> Rec f bs
+ , applyRecBijInv :: Rec f bs -> Rec f as
+ }
+
+instance Cat.Category (RecBijection f) where
+ id = RecBijection id id
+ RecBijection f fi . RecBijection g gi = RecBijection (f . g) (gi . fi)
+
+-- | Returns the inverse of the bijection
+invertRecBij :: RecBijection f as bs -> RecBijection f bs as
+invertRecBij (RecBijection f g) = RecBijection g f
+
+-- | Composes two 'RecBijection's in a parallel fashion.
+(<<|>>)
+ :: ( as `Intersection` as' ~ '[]
+ , bs `Intersection` bs' ~ '[]
+ , (as ++ as') `Includes` as, (as ++ as') `Includes` as'
+ , (bs ++ bs') `Includes` bs, (bs ++ bs') `Includes` bs')
+ => RecBijection f as bs
+ -> RecBijection f as' bs'
+ -> RecBijection f (as++as') (bs++bs')
+RecBijection f fi <<|>> RecBijection g gi =
+ RecBijection (\r -> f (rcast r) <+> g (rcast r))
+ (\r -> fi (rcast r) <+> gi (rcast r))
+
+-- | Creates a 'RecBijection' that just maps over a singleton 'Rec'
+bijectField :: forall s f a b. (ShowPath s, NamedField f)
+ => (a -> b) -> (b -> a) -> RecBijection f '[s:|:a] '[s:|:b]
+bijectField f g = RecBijection (\(fl :& RNil) -> mapField f fl :& RNil)
+ (\(fl :& RNil) -> mapField g fl :& RNil)
+{-# INLINE bijectField #-}
+
+-- | Creates a 'RecBijection' that just maps over a singleton 'Rec' and changes the name along
+bijectField' :: forall s s' f a b. (ShowPath s, ShowPath s', NamedField f)
+ => (a -> b) -> (b -> a) -> RecBijection f '[s:|:a] '[s':|:b]
+bijectField' f g = RecBijection (\(fl :& RNil) -> changePath (mapField f fl) :& RNil)
+ (\(fl :& RNil) -> changePath (mapField g fl) :& RNil)
+{-# INLINE bijectField' #-}
+
+-- | Creates a 'RecBijection' that changes the path of the field in a singleton
+-- 'Rec'
+renameField :: forall s s' f a. (ShowPath s, ShowPath s', NamedField f)
+ => RecBijection f '[s:|:a] '[s':|:a]
+renameField = RecBijection (\(fl :& RNil) -> changePath fl :& RNil)
+ (\(fl :& RNil) -> changePath fl :& RNil)
+{-# INLINE renameField #-}
+
+-- | Just adds a field that will be constant
+addConstField :: forall s f a. f (s:|:a) -> RecBijection f '[] '[s:|:a]
+addConstField x = RecBijection (\_ -> x :& RNil) (const RNil)
+{-# INLINE addConstField #-}
+
+-- | A version of '(-/)' for 'RecBijection's
+bijectUnder
+ :: forall s f as bs.
+ ( as ~ UnprefixingAll s (PrefixingAll s as)
+ , bs ~ UnprefixingAll s (PrefixingAll s bs)
+ , PrefixPath s as, PrefixPath s bs, NamedField f
+ , UnprefixPath s (PrefixingAll s as)
+ , UnprefixPath s (PrefixingAll s bs) )
+ => RecBijection f as bs
+ -> RecBijection f (s `PrefixingAll` as) (s `PrefixingAll` bs)
+bijectUnder (RecBijection f fi) =
+ RecBijection (prefixPath @s . f . unprefixPath @s)
+ (prefixPath @s . fi . unprefixPath @s)
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
diff --git a/test/DocTest.hs b/test/DocTest.hs
new file mode 100644
index 0000000..f3d4f07
--- /dev/null
+++ b/test/DocTest.hs
@@ -0,0 +1,5 @@
+import Test.DocTest
+
+main :: IO ()
+main = doctest ["-isrc", "src"]
+