src/Symantic/Parser/Grammar/Write.hs

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