{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveLift #-} module Symantic.Parser.Grammar.Write where import Control.Monad (Monad(..)) import Data.Bool (Bool(..)) import Data.Function (($), (.)) import Data.Maybe (Maybe(..), fromMaybe, catMaybes) import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) import Data.String (IsString(..)) import Language.Haskell.TH.HideName import Text.Show (Show(..)) import qualified Data.Functor as Functor import qualified Data.HashMap.Strict as HM import qualified Data.List as List import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB import Control.DeepSeq (NFData(..)) import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH import Prelude (undefined) import Debug.Trace import Symantic.Semantics.SharingObserver import Symantic.Semantics.Viewer.Fixity import Symantic.Parser.Grammar.Combinators import Symantic.Parser.Grammar.SharingObserver -- * Type 'WriteGrammar' newtype WriteGrammar (showName::Bool) a = WriteGrammar { unWriteGrammar :: WriteGrammarEnv -> Maybe TLB.Builder } deriving (NFData) instance IsString (WriteGrammar sN a) where fromString s = WriteGrammar $ \_env -> if List.null s then Nothing else Just (fromString s) -- ** Type 'WriteGrammarEnv' data WriteGrammarEnv = WriteGrammarEnv { writeGrammarEnvIndent :: TLB.Builder , writeGrammarEnvOpFixity :: Infix , writeGrammarEnvOpSide :: Side , writeGrammarEnvPair :: Pair } deriving (Show) writeGrammar :: WriteGrammar sN a -> TL.Text writeGrammar (WriteGrammar go) = TLB.toLazyText $ fromMaybe "" $ go WriteGrammarEnv { writeGrammarEnvIndent = "\n" , writeGrammarEnvOpFixity = infixN0 , writeGrammarEnvOpSide = SideL , writeGrammarEnvPair = pairParen } instance Show (WriteGrammar sN a) where show = TL.unpack . writeGrammar writeGrammarPair :: Infix -> (WriteGrammarEnv -> Maybe TLB.Builder) -> WriteGrammar sN a writeGrammarPair op wg = WriteGrammar $ \env -> let newEnv = env{writeGrammarEnvOpFixity=op, writeGrammarEnvOpSide=SideL} in if isPairNeeded (writeGrammarEnvOpFixity env, writeGrammarEnvOpSide env) op then let (o,c) = writeGrammarEnvPair env in Just (fromString o)<> wg newEnv <> Just (fromString c) else wg newEnv instance CombAlternable (WriteGrammar sN) where alt exn x y = writeGrammarPair (infixB SideL 3) $ \env -> unWriteGrammar x env { writeGrammarEnvOpSide = SideL , writeGrammarEnvPair = pairParen } <> Just (" |^"<>fromString (show exn)<>" ") <> unWriteGrammar y env { writeGrammarEnvOpSide = SideR , writeGrammarEnvPair = pairParen } throw exn = writeGrammarPair (infixN 9) $ \env -> Just ("throw "<>fromString (show exn)) empty = "empty" try x = writeGrammarPair (infixN 9) $ \env -> Just "try " <> unWriteGrammar x env instance CombApplicable (WriteGrammar sN) where pure _ = WriteGrammar $ return Nothing{-TODO: print?-} -- pure _ = "pure" x <*> y = writeGrammarPair (infixB SideL 4) $ \env -> let env' side = env { writeGrammarEnvPair = pairParen } in case unWriteGrammar x (env' SideL) of Nothing -> unWriteGrammar y (env' SideR) Just xText -> case unWriteGrammar y (env' SideR) of Nothing -> Just xText Just _yText -> unWriteGrammar x env{writeGrammarEnvOpSide = SideL} <> Just " " <> unWriteGrammar y env{writeGrammarEnvOpSide = SideR} instance CombFoldable (WriteGrammar sN) where chainPre f x = writeGrammarPair (infixN 9) $ \env -> Just "chainPre " <> unWriteGrammar f env <> Just " " <> unWriteGrammar x env chainPost f x = writeGrammarPair (infixN 9) $ \env -> Just "chainPost " <> unWriteGrammar f env <> Just " " <> unWriteGrammar x env instance ( Show letName , HideName letName , HideableName sN ) => Referenceable letName (WriteGrammar sN) where ref isRec name = writeGrammarPair (infixN 9) $ \env -> Just (if isRec then "rec " else "ref ") <> Just (fromString (show (hideableName @sN name))) instance ( Show letName , HideName letName , HideableName sN ) => Letsable letName (WriteGrammar sN) where lets defs x = writeGrammarPair (infixN 9) $ \env -> Just "let " <> HM.foldMapWithKey (\name (SomeLet val) -> Just (fromString (show (hideableName @sN name))) <> unWriteGrammar val env) defs <> unWriteGrammar x env instance CombLookable (WriteGrammar sN) where look x = writeGrammarPair (infixN 9) $ \env -> Just "look " <> unWriteGrammar x env negLook x = writeGrammarPair (infixN 9) $ \env -> Just "negLook " <> unWriteGrammar x env eof = "eof" instance CombMatchable (WriteGrammar sN) where conditional a bs d = writeGrammarPair (infixN 9) $ \env -> Just "conditional " <> unWriteGrammar a env <> unWriteGrammar d env <> Just " [" <> Just (mconcat (List.intersperse ", " $ catMaybes $ (Functor.<$> bs) $ \(p{-TODO: print?-}, b) -> unWriteGrammar b env { writeGrammarEnvOpFixity = infixN 0 , writeGrammarEnvOpSide = SideL })) <> Just "] " instance CombSatisfiable tok (WriteGrammar sN) where satisfy p = writeGrammarPair (infixN 9) $ \env -> Just "satisfy " <> Just (fromString (showsPrec 10 p "")) instance CombSelectable (WriteGrammar sN) where branch lr l r = writeGrammarPair (infixN 9) $ \env -> Just "branch " <> unWriteGrammar lr env <> Just " " <> unWriteGrammar l env <> Just " " <> unWriteGrammar r env instance CombRegisterableUnscoped (WriteGrammar sN) where newUnscoped r x y = writeGrammarPair (infixN 9) $ \env -> Just "newUnscoped " <> Just (fromString (show r)) <> unWriteGrammar x env <> Just " " <> unWriteGrammar y env getUnscoped r = writeGrammarPair (infixN 9) $ \env -> Just "getUnscoped " <> Just (fromString (show r)) putUnscoped r x = writeGrammarPair (infixN 9) $ \env -> Just "putUnscoped " <> Just (fromString (show r)) <> unWriteGrammar x env instance CombRegisterable (WriteGrammar sN) where new x f = undefined get = undefined put = undefined -- FIXME