Language/TCT/Cell.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# LANGUAGE RecordWildCards #-}
   3 module Language.TCT.Cell where
   4
   5 import Data.Eq (Eq(..))
   6 import Data.Function (($), (.))
   7 import Data.Functor (Functor)
   8 import Data.Maybe (Maybe(..))
   9 import Data.Monoid (Monoid(..))
  10 import Data.Ord (Ord(..))
  11 import Data.Semigroup (Semigroup(..))
  12 import Data.Sequence (Seq, ViewL(..), ViewR(..))
  13 import Data.TreeSeq.Strict (Tree(..))
  14 import Prelude (Int)
  15 import Text.Show (Show(..), showParen, showString, showChar)
  16 import qualified Data.Sequence as Seq
  17
  18 -- * Type 'Cell'
  19 -- | NOTE: every 'Cell' as a 'Pos',
  20 --         which is useful to indicate matches/errors/warnings/whatever,
  21 --         or outputing in a format somehow preserving
  22 --         the original input style.
  23 data Cell a
  24  =   Cell
  25  { posCell    :: {-# UNPACK #-} !Pos
  26  , posEndCell :: {-# UNPACK #-} !Pos
  27  , unCell     :: a
  28  } deriving (Eq, Ord, Functor)
  29 instance Show a => Show (Cell a) where
  30         showsPrec p Cell{..} =
  31                 showParen (p >= 10) $
  32                 showString "Cell" .
  33                 showChar ' ' . showsPrec 10 posCell .
  34                 showChar ' ' . showsPrec 10 posEndCell .
  35                 showChar ' ' . showsPrec 11 unCell
  36 instance Semigroup a => Semigroup (Cell a) where
  37         Cell bx ex x <> Cell by ey y =
  38                 Cell (bx`min`by) (ex`max`ey) (x<>y)
  39 instance (Monoid a, Semigroup a) => Monoid (Cell a) where
  40         mempty  = Cell pos1 pos1 mempty
  41         mappend = (<>)
  42
  43 lineCell :: Cell a -> Line
  44 lineCell = linePos . posCell
  45 columnCell :: Cell a -> Column
  46 columnCell = columnPos . posCell
  47
  48 cell0 :: a -> Cell a
  49 cell0 = Cell pos0 pos0
  50 cell1 :: a -> Cell a
  51 cell1 = Cell pos1 pos1
  52
  53 posSeq :: Seq (Cell a) -> Maybe (Pos,Pos)
  54 posSeq toks =
  55         case Seq.viewl toks of
  56          EmptyL -> Nothing
  57          Cell bp _ep _ :< _ ->
  58                 case Seq.viewr toks of
  59                  EmptyR -> Nothing
  60                  _ :> Cell _bp ep _ ->
  61                         Just (bp, ep)
  62
  63 {-
  64 posTrees :: Seq (Trees (Cell k) a) -> Maybe (Pos,Pos)
  65 posTrees trees =
  66         case Seq.viewl trees of
  67          EmptyL -> Nothing
  68          Tree0 toks :< ts ->
  69                 case posSeq toks of
  70                  Nothing -> posTrees ts
  71                  Just (bp,_ep) ->
  72                         Just $
  73                                 case Seq.viewr trees of
  74                                  EmptyR -> (bp,bp)
  75                                  _ :> TreeN _ toks | iiiii->
  76
  77          TreeN (Cell bp _ep _) _ :< _ ->
  78                 case Seq.viewr trees of
  79                  EmptyR -> Nothing
  80                  _ :> TreeN _ toks | iiiii->
  81                         Just (Cell bp ep ())
  82 -}
  83
  84 -- * Type 'Pos'
  85 data Pos
  86  = Pos
  87  { linePos   :: {-# UNPACK #-} !Line
  88  , columnPos :: {-# UNPACK #-} !Column
  89  } deriving (Eq)
  90 instance Show Pos where
  91         showsPrec _p pos = showsPrec 11 (linePos pos,columnPos pos)
  92 instance Ord Pos where
  93         Pos lx cx `compare` Pos ly cy =
  94                 compare lx ly <>
  95                 compare cx cy
  96
  97 posTree :: Tree (Cell k) (Cell a) -> Pos
  98 posTree (TreeN c _) = posCell c
  99 posTree (Tree0 c)   = posCell c
 100
 101 posEndTree :: Tree (Cell k) (Cell a) -> Pos
 102 posEndTree (TreeN c _) = posEndCell c
 103 posEndTree (Tree0 c)   = posEndCell c
 104
 105 pos0 :: Pos
 106 pos0 = Pos 0 0
 107 pos1 :: Pos
 108 pos1 = Pos 1 1
 109
 110 -- ** Type 'Line'
 111 -- | Line in the source file, counting from 1.
 112 type Line = Int
 113
 114 -- ** Type 'Column'
 115 -- | Column in the source file, counting from 1.
 116 type Column = Int