{-# LANGUAGE OverloadedStrings #-} module Symantic.Parser.Grammar.Write where 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 qualified Data.Text.Lazy.Builder as TLB import Symantic.Univariant.Letable import Symantic.Parser.Grammar.Combinators import Symantic.Parser.Grammar.Fixity -- * Type 'WriteComb' newtype WriteComb a = WriteComb { unWriteComb :: WriteCombInh -> Maybe TLB.Builder } instance IsString (WriteComb a) where fromString s = WriteComb $ \_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 } emptyWriteCombInh :: WriteCombInh emptyWriteCombInh = WriteCombInh { writeCombInh_indent = "\n" , writeCombInh_op = (infixN0, SideL) , writeCombInh_pair = pairParen } writeComb :: WriteComb a -> TL.Text writeComb (WriteComb r) = TLB.toLazyText $ fromMaybe "" $ r emptyWriteCombInh pairWriteCombInh :: Semigroup s => IsString s => WriteCombInh -> Infix -> Maybe s -> Maybe s pairWriteCombInh inh op s = if isPairNeeded (writeCombInh_op inh) op then Just (fromString o<>" ")<>s<>Just (" "<>fromString c) else s where (o,c) = writeCombInh_pair inh instance Show letName => Letable letName WriteComb where def name x = WriteComb $ \inh -> pairWriteCombInh inh op $ Just "def " <> Just (fromString (show name)) <> unWriteComb x inh where op = infixN 9 ref rec name = WriteComb $ \inh -> pairWriteCombInh inh op $ Just (if rec then "rec " else "ref ") <> Just (fromString (show name)) where op = infixN 9 instance Applicable WriteComb where pure _ = WriteComb $ return Nothing -- pure _ = "pure" WriteComb x <*> WriteComb y = WriteComb $ \inh -> let inh' side = inh { writeCombInh_op = (op, side) , writeCombInh_pair = pairParen } in case x (inh' SideL) of Nothing -> y (inh' SideR) Just xt -> case y (inh' SideR) of Nothing -> Just xt Just yt -> pairWriteCombInh inh op $ Just $ xt <> ", " <> yt where op = infixN 1 instance Alternable WriteComb where empty = "empty" try x = WriteComb $ \inh -> pairWriteCombInh inh op $ Just "try " <> unWriteComb x inh where op = infixN 9 x <|> y = WriteComb $ \inh -> pairWriteCombInh inh op $ unWriteComb x inh { writeCombInh_op = (op, SideL) , writeCombInh_pair = pairParen } <> Just " | " <> unWriteComb y inh { writeCombInh_op = (op, SideR) , writeCombInh_pair = pairParen } where op = infixB SideL 3 instance Satisfiable WriteComb tok where satisfy _es _f = "satisfy" instance Selectable WriteComb where branch lr l r = WriteComb $ \inh -> pairWriteCombInh inh op $ Just "branch " <> unWriteComb lr inh <> Just " " <> unWriteComb l inh <> Just " " <> unWriteComb r inh where op = infixN 9 instance Matchable WriteComb where conditional a _ps bs d = WriteComb $ \inh -> pairWriteCombInh inh op $ Just "conditional " <> unWriteComb a inh <> Just " [" <> Just (mconcat (List.intersperse ", " $ catMaybes $ (Pre.<$> bs) $ \x -> unWriteComb x inh{writeCombInh_op=(infixN 0, SideL)})) <> Just "] " <> unWriteComb d inh where op = infixN 9 instance Lookable WriteComb where look x = WriteComb $ \inh -> pairWriteCombInh inh op $ Just "look " <> unWriteComb x inh where op = infixN 9 negLook x = WriteComb $ \inh -> pairWriteCombInh inh op $ Just "negLook " <> unWriteComb x inh where op = infixN 9 eof = "eof" instance Foldable WriteComb where chainPre f x = WriteComb $ \inh -> pairWriteCombInh inh op $ Just "chainPre " <> unWriteComb f inh <> Just " " <> unWriteComb x inh where op = infixN 9 chainPost f x = WriteComb $ \inh -> pairWriteCombInh inh op $ Just "chainPost " <> unWriteComb f inh <> Just " " <> unWriteComb x inh where op = infixN 9