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.ObserveSharing
  19 import Symantic.Fixity
  20 import Symantic.Parser.Grammar.Combinators
  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{-TODO: print?-}
  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   Referenceable letName (WriteGrammar sN) where
 119   ref isRec name = WriteGrammar $ \inh ->
 120     pairWriteGrammarInh inh op $
 121       Just (if isRec then "rec " else "ref ") <>
 122       Just (fromString (showLetName @sN name))
 123     where
 124     op = infixN 9
 125 instance
 126   ShowLetName sN letName =>
 127   Letsable letName (WriteGrammar sN) where
 128   lets defs x = WriteGrammar $ \inh ->
 129     pairWriteGrammarInh inh op $
 130       Just "let "
 131       <> HM.foldMapWithKey
 132         (\name (SomeLet val) ->
 133           Just (fromString (showLetName @sN name))
 134           <> unWriteGrammar val inh)
 135         defs
 136       <> unWriteGrammar x inh
 137     where
 138     op = infixN 9
 139 instance CombLookable (WriteGrammar sN) where
 140   look x = WriteGrammar $ \inh ->
 141     pairWriteGrammarInh inh op $
 142       Just "look " <> unWriteGrammar x inh
 143     where op = infixN 9
 144   negLook x = WriteGrammar $ \inh ->
 145     pairWriteGrammarInh inh op $
 146       Just "negLook " <> unWriteGrammar x inh
 147     where op = infixN 9
 148   eof = "eof"
 149 instance CombMatchable (WriteGrammar sN) where
 150   conditional a bs d = WriteGrammar $ \inh ->
 151     pairWriteGrammarInh inh op $
 152       Just "conditional " <>
 153       unWriteGrammar a inh <>
 154       unWriteGrammar d inh <>
 155       Just " [" <>
 156       Just (mconcat (List.intersperse ", " $
 157       catMaybes $ (Functor.<$> bs) $ \(p{-TODO: print?-}, b) ->
 158         unWriteGrammar b inh{writeGrammarInh_op=(infixN 0, SideL)})) <>
 159       Just "] "
 160     where
 161     op = infixN 9
 162 instance CombSatisfiable tok (WriteGrammar sN) where
 163   satisfyOrFail _fs _f = "satisfy"
 164 instance CombSelectable (WriteGrammar sN) where
 165   branch lr l r = WriteGrammar $ \inh ->
 166     pairWriteGrammarInh inh op $
 167       Just "branch " <>
 168       unWriteGrammar lr inh <> Just " " <>
 169       unWriteGrammar l inh <> Just " " <>
 170       unWriteGrammar r inh
 171     where
 172     op = infixN 9