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.List as List
  13 import qualified Data.Text.Lazy as TL
  14 import qualified Data.Text.Lazy.Builder as TLB
  15
  16 import Symantic.Univariant.Letable
  17 import Symantic.Parser.Grammar.Combinators
  18 import Symantic.Parser.Grammar.Fixity
  19
  20 -- * Type 'WriteGrammar'
  21 newtype WriteGrammar (showName::Bool) a = WriteGrammar { unWriteGrammar :: WriteGrammarInh -> Maybe TLB.Builder }
  22
  23 instance IsString (WriteGrammar sN 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 sN 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
  56   ShowLetName sN letName =>
  57   Letable letName (WriteGrammar sN) where
  58   def name x = WriteGrammar $ \inh ->
  59     pairWriteGrammarInh inh op $
  60       Just "def "
  61       <> Just (fromString (showLetName @sN name))
  62       <> unWriteGrammar x inh
  63     where
  64     op = infixN 9
  65   ref rec name = WriteGrammar $ \inh ->
  66     pairWriteGrammarInh inh op $
  67       Just (if rec then "rec " else "ref ") <>
  68       Just (fromString (showLetName @sN name))
  69     where
  70     op = infixN 9
  71 instance Applicable (WriteGrammar sN) where
  72   pure _ = WriteGrammar $ return Nothing
  73   -- pure _ = "pure"
  74   WriteGrammar x <*> WriteGrammar y = WriteGrammar $ \inh ->
  75     let inh' side = inh
  76          { writeGrammarInh_op = (op, side)
  77          , writeGrammarInh_pair = pairParen
  78          } in
  79     case x (inh' SideL) of
  80      Nothing -> y (inh' SideR)
  81      Just xt ->
  82       case y (inh' SideR) of
  83        Nothing -> Just xt
  84        Just yt ->
  85         pairWriteGrammarInh inh op $
  86           Just $ xt <> ", " <> yt
  87     where
  88     op = infixN 1
  89 instance Alternable (WriteGrammar sN) where
  90   empty = "empty"
  91   try x = WriteGrammar $ \inh ->
  92     pairWriteGrammarInh inh op $
  93       Just "try " <> unWriteGrammar x inh
  94     where
  95     op = infixN 9
  96   x <|> y = WriteGrammar $ \inh ->
  97     pairWriteGrammarInh inh op $
  98     unWriteGrammar x inh
  99      { writeGrammarInh_op = (op, SideL)
 100      , writeGrammarInh_pair = pairParen
 101      } <>
 102     Just " | " <>
 103     unWriteGrammar y inh
 104      { writeGrammarInh_op = (op, SideR)
 105      , writeGrammarInh_pair = pairParen
 106      }
 107     where op = infixB SideL 3
 108 instance Satisfiable tok (WriteGrammar sN) where
 109   satisfy _es _f = "satisfy"
 110 instance Selectable (WriteGrammar sN) where
 111   branch lr l r = WriteGrammar $ \inh ->
 112     pairWriteGrammarInh inh op $
 113       Just "branch " <>
 114       unWriteGrammar lr inh <> Just " " <>
 115       unWriteGrammar l inh <> Just " " <>
 116       unWriteGrammar r inh
 117     where
 118     op = infixN 9
 119 instance Matchable (WriteGrammar sN) where
 120   conditional a _ps bs d = WriteGrammar $ \inh ->
 121     pairWriteGrammarInh inh op $
 122       Just "conditional " <>
 123       unWriteGrammar a inh <>
 124       Just " [" <>
 125       Just (mconcat (List.intersperse ", " $
 126       catMaybes $ (Pre.<$> bs) $ \x ->
 127         unWriteGrammar x inh{writeGrammarInh_op=(infixN 0, SideL)})) <>
 128       Just "] " <>
 129       unWriteGrammar d inh
 130     where
 131     op = infixN 9
 132 instance Lookable (WriteGrammar sN) where
 133   look x = WriteGrammar $ \inh ->
 134     pairWriteGrammarInh inh op $
 135       Just "look " <> unWriteGrammar x inh
 136     where op = infixN 9
 137   negLook x = WriteGrammar $ \inh ->
 138     pairWriteGrammarInh inh op $
 139       Just "negLook " <> unWriteGrammar x inh
 140     where op = infixN 9
 141   eof = "eof"
 142 instance Foldable (WriteGrammar sN) where
 143   chainPre f x = WriteGrammar $ \inh ->
 144     pairWriteGrammarInh inh op $
 145       Just "chainPre " <>
 146       unWriteGrammar f inh <> Just " " <>
 147       unWriteGrammar x inh
 148     where op = infixN 9
 149   chainPost f x = WriteGrammar $ \inh ->
 150     pairWriteGrammarInh inh op $
 151       Just "chainPost " <>
 152       unWriteGrammar f inh <> Just " " <>
 153       unWriteGrammar x inh
 154     where op = infixN 9