docrecords (empty) → 0.1.0.0
raw patch · 5 files changed
+1260/−0 lines, 5 filesdep +aesondep +basedep +data-default
Dependencies added: aeson, base, data-default, doctest, lens, optparse-applicative, text, unordered-containers, vinyl, yaml
Files
- LICENSE +21/−0
- docrecords.cabal +72/−0
- src/Data/DocRecord.hs +1006/−0
- src/Data/DocRecord/OptParse.hs +156/−0
- test/DocTest.hs +5/−0
+ LICENSE view
@@ -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.
+ docrecords.cabal view
@@ -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
+ src/Data/DocRecord.hs view
@@ -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)
+ src/Data/DocRecord/OptParse.hs view
@@ -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
+ test/DocTest.hs view
@@ -0,0 +1,5 @@+import Test.DocTest++main :: IO ()+main = doctest ["-isrc", "src"]+