Language/Symantic/CLI/Plain.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Language.Symantic.CLI.Plain where
   3
   4 import Data.Bool
   5 import Data.Function (($), (.))
   6 import Data.Functor ((<$>))
   7 import Data.Functor.Compose (Compose(..))
   8 import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
   9 import Data.Monoid (Monoid(..))
  10 import Data.Semigroup (Semigroup(..))
  11 import Data.String (String, IsString(..))
  12 import Text.Show (Show(..))
  13 import qualified Data.Text.Lazy as TL
  14 import qualified Language.Symantic.Document.Term as Doc
  15 import qualified Language.Symantic.Document.Term.IO as DocIO
  16
  17 import Language.Symantic.CLI.Sym
  18 import Language.Symantic.CLI.Fixity
  19
  20 -- * Class 'Doc'
  21 class
  22  ( IsString d
  23  , Semigroup d
  24  , Monoid d
  25  , Doc.Textable d
  26  , Doc.Indentable d
  27  , Doc.Breakable d
  28  , Doc.Colorable d
  29  , Doc.Decorable d
  30  ) =>
  31  Doc d
  32 instance Doc Doc.Term
  33 instance Doc DocIO.TermIO
  34
  35 words :: Doc.Textable d => Doc.Breakable d => String -> d
  36 words m = Doc.breakableSpaces $ Doc.string <$> Doc.words m
  37
  38 -- * Type 'Reader'
  39 -- | Constructed top-down
  40 data Reader d
  41  =   Reader
  42  {   reader_op             :: (Infix, Side) -- ^ Parent operator.
  43  ,   reader_define         :: Bool          -- ^ Whether to print a definition, or not.
  44  ,   reader_or             :: d
  45  }
  46
  47 defReader :: Doc.Textable d => Reader d
  48 defReader = Reader
  49  { reader_op             = (infixN0, SideL)
  50  , reader_define         = True
  51  , reader_or             = Doc.stringH " | "
  52  }
  53
  54 pairIfNeeded :: Doc d => Reader d -> Infix -> d -> d
  55 pairIfNeeded Reader{..} op d =
  56         if needsParenInfix reader_op op
  57         then Doc.align $ Doc.between (Doc.charH '(') (Doc.charH ')') d
  58         else d
  59
  60 -- * Type 'Plain'
  61 newtype Plain d e t a
  62  =      Plain { unPlain :: Reader d -> Maybe d }
  63
  64 runPlain :: Monoid d => Plain d e t a -> Reader d -> d
  65 runPlain (Plain p) = fromMaybe mempty . p
  66
  67 coercePlain :: Plain d e t a -> Plain d e u b
  68 coercePlain Plain{..} = Plain{..}
  69
  70 textPlain :: Monoid d => Doc.Textable d => Plain d e t a -> d
  71 textPlain p = runPlain p defReader
  72
  73 instance Semigroup d => Semigroup (Plain d e t a) where
  74         Plain x <> Plain y = Plain $ x <> y
  75 instance (Semigroup d, Monoid d) => Monoid (Plain d e t a) where
  76         mempty  = Plain mempty
  77         mappend = (<>)
  78 instance (Semigroup d, IsString d) => IsString (Plain d e t a) where
  79         fromString "" = Plain $ \_ro -> Nothing
  80         fromString s  = Plain $ \_ro -> Just $ fromString s
  81 instance Show (Plain Doc.Term e t a) where
  82         show = TL.unpack . Doc.textTerm . textPlain
  83 instance Doc d => Sym_Fun (Plain d) where
  84         _f <$$> Plain x = Plain $ \ro ->
  85                 pairIfNeeded ro op <$>
  86                 x ro{reader_op=(op, SideR)}
  87                 where
  88                 op = infixB SideL 10
  89 instance Doc d => Sym_App (Plain d) where
  90         value _ = Plain $ \_ro -> Nothing
  91         end     = Plain $ \_ro -> Nothing
  92         Plain f <**> Plain x = Plain $ \ro ->
  93                 case (f ro{reader_op=(op, SideL)}, x ro{reader_op=(op, SideR)}) of
  94                  (Nothing, Nothing) -> Nothing
  95                  (Just f', Nothing) -> Just f'
  96                  (Nothing, Just x') -> Just x'
  97                  (Just f', Just x') -> Just $ pairIfNeeded ro op $ f' <> Doc.space <> x'
  98                 where
  99                 op = infixB SideL 10
 100 instance Doc d => Sym_Alt (Plain d) where
 101         lp <||> rp = Plain $ \ro ->
 102                 Just $
 103                 if needsParenInfix (reader_op ro) op
 104                 then
 105                         Doc.ifBreak
 106                          (Doc.align $
 107                                 Doc.between (Doc.charH '(') (Doc.charH ')') $
 108                                 Doc.space <>
 109                                 runPlain lp ro{reader_op=(op, SideL), reader_or=Doc.newline<>Doc.charH '|'<>Doc.space} <>
 110                                 Doc.newline <>
 111                                 Doc.stringH "| " <>
 112                                 runPlain rp ro{reader_op=(op, SideR), reader_or=Doc.newline<>Doc.charH '|'<>Doc.space} <>
 113                                 Doc.newline)
 114                          (Doc.between (Doc.charH '(') (Doc.charH ')') $
 115                                 Doc.withBreakable Nothing $
 116                                 runPlain lp ro{reader_op=(op, SideL), reader_or=Doc.stringH " | "} <>
 117                                 Doc.stringH " | " <>
 118                                 runPlain rp ro{reader_op=(op, SideR), reader_or=Doc.stringH " | "})
 119                 else
 120                         runPlain lp ro{reader_op=(op, SideL)} <>
 121                         reader_or ro <>
 122                         runPlain rp ro{reader_op=(op, SideR)}
 123                 where op = infixB SideL 2
 124         try p = p
 125         choice [] = "<none>"
 126         choice [p] = p
 127         choice l@(_:_) = Plain $ \ro -> Just $
 128                 pairIfNeeded ro op $
 129                 Doc.foldWith ("\n| " <>) $
 130                 (($ ro{reader_op=(op, SideL)}) . runPlain) <$> l
 131                 where op = infixB SideL 2
 132         option _a p = Plain $ \ro -> Just $
 133                 if needsParenInfix (reader_op ro) op
 134                 then
 135                         Doc.ifBreak
 136                          (Doc.align $
 137                                 Doc.between (Doc.charH '[') (Doc.charH ']') $
 138                                 Doc.space <>
 139                                 runPlain p ro{reader_op=(op, SideL)} <>
 140                                 Doc.newline)
 141                          (Doc.between (Doc.charH '[') (Doc.charH ']') $
 142                                 Doc.withBreakable Nothing $
 143                                 runPlain p ro{reader_op=(op, SideL), reader_or=Doc.stringH " | "})
 144                 else
 145                         runPlain p ro{reader_op=(op, SideL)}
 146                 where op = infixN0
 147 instance Doc d => Sym_AltApp (Plain d) where
 148         many p = Plain $ \ro -> Just $
 149                 runPlain p ro{reader_op=(op, SideL)}<>"*"
 150                 where op = infixN 10
 151         some p = Plain $ \ro -> Just $
 152                 runPlain p ro{reader_op=(op, SideL)}<>"+"
 153                 where op = infixN 10
 154 type instance Perm (Plain d e t) = Compose [] (Plain d e t)
 155 instance Doc d => Sym_Interleaved (Plain d) where
 156         interleaved (Compose []) = "<none>"
 157         interleaved (Compose [Plain p]) = Plain p
 158         interleaved (Compose l@(_:_)) = Plain $ \ro -> Just $
 159                 -- pairIfNeeded ro op $
 160                 Doc.align $
 161                 Doc.foldWith Doc.breakableSpace $
 162                 catMaybes $
 163                 (\(Plain p) ->
 164                         p ro
 165                          { reader_op=(op, SideL)
 166                          , reader_or=Doc.stringH " | " }
 167                 ) <$> l
 168                 where op = infixN 10
 169         _f <<$>>      Plain p          = Compose [Plain p]
 170         _f <<$?>> (_, Plain p)         = Compose [coercePlain $ optional $ Plain p]
 171         _f <<$*>>     Plain p          = Compose [coercePlain $ many     $ Plain p]
 172         Compose ws <<|>>      Plain p  = Compose $ coercePlain <$> ws <> [Plain p]
 173         Compose ws <<|?>> (_, Plain p) = Compose $ coercePlain <$> ws <> [coercePlain $ optional $ Plain p]
 174         Compose ws <<|*>>     Plain p  = Compose $ coercePlain <$> ws <> [coercePlain $ many     $ Plain p]
 175 instance Doc d => Sym_Rule (Plain d) where
 176         rule n p = Plain $ \ro -> Just $
 177                 if reader_define ro
 178                 then runPlain p ro{reader_define=False}
 179                 else ref
 180                 where
 181                 ref =
 182                         Doc.bold $
 183                         Doc.between (Doc.charH '<') (Doc.charH '>') $
 184                         Doc.magentaer $
 185                         Doc.stringH n
 186 instance Doc d => Sym_Option (Plain d) where
 187         var n _f = Plain $ \_ro -> Just $ Doc.between (Doc.charH '<') (Doc.charH '>') (Doc.string n)
 188         tag = fromString
 189         opt n r = Plain $ \ro ->
 190                 unPlain (prefix n <**> coercePlain r) ro
 191                 where
 192                 prefix = \case
 193                  OptionName      s l -> prefix (OptionNameShort s)<>"|"<>prefix (OptionNameLong l)
 194                  OptionNameShort s   -> fromString ['-', s]
 195                  OptionNameLong  l   -> fromString ("--"<>l)
 196 instance Doc d => Sym_Command (Plain d) where
 197         main n r = Plain $ \ro -> Just $
 198                 if reader_define ro
 199                 then
 200                         runPlain
 201                          (fromString n <**> coercePlain r)
 202                          ro{reader_define = False}
 203                 else ref
 204                 where
 205                 ref =
 206                         Doc.bold $
 207                         Doc.between (Doc.charH '<') (Doc.charH '>') $
 208                         Doc.magentaer $
 209                         Doc.stringH n
 210         command = main
 211 instance Doc d => Sym_Help d (Plain d) where
 212         help _msg p = p
 213 instance Doc d => Sym_Exit (Plain d) where
 214         exit _ = Plain $ \_ro -> Nothing