src/Symantic/Plaintext/Output.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3
   4 module Symantic.Plaintext.Output where
   5
   6 import Data.Bool
   7 import Data.Char (Char)
   8 import Data.Eq (Eq (..))
   9 import Data.Foldable qualified as Fold
  10 import Data.Function (id, ($), (.))
  11 import Data.Function qualified as Fun
  12 import Data.Functor (Functor, (<$>))
  13 import Data.List qualified as List
  14 import Data.Maybe (Maybe (..))
  15 import Data.Monoid (Monoid (..))
  16 import Data.Semigroup (Semigroup (..))
  17 import Data.Semigroup qualified as SG
  18 import Data.String (IsString (..), String)
  19 import Data.Text qualified as T
  20 import Data.Text.Lazy qualified as TL
  21 import Data.Text.Lazy.Builder qualified as TLB
  22 import Prelude (fromIntegral)
  23
  24 import Symantic.Plaintext.Classes
  25
  26 -- * Class 'Outputable'
  27 class
  28   ( IsString o
  29   , Convertible Char o
  30   , Convertible String o
  31   , Convertible T.Text o
  32   , Convertible TL.Text o
  33   , Monoid o
  34   ) =>
  35   Outputable o
  36   where
  37   char :: Char -> o
  38   nl :: o
  39   repeatedChar :: Width -> Char -> o
  40 instance Outputable String where
  41   char = (: [])
  42   nl = "\n"
  43   repeatedChar w c = fromString (List.replicate (fromIntegral w) c)
  44 instance Outputable T.Text where
  45   char = T.singleton
  46   nl = "\n"
  47   repeatedChar w = T.replicate (fromIntegral w) . T.singleton
  48 instance Outputable TL.Text where
  49   char = TL.singleton
  50   nl = "\n"
  51   repeatedChar w = TL.replicate (fromIntegral w) . TL.singleton
  52
  53 -- * Class 'Lengthable'
  54 class Lengthable o where
  55   length :: o -> Column
  56   isEmpty :: o -> Bool
  57   isEmpty x = length x == 0
  58 instance Lengthable Char where
  59   length _ = 1
  60   isEmpty = Fun.const False
  61 instance Lengthable String where
  62   length = fromIntegral . List.length
  63   isEmpty = Fold.null
  64 instance Lengthable T.Text where
  65   length = fromIntegral . T.length
  66   isEmpty = T.null
  67 instance Lengthable TL.Text where
  68   length = fromIntegral . TL.length
  69   isEmpty = TL.null
  70
  71 -- * Class 'Splitable'
  72 class (Lengthable o, Monoid o) => Splitable o where
  73   tail :: o -> Maybe (o)
  74   break :: (Char -> Bool) -> o -> (o, o)
  75   span :: (Char -> Bool) -> o -> (o, o)
  76   span f = break (not . f)
  77
  78   splitOnChar :: (Char -> Bool) -> o -> [o]
  79   splitOnChar f d0 =
  80     if isEmpty d0 then [] else go d0
  81     where
  82       go o =
  83         let (l, r) = f `break` o
  84          in l : case tail r of
  85               Nothing -> []
  86               Just rt
  87                 | isEmpty rt -> [mempty]
  88                 | otherwise -> go rt
  89   splitOnCharNoEmpty :: (Char -> Bool) -> o -> [o]
  90   splitOnCharNoEmpty f x =
  91     let (l, r) = f `break` x
  92      in [l | not (isEmpty l)]
  93         SG.<> case tail r of
  94           Nothing -> []
  95           Just rt -> splitOnCharNoEmpty f rt
  96 instance Splitable String where
  97   tail [] = Nothing
  98   tail s = Just $ List.tail s
  99   break = List.break
 100 instance Splitable T.Text where
 101   tail "" = Nothing
 102   tail s = Just $ T.tail s
 103   break = T.break
 104 instance Splitable TL.Text where
 105   tail "" = Nothing
 106   tail s = Just $ TL.tail s
 107   break = TL.break
 108
 109 -- ** Type 'Line'
 110 newtype Line o = Line {unLine :: o}
 111   deriving (Functor, Semigroup, Monoid, Lengthable, Splitable)
 112
 113 lines :: Splitable o => o -> [Line o]
 114 linesNoEmpty :: Splitable o => o -> [Line o]
 115 lines = (Line <$>) . splitOnChar (== '\n')
 116 linesNoEmpty = (Line <$>) . splitOnCharNoEmpty (== '\n')
 117
 118 -- ** Type 'Word'
 119 newtype Word o = Word {unWord :: o}
 120   deriving (Functor, Semigroup, Monoid, Lengthable, Splitable)
 121
 122 words :: Splitable o => Line o -> [Word o]
 123 wordsNoEmpty :: Splitable o => Line o -> [Word o]
 124 words = (Word <$>) . splitOnChar (== ' ') . unLine
 125 wordsNoEmpty = (Word <$>) . splitOnCharNoEmpty (== ' ') . unLine
 126
 127 -- * Class 'Convertible'
 128 class Convertible i o where
 129   convert :: i -> o
 130 instance Convertible Char String where
 131   convert = (: [])
 132 instance Convertible String String where
 133   convert = id
 134 instance Convertible T.Text String where
 135   convert = T.unpack
 136 instance Convertible TL.Text String where
 137   convert = TL.unpack
 138 instance Convertible Char T.Text where
 139   convert = T.singleton
 140 instance Convertible String T.Text where
 141   convert = T.pack
 142 instance Convertible T.Text T.Text where
 143   convert = id
 144 instance Convertible TL.Text T.Text where
 145   convert = TL.toStrict
 146 instance Convertible Char TL.Text where
 147   convert = TL.singleton
 148 instance Convertible String TL.Text where
 149   convert = TL.pack
 150 instance Convertible T.Text TL.Text where
 151   convert = TL.fromStrict
 152 instance Convertible TL.Text TL.Text where
 153   convert = id
 154 instance Convertible Char TLB.Builder where
 155   convert = TLB.singleton
 156 instance Convertible String TLB.Builder where
 157   convert = fromString
 158 instance Convertible T.Text TLB.Builder where
 159   convert = TLB.fromText
 160 instance Convertible TL.Text TLB.Builder where
 161   convert = TLB.fromLazyText
 162 instance Convertible TLB.Builder TLB.Builder where
 163   convert = id
 164 instance Convertible i o => Convertible (Word i) (Word o) where
 165   convert = Word . convert . unWord
 166 instance Convertible i o => Convertible (Line i) (Line o) where
 167   convert = Line . convert . unLine