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