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