src/Symantic/XML/Tree/Source.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE ConstraintKinds #-}
   3 {-# LANGUAGE DeriveFunctor #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE Rank2Types #-}
   6 {-# LANGUAGE StrictData #-}
   7 {-# LANGUAGE UndecidableInstances #-}
   8 {-# OPTIONS_GHC -fno-warn-orphans #-}
   9 module Symantic.XML.Tree.Source where
  10
  11 import Control.Applicative (Applicative(..))
  12 import Data.Bool
  13 import Data.Eq (Eq(..))
  14 import Data.Function (($), (.), const)
  15 import Data.Functor (Functor)
  16 import Data.Functor.Identity (Identity(..))
  17 import Data.Monoid (Monoid(..))
  18 import Data.Ord (Ord(..))
  19 import Data.Semigroup (Semigroup(..))
  20 import Data.List.NonEmpty (NonEmpty(..))
  21 import Prelude (Num(..), Int)
  22 import System.IO (FilePath)
  23 import Text.Show (Show(..), shows, showChar, showParen, showString)
  24
  25 -- * Type family 'Source'
  26 type family Source (src :: * -> *) :: *
  27 type instance Source (Sourced src) = src
  28 type instance Source Identity = ()
  29
  30 -- * Class 'NoSource'
  31 class NoSource src where
  32   noSource :: a -> src a
  33   nullSource :: Source src -> Bool
  34   default nullSource ::
  35    Eq (Source src) =>
  36    SourceOf src =>
  37    Source src -> Bool
  38   nullSource = (==) (sourceOf @src (noSource @src ()))
  39 instance NoSource Identity where
  40   noSource = Identity
  41   nullSource = const True
  42
  43 -- * Class 'UnSource'
  44 class UnSource src where
  45   unSource :: src a -> a
  46 instance UnSource Identity where
  47   unSource = runIdentity
  48
  49 -- * Class 'SourceOf'
  50 class SourceOf src where
  51   sourceOf :: src a -> Source src
  52 instance SourceOf Identity where
  53   sourceOf _ = ()
  54
  55 -- * Type 'FileSource'
  56 newtype FileSource pos
  57  =      FileSource (NonEmpty (FileRange pos))
  58  deriving (Eq)
  59 instance Show (FileRange pos) => Show (FileSource pos) where
  60   showsPrec _p (FileSource (s:|[])) = shows s
  61   showsPrec _p (FileSource (s:|s1:ss)) =
  62     shows s . showString "\n in " .
  63     shows (FileSource (s1:|ss))
  64
  65 -- ** Type 'FileSourced'
  66 type FileSourced = Sourced (FileSource Offset)
  67
  68 -- ** Type 'FileRange'
  69 data FileRange pos
  70  =   FileRange
  71  {   fileRange_path  :: FilePath
  72  ,   fileRange_begin :: pos
  73  ,   fileRange_end   :: pos
  74  } deriving (Eq, Ord)
  75 instance Show (FileRange Offset) where
  76   showsPrec _p FileRange{..} =
  77     showString fileRange_path . showString " at char position " .
  78     showsPrec 10 fileRange_begin . showString " to " .
  79     showsPrec 10 fileRange_end
  80 instance Show (FileRange LineColumn) where
  81   showsPrec _p FileRange{..} =
  82     showString fileRange_path . showString " at line:column position " .
  83     showsPrec 10 fileRange_begin . showString " to " .
  84     showsPrec 10 fileRange_end
  85
  86 -- *** Type 'Offset'
  87 newtype Offset = Offset Int
  88  deriving (Eq, Ord)
  89 instance Show Offset where
  90   showsPrec p (Offset o) = showsPrec p o
  91 instance Semigroup Offset where
  92   Offset x <> Offset y = Offset (x+y)
  93 instance Monoid Offset where
  94   mempty  = Offset 0
  95   mappend = (<>)
  96
  97 -- *** Type 'LineColumn'
  98 -- | Absolute text file position.
  99 data LineColumn = LineColumn
 100  { lineNum :: {-# UNPACK #-} Offset
 101  , colNum  :: {-# UNPACK #-} Offset
 102  } deriving (Eq, Ord)
 103 instance Show LineColumn where
 104   showsPrec _p LineColumn{..} =
 105     showsPrec 11 lineNum .
 106     showChar ':' .
 107     showsPrec 11 colNum
 108
 109 -- * Type 'Sourced'
 110 data Sourced src a
 111  =   Sourced
 112  {   source  :: src
 113  , unSourced :: a
 114  } deriving (Functor)
 115 instance UnSource (Sourced src) where
 116   unSource = unSourced
 117 instance NoSource (Sourced (FileSource Offset)) where
 118   noSource = Sourced $ FileSource $ pure $ FileRange mempty mempty mempty
 119 instance SourceOf (Sourced src) where
 120   sourceOf (Sourced src _a) = src
 121 -- | Ignore 'src'
 122 instance Eq a => Eq (Sourced src a) where
 123   x == y = unSourced x == unSourced y
 124 -- | Ignore 'src'
 125 instance Ord a => Ord (Sourced src a) where
 126   x `compare` y = unSourced x `compare` unSourced y
 127 instance
 128  (Show src, Show a, NoSource (Sourced src)) =>
 129  Show (Sourced src a) where
 130   showsPrec p (Sourced src a)
 131    | nullSource @(Sourced src) src = showsPrec p a
 132    | otherwise =
 133     showParen (p > 10) $
 134     showsPrec 10 a .
 135     showString " in " . showsPrec 10 src
 136 instance Semigroup a => Semigroup (Sourced (FileSource Offset) a) where
 137   (<>)
 138    (Sourced rx@(FileSource (FileRange xf xb xe :|  xs)) x)
 139    (Sourced    (FileSource (FileRange yf yb ye :| _ys)) y)
 140    | xf == yf && xe == yb =
 141     Sourced (FileSource (FileRange xf xb ye :| xs)) $ x<>y
 142    | otherwise = Sourced rx (x<>y)