src/Symantic/Parser/Grammar/Write.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Symantic.Parser.Grammar.Write where
   3
   4 import Data.Bool
   5 import Data.Function (($))
   6 import qualified Data.Functor as Pre
   7 import Control.Monad (Monad(..))
   8 import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
   9 import Data.String (IsString(..))
  10 import Data.Semigroup (Semigroup(..))
  11 import Data.Monoid (Monoid(..))
  12 import Symantic.Base.Univariant
  13 import Symantic.Parser.Grammar.Combinators
  14 import Symantic.Parser.Grammar.Observations
  15 import Text.Show (Show(..))
  16 import qualified Data.List as List
  17 import qualified Control.Monad.Trans.Class as MT
  18 import qualified Control.Monad.Trans.Maybe as MT
  19 import qualified Control.Monad.Trans.Reader as MT
  20 import qualified Data.Text.Lazy as TL
  21 import qualified Data.Text.Lazy.Builder as TLB
  22
  23 import Symantic.Base.Fixity
  24
  25 -- * Type 'GramWrite'
  26 newtype GramWrite a = GramWrite { unGramWrite :: GramWriteInh -> Maybe TLB.Builder }
  27
  28 instance IsString (GramWrite a) where
  29   fromString s = GramWrite $ \_inh ->
  30     if List.null s then Nothing
  31     else Just (fromString s)
  32
  33 -- ** Type 'GramWriteInh'
  34 data GramWriteInh
  35  =   GramWriteInh
  36  {   gramWriteInh_indent :: TLB.Builder
  37  ,   gramWriteInh_op :: (Infix, Side)
  38  ,   gramWriteInh_pair :: Pair
  39  }
  40
  41 emptyGramWriteInh :: GramWriteInh
  42 emptyGramWriteInh = GramWriteInh
  43  { gramWriteInh_indent = "\n"
  44  , gramWriteInh_op = (infixN0, SideL)
  45  , gramWriteInh_pair = pairParen
  46  }
  47
  48 gramWrite :: GramWrite a -> TL.Text
  49 gramWrite (GramWrite r) = TLB.toLazyText $ fromMaybe "" $ r emptyGramWriteInh
  50
  51 pairGramWriteInh ::
  52  Semigroup s => IsString s =>
  53  GramWriteInh -> Infix -> Maybe s -> Maybe s
  54 pairGramWriteInh inh op s =
  55   if isPairNeeded (gramWriteInh_op inh) op
  56   then Just (fromString o<>" ")<>s<>Just (" "<>fromString c)
  57   else s
  58   where (o,c) = gramWriteInh_pair inh
  59
  60 instance Sharable GramWrite where
  61   def refName x = GramWrite $ \inh ->
  62     pairGramWriteInh inh op $
  63       Just "def "
  64       <> Just (fromString (show refName))
  65       <> unGramWrite x inh
  66     where
  67     op = infixN 9
  68   ref refRec refName = GramWrite $ \inh ->
  69     pairGramWriteInh inh op $
  70       Just "ref " <>
  71       (if refRec then Just "rec " else Nothing) <>
  72       Just (fromString (show refName))
  73     where
  74     op = infixN 9
  75 instance Applicable GramWrite where
  76   pure _ = GramWrite $ return Nothing
  77   -- pure _ = "pure"
  78   GramWrite x <*> GramWrite y = GramWrite $ \inh ->
  79     let inh' side = inh
  80          { gramWriteInh_op = (op, side)
  81          , gramWriteInh_pair = pairParen
  82          } in
  83     case x (inh' SideL) of
  84      Nothing -> y (inh' SideR)
  85      Just xt ->
  86       case y (inh' SideR) of
  87        Nothing -> Just xt
  88        Just yt ->
  89         pairGramWriteInh inh op $
  90           Just $ xt <> ", " <> yt
  91     where
  92     op = infixN 1
  93 instance Alternable GramWrite where
  94   empty = "empty"
  95   try x = GramWrite $ \inh ->
  96     pairGramWriteInh inh op $
  97       Just "try " <> unGramWrite x inh
  98     where
  99     op = infixN 9
 100   x <|> y = GramWrite $ \inh ->
 101     pairGramWriteInh inh op $
 102     unGramWrite x inh
 103      { gramWriteInh_op = (op, SideL)
 104      , gramWriteInh_pair = pairParen
 105      } <>
 106     Just " | " <>
 107     unGramWrite y inh
 108      { gramWriteInh_op = (op, SideR)
 109      , gramWriteInh_pair = pairParen
 110      }
 111     where op = infixB SideL 3
 112 instance Charable GramWrite where
 113   satisfy _f = "sat"
 114 instance Selectable GramWrite where
 115   branch lr l r = GramWrite $ \inh ->
 116     pairGramWriteInh inh op $
 117       Just "branch " <>
 118       unGramWrite lr inh <> Just " " <>
 119       unGramWrite l inh <> Just " " <>
 120       unGramWrite r inh
 121     where
 122     op = infixN 9
 123 instance Matchable GramWrite where
 124   conditional _cs bs a b = GramWrite $ \inh ->
 125     pairGramWriteInh inh op $
 126       Just "conditional " <>
 127       Just "[" <>
 128       Just (mconcat (List.intersperse ", " $
 129       catMaybes $ (Pre.<$> bs) $ \x ->
 130         unGramWrite x inh{gramWriteInh_op=(infixN 0, SideL)})) <>
 131       Just "] " <>
 132       unGramWrite a inh <> Just " " <>
 133       unGramWrite b inh
 134     where
 135     op = infixN 9
 136 instance Lookable GramWrite where
 137   look x = GramWrite $ \inh ->
 138     pairGramWriteInh inh op $
 139       Just "look " <> unGramWrite x inh
 140     where op = infixN 9
 141   negLook x = GramWrite $ \inh ->
 142     pairGramWriteInh inh op $
 143       Just "negLook " <> unGramWrite x inh
 144     where op = infixN 9
 145 instance Foldable GramWrite where
 146   chainPre f x = GramWrite $ \inh ->
 147     pairGramWriteInh inh op $
 148       Just "chainPre " <>
 149       unGramWrite f inh <> Just " " <>
 150       unGramWrite x inh
 151     where op = infixN 9
 152   chainPost f x = GramWrite $ \inh ->
 153     pairGramWriteInh inh op $
 154       Just "chainPost " <>
 155       unGramWrite f inh <> Just " " <>
 156       unGramWrite x inh
 157     where op = infixN 9