src/Symantic/Parser/Grammar/Write.hs

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