src/Symantic/Parser/Grammar/Write.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Symantic.Parser.Grammar.Write where
   3
   4 import Data.Function (($))
   5 import qualified Data.Functor as Pre
   6 import Control.Monad (Monad(..))
   7 import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
   8 import Data.String (IsString(..))
   9 import Data.Semigroup (Semigroup(..))
  10 import Data.Monoid (Monoid(..))
  11 import Text.Show (Show(..))
  12 import qualified Data.List as List
  13 import qualified Data.Text.Lazy as TL
  14 import qualified Data.Text.Lazy.Builder as TLB
  15
  16 import Symantic.Base.Fixity
  17 import Symantic.Parser.Grammar.Combinators
  18 import Symantic.Parser.Grammar.ObserveSharing
  19
  20 -- * Type 'WriteGrammar'
  21 newtype WriteGrammar a = WriteGrammar { unWriteGrammar :: WriteGrammarInh -> Maybe TLB.Builder }
  22
  23 instance IsString (WriteGrammar a) where
  24   fromString s = WriteGrammar $ \_inh ->
  25     if List.null s then Nothing
  26     else Just (fromString s)
  27
  28 -- ** Type 'WriteGrammarInh'
  29 data WriteGrammarInh
  30  =   WriteGrammarInh
  31  {   writeGrammarInh_indent :: TLB.Builder
  32  ,   writeGrammarInh_op :: (Infix, Side)
  33  ,   writeGrammarInh_pair :: Pair
  34  }
  35
  36 emptyWriteGrammarInh :: WriteGrammarInh
  37 emptyWriteGrammarInh = WriteGrammarInh
  38  { writeGrammarInh_indent = "\n"
  39  , writeGrammarInh_op = (infixN0, SideL)
  40  , writeGrammarInh_pair = pairParen
  41  }
  42
  43 writeGrammar :: WriteGrammar a -> TL.Text
  44 writeGrammar (WriteGrammar r) = TLB.toLazyText $ fromMaybe "" $ r emptyWriteGrammarInh
  45
  46 pairWriteGrammarInh ::
  47  Semigroup s => IsString s =>
  48  WriteGrammarInh -> Infix -> Maybe s -> Maybe s
  49 pairWriteGrammarInh inh op s =
  50   if isPairNeeded (writeGrammarInh_op inh) op
  51   then Just (fromString o<>" ")<>s<>Just (" "<>fromString c)
  52   else s
  53   where (o,c) = writeGrammarInh_pair inh
  54
  55 instance Letable WriteGrammar where
  56   def name x = WriteGrammar $ \inh ->
  57     pairWriteGrammarInh inh op $
  58       Just "def "
  59       <> Just (fromString (show name))
  60       <> unWriteGrammar x inh
  61     where
  62     op = infixN 9
  63   ref rec name = WriteGrammar $ \inh ->
  64     pairWriteGrammarInh inh op $
  65       Just "ref " <>
  66       (if rec then Just "rec " else Nothing) <>
  67       Just (fromString (show name))
  68     where
  69     op = infixN 9
  70 instance Applicable WriteGrammar where
  71   pure _ = WriteGrammar $ return Nothing
  72   -- pure _ = "pure"
  73   WriteGrammar x <*> WriteGrammar y = WriteGrammar $ \inh ->
  74     let inh' side = inh
  75          { writeGrammarInh_op = (op, side)
  76          , writeGrammarInh_pair = pairParen
  77          } in
  78     case x (inh' SideL) of
  79      Nothing -> y (inh' SideR)
  80      Just xt ->
  81       case y (inh' SideR) of
  82        Nothing -> Just xt
  83        Just yt ->
  84         pairWriteGrammarInh inh op $
  85           Just $ xt <> ", " <> yt
  86     where
  87     op = infixN 1
  88 instance Alternable WriteGrammar where
  89   empty = "empty"
  90   try x = WriteGrammar $ \inh ->
  91     pairWriteGrammarInh inh op $
  92       Just "try " <> unWriteGrammar x inh
  93     where
  94     op = infixN 9
  95   x <|> y = WriteGrammar $ \inh ->
  96     pairWriteGrammarInh inh op $
  97     unWriteGrammar x inh
  98      { writeGrammarInh_op = (op, SideL)
  99      , writeGrammarInh_pair = pairParen
 100      } <>
 101     Just " | " <>
 102     unWriteGrammar y inh
 103      { writeGrammarInh_op = (op, SideR)
 104      , writeGrammarInh_pair = pairParen
 105      }
 106     where op = infixB SideL 3
 107 instance Charable WriteGrammar where
 108   satisfy _f = "sat"
 109 instance Selectable WriteGrammar where
 110   branch lr l r = WriteGrammar $ \inh ->
 111     pairWriteGrammarInh inh op $
 112       Just "branch " <>
 113       unWriteGrammar lr inh <> Just " " <>
 114       unWriteGrammar l inh <> Just " " <>
 115       unWriteGrammar r inh
 116     where
 117     op = infixN 9
 118 instance Matchable WriteGrammar where
 119   conditional _cs bs a b = WriteGrammar $ \inh ->
 120     pairWriteGrammarInh inh op $
 121       Just "conditional " <>
 122       Just "[" <>
 123       Just (mconcat (List.intersperse ", " $
 124       catMaybes $ (Pre.<$> bs) $ \x ->
 125         unWriteGrammar x inh{writeGrammarInh_op=(infixN 0, SideL)})) <>
 126       Just "] " <>
 127       unWriteGrammar a inh <> Just " " <>
 128       unWriteGrammar b inh
 129     where
 130     op = infixN 9
 131 instance Lookable WriteGrammar where
 132   look x = WriteGrammar $ \inh ->
 133     pairWriteGrammarInh inh op $
 134       Just "look " <> unWriteGrammar x inh
 135     where op = infixN 9
 136   negLook x = WriteGrammar $ \inh ->
 137     pairWriteGrammarInh inh op $
 138       Just "negLook " <> unWriteGrammar x inh
 139     where op = infixN 9
 140 instance Foldable WriteGrammar where
 141   chainPre f x = WriteGrammar $ \inh ->
 142     pairWriteGrammarInh inh op $
 143       Just "chainPre " <>
 144       unWriteGrammar f inh <> Just " " <>
 145       unWriteGrammar x inh
 146     where op = infixN 9
 147   chainPost f x = WriteGrammar $ \inh ->
 148     pairWriteGrammarInh inh op $
 149       Just "chainPost " <>
 150       unWriteGrammar f inh <> Just " " <>
 151       unWriteGrammar x inh
 152     where op = infixN 9