MyPath.hs

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
module MyPath where

import           Data.Maybe
import           Data.Typeable
import           GHC.TypeLits                   ( ErrorMessage(..)
                                                , TypeError
                                                )
import           System.Directory
import           Data.List
import           System.FilePath

parseAbs :: FilePath -> Maybe (Path Abs)
parseAbs = pure . AbsPath -- simplified
parseRel :: FilePath -> Maybe (Path (Rel 'False))
parseRel = pure . RelPath
parseFn :: FilePath -> Maybe (Path (Rel 'True))
parseFn = pure . FnPath


data Path (a :: PathType) where
  AbsPath ::FilePath -> Path 'Abs
  RelPath ::FilePath -> Path ('Rel 'False)
  FnPath  ::FilePath -> Path ('Rel 'True)

instance Show (Path a) where
  show (AbsPath fp) = "AbsPath " ++ show fp
  show (RelPath fp) = "RelPath " ++ show fp
  show (FnPath  fp) = "FnPath " ++ show fp

data PathType = Abs
              | Rel Bool -- True means filename
              | Any


pattern Path :: FilePath -> Path a
pattern Path a <- (toFilePath -> a)


toFilePath :: Path a -> FilePath
toFilePath (AbsPath fp) = fp
toFilePath (RelPath fp) = fp
toFilePath (FnPath  fp) = fp

class MkPath a where
  mkPath :: FilePath -> Path a
  fromPath :: Path a -> FilePath

instance MkPath 'Abs where
  mkPath   = AbsPath
  fromPath = toFilePath

instance MkPath ('Rel 'False) where
  mkPath   = RelPath
  fromPath = toFilePath

instance MkPath ('Rel 'True) where
  mkPath   = FnPath
  fromPath = toFilePath


-- | A file name can be upcasted to a relative path. All others
-- preserve their type. 'Any' is a type error.
type family UpCast (from :: PathType) :: PathType where
  UpCast 'Abs          = 'Abs
  UpCast ('Rel 'False) = 'Rel 'False
  UpCast ('Rel 'True)  = 'Rel 'False
  UpCast 'Any = TypeError ('Text "Any cannot be upcasted")


(</>) :: (UpCast b ~ r, MkPath r) => Path b -> Path ( 'Rel p) -> Path r
(</>) (Path a) (Path b) = mkPath (a ++ "/" ++ b) -- simplified


-- abs abs ~ true
-- rel rel ~ true
-- fn rel ~ true
-- _ _ ~ false
stripDir :: (UpCast this ~ from)
         => Path this
         -> Path from
         -> Maybe (Path (Rel b))
stripDir (Path p) (Path l) =
  case stripPrefix p l of
       Just x  -> if isFileName x
                     then Just $ FnPath x -- dependent types?
                     else Just $ RelPath x
       Nothing -> Nothing

  where
    isFileName = (==1) . length . splitPath