Language/TCT/Cell.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 module Language.TCT.Cell where
   5
   6 import Data.Eq (Eq(..))
   7 import Data.Function (($), (.))
   8 import Data.Functor (Functor)
   9 import Data.Monoid (Monoid(..))
  10 import Data.Ord (Ord(..))
  11 import Data.Semigroup (Semigroup(..))
  12 import Data.Text (Text)
  13 import Prelude (Int, Num(..), fromIntegral)
  14 import Text.Show (Show(..), showParen, showString, showChar)
  15 import qualified Data.Text as Text
  16 import qualified Data.Text.Lazy as TL
  17
  18 -- * Type 'Pos'
  19 -- | Relative position
  20 data Pos
  21  =   Pos
  22  {   pos_line   :: {-# UNPACK #-} !LineNum
  23  ,   pos_column :: {-# UNPACK #-} !ColNum
  24  } deriving (Eq)
  25 instance Semigroup Pos where
  26         Pos lx cx <> Pos ly cy =
  27                 Pos (lx+ly) (cx+cy)
  28 instance Monoid Pos where
  29         mempty  = Pos 0 0
  30         mappend = (<>)
  31 instance Show Pos where
  32         showsPrec _p Pos{..} =
  33                 showsPrec 11 pos_line .
  34                 showChar ':' .
  35                 showsPrec 11 pos_column
  36
  37 -- ** Type 'LineNum'
  38 type LineNum = Int
  39
  40 -- ** Type 'ColNum'
  41 type ColNum = Int
  42
  43 -- * Type 'Cell'
  44 data Cell a
  45  =   Cell
  46  {   cell_begin :: {-# UNPACK #-} !Pos
  47  ,   cell_end   :: {-# UNPACK #-} !Pos
  48  , unCell       :: !a
  49  }   deriving (Eq, Functor)
  50 instance Show a => Show (Cell a) where
  51         showsPrec p Cell{..} =
  52                 showParen (p >= 10) $
  53                 showString "Cell" .
  54                 showChar ' ' . showsPrec 10 cell_begin .
  55                 showChar ' ' . showsPrec 10 cell_end .
  56                 showChar ' ' . showsPrec 11 unCell
  57 instance (FromPad a, Semigroup a) => Semigroup (Cell a) where
  58         Cell bx (Pos lx _cx) x <> Cell (Pos ly cy) ey y =
  59                 Cell bx ey $ x <> fromPad (Pos (ly - lx) cy) <> y
  60 instance (FromPad a, Semigroup a, Monoid a) => Monoid (Cell a) where
  61         mempty  = cell0 mempty
  62         mappend = (<>)
  63 cell0 :: a -> Cell a
  64 cell0 = Cell mempty mempty
  65
  66 -- * Class 'FromPad'
  67 class FromPad a where
  68         fromPad :: Pos -> a
  69 instance FromPad Text where
  70         fromPad Pos{..} =
  71                 Text.replicate pos_line   "\n" <>
  72                 Text.replicate pos_column " "
  73 instance FromPad TL.Text where
  74         fromPad Pos{..} =
  75                 TL.replicate (fromIntegral pos_line)   "\n" <>
  76                 TL.replicate (fromIntegral pos_column) " "
  77
  78 {-
  79 instance (FromPad a, Semigroup a) => Semigroup (Cell a) where
  80         Cell bx ex x <> Cell by ey y =
  81                 Cell bx ey $ x <> fromPad by <> y
  82 instance Applicative Cell where
  83         pure = Cell mempty mempty
  84         Cell of_ sf f <*> Cell bx ex x =
  85                 Cell of_ (sf<>bx<>ex) (f x)
  86
  87 cell0 :: a -> Cell a
  88 cell0 = pure
  89
  90 -- * Class 'Cellified'
  91 class Cellified a where
  92         reachOf :: a -> Pos
  93         reachOf a = offsetOf a <> sizeOf a
  94         offsetOf :: a -> Pos
  95         sizeOf :: a -> Pos
  96 instance Cellified (Cell a) where
  97         offsetOf = cell_begin
  98         sizeOf   = cell_end
  99 instance Cellified a => Cellified [a] where
 100         reachOf = foldMap reachOf
 101         offsetOf = \case
 102          [] -> mempty
 103          s0 : ss ->
 104                 if sizeOf s0 == mempty
 105                 then offsetOf s0 <> offsetOf ss
 106                 else offsetOf s0
 107         sizeOf = foldMap sizeOf
 108 instance Cellified a => Cellified (Seq a) where
 109         reachOf = foldMap reachOf
 110         offsetOf s = case Seq.viewl s of
 111          EmptyL -> mempty
 112          s0 :< ss ->
 113                 if sizeOf s0 == mempty
 114                 then offsetOf s0 <> offsetOf ss
 115                 else offsetOf s0
 116         sizeOf = foldMap sizeOf
 117 instance (Cellified k, Cellified a) => Cellified (Tree k a) where
 118         reachOf = \case
 119          TreeN k _ts -> reachOf k
 120          Tree0 a -> reachOf a
 121         offsetOf = \case
 122          TreeN k _ts -> offsetOf k
 123          Tree0 a -> offsetOf a
 124         sizeOf = \case
 125          TreeN k _ts -> sizeOf k
 126          Tree0 a -> sizeOf a
 127 -}
 128
 129 {-
 130 -- * Class 'Cellify'
 131 class Cellify a where
 132         cellify :: a -> Cell a
 133 instance Cellify Text where
 134         cellify t = Cell mempty s t
 135                 where
 136                 s =
 137                         Text.foldl' (\acc -> \case
 138                          '\n' -> acc{pos_line   = pos_line   acc + 1}
 139                          _    -> acc{pos_column = pos_column acc + 1})
 140                          mempty t
 141
 142 -- * Type 'Pad'
 143 type Pad = Pos
 144
 145 -- * Type 'Padded'
 146 data Padded a
 147  =   Padded
 148  {   pad    :: !Pad
 149  ,   unPad  :: !a
 150  } deriving (Eq,Show)
 151
 152
 153 -- * Type 'Pos'
 154 -- | Absolute position
 155 data Pos
 156  =   Pos
 157  {   pos_line   :: {-# UNPACK #-} !LineNum
 158  ,   pos_column :: {-# UNPACK #-} !ColNum
 159  } deriving (Eq, Ord)
 160 instance Show Pos where
 161         showsPrec _p Pos{..} = showsPrec 11 (pos_line,pos_column)
 162
 163 pos1 :: Pos
 164 pos1 = Pos 1 1
 165
 166 -}
 167
 168
 169
 170
 171
 172
 173 {-
 174 instance Applicative (Cell a) where
 175         pure = cell0
 176         cf@(Cell bf ef f) <*> ca@(Cell ba ea a) =
 177          | isCell0 cf || isCell0 ca = cell0 (f a)
 178                 Cell bf ea (f a)
 179 isCell0 :: Cell a -> Bool
 180 isCell0 (Cell bp ep _) = isPos0 bp && isPos0 ep
 181 -}
 182
 183 {-
 184 lineCell :: Cell a -> LineNum
 185 lineCell = pos_line . cell_begin
 186 columnCell :: Cell a -> ColNum
 187 columnCell = pos_column . cell_begin
 188
 189 cell1 :: a -> Cell a
 190 cell1 = Cell pos1 pos1
 191 -}
 192
 193 {-
 194 posSeq :: Seq (Cell a) -> Maybe (Pos,Pos)
 195 posSeq toks =
 196         case Seq.viewl toks of
 197          EmptyL -> Nothing
 198          Cell bp _ep _ :< _ ->
 199                 case Seq.viewr toks of
 200                  EmptyR -> Nothing
 201                  _ :> Cell _bp ep _ ->
 202                         Just (bp, ep)
 203 posTrees :: Seq (Trees (Cell k) a) -> Maybe (Pos,Pos)
 204 posTrees trees =
 205         case Seq.viewl trees of
 206          EmptyL -> Nothing
 207          Tree0 toks :< ts ->
 208                 case posSeq toks of
 209                  Nothing -> posTrees ts
 210                  Just (bp,_ep) ->
 211                         Just $
 212                                 case Seq.viewr trees of
 213                                  EmptyR -> (bp,bp)
 214                                  _ :> TreeN _ toks | iiiii->
 215
 216          TreeN (Cell bp _ep _) _ :< _ ->
 217                 case Seq.viewr trees of
 218                  EmptyR -> Nothing
 219                  _ :> TreeN _ toks | iiiii->
 220                         Just (Cell bp ep ())
 221 -}
 222
 223 {-
 224 posTree :: Tree (Cell k) (Cell a) -> Pos
 225 posTree (TreeN c _) = cell_begin c
 226 posTree (Tree0 c)   = cell_begin c
 227
 228 posEndTree :: Tree (Cell k) (Cell a) -> Pos
 229 posEndTree (TreeN c _) = cell_end c
 230 posEndTree (Tree0 c)   = cell_end c
 231
 232 pos0 :: Pos
 233 pos0 = Pos 0 0
 234 -}
 235 {-
 236 instance Ord Pos where
 237         Pos lx cx `compare` Pos ly cy =
 238                 compare lx ly <>
 239                 compare cx cy
 240
 241 isPos0 :: Pos -> Bool
 242 isPos0 (Pos 0 0 ) = True
 243 isPos0 _ = False
 244 -}
 245
 246 {-
 247 -- ** Class 'CellOf'
 248 class CellOf a where
 249         firstCellOf :: a -> Maybe (Cell ())
 250 instance CellOf (Cell a) where
 251         firstCellOf = Just . (() <$)
 252 instance CellOf a => CellOf (Seq a) where
 253         firstCellOf s =
 254                 case Seq.viewl s of
 255                  EmptyL -> Nothing
 256                  s0 :< ss ->
 257                         firstCellOf s0 <|>
 258                         firstCellOf ss
 259 instance CellOf a => CellOf [a] where
 260         firstCellOf = \case
 261          [] -> Nothing
 262          s0 : ss ->
 263                 firstCellOf s0 <|>
 264                 firstCellOf ss
 265 instance (CellOf k, CellOf a) => CellOf (Tree k a) where
 266         firstCellOf = \case
 267          Tree0 a -> firstCellOf a
 268          TreeN k a -> firstCellOf k <|> firstCellOf a
 269 -}