1 {-# LANGUAGE OverloadedStrings #-}
2 module Language.Symantic.CLI.Plain where
4 import Control.Applicative (Applicative(..))
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
18 import Language.Symantic.CLI.Sym
19 import Language.Symantic.CLI.Fixity
34 instance Doc DocIO.TermIO
36 words :: Doc.Textable d => Doc.Breakable d => String -> d
37 words m = Doc.breakableSpaces $ Doc.string <$> Doc.words m
40 -- | Constructed top-down
43 { reader_op :: (Infix, Side) -- ^ Parent operator.
44 , reader_define :: Bool -- ^ Whether to print a definition, or not.
48 defReader :: Doc.Textable d => Reader d
50 { reader_op = (infixN0, SideL)
51 , reader_define = True
52 , reader_or = Doc.stringH " | "
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
63 = Plain { unPlain :: Reader d -> Maybe d }
65 runPlain :: Monoid d => Plain d e t a -> Reader d -> d
66 runPlain (Plain p) = fromMaybe mempty . p
68 coercePlain :: Plain d e t a -> Plain d e u b
69 coercePlain Plain{..} = Plain{..}
71 textPlain :: Monoid d => Doc.Textable d => Plain d e t a -> d
72 textPlain p = runPlain p defReader
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
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)}
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'
101 instance Doc d => Sym_Alt (Plain d) where
102 lp <||> rp = Plain $ \ro ->
104 if needsParenInfix (reader_op ro) op
108 Doc.between (Doc.charH '(') (Doc.charH ')') $
110 runPlain lp ro{reader_op=(op, SideL), reader_or=Doc.newline<>Doc.charH '|'<>Doc.space} <>
113 runPlain rp ro{reader_op=(op, SideR), reader_or=Doc.newline<>Doc.charH '|'<>Doc.space} <>
115 (Doc.between (Doc.charH '(') (Doc.charH ')') $
116 Doc.withBreakable Nothing $
117 runPlain lp ro{reader_op=(op, SideL), reader_or=Doc.stringH " | "} <>
119 runPlain rp ro{reader_op=(op, SideR), reader_or=Doc.stringH " | "})
121 runPlain lp ro{reader_op=(op, SideL)} <>
123 runPlain rp ro{reader_op=(op, SideR)}
124 where op = infixB SideL 2
128 choice l@(_:_) = Plain $ \ro -> Just $
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
138 Doc.between (Doc.charH '[') (Doc.charH ']') $
140 runPlain p ro{reader_op=(op, SideL)} <>
142 (Doc.between (Doc.charH '[') (Doc.charH ']') $
143 Doc.withBreakable Nothing $
144 runPlain p ro{reader_op=(op, SideL), reader_or=Doc.stringH " | "})
146 runPlain p ro{reader_op=(op, SideL)}
148 instance Doc d => Sym_AltApp (Plain d) where
149 many p = Plain $ \ro -> Just $
150 runPlain p ro{reader_op=(op, SideL)}<>"*"
152 some p = Plain $ \ro -> Just $
153 runPlain p ro{reader_op=(op, SideL)}<>"+"
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 $
162 Doc.foldWith Doc.breakableSpace $
166 { reader_op=(op, SideL)
167 , reader_or=Doc.stringH " | " }
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 $
187 then runPlain p ro{reader_define=False}
192 Doc.between (Doc.charH '<') (Doc.charH '>') $
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)
198 opt n r = Plain $ \ro ->
199 unPlain (prefix n <**> coercePlain r) ro
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 $
210 (fromString n <**> coercePlain r)
211 ro{reader_define = False}
216 Doc.between (Doc.charH '<') (Doc.charH '>') $
220 instance Doc d => Sym_Help d (Plain d) where
222 instance Doc d => Sym_Exit (Plain d) where
223 exit _ = Plain $ \_ro -> Nothing