Hdoc/TCT/Cell.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 module Hdoc.TCT.Cell
   4  ( module Hdoc.TCT.Cell
   5  , XML.FileRange(..)
   6  , XML.NoSource(..)
   7  , XML.Sourced(..)
   8  ) where
   9
  10 import Control.Applicative (Applicative(..))
  11 import Data.Bool
  12 import Data.Default.Class (Default(..))
  13 import Data.Eq (Eq(..))
  14 import Data.Function (($), (.))
  15 import Data.List.NonEmpty (NonEmpty(..))
  16 import Data.Ord (Ord(..))
  17 import Data.Semigroup (Semigroup(..))
  18 import Language.Symantic.XML (Sourced(..))
  19 import Prelude (Bounded(..), (-), Int, fromIntegral, Integral, Num)
  20 import Text.Show (Show(..), showChar, showString)
  21 import qualified Data.Text as T
  22 import qualified Data.Text.Lazy as TL
  23 import qualified Language.Symantic.XML as XML
  24 import qualified Text.Megaparsec as P
  25
  26 import Hdoc.TCT.Debug
  27
  28 {-
  29 -- * Type 'Pos'
  30 -- | Absolute text file position.
  31 type Pos = XML.FileRange XML.LineColumn
  32 instance Semigroup Pos where
  33         Pos lx cx <> Pos ly cy =
  34                 Pos (lx+ly) (cx+cy)
  35 instance Monoid Pos where
  36         mempty  = Pos 0 0
  37         mappend = (<>)
  38
  39 pos1 :: Pos
  40 pos1 = def
  41 -}
  42
  43 -- * Type 'Cell'
  44 type Cell = XML.Sourced Location
  45 {-
  46 instance (FromPad a, Semigroup a, Monoid a) => Monoid (Cell a) where
  47         mempty  = cell0 mempty
  48         mappend = (<>)
  49 -}
  50
  51 cell0 :: a -> Cell a
  52 cell0 = XML.Sourced (XML.FileRange "" pos0 pos0 :| [])
  53         where
  54         pos0 = LineColumn num0 num0
  55         num0 = numMax<>numMax<>pos1<>pos1
  56         numMax = P.mkPos maxBound
  57
  58 -- ** Type 'Span'
  59 type Span = XML.FileRange LineColumn
  60
  61 -- ** Type 'Location'
  62 type Location = XML.FileSource LineColumn
  63
  64 instance (FromPad a, Semigroup a) => Semigroup (Sourced (XML.FileSource LineColumn) a) where
  65         (<>)
  66          (Sourced rx@(XML.FileRange xf xb xe :|  xs) x)
  67          (Sourced    (XML.FileRange yf yb ye :| _ys) y)
  68          | xf == yf  = Sourced (XML.FileRange xf xb ye :| xs) $
  69                                x<>fromPad (l,c)<>y
  70          | otherwise = Sourced rx (x<>y)
  71                 where
  72                 l = lineInt yb - lineInt xe
  73                 c = colInt  yb - colInt (if l <= 0 then xe else xb)
  74
  75 -- ** Class 'FromPad'
  76 class FromPad a where
  77         fromPad :: (Int, Int) -> a
  78 instance FromPad T.Text where
  79         fromPad (lineNum, colNum) =
  80                 T.replicate lineNum "\n" <>
  81                 T.replicate colNum " "
  82 instance FromPad TL.Text where
  83         fromPad (lineNum, colNum) =
  84                 TL.replicate (fromIntegral lineNum) "\n" <>
  85                 TL.replicate (fromIntegral colNum) " "
  86 instance FromPad XML.EscapedText where
  87         fromPad = XML.EscapedText . pure . fromPad
  88 instance FromPad XML.Escaped where
  89         fromPad = XML.EscapedPlain . fromPad
  90 {-
  91 instance (FromPad a, Semigroup a, Monoid a) => Monoid (Sourced a) where
  92         mempty  = sourced0 mempty
  93         mappend = (<>)
  94 -}
  95
  96 -- ** Type 'LineColumn'
  97 -- | Absolute text file position.
  98 data LineColumn = LineColumn
  99  { lineNum :: {-# UNPACK #-} !P.Pos
 100  , colNum  :: {-# UNPACK #-} !P.Pos
 101  } deriving (Eq, Ord)
 102 num :: (Integral a, Num a) => a -> P.Pos
 103 num = P.mkPos . fromIntegral
 104 pos1 :: P.Pos
 105 pos1 = P.pos1
 106 instance Default LineColumn where
 107         def = LineColumn P.pos1 P.pos1
 108 instance Show LineColumn where
 109         showsPrec _p lc =
 110                 showsPrec 11 (lineInt lc) .
 111                 showChar ':' .
 112                 showsPrec 11 (colInt lc)
 113 instance Pretty LineColumn
 114
 115 -- ** Type 'LineInt'
 116 type LineInt = Int
 117 lineInt :: LineColumn -> Int
 118 lineInt = P.unPos . lineNum
 119
 120 -- ** Type 'ColInt'
 121 type ColInt = Int
 122 colInt :: LineColumn -> Int
 123 colInt = P.unPos . colNum
 124 instance Default (XML.FileRange LineColumn) where
 125         def = XML.FileRange "" def def
 126 instance Show (XML.FileRange LineColumn) where
 127         showsPrec _p XML.FileRange{..} =
 128                 showString fileRange_file .
 129                 showChar '#' . showsPrec 10 fileRange_begin .
 130                 showChar '-' . showsPrec 10 fileRange_end