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 -- | Absolute text file position.
  25 data Pos = Pos
  26  { pos_line   :: {-# UNPACK #-} !LineNum
  27  , pos_column :: {-# UNPACK #-} !ColNum
  28  } deriving (Eq, Ord)
  29 instance Default Pos where
  30         def = pos1
  31 {-
  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 instance Show Pos where
  40         showsPrec _p Pos{..} =
  41                 showsPrec 11 pos_line .
  42                 showChar ':' .
  43                 showsPrec 11 pos_column
  44 instance Pretty Pos
  45
  46 pos1 :: Pos
  47 pos1 = Pos 1 1
  48
  49 -- ** Type 'LineNum'
  50 type LineNum = Int
  51
  52 -- ** Type 'ColNum'
  53 type ColNum = Int
  54
  55 -- * Type 'Cell'
  56 data Cell a
  57  =   Cell
  58  {   cell_location :: !Location
  59  , unCell          :: !a
  60  } deriving (Eq, Ord, Functor)
  61 instance Show a => Show (Cell a) where
  62         showsPrec p Cell{..} =
  63                 showParen (p > 10) $
  64                 showString "Cell" .
  65                 showChar ' ' . showsPrec 11 unCell .
  66                 showChar ' ' . showsPrec 10 (toList cell_location)
  67 instance (Pretty a, Show a) => Pretty (Cell a)
  68 instance (FromPad a, Semigroup a) => Semigroup (Cell a) where
  69         Cell (Span fx bx ex :| lx) x <> Cell (Span _fy by ey :| _ly) y =
  70                 Cell (Span fx bx ey :| lx) $
  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 (def :| [])
  83
  84 -- ** Type 'Span'
  85 data Span
  86  =   Span
  87  {   span_file  :: !FilePath
  88  ,   span_begin :: !Pos
  89  ,   span_end   :: !Pos
  90  } deriving (Eq, Ord)
  91 instance Default Span where
  92         def = Span "" pos1 pos1
  93 instance Show Span where
  94         showsPrec _p Span{..} =
  95                 showString span_file .
  96                 showChar '#' . showsPrec 10 span_begin .
  97                 showChar '-' . showsPrec 10 span_end
  98
  99 -- ** Type 'Location'
 100 type Location = NonEmpty Span
 101
 102 -- * Class 'FromPad'
 103 class FromPad a where
 104         fromPad :: Pos -> a
 105 instance FromPad Text where
 106         fromPad Pos{..} =
 107                 Text.replicate pos_line   "\n" <>
 108                 Text.replicate pos_column " "
 109 instance FromPad TL.Text where
 110         fromPad Pos{..} =
 111                 TL.replicate (fromIntegral pos_line)   "\n" <>
 112                 TL.replicate (fromIntegral pos_column) " "