1 {-# LANGUAGE OverloadedStrings #-}
2 module Language.Symantic.CLI.Write.Plain where
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
17 import Language.Symantic.CLI.Sym
18 import Language.Symantic.CLI.Fixity
33 instance Doc DocIO.TermIO
35 words :: Doc.Textable d => Doc.Breakable d => String -> d
36 words m = Doc.breakableSpaces $ Doc.string <$> Doc.words m
39 -- | Constructed top-down
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.
46 -- , reader_command_indent :: Doc.Indent
47 -- , reader_option_indent :: Doc.Indent
50 defReader :: Doc.Textable d => Reader d
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
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
68 = Plain { unPlain :: Reader d -> Maybe d }
70 runPlain :: Monoid d => Plain d e t a -> Reader d -> d
71 runPlain (Plain p) = fromMaybe mempty . p
73 coercePlain :: Plain d e t a -> Plain d e u b
74 coercePlain Plain{..} = Plain{..}
76 textPlain :: Monoid d => Doc.Textable d => Plain d e t a -> d
77 textPlain p = runPlain p defReader
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
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)}
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'
106 instance Doc d => Sym_Alt (Plain d) where
107 lp <||> rp = Plain $ \ro ->
109 if needsParenInfix (reader_op ro) op
113 Doc.between (Doc.charH '(') (Doc.charH ')') $
115 runPlain lp ro{reader_op=(op, SideL), reader_or=Doc.newline<>Doc.charH '|'<>Doc.space} <>
118 runPlain rp ro{reader_op=(op, SideR), reader_or=Doc.newline<>Doc.charH '|'<>Doc.space} <>
120 (Doc.between (Doc.charH '(') (Doc.charH ')') $
121 Doc.withBreakable Nothing $
122 runPlain lp ro{reader_op=(op, SideL), reader_or=Doc.stringH " | "} <>
124 runPlain rp ro{reader_op=(op, SideR), reader_or=Doc.stringH " | "})
126 runPlain lp ro{reader_op=(op, SideL)} <>
128 runPlain rp ro{reader_op=(op, SideR)}
129 where op = infixB SideL 2
133 choice l@(_:_) = Plain $ \ro -> Just $
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
143 Doc.between (Doc.charH '[') (Doc.charH ']') $
145 runPlain p ro{reader_op=(op, SideL)} <>
147 (Doc.between (Doc.charH '[') (Doc.charH ']') $
148 Doc.withBreakable Nothing $
149 runPlain p ro{reader_op=(op, SideL), reader_or=Doc.stringH " | "})
151 runPlain p ro{reader_op=(op, SideL)}
153 instance Doc d => Sym_AltApp (Plain d) where
154 many p = Plain $ \ro -> Just $
155 runPlain p ro{reader_op=(op, SideL)}<>"*"
157 some p = Plain $ \ro -> Just $
158 runPlain p ro{reader_op=(op, SideL)}<>"+"
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 $
167 Doc.foldWith Doc.breakableSpace $
171 { reader_op=(op, SideL)
172 , reader_or=Doc.stringH " | " }
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 $
184 then runPlain p ro{reader_define=False}
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>"
192 opt n r = Plain $ \ro ->
193 unPlain (prefix n <**> coercePlain r) ro
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 $
204 (fromString n <**> coercePlain r)
205 ro{reader_define = False}
208 ref = Doc.bold $ Doc.between (Doc.charH '<') (Doc.charH '>') (Doc.stringH n)
210 instance Doc d => Sym_Help d (Plain d) where
212 instance Doc d => Sym_Exit (Plain d) where
213 exit _ = Plain $ \_ro -> Nothing