summaryrefslogtreecommitdiff
path: root/src/Data
diff options
context:
space:
mode:
Diffstat (limited to 'src/Data')
-rw-r--r--src/Data/Locations.hs17
-rw-r--r--src/Data/Locations/Accessors.hs381
-rw-r--r--src/Data/Locations/FunflowRemoteCache.hs66
-rw-r--r--src/Data/Locations/Loc.hs381
-rw-r--r--src/Data/Locations/LocVariable.hs14
-rw-r--r--src/Data/Locations/LocationTree.hs283
-rw-r--r--src/Data/Locations/LogAndErrors.hs58
-rw-r--r--src/Data/Locations/Mappings.hs259
-rw-r--r--src/Data/Locations/SerializationMethod.hs745
-rw-r--r--src/Data/Locations/VirtualFile.hs394
-rw-r--r--src/Data/Representable.hs24
11 files changed, 2622 insertions, 0 deletions
diff --git a/src/Data/Locations.hs b/src/Data/Locations.hs
new file mode 100644
index 0000000..a1a5a6b
--- /dev/null
+++ b/src/Data/Locations.hs
@@ -0,0 +1,17 @@
+module Data.Locations
+ ( module Data.Locations.Loc
+ , module Data.Locations.LocationTree
+ , module Data.Locations.LocVariable
+ , module Data.Locations.Mappings
+ , module Data.Locations.VirtualFile
+ , module Data.Locations.SerializationMethod
+ , module Data.Locations.LogAndErrors
+ ) where
+
+import Data.Locations.Loc
+import Data.Locations.LocationTree
+import Data.Locations.LocVariable
+import Data.Locations.LogAndErrors
+import Data.Locations.Mappings
+import Data.Locations.SerializationMethod
+import Data.Locations.VirtualFile
diff --git a/src/Data/Locations/Accessors.hs b/src/Data/Locations/Accessors.hs
new file mode 100644
index 0000000..5642453
--- /dev/null
+++ b/src/Data/Locations/Accessors.hs
@@ -0,0 +1,381 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC "-fno-warn-incomplete-uni-patterns" #-}
+{-# OPTIONS_GHC "-fno-warn-missing-signatures" #-}
+{-# OPTIONS_GHC "-fno-warn-redundant-constraints" #-}
+
+module Data.Locations.Accessors
+ ( module Control.Monad.ReaderSoup.Resource
+ , FromJSON(..), ToJSON(..)
+ , LocationAccessor(..)
+ , LocOf, LocWithVarsOf
+ , SomeGLoc(..), SomeLoc, SomeLocWithVars
+ , SomeHashableLocs
+ , toHashableLocs
+ , FieldWithAccessors
+ , Rec(..), ElField(..)
+ , MayProvideLocationAccessors(..)
+ , SomeLocationAccessor(..)
+ , AvailableAccessors
+ , LocResolutionM
+ , BasePorcupineContexts
+ , (<--)
+ , baseContexts, baseContextsWithScribeParams
+ , pattern L
+ , splitAccessorsFromArgRec
+ , withParsedLocs, withParsedLocsWithVars, resolvePathToSomeLoc, resolveYamlDocToSomeLoc
+ , writeLazyByte, readLazyByte, readText, writeText
+ ) where
+
+import Control.Funflow.ContentHashable
+import Control.Lens (over, (^.), _1)
+import Control.Monad.IO.Unlift
+import Control.Monad.ReaderSoup
+import Control.Monad.ReaderSoup.Resource
+import Control.Monad.Trans.Resource
+import Data.Aeson
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Streaming as BSS
+import qualified Data.HashMap.Strict as HM
+import Data.Locations.Loc
+import Data.Locations.LogAndErrors
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Encoding as LTE
+import Data.Vinyl
+import Data.Vinyl.Functor
+import qualified Data.Yaml as Y
+import GHC.TypeLits
+import Katip
+import System.Directory (createDirectoryIfMissing,
+ createFileLink,
+ doesPathExist)
+import qualified System.FilePath as Path
+import qualified System.IO.Temp as Tmp
+import System.TaskPipeline.Logger
+
+
+-- | A location where no variables left to be instanciated.
+type LocOf l = GLocOf l String
+
+-- | A location that contains variables needing to be instanciated.
+type LocWithVarsOf l = GLocOf l StringWithVars
+
+-- | Creates some Loc type, indexed over a symbol (see ReaderSoup for how that
+-- symbol should be used), and equipped with functions to access it in some
+-- Monad
+class ( MonadMask m, MonadIO m
+ , TypedLocation (GLocOf l) )
+ => LocationAccessor m (l::Symbol) where
+
+ -- | Generalized location. The implementation is completely to the discretion
+ -- of the LocationAccessor, but it must be serializable in json, and it must
+ -- be able to contain "variable bits" (that will correspond for instance to
+ -- indices). These "variable bits" must be exposed through the parameter @a@
+ -- in @GLocOf l a@, and @GLocOf l@ must be a Traversable. @a@ will always be
+ -- an instance of 'IsLocString'. The rest of the implementation of
+ -- 'LocationAccessor' doesn't have to work in the most general case @GLocOf l
+ -- a@, as when all variables have been replaced by their final values, @a@ is
+ -- just @String@.
+ data GLocOf l :: * -> *
+
+ locExists :: LocOf l -> m Bool
+
+ writeBSS :: LocOf l -> BSS.ByteString m r -> m r
+
+ readBSS :: LocOf l -> (BSS.ByteString m () -> m b) -> m b
+
+ copy :: LocOf l -> LocOf l -> m ()
+ copy locFrom locTo = readBSS locFrom (writeBSS locTo)
+
+ withLocalBuffer :: (FilePath -> m a) -> LocOf l -> m a
+ -- If we have a local resource accessor, we use it:
+ default withLocalBuffer :: (MonadResource m)
+ => (FilePath -> m a) -> LocOf l -> m a
+ withLocalBuffer f loc =
+ Tmp.withSystemTempDirectory "pipeline-tools-tmp" writeAndUpload
+ where
+ writeAndUpload tmpDir = do
+ let tmpFile = tmpDir Path.</> "out"
+ res <- f tmpFile
+ _ <- readBSS (L (localFile tmpFile)) (writeBSS loc)
+ return res
+
+-- | Reifies an instance of LocationAccessor
+data SomeLocationAccessor m where
+ SomeLocationAccessor :: (KnownSymbol l, LocationAccessor m l)
+ => Label l -> SomeLocationAccessor m
+
+-- | This class is meant to be implemented by every label used in the reader
+-- soup. It tells whether this label provides LocationAccessors (usually zero or
+-- 1).
+class MayProvideLocationAccessors m l where
+ getLocationAccessors :: Label l -> [SomeLocationAccessor m]
+ default getLocationAccessors :: (KnownSymbol l, LocationAccessor m l)
+ => Label l -> [SomeLocationAccessor m]
+ getLocationAccessors x = [SomeLocationAccessor x]
+
+-- | By default, no accessor is provided
+instance {-# OVERLAPPABLE #-} MayProvideLocationAccessors m l where
+ getLocationAccessors _ = []
+
+-- | Packs together the args to run a context of the ReaderSoup, and if
+-- available, an instance of LocationAccessor
+type FieldWithAccessors m =
+ Compose ((,) [SomeLocationAccessor m]) ElField
+
+-- | Much like (=:) builds an ElField, (<--) builds a Field composed with
+-- LocationAccessors (if available)
+(<--) :: (KnownSymbol l, MayProvideLocationAccessors m l)
+ => Label l -> args -> FieldWithAccessors m (l:::args)
+lbl <-- args = Compose (getLocationAccessors lbl, lbl =: args)
+
+-- | All the LocationAccessors available to the system during a run, so that
+-- when we encounter an Aeson Value corresponding to some LocOf, we may try them
+-- all and use the first one that matches.
+newtype AvailableAccessors m = AvailableAccessors [SomeLocationAccessor m]
+
+-- | Retrieves the list of all available LocationAccessors
+--
+-- The ArgsForSoupConsumption constraint is redundant, but it is placed here to
+-- help type inference when using this function.
+splitAccessorsFromArgRec
+ :: (ArgsForSoupConsumption args)
+ => Rec (FieldWithAccessors (ReaderSoup (ContextsFromArgs args))) args
+ -> ( AvailableAccessors (ReaderSoup (ContextsFromArgs args))
+ , Rec ElField args )
+splitAccessorsFromArgRec = over _1 AvailableAccessors . rtraverse getCompose
+ -- `(,) a` is an Applicative if a is a Monoid, so this will merge all the lists
+ -- of SomeLocationAccessors
+
+-- * Making "resource" a LocationAccessor
+
+checkLocal :: String -> Loc -> (LocalFilePath -> p) -> p
+checkLocal _ (LocalFile fname) f = f fname
+checkLocal funcName loc _ = error $ funcName ++ ": location " ++ show loc ++ " isn't a LocalFile"
+
+-- | Accessing local resources
+instance (MonadResource m, MonadMask m) => LocationAccessor m "resource" where
+ newtype GLocOf "resource" a = L (URL a)
+ deriving (Functor, Foldable, Traversable, ToJSON, TypedLocation)
+ locExists (L l) = checkLocal "locExists" l $
+ liftIO . doesPathExist . (^. pathWithExtensionAsRawFilePath)
+ writeBSS (L l) body = checkLocal "writeBSS" l $ \path -> do
+ let raw = path ^. pathWithExtensionAsRawFilePath
+ liftIO $ createDirectoryIfMissing True (Path.takeDirectory raw)
+ BSS.writeFile raw body
+ readBSS (L l) f = checkLocal "readBSS" l $ \path ->
+ f $ BSS.readFile $ path ^. pathWithExtensionAsRawFilePath
+ withLocalBuffer f (L l) = checkLocal "withLocalBuffer" l $ \path ->
+ f $ path ^. pathWithExtensionAsRawFilePath
+ copy (L l1) (L l2) =
+ checkLocal "copy" l1 $ \path1 ->
+ checkLocal "copy (2nd argument)" l2 $ \path2 ->
+ liftIO $ createFileLink
+ (path1 ^. pathWithExtensionAsRawFilePath)
+ (path2 ^. pathWithExtensionAsRawFilePath)
+
+instance (MonadResource m, MonadMask m) => MayProvideLocationAccessors m "resource"
+
+instance (IsLocString a) => Show (GLocOf "resource" a) where
+ show (L l) = show l -- Not automatically derived to avoid the 'L' constructor
+ -- being added
+
+instance (IsLocString a) => FromJSON (GLocOf "resource" a) where
+ parseJSON v = do
+ loc <- parseJSON v
+ case loc of
+ LocalFile{} -> return $ L loc
+ _ -> fail "Isn't a local file"
+
+
+-- * Treating locations in a general manner
+
+-- | Some generalized location. Wraps a @GLocOf l a@ where @l@ is a
+-- 'LocationAccessor' in monad @m@.
+data SomeGLoc m a = forall l. (LocationAccessor m l) => SomeGLoc (GLocOf l a)
+
+instance Functor (SomeGLoc m) where
+ fmap f (SomeGLoc l) = SomeGLoc $ fmap f l
+instance Foldable (SomeGLoc m) where
+ foldMap f (SomeGLoc l) = foldMap f l
+instance Traversable (SomeGLoc m) where
+ traverse f (SomeGLoc l) = SomeGLoc <$> traverse f l
+
+type SomeLoc m = SomeGLoc m String
+type SomeLocWithVars m = SomeGLoc m StringWithVars
+
+instance Show (SomeLoc m) where
+ show (SomeGLoc l) = show l
+instance Show (SomeLocWithVars m) where
+ show (SomeGLoc l) = show l
+
+instance ToJSON (SomeLoc m) where
+ toJSON (SomeGLoc l) = toJSON l
+instance ToJSON (SomeLocWithVars m) where
+ toJSON (SomeGLoc l) = toJSON l
+
+-- | 'SomeLoc' turned into something that can be hashed
+newtype SomeHashableLocs = SomeHashableLocs [Value]
+ -- TODO: We go through Aeson.Value representation of the locations to update
+ -- the hash. That's not terribly efficient, we should measure if that's a
+ -- problem.
+
+instance (Monad m) => ContentHashable m SomeHashableLocs where
+ contentHashUpdate ctx (SomeHashableLocs vals) = contentHashUpdate ctx vals
+
+toHashableLocs :: [SomeLoc m] -> SomeHashableLocs
+toHashableLocs = SomeHashableLocs . map toJSON
+
+-- * Some helper functions to directly read write/read bytestring into/from
+-- locations
+
+writeLazyByte
+ :: (LocationAccessor m l)
+ => LocOf l
+ -> LBS.ByteString
+ -> m ()
+writeLazyByte loc = writeBSS loc . BSS.fromLazy
+
+-- The following functions are DEPRECATED, because converting to a lazy
+-- ByteString with BSS.toLazy_ isn't actually lazy
+
+readLazyByte
+ :: (LocationAccessor m l)
+ => LocOf l
+ -> m LBS.ByteString
+readLazyByte loc = readBSS loc BSS.toLazy_
+
+readText
+ :: (LocationAccessor m l)
+ => LocOf l
+ -> m T.Text
+readText loc =
+ LT.toStrict . LTE.decodeUtf8 <$> readLazyByte loc
+
+writeText
+ :: (LocationAccessor m l)
+ => LocOf l
+ -> T.Text
+ -> m ()
+writeText loc = writeBSS loc . BSS.fromStrict . TE.encodeUtf8
+
+
+-- * Base contexts, providing LocationAccessor to local filesystem resources
+
+type BasePorcupineContexts =
+ '[ "katip" ::: ContextFromName "katip"
+ , "resource" ::: ContextFromName "resource" ]
+
+-- | Use it as the base of the record you give to 'runPipelineTask'. Use '(:&)'
+-- to stack other contexts and LocationAccessors on top of it
+baseContexts topNamespace =
+ #katip <-- ContextRunner (runLogger topNamespace maxVerbosityLoggerScribeParams)
+ :& #resource <-- useResource
+ :& RNil
+
+-- | Like 'baseContext' but allows you to set the 'LoggerScribeParams'. Useful
+-- when no CLI is used (see 'NoConfig' and 'ConfigFileOnly')
+baseContextsWithScribeParams topNamespace scribeParams =
+ #katip <-- ContextRunner (runLogger topNamespace scribeParams)
+ :& #resource <-- useResource
+ :& RNil
+
+-- * Parsing and resolving locations, tying them to one LocationAccessor
+
+-- | The context in which aeson Values can be resolved to actual Locations
+type LocResolutionM m = ReaderT (AvailableAccessors m) m
+
+newtype ErrorsFromAccessors = ErrorsFromAccessors Object
+ deriving (ToObject, ToJSON)
+instance LogItem ErrorsFromAccessors where
+ payloadKeys _ _ = AllKeys
+
+errsFromAccs :: Object -> ErrorsFromAccessors
+errsFromAccs = ErrorsFromAccessors . HM.singleton "errorsFromAccessors" . Object
+
+-- | Finds in the accessors list a way to parse a list of JSON values that
+-- should correspond to some `LocOf l` type
+withParsedLocsWithVars
+ :: (LogThrow m)
+ => [Value]
+ -> (forall l. (LocationAccessor m l)
+ => [LocWithVarsOf l] -> LocResolutionM m r)
+ -> LocResolutionM m r
+withParsedLocsWithVars aesonVals f = do
+ AvailableAccessors allAccessors <- ask
+ case allAccessors of
+ [] -> throwWithPrefix $ "List of accessors is empty"
+ _ -> return ()
+ loop allAccessors mempty
+ where
+ showJ = LT.unpack . LT.intercalate ", " . map (LTE.decodeUtf8 . encode)
+ loop [] errCtxs =
+ katipAddContext (errsFromAccs errCtxs) $
+ throwWithPrefix $ "Location(s) " ++ showJ aesonVals
+ ++ " cannot be used by the location accessors in place."
+ loop (SomeLocationAccessor (lbl :: Label l) : accs) errCtxs =
+ case mapM fromJSON aesonVals of
+ Success a -> f (a :: [LocWithVarsOf l])
+ Error e -> loop accs (errCtxs <>
+ HM.singleton (T.pack $ symbolVal lbl) (String $ T.pack e))
+
+-- | Finds in the accessors list a way to parse a list of JSON values that
+-- should correspond to some `LocOf l` type
+withParsedLocs :: (LogThrow m)
+ => [Value]
+ -> (forall l. (LocationAccessor m l)
+ => [LocOf l] -> LocResolutionM m r)
+ -> LocResolutionM m r
+withParsedLocs aesonVals f = do
+ AvailableAccessors allAccessors <- ask
+ case allAccessors of
+ [] -> throwWithPrefix $ "List of accessors is empty"
+ _ -> return ()
+ loop allAccessors mempty
+ where
+ showJ = LT.unpack . LT.intercalate ", " . map (LTE.decodeUtf8 . encode)
+ loop [] errCtxs =
+ katipAddContext (errsFromAccs errCtxs) $
+ throwWithPrefix $ "Location(s) " ++ showJ aesonVals
+ ++ " cannot be used by the location accessors in place."
+ loop (SomeLocationAccessor (lbl :: Label l) : accs) errCtxs =
+ case mapM fromJSON aesonVals of
+ Success a -> f (a :: [LocOf l])
+ Error e -> loop accs (errCtxs <>
+ HM.singleton (T.pack $ symbolVal lbl) (String $ T.pack e))
+
+-- | The string will be parsed as a YAML value. It can be a simple string or the
+-- representation used by some location acccessor. Every accessor will be
+-- tried. Will fail if no accessor can handle the YAML value.
+resolveYamlDocToSomeLoc
+ :: (LogThrow m)
+ => String
+ -> LocResolutionM m (SomeLoc m)
+resolveYamlDocToSomeLoc doc = do
+ val <- Y.decodeThrow $ TE.encodeUtf8 $ T.pack doc
+ withParsedLocs [val] $ \[l] -> return $ SomeGLoc l
+
+-- | For locations which can be expressed as a simple String. The path will be
+-- used as a JSON string. Will fail if no accessor can handle the path.
+resolvePathToSomeLoc
+ :: (LogThrow m)
+ => FilePath
+ -> LocResolutionM m (SomeLoc m)
+resolvePathToSomeLoc p =
+ withParsedLocs [String $ T.pack p] $ \[l] -> return $ SomeGLoc l
diff --git a/src/Data/Locations/FunflowRemoteCache.hs b/src/Data/Locations/FunflowRemoteCache.hs
new file mode 100644
index 0000000..d501db2
--- /dev/null
+++ b/src/Data/Locations/FunflowRemoteCache.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.Locations.FunflowRemoteCache
+ ( locationCacher
+ , LiftCacher(..)
+ ) where
+
+import Control.Exception.Safe
+import Control.Funflow.ContentHashable (ContentHash, hashToPath)
+import qualified Control.Funflow.RemoteCache as Remote
+import Control.Lens
+import Control.Monad.Trans
+import Data.Bifunctor (first)
+import Data.Locations.Accessors
+import Data.Locations.Loc
+import Katip
+import Path (toFilePath)
+import System.FilePath (dropTrailingPathSeparator)
+
+
+hashToFilePath :: ContentHash -> FilePath
+hashToFilePath = dropTrailingPathSeparator . toFilePath . hashToPath
+
+newtype LocationCacher m = LocationCacher (SomeLoc m)
+
+tryS :: (MonadCatch m) => m a -> m (Either String a)
+tryS = fmap (over _Left (displayException :: SomeException -> String)) . try
+
+instance (KatipContext m)
+ => Remote.Cacher m (LocationCacher m) where
+ push (LocationCacher (SomeGLoc rootLoc)) = Remote.pushAsArchive aliasPath $ \hash body -> do
+ let loc = rootLoc `addSubdirToLoc` hashToFilePath hash
+ katipAddNamespace "remoteCacher" $ logFM DebugS $ logStr $
+ "Writing to file " ++ show loc
+ writeLazyByte loc body
+ pure Remote.PushOK
+ where
+ aliasPath from_ to_ = first show <$> tryS
+ (copy
+ (rootLoc `addSubdirToLoc` hashToFilePath from_)
+ (rootLoc `addSubdirToLoc` hashToFilePath to_))
+ pull (LocationCacher (SomeGLoc rootLoc)) = Remote.pullAsArchive $ \hash ->
+ katipAddNamespace "remoteCacher" $ do
+ let loc = rootLoc `addSubdirToLoc` hashToFilePath hash
+ readResult <- tryS $ readLazyByte loc
+ case readResult of
+ Right bs -> do
+ logFM DebugS $ logStr $ "Found in remote cache " ++ show loc
+ return $ Remote.PullOK bs
+ Left err -> do
+ katipAddContext (sl "errorFromRemoteCache" err) $
+ logFM DebugS $ logStr $ "Not in remote cache " ++ show loc
+ return $ Remote.PullError err
+
+locationCacher :: Maybe (SomeLoc m) -> Maybe (LocationCacher m)
+locationCacher = fmap LocationCacher
+
+newtype LiftCacher cacher = LiftCacher cacher
+
+instance (MonadTrans t, Remote.Cacher m cacher, Monad (t m)) =>
+ Remote.Cacher (t m) (LiftCacher cacher) where
+ push (LiftCacher c) hash hash2 path = lift $ Remote.push c hash hash2 path
+ pull (LiftCacher c) hash path = lift $ Remote.pull c hash path
diff --git a/src/Data/Locations/Loc.hs b/src/Data/Locations/Loc.hs
new file mode 100644
index 0000000..1cc9c7c
--- /dev/null
+++ b/src/Data/Locations/Loc.hs
@@ -0,0 +1,381 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StaticPointers #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# OPTIONS_GHC -Wall #-}
+
+module Data.Locations.Loc where
+
+import Control.Applicative
+import Control.Funflow.ContentHashable
+import Control.Lens
+import Control.Monad (foldM)
+import Data.Aeson
+import Data.Binary (Binary)
+import Data.Char (toLower)
+import qualified Data.HashMap.Strict as HM
+import Data.Locations.LocVariable
+import Data.Representable
+import Data.Store (Store)
+import Data.String
+import qualified Data.Text as T
+import Data.Typeable
+import GHC.Generics (Generic)
+import qualified Network.URL as URL
+import qualified System.Directory as Dir (createDirectoryIfMissing)
+import qualified System.FilePath as Path
+
+
+-- | Each location bit can be a simple chunk of string, or a variable name
+-- waiting to be spliced in.
+data StringOrVariable
+ = SoV_String FilePath -- ^ A raw filepath part, to be used as is
+ | SoV_Variable LocVariable -- ^ A variable name
+ deriving (Eq, Generic, ToJSON, FromJSON, Store)
+
+instance Show StringOrVariable where
+ show (SoV_String s) = s
+ show (SoV_Variable (LocVariable v)) = "{" ++ v ++ "}"
+
+locBitContent :: Lens' StringOrVariable String
+locBitContent f (SoV_String p) = SoV_String <$> f p
+locBitContent f (SoV_Variable (LocVariable v)) = SoV_Variable . LocVariable <$> f v
+
+-- | A newtype so that we can redefine the Show instance
+newtype StringWithVars = StringWithVars [StringOrVariable]
+ deriving (Generic, Store)
+
+instance Semigroup StringWithVars where
+ StringWithVars l1 <> StringWithVars l2 = StringWithVars $ concatSoV_Strings $ l1++l2
+instance Monoid StringWithVars where
+ mempty = StringWithVars []
+
+instance Show StringWithVars where
+ show (StringWithVars l) = concatMap show l
+
+-- | Get all the variable names still in the loc string and possibly replace
+-- them.
+locStringVariables :: Traversal' StringWithVars StringOrVariable
+locStringVariables f (StringWithVars bits) = StringWithVars . concatSoV_Strings <$> traverse f' bits
+ where f' c@SoV_String{} = pure c
+ f' c@SoV_Variable{} = f c
+
+-- | Ensures 2 consecutive chunks are concatenated together
+concatSoV_Strings :: [StringOrVariable] -> [StringOrVariable]
+concatSoV_Strings (SoV_String p1 : SoV_String p2 : rest) =
+ concatSoV_Strings (SoV_String (p1++p2) : rest)
+concatSoV_Strings (x : rest) = x : concatSoV_Strings rest
+concatSoV_Strings [] = []
+
+data PathWithExtension a = PathWithExtension { _pathWithoutExt :: a, _pathExtension :: String }
+ deriving (Eq, Ord, Generic, ToJSON, FromJSON, Functor, Foldable, Traversable, Binary, Store)
+
+instance (Monad m, ContentHashable m a) => ContentHashable m (PathWithExtension a)
+
+makeLenses ''PathWithExtension
+
+firstNonEmptyExt :: String -> String -> String
+firstNonEmptyExt "" b = b
+firstNonEmptyExt a _ = a
+
+instance (Semigroup a) => Semigroup (PathWithExtension a) where
+ -- Concats the filepaths /without considering extension/ and then chooses one
+ -- non-empty extension, right-biased.
+ PathWithExtension p e <> PathWithExtension p' e' =
+ PathWithExtension (p<>p') $ firstNonEmptyExt e' e
+instance (Monoid a) => Monoid (PathWithExtension a) where
+ mempty = PathWithExtension mempty ""
+
+-- | Turns the 'PathWithExtension' to/from a simple string to be used as is.
+pathWithExtensionAsRawFilePath :: (IsLocString a) => Iso' (PathWithExtension a) FilePath
+pathWithExtensionAsRawFilePath = iso to_ from_
+ where
+ to_ (PathWithExtension p e) = case e of
+ "" -> p'
+ _ -> p'++"."++e
+ where p' = p ^. locStringAsRawString
+ from_ fp = let (p,e) = splitExtension' fp
+ in PathWithExtension (p ^. from locStringAsRawString) e
+
+instance (IsLocString a) => IsString (PathWithExtension a) where
+ fromString p = p ^. from pathWithExtensionAsRawFilePath
+
+instance (IsLocString a) => Show (PathWithExtension a) where
+ show p = fmap (view locStringAsRawString) p ^. pathWithExtensionAsRawFilePath
+
+data QParam a = QParam a a
+ deriving (Eq, Ord, Generic, Functor, Foldable, Traversable, Binary, Store)
+
+instance (Monad m, ContentHashable m a) => ContentHashable m (QParam a)
+
+instance (IsLocString a) => Show (QParam a) where
+ show = show . view (from asQParam)
+
+asQParam :: (IsLocString a) => Iso' (String,String) (QParam a)
+asQParam = iso to_ from_
+ where
+ to_ (x,y) = QParam (x ^. from locStringAsRawString) (y ^. from locStringAsRawString)
+ from_ (QParam x y) = (x ^. locStringAsRawString, y ^. locStringAsRawString)
+
+-- | Location's main type. A value of type 'URL' denotes a file or a
+-- folder that may be local or hosted remotely
+data URL a
+ = LocalFile { filePath :: PathWithExtension a }
+ | RemoteFile { rfProtocol :: String
+ , rfServerName :: String
+ , rfPortNumber :: Maybe Integer
+ , rfPathWithExtension :: PathWithExtension a
+ , rfLocParams :: [QParam a] }
+ deriving ( Eq, Ord, Generic
+ , Functor, Foldable, Traversable, Binary, Store )
+
+instance (Monad m, Typeable a, ContentHashable m a) => ContentHashable m (URL a)
+
+instance (IsLocString a) => Show (URL a) where
+ show LocalFile{ filePath } = show filePath
+ show RemoteFile{ rfProtocol, rfServerName, rfPathWithExtension, rfPortNumber, rfLocParams } =
+ rfProtocol ++ "://" ++ rfServerName ++ port ++ "/" ++ show rfPathWithExtension ++ qs
+ where
+ port = case rfPortNumber of
+ Nothing -> ""
+ Just p -> ":" <> show p
+ qs = case rfLocParams of
+ [] -> ""
+ _ -> "?" ++ URL.exportParams (map (view (from asQParam)) rfLocParams)
+
+urlPathWithExtension :: Lens' (URL a) (PathWithExtension a)
+urlPathWithExtension f (LocalFile fp) = LocalFile <$> f fp
+urlPathWithExtension f RemoteFile{rfPathWithExtension=fp,..} =
+ (\fp' -> RemoteFile{rfPathWithExtension=fp',..}) <$> f fp
+
+-- | A 'URL' that might contain some named holes, called variables, that we
+-- have first to replace by a value before we can get a definite physical
+-- location.
+type LocWithVars = URL StringWithVars
+
+-- | A 'URL' that can directly be accessed as is.
+type Loc = URL String
+
+type LocalFilePath = PathWithExtension String
+
+-- | Creates a 'Loc' from a simple litteral string
+localFile :: FilePath -> Loc
+localFile s = LocalFile $ s ^. from pathWithExtensionAsRawFilePath
+
+-- | Creates a 'LocWithVars' that will only contain a chunk, no variables
+locWithVarsFromLoc :: (Functor f) => f String -> f StringWithVars
+locWithVarsFromLoc = fmap (StringWithVars . (:[]) . SoV_String)
+
+-- | A map that can be used to splice variables in a 'LocWithVars'
+type LocVariableMap = HM.HashMap LocVariable String
+
+-- | Splices in the variables present in the hashmap
+spliceLocVariables :: (Functor f) => LocVariableMap -> f StringWithVars -> f StringWithVars
+spliceLocVariables vars = fmap $ over locStringVariables $ \v -> case v of
+ SoV_Variable vname ->
+ case HM.lookup vname vars of
+ Just val -> SoV_String val
+ Nothing -> v
+ _ -> error "spliceLocVariables: Should not happen"
+
+-- | Yields @Left _@ if any of the given StringWithVars contains variables.
+terminateLocWithVars :: (Traversable f) => f StringWithVars -> Either String (f String)
+terminateLocWithVars = traverse terminateStringWithVars
+ where
+ terminateStringWithVars (StringWithVars [SoV_String s]) = Right s
+ terminateStringWithVars locString = Left $
+ "Variable(s) " ++ show (locString ^.. locStringVariables)
+ ++ " in '" ++ show locString ++ "' haven't been given a value"
+
+-- | Means that @a@ can represent file paths
+class (Monoid a) => IsLocString a where
+ locStringAsRawString :: Iso' a String
+ parseLocString :: String -> Either String a
+
+parseLocStringAndExt :: (IsLocString a) => String -> Either String (PathWithExtension a)
+parseLocStringAndExt s =
+ PathWithExtension <$> parseLocString p <*> refuseVarRefs "extension" e
+ where (p, e) = splitExtension' s
+
+splitExtension' :: FilePath -> (FilePath, String)
+splitExtension' fp = let (f,e) = Path.splitExtension fp in
+ case e of '.':e' -> (f,e')
+ _ -> (f,e)
+
+instance IsLocString String where
+ locStringAsRawString = id
+ parseLocString = Right
+
+parseStringWithVars :: String -> Either String StringWithVars
+parseStringWithVars s = (StringWithVars . reverse . map (over locBitContent reverse) . filter isFull)
+ <$> foldM oneChar [] s
+ where
+ oneChar (SoV_Variable _ : _) '{' = Left "Cannot nest {...}"
+ oneChar acc '{' = return $ SoV_Variable (LocVariable "") : acc
+ oneChar (SoV_String _ : _) '}' = Left "'}' terminates nothing"
+ oneChar acc '}' = return $ SoV_String "" : acc
+ oneChar (hd : rest) c = return $ over locBitContent (c:) hd : rest
+ oneChar [] c = return [SoV_String [c]]
+
+ isFull (SoV_String "") = False
+ isFull _ = True
+
+-- | @refuseVarRefs p s == Right s@ if `s` contains no variables.
+-- Otherwise, yields an error message.
+refuseVarRefs :: String -> String -> Either String String
+refuseVarRefs place s = do
+ l <- parseStringWithVars s
+ case l of
+ (StringWithVars []) -> return ""
+ (StringWithVars [SoV_String p]) -> return p
+ _ -> Left $ "Variable references {...} are not allowed in the " ++ place ++ " part of a URL"
+
+instance IsLocString StringWithVars where
+ locStringAsRawString = iso show from_
+ where from_ s = StringWithVars [SoV_String s]
+ parseLocString = parseStringWithVars
+
+-- | The main way to parse an 'URL'. Variables are not allowed in the protocol
+-- and server parts.
+parseURL :: (IsLocString a) => String -> Either String (URL a)
+parseURL "." = Right $ LocalFile $ PathWithExtension ("." ^. from locStringAsRawString) ""
+parseURL litteralPath = do
+ url <- maybe (Left $ "parseURL: Invalid URL '" ++ litteralPath ++ "'") Right $
+ URL.importURL litteralPath
+ case URL.url_type url of
+ URL.Absolute h ->
+ RemoteFile <$> (refuseVarRefs "protocol" $ getProtocol $ URL.protocol h)
+ <*> (refuseVarRefs "server" $ URL.host h)
+ <*> (Right $ URL.port h)
+ <*> (parseLocStringAndExt $ URL.url_path url)
+ <*> (map (uncurry QParam) <$>
+ mapMOf (traversed.both) parseLocString (URL.url_params url))
+ URL.HostRelative -> LocalFile <$> (parseLocStringAndExt $ "/" ++ URL.url_path url)
+ URL.PathRelative -> LocalFile <$> (parseLocStringAndExt $ URL.url_path url)
+ where getProtocol (URL.RawProt h) = map toLower h
+ getProtocol (URL.HTTP False) = "http"
+ getProtocol (URL.HTTP True) = "https"
+ getProtocol (URL.FTP False) = "ftp"
+ getProtocol (URL.FTP True) = "ftps"
+
+instance (IsLocString a) => IsString (URL a) where
+ fromString s = case parseURL s of
+ Right l -> l
+ Left e -> error e
+
+instance (IsLocString a) => Representable (PathWithExtension a) where
+ toTextRepr = T.pack . show
+ fromTextRepr x = case parseLocStringAndExt $ T.unpack x of
+ Left _ -> empty
+ Right x' -> pure x'
+
+instance (IsLocString a) => Representable (URL a) where
+ toTextRepr = T.pack . show
+ fromTextRepr x = case parseURL $ T.unpack x of
+ Left _ -> empty
+ Right x' -> pure x'
+
+instance (IsLocString a) => FromJSON (URL a) where
+ parseJSON (String j) = fromTextRepr j
+ parseJSON _ = fail "URL must be read from a JSON String"
+
+instance (IsLocString a) => ToJSON (URL a) where
+ toJSON = String . toTextRepr
+
+-- | The equivalent of </> from `filepath` package on 'PathWithExtension's
+appendToPathWithExtensionAsSubdir :: (IsLocString a) => PathWithExtension a -> String -> PathWithExtension a
+fp `appendToPathWithExtensionAsSubdir` s = view (from pathWithExtensionAsRawFilePath) $
+ (fp^.pathWithExtensionAsRawFilePath) Path.</> s
+
+-- | Appends a path to a location. The Loc is considered to be a folder, so its
+-- possible extension will be /ignored/.
+(</>) :: (IsLocString a) => URL a -> String -> URL a
+f </> p = f & over urlPathWithExtension (`appendToPathWithExtensionAsSubdir` p)
+infixl 4 </>
+
+-- | Alias for '</>'
+(<//>) :: (IsLocString a) => URL a -> String -> URL a
+(<//>) = (</>)
+infixl 4 <//>
+
+-- | Replaces a Loc extension
+(-<.>) :: Loc -> String -> Loc
+f -<.> ext = f & urlPathWithExtension . pathExtension .~ ext
+infixl 3 -<.>
+
+-- | Initialises a directory from a Loc to it, so that we can safely write in it
+-- afterwards. For a local filesystem, this means creating it.
+initDir :: Loc -> IO ()
+initDir f@LocalFile{} =
+ Dir.createDirectoryIfMissing True $ f ^. urlPathWithExtension . pathWithoutExt
+initDir _ = pure ()
+
+-- | Analog to 'Path.takeDirectory' for generalized locations
+takeDirectory :: Loc -> Loc
+takeDirectory = over (urlPathWithExtension . pathWithoutExt) Path.takeDirectory . dropExtension
+
+-- | Analog of 'Path.dropExtension'
+dropExtension :: URL a -> URL a
+dropExtension f = f & urlPathWithExtension . pathExtension .~ ""
+
+-- | The class of all locations that can be mapped to VirtualFiles in a
+-- configuration file.
+class (Traversable f
+ -- Just ensure that `forall a. (IsLocString a) => (FromJSON (f a),
+ -- ToJSON (f a))`:
+ ,FromJSON (f String), FromJSON (f StringWithVars)
+ ,ToJSON (f String), ToJSON (f StringWithVars)
+ -- `forall a. (IsLocString a) => (Show (f a))`:
+ ,Show (f String), Show (f StringWithVars)) => TypedLocation f where
+
+ -- TODO: Find a way to replace get/setLocType by a Lens. This displeased
+ -- GeneralizedNewtypeDeriving when making LocationAccessor and trying to
+ -- automatically derived instances of TypedLocation
+ getLocType :: f a -> String
+
+ -- | Access the file type part of a location
+ --
+ -- For locations that encode types as extensions, this would access the
+ -- extension. But for others (like HTTP urls), locType would probably need to
+ -- translate it first to a mime type, or some other implementation-specific
+ -- way to to represent resource types
+ setLocType :: f a -> (String -> String) -> f a
+
+ -- | Use the location as a directory and append a "subdir" to it. Depending on
+ -- the implementation this "subdir" relationship can only be semantic (the
+ -- result doesn't have to physically be a subdirectory of the input)
+ --
+ -- Note: this isn't a path, the subdir shouldn't contain any slashes
+ addSubdirToLoc :: (IsLocString a) => f a -> String -> f a
+
+ -- | Apply a mapping shortcut (represented as a partial file path, with its
+ -- extension) to the location. For now, non URL-based locations should send an
+ -- error
+ --
+ -- Note: contrary to 'addSubdirToLoc', the 'PathWithExtension' MAY contain
+ -- slashes
+ useLocAsPrefix :: (IsLocString a) => f a -> PathWithExtension a -> f a
+
+instance TypedLocation URL where
+ setLocType l f = l & over (urlPathWithExtension . pathExtension) f
+ getLocType = view (urlPathWithExtension . pathExtension)
+ addSubdirToLoc = (</>)
+ useLocAsPrefix l p = l & over urlPathWithExtension (<> p)
+
+-- | Sets the file type of a location
+overrideLocType :: (TypedLocation f) => f a -> String -> f a
+overrideLocType loc newExt = setLocType loc (newExt `firstNonEmptyExt`)
+
+-- | Sets the file type of a location unless it already has one
+setLocTypeIfMissing :: (TypedLocation f) => f a -> String -> f a
+setLocTypeIfMissing loc newExt = setLocType loc (`firstNonEmptyExt` newExt)
diff --git a/src/Data/Locations/LocVariable.hs b/src/Data/Locations/LocVariable.hs
new file mode 100644
index 0000000..760a20f
--- /dev/null
+++ b/src/Data/Locations/LocVariable.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Data.Locations.LocVariable where
+
+import Data.Aeson
+import Data.Hashable (Hashable)
+import Data.Store (Store)
+import Data.String
+
+
+-- | Just a variable name
+newtype LocVariable = LocVariable { unLocVariable :: String }
+ deriving (IsString, Show, ToJSON, FromJSON, Eq, Hashable
+ ,FromJSONKey, ToJSONKey, Store)
diff --git a/src/Data/Locations/LocationTree.hs b/src/Data/Locations/LocationTree.hs
new file mode 100644
index 0000000..f26c692
--- /dev/null
+++ b/src/Data/Locations/LocationTree.hs
@@ -0,0 +1,283 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# OPTIONS_GHC -Wall #-}
+{-# LANGUAGE DataKinds #-}
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
+
+-- | Abstraction layer around the filesystem, so that inputs and outputs may be
+-- redirected to various files without the logic code having to know.
+module Data.Locations.LocationTree
+ (
+ -- * Types
+ LocationTree(..)
+ , LocationTreePathItem(..), LocationTreePath(..)
+ , LTPIAndSubtree(..)
+ , (:||)(..), _Unprioritized, _Prioritized
+ -- * Functions
+ , locTreeNodeTag, locTreeSubfolders
+ , inLocTree
+ , allSubLocTrees, traversedTreeWithPath
+ , atSubfolder, atSubfolderRec
+ , filteredLocsInTree
+ , subtractPathFromTree
+ , singLTP
+ , showLTPIName
+ , ltpiName
+ , locNode, folderNode, fileEmpty, file
+ , splitLocTree, joinLocTrees
+ , locTreeToDataTree
+ , prettyLocTree
+ , apLocationTree
+ , showLTP
+ )
+where
+
+import Control.Applicative
+import Control.Lens
+import Data.Aeson
+import Data.Binary
+import Data.Hashable
+import qualified Data.HashMap.Strict as HM
+import Data.List
+import Data.Maybe
+import Data.Representable
+import Data.String
+import qualified Data.Text as T
+import qualified Data.Tree as DT
+import GHC.Generics (Generic)
+-- import Data.Tree.Pretty
+-- import Diagrams.TwoD.Layout.Tree
+
+
+-- | A very simple virtual filesystem. Defines a hierarchy of virtual locations,
+-- and some rules for how to store and read files. Each type of pipeline
+-- (solving, exploration) will need its 'LocationTree', that can be obtained by
+-- composing the 'LocationTree's of the tasks it contains.
+--
+-- In a project using pipeline-tools, the project's code will only use virtual
+-- paths, and it won't know what actual physical location is behind that path.
+--
+-- We could use a DocRecord to represent a LocationTree. Maybe we'll refactor it
+-- to use DocRecords in the future, but for now it was simpler to use a simple
+-- tree of maps.
+data LocationTree a = LocationTree
+ { _locTreeNodeTag :: a -- ^ In the case of a 'BareLocationTree', indicates
+ -- the prefered serialization method of the content
+ -- of that node. If that node is a folder, the
+ -- serialization method can mean that its content
+ -- will be packed at a single place (for instance
+ -- one table in a database to group several virtual
+ -- JSON files)
+ , _locTreeSubfolders :: HM.HashMap LocationTreePathItem (LocationTree a)
+ -- ^ The content of the node. Is empty for a terminal file.
+ }
+ deriving (Eq, Show, Functor, Foldable, Traversable)
+
+instance (Monoid a) => Monoid (LocationTree a) where
+ mempty = LocationTree mempty mempty
+
+instance (Semigroup a) => Semigroup (LocationTree a) where
+ LocationTree m1 s1 <> LocationTree m2 s2 =
+ LocationTree (m1 <> m2) (HM.unionWith (<>) s1 s2)
+
+-- | LocationTree cannot be an applicative because pure cannot construct an
+-- infinite tree (since HashMaps are strict in their keys), but <*> can be
+-- implemented, and a LocationTree is already a Functor. Branches that don't
+-- match are just abandoned.
+apLocationTree :: LocationTree (a -> b) -> LocationTree a -> LocationTree b
+apLocationTree (LocationTree f sub) (LocationTree x sub') = LocationTree (f x) sub''
+ where
+ sub'' = HM.intersectionWith apLocationTree sub sub'
+
+-- | Identifies a folder or file-like object in the 'LocationTree'.
+newtype LocationTreePathItem
+ = LTPI { _ltpiName :: T.Text -- ^ Name of the file or folder
+ -- , _ltpiIsRepeatable :: Bool -- ^ If true, then will correspond to
+ -- -- several files or folders, where _ltpiName
+ -- -- is just a prefix followed by a number
+ -- -- (e.g. patient01, patient02, etc.)
+ -- , _ltpiIsTerminal :: Bool -- ^ If true, is a pure file that must be
+ -- -- deserizalized as a whole
+ }
+ deriving (Eq, Ord, Show, Generic, Hashable, Binary)
+
+showLTPIName :: LocationTreePathItem -> String
+showLTPIName = T.unpack . _ltpiName
+
+singleFolder :: T.Text -> LocationTreePathItem
+singleFolder x = LTPI x -- False False
+
+instance IsString LocationTreePathItem where
+ fromString = singleFolder . T.pack
+
+-- | A path in a 'LocationTree'
+newtype LocationTreePath = LTP [LocationTreePathItem]
+ deriving (Eq, Ord, Show, Generic, Hashable, Binary)
+
+instance Representable LocationTreePath where
+ toTextRepr (LTP l) = mconcat $ "/" : intersperse "/" (map _ltpiName l)
+ fromTextRepr =
+ pure . LTP . map singleFolder . filter (not . T.null) . T.splitOn "/"
+
+showLTP :: LocationTreePath -> String
+showLTP = T.unpack . toTextRepr
+
+instance ToJSON LocationTreePath where
+ toJSON = String . toTextRepr
+
+instance FromJSON LocationTreePath where
+ parseJSON (String t) = fromTextRepr t
+ parseJSON _ = mempty
+
+instance ToJSONKey LocationTreePath
+instance FromJSONKey LocationTreePath
+
+instance Semigroup LocationTreePath where
+ (LTP a) <> (LTP b) = LTP $ a ++ b
+instance Monoid LocationTreePath where
+ mempty = LTP []
+
+singLTP :: LocationTreePathItem -> LocationTreePath
+singLTP = LTP . (:[])
+
+-- | Permits to filter a tree and to remove some nodes
+filteredLocsInTree
+ :: Traversal (LocationTree a) (Maybe (LocationTree b)) a (Maybe b)
+filteredLocsInTree f (LocationTree a sub) =
+ liftA2 LocationTree <$> f a
+ <*> (Just . HM.fromList . catMaybes <$> traverse onSub (HM.toList sub))
+ where
+ onSub (k,t) = fmap (k,) <$> filteredLocsInTree f t
+
+-- | Access or edit a subtree
+inLocTree :: LocationTreePath -> Lens' (LocationTree a) (Maybe (LocationTree a))
+inLocTree path f t = fromJust <$> go path (Just t)
+ where
+ go _ Nothing = f Nothing
+ go (LTP []) mbT = f mbT
+ go (LTP (p:ps)) (Just (LocationTree m s)) = rebuild <$> go (LTP ps) (HM.lookup p s)
+ where
+ rebuild Nothing | HM.null s' = Nothing
+ | otherwise = Just $ LocationTree m s'
+ where s' = HM.delete p s
+ rebuild (Just res) = Just $ LocationTree m $ HM.insert p res s
+
+-- | Find all the subtrees, indexed by their 'LocationTreePath'
+allSubLocTrees
+ :: Traversal (LocationTree a) (LocationTree b)
+ (LocationTreePath, LocationTree a) b
+allSubLocTrees f = go []
+ where go ps n@(LocationTree _ sub) = LocationTree
+ <$> f (LTP $ reverse ps, n)
+ <*> itraverse (\p n' -> go (p:ps) n') sub
+
+-- | Traverse all the nodes, indexed by their 'LocationTreePath'
+traversedTreeWithPath
+ :: Traversal (LocationTree a) (LocationTree b)
+ (LocationTreePath, a) b
+traversedTreeWithPath f = go []
+ where go ps (LocationTree n sub) = LocationTree
+ <$> f (LTP $ reverse ps, n)
+ <*> itraverse (\p n' -> go (p:ps) n') sub
+
+-- | Removes a path from a 'LocationTree'.
+subtractPathFromTree :: LocationTree a -> LocationTreePath -> LocationTree a
+subtractPathFromTree tree path = tree & inLocTree path .~ Nothing
+
+-- | Just a tuple-like type. An entry for the map of contents at some path in a
+-- 'LocationTree'
+data LTPIAndSubtree a = LocationTreePathItem :/ LocationTree a
+ deriving (Eq, Show, Functor, Foldable, Traversable)
+
+infixr 5 :/
+
+locNode :: a -> [LTPIAndSubtree a] -> LocationTree a
+locNode a = LocationTree a . HM.fromList . map (\(x:/y) -> (x,y))
+
+-- | A shortcut for 'locNode' for folders
+folderNode :: (Monoid a) => [LTPIAndSubtree a] -> LocationTree a
+folderNode = locNode mempty
+
+fileEmpty :: (Monoid a)
+ => LocationTreePathItem
+ -> LTPIAndSubtree a
+fileEmpty i = i :/ mempty
+file :: LocationTreePathItem
+ -> a
+ -> LTPIAndSubtree a
+file i a = i :/ LocationTree a mempty
+
+instance (Monoid a) => IsString (LTPIAndSubtree a) where
+ fromString = fileEmpty . fromString
+
+-- | Like Either, but equipped with a Monoid instance that would prioritize Right over Left
+data a :|| b = Unprioritized a | Prioritized b
+infixr 5 :||
+
+instance (Semigroup a, Semigroup b) => Semigroup (a :|| b) where
+ (<>) (Prioritized x) (Prioritized x') = Prioritized (x<>x')
+ (<>) (Unprioritized x) (Unprioritized x') = Unprioritized (x<>x')
+ (<>) p@(Prioritized _) _ = p
+ (<>) _ p@(Prioritized _) = p
+instance (Monoid a, Monoid b) => Monoid (a :|| b) where
+ mempty = Unprioritized mempty
+
+-- | Merges two trees of different node types, prioritizing those of the second
+-- tree when a node exists in both trees
+joinLocTrees
+ :: (Monoid a, Monoid b)
+ => LocationTree a -> LocationTree b -> LocationTree (a :|| b)
+joinLocTrees ta tb = fmap Unprioritized ta <> fmap Prioritized tb
+
+-- | Splits a 'LocationTree' of @a :|| b@ into two trees that will have the same
+-- structure but not the same nodes
+splitLocTree :: LocationTree (a :|| b) -> (LocationTree (Maybe a), LocationTree (Maybe b))
+splitLocTree (LocationTree n sub) = case n of
+ Unprioritized a -> (LocationTree (Just a) subA, LocationTree Nothing subB)
+ Prioritized b -> (LocationTree Nothing subA, LocationTree (Just b) subB)
+ where
+ subA = HM.fromList subAL
+ subB = HM.fromList subBL
+ (subAL, subBL) = unzip $
+ map (\(path, ltree) ->
+ let (na, nb) = splitLocTree ltree
+ in ((path, na), (path, nb)))
+ (HM.toList sub)
+
+makeLenses ''LocationTree
+makeLenses ''LocationTreePathItem
+makePrisms ''(:||)
+
+
+atSubfolder :: Applicative f => LocationTreePathItem -> (LocationTree a -> f (LocationTree a)) -> LocationTree a -> f (LocationTree a)
+atSubfolder pathItem = locTreeSubfolders . at pathItem . _Just
+
+atSubfolderRec :: (Applicative f, Foldable t) => t LocationTreePathItem -> (LocationTree a -> f (LocationTree a)) -> LocationTree a -> f (LocationTree a)
+atSubfolderRec path =
+ foldr (\pathItem subtree -> atSubfolder pathItem . subtree) id path
+
+locTreeToDataTree :: LocationTreePath -> LocationTree b -> DT.Tree (LocationTreePathItem, b)
+locTreeToDataTree (LTP root) t = toCanonicalTree root' t
+ where
+ root' = case root of
+ [] -> "/"
+ _ -> last root
+ toCanonicalTree p (LocationTree n sub) =
+ DT.Node (p,n) $ map (uncurry toCanonicalTree) $ HM.toList sub
+
+prettyLocTree :: (Show a) => LocationTreePath -> LocationTree a -> String
+prettyLocTree root t = DT.drawTree t'
+ where
+ str (p,n) = T.unpack (_ltpiName p) ++ ": " ++ show n
+ t' = str <$> locTreeToDataTree root t
diff --git a/src/Data/Locations/LogAndErrors.hs b/src/Data/Locations/LogAndErrors.hs
new file mode 100644
index 0000000..675ccbe
--- /dev/null
+++ b/src/Data/Locations/LogAndErrors.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | This module contains some helper functions for logging info and throwing
+-- errors
+
+module Data.Locations.LogAndErrors
+ ( module Control.Exception.Safe
+ , KatipContext
+ , LogThrow, LogCatch, LogMask
+ , TaskRunError(..)
+ , logAndThrowM
+ , throwWithPrefix
+ ) where
+
+import Control.Exception.Safe
+import qualified Data.Text as T
+import GHC.Stack
+import Katip
+
+
+-- | An error when running a pipeline of tasks
+newtype TaskRunError = TaskRunError String
+
+instance Show TaskRunError where
+ show (TaskRunError s) = s
+
+instance Exception TaskRunError where
+ displayException (TaskRunError s) = s
+
+getTaskErrorPrefix :: (KatipContext m) => m String
+getTaskErrorPrefix = do
+ Namespace ns <- getKatipNamespace
+ case ns of
+ [] -> return ""
+ _ -> return $ T.unpack $ T.intercalate "." ns <> ": "
+
+-- | Just an alias for monads that can throw errors and log them
+type LogThrow m = (KatipContext m, MonadThrow m, HasCallStack)
+
+-- | Just an alias for monads that can throw,catch errors and log them
+type LogCatch m = (KatipContext m, MonadCatch m)
+
+-- | Just an alias for monads that can throw,catch,mask errors and log them
+type LogMask m = (KatipContext m, MonadMask m)
+
+-- | A replacement for throwM. Logs an error (using displayException) and throws
+logAndThrowM :: (LogThrow m, Exception e) => e -> m a
+logAndThrowM exc = do
+ logFM ErrorS $ logStr $ displayException exc
+ throwM exc
+
+-- | Logs an error and throws a 'TaskRunError'
+throwWithPrefix :: (LogThrow m) => String -> m a
+throwWithPrefix msg = do
+ logFM ErrorS $ logStr msg
+ prefix <- getTaskErrorPrefix
+ throwM $ TaskRunError $ prefix ++ msg
diff --git a/src/Data/Locations/Mappings.hs b/src/Data/Locations/Mappings.hs
new file mode 100644
index 0000000..b469eb6
--- /dev/null
+++ b/src/Data/Locations/Mappings.hs
@@ -0,0 +1,259 @@
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -Wall #-}
+{-# OPTIONS_GHC "-fno-warn-incomplete-uni-patterns" #-}
+
+module Data.Locations.Mappings
+ ( LocationMappings, LocationMappings_(..)
+ , HasDefaultMappingRule(..)
+ , LocShortcut(..), SerializableLocShortcut
+ --, allLocsInMappings
+ , mappingsFromLocTree
+ , mappingRootOnly
+ , insertMappings
+ , propagateMappings
+ , applyMappings
+ ) where
+
+import Control.Arrow ((***))
+import Control.Lens
+import Data.Aeson
+import qualified Data.HashMap.Strict as HM
+import Data.List
+import Data.Locations.Accessors
+import Data.Locations.Loc
+import Data.Locations.LocationTree
+import Data.Locations.LogAndErrors
+import Data.Locations.SerializationMethod (FileExt)
+import Data.Maybe
+import Data.Representable
+import qualified Data.Text as T
+
+
+-- * The 'LocationMappings' type
+
+newtype LocationMappings_ n = LocationMappings_
+ (HM.HashMap LocationTreePath [n])
+ deriving (Functor, Show)
+
+-- | Describes how physical locations are mapped to an application's
+-- LocationTree. This is the type that is written to the pipeline yaml config
+-- file under the "locations" section.
+type LocationMappings = LocationMappings_ SerializableLocShortcut
+
+instance Monoid (LocationMappings_ n) where
+ mempty = LocationMappings_ mempty
+
+instance Semigroup (LocationMappings_ n) where
+ (LocationMappings_ m) <> (LocationMappings_ m') = LocationMappings_ $
+ HM.unionWith (++) m m'
+
+instance (ToJSON n) => ToJSON (LocationMappings_ n) where
+ toJSON (LocationMappings_ m) = Object $ HM.fromList $
+ map (toTextRepr *** layersToJSON) $ HM.toList m
+ where
+ layersToJSON [] = Null
+ layersToJSON [l] = toJSON l
+ layersToJSON layers = toJSON layers
+
+instance FromJSON LocationMappings where
+ parseJSON (Object m) = LocationMappings_ . HM.fromList <$>
+ mapM (\(k, v) -> (,) <$> fromTextRepr k <*> parseJSONLayers v) (HM.toList m)
+ where
+ parseJSONLayers Null = pure []
+ parseJSONLayers j@Array{} = parseJSON j
+ parseJSONLayers j = (:[]) <$> parseJSON j
+ parseJSON _ = mempty
+
+-- -- | Lists all the physical paths that have been associated to some virtual
+-- -- location
+-- allLocsInMappings :: LocationMappings -> [LocWithVars]
+-- allLocsInMappings (LocationMappings_ m) =
+-- [ loc
+-- | (_,layers) <- HM.toList m, FullySpecifiedLoc loc <- layers ]
+
+
+-- * How to get pre-filled defaut mappings from an existing LocationTree
+
+-- | Means that we can possibly derive a default @LocShortcut@ from @a@
+class HasDefaultMappingRule a where
+ getDefaultLocShortcut :: a -> Maybe (LocShortcut x)
+ -- ^ Nothing means that the @a@ should not be mapped by default
+
+-- | Pre-fills the mappings from the context of a 'LocationTree', with extra
+-- metadata saying whether each node should be explicitely mapped or unmapped.
+mappingsFromLocTree :: (HasDefaultMappingRule a) => LocationTree a -> LocationMappings
+mappingsFromLocTree (LocationTree node subtree) | HM.null subtree =
+ LocationMappings_ $
+ HM.singleton (LTP [])
+ (case getDefaultLocShortcut node of
+ Just shortcuts -> [shortcuts]
+ Nothing -> [])
+mappingsFromLocTree (LocationTree _ sub) =
+ LocationMappings_ (mconcat $ map f $ HM.toList sub)
+ where
+ f (ltpi, t) =
+ HM.fromList $ map appendPath $ HM.toList m
+ where
+ appendPath (LTP path, maps) = (LTP $ ltpi : path, maps)
+ LocationMappings_ m = mappingsFromLocTree t
+
+-- | Creates a 'LocationMappings_' where the whole LocationTree is mapped to a
+-- single folder
+mappingRootOnly :: Loc -> LocationMappings
+mappingRootOnly l = LocationMappings_ $
+ HM.singleton (LTP [])
+ [FullySpecifiedLoc $ toJSON $ locWithVarsFromLoc l]
+
+
+-- * How to parse mappings to and from JSON
+
+-- | A location with variables where some parts may have been eluded
+data LocShortcut a
+ = DeriveWholeLocFromTree FileExt
+ -- ^ Means that this loc path and name should be inherited from locs up the
+ -- virtual tree.
+ | DeriveLocPrefixFromTree (PathWithExtension StringWithVars)
+ -- ^ Means that this loc path should be inherited from locs up the resource
+ -- tree. Its name should be a concatenation of the corresponding name in the
+ -- tree and the PathWithExtension provided
+ | FullySpecifiedLoc a
+ -- ^ Means that this shortcut is a full location
+ deriving (Show)
+
+-- | A 'LocShorcut' where fully specified locs are aeson Values ready to be
+-- parsed by some LocationAccessor. It is parsed from the mappings in the
+-- configuration file.
+type SerializableLocShortcut = LocShortcut Value
+
+-- | A 'LocShortcut' where fully specified locs have been parsed, and resolved
+-- to be tied to some specific LocationAccessor. It isn't serializable in JSON,
+-- hence the separation between this and 'SerializableLocShortcut'.
+type ResolvedLocShortcut m = LocShortcut (SomeLocWithVars m)
+
+ -- The underscore sign here means "reuse inherited", depending on the
+ -- position it can mean either file path or extension or both.
+instance ToJSON SerializableLocShortcut where
+ toJSON (DeriveWholeLocFromTree ext) = String $ case ext of
+ "" -> "_"
+ _ -> "_." <> ext
+ toJSON (DeriveLocPrefixFromTree l) = String $ "_" <> toTextRepr l
+ toJSON (FullySpecifiedLoc v) = v
+
+instance FromJSON SerializableLocShortcut where
+ parseJSON (String "_") = pure $ DeriveWholeLocFromTree ""
+ parseJSON (String (T.uncons -> Just ('_', s))) = case parseLocStringAndExt $ T.unpack s of
+ Left e -> fail e
+ Right r -> pure $ DeriveLocPrefixFromTree r
+ parseJSON v = pure $ FullySpecifiedLoc v
+
+-- * How to apply mappings to a LocationTree to get the physical locations bound
+-- to each of its nodes
+
+-- | Returns a new 'LocationTree', updated from the mappings. Paths in the
+-- 'LocationMappings_' that don't correspond to anything in the 'LocationTree'
+-- will just be ignored
+insertMappings
+ :: LocationMappings
+ -> LocationTree a
+ -> LocationTree (a, Maybe [SerializableLocShortcut])
+insertMappings (LocationMappings_ m) tree = foldl' go initTree $ HM.toList m
+ where
+ initTree = fmap (,Nothing) tree
+ -- By defaut, each node is set to "no mapping defined"...
+ go t (path, layers) = t &
+ inLocTree path . _Just . locTreeNodeTag . _2 .~ Just layers
+ -- ...then we update the tree for each mapping present in the
+ -- LocationMappings
+
+-- | For each location in the tree, gives it a final list of physical locations,
+-- as /layers/ (which can be empty)
+propagateMappings :: forall m a b.
+ ([SomeLocWithVars m] -> a -> Bool -> b)
+ -> LocationTree (a, Maybe [ResolvedLocShortcut m])
+ -> LocationTree b
+propagateMappings f tree = propagateMappings' [] tree
+ where
+ -- if a folder is explicitly set to null (ie if no layer exist for this
+ -- folder), then we recursively unmap everything is contains, ignoring every
+ -- submapping that might exist:
+ propagateMappings' _ t@(LocationTree (_, Just []) _) = fmap unmap t
+ where unmap (n, _) = f [] n True
+ -- if a folder is mapped, we propagate the mapping downwards:
+ propagateMappings' inheritedLayers (LocationTree (thisNode, mbTheseMappings) thisSub) =
+ LocationTree thisNode' $ imap recur thisSub
+ where
+ theseLayers = applyInheritedLayersToShortcuts inheritedLayers mbTheseMappings
+ thisNode' = f theseLayers thisNode (isJust mbTheseMappings)
+ recur fname subtree = propagateMappings' sublayers subtree
+ where
+ addSubdir :: SomeLocWithVars m -> SomeLocWithVars m
+ addSubdir (SomeGLoc l) = SomeGLoc $ addSubdirToLoc l $ T.unpack (_ltpiName fname)
+ sublayers = fmap addSubdir theseLayers
+
+-- | Given a list of loc layers inherited from further up the tree, fills in the
+-- blanks in the loc shortcuts given for once node of the tree in order to get
+-- the final loc layers mapped to this node.
+applyInheritedLayersToShortcuts
+ :: forall m.
+ [SomeLocWithVars m] -- ^ Inherited layers
+ -> Maybe [ResolvedLocShortcut m] -- ^ LocShortcuts mapped to the node
+ -> [SomeLocWithVars m] -- ^ Final layers mapped to this node
+applyInheritedLayersToShortcuts inheritedLayers Nothing = inheritedLayers
+applyInheritedLayersToShortcuts inheritedLayers (Just shortcuts) =
+ concatMap fillShortcut shortcuts
+ where
+ fillShortcut = \case
+ FullySpecifiedLoc l -> [l]
+ DeriveLocPrefixFromTree fp ->
+ flip map inheritedLayers $ \(SomeGLoc l) ->
+ SomeGLoc @m $ useLocAsPrefix l fp
+ DeriveWholeLocFromTree ext ->
+ flip map inheritedLayers $ \(SomeGLoc l) ->
+ SomeGLoc @m $ overrideLocType l (T.unpack ext)
+
+-- | In a context where we have LocationAccessors available, we parse the
+-- locations in a 'SerializableLocShortcut' and obtain a 'ResolvedLocShortcut'
+resolveLocShortcut :: (LogThrow m) => SerializableLocShortcut -> LocResolutionM m (ResolvedLocShortcut m)
+resolveLocShortcut (DeriveWholeLocFromTree ext) = return $ DeriveWholeLocFromTree ext
+resolveLocShortcut (DeriveLocPrefixFromTree path) = return $ DeriveLocPrefixFromTree path
+resolveLocShortcut (FullySpecifiedLoc value) =
+ withParsedLocsWithVars [value] $ \[resolvedLoc] ->
+ return $ FullySpecifiedLoc $ SomeGLoc resolvedLoc
+
+-- | Transform a tree to one where unmapped nodes have been changed to 'mempty'
+-- and mapped nodes have been associated to their physical location. A function
+-- is applied to ask each node to integrate its final mappings, with a Bool to
+-- tell whether whether the mapping for a node was explicit (True) or not
+-- (False), ie. if it was explicitely declared in the config file or if it was
+-- derived from the mapping of a parent folder. @n'@ is often some file type or
+-- metadata that's required in the mapping.
+--
+-- TODO: Maybe change the callback type to
+-- @DerivedOrExplicit [SomeLocWithVars m] -> a -> b@ with
+-- @data DerivedOrExplicit a = Derived a | Explicit a@
+applyMappings :: (LogThrow m)
+ => ([SomeLocWithVars m] -> a -> Bool -> b)
+ -- ^ Add physical locations (if they exist)
+ -- to a node
+ -> LocationMappings -- ^ Mappings to apply
+ -> LocationTree a -- ^ Original tree
+ -> LocResolutionM m (LocationTree b) -- ^ Tree with physical locations
+applyMappings f mappings loctree = do
+ let treeWithShortcuts = insertMappings mappings loctree
+ resolve (node, Nothing) = return (node, Nothing)
+ resolve (node, Just shortcuts) =
+ (\rs -> (node, Just rs)) <$> mapM resolveLocShortcut shortcuts
+ treeWithResolvedShortcuts <- traverse resolve treeWithShortcuts
+ return $ propagateMappings f treeWithResolvedShortcuts
diff --git a/src/Data/Locations/SerializationMethod.hs b/src/Data/Locations/SerializationMethod.hs
new file mode 100644
index 0000000..49e751c
--- /dev/null
+++ b/src/Data/Locations/SerializationMethod.hs
@@ -0,0 +1,745 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -Wall #-}
+
+module Data.Locations.SerializationMethod where
+
+import Control.Lens hiding ((:>))
+import Control.Funflow.ContentHashable
+import Data.Aeson as A
+import qualified Data.Attoparsec.Lazy as AttoL
+import qualified Data.Binary.Builder as BinBuilder
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Streaming as BSS
+import Data.Char (ord)
+import qualified Data.Csv as Csv
+import qualified Data.Csv.Builder as CsvBuilder
+import qualified Data.Csv.Parser as CsvParser
+import Codec.Compression.Zlib as Zlib
+import Data.DocRecord
+import Data.DocRecord.OptParse (RecordUsableWithCLI)
+import qualified Data.HashMap.Strict as HM
+import Data.Locations.LocVariable
+import Data.Locations.LogAndErrors
+import Data.Maybe
+import Data.Monoid (First (..))
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Encoding as LTE
+import Data.Typeable
+import qualified Data.Vector as V
+import qualified Data.Yaml as Y
+import Katip
+import GHC.Generics
+import Streaming
+import qualified Streaming.Prelude as S
+import qualified Streaming.Zip as SZip
+
+
+-- | A file extension
+type FileExt = T.Text
+
+type FromAtomicFn' i a = i -> Either String a
+
+-- | How to read an @a@ from some identified type @i@, which is meant to be a
+-- general-purpose intermediate representation, like 'A.Value'.
+data FromAtomicFn a =
+ forall i. (Typeable i) => FromAtomicFn (FromAtomicFn' i a)
+deriving instance Functor FromAtomicFn
+
+instance Show (FromAtomicFn a) where
+ show _ = "<FromAtomicFn>"
+
+fromAtomicFn
+ :: forall i a. (Typeable i)
+ => [Maybe FileExt]
+ -> FromAtomicFn' i a
+ -> HM.HashMap (TypeRep,Maybe FileExt) (FromAtomicFn a)
+fromAtomicFn exts f = HM.fromList $ map (\ext -> ((argTypeRep,ext), FromAtomicFn f)) exts
+ where
+ argTypeRep = typeOf (undefined :: i)
+
+allFromAtomicFnsWithType :: forall i ext a. (Typeable i)
+ => HM.HashMap (TypeRep,Maybe ext) (FromAtomicFn a)
+ -> [(ext, FromAtomicFn' i a)]
+allFromAtomicFnsWithType = mapMaybe fltr . HM.toList
+ where
+ wanted = typeOf (undefined :: i)
+ fltr ((_,Nothing),_) = Nothing
+ fltr ((tr,Just ext), FromAtomicFn (f :: FromAtomicFn' i' a))
+ | tr == wanted = case eqT :: Maybe (i:~:i') of
+ Just Refl -> Just (ext, f)
+ Nothing -> error $ "allFromAtomicFnsWithType: some function doesn't deal with type "
+ ++ show wanted ++ " when it should"
+ | otherwise = Nothing
+
+
+type FromStreamFn' i a =
+ forall m. (LogMask m) => Stream (Of i) m () -> m a
+
+-- | How to read an @a@ from some @Stream (Of i) m r@
+data FromStreamFn a =
+ forall i. (Typeable i) => FromStreamFn (FromStreamFn' i a)
+
+instance Functor FromStreamFn where
+ fmap f (FromStreamFn g) = FromStreamFn $ \s -> do
+ f <$> g s
+
+instance Show (FromStreamFn a) where
+ show _ = "<FromStreamFn>"
+
+fromStreamFn
+ :: forall i a. (Typeable i)
+ => [Maybe FileExt]
+ -> FromStreamFn' i a
+ -> HM.HashMap (TypeRep,Maybe FileExt) (FromStreamFn a)
+fromStreamFn exts f = HM.fromList $ map (\ext -> ((argTypeRep,ext), FromStreamFn f)) exts
+ where
+ argTypeRep = typeOf (undefined :: i)
+
+newtype FromStreamFn'' i a = FromStreamFn'' (FromStreamFn' i a)
+
+allFromStreamFnsWithType :: forall i ext a. (Typeable i)
+ => HM.HashMap (TypeRep,Maybe ext) (FromStreamFn a)
+ -> [(ext, FromStreamFn'' i a)]
+allFromStreamFnsWithType = mapMaybe fltr . HM.toList
+ where
+ wanted = typeOf (undefined :: i)
+ fltr ((_,Nothing),_) = Nothing
+ fltr ((tr,Just ext), FromStreamFn (f :: FromStreamFn' i' a))
+ | tr == wanted = case eqT :: Maybe (i:~:i') of
+ Just Refl -> Just (ext, FromStreamFn'' f)
+ Nothing -> error $ "allFromStreamFnsWithType: some function doesn't deal with type "
+ ++ show wanted ++ " when it should"
+ | otherwise = Nothing
+
+-- | A function to read @a@ from a 'DocRec'
+data ReadFromConfigFn a = forall rs. (Typeable rs) => ReadFromConfigFn (DocRec rs -> a)
+deriving instance Functor ReadFromConfigFn
+
+instance Show (ReadFromConfigFn a) where
+ show _ = "<ReadFromConfigFn>"
+
+-- | Here, "serial" is short for "serialization method". 'SerialReaders' is the
+-- **covariant** part of 'SerialsFor'. It describes the different ways a serial
+-- can be used to obtain data.
+data SerialReaders a = SerialReaders
+ { -- TODO: Establish whether we should remove readersFromAtomic? It is often
+ -- equivalent to reading from a stream of just one element, and therefore
+ -- mostly duplicates code.
+ _serialReadersFromAtomic ::
+ HM.HashMap (TypeRep,Maybe FileExt) (FromAtomicFn a)
+ -- ^ How to read data from an intermediate type (like 'A.Value' or
+ -- 'T.Text'). As much as possible these intermediate atomic
+ -- representations should be **strict**.
+ , _serialReadersFromStream ::
+ HM.HashMap (TypeRep,Maybe FileExt) (FromStreamFn a)
+ -- ^ How to read data from a stream of intermediate data types (like
+ -- strict ByteStrings). Each one of them being strict as much as
+ -- possible.
+ }
+ deriving (Functor, Show)
+
+makeLenses ''SerialReaders
+
+instance Semigroup (SerialReaders a) where
+ SerialReaders a s <> SerialReaders a' s' =
+ SerialReaders (HM.unionWith const a a') (HM.unionWith const s s')
+instance Monoid (SerialReaders a) where
+ mempty = SerialReaders mempty mempty
+
+-- | How to turn an @a@ into some identified type @i@, which is meant to a
+-- general purpose intermediate representation, like 'A.Value' or even 'T.Text'.
+data ToAtomicFn a =
+ forall i. (Typeable i) => ToAtomicFn (a -> i)
+
+instance Show (ToAtomicFn a) where
+ show _ = "<ToAtomicFn>"
+
+toAtomicFn :: forall i a. (Typeable i)
+ => [Maybe FileExt]
+ -> (a -> i)
+ -> HM.HashMap (TypeRep,Maybe FileExt) (ToAtomicFn a)
+toAtomicFn exts f = HM.fromList $ map (\ext -> ((argTypeRep,ext), ToAtomicFn f)) exts
+ where
+ argTypeRep = typeOf (undefined :: i)
+
+allToAtomicFnsWithType :: forall i ext a. (Typeable i)
+ => HM.HashMap (TypeRep,Maybe ext) (ToAtomicFn a)
+ -> [(ext, a -> i)]
+allToAtomicFnsWithType = mapMaybe fltr . HM.toList
+ where
+ wanted = typeOf (undefined :: i)
+ fltr ((_,Nothing),_) = Nothing
+ fltr ((tr,Just ext), ToAtomicFn (f :: a -> i'))
+ | tr == wanted = case eqT :: Maybe (i:~:i') of
+ Just Refl -> Just (ext, f)
+ Nothing -> error $ "allToAtomicFnsWithType: some function doesn't deal with type "
+ ++ show wanted ++ " when it should"
+ | otherwise = Nothing
+
+-- -- | How to turn an @a@ into some @Stream (Of i) m ()@
+-- data ToStreamFn a =
+-- forall i. (Typeable i)
+-- => ToStreamFn (forall m. (LogMask m)
+-- => a -> Stream (Of i) m ())
+
+-- instance Show (ToStreamFn a) where
+-- show _ = "<ToStreamFn>"
+
+-- singletonToStreamFn
+-- :: forall i a. (Typeable i)
+-- => Maybe FileExt
+-- -> (forall m. (LogMask m) => a -> Stream (Of i) m ())
+-- -> HM.HashMap (TypeRep,Maybe FileExt) (ToStreamFn a)
+-- singletonToStreamFn ext f = HM.singleton (argTypeRep,ext) (ToStreamFn f)
+-- where argTypeRep = typeOf (undefined :: i)
+
+-- | The contravariant part of 'ReadFromConfigFn'. Permits to write default values
+-- of the input config
+data WriteToConfigFn a = forall rs. (Typeable rs, RecordUsableWithCLI rs)
+ => WriteToConfigFn (a -> DocRec rs)
+
+instance Show (WriteToConfigFn a) where
+ show _ = "<WriteToConfigFn>"
+
+-- | The writing part of a serial. 'SerialWriters' describes the different ways
+-- a serial can be used to serialize (write) data.
+data SerialWriters a = SerialWriters
+ { _serialWritersToAtomic :: HM.HashMap (TypeRep,Maybe FileExt) (ToAtomicFn a)
+ -- ^ How to write the data to an intermediate type (like 'A.Value'). As
+ -- much as possible this intermediate type should be **lazy**.
+
+ -- , _serialWritersToStream :: HM.HashMap (TypeRep,Maybe FileExt) (ToStreamFn a)
+ -- -- ^ How to write the data to an external file or storage.
+ }
+ deriving (Show)
+
+makeLenses ''SerialWriters
+
+instance Semigroup (SerialWriters a) where
+ SerialWriters a <> SerialWriters a' = SerialWriters (HM.unionWith const a a')
+instance Monoid (SerialWriters a) where
+ mempty = SerialWriters mempty
+
+instance Contravariant SerialWriters where
+ contramap f sw = SerialWriters
+ { _serialWritersToAtomic = fmap (\(ToAtomicFn f') -> ToAtomicFn $ f' . f)
+ (_serialWritersToAtomic sw)
+ -- , _serialWritersToStream = fmap (\(ToStreamFn f') -> ToStreamFn $ f' . f)
+ -- (_serialWritersToStream sw)
+ }
+
+-- | Links a serialization method to a prefered file extension, if this is
+-- relevant.
+class SerializationMethod serial where
+ -- | If @Just x@, @x@ should correspond to one of the keys in
+ -- _serialReadersFromStream or _serialWritersToAtomic.
+ getSerialDefaultExt :: serial -> Maybe FileExt
+ getSerialDefaultExt _ = Nothing
+
+-- | Tells whether some type @a@ can be serialized by some _serial_ (serialization
+-- method).
+class (SerializationMethod serial) => SerializesWith serial a where
+ getSerialWriters :: serial -> SerialWriters a
+
+-- | Tells whether some type @a@ can be deserialized by some _serial_
+-- (serialization method).
+class (SerializationMethod serial) => DeserializesWith serial a where
+ getSerialReaders :: serial -> SerialReaders a
+
+-- * Serialization to/from JSON and YAML, which both use the same intermediary
+-- type, Data.Aeson.Value
+
+-- | Has 'SerializesWith' & 'DeserializesWith' instances that permits to
+-- store/load JSON and YAML files and 'A.Value's.
+data JSONSerial = JSONSerial -- ^ Expects @.json@ files by default, but supports
+ -- @.yaml@/@.yml@ files too "for free"
+ | YAMLSerial -- ^ Expects @.yaml@/@.yml@ files by default, but
+ -- supports @.json@ files too "for free"
+
+-- | For when you want a JSON **only** or YAML **only** serialization, but tied to a
+-- specific extension. It's more restrictive than 'JSONSerial' in the sense that
+-- JSONSerialWithExt cannot read from values from the configuration (because in
+-- the config we only have an Aeson Value, without an associated extension, so
+-- we cannot know for sure this Value corresponds to the expected extension)
+data JSONSerialWithExt = JSONSerialWithExt FileExt
+ -- ^ Expects files of a given extension, ONLY
+ -- formatted in JSON (YAML not provided "for free")
+ | YAMLSerialWithExt FileExt
+ -- ^ Expects files of a given extension, ONLY
+ -- formatted in YAML (JSON not provided "for free")
+
+instance SerializationMethod JSONSerial where
+ getSerialDefaultExt JSONSerial = Just "json"
+ getSerialDefaultExt YAMLSerial = Just "yaml"
+
+instance SerializationMethod JSONSerialWithExt where
+ getSerialDefaultExt (JSONSerialWithExt e) = Just e
+ getSerialDefaultExt (YAMLSerialWithExt e) = Just e
+
+-- | To lazy bytestring of JSON
+toAtomicJSON, toAtomicYAML
+ :: ToJSON a
+ => [FileExt] -> HM.HashMap (TypeRep, Maybe FileExt) (ToAtomicFn a)
+toAtomicJSON exts =
+ toAtomicFn (map Just exts) A.encode
+
+-- | To lazy bytestring of YAML
+toAtomicYAML exts =
+ toAtomicFn (map Just exts) $ LBS.fromStrict . Y.encode
+
+instance (ToJSON a) => SerializesWith JSONSerial a where
+ getSerialWriters _srl = mempty
+ { _serialWritersToAtomic =
+ toAtomicFn [Nothing] A.toJSON -- To A.Value, doesn't need an extension
+ <> toAtomicJSON ["json"]
+ <> toAtomicYAML ["yaml","yml"] }
+
+instance (ToJSON a) => SerializesWith JSONSerialWithExt a where
+ getSerialWriters (JSONSerialWithExt ext) = mempty
+ { _serialWritersToAtomic = toAtomicJSON [ext] }
+ getSerialWriters (YAMLSerialWithExt ext) = mempty
+ { _serialWritersToAtomic = toAtomicYAML [ext] }
+
+parseJSONEither :: (A.FromJSON t) => A.Value -> Either String t
+parseJSONEither x = case A.fromJSON x of
+ A.Success s -> Right s
+ A.Error r -> Left r
+{-# INLINE parseJSONEither #-}
+
+-- | From strict bytestring of JSON
+fromAtomicJSON, fromAtomicYAML
+ :: FromJSON a
+ => [FileExt] -> HM.HashMap (TypeRep, Maybe FileExt) (FromAtomicFn a)
+fromAtomicJSON exts =
+ fromAtomicFn (map Just exts) A.eitherDecodeStrict
+
+-- | From strict bytestring of YAML
+fromAtomicYAML exts =
+ fromAtomicFn (map Just exts) $
+ over _Left displayException . Y.decodeEither'
+
+-- | From a stream of strict bytestrings of JSON
+fromJSONStream, fromYAMLStream
+ :: FromJSON a
+ => [FileExt] -> HM.HashMap (TypeRep, Maybe FileExt) (FromStreamFn a)
+fromJSONStream exts = fromStreamFn (map Just exts) $ \strm -> do
+ BSS.toStrict_ (BSS.fromChunks strm) >>= decodeJ
+ -- TODO: Enhance this so we don't have to accumulate the whole
+ where
+ decodeJ x = case A.eitherDecodeStrict x of
+ Right y -> return y
+ Left msg -> throwWithPrefix msg
+
+-- | From a stream of strict bytestrings of YAML
+fromYAMLStream exts = fromStreamFn (map Just exts) (decodeYAMLStream . BSS.fromChunks)
+
+decodeYAMLStream :: (LogThrow m, FromJSON a) => BSS.ByteString m () -> m a
+decodeYAMLStream strm = do
+ BSS.toStrict_ strm >>= decodeY -- TODO: same than above
+ where
+ decodeY x = case Y.decodeEither' x of
+ Right y -> return y
+ Left exc -> logAndThrowM exc
+
+instance (FromJSON a) => DeserializesWith JSONSerial a where
+ getSerialReaders _srl = mempty
+ { _serialReadersFromAtomic =
+ fromAtomicFn [Nothing] parseJSONEither -- From A.Value, doesn't need an
+ -- extension
+ <> fromAtomicJSON ["json"]
+ <> fromAtomicYAML ["yaml","yml"]
+ , _serialReadersFromStream =
+ fromJSONStream ["json"]
+ -- TODO: Add reading from a stream of JSON objects (which would
+ -- therefore be considered a JSON array of objects?)
+ <>
+ fromYAMLStream ["yaml","yml"] }
+
+instance (FromJSON a) => DeserializesWith JSONSerialWithExt a where
+ getSerialReaders (JSONSerialWithExt ext) = mempty
+ { _serialReadersFromAtomic = fromAtomicJSON [ext]
+ , _serialReadersFromStream = fromJSONStream [ext] }
+ getSerialReaders (YAMLSerialWithExt ext) = mempty
+ { _serialReadersFromAtomic = fromAtomicYAML [ext]
+ , _serialReadersFromStream = fromYAMLStream [ext] }
+
+
+-- * Helpers to write to and from binary representations
+
+class ToBinaryBuilder serial a where
+ toBinaryBuilder :: serial -> a -> BinBuilder.Builder
+
+-- | Recommendation: instances should implement fromLazyByteString and
+-- fromByteStream whenever possible.
+class FromByteStream serial a where
+ fromLazyByteString :: serial -> LBS.ByteString -> Either String a
+ fromLazyByteString s = fromStrictByteString s . LBS.toStrict
+ fromStrictByteString :: serial -> BS.ByteString -> Either String a
+ fromStrictByteString s = fromLazyByteString s . LBS.fromStrict
+ fromByteStream :: (LogThrow m) => serial -> BSS.ByteString m () -> m a
+ fromByteStream s bss = do
+ bs <- BSS.toLazy_ bss -- This default implementation is stricter than
+ -- it needs to be
+ case fromLazyByteString s bs of
+ Left msg -> throwWithPrefix msg
+ Right y -> return y
+
+getSerialWriters_ToBinaryBuilder
+ :: (SerializationMethod srl, ToBinaryBuilder srl a) => srl -> SerialWriters a
+getSerialWriters_ToBinaryBuilder srl = mempty
+ { _serialWritersToAtomic =
+ toAtomicFn [getSerialDefaultExt srl] $
+ BinBuilder.toLazyByteString . toBinaryBuilder srl }
+
+getSerialReaders_FromByteStream
+ :: (SerializationMethod srl, FromByteStream srl a) => srl -> SerialReaders a
+getSerialReaders_FromByteStream srl = mempty
+ { _serialReadersFromStream =
+ fromStreamFn [getSerialDefaultExt srl] (fromByteStream srl . BSS.fromChunks)
+ , _serialReadersFromAtomic = -- From strict bytestring
+ fromAtomicFn [getSerialDefaultExt srl] (fromStrictByteString srl)
+ }
+
+-- * Serialization to/from CSV
+
+-- | Data with header not known in advance, that can be converted to/from CSV,
+-- keeping track of the header
+data Tabular a = Tabular
+ { tabularHeader :: Maybe [T.Text]
+ , tabularData :: a }
+ deriving (Show, Generic, ToJSON, FromJSON)
+
+-- | Data that can be converted to/from CSV, with previous knowledge of the
+-- headers
+newtype Records a = Records { fromRecords :: a }
+
+instance (Show a) => Show (Records a) where
+ show = show . fromRecords
+
+instance (ToJSON a) => ToJSON (Records a) where
+ toJSON = toJSON . fromRecords
+
+instance (FromJSON a) => FromJSON (Records a) where
+ parseJSON = fmap Records . parseJSON
+
+-- | Can serialize and deserialize any @Tabular a@ from a CSV file
+data CSVSerial = CSVSerial
+ { csvSerialExt :: FileExt
+ -- ^ The extension to use (csv, tsv, txt, etc.)
+ , csvSerialHasHeader :: Bool
+ -- ^ The csv file contains a header (to skip or to read/write). Must be True
+ -- if we want to read 'Records' from it
+ , csvSerialDelimiter :: Char
+ -- ^ The character (@,@, @\t@, etc.) to use as a field delimiter.
+ }
+
+instance SerializationMethod CSVSerial where
+ getSerialDefaultExt = Just . csvSerialExt
+
+instance (Foldable f, Csv.ToRecord a) => ToBinaryBuilder CSVSerial (Tabular (f a)) where
+ toBinaryBuilder (CSVSerial _ hasHeader delim) (Tabular mbHeader dat) =
+ mbAddHeader $ foldMap encField dat
+ where
+ mbAddHeader | hasHeader = maybe id (<>) (encHeader <$> mbHeader)
+ | otherwise = id
+ encodeOpts = Csv.defaultEncodeOptions {Csv.encDelimiter = fromIntegral $ ord delim}
+ encHeader = CsvBuilder.encodeRecordWith encodeOpts
+ encField = CsvBuilder.encodeRecordWith encodeOpts
+
+instance (Foldable f, Csv.ToNamedRecord a, Csv.DefaultOrdered a)
+ => ToBinaryBuilder CSVSerial (Records (f a)) where
+ toBinaryBuilder (CSVSerial _ hasHeader delim) (Records dat) =
+ mbAddHeader $ foldMap encField dat
+ where
+ mbAddHeader | hasHeader = (encHeader (Csv.headerOrder (undefined :: a)) <>)
+ | otherwise = id
+ encodeOpts = Csv.defaultEncodeOptions {Csv.encDelimiter = fromIntegral $ ord delim}
+ encHeader = CsvBuilder.encodeHeaderWith encodeOpts
+ encField = CsvBuilder.encodeDefaultOrderedNamedRecordWith encodeOpts
+
+instance (Csv.FromRecord a) => FromByteStream CSVSerial (Tabular (V.Vector a)) where
+ fromLazyByteString (CSVSerial _ hasHeader delim) bs = do
+ (mbHeader, rest) <- if hasHeader
+ then case AttoL.parse (CsvParser.header delim') bs of
+ AttoL.Fail _ _ err -> Left err
+ AttoL.Done rest r -> return (Just r, rest)
+ else return (Nothing, bs)
+ let mbHeader' = map TE.decodeUtf8 . V.toList <$> mbHeader
+ Tabular mbHeader' <$> Csv.decodeWith decOpts Csv.NoHeader rest
+ where
+ delim' = fromIntegral $ ord delim
+ decOpts = Csv.defaultDecodeOptions {Csv.decDelimiter=delim'}
+
+instance (Csv.FromNamedRecord a) => FromByteStream CSVSerial (Records (V.Vector a)) where
+ fromLazyByteString (CSVSerial _ hasHeader delim) bs =
+ if not hasHeader then error "CANNOT USE ColNamed on CSV files without headers"
+ else do
+ (_, v) <- Csv.decodeByNameWith decOpts bs
+ return $ Records v
+ where
+ decOpts = Csv.defaultDecodeOptions {Csv.decDelimiter=fromIntegral $ ord delim}
+
+instance (Foldable f, Csv.ToRecord a) => SerializesWith CSVSerial (Tabular (f a)) where
+ getSerialWriters = getSerialWriters_ToBinaryBuilder
+
+instance (Foldable f, Csv.ToNamedRecord a, Csv.DefaultOrdered a)
+ => SerializesWith CSVSerial (Records (f a)) where
+ getSerialWriters = getSerialWriters_ToBinaryBuilder
+
+instance (Csv.FromRecord a) => DeserializesWith CSVSerial (Tabular (V.Vector a)) where
+ getSerialReaders = getSerialReaders_FromByteStream
+
+instance (Csv.FromNamedRecord a) => DeserializesWith CSVSerial (Records (V.Vector a)) where
+ getSerialReaders = getSerialReaders_FromByteStream
+
+-- * "Serialization" to/from bytestrings
+
+-- | ByteStringSerial is just a reader of strict ByteStrings and writer of lazy
+-- ByteStrings. It's the simplest SerializationMethod possible
+newtype ByteStringSerial = ByteStringSerial { bsSerialSpecificExt :: Maybe FileExt }
+
+instance SerializationMethod ByteStringSerial where
+ getSerialDefaultExt (ByteStringSerial ext) = ext
+
+instance SerializesWith ByteStringSerial LBS.ByteString where
+ getSerialWriters (ByteStringSerial ext) = mempty
+ { _serialWritersToAtomic = toAtomicFn [ext] id }
+ -- TODO: Add base64 encoding so it can be read/written from/to JSON strings
+ -- too
+
+-- We only deserialize *strict* bytestrings, in order not to hide the fact that
+-- the data must be accumulated from the stream we read if you want to break
+-- away from it
+
+instance DeserializesWith ByteStringSerial BS.ByteString where
+ getSerialReaders (ByteStringSerial ext) = mempty
+ { _serialReadersFromAtomic =
+ fromAtomicFn [ext] Right
+ , _serialReadersFromStream =
+ fromStreamFn [ext] S.mconcat_ }
+
+-- * Serialization to/from plain text
+
+-- | Can read from text files or raw input strings in the pipeline configuration
+-- file. Should be used only for small files or input strings. If we should
+-- accept only some extension, specify it. Else just use Nothing.
+newtype PlainTextSerial = PlainTextSerial { plainTextSerialSpecificExt :: Maybe FileExt }
+
+instance SerializationMethod PlainTextSerial where
+ getSerialDefaultExt (PlainTextSerial ext) = ext
+
+instance SerializesWith PlainTextSerial T.Text where
+ getSerialWriters (PlainTextSerial ext) = mempty
+ { _serialWritersToAtomic =
+ toAtomicFn [Nothing] (\t -> LT.fromChunks [t]) -- To lazy text
+ <> toAtomicFn [ext] (\t -> LTE.encodeUtf8 $ LT.fromChunks [t]) -- To lazy bytestring
+ <> toAtomicFn [ext] toJSON -- To A.Value
+ }
+
+instance SerializesWith PlainTextSerial LT.Text where
+ getSerialWriters (PlainTextSerial ext) = mempty
+ { _serialWritersToAtomic =
+ toAtomicFn [Nothing] id -- To lazy text
+ <> toAtomicFn [ext] LTE.encodeUtf8 -- To lazy bytestring
+ <> toAtomicFn [ext] toJSON -- To A.Value
+ }
+
+instance DeserializesWith PlainTextSerial T.Text where
+ getSerialReaders (PlainTextSerial ext) = mempty
+ { _serialReadersFromAtomic =
+ fromAtomicFn [Nothing] Right
+ <> fromAtomicFn [ext] parseJSONEither
+ <> fromAtomicFn [ext] (Right . TE.decodeUtf8)
+ , _serialReadersFromStream =
+ fromStreamFn [ext] S.mconcat_
+ <>
+ fromStreamFn [ext] (fmap TE.decodeUtf8 . S.mconcat_)
+ }
+
+-- * Serialization of options
+
+-- | Contains any set of options that should be exposed via the CLI
+data RecOfOptions field where
+ RecOfOptions :: (Typeable rs, RecordUsableWithCLI rs) => Rec field rs -> RecOfOptions field
+
+type DocRecOfOptions = RecOfOptions DocField
+
+-- | A serialization method used for options which can have a default value,
+-- that can be exposed through the configuration.
+data OptionsSerial a = forall rs. (Typeable rs, RecordUsableWithCLI rs)
+ => OptionsSerial (a -> DocRec rs) (DocRec rs -> a)
+instance SerializationMethod (OptionsSerial a)
+instance SerializesWith (OptionsSerial a) a where
+ getSerialWriters (OptionsSerial f _) = mempty
+ { _serialWritersToAtomic =
+ toAtomicFn [Nothing] (RecOfOptions . f) }
+instance DeserializesWith (OptionsSerial a) a where
+ getSerialReaders (OptionsSerial _ (f :: DocRec rs -> a)) = mempty
+ { _serialReadersFromAtomic =
+ let conv :: DocRecOfOptions -> Either String a
+ conv (RecOfOptions r) = case cast r of
+ Just r' -> Right $ f r'
+ Nothing -> Left "OptionsSerial: _serialReadersFromAtomic: Not the right fields"
+ in fromAtomicFn [Nothing] conv }
+
+
+-- * Combining serializers and deserializers into one structure
+
+-- | Can serialize @a@ and deserialize @b@.
+data SerialsFor a b = SerialsFor
+ { _serialWriters :: SerialWriters a
+ , _serialReaders :: SerialReaders b
+ , _serialDefaultExt :: First FileExt
+ , _serialRepetitionKeys :: [LocVariable] }
+ deriving (Show)
+
+makeLenses ''SerialsFor
+
+-- | An equivaluent of 'Void', to avoid orphan instances
+data NoWrite
+
+instance (Monad m) => ContentHashable m NoWrite where
+ contentHashUpdate ctx _ = contentHashUpdate ctx ()
+
+-- | Just for symmetry with 'NoWrite'
+data NoRead = NoRead
+ deriving (Eq, Ord, Show)
+
+instance Semigroup NoRead where
+ _ <> _ = NoRead
+instance Monoid NoRead where
+ mempty = NoRead
+
+instance (Monad m) => ContentHashable m NoRead where
+ contentHashUpdate ctx _ = contentHashUpdate ctx ()
+
+-- | Can serialize and deserialize @a@. Use 'dimap' to transform it
+type BidirSerials a = SerialsFor a a
+
+-- | Can only serialize @a@. Use 'lmap' to transform it.
+type PureSerials a = SerialsFor a NoRead
+
+-- | Can only deserialize @a@. Use 'rmap' to transform it.
+type PureDeserials a = SerialsFor NoWrite a
+
+instance Profunctor SerialsFor where
+ lmap f (SerialsFor sers desers ext rk) = SerialsFor (contramap f sers) desers ext rk
+ rmap f (SerialsFor sers desers ext rk) = SerialsFor sers (fmap f desers) ext rk
+
+instance Semigroup (SerialsFor a b) where
+ SerialsFor s d ext rk <> SerialsFor s' d' ext' _ =
+ SerialsFor (s<>s') (d<>d') (ext<>ext') rk
+instance Monoid (SerialsFor a b) where
+ mempty = SerialsFor mempty mempty mempty []
+
+-- | Changes the serialization function used by default
+setDefaultSerial :: FileExt -> SerialsFor a b -> SerialsFor a b
+setDefaultSerial = set serialDefaultExt . First . Just
+
+-- | Packs together ways to serialize and deserialize some data @a@
+someBidirSerial :: (SerializesWith s a, DeserializesWith s a) => s -> BidirSerials a
+someBidirSerial s =
+ SerialsFor (getSerialWriters s) (getSerialReaders s) (First $ getSerialDefaultExt s) []
+
+makeBidir :: PureSerials a -> PureDeserials a -> BidirSerials a
+makeBidir (SerialsFor sers _ ext rk) (SerialsFor _ desers ext' _) =
+ SerialsFor sers desers (ext<>ext') rk
+
+-- | Packs together ways to serialize some data @a@
+somePureSerial :: (SerializesWith s a) => s -> PureSerials a
+somePureSerial s =
+ SerialsFor (getSerialWriters s) mempty (First $ getSerialDefaultExt s) []
+
+-- | Packs together ways to deserialize and deserialize some data @a@
+somePureDeserial :: (DeserializesWith s a) => s -> PureDeserials a
+somePureDeserial s =
+ SerialsFor mempty (getSerialReaders s) (First $ getSerialDefaultExt s) []
+
+eraseSerials :: SerialsFor a b -> PureDeserials b
+eraseSerials (SerialsFor _ desers ext rk) = SerialsFor mempty desers ext rk
+
+eraseDeserials :: SerialsFor a b -> PureSerials a
+eraseDeserials (SerialsFor sers _ ext rk) = SerialsFor sers mempty ext rk
+
+
+-- * Retrieve conversion functions from a 'SerialsFor' @a@ @b@
+
+-- | Tries to get a conversion function to some type @i@
+getToAtomicFn :: forall i a b. (Typeable i) => SerialsFor a b -> Maybe (a -> i)
+getToAtomicFn ser = do
+ ToAtomicFn (f :: a -> i') <-
+ HM.lookup (typeOf (undefined :: i),Nothing) (ser ^. serialWriters . serialWritersToAtomic)
+ case eqT :: Maybe (i' :~: i) of
+ Just Refl -> return f
+ Nothing -> error $ "getToAtomicFn: Some conversion function isn't properly indexed. Should not happen"
+
+-- | Tries to get a conversion function from some type @i@
+getFromAtomicFn :: forall i a b. (Typeable i) => SerialsFor a b -> Maybe (FromAtomicFn' i b)
+getFromAtomicFn ser = do
+ FromAtomicFn (f :: FromAtomicFn' i' b) <-
+ HM.lookup (typeOf (undefined :: i),Nothing) (ser ^. serialReaders . serialReadersFromAtomic)
+ case eqT :: Maybe (i' :~: i) of
+ Just Refl -> return f
+ Nothing -> error $ "getFromAtomicFn: Some conversion function isn't properly indexed. Should not happen"
+
+
+-- * Serialization for compressed formats
+
+-- | Wraps all the functions in the serial so for each serial (extension) @xxx@
+-- supported, we know also support @xxxzlib@. Doesn't change the default
+-- extension
+addZlibSerials :: SerialsFor a b -> SerialsFor a b
+addZlibSerials = over serialWriters (over serialWritersToAtomic editTA)
+ . over serialReaders (over serialReadersFromAtomic editFA
+ . over serialReadersFromStream editFS)
+ where
+ editTA hm = (hm <>) $ mconcat $ flip map (allToAtomicFnsWithType hm) $
+ \(ext, f) ->
+ toAtomicFn [Just $ ext <> "zlib"] $ Zlib.compress . f -- Lazy bytestring
+ editFA hm = (hm <>) $ mconcat $ flip map (allFromAtomicFnsWithType hm) $
+ \(ext, f) ->
+ fromAtomicFn [Just $ ext <> "zlib"] $
+ f . LBS.toStrict . Zlib.decompress . LBS.fromStrict -- Strict bytestring
+ editFS hm = (hm <>) $ mconcat $ flip map (allFromStreamFnsWithType hm) $
+ \(ext, FromStreamFn'' f) ->
+ fromStreamFn [Just $ ext <> "zlib"] $
+ f . BSS.toChunks . SZip.decompress SZip.defaultWindowBits . BSS.fromChunks
+
+-- | Adds warnings when deserializing values /from a stream/
+addDeserialWarnings :: (b -> [String]) -> SerialsFor a b -> SerialsFor a b
+addDeserialWarnings f = serialReaders . serialReadersFromStream . traversed %~ addW
+ where
+ addW (FromStreamFn g) = FromStreamFn $ \s -> do
+ a <- g s
+ let warnings = f a
+ mapM_ (logFM WarningS . logStr) warnings
+ return a
+
+
+-- -- | Traverses to the repetition keys stored in the access functions of a
+-- -- 'SerialsFor'
+-- serialsRepetitionKeys :: Traversal' (SerialsFor a b) [LocVariable]
+-- serialsRepetitionKeys f (SerialsFor writers readers ext rk) =
+-- rebuild <$> (serialWritersToOutputFile . traversed . writeToLocRepetitionKeys) f writers
+-- <*> (serialReadersFromInputFile . traversed . readFromLocRepetitionKeys) f readers
+-- where
+-- rebuild w r = SerialsFor w r ext rk
diff --git a/src/Data/Locations/VirtualFile.hs b/src/Data/Locations/VirtualFile.hs
new file mode 100644
index 0000000..f2d23cf
--- /dev/null
+++ b/src/Data/Locations/VirtualFile.hs
@@ -0,0 +1,394 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module Data.Locations.VirtualFile
+ ( LocationTreePathItem
+ , module Data.Locations.SerializationMethod
+ , Profunctor(..)
+ , VirtualFile(..), LayeredReadScheme(..)
+ , BidirVirtualFile, DataSource, DataSink
+ , VFileIntent(..), VFileDescription(..)
+ , RecOfOptions(..)
+ , VFileImportance(..)
+ , Cacher(..)
+ , vfileSerials
+ , vfileAsBidir, vfileImportance
+ , vfileEmbeddedValue
+ , getConvertedEmbeddedValue, setConvertedEmbeddedValue
+ , tryMergeLayersForVFile
+ , vfileOriginalPath, showVFileOriginalPath
+ , vfileLayeredReadScheme
+ , vfileVoided
+ , vfiReadSuccess, vfiWriteSuccess, vfiError
+ , dataSource, dataSink, bidirVirtualFile
+ , makeSink, makeSource
+ , documentedFile
+ , withEmbeddedValue
+ , usesLayeredMapping, canBeUnmapped, unmappedByDefault
+ , usesCacherWithIdent
+ , getVFileDescription
+ , describeVFileAsSourceSink, describeVFileExtensions, describeVFileTypes
+ , describeVFileAsRecOfOptions
+ , clockVFileAccesses
+ , defaultCacherWithIdent
+ ) where
+
+import Control.Funflow
+import Control.Funflow.ContentHashable
+import Control.Lens
+import Data.Aeson (Value)
+import Data.Default
+import Data.DocRecord
+import qualified Data.HashMap.Strict as HM
+import qualified Data.HashSet as HS
+import Data.List (intersperse)
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Locations.Accessors
+import Data.Locations.Loc
+import Data.Locations.LocationTree
+import Data.Locations.LocVariable
+import Data.Locations.Mappings (HasDefaultMappingRule (..),
+ LocShortcut (..))
+import Data.Locations.SerializationMethod
+import Data.Maybe
+import Data.Monoid (First (..))
+import Data.Profunctor (Profunctor (..))
+import Data.Representable
+import Data.Semigroup (sconcat)
+import Data.Store (Store)
+import qualified Data.Text as T
+import Data.Type.Equality
+import Data.Typeable
+import Katip
+
+
+-- * The general 'VirtualFile' type
+
+-- | Tells how the file is meant to be read
+data LayeredReadScheme b where
+ SingleLayerRead :: LayeredReadScheme b
+ -- No layered reading accepted
+ LayeredRead :: Semigroup b => LayeredReadScheme b
+ -- A layered reading combining all the layers with (<>)
+ LayeredReadWithNull :: Monoid b => LayeredReadScheme b
+ -- Like 'LayeredRead', and handles mapping to no layer (mempty)
+
+-- | Tells how the accesses to this 'VirtualFile' should be logged
+data VFileImportance = VFileImportance
+ { _vfiReadSuccess :: Severity
+ , _vfiWriteSuccess :: Severity
+ , _vfiError :: Severity
+ , _vfiClockAccess :: Bool }
+ deriving (Show)
+
+makeLenses ''VFileImportance
+
+instance Default VFileImportance where
+ def = VFileImportance InfoS NoticeS ErrorS False
+
+-- | A virtual file in the location tree to which we can write @a@ and from
+-- which we can read @b@.
+data VirtualFile a b = VirtualFile
+ { _vfileOriginalPath :: [LocationTreePathItem]
+ , _vfileLayeredReadScheme :: LayeredReadScheme b
+ , _vfileEmbeddedValue :: Maybe b
+ , _vfileMappedByDefault :: Bool
+ , _vfileImportance :: VFileImportance
+ , _vfileDocumentation :: Maybe T.Text
+ , _vfileWriteCacher :: Cacher (a, Either String SomeHashableLocs) ()
+ , _vfileReadCacher :: Cacher (Either String SomeHashableLocs) b
+ , _vfileSerials :: SerialsFor a b }
+
+makeLenses ''VirtualFile
+
+-- How we derive the default configuration for mapping some VirtualFile
+instance HasDefaultMappingRule (VirtualFile a b) where
+ getDefaultLocShortcut vf = if vf ^. vfileMappedByDefault
+ then Just $
+ case vf ^? vfileSerials . serialRepetitionKeys . filtered (not . null) of
+ Nothing -> DeriveWholeLocFromTree defExt
+ -- LIMITATION: For now we suppose that every reading/writing function in
+ -- the serials has the same repetition keys
+ Just rkeys -> DeriveLocPrefixFromTree $
+ let toVar rkey = SoV_Variable rkey
+ locStr = StringWithVars $ (SoV_String "-")
+ : intersperse (SoV_String "-") (map toVar rkeys)
+ in PathWithExtension locStr $ T.unpack defExt
+ else Nothing
+ where
+ defExt =
+ case vf ^. vfileSerials . serialDefaultExt of
+ First (Just ext) -> ext
+ _ -> T.pack ""
+
+-- For now, given the requirement of PTask, VirtualFile has to be a Monoid
+-- because a VirtualTree also has to.
+instance Semigroup (VirtualFile a b) where
+ VirtualFile p l v m i d wc rc s <> VirtualFile _ _ _ _ _ _ _ _ s' =
+ VirtualFile p l v m i d wc rc (s<>s')
+instance Monoid (VirtualFile a b) where
+ mempty = VirtualFile [] SingleLayerRead Nothing True def Nothing NoCache NoCache mempty
+
+-- | The Profunctor instance is forgetful, it forgets about the mapping scheme
+-- and the caching properties.
+instance Profunctor VirtualFile where
+ dimap f g (VirtualFile p _ v m i d _ _ s) =
+ VirtualFile p SingleLayerRead (g <$> v) m i d NoCache NoCache $ dimap f g s
+
+
+-- * Obtaining a description of how the 'VirtualFile' should be used
+
+-- | Describes how a virtual file is meant to be used
+data VFileIntent =
+ VFForWriting | VFForReading | VFForRW | VFForCLIOptions
+ deriving (Show, Eq)
+
+-- | Gives the purpose of the 'VirtualFile'. Used to document the pipeline and check
+-- mappings to physical files.
+data VFileDescription = VFileDescription
+ { vfileDescIntent :: Maybe VFileIntent
+ -- ^ How is the 'VirtualFile' meant to be used
+ , vfileDescEmbeddableInConfig :: Bool
+ -- ^ True if the data can be read directly from the
+ -- pipeline's config file
+ , vfileDescEmbeddableInOutput :: Bool
+ -- ^ True if the data can be written directly in the
+ -- pipeline's output location tree
+ , vfileDescPossibleExtensions :: [FileExt]
+ -- ^ Possible extensions for the files this virtual file
+ -- can be mapped to (prefered extension is the first)
+ } deriving (Show)
+
+-- | Gives a 'VirtualFileDescription'. To be used on files stored in the
+-- VirtualTree.
+getVFileDescription :: VirtualFile a b -> VFileDescription
+getVFileDescription vf =
+ VFileDescription intent readableFromConfig writableInOutput exts
+ where
+ (SerialsFor
+ (SerialWriters toA)
+ (SerialReaders fromA fromS)
+ prefExt
+ _) = _vfileSerials vf
+ intent
+ | HM.null fromA && HM.null fromS && HM.null toA = Nothing
+ | HM.null fromA && HM.null fromS = Just VFForWriting
+ | HM.null toA = Just VFForReading
+ | Just _ <- vf ^. vfileEmbeddedValue = Just VFForCLIOptions
+ | otherwise = Just VFForRW
+ extSet = HS.fromList . mapMaybe snd . HM.keys
+ otherExts = extSet toA <> extSet fromA <> extSet fromS
+ exts = case prefExt of
+ First (Just e) -> e:(HS.toList $ HS.delete e otherExts)
+ _ -> HS.toList otherExts
+ typeOfAesonVal = typeOf (undefined :: Value)
+ readableFromConfig = (typeOfAesonVal,Nothing) `HM.member` fromA
+ writableInOutput = (typeOfAesonVal,Nothing) `HM.member` toA
+
+describeVFileAsSourceSink :: VirtualFile a b -> String
+describeVFileAsSourceSink vf =
+ sourceSink
+ ++ (if vfileDescEmbeddableInConfig vfd then " (embeddable)" else "")
+ ++ (case vf ^. vfileSerials.serialRepetitionKeys of
+ [] -> ""
+ lvs -> " repeated over " ++ concat
+ (intersperse ", " (map (("\""++) . (++"\"") . unLocVariable) lvs)))
+ where
+ sourceSink = case vfileDescIntent vfd of
+ Nothing -> ""
+ Just i -> case i of
+ VFForWriting -> "DATA SINK"
+ VFForReading -> "DATA SOURCE"
+ VFForRW -> "BIDIR VFILE"
+ VFForCLIOptions -> "OPTION SOURCE"
+ vfd = getVFileDescription vf
+
+describeVFileAsRecOfOptions :: (Typeable a, Typeable b) => VirtualFile a b -> Int -> String
+describeVFileAsRecOfOptions vf charLimit =
+ case (vf ^? vfileAsBidir) >>= getConvertedEmbeddedValue of
+ Just (RecOfOptions record :: DocRecOfOptions) ->
+ "\n--- Fields ---\n" ++ T.unpack (showDocumentation charLimit record)
+ _ -> ""
+
+describeVFileExtensions :: VirtualFile a b -> String
+describeVFileExtensions vf =
+ "Accepts " ++ T.unpack (T.intercalate (T.pack ", ") (vfileDescPossibleExtensions vfd))
+ where vfd = getVFileDescription vf
+
+describeVFileTypes :: forall a b. (Typeable a, Typeable b) => VirtualFile a b -> Int -> String
+describeVFileTypes _ charLimit
+ | a == b = "Receives & emits: " ++ cap (show a)
+ | b == typeOf (undefined :: NoRead) = "Receives " ++ cap (show a)
+ | a == typeOf (undefined :: NoWrite) = "Emits " ++ cap (show b)
+ | otherwise = "Receives " ++ cap (show a) ++ " & emits " ++ cap (show b)
+ where
+ cap x | length x >= charLimit = take charLimit x ++ "..."
+ | otherwise = x
+ a = typeOf (undefined :: a)
+ b = typeOf (undefined :: b)
+
+-- | Just for logs and error messages
+showVFileOriginalPath :: VirtualFile a b -> String
+showVFileOriginalPath = T.unpack . toTextRepr . LTP . _vfileOriginalPath
+
+-- | Embeds a value inside the 'VirtualFile'. This value will be considered the
+-- base layer if we read extra @b@'s from external physical files.
+withEmbeddedValue :: b -> VirtualFile a b -> VirtualFile a b
+withEmbeddedValue = set vfileEmbeddedValue . Just
+
+-- | Indicates that the file uses layered mapping
+usesLayeredMapping :: (Semigroup b) => VirtualFile a b -> VirtualFile a b
+usesLayeredMapping =
+ vfileLayeredReadScheme .~ LayeredRead
+
+-- | Indicates that the file uses layered mapping, and additionally can be left
+-- unmapped (ie. mapped to null)
+canBeUnmapped :: (Monoid b) => VirtualFile a b -> VirtualFile a b
+canBeUnmapped =
+ vfileLayeredReadScheme .~ LayeredReadWithNull
+
+-- | Indicates that the file should be mapped to null by default
+unmappedByDefault :: (Monoid b) => VirtualFile a b -> VirtualFile a b
+unmappedByDefault =
+ (vfileLayeredReadScheme .~ LayeredReadWithNull)
+ . (vfileMappedByDefault .~ False)
+
+-- | Gives a documentation to the 'VirtualFile'
+documentedFile :: T.Text -> VirtualFile a b -> VirtualFile a b
+documentedFile doc = vfileDocumentation .~ Just doc
+
+-- | Sets the file's reads and writes to be cached. Useful if the file is bound
+-- to a source/sink that takes time to respond, such as an HTTP endpoint, or
+-- that uses an expensive text serialization method (like JSON or XML).
+usesCacherWithIdent :: (ContentHashable Identity a, Store b)
+ => Int -> VirtualFile a b -> VirtualFile a b
+usesCacherWithIdent ident =
+ (vfileWriteCacher .~ defaultCacherWithIdent ident)
+ . (vfileReadCacher .~ defaultCacherWithIdent ident)
+
+-- * Creating VirtualFiles and convertings between its different subtypes (bidir
+-- files, sources and sinks)
+
+-- | A virtual file which depending on the situation can be written or read
+type BidirVirtualFile a = VirtualFile a a
+
+-- | A virtual file that's only readable
+type DataSource a = VirtualFile NoWrite a
+
+-- | A virtual file that's only writable
+type DataSink a = VirtualFile a NoRead
+
+-- | Creates a virtuel file from its virtual path and ways serialize/deserialize
+-- the data. You should prefer 'dataSink' and 'dataSource' for clarity when the
+-- file is meant to be readonly or writeonly.
+virtualFile :: [LocationTreePathItem] -> SerialsFor a b -> VirtualFile a b
+virtualFile path sers = VirtualFile path SingleLayerRead Nothing True def Nothing NoCache NoCache sers
+
+-- | Creates a virtual file from its virtual path and ways to deserialize the
+-- data.
+dataSource :: [LocationTreePathItem] -> SerialsFor a b -> DataSource b
+dataSource path = makeSource . virtualFile path
+
+-- | Creates a virtual file from its virtual path and ways to serialize the
+-- data.
+dataSink :: [LocationTreePathItem] -> SerialsFor a b -> DataSink a
+dataSink path = makeSink . virtualFile path
+
+-- | Like 'virtualFile', but constrained to bidirectional serials, for clarity
+bidirVirtualFile :: [LocationTreePathItem] -> BidirSerials a -> BidirVirtualFile a
+bidirVirtualFile = virtualFile
+
+-- | Turns the 'VirtualFile' into a pure source
+makeSource :: VirtualFile a b -> DataSource b
+makeSource vf = vf{_vfileSerials=eraseSerials $ _vfileSerials vf
+ ,_vfileWriteCacher=NoCache}
+
+-- | Turns the 'VirtualFile' into a pure sink
+makeSink :: VirtualFile a b -> DataSink a
+makeSink vf = vf{_vfileSerials=eraseDeserials $ _vfileSerials vf
+ ,_vfileLayeredReadScheme=LayeredReadWithNull
+ ,_vfileReadCacher=NoCache
+ ,_vfileEmbeddedValue=Nothing}
+
+
+-- * Traversals to the content of the VirtualFile, when it already embeds some
+-- value
+
+-- | If we have the internal proof that a VirtualFile is actually bidirectional,
+ -- we convert it.
+vfileAsBidir :: forall a b. (Typeable a, Typeable b)
+ => Traversal' (VirtualFile a b) (BidirVirtualFile a)
+vfileAsBidir f vf = case eqT :: Maybe (a :~: b) of
+ Just Refl -> f vf
+ Nothing -> pure vf
+
+-- | Gives access to a version of the VirtualFile without type params. The
+-- original path isn't settable.
+vfileVoided :: Lens' (VirtualFile a b) (VirtualFile NoWrite NoRead)
+vfileVoided f (VirtualFile p l v m i d wc rc s) =
+ rebuild <$> f (VirtualFile p SingleLayerRead Nothing m i d NoCache NoCache mempty)
+ where
+ rebuild (VirtualFile _ _ _ m' i' d' _ _ _) =
+ VirtualFile p l v m' i' d' wc rc s
+
+-- | If the 'VirtualFile' has an embedded value convertible to type @i@, we get
+-- it.
+getConvertedEmbeddedValue
+ :: (Typeable i)
+ => BidirVirtualFile a
+ -> Maybe i
+getConvertedEmbeddedValue vf = do
+ toA <- getToAtomicFn (vf ^. vfileSerials)
+ toA <$> vf ^. vfileEmbeddedValue
+
+-- | If the 'VirtualFile' can hold a embedded value of type @a@ that's
+-- convertible from type @i@, we set it. Note that the conversion may fail, we
+-- return Left if the VirtualFile couldn't be set.
+setConvertedEmbeddedValue
+ :: forall a b i. (Typeable i)
+ => VirtualFile a b
+ -> i
+ -> Either String (VirtualFile a b)
+setConvertedEmbeddedValue vf i =
+ case getFromAtomicFn (vf ^. vfileSerials) of
+ Nothing -> Left $ showVFileOriginalPath vf ++
+ ": no conversion function is available to transform type " ++ show (typeOf (undefined :: i))
+ Just fromA -> do
+ i' <- fromA i
+ return $ vf & vfileEmbeddedValue .~ Just i'
+
+-- | Tries to convert each @i@ layer to and from type @b@ and find a
+-- Monoid/Semigroup instance for @b@ in the vfileLayeredReadScheme, so we can
+-- merge these layers. So if we have more that one layer, this will fail if the
+-- file doesn't use LayeredRead.
+tryMergeLayersForVFile
+ :: forall a b i. (Typeable i)
+ => VirtualFile a b
+ -> [i]
+ -> Either String b
+tryMergeLayersForVFile vf layers = let ser = vf ^. vfileSerials in
+ case getFromAtomicFn ser of
+ Nothing -> Left $ showVFileOriginalPath vf ++
+ ": no conversion functions are available to transform back and forth type "
+ ++ show (typeOf (undefined :: i))
+ Just fromA -> do
+ case (layers, vf^.vfileLayeredReadScheme) of
+ ([], LayeredReadWithNull) -> return mempty
+ ([], _) -> Left $ "tryMergeLayersForVFile: " ++ showVFileOriginalPath vf
+ ++ " doesn't support mapping to no layers"
+ ([x], _) -> fromA x
+ (x:xs, LayeredRead) -> sconcat <$> traverse fromA (x:|xs)
+ (xs, LayeredReadWithNull) -> mconcat <$> traverse fromA xs
+ (_, _) -> Left $ "tryMergeLayersForVFile: " ++ showVFileOriginalPath vf
+ ++ " cannot use several layers of data"
+
+-- | Sets vfileImportance . vfiClockAccess to True. This way each access to the
+-- file will be clocked and logged.
+clockVFileAccesses :: VirtualFile a b -> VirtualFile a b
+clockVFileAccesses = vfileImportance . vfiClockAccess .~ True
diff --git a/src/Data/Representable.hs b/src/Data/Representable.hs
new file mode 100644
index 0000000..8109179
--- /dev/null
+++ b/src/Data/Representable.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.Representable where
+
+import Control.Applicative
+import Data.Text
+
+-- | A class for small objects that can be printed and read back from Text.
+--
+-- > fromTextRepr . toTextRepr == pure
+--
+class Representable a where
+ toTextRepr :: a -> Text
+ fromTextRepr :: (Alternative f) => Text -> f a
+
+instance (Representable a) => Representable (Maybe a) where
+ toTextRepr Nothing = ""
+ toTextRepr (Just x) = toTextRepr x
+ fromTextRepr "" = pure Nothing
+ fromTextRepr t = Just <$> fromTextRepr t
+
+instance Representable Text where
+ toTextRepr = id
+ fromTextRepr = pure