1 {-# LANGUAGE OverloadedStrings #-}
2 module Language.Symantic.CLI.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_define :: Bool -- ^ Whether to print a definition, or not.
47 defReader :: Doc.Textable d => Reader d
49 { reader_op = (infixN0, SideL)
50 , reader_define = True
51 , reader_or = Doc.stringH " | "
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
62 = Plain { unPlain :: Reader d -> Maybe d }
64 runPlain :: Monoid d => Plain d e t a -> Reader d -> d
65 runPlain (Plain p) = fromMaybe mempty . p
67 coercePlain :: Plain d e t a -> Plain d e u b
68 coercePlain Plain{..} = Plain{..}
70 textPlain :: Monoid d => Doc.Textable d => Plain d e t a -> d
71 textPlain p = runPlain p defReader
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
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)}
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'
100 instance Doc d => Sym_Alt (Plain d) where
101 lp <||> rp = Plain $ \ro ->
103 if needsParenInfix (reader_op ro) op
107 Doc.between (Doc.charH '(') (Doc.charH ')') $
109 runPlain lp ro{reader_op=(op, SideL), reader_or=Doc.newline<>Doc.charH '|'<>Doc.space} <>
112 runPlain rp ro{reader_op=(op, SideR), reader_or=Doc.newline<>Doc.charH '|'<>Doc.space} <>
114 (Doc.between (Doc.charH '(') (Doc.charH ')') $
115 Doc.withBreakable Nothing $
116 runPlain lp ro{reader_op=(op, SideL), reader_or=Doc.stringH " | "} <>
118 runPlain rp ro{reader_op=(op, SideR), reader_or=Doc.stringH " | "})
120 runPlain lp ro{reader_op=(op, SideL)} <>
122 runPlain rp ro{reader_op=(op, SideR)}
123 where op = infixB SideL 2
127 choice l@(_:_) = Plain $ \ro -> Just $
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
137 Doc.between (Doc.charH '[') (Doc.charH ']') $
139 runPlain p ro{reader_op=(op, SideL)} <>
141 (Doc.between (Doc.charH '[') (Doc.charH ']') $
142 Doc.withBreakable Nothing $
143 runPlain p ro{reader_op=(op, SideL), reader_or=Doc.stringH " | "})
145 runPlain p ro{reader_op=(op, SideL)}
147 instance Doc d => Sym_AltApp (Plain d) where
148 many p = Plain $ \ro -> Just $
149 runPlain p ro{reader_op=(op, SideL)}<>"*"
151 some p = Plain $ \ro -> Just $
152 runPlain p ro{reader_op=(op, SideL)}<>"+"
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 $
161 Doc.foldWith Doc.breakableSpace $
165 { reader_op=(op, SideL)
166 , reader_or=Doc.stringH " | " }
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 $
178 then runPlain p ro{reader_define=False}
183 Doc.between (Doc.charH '<') (Doc.charH '>') $
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)
189 opt n r = Plain $ \ro ->
190 unPlain (prefix n <**> coercePlain r) ro
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 $
201 (fromString n <**> coercePlain r)
202 ro{reader_define = False}
207 Doc.between (Doc.charH '<') (Doc.charH '>') $
211 instance Doc d => Sym_Help d (Plain d) where
213 instance Doc d => Sym_Exit (Plain d) where
214 exit _ = Plain $ \_ro -> Nothing