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