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.Bool (Bool(..))
   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 Language.Haskell.TH.HideName
  12 import Text.Show (Show(..))
  13 import qualified Data.Functor as Functor
  14 import qualified Data.HashMap.Strict as HM
  15 import qualified Data.List as List
  16 import qualified Data.Text.Lazy as TL
  17 import qualified Data.Text.Lazy.Builder as TLB
  18
  19 import Symantic.ObserveSharing
  20 import Symantic.Fixity
  21 import Symantic.Parser.Grammar.Combinators
  22
  23 -- * Type 'WriteGrammar'
  24 newtype WriteGrammar (showName::Bool) a = WriteGrammar { unWriteGrammar ::
  25   WriteGrammarInh -> Maybe TLB.Builder }
  26
  27 instance IsString (WriteGrammar sN a) where
  28   fromString s = WriteGrammar $ \_inh ->
  29     if List.null s then Nothing
  30     else Just (fromString s)
  31
  32 -- ** Type 'WriteGrammarInh'
  33 data WriteGrammarInh
  34  =   WriteGrammarInh
  35  {   writeGrammarInh_indent :: TLB.Builder
  36  ,   writeGrammarInh_op :: (Infix, Side)
  37  ,   writeGrammarInh_pair :: Pair
  38  }
  39
  40 emptyWriteGrammarInh :: WriteGrammarInh
  41 emptyWriteGrammarInh = WriteGrammarInh
  42  { writeGrammarInh_indent = "\n"
  43  , writeGrammarInh_op = (infixN0, SideL)
  44  , writeGrammarInh_pair = pairParen
  45  }
  46
  47 writeGrammar :: WriteGrammar sN a -> TL.Text
  48 writeGrammar (WriteGrammar go) =
  49   TLB.toLazyText $ fromMaybe "" $
  50   go emptyWriteGrammarInh
  51
  52 pairWriteGrammarInh ::
  53  Semigroup s => IsString s =>
  54  WriteGrammarInh -> Infix -> Maybe s -> Maybe s
  55 pairWriteGrammarInh inh op s =
  56   if isPairNeeded (writeGrammarInh_op inh) op
  57   then Just (fromString o<>" ")<>s<>Just (" "<>fromString c)
  58   else s
  59   where (o,c) = writeGrammarInh_pair inh
  60
  61 instance CombAlternable (WriteGrammar sN) where
  62   alt exn x y = WriteGrammar $ \inh ->
  63     pairWriteGrammarInh inh op $
  64     unWriteGrammar x inh
  65      { writeGrammarInh_op = (op, SideL)
  66      , writeGrammarInh_pair = pairParen
  67      } <>
  68     Just (" |^"<>fromString (show exn)<>" ") <>
  69     unWriteGrammar y inh
  70      { writeGrammarInh_op = (op, SideR)
  71      , writeGrammarInh_pair = pairParen
  72      }
  73     where op = infixB SideL 3
  74   throw exn = WriteGrammar $ \inh ->
  75     pairWriteGrammarInh inh op $
  76       Just ("throw "<>fromString (show exn))
  77     where
  78     op = infixN 9
  79   failure _sf = "failure"
  80   empty = "empty"
  81   try x = WriteGrammar $ \inh ->
  82     pairWriteGrammarInh inh op $
  83       Just "try " <> unWriteGrammar x inh
  84     where
  85     op = infixN 9
  86 instance CombApplicable (WriteGrammar sN) where
  87   pure _ = WriteGrammar $ return Nothing{-TODO: print?-}
  88   -- pure _ = "pure"
  89   WriteGrammar x <*> WriteGrammar y = WriteGrammar $ \inh ->
  90     let inh' side = inh
  91          { writeGrammarInh_op = (op, side)
  92          , writeGrammarInh_pair = pairParen
  93          } in
  94     case x (inh' SideL) of
  95      Nothing -> y (inh' SideR)
  96      Just xt ->
  97       case y (inh' SideR) of
  98        Nothing -> Just xt
  99        Just yt ->
 100         pairWriteGrammarInh inh op $
 101           Just $ xt <> ", " <> yt
 102     where
 103     op = infixN 1
 104 instance CombFoldable (WriteGrammar sN) where
 105   chainPre f x = WriteGrammar $ \inh ->
 106     pairWriteGrammarInh inh op $
 107       Just "chainPre " <>
 108       unWriteGrammar f inh <> Just " " <>
 109       unWriteGrammar x inh
 110     where op = infixN 9
 111   chainPost f x = WriteGrammar $ \inh ->
 112     pairWriteGrammarInh inh op $
 113       Just "chainPost " <>
 114       unWriteGrammar f inh <> Just " " <>
 115       unWriteGrammar x inh
 116     where op = infixN 9
 117 instance
 118   ( Show letName
 119   , HideName letName
 120   , HideableName sN
 121   ) => Referenceable letName (WriteGrammar sN) where
 122   ref isRec name = WriteGrammar $ \inh ->
 123     pairWriteGrammarInh inh op $
 124       Just (if isRec then "rec " else "ref ") <>
 125       Just (fromString (show (hideableName @sN name)))
 126     where
 127     op = infixN 9
 128 instance
 129   ( Show letName
 130   , HideName letName
 131   , HideableName sN
 132   ) => Letsable letName (WriteGrammar sN) where
 133   lets defs x = WriteGrammar $ \inh ->
 134     pairWriteGrammarInh inh op $
 135       Just "let "
 136       <> HM.foldMapWithKey
 137         (\name (SomeLet val) ->
 138           Just (fromString (show (hideableName @sN name)))
 139           <> unWriteGrammar val inh)
 140         defs
 141       <> unWriteGrammar x inh
 142     where
 143     op = infixN 9
 144 instance CombLookable (WriteGrammar sN) where
 145   look x = WriteGrammar $ \inh ->
 146     pairWriteGrammarInh inh op $
 147       Just "look " <> unWriteGrammar x inh
 148     where op = infixN 9
 149   negLook x = WriteGrammar $ \inh ->
 150     pairWriteGrammarInh inh op $
 151       Just "negLook " <> unWriteGrammar x inh
 152     where op = infixN 9
 153   eof = "eof"
 154 instance CombMatchable (WriteGrammar sN) where
 155   conditional a bs d = WriteGrammar $ \inh ->
 156     pairWriteGrammarInh inh op $
 157       Just "conditional " <>
 158       unWriteGrammar a inh <>
 159       unWriteGrammar d inh <>
 160       Just " [" <>
 161       Just (mconcat (List.intersperse ", " $
 162       catMaybes $ (Functor.<$> bs) $ \(p{-TODO: print?-}, b) ->
 163         unWriteGrammar b inh{writeGrammarInh_op=(infixN 0, SideL)})) <>
 164       Just "] "
 165     where
 166     op = infixN 9
 167 instance CombSatisfiable tok (WriteGrammar sN) where
 168   satisfyOrFail _fs _f = "satisfy"
 169 instance CombSelectable (WriteGrammar sN) where
 170   branch lr l r = WriteGrammar $ \inh ->
 171     pairWriteGrammarInh inh op $
 172       Just "branch " <>
 173       unWriteGrammar lr inh <> Just " " <>
 174       unWriteGrammar l inh <> Just " " <>
 175       unWriteGrammar r inh
 176     where
 177     op = infixN 9