{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.XML.Tree.Source where

import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Eq (Eq(..))
import Data.Function (($), (.), const)
import Data.Functor (Functor)
import Data.Functor.Identity (Identity(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.List.NonEmpty (NonEmpty(..))
import Prelude (Num(..), Int)
import System.IO (FilePath)
import Text.Show (Show(..), shows, showChar, showParen, showString)

-- * Type family 'Source'
type family Source (src :: * -> *) :: *
type instance Source (Sourced src) = src
type instance Source Identity = ()

-- * Class 'NoSource'
class NoSource src where
  noSource :: a -> src a
  nullSource :: Source src -> Bool
  default nullSource ::
   Eq (Source src) =>
   SourceOf src =>
   Source src -> Bool
  nullSource = (==) (sourceOf @src (noSource @src ()))
instance NoSource Identity where
  noSource = Identity
  nullSource = const True

-- * Class 'UnSource'
class UnSource src where
  unSource :: src a -> a
instance UnSource Identity where
  unSource = runIdentity

-- * Class 'SourceOf'
class SourceOf src where
  sourceOf :: src a -> Source src
instance SourceOf Identity where
  sourceOf _ = ()

-- * Type 'FileSource'
newtype FileSource pos
 =      FileSource (NonEmpty (FileRange pos))
 deriving (Eq)
instance Show (FileRange pos) => Show (FileSource pos) where
  showsPrec _p (FileSource (s:|[])) = shows s
  showsPrec _p (FileSource (s:|s1:ss)) =
    shows s . showString "\n in " .
    shows (FileSource (s1:|ss))

-- ** Type 'FileSourced'
type FileSourced = Sourced (FileSource Offset)

-- ** Type 'FileRange'
data FileRange pos
 =   FileRange
 {   fileRange_path  :: FilePath
 ,   fileRange_begin :: pos
 ,   fileRange_end   :: pos
 } deriving (Eq, Ord)
instance Show (FileRange Offset) where
  showsPrec _p FileRange{..} =
    showString fileRange_path . showString " at char position " .
    showsPrec 10 fileRange_begin . showString " to " .
    showsPrec 10 fileRange_end
instance Show (FileRange LineColumn) where
  showsPrec _p FileRange{..} =
    showString fileRange_path . showString " at line:column position " .
    showsPrec 10 fileRange_begin . showString " to " .
    showsPrec 10 fileRange_end

-- *** Type 'Offset'
newtype Offset = Offset Int
 deriving (Eq, Ord)
instance Show Offset where
  showsPrec p (Offset o) = showsPrec p o
instance Semigroup Offset where
  Offset x <> Offset y = Offset (x+y)
instance Monoid Offset where
  mempty  = Offset 0
  mappend = (<>)

-- *** Type 'LineColumn'
-- | Absolute text file position.
data LineColumn = LineColumn
 { lineNum :: {-# UNPACK #-} Offset
 , colNum  :: {-# UNPACK #-} Offset
 } deriving (Eq, Ord)
instance Show LineColumn where
  showsPrec _p LineColumn{..} =
    showsPrec 11 lineNum .
    showChar ':' .
    showsPrec 11 colNum

-- * Type 'Sourced'
data Sourced src a
 =   Sourced
 {   source  :: src
 , unSourced :: a
 } deriving (Functor)
instance UnSource (Sourced src) where
  unSource = unSourced
instance NoSource (Sourced (FileSource Offset)) where
  noSource = Sourced $ FileSource $ pure $ FileRange mempty mempty mempty
instance SourceOf (Sourced src) where
  sourceOf (Sourced src _a) = src
-- | Ignore 'src'
instance Eq a => Eq (Sourced src a) where
  x == y = unSourced x == unSourced y
-- | Ignore 'src'
instance Ord a => Ord (Sourced src a) where
  x `compare` y = unSourced x `compare` unSourced y
instance
 (Show src, Show a, NoSource (Sourced src)) =>
 Show (Sourced src a) where
  showsPrec p (Sourced src a)
   | nullSource @(Sourced src) src = showsPrec p a
   | otherwise =
    showParen (p > 10) $
    showsPrec 10 a .
    showString " in " . showsPrec 10 src
instance Semigroup a => Semigroup (Sourced (FileSource Offset) a) where
  (<>)
   (Sourced rx@(FileSource (FileRange xf xb xe :|  xs)) x)
   (Sourced    (FileSource (FileRange yf yb ye :| _ys)) y)
   | xf == yf && xe == yb =
    Sourced (FileSource (FileRange xf xb ye :| xs)) $ x<>y
   | otherwise = Sourced rx (x<>y)