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) " "