src/Symantic/Formatter/Output.hs

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