content: {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE TemplateHaskell   #-}
  
  -- | Quasiquoters for easier generation of STG syntax trees.
  -- The 'stg' quoter is most convenient, I suggest you use it unless you have a
  -- reason not to.
  module Stg.Parser.QuasiQuoter (
  
      -- * Heuristic quasiquoter
      stg,
  
      -- * Specific syntax element quasiquoters
      program,
      binds,
      lambdaForm,
      expr,
      alts,
      nonDefaultAlts,
      algebraicAlt,
      primitiveAlt,
      defaultAlt,
      literal,
      primOp,
      atom,
  ) where
  
  
  
  import           Data.Either
  import           Data.Text                    (Text)
  import qualified Data.Text                    as T
  import           Data.String
  import           Language.Haskell.TH
  import           Language.Haskell.TH.Syntax (Lift(lift))
  import           Language.Haskell.TH.Quote
  import           Prettyprinter
  
  import           Stg.Language.Prettyprint
  import           Stg.Parser.Parser        (StgParser, parse)
  import qualified Stg.Parser.Parser        as Parser
  
  -- $setup
  -- >>> :set -XTemplateHaskell
  -- >>> :set -XQuasiQuotes
  
  
  
  defaultQuoter :: QuasiQuoter
  defaultQuoter = QuasiQuoter
      { quoteExp  = \_ -> fail "No STG expression quoter implemented"
      , quotePat  = \_ -> fail "No STG pattern quoter implemented"
      , quoteType = \_ -> fail "No STG type quoter implemented"
      , quoteDec  = \_ -> fail "No STG declaration quoter implemented" }
  
  -- | Heuristic quasiquoter for STG language elements.
  -- Tries a number of parsers, and will use the first successful one.
  --
  -- To gain more fine-grained control over what the input should be parsed to,
  -- use one of the non-heuristic quoters, such as 'stgProgram' or
  -- 'stgLambdaForm'. These will also give you much better error messages than
  -- merely "doesn't work".
  --
  -- >>> [stg| id = \x -> x |]
  -- Program (Binds [(Var "id",LambdaForm [] NoUpdate [Var "x"] (AppF (Var "x") []))])
  --
  -- >>> [stg| \x -> x |]
  -- LambdaForm [] NoUpdate [Var "x"] (AppF (Var "x") [])
  --
  -- >>> [stg| x |]
  -- AppF (Var "x") []
  stg :: QuasiQuoter
  stg = defaultQuoter { quoteExp = expQuoter }
    where
      expQuoter inputString =
          let input = T.pack inputString
              parses =
                  [ quoteAs "program"        Parser.program        input
                  , quoteAs "lambdaForm"     Parser.lambdaForm     input
                  , quoteAs "expr"           Parser.expr           input
                  , quoteAs "alts"           Parser.alts           input
                  , quoteAs "algebraicAlt"   Parser.algebraicAlt   input
                  , quoteAs "primitiveAlt"   Parser.primitiveAlt   input
                  , quoteAs "defaultAlt"     Parser.defaultAlt     input
                  , quoteAs "literal"        Parser.literal        input
                  , quoteAs "primOp"         Parser.primOp         input
                  , quoteAs "atom"           Parser.atom           input
                  , quoteAs "variable"       Parser.var            input
                  , quoteAs "constructor"    Parser.con            input ]
          in case partitionEithers parses of
              (_, ast:_) -> ast
              (errs, _) -> (fail . T.unpack . T.unlines)
                  ("No parse succeeded. Individual errors:" : errs)
  
      -- | Attempt to parse an input using a certain parser, and return the
      -- generated expression on success.
      quoteAs :: Lift ast => Text -> Parser.StgParser ast -> Text -> Either Text (Q Exp)
      quoteAs parserName parser input = fmap lift (case Parser.parse parser input of
          Left err -> Left (renderPlain ("  -" <+> fromString (T.unpack parserName) <> ":" <+> align err))
          Right r -> Right r )
  
  -- | Build a quasiquoter from a 'Parser'.
  stgQQ
      :: Lift ast
      => StgParser ast
      -> Text -- ^ Name of the parsed syntax element (for error reporting)
      -> QuasiQuoter
  stgQQ parser elementName = defaultQuoter { quoteExp  = expQuoter }
      where
      expQuoter input = case parse parser (T.pack input) of
          Left err  -> fail (T.unpack ("Invalid STG " <> elementName <> ":\n" <> renderPlain err))
          Right ast -> [| ast |]
  
  -- | Quasiquoter for 'Stg.Language.Program's.
  --
  -- >>> [program| id = \x -> x |]
  -- Program (Binds [(Var "id",LambdaForm [] NoUpdate [Var "x"] (AppF (Var "x") []))])
  program :: QuasiQuoter
  program = stgQQ Parser.program "program"
  
  -- | Quasiquoter for 'Stg.Language.Binds'.
  --
  -- >>> [binds| id = \x -> x |]
  -- (Binds [(Var "id",LambdaForm [] NoUpdate [Var "x"] (AppF (Var "x") []))])
  binds :: QuasiQuoter
  binds = stgQQ Parser.binds "binds"
  
  -- | Quasiquoter for 'Stg.Language.LambdaForm's.
  --
  -- >>> [lambdaForm| \x -> x |]
  -- LambdaForm [] NoUpdate [Var "x"] (AppF (Var "x") [])
  lambdaForm :: QuasiQuoter
  lambdaForm = stgQQ Parser.lambdaForm "lambda form"
  
  -- | Quasiquoter for 'Stg.Language.Expr'essions.
  --
  -- >>> [expr| f x y z |]
  -- AppF (Var "f") [AtomVar (Var "x"),AtomVar (Var "y"),AtomVar (Var "z")]
  expr :: QuasiQuoter
  expr = stgQQ Parser.expr "expression"
  
  -- | Quasiquoter for 'Stg.Language.Alts'.
  --
  -- >>> [alts| Just x -> True; default -> False |]
  -- Alts (AlgebraicAlts (AlgebraicAlt (Constr "Just") [Var "x"] (AppC (Constr "True") []) :| [])) (DefaultNotBound (AppC (Constr "False") []))
  --
  -- >>> [alts| 0# -> True; default -> False |]
  -- Alts (PrimitiveAlts (PrimitiveAlt (Literal 0) (AppC (Constr "True") []) :| [])) (DefaultNotBound (AppC (Constr "False") []))
  alts :: QuasiQuoter
  alts = stgQQ Parser.alts "alternatives"
  
  -- | Quasiquoter for 'Stg.Language.Alt'.
  --
  -- >>> [nonDefaultAlts| Just x -> True; Nothing -> False; |]
  -- AlgebraicAlts (AlgebraicAlt (Constr "Just") [Var "x"] (AppC (Constr "True") []) :| [AlgebraicAlt (Constr "Nothing") [] (AppC (Constr "False") [])])
  --
  -- >>> [nonDefaultAlts| 0# -> False; 1# -> True; |]
  -- PrimitiveAlts (PrimitiveAlt (Literal 0) (AppC (Constr "False") []) :| [PrimitiveAlt (Literal 1) (AppC (Constr "True") [])])
  nonDefaultAlts :: QuasiQuoter
  nonDefaultAlts = stgQQ Parser.nonDefaultAlts "algebraic alternatives"
  
  -- | Quasiquoter for 'Stg.Language.AlgebraicAlt's.
  --
  -- >>> [algebraicAlt| Just x -> x; |]
  -- AlgebraicAlt (Constr "Just") [Var "x"] (AppF (Var "x") [])
  algebraicAlt :: QuasiQuoter
  algebraicAlt = stgQQ Parser.algebraicAlt "algebraic alternative"
  
  -- | Quasiquoter for 'Stg.Language.PrimitiveAlt's.
  --
  -- >>> [primitiveAlt| 1# -> x; |]
  -- PrimitiveAlt (Literal 1) (AppF (Var "x") [])
  primitiveAlt :: QuasiQuoter
  primitiveAlt = stgQQ Parser.primitiveAlt "primitive alternative"
  
  -- | Quasiquoter for 'Stg.Language.DefaultAlt's.
  --
  -- >>> [defaultAlt| default -> x |]
  -- DefaultNotBound (AppF (Var "x") [])
  --
  -- >>> [defaultAlt| x -> x |]
  -- DefaultBound (Var "x") (AppF (Var "x") [])
  defaultAlt :: QuasiQuoter
  defaultAlt = stgQQ Parser.defaultAlt "default alternative"
  
  -- | Quasiquoter for 'Stg.Language.Literal's.
  --
  -- >>> [literal| 1# |]
  -- Literal 1
  literal :: QuasiQuoter
  literal = stgQQ Parser.literal "literal"
  
  -- | Quasiquoter for 'Stg.Language.PrimOp's.
  --
  -- >>> [primOp| +# |]
  -- Add
  primOp :: QuasiQuoter
  primOp = stgQQ Parser.primOp "primop"
  
  -- | Quasiquoter for 'Stg.Language.Atom's.
  --
  -- >>> [atom| x |]
  -- AtomVar (Var "x")
  atom :: QuasiQuoter
  atom = stgQQ Parser.atom "atom"
  