src/Symantic/Parser/Grammar/Write.hs

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