diff --git a/LICENSE b/LICENSE new file mode 100644 --- /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. diff --git a/docrecords.cabal b/docrecords.cabal new file mode 100644 --- /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 + +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 +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 --- /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 _ = "" + +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 --- /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 --- /dev/null +++ b/test/DocTest.hs @@ -0,0 +1,5 @@ +import Test.DocTest + +main :: IO () +main = doctest ["-isrc", "src"] +