{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Language.Symantic.Document.Sym where
import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Foldable (Foldable, foldr, foldr1)
import Data.Function ((.), ($))
import Data.Functor (Functor(..))
import Data.Int (Int)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..), Ordering(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString)
import Prelude (Integer, fromIntegral, Num(..), pred, undefined, Integral, Real, Enum)
import Text.Show (Show(..))
import qualified Data.Foldable as Foldable
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
newtype Nat = Nat { unNat :: Integer }
deriving (Eq, Ord, Show, Integral, Real, Enum)
unLength :: Nat -> Integer
unLength (Nat i) = i
instance Num Nat where
fromInteger i | 0 <= i = Nat i
| otherwise = undefined
abs = Nat . abs . unLength
signum = signum . signum
Nat x + Nat y = Nat (x + y)
Nat x * Nat y = Nat (x * y)
Nat x - Nat y | x >= y = Nat (x - y)
| otherwise = undefined
class Lengthable a where
length :: a -> Nat
instance Lengthable Char where
length _ = Nat 1
instance Lengthable [a] where
length = Nat . fromIntegral . List.length
instance Lengthable Text.Text where
length = Nat . fromIntegral . Text.length
instance Lengthable TL.Text where
length = Nat . fromIntegral . TL.length
class Monoid a => Splitable a where
null :: a -> Bool
tail :: a -> a
break :: (Char -> Bool) -> a -> (a, a)
lines :: a -> [a]
lines = splitOnChar (== '\n')
words :: a -> [a]
words = splitOnChar (== ' ')
splitOnChar :: (Char -> Bool) -> a -> [a]
splitOnChar c a =
if null a then []
else let (l,a') = break c a in
l : if null a' then []
else let a'' = tail a' in
if null a'' then [mempty] else splitOnChar c a''
instance Splitable String where
null = List.null
tail = List.tail
break = List.break
instance Splitable Text.Text where
null = Text.null
tail = Text.tail
break = Text.break
instance Splitable TL.Text where
null = TL.null
tail = TL.tail
break = TL.break
type Column = Nat
type Indent = Column
class (IsString d, Semigroup d) => Textable d where
empty :: d
charH :: Char
-> d
stringH :: String
-> d
textH :: Text.Text
-> d
ltextH :: TL.Text
-> d
default empty :: Textable (ReprOf d) => Trans d => d
default charH :: Textable (ReprOf d) => Trans d => Char -> d
default stringH :: Textable (ReprOf d) => Trans d => String -> d
default textH :: Textable (ReprOf d) => Trans d => Text.Text -> d
default ltextH :: Textable (ReprOf d) => Trans d => TL.Text -> d
empty = trans empty
charH = trans . charH
stringH = trans . stringH
textH = trans . textH
ltextH = trans . ltextH
newline :: d
space :: d
(<+>) :: d -> d -> d
(</>) :: d -> d -> d
int :: Int -> d
integer :: Integer -> d
char :: Char -> d
string :: String -> d
text :: Text.Text -> d
ltext :: TL.Text -> d
catH :: Foldable f => f d -> d
catV :: Foldable f => f d -> d
unwords :: Foldable f => f d -> d
unlines :: Foldable f => f d -> d
foldrWith :: Foldable f => (d -> d -> d) -> f d -> d
foldWith :: Foldable f => (d -> d) -> f d -> d
intercalate :: Foldable f => d -> f d -> d
between :: d -> d -> d -> d
replicate :: Int -> d -> d
newline = "\n"
space = char ' '
x <+> y = x <> space <> y
x </> y = x <> newline <> y
int = stringH . show
integer = stringH . show
char = \case '\n' -> newline; c -> charH c
string = catV . fmap stringH . lines
text = catV . fmap textH . lines
ltext = catV . fmap ltextH . lines
catH = foldr (<>) empty
catV = foldrWith (\x y -> x<>newline<>y)
unwords = foldr (<>) space
unlines = foldr (\x y -> x<>newline<>y) empty
foldrWith f ds = if Foldable.null ds then empty else foldr1 f ds
foldWith f = foldrWith $ \a acc -> a <> f acc
intercalate sep = foldrWith (\x y -> x<>sep<>y)
between o c d = o<>d<>c
replicate cnt t | cnt <= 0 = empty
| otherwise = t <> replicate (pred cnt) t
class Textable d => Indentable d where
align :: d -> d
default align :: Indentable (ReprOf d) => Trans d => d -> d
align = trans1 align
incrIndent :: Indent -> d -> d
default incrIndent :: Indentable (ReprOf d) => Trans d => Indent -> d -> d
incrIndent = trans1 . incrIndent
withIndent :: Indent -> d -> d
default withIndent :: Indentable (ReprOf d) => Trans d => Indent -> d -> d
withIndent = trans1 . withIndent
withNewline :: d -> d -> d
newlineWithoutIndent :: d
newlineWithIndent :: d
default withNewline :: Indentable (ReprOf d) => Trans d => d -> d -> d
default newlineWithoutIndent :: Indentable (ReprOf d) => Trans d => d
default newlineWithIndent :: Indentable (ReprOf d) => Trans d => d
withNewline = trans2 withNewline
newlineWithoutIndent = trans newlineWithoutIndent
newlineWithIndent = trans newlineWithIndent
column :: (Column -> d) -> d
default column :: Indentable (ReprOf d) => Trans d => (Column -> d) -> d
column f = trans $ column (unTrans . f)
indent :: (Indent -> d) -> d
default indent :: Indentable (ReprOf d) => Trans d => (Indent -> d) -> d
indent f = trans $ indent (unTrans . f)
hang :: Indent -> d -> d
hang ind = align . incrIndent ind
endToEndWidth :: d -> (Column -> d) -> d
endToEndWidth d f =
column $ \c1 ->
(d <>) $
column $ \c2 ->
f $ if c2 - c1 >= 0
then c2 - c1
else c1 - c2
spaces :: Indent -> d
spaces i = replicate (fromIntegral i) space
fill :: Indent -> d -> d
fill m d =
endToEndWidth d $ \w ->
case w`compare`m of
LT -> spaces $ m - w
_ -> empty
breakableFill :: Indent -> d -> d
breakableFill m d =
column $ \c ->
endToEndWidth d $ \w ->
case w`compare`m of
LT -> spaces (m - w)
EQ -> empty
GT -> withIndent (c + m) newline
class (Textable d, Indentable d) => Breakable d where
breakable :: (Maybe Column -> d) -> d
default breakable :: Breakable (ReprOf d) => Trans d => (Maybe Column -> d) -> d
breakable f = trans $ breakable (unTrans . f)
withBreakable :: Maybe Column -> d -> d
default withBreakable :: Breakable (ReprOf d) => Trans d => Maybe Column -> d -> d
withBreakable = trans1 . withBreakable
ifBreak :: d -> d -> d
default ifBreak :: Breakable (ReprOf d) => Trans d => d -> d -> d
ifBreak = trans2 ifBreak
breakpoint :: d -> d -> d -> d
default breakpoint :: Breakable (ReprOf d) => Trans d => d -> d -> d -> d
breakpoint = trans3 breakpoint
breakableEmpty :: d -> d
breakableEmpty = breakpoint empty newline
(><) :: d -> d -> d
x >< y = x <> breakableEmpty y
breakableSpace :: d -> d
breakableSpace = breakpoint space newline
(>+<) :: d -> d -> d
x >+< y = x <> breakableSpace y
breakableSpaces :: Foldable f => f d -> d
breakableSpaces = foldWith breakableSpace
intercalateHorV :: Foldable f => d -> f d -> d
intercalateHorV sep xs =
ifBreak
(align $ foldWith ((newline <> sep) <>) xs)
(foldWith (sep <>) xs)
class Colorable d where
colorable :: (Bool -> d) -> d
default colorable :: Colorable (ReprOf d) => Trans d => (Bool -> d) -> d
colorable f = trans $ colorable (unTrans . f)
withColorable :: Bool -> d -> d
default withColorable :: Colorable (ReprOf d) => Trans d => Bool -> d -> d
withColorable = trans1 . withColorable
reverse :: d -> d
black :: d -> d
red :: d -> d
green :: d -> d
yellow :: d -> d
blue :: d -> d
magenta :: d -> d
cyan :: d -> d
white :: d -> d
blacker :: d -> d
redder :: d -> d
greener :: d -> d
yellower :: d -> d
bluer :: d -> d
magentaer :: d -> d
cyaner :: d -> d
whiter :: d -> d
onBlack :: d -> d
onRed :: d -> d
onGreen :: d -> d
onYellow :: d -> d
onBlue :: d -> d
onMagenta :: d -> d
onCyan :: d -> d
onWhite :: d -> d
onBlacker :: d -> d
onRedder :: d -> d
onGreener :: d -> d
onYellower :: d -> d
onBluer :: d -> d
onMagentaer :: d -> d
onCyaner :: d -> d
onWhiter :: d -> d
default reverse :: Colorable (ReprOf d) => Trans d => d -> d
default black :: Colorable (ReprOf d) => Trans d => d -> d
default red :: Colorable (ReprOf d) => Trans d => d -> d
default green :: Colorable (ReprOf d) => Trans d => d -> d
default yellow :: Colorable (ReprOf d) => Trans d => d -> d
default blue :: Colorable (ReprOf d) => Trans d => d -> d
default magenta :: Colorable (ReprOf d) => Trans d => d -> d
default cyan :: Colorable (ReprOf d) => Trans d => d -> d
default white :: Colorable (ReprOf d) => Trans d => d -> d
default blacker :: Colorable (ReprOf d) => Trans d => d -> d
default redder :: Colorable (ReprOf d) => Trans d => d -> d
default greener :: Colorable (ReprOf d) => Trans d => d -> d
default yellower :: Colorable (ReprOf d) => Trans d => d -> d
default bluer :: Colorable (ReprOf d) => Trans d => d -> d
default magentaer :: Colorable (ReprOf d) => Trans d => d -> d
default cyaner :: Colorable (ReprOf d) => Trans d => d -> d
default whiter :: Colorable (ReprOf d) => Trans d => d -> d
default onBlack :: Colorable (ReprOf d) => Trans d => d -> d
default onRed :: Colorable (ReprOf d) => Trans d => d -> d
default onGreen :: Colorable (ReprOf d) => Trans d => d -> d
default onYellow :: Colorable (ReprOf d) => Trans d => d -> d
default onBlue :: Colorable (ReprOf d) => Trans d => d -> d
default onMagenta :: Colorable (ReprOf d) => Trans d => d -> d
default onCyan :: Colorable (ReprOf d) => Trans d => d -> d
default onWhite :: Colorable (ReprOf d) => Trans d => d -> d
default onBlacker :: Colorable (ReprOf d) => Trans d => d -> d
default onRedder :: Colorable (ReprOf d) => Trans d => d -> d
default onGreener :: Colorable (ReprOf d) => Trans d => d -> d
default onYellower :: Colorable (ReprOf d) => Trans d => d -> d
default onBluer :: Colorable (ReprOf d) => Trans d => d -> d
default onMagentaer :: Colorable (ReprOf d) => Trans d => d -> d
default onCyaner :: Colorable (ReprOf d) => Trans d => d -> d
default onWhiter :: Colorable (ReprOf d) => Trans d => d -> d
reverse = trans1 reverse
black = trans1 black
red = trans1 red
green = trans1 green
yellow = trans1 yellow
blue = trans1 blue
magenta = trans1 magenta
cyan = trans1 cyan
white = trans1 white
blacker = trans1 blacker
redder = trans1 redder
greener = trans1 greener
yellower = trans1 yellower
bluer = trans1 bluer
magentaer = trans1 magentaer
cyaner = trans1 cyaner
whiter = trans1 whiter
onBlack = trans1 onBlack
onRed = trans1 onRed
onGreen = trans1 onGreen
onYellow = trans1 onYellow
onBlue = trans1 onBlue
onMagenta = trans1 onMagenta
onCyan = trans1 onCyan
onWhite = trans1 onWhite
onBlacker = trans1 onBlacker
onRedder = trans1 onRedder
onGreener = trans1 onGreener
onYellower = trans1 onYellower
onBluer = trans1 onBluer
onMagentaer = trans1 onMagentaer
onCyaner = trans1 onCyaner
onWhiter = trans1 onWhiter
class Decorable d where
decorable :: (Bool -> d) -> d
default decorable :: Decorable (ReprOf d) => Trans d => (Bool -> d) -> d
decorable f = trans $ decorable (unTrans . f)
withDecorable :: Bool -> d -> d
default withDecorable :: Decorable (ReprOf d) => Trans d => Bool -> d -> d
withDecorable = trans1 . withDecorable
bold :: d -> d
underline :: d -> d
italic :: d -> d
default bold :: Decorable (ReprOf d) => Trans d => d -> d
default underline :: Decorable (ReprOf d) => Trans d => d -> d
default italic :: Decorable (ReprOf d) => Trans d => d -> d
bold = trans1 bold
underline = trans1 underline
italic = trans1 italic
class Trans tr where
type ReprOf tr :: *
trans :: ReprOf tr -> tr
unTrans :: tr -> ReprOf tr
trans1 :: (ReprOf tr -> ReprOf tr) -> (tr -> tr)
trans1 f = trans . f . unTrans
trans2
:: (ReprOf tr -> ReprOf tr -> ReprOf tr)
-> (tr -> tr -> tr)
trans2 f t1 t2 = trans (f (unTrans t1) (unTrans t2))
trans3
:: (ReprOf tr -> ReprOf tr -> ReprOf tr -> ReprOf tr)
-> (tr -> tr -> tr -> tr)
trans3 f t1 t2 t3 = trans (f (unTrans t1) (unTrans t2) (unTrans t3))