{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Path
    ( PathSegment
    , pathSegmentFromDbString
    , toPath
    , toText
    , GitBranch (..)
    , makeGitObjectPath
    , (<:>)
    ) where

import ClassyPrelude hiding ((</>))

import System.OsPath (OsPath, encodeUtf, osp, (</>))
import Text.Blaze (ToMarkup)
import Yesod.Core.Dispatch (PathPiece (..))

newtype PathSegment = PathSegment Text
    deriving (Eq, Show)
    deriving newtype (Read, ToMarkup)

instance PathPiece PathSegment where
    fromPathPiece str
        | '/' `elem` str = Nothing
        | otherwise = Just . PathSegment $ str
    toPathPiece (PathSegment x) = x

newtype GitBranch = GitBranch Text
    deriving (Eq, Show)
    deriving newtype (Read, ToMarkup, IsString)

instance PathPiece GitBranch where
    fromPathPiece str
        | ':' `elem` str = Nothing
        | otherwise = Just . GitBranch $ str
    toPathPiece (GitBranch x) = x

pathSegmentFromDbString :: Text -> PathSegment
pathSegmentFromDbString = PathSegment

toPath :: PathSegment -> OsPath
toPath (PathSegment x) = case encodeUtf . unpack $ x of
    Left _ -> error "Surrogate char in path"
    Right p -> p

toText :: PathSegment -> Text
toText (PathSegment x) = x

makeGitObjectPath :: GitBranch -> [PathSegment] -> OsPath
makeGitObjectPath br segs = br <:> path
  where
    path = foldr ((</>) . toPath) mempty segs

(<:>) :: GitBranch -> OsPath -> OsPath
GitBranch br <:> path = branch <> [osp|:|] <> path
  where
    branch = case encodeUtf . unpack $ br of
        Left _ -> error "Surrogate char in branch"
        Right p -> p