{-# LANGUAGE OverloadedStrings #-}
module Symantic.Parser.Grammar.Write where
+import Data.Bool (Bool(..))
import Control.Monad (Monad(..))
import Data.Function (($))
import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
-import Text.Show (Show(..))
import qualified Data.Functor as Pre
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
import Symantic.Parser.Grammar.Combinators
import Symantic.Parser.Grammar.Fixity
--- * Type 'WriteComb'
-newtype WriteComb a = WriteComb { unWriteComb :: WriteCombInh -> Maybe TLB.Builder }
+-- * Type 'WriteGrammar'
+newtype WriteGrammar (showName::Bool) a = WriteGrammar { unWriteGrammar :: WriteGrammarInh -> Maybe TLB.Builder }
-instance IsString (WriteComb a) where
- fromString s = WriteComb $ \_inh ->
+instance IsString (WriteGrammar sN a) where
+ fromString s = WriteGrammar $ \_inh ->
if List.null s then Nothing
else Just (fromString s)
--- ** Type 'WriteCombInh'
-data WriteCombInh
- = WriteCombInh
- { writeCombInh_indent :: TLB.Builder
- , writeCombInh_op :: (Infix, Side)
- , writeCombInh_pair :: Pair
+-- ** Type 'WriteGrammarInh'
+data WriteGrammarInh
+ = WriteGrammarInh
+ { writeGrammarInh_indent :: TLB.Builder
+ , writeGrammarInh_op :: (Infix, Side)
+ , writeGrammarInh_pair :: Pair
}
-emptyWriteCombInh :: WriteCombInh
-emptyWriteCombInh = WriteCombInh
- { writeCombInh_indent = "\n"
- , writeCombInh_op = (infixN0, SideL)
- , writeCombInh_pair = pairParen
+emptyWriteGrammarInh :: WriteGrammarInh
+emptyWriteGrammarInh = WriteGrammarInh
+ { writeGrammarInh_indent = "\n"
+ , writeGrammarInh_op = (infixN0, SideL)
+ , writeGrammarInh_pair = pairParen
}
-writeComb :: WriteComb a -> TL.Text
-writeComb (WriteComb r) = TLB.toLazyText $ fromMaybe "" $ r emptyWriteCombInh
+writeGrammar :: WriteGrammar sN a -> TL.Text
+writeGrammar (WriteGrammar r) = TLB.toLazyText $ fromMaybe "" $ r emptyWriteGrammarInh
-pairWriteCombInh ::
+pairWriteGrammarInh ::
Semigroup s => IsString s =>
- WriteCombInh -> Infix -> Maybe s -> Maybe s
-pairWriteCombInh inh op s =
- if isPairNeeded (writeCombInh_op inh) op
+ WriteGrammarInh -> Infix -> Maybe s -> Maybe s
+pairWriteGrammarInh inh op s =
+ if isPairNeeded (writeGrammarInh_op inh) op
then Just (fromString o<>" ")<>s<>Just (" "<>fromString c)
else s
- where (o,c) = writeCombInh_pair inh
+ where (o,c) = writeGrammarInh_pair inh
-instance Show letName => Letable letName WriteComb where
- def name x = WriteComb $ \inh ->
- pairWriteCombInh inh op $
+instance
+ ShowLetName sN letName =>
+ Letable letName (WriteGrammar sN) where
+ def name x = WriteGrammar $ \inh ->
+ pairWriteGrammarInh inh op $
Just "def "
- <> Just (fromString (show name))
- <> unWriteComb x inh
+ <> Just (fromString (showLetName @sN name))
+ <> unWriteGrammar x inh
where
op = infixN 9
- ref rec name = WriteComb $ \inh ->
- pairWriteCombInh inh op $
+ ref rec name = WriteGrammar $ \inh ->
+ pairWriteGrammarInh inh op $
Just (if rec then "rec " else "ref ") <>
- Just (fromString (show name))
+ Just (fromString (showLetName @sN name))
where
op = infixN 9
-instance Applicable WriteComb where
- pure _ = WriteComb $ return Nothing
+instance Applicable (WriteGrammar sN) where
+ pure _ = WriteGrammar $ return Nothing
-- pure _ = "pure"
- WriteComb x <*> WriteComb y = WriteComb $ \inh ->
+ WriteGrammar x <*> WriteGrammar y = WriteGrammar $ \inh ->
let inh' side = inh
- { writeCombInh_op = (op, side)
- , writeCombInh_pair = pairParen
+ { writeGrammarInh_op = (op, side)
+ , writeGrammarInh_pair = pairParen
} in
case x (inh' SideL) of
Nothing -> y (inh' SideR)
case y (inh' SideR) of
Nothing -> Just xt
Just yt ->
- pairWriteCombInh inh op $
+ pairWriteGrammarInh inh op $
Just $ xt <> ", " <> yt
where
op = infixN 1
-instance Alternable WriteComb where
+instance Alternable (WriteGrammar sN) where
empty = "empty"
- try x = WriteComb $ \inh ->
- pairWriteCombInh inh op $
- Just "try " <> unWriteComb x inh
+ try x = WriteGrammar $ \inh ->
+ pairWriteGrammarInh inh op $
+ Just "try " <> unWriteGrammar x inh
where
op = infixN 9
- x <|> y = WriteComb $ \inh ->
- pairWriteCombInh inh op $
- unWriteComb x inh
- { writeCombInh_op = (op, SideL)
- , writeCombInh_pair = pairParen
+ x <|> y = WriteGrammar $ \inh ->
+ pairWriteGrammarInh inh op $
+ unWriteGrammar x inh
+ { writeGrammarInh_op = (op, SideL)
+ , writeGrammarInh_pair = pairParen
} <>
Just " | " <>
- unWriteComb y inh
- { writeCombInh_op = (op, SideR)
- , writeCombInh_pair = pairParen
+ unWriteGrammar y inh
+ { writeGrammarInh_op = (op, SideR)
+ , writeGrammarInh_pair = pairParen
}
where op = infixB SideL 3
-instance Satisfiable tok WriteComb where
+instance Satisfiable tok (WriteGrammar sN) where
satisfy _es _f = "satisfy"
-instance Selectable WriteComb where
- branch lr l r = WriteComb $ \inh ->
- pairWriteCombInh inh op $
+instance Selectable (WriteGrammar sN) where
+ branch lr l r = WriteGrammar $ \inh ->
+ pairWriteGrammarInh inh op $
Just "branch " <>
- unWriteComb lr inh <> Just " " <>
- unWriteComb l inh <> Just " " <>
- unWriteComb r inh
+ unWriteGrammar lr inh <> Just " " <>
+ unWriteGrammar l inh <> Just " " <>
+ unWriteGrammar r inh
where
op = infixN 9
-instance Matchable WriteComb where
- conditional a _ps bs d = WriteComb $ \inh ->
- pairWriteCombInh inh op $
+instance Matchable (WriteGrammar sN) where
+ conditional a _ps bs d = WriteGrammar $ \inh ->
+ pairWriteGrammarInh inh op $
Just "conditional " <>
- unWriteComb a inh <>
+ unWriteGrammar a inh <>
Just " [" <>
Just (mconcat (List.intersperse ", " $
catMaybes $ (Pre.<$> bs) $ \x ->
- unWriteComb x inh{writeCombInh_op=(infixN 0, SideL)})) <>
+ unWriteGrammar x inh{writeGrammarInh_op=(infixN 0, SideL)})) <>
Just "] " <>
- unWriteComb d inh
+ unWriteGrammar d inh
where
op = infixN 9
-instance Lookable WriteComb where
- look x = WriteComb $ \inh ->
- pairWriteCombInh inh op $
- Just "look " <> unWriteComb x inh
+instance Lookable (WriteGrammar sN) where
+ look x = WriteGrammar $ \inh ->
+ pairWriteGrammarInh inh op $
+ Just "look " <> unWriteGrammar x inh
where op = infixN 9
- negLook x = WriteComb $ \inh ->
- pairWriteCombInh inh op $
- Just "negLook " <> unWriteComb x inh
+ negLook x = WriteGrammar $ \inh ->
+ pairWriteGrammarInh inh op $
+ Just "negLook " <> unWriteGrammar x inh
where op = infixN 9
eof = "eof"
-instance Foldable WriteComb where
- chainPre f x = WriteComb $ \inh ->
- pairWriteCombInh inh op $
+instance Foldable (WriteGrammar sN) where
+ chainPre f x = WriteGrammar $ \inh ->
+ pairWriteGrammarInh inh op $
Just "chainPre " <>
- unWriteComb f inh <> Just " " <>
- unWriteComb x inh
+ unWriteGrammar f inh <> Just " " <>
+ unWriteGrammar x inh
where op = infixN 9
- chainPost f x = WriteComb $ \inh ->
- pairWriteCombInh inh op $
+ chainPost f x = WriteGrammar $ \inh ->
+ pairWriteGrammarInh inh op $
Just "chainPost " <>
- unWriteComb f inh <> Just " " <>
- unWriteComb x inh
+ unWriteGrammar f inh <> Just " " <>
+ unWriteGrammar x inh
where op = infixN 9
sourcephile / git / haskell / symantic-parser.git / blobdiff