{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.TCT.Cell where

import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Functor (Functor)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import Prelude (Int, Num(..), fromIntegral)
import Text.Show (Show(..), showParen, showString, showChar)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL

-- * Type 'Pos'
-- | Relative position
data Pos
 =   Pos
 {   pos_line   :: {-# UNPACK #-} !LineNum
 ,   pos_column :: {-# UNPACK #-} !ColNum
 } deriving (Eq)
instance Semigroup Pos where
	Pos lx cx <> Pos ly cy =
		Pos (lx+ly) (cx+cy)
instance Monoid Pos where
	mempty  = Pos 0 0
	mappend = (<>)
instance Show Pos where
	showsPrec _p Pos{..} =
		showsPrec 11 pos_line .
		showChar ':' .
		showsPrec 11 pos_column

-- ** Type 'LineNum'
type LineNum = Int

-- ** Type 'ColNum'
type ColNum = Int

-- * Type 'Cell'
data Cell a
 =   Cell
 {   cell_begin :: {-# UNPACK #-} !Pos
 ,   cell_end   :: {-# UNPACK #-} !Pos
 , unCell       :: !a
 }   deriving (Eq, Functor)
instance Show a => Show (Cell a) where
	showsPrec p Cell{..} =
		showParen (p >= 10) $
		showString "Cell" .
		showChar ' ' . showsPrec 10 cell_begin .
		showChar ' ' . showsPrec 10 cell_end .
		showChar ' ' . showsPrec 11 unCell
instance (FromPad a, Semigroup a) => Semigroup (Cell a) where
	Cell bx (Pos lx _cx) x <> Cell (Pos ly cy) ey y =
		Cell bx ey $ x <> fromPad (Pos (ly - lx) cy) <> y
instance (FromPad a, Semigroup a, Monoid a) => Monoid (Cell a) where
	mempty  = cell0 mempty
	mappend = (<>)
cell0 :: a -> Cell a
cell0 = Cell mempty mempty

-- * Class 'FromPad'
class FromPad a where
	fromPad :: Pos -> a
instance FromPad Text where
	fromPad Pos{..} =
		Text.replicate pos_line   "\n" <>
		Text.replicate pos_column " "
instance FromPad TL.Text where
	fromPad Pos{..} =
		TL.replicate (fromIntegral pos_line)   "\n" <>
		TL.replicate (fromIntegral pos_column) " "

{-
instance (FromPad a, Semigroup a) => Semigroup (Cell a) where
	Cell bx ex x <> Cell by ey y =
		Cell bx ey $ x <> fromPad by <> y
instance Applicative Cell where
	pure = Cell mempty mempty
	Cell of_ sf f <*> Cell bx ex x =
		Cell of_ (sf<>bx<>ex) (f x)

cell0 :: a -> Cell a
cell0 = pure

-- * Class 'Cellified'
class Cellified a where
	reachOf :: a -> Pos
	reachOf a = offsetOf a <> sizeOf a
	offsetOf :: a -> Pos
	sizeOf :: a -> Pos
instance Cellified (Cell a) where
	offsetOf = cell_begin
	sizeOf   = cell_end
instance Cellified a => Cellified [a] where
	reachOf = foldMap reachOf
	offsetOf = \case
	 [] -> mempty
	 s0 : ss ->
		if sizeOf s0 == mempty
		then offsetOf s0 <> offsetOf ss
		else offsetOf s0
	sizeOf = foldMap sizeOf
instance Cellified a => Cellified (Seq a) where
	reachOf = foldMap reachOf
	offsetOf s = case Seq.viewl s of
	 EmptyL -> mempty
	 s0 :< ss ->
		if sizeOf s0 == mempty
		then offsetOf s0 <> offsetOf ss
		else offsetOf s0
	sizeOf = foldMap sizeOf
instance (Cellified k, Cellified a) => Cellified (Tree k a) where
	reachOf = \case
	 TreeN k _ts -> reachOf k
	 Tree0 a -> reachOf a
	offsetOf = \case
	 TreeN k _ts -> offsetOf k
	 Tree0 a -> offsetOf a
	sizeOf = \case
	 TreeN k _ts -> sizeOf k
	 Tree0 a -> sizeOf a
-}

{-
-- * Class 'Cellify'
class Cellify a where
	cellify :: a -> Cell a
instance Cellify Text where
	cellify t = Cell mempty s t
		where
		s =
			Text.foldl' (\acc -> \case
			 '\n' -> acc{pos_line   = pos_line   acc + 1}
			 _    -> acc{pos_column = pos_column acc + 1})
			 mempty t

-- * Type 'Pad'
type Pad = Pos

-- * Type 'Padded'
data Padded a
 =   Padded
 {   pad    :: !Pad
 ,   unPad  :: !a
 } deriving (Eq,Show)


-- * Type 'Pos'
-- | Absolute position
data Pos
 =   Pos
 {   pos_line   :: {-# UNPACK #-} !LineNum
 ,   pos_column :: {-# UNPACK #-} !ColNum
 } deriving (Eq, Ord)
instance Show Pos where
	showsPrec _p Pos{..} = showsPrec 11 (pos_line,pos_column)

pos1 :: Pos
pos1 = Pos 1 1

-}






{-
instance Applicative (Cell a) where
	pure = cell0
	cf@(Cell bf ef f) <*> ca@(Cell ba ea a) =
	 | isCell0 cf || isCell0 ca = cell0 (f a)
		Cell bf ea (f a)
isCell0 :: Cell a -> Bool
isCell0 (Cell bp ep _) = isPos0 bp && isPos0 ep
-}

{-
lineCell :: Cell a -> LineNum
lineCell = pos_line . cell_begin
columnCell :: Cell a -> ColNum
columnCell = pos_column . cell_begin

cell1 :: a -> Cell a
cell1 = Cell pos1 pos1
-}

{-
posSeq :: Seq (Cell a) -> Maybe (Pos,Pos)
posSeq toks =
	case Seq.viewl toks of
	 EmptyL -> Nothing
	 Cell bp _ep _ :< _ ->
		case Seq.viewr toks of
		 EmptyR -> Nothing
		 _ :> Cell _bp ep _ ->
			Just (bp, ep)
posTrees :: Seq (Trees (Cell k) a) -> Maybe (Pos,Pos)
posTrees trees =
	case Seq.viewl trees of
	 EmptyL -> Nothing
	 Tree0 toks :< ts ->
		case posSeq toks of
		 Nothing -> posTrees ts
		 Just (bp,_ep) ->
			Just $
				case Seq.viewr trees of
				 EmptyR -> (bp,bp)
				 _ :> TreeN _ toks | iiiii->
			
	 TreeN (Cell bp _ep _) _ :< _ ->
		case Seq.viewr trees of
		 EmptyR -> Nothing
		 _ :> TreeN _ toks | iiiii->
			Just (Cell bp ep ())
-}

{-
posTree :: Tree (Cell k) (Cell a) -> Pos
posTree (TreeN c _) = cell_begin c
posTree (Tree0 c)   = cell_begin c

posEndTree :: Tree (Cell k) (Cell a) -> Pos
posEndTree (TreeN c _) = cell_end c
posEndTree (Tree0 c)   = cell_end c

pos0 :: Pos
pos0 = Pos 0 0
-}
{-
instance Ord Pos where
	Pos lx cx `compare` Pos ly cy =
		compare lx ly <>
		compare cx cy

isPos0 :: Pos -> Bool
isPos0 (Pos 0 0 ) = True
isPos0 _ = False
-}

{-
-- ** Class 'CellOf'
class CellOf a where
	firstCellOf :: a -> Maybe (Cell ())
instance CellOf (Cell a) where
	firstCellOf = Just . (() <$)
instance CellOf a => CellOf (Seq a) where
	firstCellOf s =
		case Seq.viewl s of
		 EmptyL -> Nothing
		 s0 :< ss ->
			firstCellOf s0 <|>
			firstCellOf ss
instance CellOf a => CellOf [a] where
	firstCellOf = \case
	 [] -> Nothing
	 s0 : ss ->
		firstCellOf s0 <|>
		firstCellOf ss
instance (CellOf k, CellOf a) => CellOf (Tree k a) where
	firstCellOf = \case
	 Tree0 a -> firstCellOf a
	 TreeN k a -> firstCellOf k <|> firstCellOf a
-}