]> Git — Sourcephile - doclang.git/blob - Language/TCT/Cell.hs
Sync HTML5 rendition of DTC with new TCT parsing.
[doclang.git] / Language / TCT / Cell.hs
1 {-# LANGUAGE DeriveFunctor #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 module Language.TCT.Cell where
5
6 import Control.Monad (Monad(..))
7 import Data.Eq (Eq(..))
8 import Data.Function (($), (.))
9 import Data.Functor (Functor)
10 import Data.Monoid (Monoid(..))
11 import Data.Ord (Ord(..))
12 import Data.Semigroup (Semigroup(..))
13 import Data.Text (Text)
14 import Prelude (Int, Num(..), fromIntegral)
15 import Text.Show (Show(..), showParen, showString, showChar)
16 import qualified Data.Text as Text
17 import qualified Data.Text.Lazy as TL
18
19 import Language.TCT.Debug
20
21 -- * Type 'Pos'
22 -- | Relative position
23 data Pos
24 = Pos
25 { pos_line :: {-# UNPACK #-} !LineNum
26 , pos_column :: {-# UNPACK #-} !ColNum
27 } deriving (Eq, Ord)
28 instance Semigroup Pos where
29 Pos lx cx <> Pos ly cy =
30 Pos (lx+ly) (cx+cy)
31 instance Monoid Pos where
32 mempty = Pos 0 0
33 mappend = (<>)
34 instance Show Pos where
35 showsPrec _p Pos{..} =
36 showsPrec 11 pos_line .
37 showChar ':' .
38 showsPrec 11 pos_column
39 instance Pretty Pos
40
41 pos1 :: Pos
42 pos1 = Pos 1 1
43
44 -- ** Type 'LineNum'
45 type LineNum = Int
46
47 -- ** Type 'ColNum'
48 type ColNum = Int
49
50 -- * Type 'Cell'
51 data Cell a
52 = Cell
53 { cell_begin :: {-# UNPACK #-} !Pos
54 , cell_end :: {-# UNPACK #-} !Pos
55 , unCell :: !a
56 } deriving (Eq, Ord, Functor)
57 instance Show a => Show (Cell a) where
58 showsPrec p Cell{..} =
59 showParen (p >= 10) $
60 showString "Cell" .
61 showChar ' ' . showsPrec 10 cell_begin .
62 showChar ' ' . showsPrec 10 cell_end .
63 showChar ' ' . showsPrec 11 unCell
64 instance Pretty a => Pretty (Cell a) where
65 pretty (Cell bp ep m) = do
66 s <- pretty m
67 return $ "Cell "<>show bp<>":"<>show ep<>" "<>s
68 instance (FromPad a, Semigroup a) => Semigroup (Cell a) where
69 Cell bx ex x <> Cell by ey y =
70 Cell bx ey $
71 x<>fromPad (Pos lines columns)<>y
72 where
73 lines = pos_line by - pos_line ex
74 columns = pos_column by - pos_column (if lines <= 0 then ex else bx)
75 {-
76 instance (FromPad a, Semigroup a, Monoid a) => Monoid (Cell a) where
77 mempty = cell0 mempty
78 mappend = (<>)
79 -}
80
81 cell0 :: a -> Cell a
82 cell0 = Cell mempty mempty
83
84 -- * Class 'FromPad'
85 class FromPad a where
86 fromPad :: Pos -> a
87 instance FromPad Text where
88 fromPad Pos{..} =
89 Text.replicate pos_line "\n" <>
90 Text.replicate pos_column " "
91 instance FromPad TL.Text where
92 fromPad Pos{..} =
93 TL.replicate (fromIntegral pos_line) "\n" <>
94 TL.replicate (fromIntegral pos_column) " "