cli/Hcompta/Lib/System/File/Path.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE DeriveFunctor #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE GADTs #-}
   5 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   6 {-# LANGUAGE MultiParamTypeClasses #-}
   7 {-# LANGUAGE OverloadedStrings #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9 {-# OPTIONS_GHC -fno-warn-tabs #-}
  10 {-# OPTIONS_GHC -fno-warn-orphans #-}
  11
  12 module Hadmin.Lib.System.File.Path where
  13
  14 import Data.Foldable (foldMap)
  15 import Data.Function (($), (.))
  16 import Data.Functor (Functor(..), (<$>))
  17 import qualified Data.List as List
  18 import Data.Maybe (Maybe(..))
  19 import Data.Monoid (Monoid(..), (<>))
  20 import Data.String (IsString(..))
  21 import Data.Text (Text)
  22 import Data.Text.Buildable (Buildable(..))
  23 import GHC.Exts (IsList(..))
  24 import Prelude (undefined)
  25 import qualified System.FilePath.Posix as FP
  26
  27 import Hadmin.Lib.Data.Text
  28
  29 -- * Type 'Path'
  30 type Path pos a = InPos pos (InDir a)
  31
  32 -- * Type 'Position'
  33 data Position = Absolute | Relative
  34
  35 -- ** Type 'SPos'
  36 -- | Singleton type for 'Position'.
  37 data SPos pos where
  38         Abs :: SPos 'Absolute
  39         Rel :: SPos 'Relative
  40
  41 -- ** Type 'IPos'
  42
  43 -- | Implicit class for 'Position'.
  44 class IPos pos where
  45         pos :: SPos pos
  46 instance IPos 'Absolute where pos = Abs
  47 instance IPos 'Relative where pos = Rel
  48
  49 -- ** Type 'InPos'
  50 data InPos pos a = InPos (SPos pos) a
  51  deriving (Functor)
  52 instance Buildable a => Buildable (InPos pos a) where
  53         build (InPos Abs a) = build FP.pathSeparator <> build a
  54         build (InPos Rel a) = build a
  55 instance (IsString a, IPos pos) => IsString (InPos pos a) where
  56         fromString = InPos pos . fromString
  57
  58 -- ** Type 'PosOf'
  59 type family PosOf x :: Position
  60 type instance PosOf (InPos pos a) = pos
  61
  62 -- * Type 'Dir'
  63
  64 newtype Dir = Dir [Dir_Seg]
  65  deriving (Monoid)
  66 type Dir_Seg = Text
  67 type AbsDir = InPos 'Absolute Dir
  68 type RelDir = InPos 'Relative Dir
  69 instance IsString Dir where
  70         fromString = Dir . (fromString <$>) . splitOnChar FP.pathSeparator
  71 instance IsList Dir where
  72         type Item Dir = Dir_Seg
  73         fromList = Dir . foldMap (splitOnChar FP.pathSeparator)
  74         toList (Dir d) = toList d
  75 instance Buildable Dir where
  76         build (Dir []) = "."
  77         build (Dir p) =
  78                 mconcat $
  79                 List.intersperse
  80                  (build FP.pathSeparator)
  81                  (build <$> p)
  82
  83 {-
  84 absDir :: InPos pos a -> InPos 'Absolute a
  85 absDir (InPos _p a) = InPos Abs a
  86
  87 relDir :: InPos pos a -> InPos 'Relative a
  88 relDir (InPos _p a) = InPos Rel a
  89 -}
  90
  91 -- ** Type 'InDir'
  92 data InDir a = InDir Dir a
  93  deriving (Functor)
  94 instance IsString (a -> InDir a) where
  95         fromString = InDir . fromString
  96 instance IsString a => IsString (InDir a) where
  97         fromString s =
  98                 case splitOnChar FP.pathSeparator s of
  99                  [] -> InDir (Dir []) $ fromString ""
 100                  l  -> InDir (Dir $ fromString <$> List.init l) $ fromString (List.last l)
 101 instance IsList (a -> InDir a) where
 102         type Item (a -> InDir a) = Dir_Seg
 103         fromList = InDir . fromList
 104         toList = undefined
 105 instance Buildable a => Buildable (InDir a) where
 106         build (InDir d a) = build d <> build FP.pathSeparator <> build a
 107
 108 -- ** Class 'Dir_Parent'
 109
 110 -- | Return the parent 'Dir' of given 'Dir'
 111 class Dir_Parent d where
 112         type Dir_Parent_Dir d
 113         dir_parent :: d -> Maybe (Dir_Parent_Dir d)
 114
 115 instance Dir_Parent Dir where
 116         type Dir_Parent_Dir Dir = Dir
 117         dir_parent (Dir p) =
 118                 case p of
 119                  [] -> Nothing
 120                  _  -> Just $ Dir (List.init p)
 121 instance Dir_Parent a => Dir_Parent (InPos pos a) where
 122         type Dir_Parent_Dir (InPos pos a) = InPos pos (Dir_Parent_Dir a)
 123         dir_parent (InPos p a) = InPos p <$> dir_parent a
 124 instance Dir_Parent (InDir a) where
 125         type Dir_Parent_Dir (InDir a) = Dir
 126         dir_parent (InDir d _a) = Just d
 127 {-
 128 instance Dir_Parent File where
 129         type Dir_Parent_Dir File = Dir
 130         dir_parent (File _f) = Just $ Dir []
 131 -}
 132
 133 -- ** Class 'Dir_Ancestors'
 134
 135 -- | Return self and parents 'Dir' of given 'Dir', in topological order.
 136 class Dir_Ancestors d where
 137         type Dir_Ancestors_Dir d
 138         dir_ancestors :: d -> [Dir_Parent_Dir d]
 139
 140 instance Dir_Ancestors Dir where
 141         type Dir_Ancestors_Dir Dir = Dir
 142         dir_ancestors (Dir p) =
 143                 List.reverse $
 144                 List.foldl' (\acc seg ->
 145                         case acc of
 146                          [] -> [Dir [seg]]
 147                          Dir d:_ -> Dir (d<>[seg]):acc
 148                  ) [Dir []] p
 149 instance Dir_Ancestors a => Dir_Ancestors (InPos pos a) where
 150         type Dir_Ancestors_Dir (InPos pos a) = InPos pos (Dir_Ancestors_Dir a)
 151         dir_ancestors (InPos p a) = InPos p <$> dir_ancestors a
 152 instance Dir_Ancestors (InDir a) where
 153         type Dir_Ancestors_Dir (InDir a) = Dir
 154         dir_ancestors (InDir d _a) = dir_ancestors d
 155 {-
 156 instance Dir_Ancestors File where
 157         type Dir_Ancestors_Dir File = Dir
 158         dir_ancestors (File _f) = [Dir []]
 159 -}
 160
 161 -- ** Class 'Dir_Append'
 162 class Dir_Append p q where
 163         type Dir_Append_Dir p q
 164         (</>) :: p -> q -> Dir_Append_Dir p q
 165 instance Dir_Append (InPos p Dir) (InPos 'Relative Dir) where
 166         type Dir_Append_Dir (InPos p Dir) (InPos 'Relative Dir) = InPos p Dir
 167         (</>) (InPos p x) (InPos _q y) = InPos p (x <> y)
 168 instance Dir_Append (InPos p Dir) File where
 169         type Dir_Append_Dir (InPos p Dir) File = InPos p (InDir File)
 170         (</>) (InPos p d) f = InPos p (InDir d f)
 171 instance Dir_Append (InPos p Dir) (InPos 'Relative (InDir a)) where
 172         type Dir_Append_Dir (InPos p Dir) (InPos 'Relative (InDir a)) = InPos p (InDir a)
 173         (</>) (InPos p x) (InPos _q (InDir y a)) = InPos p (InDir (x <> y) a)
 174
 175 -- * Type 'File'
 176 newtype File = File [Text]
 177 instance IsString File where
 178         fromString = File . (fromString <$>) . splitOnCharWithEmpty FP.extSeparator
 179 instance Buildable File where
 180         build (File p) =
 181                 mconcat $
 182                 List.intersperse
 183                  (build FP.extSeparator)
 184                  (build <$> p)
 185
 186 type RelFile = InPos 'Relative (InDir File)