symantic-document/Language/Symantic/Document/Sym.hs

   1 module Language.Symantic.Document.Sym where
   2
   3 import Data.Char (Char)
   4 import Data.Foldable (Foldable(..))
   5 import Data.Function ((.), ($))
   6 import Data.Functor (Functor(..))
   7 import Data.Int (Int, Int64)
   8 import Data.Ord (Ord(..), Ordering(..))
   9 import Data.Semigroup (Semigroup(..))
  10 import Data.String (String, IsString)
  11 import Data.Text (Text)
  12 import Prelude (Integer, toInteger, fromIntegral, Num(..))
  13 import qualified Data.List as L
  14 import qualified Data.Text as T
  15 import qualified Data.Text.Lazy as TL
  16
  17 -- * Class 'Doc_Text'
  18 class (IsString d, Semigroup d) => Doc_Text d where
  19         charH     :: Char    -> d -- ^ XXX: MUST NOT be '\n'
  20         stringH   :: String  -> d -- ^ XXX: MUST NOT contain '\n'
  21         textH     :: Text    -> d -- ^ XXX: MUST NOT contain '\n'
  22         ltextH    :: TL.Text -> d -- ^ XXX: MUST NOT contain '\n'
  23         replicate :: Int -> d -> d
  24         integer   :: Integer -> d
  25         default replicate :: Doc_Text (ReprOf d) => Trans d => Int -> d -> d
  26         default integer   :: Doc_Text (ReprOf d) => Trans d => Integer -> d
  27         default charH     :: Doc_Text (ReprOf d) => Trans d => Char -> d
  28         default stringH   :: Doc_Text (ReprOf d) => Trans d => String -> d
  29         default textH     :: Doc_Text (ReprOf d) => Trans d => Text -> d
  30         default ltextH    :: Doc_Text (ReprOf d) => Trans d => TL.Text -> d
  31         charH     = trans . charH
  32         stringH   = trans . stringH
  33         textH     = trans . textH
  34         ltextH    = trans . ltextH
  35         replicate = trans1 . replicate
  36         integer   = trans . integer
  37
  38         empty       :: d
  39         newline     :: d
  40         space       :: d
  41         (<+>)       :: d -> d -> d
  42         int         :: Int -> d
  43         char        :: Char    -> d
  44         string      :: String  -> d
  45         text        :: Text    -> d
  46         ltext       :: TL.Text -> d
  47         catH        :: Foldable f => f d -> d
  48         catV        :: Foldable f => f d -> d
  49         foldrWith   :: Foldable f => (d -> d -> d) -> f d -> d
  50         foldWith    :: Foldable f => (d -> d) -> f d -> d
  51         intercalate :: Foldable f => d -> f d -> d
  52         between     :: d -> d -> d -> d
  53
  54         newline  = "\n"
  55         space    = char ' '
  56         x <+> y  = x <> space <> y
  57         int      = integer . toInteger
  58         char     = \case '\n' -> newline; c -> charH c
  59         string   = catV . fmap stringH . L.lines
  60         text     = catV . fmap textH   . T.lines
  61         ltext    = catV . fmap ltextH  . TL.lines
  62         catH     = foldr (<>) empty
  63         catV     = foldrWith (\x y -> x<>newline<>y)
  64         foldrWith f ds  = if null ds then empty else foldr1 f ds
  65         foldWith  f = foldrWith (\a acc -> a <> f acc)
  66         intercalate sep = foldrWith (\x y -> x<>sep<>y)
  67         between o c d = o<>d<>c
  68         -- default catH :: Doc_Text (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
  69         -- default catV :: Doc_Text (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
  70         -- catH  l = trans (catH (fmap unTrans l))
  71         -- catV  l = trans (catV (fmap unTrans l))
  72
  73 -- * Class 'Doc_Align'
  74 class Doc_Text d => Doc_Align d where
  75         type Column d
  76         type Column d = Int
  77         type Indent d
  78         type Indent d = Int
  79         -- | @align d@, make @d@ uses current 'Column' as 'Indent' level.
  80         align :: d -> d
  81         -- | @hang ind d@, make @d@ uses current 'Column' plus @ind@ as 'Indent' level.
  82         hang :: Indent d -> d -> d
  83         hang ind = align . incrIndent ind
  84         -- | @incrIndent ind d@, make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
  85         incrIndent  :: Indent d -> d -> d
  86         -- | @withIndent ind d@, make @d@ uses @ind@ as 'Indent' level.
  87         withIndent  :: Indent d -> d -> d
  88         -- | @withNewline nl d@, make @d@ uses @nl@ as 'newline'.
  89         withNewline :: d -> d -> d
  90         -- | @column f@, return @f@ applied to the current 'Column'.
  91         column :: (Column d -> d) -> d
  92         -- | @endToEndWidth d f@, return @d@ concatenated to
  93         -- @f@ applied to the difference between the end 'Column' and start 'Column' of @d@.
  94         --
  95         -- Note that @f@ is given the end-to-end width,
  96         -- which is not necessarily the maximal width.
  97         default endToEndWidth ::
  98          Semigroup d =>
  99          Num (Column d) =>
 100          d -> (Column d -> d) -> d
 101         endToEndWidth :: d -> (Column d -> d) -> d
 102         endToEndWidth d f = column $ \c1 -> (d <>) $ column $ \c2 -> f $ c2 - c1
 103
 104         -- | @spaces ind@, replicates 'space' @ind@ times.
 105         default spaces :: Indent d ~ Int => Indent d -> d
 106         spaces :: Indent d -> d
 107         spaces i = replicate i space
 108
 109         default fill ::
 110          Indent d ~ Int =>
 111          Column d ~ Int =>
 112          Indent d -> d -> d
 113         fill :: Indent d -> d -> d
 114         fill m d =
 115                 endToEndWidth d $ \w ->
 116                         case w`compare`m of
 117                          LT -> spaces $ m - w
 118                          _  -> empty
 119
 120         default breakableFill ::
 121          Indent d ~ Int =>
 122          Column d ~ Int =>
 123          Indent d -> d -> d
 124         breakableFill :: Indent d -> d -> d
 125         breakableFill m d =
 126                 endToEndWidth d $ \w ->
 127                         case w`compare`m of
 128                          LT -> spaces $ m - w
 129                          EQ -> empty
 130                          GT -> incrIndent m newline
 131
 132 -- * Class 'Doc_Wrap'
 133 class (Doc_Text d, Doc_Align d) => Doc_Wrap d where
 134         -- | @ifFit onFit onNoFit@,
 135         -- return @onFit@ if @onFit@ leads to a 'Column'
 136         -- lower or equal to the one sets with 'withWrapColumn',
 137         -- otherwise return @onNoFit@.
 138         ifFit :: d -> d -> d
 139         -- | @breakpoint onNoBreak onBreak d@,
 140         -- return @onNoBreak@ then @d@ if they fit,
 141         -- @onBreak@ otherwise.
 142         breakpoint :: d -> d -> d -> d
 143         -- | @breakableEmpty d@, return @d@ if it fits, 'newline' then @d@ otherwise.
 144         breakableEmpty :: d -> d
 145         breakableEmpty = breakpoint empty newline
 146         -- | @breakableSpace d@, return 'space' then @d@ it they fit, 'newline' then @d@ otherwise.
 147         breakableSpace :: d -> d
 148         breakableSpace = breakpoint space newline
 149         -- | @breakableSpaces ds@ intercalate a 'breakableSpace' between items of @ds@.
 150         breakableSpaces :: Foldable f => f d -> d
 151         breakableSpaces = foldWith breakableSpace
 152         -- | @withWrapColumn col d@ set the 'Column' triggering wrapping to @col@ within @d@.
 153         withWrapColumn :: Column d -> d -> d
 154         -- | @intercalateHorV sep ds@,
 155         -- return @ds@ with @sep@ intercalated if the whole fits,
 156         -- otherwise return 'align' of @ds@ with 'newline' and @sep@ intercalated.
 157         intercalateHorV :: Foldable f => d -> f d -> d
 158         intercalateHorV sep xs =
 159                 ifFit    (foldr1 (\a acc -> a <> sep            <> acc) xs)
 160                  (align $ foldr1 (\a acc -> a <> newline <> sep <> acc) xs)
 161
 162 -- * Class 'Doc_Color'
 163 class Doc_Color d where
 164         reverse :: d -> d
 165
 166         -- Foreground colors
 167         -- Dull
 168         black   :: d -> d
 169         red     :: d -> d
 170         green   :: d -> d
 171         yellow  :: d -> d
 172         blue    :: d -> d
 173         magenta :: d -> d
 174         cyan    :: d -> d
 175         white   :: d -> d
 176
 177         -- Vivid
 178         blacker   :: d -> d
 179         redder    :: d -> d
 180         greener   :: d -> d
 181         yellower  :: d -> d
 182         bluer     :: d -> d
 183         magentaer :: d -> d
 184         cyaner    :: d -> d
 185         whiter    :: d -> d
 186
 187         -- Background colors
 188         -- Dull
 189         onBlack   :: d -> d
 190         onRed     :: d -> d
 191         onGreen   :: d -> d
 192         onYellow  :: d -> d
 193         onBlue    :: d -> d
 194         onMagenta :: d -> d
 195         onCyan    :: d -> d
 196         onWhite   :: d -> d
 197
 198         -- Vivid
 199         onBlacker   :: d -> d
 200         onRedder    :: d -> d
 201         onGreener   :: d -> d
 202         onYellower  :: d -> d
 203         onBluer     :: d -> d
 204         onMagentaer :: d -> d
 205         onCyaner    :: d -> d
 206         onWhiter    :: d -> d
 207
 208         default reverse     :: Doc_Color (ReprOf d) => Trans d => d -> d
 209         default black       :: Doc_Color (ReprOf d) => Trans d => d -> d
 210         default red         :: Doc_Color (ReprOf d) => Trans d => d -> d
 211         default green       :: Doc_Color (ReprOf d) => Trans d => d -> d
 212         default yellow      :: Doc_Color (ReprOf d) => Trans d => d -> d
 213         default blue        :: Doc_Color (ReprOf d) => Trans d => d -> d
 214         default magenta     :: Doc_Color (ReprOf d) => Trans d => d -> d
 215         default cyan        :: Doc_Color (ReprOf d) => Trans d => d -> d
 216         default white       :: Doc_Color (ReprOf d) => Trans d => d -> d
 217         default blacker     :: Doc_Color (ReprOf d) => Trans d => d -> d
 218         default redder      :: Doc_Color (ReprOf d) => Trans d => d -> d
 219         default greener     :: Doc_Color (ReprOf d) => Trans d => d -> d
 220         default yellower    :: Doc_Color (ReprOf d) => Trans d => d -> d
 221         default bluer       :: Doc_Color (ReprOf d) => Trans d => d -> d
 222         default magentaer   :: Doc_Color (ReprOf d) => Trans d => d -> d
 223         default cyaner      :: Doc_Color (ReprOf d) => Trans d => d -> d
 224         default whiter      :: Doc_Color (ReprOf d) => Trans d => d -> d
 225         default onBlack     :: Doc_Color (ReprOf d) => Trans d => d -> d
 226         default onRed       :: Doc_Color (ReprOf d) => Trans d => d -> d
 227         default onGreen     :: Doc_Color (ReprOf d) => Trans d => d -> d
 228         default onYellow    :: Doc_Color (ReprOf d) => Trans d => d -> d
 229         default onBlue      :: Doc_Color (ReprOf d) => Trans d => d -> d
 230         default onMagenta   :: Doc_Color (ReprOf d) => Trans d => d -> d
 231         default onCyan      :: Doc_Color (ReprOf d) => Trans d => d -> d
 232         default onWhite     :: Doc_Color (ReprOf d) => Trans d => d -> d
 233         default onBlacker   :: Doc_Color (ReprOf d) => Trans d => d -> d
 234         default onRedder    :: Doc_Color (ReprOf d) => Trans d => d -> d
 235         default onGreener   :: Doc_Color (ReprOf d) => Trans d => d -> d
 236         default onYellower  :: Doc_Color (ReprOf d) => Trans d => d -> d
 237         default onBluer     :: Doc_Color (ReprOf d) => Trans d => d -> d
 238         default onMagentaer :: Doc_Color (ReprOf d) => Trans d => d -> d
 239         default onCyaner    :: Doc_Color (ReprOf d) => Trans d => d -> d
 240         default onWhiter    :: Doc_Color (ReprOf d) => Trans d => d -> d
 241
 242         reverse     = trans1 reverse
 243         black       = trans1 black
 244         red         = trans1 red
 245         green       = trans1 green
 246         yellow      = trans1 yellow
 247         blue        = trans1 blue
 248         magenta     = trans1 magenta
 249         cyan        = trans1 cyan
 250         white       = trans1 white
 251         blacker     = trans1 blacker
 252         redder      = trans1 redder
 253         greener     = trans1 greener
 254         yellower    = trans1 yellower
 255         bluer       = trans1 bluer
 256         magentaer   = trans1 magentaer
 257         cyaner      = trans1 cyaner
 258         whiter      = trans1 whiter
 259         onBlack     = trans1 onBlack
 260         onRed       = trans1 onRed
 261         onGreen     = trans1 onGreen
 262         onYellow    = trans1 onYellow
 263         onBlue      = trans1 onBlue
 264         onMagenta   = trans1 onMagenta
 265         onCyan      = trans1 onCyan
 266         onWhite     = trans1 onWhite
 267         onBlacker   = trans1 onBlacker
 268         onRedder    = trans1 onRedder
 269         onGreener   = trans1 onGreener
 270         onYellower  = trans1 onYellower
 271         onBluer     = trans1 onBluer
 272         onMagentaer = trans1 onMagentaer
 273         onCyaner    = trans1 onCyaner
 274         onWhiter    = trans1 onWhiter
 275
 276 -- * Class 'Doc_Decoration'
 277 class Doc_Decoration d where
 278         bold      :: d -> d
 279         underline :: d -> d
 280         italic    :: d -> d
 281         default bold      :: Doc_Decoration (ReprOf d) => Trans d => d -> d
 282         default underline :: Doc_Decoration (ReprOf d) => Trans d => d -> d
 283         default italic    :: Doc_Decoration (ReprOf d) => Trans d => d -> d
 284         bold      = trans1 bold
 285         underline = trans1 underline
 286         italic    = trans1 italic
 287
 288 -- * Class 'Trans'
 289 class Trans tr where
 290         -- | Return the underlying @tr@ of the transformer.
 291         type ReprOf tr :: *
 292
 293         -- | Lift a tr to the transformer's.
 294         trans :: ReprOf tr -> tr
 295         -- | Unlift a tr from the transformer's.
 296         unTrans :: tr -> ReprOf tr
 297
 298         -- | Identity transformation for a unary symantic method.
 299         trans1 :: (ReprOf tr -> ReprOf tr) -> (tr -> tr)
 300         trans1 f = trans . f . unTrans
 301
 302         -- | Identity transformation for a binary symantic method.
 303         trans2
 304          :: (ReprOf tr -> ReprOf tr -> ReprOf tr)
 305          -> (tr -> tr -> tr)
 306         trans2 f t1 t2 = trans (f (unTrans t1) (unTrans t2))
 307
 308         -- | Identity transformation for a ternary symantic method.
 309         trans3
 310          :: (ReprOf tr -> ReprOf tr -> ReprOf tr -> ReprOf tr)
 311          -> (tr -> tr -> tr -> tr)
 312         trans3 f t1 t2 t3 = trans (f (unTrans t1) (unTrans t2) (unTrans t3))
 313
 314 int64OfInt :: Int -> Int64
 315 int64OfInt = fromIntegral
 316
 317 intOfInt64 :: Int64 -> Int
 318 intOfInt64 = fromIntegral