]> Git — Sourcephile - doclang.git/blob - Hdoc/TCT/Cell.hs
Update to megaparsec-7 and new symantic-xml
[doclang.git] / 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