symantic-cli/Language/Symantic/CLI/Write/Plain.hs

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