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