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 Text.Show (Show(..))
  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.Typed.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 CombAlternable (WriteGrammar sN) where
  61   alt exn x y = WriteGrammar $ \inh ->
  62     pairWriteGrammarInh inh op $
  63     unWriteGrammar x inh
  64      { writeGrammarInh_op = (op, SideL)
  65      , writeGrammarInh_pair = pairParen
  66      } <>
  67     Just (" |^"<>fromString (show exn)<>" ") <>
  68     unWriteGrammar y inh
  69      { writeGrammarInh_op = (op, SideR)
  70      , writeGrammarInh_pair = pairParen
  71      }
  72     where op = infixB SideL 3
  73   throw exn = WriteGrammar $ \inh ->
  74     pairWriteGrammarInh inh op $
  75       Just ("throw "<>fromString (show exn))
  76     where
  77     op = infixN 9
  78   failure _sf = "failure"
  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 instance CombApplicable (WriteGrammar sN) where
  86   pure _ = WriteGrammar $ return Nothing
  87   -- pure _ = "pure"
  88   WriteGrammar x <*> WriteGrammar y = WriteGrammar $ \inh ->
  89     let inh' side = inh
  90          { writeGrammarInh_op = (op, side)
  91          , writeGrammarInh_pair = pairParen
  92          } in
  93     case x (inh' SideL) of
  94      Nothing -> y (inh' SideR)
  95      Just xt ->
  96       case y (inh' SideR) of
  97        Nothing -> Just xt
  98        Just yt ->
  99         pairWriteGrammarInh inh op $
 100           Just $ xt <> ", " <> yt
 101     where
 102     op = infixN 1
 103 instance CombFoldable (WriteGrammar sN) where
 104   chainPre f x = WriteGrammar $ \inh ->
 105     pairWriteGrammarInh inh op $
 106       Just "chainPre " <>
 107       unWriteGrammar f inh <> Just " " <>
 108       unWriteGrammar x inh
 109     where op = infixN 9
 110   chainPost f x = WriteGrammar $ \inh ->
 111     pairWriteGrammarInh inh op $
 112       Just "chainPost " <>
 113       unWriteGrammar f inh <> Just " " <>
 114       unWriteGrammar x inh
 115     where op = infixN 9
 116 instance
 117   ShowLetName sN letName =>
 118   Letable letName (WriteGrammar sN) where
 119   shareable name x = WriteGrammar $ \inh ->
 120     pairWriteGrammarInh inh op $
 121       Just "shareable "
 122       <> Just (fromString (showLetName @sN name))
 123       <> unWriteGrammar x inh
 124     where
 125     op = infixN 9
 126   ref rec name = WriteGrammar $ \inh ->
 127     pairWriteGrammarInh inh op $
 128       Just (if rec then "rec " else "ref ") <>
 129       Just (fromString (showLetName @sN name))
 130     where
 131     op = infixN 9
 132 instance
 133   ShowLetName sN letName =>
 134   Letsable letName (WriteGrammar sN) where
 135   lets defs x = WriteGrammar $ \inh ->
 136     pairWriteGrammarInh inh op $
 137       Just "let "
 138       <> HM.foldMapWithKey
 139         (\name (SomeLet val) ->
 140           Just (fromString (showLetName @sN name))
 141           <> unWriteGrammar val inh)
 142         defs
 143       <> unWriteGrammar x inh
 144     where
 145     op = infixN 9
 146 instance CombLookable (WriteGrammar sN) where
 147   look x = WriteGrammar $ \inh ->
 148     pairWriteGrammarInh inh op $
 149       Just "look " <> unWriteGrammar x inh
 150     where op = infixN 9
 151   negLook x = WriteGrammar $ \inh ->
 152     pairWriteGrammarInh inh op $
 153       Just "negLook " <> unWriteGrammar x inh
 154     where op = infixN 9
 155   eof = "eof"
 156 instance CombMatchable (WriteGrammar sN) where
 157   conditional a _ps bs d = WriteGrammar $ \inh ->
 158     pairWriteGrammarInh inh op $
 159       Just "conditional " <>
 160       unWriteGrammar a inh <>
 161       Just " [" <>
 162       Just (mconcat (List.intersperse ", " $
 163       catMaybes $ (Functor.<$> bs) $ \x ->
 164         unWriteGrammar x inh{writeGrammarInh_op=(infixN 0, SideL)})) <>
 165       Just "] " <>
 166       unWriteGrammar d inh
 167     where
 168     op = infixN 9
 169 instance CombSatisfiable tok (WriteGrammar sN) where
 170   satisfyOrFail _fs _f = "satisfy"
 171 instance CombSelectable (WriteGrammar sN) where
 172   branch lr l r = WriteGrammar $ \inh ->
 173     pairWriteGrammarInh inh op $
 174       Just "branch " <>
 175       unWriteGrammar lr inh <> Just " " <>
 176       unWriteGrammar l inh <> Just " " <>
 177       unWriteGrammar r inh
 178     where
 179     op = infixN 9