{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Hadmin.Lib.System.File.Path where

import Data.Foldable (foldMap)
import Data.Function (($), (.))
import Data.Functor (Functor(..), (<$>))
import qualified Data.List as List
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..), (<>))
import Data.String (IsString(..))
import Data.Text (Text)
import Data.Text.Buildable (Buildable(..))
import GHC.Exts (IsList(..))
import Prelude (undefined)
import qualified System.FilePath.Posix as FP

import Hadmin.Lib.Data.Text

-- * Type 'Path'
type Path pos a = InPos pos (InDir a)

-- * Type 'Position'
data Position = Absolute | Relative

-- ** Type 'SPos'
-- | Singleton type for 'Position'.
data SPos pos where
	Abs :: SPos 'Absolute
	Rel :: SPos 'Relative

-- ** Type 'IPos'

-- | Implicit class for 'Position'.
class IPos pos where
	pos :: SPos pos
instance IPos 'Absolute where pos = Abs
instance IPos 'Relative where pos = Rel

-- ** Type 'InPos'
data InPos pos a = InPos (SPos pos) a
 deriving (Functor)
instance Buildable a => Buildable (InPos pos a) where
	build (InPos Abs a) = build FP.pathSeparator <> build a
	build (InPos Rel a) = build a
instance (IsString a, IPos pos) => IsString (InPos pos a) where
	fromString = InPos pos . fromString

-- ** Type 'PosOf'
type family PosOf x :: Position
type instance PosOf (InPos pos a) = pos

-- * Type 'Dir'

newtype Dir = Dir [Dir_Seg]
 deriving (Monoid)
type Dir_Seg = Text
type AbsDir = InPos 'Absolute Dir
type RelDir = InPos 'Relative Dir
instance IsString Dir where
	fromString = Dir . (fromString <$>) . splitOnChar FP.pathSeparator
instance IsList Dir where
	type Item Dir = Dir_Seg
	fromList = Dir . foldMap (splitOnChar FP.pathSeparator)
	toList (Dir d) = toList d
instance Buildable Dir where
	build (Dir []) = "."
	build (Dir p) =
		mconcat $
		List.intersperse
		 (build FP.pathSeparator)
		 (build <$> p)

{-
absDir :: InPos pos a -> InPos 'Absolute a
absDir (InPos _p a) = InPos Abs a

relDir :: InPos pos a -> InPos 'Relative a
relDir (InPos _p a) = InPos Rel a
-}

-- ** Type 'InDir'
data InDir a = InDir Dir a
 deriving (Functor)
instance IsString (a -> InDir a) where
	fromString = InDir . fromString
instance IsString a => IsString (InDir a) where
	fromString s =
		case splitOnChar FP.pathSeparator s of
		 [] -> InDir (Dir []) $ fromString ""
		 l  -> InDir (Dir $ fromString <$> List.init l) $ fromString (List.last l)
instance IsList (a -> InDir a) where
	type Item (a -> InDir a) = Dir_Seg
	fromList = InDir . fromList
	toList = undefined
instance Buildable a => Buildable (InDir a) where
	build (InDir d a) = build d <> build FP.pathSeparator <> build a

-- ** Class 'Dir_Parent'

-- | Return the parent 'Dir' of given 'Dir'
class Dir_Parent d where
	type Dir_Parent_Dir d
	dir_parent :: d -> Maybe (Dir_Parent_Dir d)

instance Dir_Parent Dir where
	type Dir_Parent_Dir Dir = Dir
	dir_parent (Dir p) =
		case p of
		 [] -> Nothing
		 _  -> Just $ Dir (List.init p)
instance Dir_Parent a => Dir_Parent (InPos pos a) where
	type Dir_Parent_Dir (InPos pos a) = InPos pos (Dir_Parent_Dir a)
	dir_parent (InPos p a) = InPos p <$> dir_parent a
instance Dir_Parent (InDir a) where
	type Dir_Parent_Dir (InDir a) = Dir
	dir_parent (InDir d _a) = Just d
{-
instance Dir_Parent File where
	type Dir_Parent_Dir File = Dir
	dir_parent (File _f) = Just $ Dir []
-}

-- ** Class 'Dir_Ancestors'

-- | Return self and parents 'Dir' of given 'Dir', in topological order.
class Dir_Ancestors d where
	type Dir_Ancestors_Dir d
	dir_ancestors :: d -> [Dir_Parent_Dir d]

instance Dir_Ancestors Dir where
	type Dir_Ancestors_Dir Dir = Dir
	dir_ancestors (Dir p) =
		List.reverse $
		List.foldl' (\acc seg ->
			case acc of
			 [] -> [Dir [seg]]
			 Dir d:_ -> Dir (d<>[seg]):acc
		 ) [Dir []] p
instance Dir_Ancestors a => Dir_Ancestors (InPos pos a) where
	type Dir_Ancestors_Dir (InPos pos a) = InPos pos (Dir_Ancestors_Dir a)
	dir_ancestors (InPos p a) = InPos p <$> dir_ancestors a
instance Dir_Ancestors (InDir a) where
	type Dir_Ancestors_Dir (InDir a) = Dir
	dir_ancestors (InDir d _a) = dir_ancestors d
{-
instance Dir_Ancestors File where
	type Dir_Ancestors_Dir File = Dir
	dir_ancestors (File _f) = [Dir []]
-}

-- ** Class 'Dir_Append'
class Dir_Append p q where
	type Dir_Append_Dir p q
	(</>) :: p -> q -> Dir_Append_Dir p q
instance Dir_Append (InPos p Dir) (InPos 'Relative Dir) where
	type Dir_Append_Dir (InPos p Dir) (InPos 'Relative Dir) = InPos p Dir
	(</>) (InPos p x) (InPos _q y) = InPos p (x <> y)
instance Dir_Append (InPos p Dir) File where
	type Dir_Append_Dir (InPos p Dir) File = InPos p (InDir File)
	(</>) (InPos p d) f = InPos p (InDir d f)
instance Dir_Append (InPos p Dir) (InPos 'Relative (InDir a)) where
	type Dir_Append_Dir (InPos p Dir) (InPos 'Relative (InDir a)) = InPos p (InDir a)
	(</>) (InPos p x) (InPos _q (InDir y a)) = InPos p (InDir (x <> y) a)

-- * Type 'File'
newtype File = File [Text]
instance IsString File where
	fromString = File . (fromString <$>) . splitOnCharWithEmpty FP.extSeparator
instance Buildable File where
	build (File p) =
		mconcat $
		List.intersperse
		 (build FP.extSeparator)
		 (build <$> p)

type RelFile = InPos 'Relative (InDir File)