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)
  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
  40 pos1 :: Pos
  41 pos1 = Pos 1 1
  42
  43 -- ** Type 'LineNum'
  44 type LineNum = Int
  45
  46 -- ** Type 'ColNum'
  47 type ColNum = Int
  48
  49 -- * Type 'Cell'
  50 data Cell a
  51  =   Cell
  52  {   cell_begin :: {-# UNPACK #-} !Pos
  53  ,   cell_end   :: {-# UNPACK #-} !Pos
  54  , unCell       :: !a
  55  }   deriving (Eq, Functor)
  56 instance Show a => Show (Cell a) where
  57         showsPrec p Cell{..} =
  58                 showParen (p >= 10) $
  59                 showString "Cell" .
  60                 showChar ' ' . showsPrec 10 cell_begin .
  61                 showChar ' ' . showsPrec 10 cell_end .
  62                 showChar ' ' . showsPrec 11 unCell
  63 instance Pretty a => Pretty (Cell a) where
  64         pretty (Cell bp ep m) = do
  65                 s <- pretty m
  66                 return $ "Cell "<>show bp<>":"<>show ep<>" "<>s
  67 instance (FromPad a, Semigroup a) => Semigroup (Cell a) where
  68         Cell bx (Pos lx cx) x <> Cell (Pos ly cy) ey y =
  69                 Cell bx ey $
  70                         x <> fromPad pad <> y
  71                 where
  72                 pad = Pos lyx $ if lyx == 0 then cy - cx else cy
  73                 lyx = ly - lx
  74 instance (FromPad a, Semigroup a, Monoid a) => Monoid (Cell a) where
  75         mempty  = cell0 mempty
  76         mappend = (<>)
  77
  78 cell0 :: a -> Cell a
  79 cell0 = Cell mempty mempty
  80
  81 -- * Class 'FromPad'
  82 class FromPad a where
  83         fromPad :: Pos -> a
  84 instance FromPad Text where
  85         fromPad Pos{..} =
  86                 Text.replicate pos_line   "\n" <>
  87                 Text.replicate pos_column " "
  88 instance FromPad TL.Text where
  89         fromPad Pos{..} =
  90                 TL.replicate (fromIntegral pos_line)   "\n" <>
  91                 TL.replicate (fromIntegral pos_column) " "