src/Literate/Web/Types/URL.hs

   1 {-# LANGUAGE InstanceSigs #-}
   2
   3 module Literate.Web.Types.URL (
   4   Path,
   5   encodePath,
   6   PathSegment (unPathSegment),
   7   decodePathSegment,
   8   encodePathSegment,
   9 ) where
  10
  11 import Data.Data (Data)
  12 import Data.Eq (Eq)
  13 import Data.Function (($), (.))
  14 import Data.Functor ((<$>))
  15 import Data.List (isInfixOf)
  16 import Data.Ord (Ord)
  17 import Data.Semigroup (Semigroup (..))
  18 import Data.String (IsString (..), String)
  19 import Data.Text (Text)
  20 import Data.Text qualified as Text
  21 import Data.Text.Normalize qualified as UT
  22 import GHC.Generics (Generic)
  23 import GHC.Stack (HasCallStack)
  24 import Network.URI.Encode qualified as UE
  25 import Text.Show (Show)
  26 import Prelude (FilePath, error)
  27
  28 -- * Type 'Path'
  29 type Path = [PathSegment]
  30
  31 encodePath :: [PathSegment] -> FilePath
  32 encodePath s =
  33   Text.unpack $
  34     Text.intercalate (Text.singleton '/') $
  35       encodePathSegment <$> s
  36
  37 -- ** Type 'PathSegment'
  38 newtype PathSegment = PathSegment {unPathSegment :: Text}
  39   deriving (Eq, Show, Ord, Data, Generic)
  40
  41 instance IsString PathSegment where
  42   fromString :: HasCallStack => String -> PathSegment
  43   fromString s =
  44     if "/" `isInfixOf` s
  45       then error ("PathSegment cannot contain a slash: " <> s)
  46       else PathSegment (normalizeUnicode (fromString s))
  47
  48 encodePathSegment :: PathSegment -> Text
  49 encodePathSegment = UE.encodeText . unPathSegment
  50
  51 decodePathSegment :: Text -> PathSegment
  52 decodePathSegment = fromString . UE.decode . Text.unpack
  53
  54 normalizeUnicode :: Text -> Text
  55 normalizeUnicode = UT.normalize UT.NFC