]> Git — Sourcephile - doclang.git/blob - Hdoc/TCT/Cell.hs
Prepare for merging DTC mangling operations.
[doclang.git] / Hdoc / TCT / Cell.hs
1 {-# LANGUAGE DeriveFunctor #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 module Hdoc.TCT.Cell where
5
6 import Data.Eq (Eq(..))
7 import Data.Foldable (toList)
8 import Data.Function (($), (.))
9 import Data.Functor (Functor)
10 import Data.List.NonEmpty (NonEmpty(..))
11 import Data.Ord (Ord(..))
12 import Data.Semigroup (Semigroup(..))
13 import Data.Text (Text)
14 import Prelude (Int, Num(..), fromIntegral)
15 import System.FilePath (FilePath)
16 import Text.Show (Show(..), showChar, showString, showParen)
17 import qualified Data.Text as Text
18 import qualified Data.Text.Lazy as TL
19
20 import Hdoc.TCT.Debug
21
22 -- * Type 'Pos'
23 -- | Relative position
24 data Pos
25 = Pos
26 { pos_line :: {-# UNPACK #-} !LineNum
27 , pos_column :: {-# UNPACK #-} !ColNum
28 } deriving (Eq, Ord)
29 {-
30 instance Semigroup Pos where
31 Pos lx cx <> Pos ly cy =
32 Pos (lx+ly) (cx+cy)
33 instance Monoid Pos where
34 mempty = Pos 0 0
35 mappend = (<>)
36 -}
37 instance Show Pos where
38 showsPrec _p Pos{..} =
39 showsPrec 11 pos_line .
40 showChar ':' .
41 showsPrec 11 pos_column
42 instance Pretty Pos
43
44 pos1 :: Pos
45 pos1 = Pos 1 1
46
47 -- ** Type 'LineNum'
48 type LineNum = Int
49
50 -- ** Type 'ColNum'
51 type ColNum = Int
52
53 -- * Type 'Span'
54 data Span
55 = Span
56 { span_file :: !FilePath
57 , span_begin :: !Pos
58 , span_end :: !Pos
59 } deriving (Eq, Ord)
60 instance Show Span where
61 showsPrec _p Span{..} =
62 showString span_file .
63 showChar '#' . showsPrec 10 span_begin .
64 showChar '-' . showsPrec 10 span_end
65
66 -- * Type 'Spans'
67 type Spans = NonEmpty Span
68
69 -- * Type 'Cell'
70 data Cell a
71 = Cell
72 { cell_spans :: !Spans
73 , unCell :: !a
74 } deriving (Eq, Ord, Functor)
75 instance Show a => Show (Cell a) where
76 showsPrec p Cell{..} =
77 showParen (p > 10) $
78 showString "Cell" .
79 showChar ' ' . showsPrec 11 unCell .
80 showChar ' ' . showsPrec 10 (toList cell_spans)
81 instance (Pretty a, Show a) => Pretty (Cell a)
82 instance (FromPad a, Semigroup a) => Semigroup (Cell a) where
83 Cell (Span fx bx ex :| sx) x <> Cell (Span _fy by ey :| _sy) y =
84 Cell (Span fx bx ey :| sx) $
85 x<>fromPad (Pos lines columns)<>y
86 where
87 lines = pos_line by - pos_line ex
88 columns = pos_column by - pos_column (if lines <= 0 then ex else bx)
89 {-
90 instance (FromPad a, Semigroup a, Monoid a) => Monoid (Cell a) where
91 mempty = cell0 mempty
92 mappend = (<>)
93 -}
94
95 cell0 :: a -> Cell a
96 cell0 = Cell (span0 :| [])
97 where span0 = Span "" pos1 pos1
98
99 -- * Class 'FromPad'
100 class FromPad a where
101 fromPad :: Pos -> a
102 instance FromPad Text where
103 fromPad Pos{..} =
104 Text.replicate pos_line "\n" <>
105 Text.replicate pos_column " "
106 instance FromPad TL.Text where
107 fromPad Pos{..} =
108 TL.replicate (fromIntegral pos_line) "\n" <>
109 TL.replicate (fromIntegral pos_column) " "