{-# LANGUAGE
MultiParamTypeClasses
, FunctionalDependencies
, NamedFieldPuns
, ScopedTypeVariables
, OverloadedStrings
#-}
module Path.Extended
(
Location (..)
, QueryParam
,
ToPath (..)
, ToLocation (..)
, FromPath (..)
, FromLocation (..)
,
PathAppend (..)
,
addParent
, delParent
,
fromPath
,
setFileExt
, addFileExt
, delFileExt
, getFileExt
,
setQuery
, addQuery
, (<&>)
, addQueries
, delQuery
, getQuery
,
setFragment
, addFragment
, (<#>)
, delFragment
, getFragment
,
locationAbsDirParser
, locationAbsFileParser
) where
import Path as P hiding ((</>))
import qualified Path as P ((</>))
import Prelude hiding (takeWhile)
import Data.List (intercalate)
import Data.Attoparsec.Text (Parser, char, takeWhile, takeWhile1, sepBy, sepBy1)
import qualified Data.Text as T
import Data.Monoid ((<>))
import Control.Applicative (Alternative (many), optional)
import Control.Exception (SomeException)
import Control.Monad (void)
class PathAppend right base type' where
(</>) :: Path base Dir -> right Rel type' -> right base type'
class ToPath sym base type' | sym -> base type' where
toPath :: sym -> Path base type'
class ToLocation sym base type' | sym -> base type' where
toLocation :: sym -> Location base type'
class FromPath sym base type' | sym -> base type' where
parsePath :: Path base type' -> Either String sym
class FromLocation sym base type' | sym -> base type' where
parseLocation :: Location base type' -> Either String sym
data Location b t = Location
{ locParentJumps :: Int
, locPath :: Path b t
, locFileExt :: Maybe String
, locQueryParams :: [QueryParam]
, locFragment :: Maybe String
} deriving (Eq, Ord)
locationAbsDirParser :: Parser (Location Abs Dir)
locationAbsDirParser = do
locPath <- absDir
locQueryParams <- do
xs <- optional $ do
let val = T.unpack <$> takeWhile (`notElem` ['=','&','#'])
void (char '?')
let kv = do
k <- val
mV <- optional $ do
void (char '=')
val
pure (k,mV)
kv `sepBy` void (char '&')
case xs of
Nothing -> pure []
Just xs' -> pure xs'
locFragment <- optional $ do
void (char '#')
xs <- takeWhile (const True)
pure (T.unpack xs)
pure Location
{ locParentJumps = 0
, locPath
, locFileExt = Nothing
, locQueryParams
, locFragment
}
where
divider = void (char '/')
chunk = takeWhile1 (`notElem` ['?','&','/','#'])
absDir :: Parser (Path Abs Dir)
absDir = do
divider
xs <- many (chunk <* divider)
case parseAbsDir ( case xs of
[] -> "/"
_ -> T.unpack ("/" <> T.intercalate "/" xs <> "/")
) of
Left (e :: SomeException) -> fail (show e)
Right x -> pure x
locationAbsFileParser :: Parser (Location Abs File)
locationAbsFileParser = do
(locPath, locFileExt) <- absFile
locQueryParams <- do
xs <- optional $ do
let val = T.unpack <$> takeWhile (`notElem` ['=','&','#'])
void (char '?')
let kv = do
k <- val
mV <- optional $ do
void (char '=')
val
pure (k,mV)
kv `sepBy` void (char '&')
case xs of
Nothing -> pure []
Just xs' -> pure xs'
locFragment <- optional $ do
void (char '#')
xs <- takeWhile (const True)
pure (T.unpack xs)
pure Location
{ locParentJumps = 0
, locPath
, locFileExt
, locQueryParams
, locFragment
}
where
divider = void (char '/')
chunk = takeWhile1 (`notElem` ['?','&','/','#'])
absFile :: Parser (Path Abs File, Maybe String)
absFile = do
divider
xs <- chunk `sepBy1` divider
let (withoutFE,withFE) = T.breakOn "." (last xs)
xs' = init xs <> [withoutFE]
path <- case parseAbsFile (T.unpack ("/" <> T.intercalate "/" xs')) of
Left (e :: SomeException) -> fail (show e)
Right x -> pure x
pure
( path
, if T.null withFE
then Nothing
else Just $ T.unpack $ T.drop 1 withFE
)
instance PathAppend Path Abs Dir where
(</>) = (P.</>)
instance PathAppend Path Abs File where
(</>) = (P.</>)
instance PathAppend Path Rel Dir where
(</>) = (P.</>)
instance PathAppend Path Rel File where
(</>) = (P.</>)
instance PathAppend Location Abs Dir where
l </> (Location ps pa fe qp fr) =
Location ps ((P.</>) l pa) fe qp fr
instance PathAppend Location Abs File where
l </> (Location ps pa fe qp fr) =
Location ps ((P.</>) l pa) fe qp fr
instance PathAppend Location Rel Dir where
l </> (Location ps pa fe qp fr) =
Location ps ((P.</>) l pa) fe qp fr
instance PathAppend Location Rel File where
l </> (Location ps pa fe qp fr) =
Location ps ((P.</>) l pa) fe qp fr
instance Show (Location b t) where
show (Location js pa fe qp fr) =
let loc = concat (replicate js "../")
++ toFilePath pa
++ maybe "" (\f -> "." ++ f) fe
query = case qp of
[] -> ""
qs -> "?" ++ intercalate "&" (map go qs)
where
go (k,mv) = k ++ maybe "" (\v -> "=" ++ v) mv
in loc ++ query ++ maybe "" (\f -> "#" ++ f) fr
type QueryParam = (String, Maybe String)
addParent :: Location Rel t -> Location Rel t
addParent (Location j pa fe qp fr) =
Location (j+1) pa fe qp fr
delParent :: Location Rel t -> Location Rel t
delParent l@(Location j pa fe qp fr)
| j <= 0 = l
| otherwise = Location (j-1) pa fe qp fr
fromPath :: Path b t -> Location b t
fromPath pa = Location 0 pa Nothing [] Nothing
setFileExt :: Maybe String -> Location b File -> Location b File
setFileExt fe (Location js pa _ qp fr) =
Location js pa fe qp fr
addFileExt :: String -> Location b File -> Location b File
addFileExt fe = setFileExt (Just fe)
delFileExt :: Location b File -> Location b File
delFileExt = setFileExt Nothing
getFileExt :: Location b File -> Maybe String
getFileExt (Location _ _ fe _ _) =
fe
setQuery :: [QueryParam] -> Location b t -> Location b t
setQuery qp (Location js pa fe _ fr) =
Location js pa fe qp fr
addQuery :: QueryParam -> Location b t -> Location b t
addQuery q (Location js pa fe qp fr) =
Location js pa fe (qp ++ [q]) fr
(<&>) :: Location b t -> QueryParam -> Location b t
(<&>) = flip addQuery
infixl 7 <&>
addQueries :: [QueryParam] -> Location b t -> Location b t
addQueries qs (Location js pa fe qs' fr) =
Location js pa fe (qs' ++ qs) fr
delQuery :: Location b t -> Location b t
delQuery = setQuery []
getQuery :: Location b t -> [QueryParam]
getQuery (Location _ _ _ qp _) =
qp
setFragment :: Maybe String -> Location b t -> Location b t
setFragment fr (Location js pa fe qp _) =
Location js pa fe qp fr
addFragment :: String -> Location b t -> Location b t
addFragment fr = setFragment (Just fr)
(<#>) :: Location b t -> String -> Location b t
(<#>) = flip addFragment
infixl 8 <#>
delFragment :: Location b t -> Location b t
delFragment = setFragment Nothing
getFragment :: Location b t -> Maybe String
getFragment (Location _ _ _ _ x) = x