Language/Symantic/CLI/Plain.hs

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