parsers/Parsers/Brainfuck/SymanticParser.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE ScopedTypeVariables #-}
   3 {-# LANGUAGE TemplateHaskell #-}
   4 {-# LANGUAGE TypeApplications #-}
   5 {-# LANGUAGE ViewPatterns #-}
   6 module Parsers.Brainfuck.SymanticParser where
   7
   8 import Data.Char (Char)
   9 import Data.Function ((.))
  10 import qualified Language.Haskell.TH.Syntax as TH
  11 import qualified Prelude
  12
  13 import Symantic.Univariant.Trans
  14 import qualified Symantic.Parser as SP
  15 import qualified Symantic.Parser.Haskell as H
  16
  17 import Parsers.Utils
  18 import Parsers.Brainfuck.Types
  19
  20 haskell :: TH.Lift a => a -> SP.TermGrammar a
  21 haskell a = H.Term (H.ValueCode a [||a||])
  22
  23 -- | Use with @$$(runParser @Text grammar)@,
  24 -- but in another Haskell module to avoid
  25 -- GHC stage restriction on such top-level splice.
  26 grammar :: forall tok repr.
  27   CoerceEnum Char tok =>
  28   CoerceEnum tok Char =>
  29   SP.Grammarable tok repr =>
  30   repr [Instruction]
  31 grammar = whitespace SP.*> bf
  32   where
  33   whitespace = SP.skipMany (SP.noneOf (coerceEnum @_ @tok Prelude.<$> "<>+-,.[]"))
  34   lexeme :: repr a -> repr a
  35   lexeme p = p SP.<* whitespace
  36   bf :: repr [Instruction]
  37   bf = SP.many (lexeme (SP.match (SP.look (SP.item @tok))
  38                                (haskell . coerceEnum Prelude.<$> "<>+-,.[")
  39                                op SP.empty))
  40   op :: H.Term H.ValueCode tok -> repr Instruction
  41   op (trans -> H.ValueCode c _) = case coerceEnum c of
  42     '<' -> SP.item @tok SP.$> SP.code Backward
  43     '>' -> SP.item @tok SP.$> SP.code Forward
  44     '+' -> SP.item @tok SP.$> SP.code Increment
  45     '-' -> SP.item @tok SP.$> SP.code Decrement
  46     ',' -> SP.item @tok SP.$> SP.code Input
  47     '.' -> SP.item @tok SP.$> SP.code Output
  48     '[' -> SP.between (lexeme (SP.item @tok))
  49                       (SP.token (coerceEnum @_ @tok ']'))
  50                       (H.Term (H.ValueCode Loop [||Loop||]) SP.<$> bf)
  51     _ -> Prelude.undefined