Hdoc/TCT/Cell.hs

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