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 Letable GramWrite where
  61   let_ letRec letName = GramWrite $ \inh ->
  62     pairGramWriteInh inh op $
  63       Just "let " <>
  64       (if letRec then Just "rec " else Nothing) <>
  65       Just (fromString (show letName))
  66     where
  67     op = infixN 9
  68 instance Applicable GramWrite where
  69   pure _ = GramWrite $ return Nothing
  70   -- pure _ = "pure"
  71   GramWrite x <*> GramWrite y = GramWrite $ \inh ->
  72     let inh' side = inh
  73          { gramWriteInh_op = (op, side)
  74          , gramWriteInh_pair = pairParen
  75          } in
  76     case x (inh' SideL) of
  77      Nothing -> y (inh' SideR)
  78      Just xt ->
  79       case y (inh' SideR) of
  80        Nothing -> Just xt
  81        Just yt ->
  82         pairGramWriteInh inh op $
  83           Just $ xt <> ", " <> yt
  84     where
  85     op = infixN 1
  86 instance Alternable GramWrite where
  87   empty = "empty"
  88   try x = GramWrite $ \inh ->
  89     pairGramWriteInh inh op $
  90       Just "try " <> unGramWrite x inh
  91     where
  92     op = infixN 9
  93   x <|> y = GramWrite $ \inh ->
  94     pairGramWriteInh inh op $
  95     unGramWrite x inh
  96      { gramWriteInh_op = (op, SideL)
  97      , gramWriteInh_pair = pairParen
  98      } <>
  99     Just " | " <>
 100     unGramWrite y inh
 101      { gramWriteInh_op = (op, SideR)
 102      , gramWriteInh_pair = pairParen
 103      }
 104     where op = infixB SideL 3
 105 instance Charable GramWrite where
 106   satisfy _f = "sat"
 107 instance Selectable GramWrite where
 108   branch lr l r = GramWrite $ \inh ->
 109     pairGramWriteInh inh op $
 110       Just "branch " <>
 111       unGramWrite lr inh <> Just " " <>
 112       unGramWrite l inh <> Just " " <>
 113       unGramWrite r inh
 114     where
 115     op = infixN 9
 116 instance Matchable GramWrite where
 117   conditional _cs bs a b = GramWrite $ \inh ->
 118     pairGramWriteInh inh op $
 119       Just "conditional " <>
 120       Just "[" <>
 121       Just (mconcat (List.intersperse ", " $
 122       catMaybes $ (Pre.<$> bs) $ \x ->
 123         unGramWrite x inh{gramWriteInh_op=(infixN 0, SideL)})) <>
 124       Just "] " <>
 125       unGramWrite a inh <> Just " " <>
 126       unGramWrite b inh
 127     where
 128     op = infixN 9
 129 instance Lookable GramWrite where
 130   look x = GramWrite $ \inh ->
 131     pairGramWriteInh inh op $
 132       Just "look " <> unGramWrite x inh
 133     where op = infixN 9
 134   negLook x = GramWrite $ \inh ->
 135     pairGramWriteInh inh op $
 136       Just "negLook " <> unGramWrite x inh
 137     where op = infixN 9
 138 instance Foldable GramWrite where
 139   chainPre f x = GramWrite $ \inh ->
 140     pairGramWriteInh inh op $
 141       Just "chainPre " <>
 142       unGramWrite f inh <> Just " " <>
 143       unGramWrite x inh
 144     where op = infixN 9
 145   chainPost f x = GramWrite $ \inh ->
 146     pairGramWriteInh inh op $
 147       Just "chainPost " <>
 148       unGramWrite f inh <> Just " " <>
 149       unGramWrite x inh
 150     where op = infixN 9