src/Symantic/Parser/Grammar/Write.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Symantic.Parser.Grammar.Write where
   3
   4 import Control.Monad (Monad(..))
   5 import Data.Function (($))
   6 import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
   7 import Data.Monoid (Monoid(..))
   8 import Data.Semigroup (Semigroup(..))
   9 import Data.String (IsString(..))
  10 import Text.Show (Show(..))
  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 'WriteComb'
  21 newtype WriteComb a = WriteComb { unWriteComb :: WriteCombInh -> Maybe TLB.Builder }
  22
  23 instance IsString (WriteComb a) where
  24   fromString s = WriteComb $ \_inh ->
  25     if List.null s then Nothing
  26     else Just (fromString s)
  27
  28 -- ** Type 'WriteCombInh'
  29 data WriteCombInh
  30  =   WriteCombInh
  31  {   writeCombInh_indent :: TLB.Builder
  32  ,   writeCombInh_op :: (Infix, Side)
  33  ,   writeCombInh_pair :: Pair
  34  }
  35
  36 emptyWriteCombInh :: WriteCombInh
  37 emptyWriteCombInh = WriteCombInh
  38  { writeCombInh_indent = "\n"
  39  , writeCombInh_op = (infixN0, SideL)
  40  , writeCombInh_pair = pairParen
  41  }
  42
  43 writeComb :: WriteComb a -> TL.Text
  44 writeComb (WriteComb r) = TLB.toLazyText $ fromMaybe "" $ r emptyWriteCombInh
  45
  46 pairWriteCombInh ::
  47  Semigroup s => IsString s =>
  48  WriteCombInh -> Infix -> Maybe s -> Maybe s
  49 pairWriteCombInh inh op s =
  50   if isPairNeeded (writeCombInh_op inh) op
  51   then Just (fromString o<>" ")<>s<>Just (" "<>fromString c)
  52   else s
  53   where (o,c) = writeCombInh_pair inh
  54
  55 instance Show letName => Letable letName WriteComb where
  56   def name x = WriteComb $ \inh ->
  57     pairWriteCombInh inh op $
  58       Just "def "
  59       <> Just (fromString (show name))
  60       <> unWriteComb x inh
  61     where
  62     op = infixN 9
  63   ref rec name = WriteComb $ \inh ->
  64     pairWriteCombInh inh op $
  65       Just (if rec then "rec " else "ref ") <>
  66       Just (fromString (show name))
  67     where
  68     op = infixN 9
  69 instance Applicable WriteComb where
  70   pure _ = WriteComb $ return Nothing
  71   -- pure _ = "pure"
  72   WriteComb x <*> WriteComb y = WriteComb $ \inh ->
  73     let inh' side = inh
  74          { writeCombInh_op = (op, side)
  75          , writeCombInh_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         pairWriteCombInh inh op $
  84           Just $ xt <> ", " <> yt
  85     where
  86     op = infixN 1
  87 instance Alternable WriteComb where
  88   empty = "empty"
  89   try x = WriteComb $ \inh ->
  90     pairWriteCombInh inh op $
  91       Just "try " <> unWriteComb x inh
  92     where
  93     op = infixN 9
  94   x <|> y = WriteComb $ \inh ->
  95     pairWriteCombInh inh op $
  96     unWriteComb x inh
  97      { writeCombInh_op = (op, SideL)
  98      , writeCombInh_pair = pairParen
  99      } <>
 100     Just " | " <>
 101     unWriteComb y inh
 102      { writeCombInh_op = (op, SideR)
 103      , writeCombInh_pair = pairParen
 104      }
 105     where op = infixB SideL 3
 106 instance Satisfiable WriteComb tok where
 107   satisfy _es _f = "satisfy"
 108 instance Selectable WriteComb where
 109   branch lr l r = WriteComb $ \inh ->
 110     pairWriteCombInh inh op $
 111       Just "branch " <>
 112       unWriteComb lr inh <> Just " " <>
 113       unWriteComb l inh <> Just " " <>
 114       unWriteComb r inh
 115     where
 116     op = infixN 9
 117 instance Matchable WriteComb where
 118   conditional a _ps bs d = WriteComb $ \inh ->
 119     pairWriteCombInh inh op $
 120       Just "conditional " <>
 121       unWriteComb a inh <>
 122       Just " [" <>
 123       Just (mconcat (List.intersperse ", " $
 124       catMaybes $ (Pre.<$> bs) $ \x ->
 125         unWriteComb x inh{writeCombInh_op=(infixN 0, SideL)})) <>
 126       Just "] " <>
 127       unWriteComb d inh
 128     where
 129     op = infixN 9
 130 instance Lookable WriteComb where
 131   look x = WriteComb $ \inh ->
 132     pairWriteCombInh inh op $
 133       Just "look " <> unWriteComb x inh
 134     where op = infixN 9
 135   negLook x = WriteComb $ \inh ->
 136     pairWriteCombInh inh op $
 137       Just "negLook " <> unWriteComb x inh
 138     where op = infixN 9
 139   eof = "eof"
 140 instance Foldable WriteComb where
 141   chainPre f x = WriteComb $ \inh ->
 142     pairWriteCombInh inh op $
 143       Just "chainPre " <>
 144       unWriteComb f inh <> Just " " <>
 145       unWriteComb x inh
 146     where op = infixN 9
 147   chainPost f x = WriteComb $ \inh ->
 148     pairWriteCombInh inh op $
 149       Just "chainPost " <>
 150       unWriteComb f inh <> Just " " <>
 151       unWriteComb x inh
 152     where op = infixN 9