diff --git a/System/Monopati/Posix.hs b/System/Monopati/Posix.hs --- a/System/Monopati/Posix.hs +++ b/System/Monopati/Posix.hs @@ -1,4 +1,6 @@ module System.Monopati.Posix ( + -- * Types and instances + module System.Monopati.Posix.Core, -- * CRUD operations for filesystem module System.Monopati.Posix.Calls, -- * Pure combinators @@ -7,3 +9,4 @@ import System.Monopati.Posix.Calls import System.Monopati.Posix.Combinators +import System.Monopati.Posix.Core diff --git a/System/Monopati/Posix/Calls.hs b/System/Monopati/Posix/Calls.hs --- a/System/Monopati/Posix/Calls.hs +++ b/System/Monopati/Posix/Calls.hs @@ -1,4 +1,4 @@ -module System.Monopati.Posix.Calls (current, home, create, change, remove) where +module System.Monopati.Posix.Calls (Problem (..), current, home, create, change, remove) where import "base" Data.Bool (Bool (True)) import "base" Data.Foldable (Foldable (foldr)) @@ -14,7 +14,15 @@ import "free" Control.Comonad.Cofree (Cofree ((:<))) import "split" Data.List.Split (splitOn) -import System.Monopati.Posix.Combinators (Points (Directory), To, Path, Origin (Root), Outline (Outline), Absolute, Homeward, Relative) +import System.Monopati.Posix.Core + ( Points (Directory), Dummy (To), Path, Origin (Root), Outline (Outline) + , Absolute, Homeward, Relative) + +data Problem + = Hardware -- ^ A physical I/O error has occurred: [EIO] + | Permission -- ^ The process has insufficient privileges to perform the operation: [EROFS, EACCES, EPERM] + | Exhausted -- ^ Insufficient resources are available to perform the operation: [EDQUOT, ENOSPC, ENOMEM, EMLINK] + | Missing -- ^ There is no path to the target: [ENOENT, ENOTDIR] -- | Return Nothing, if current working directory is root (cwd) current :: IO (Maybe (Absolute Path To Directory)) diff --git a/System/Monopati/Posix/Combinators.hs b/System/Monopati/Posix/Combinators.hs --- a/System/Monopati/Posix/Combinators.hs +++ b/System/Monopati/Posix/Combinators.hs @@ -1,129 +1,21 @@ module System.Monopati.Posix.Combinators - ( Points (..), Origin (..), To, Path, Outline (..) - , Absolute, Currently, Homeward, Relative, Incompleted - , deeper, part, parent, (<^>), (<.^>), (<~^>), (<^^>), (), (), (), ()) where + ( deeper, part, parent, unparent + , (<^>), (<.^>), (<~^>), (<-^>), (<^^>) + , (), (), (), (), ()) where -import "base" Control.Applicative (pure) import "base" Data.Eq (Eq ((/=))) -import "base" Data.Foldable (Foldable (foldr)) import "base" Data.Function ((.), ($), (&), flip) import "base" Data.Functor ((<$>)) -import "base" Data.Kind (Constraint, Type) -import "base" Data.List (filter, init, reverse) -import "base" Data.Maybe (Maybe (Just, Nothing), maybe) -import "base" Data.Semigroup (Semigroup ((<>))) +import "base" Data.List (filter) +import "base" Data.Maybe (Maybe (Just, Nothing)) import "base" Data.String (String) -import "base" Text.Read (Read (readsPrec)) -import "base" Text.Show (Show (show)) +import "base" Prelude (undefined) import "free" Control.Comonad.Cofree (Cofree ((:<)), unwrap) -import "split" Data.List.Split (endBy, splitOn) - --- | What the path points to? -data Points = Directory | File - --- | What is the beginning of the path? -data Origin - = Root -- ^ (@/@) Starting point for absolute path - | Current -- ^ (@~/@) Relatively current working directory - | Home -- ^ (@~/@) Indication of home directory - | Vague -- ^ Uncertain relative path - --- | Dummy type needed only for beautiful type declarations -data To - --- | Path is non-empty sequence of folders or file (in the end) -type Path = Cofree Maybe String - --- | The internal type of path representation -newtype Outline (origin :: Origin) (points :: Points) = - Outline { outline :: Path } deriving Eq - -instance Show (Outline Root Directory) where - show = flip (<>) "/" . foldr (\x acc -> acc <> "/" <> x) "" . outline - -instance Show (Outline Root File) where - show = foldr (\x acc -> acc <> "/" <> x) "" . outline - -instance Show (Outline Current Directory) where - show = (<>) "./" . foldr (\x acc -> x <> "/" <> acc) "" . outline - -instance Show (Outline Current File) where - show = (<>) "./" . init . foldr (\x acc -> x <> "/" <> acc) "" . outline - -instance Show (Outline Home Directory) where - show = (<>) "~/" . foldr (\x acc -> x <> "/" <> acc) "" . outline - -instance Show (Outline Home File) where - show = (<>) "~/" . init . foldr (\x acc -> x <> "/" <> acc) "" . outline - -instance Show (Outline Vague Directory) where - show = foldr (\x acc -> x <> "/" <> acc) "" . outline - -instance Show (Outline Vague File) where - show = init . foldr (\x acc -> x <> "/" <> acc) "" . outline - -instance Read (Outline Root Directory) where - readsPrec _ ('/':[]) = [] - readsPrec _ ('/':rest) = foldr (\el -> Just . (:<) el) Nothing - (reverse $ endBy "/" rest) & maybe [] (pure . (,[]) . Outline) - readsPrec _ _ = [] - -instance Read (Outline Root File) where - readsPrec _ ('/':[]) = [] - readsPrec _ ('/':rest) = foldr (\el -> Just . (:<) el) Nothing - (reverse $ splitOn "/" rest) & maybe [] (pure . (,[]) . Outline) - readsPrec _ _ = [] - -instance Read (Outline Current Directory) where - readsPrec _ ('.':'/':[]) = [] - readsPrec _ ('.':'/':rest) = foldr (\el -> Just . (:<) el) Nothing - (endBy "/" rest) & maybe [] (pure . (,[]) . Outline) - readsPrec _ _ = [] - -instance Read (Outline Current File) where - readsPrec _ ('.':'/':[]) = [] - readsPrec _ ('.':'/':rest) = foldr (\el -> Just . (:<) el) Nothing - (splitOn "/" rest) & maybe [] (pure . (,[]) . Outline) - readsPrec _ _ = [] - -instance Read (Outline Home Directory) where - readsPrec _ ('~':'/':[]) = [] - readsPrec _ ('~':'/':rest) = foldr (\el -> Just . (:<) el) Nothing - (endBy "/" rest) & maybe [] (pure . (,[]) . Outline) - readsPrec _ _ = [] - -instance Read (Outline Home File) where - readsPrec _ ('~':'/':[]) = [] - readsPrec _ ('~':'/':rest) = foldr (\el -> Just . (:<) el) Nothing - (splitOn "/" rest) & maybe [] (pure . (,[]) . Outline) - readsPrec _ _ = [] - -instance Read (Outline Vague Directory) where - readsPrec _ [] = [] - readsPrec _ string = foldr (\el -> Just . (:<) el) Nothing - (endBy "/" string) & maybe [] (pure . (,[]) . Outline) - -instance Read (Outline Vague File) where - readsPrec _ [] = [] - readsPrec _ string = foldr (\el -> Just . (:<) el) Nothing - (splitOn "/" string) & maybe [] (pure . (,[]) . Outline) - -type family Absolute (path :: Type) (to :: Type) (points :: Points) :: Type where - Absolute Path To points = Outline Root points - -type family Currently (path :: Type) (to :: Type) (points :: Points) :: Type where - Currently Path To points = Outline Current points - -type family Homeward (path :: Type) (to :: Type) (points :: Points) :: Type where - Homeward Path To points = Outline Home points - -type family Relative (path :: Type) (to :: Type) (points :: Points) :: Type where - Relative Path To points = Outline Vague points +import "peano" Data.Peano (Peano (Zero, Succ)) -type family Incompleted (outline :: Origin) :: Constraint where - Incompleted Current = () - Incompleted Home = () - Incompleted Vague = () +import System.Monopati.Posix.Core + ( Points (..), Origin (..), Dummy (For, To), Path, Outline (..), Parent (..) + , Absolute, Current, Homeward, Previous, Relative, Incompleted, Parental) -- | Immerse string into a path, filter slashes part :: String -> Outline origin points @@ -139,7 +31,7 @@ {-| @ ".//etc///" + "usr///local///" + = ".///etc///usr///local//" @ -} -(<.^>) :: Currently Path To Directory -> Relative Path To points -> Currently Path To points +(<.^>) :: Current Path To Directory -> Relative Path To points -> Current Path To points currently <.^> relative = currently <^> relative {-| @ @@ -149,6 +41,12 @@ homeward <~^> relative = homeward <^> relative {-| @ +"-//etc///" + "usr///local///" + = "-///etc///usr///local//" +@ -} +(<-^>) :: Previous Path To Directory -> Relative Path To points -> Previous Path To points +previous <-^> relative = previous <^> relative + +{-| @ "etc//" + "usr///local///" + = "etc///usr///local//" @ -} (<^^>) :: Relative Path To Directory -> Relative Path To points -> Relative Path To points @@ -163,20 +61,31 @@ {-| @ "//usr///local///" + ".///etc///" = "///usr///local///etc//" @ -} -() :: Absolute Path To Directory -> Currently Path To points -> Absolute Path To points +() :: Absolute Path To Directory -> Current Path To points -> Absolute Path To points absolute currently = absolute currently {-| @ -"//usr///local///" + "~///etc///" = "///usr///local///etc//" +"//usr///local///" + "-///etc///" = "///usr///local///etc//" @ -} () :: Absolute Path To Directory -> Homeward Path To points -> Absolute Path To points absolute homeward = absolute homeward {-| @ +"//usr///local///" + "~///etc///" = "///usr///local///etc//" +@ -} +() :: Absolute Path To Directory -> Previous Path To points -> Absolute Path To points +absolute previous = absolute previous + +{-| @ "//usr///bin///" + "git" = "///usr///bin//git" @ -} () :: Absolute Path To Directory -> Relative Path To points -> Absolute Path To points absolute relative = absolute relative + +unparent :: Parental For (Outline origin Directory) -> Maybe (Outline origin Directory) +unparent (Parent Zero outline) = Just outline +unparent (Parent (Succ n) (Outline (x :< Nothing))) = Nothing +unparent (Parent (Succ n) (Outline (x :< Just xs))) = unparent . Parent n $ Outline xs -- | Take parent directory of current pointed entity parent :: Absolute Path To points -> Maybe (Absolute Path To Directory) diff --git a/System/Monopati/Posix/Core.hs b/System/Monopati/Posix/Core.hs new file mode 100644 --- /dev/null +++ b/System/Monopati/Posix/Core.hs @@ -0,0 +1,178 @@ +module System.Monopati.Posix.Core + ( Points (..), Origin (..), Dummy (..), Path, Outline (..), Parent (..) + , Absolute, Current, Homeward, Previous, Relative + , Incompleted, Certain, Parental) where + +import "base" Control.Applicative (pure) +import "base" Data.Eq (Eq) +import "base" Data.Foldable (Foldable (foldr)) +import "base" Data.Function ((.), ($), (&), flip) +import "base" Data.Kind (Constraint, Type) +import "base" Data.List (init, replicate, reverse) +import "base" Data.Maybe (Maybe (Just, Nothing), maybe) +import "base" Data.Semigroup (Semigroup ((<>))) +import "base" Data.String (String) +import "base" Prelude (fromEnum) +import "base" Text.Read (Read (readsPrec)) +import "base" Text.Show (Show (show)) +import "free" Control.Comonad.Cofree (Cofree ((:<))) +import "peano" Data.Peano (Peano) +import "split" Data.List.Split (endBy, splitOn) + +-- | What the path points to? +data Points = Directory | File + +-- | What is the beginning of the path? +data Origin + = Root -- ^ Starting point for absolute path + | Now -- ^ Indication of current working directory + | Home -- ^ Indication of home directory + | Early -- ^ Indication of previous current working directory + | Vague -- ^ For uncertain relative path + +-- | Dummy type needed only for beautiful type declarations +data Dummy = For | To + +-- | Path is non-empty sequence of folders or file (in the end) +type Path = Cofree Maybe String + +-- | The internal type of path representation +newtype Outline (origin :: Origin) (points :: Points) = + Outline { outline :: Path } deriving Eq + +show_foldaway, show_foldaway_reverse :: Outline origin points -> String +show_foldaway = foldr (\x acc -> x <> "/" <> acc) "" . outline +show_foldaway_reverse = foldr (\x acc -> acc <> "/" <> x) "" . outline + +generate_parental_string :: Peano -> String +generate_parental_string n = foldr (<>) "" $ replicate (fromEnum n) "../" + +type family Absolute (path :: Type) (to :: Dummy) (points :: Points) :: Type where + Absolute Path To points = Outline Root points + +instance Show (Outline Root Directory) where show = flip (<>) "/" . show_foldaway_reverse +instance Show (Outline Root File) where show = show_foldaway_reverse + +instance Read (Outline Root Directory) where + readsPrec _ ('/':[]) = [] + readsPrec _ ('/':rest) = foldr (\el -> Just . (:<) el) Nothing + (reverse $ endBy "/" rest) & maybe [] (pure . (,[]) . Outline) + readsPrec _ _ = [] + +instance Read (Outline Root File) where + readsPrec _ ('/':[]) = [] + readsPrec _ ('/':rest) = foldr (\el -> Just . (:<) el) Nothing + (reverse $ splitOn "/" rest) & maybe [] (pure . (,[]) . Outline) + readsPrec _ _ = [] + +type family Current (path :: Type) (to :: Dummy) (points :: Points) :: Type where + Current Path To points = Outline Now points + +instance Show (Outline Now Directory) where show = (<>) "./" . show_foldaway +instance Show (Outline Now File) where show = (<>) "./" . init . show_foldaway + +instance Read (Outline Now Directory) where + readsPrec _ ('.':'/':[]) = [] + readsPrec _ ('.':'/':rest) = foldr (\el -> Just . (:<) el) Nothing + (endBy "/" rest) & maybe [] (pure . (,[]) . Outline) + readsPrec _ _ = [] + +instance Read (Outline Now File) where + readsPrec _ ('.':'/':[]) = [] + readsPrec _ ('.':'/':rest) = foldr (\el -> Just . (:<) el) Nothing + (splitOn "/" rest) & maybe [] (pure . (,[]) . Outline) + readsPrec _ _ = [] + +type family Homeward (path :: Type) (to :: Dummy) (points :: Points) :: Type where + Homeward Path To points = Outline Home points + +instance Show (Outline Home Directory) where show = (<>) "~/" . show_foldaway +instance Show (Outline Home File) where show = (<>) "~/" . init . show_foldaway + +instance Read (Outline Home Directory) where + readsPrec _ ('~':'/':[]) = [] + readsPrec _ ('~':'/':rest) = foldr (\el -> Just . (:<) el) Nothing + (endBy "/" rest) & maybe [] (pure . (,[]) . Outline) + readsPrec _ _ = [] + +instance Read (Outline Home File) where + readsPrec _ ('~':'/':[]) = [] + readsPrec _ ('~':'/':rest) = foldr (\el -> Just . (:<) el) Nothing + (splitOn "/" rest) & maybe [] (pure . (,[]) . Outline) + readsPrec _ _ = [] + +type family Previous (path :: Type) (to :: Dummy) (points :: Points) :: Type where + Previous Path To points = Outline Early points + +instance Show (Outline Early Directory) where show = (<>) "-/" . show_foldaway +instance Show (Outline Early File) where show = (<>) "-/" . init . show_foldaway + +instance Read (Outline Early Directory) where + readsPrec _ ('-':'/':[]) = [] + readsPrec _ ('-':'/':rest) = foldr (\el -> Just . (:<) el) Nothing + (endBy "/" rest) & maybe [] (pure . (,[]) . Outline) + readsPrec _ _ = [] + +instance Read (Outline Early File) where + readsPrec _ ('-':'/':[]) = [] + readsPrec _ ('-':'/':rest) = foldr (\el -> Just . (:<) el) Nothing + (splitOn "/" rest) & maybe [] (pure . (,[]) . Outline) + readsPrec _ _ = [] + +type family Relative (path :: Type) (to :: Dummy) (points :: Points) :: Type where + Relative Path To points = Outline Vague points + +instance Show (Outline Vague Directory) where show = show_foldaway +instance Show (Outline Vague File) where show = init . show_foldaway + +instance Read (Outline Vague Directory) where + readsPrec _ [] = [] + readsPrec _ rest = foldr (\el -> Just . (:<) el) Nothing + (endBy "/" rest) & maybe [] (pure . (,[]) . Outline) + +instance Read (Outline Vague File) where + readsPrec _ [] = [] + readsPrec _ rest = foldr (\el -> Just . (:<) el) Nothing + (splitOn "/" rest) & maybe [] (pure . (,[]) . Outline) + +type family Incompleted (origin :: Origin) :: Constraint where + Incompleted Now = () + Incompleted Home = () + Incompleted Early = () + Incompleted Vague = () + +type family Certain (origin :: Origin) :: Constraint where + Certain Root = () + Certain Now = () + Certain Home = () + Certain Early = () + +data Parent origin points = Incompleted origin => + Parent Peano (Outline origin points) + +type family Parental (for :: Dummy) (outline :: Type) :: Type where + Parental For (Outline origin points) = Parent origin points + +instance Show (Parent Now Directory) where + show (Parent n raw) = "./" <> generate_parental_string n <> show_foldaway raw + +instance Show (Parent Now File) where + show (Parent n raw) = "./" <> generate_parental_string n <> (init $ show_foldaway raw) + +instance Show (Parent Home Directory) where + show (Parent n raw) = "~/" <> generate_parental_string n <> show_foldaway raw + +instance Show (Parent Home File) where + show (Parent n raw) = "~/" <> generate_parental_string n <> (init $ show_foldaway raw) + +instance Show (Parent Early Directory) where + show (Parent n raw) = "-/" <> generate_parental_string n <> show_foldaway raw + +instance Show (Parent Early File) where + show (Parent n raw) = "-/" <> generate_parental_string n <> (init $ show_foldaway raw) + +instance Show (Parent Vague Directory) where + show (Parent n raw) = generate_parental_string n <> show_foldaway raw + +instance Show (Parent Vague File) where + show (Parent n raw) = generate_parental_string n <> (init $ show_foldaway raw) diff --git a/Test/Monopati.hs b/Test/Monopati.hs --- a/Test/Monopati.hs +++ b/Test/Monopati.hs @@ -6,8 +6,9 @@ import Test.Monopati.Posix ( show_then_read_absolute - , show_then_read_currently + , show_then_read_current , show_then_read_homeward + , show_then_read_previous , show_then_read_relative ) main = do @@ -15,6 +16,7 @@ hSetBuffering stderr LineBuffering checkParallel $ Group "Simple Posix tests" [ ("Show then read absolute", show_then_read_absolute), - ("Show then read currently", show_then_read_currently), + ("Show then read current", show_then_read_current), ("Show then read homeward", show_then_read_homeward), + ("Show then read previous", show_then_read_previous), ("Show then read relative", show_then_read_relative)] diff --git a/monopati.cabal b/monopati.cabal --- a/monopati.cabal +++ b/monopati.cabal @@ -1,5 +1,5 @@ name: monopati -version: 0.1.3 +version: 0.1.4 synopsis: Well-typed paths description: Despite the fact that there are a plenty of various well-typed "path" libraries in Haskell, I decided to write new one that I would like to use. homepage: https://github.com/iokasimov/monopati @@ -17,9 +17,10 @@ location: https://github.com/iokasimov/monopati.git library - build-depends: base == 4.*, directory, free, split + build-depends: base == 4.*, directory, free, peano, split default-extensions: DataKinds + ExistentialQuantification FlexibleInstances KindSignatures NoImplicitPrelude @@ -32,10 +33,10 @@ default-language: Haskell2010 exposed-modules: System.Monopati.Posix - System.Monopati.Windows - other-modules: + System.Monopati.Posix.Core System.Monopati.Posix.Calls System.Monopati.Posix.Combinators + System.Monopati.Windows System.Monopati.Windows.Calls System.Monopati.Windows.Combinators ghc-options: -fno-warn-tabs @@ -43,10 +44,11 @@ test-suite test type: exitcode-stdio-1.0 main-is: Test/Monopati.hs - build-depends: base == 4.*, directory, free, split, transformers, hedgehog + build-depends: base == 4.*, directory, free, peano, split, transformers, hedgehog default-extensions: OverloadedStrings DataKinds + ExistentialQuantification FlexibleInstances KindSignatures NoImplicitPrelude