{-# 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 (src :: * -> *) :: *
type instance Source (Sourced src) = src
type instance Source Identity = ()
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 src where
unSource :: src a -> a
instance UnSource Identity where
unSource = runIdentity
class SourceOf src where
sourceOf :: src a -> Source src
instance SourceOf Identity where
sourceOf _ = ()
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 = Sourced (FileSource Offset)
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
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 = (<>)
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
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
instance Eq a => Eq (Sourced src a) where
x == y = unSourced x == unSourced y
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)