-use_flake() {
- watch_file flake.nix
- watch_file flake.lock
- watch_file default.nix
- watch_file shell.nix
- profile="$(direnv_layout_dir)"/flake-profile
- mkdir -p "$(direnv_layout_dir)"
- eval "$(time nix print-dev-env --show-trace --profile "$profile" || echo false)" &&
- nix-store --add-root "shell.root" --indirect --realise "$profile" &&
- nix-env --delete-generations +1 --profile "$profile"
-}
use flake
override TEST_OPTIONS += --color always --size-cutoff 1000000 $(addprefix -p ,$t)
override GHC_PROF_OPTIONS += -fprof-auto -fprof-auto-calls
override BENCHMARK_OPTIONS += --output benchmarks/html/$(version).html --match glob $b
+override REPL_OPTIONS += -ignore-dot-ghci
cabal := $(wildcard *.cabal)
package := $(notdir ./$(cabal:.cabal=))
cabal clean
repl:
cabal repl $(project)
+ghcid:
+ ghcid -c 'cabal repl $(project) --repl-options "$(REPL_OPTIONS)"' --reverse-errors
+.PHONY: parsers
+parsers:
+ cabal build $(project):parsers
parsers/repl:
cabal repl $(project):parsers
+parsers/ghcid:
+ ghcid -c 'cabal repl $(project):parsers --repl-options "$(REPL_OPTIONS)"' --reverse-errors
+parsers/prof-th:
+ cabal v2-build lib:$(project) --enable-profiling $(GHC_PROF_OPTIONS) --write-ghc-environment-files=always
+ cabal build $(project):parsers $(CABAL_BUILD_FLAGS) \
+ --enable-profiling $(GHC_PROF_OPTIONS) \
+ --ghc-options "$(addprefix -opti,+RTS $(RTS_OPTIONS))"
.PHONY: tests
tests:
benchmarks/prof-heap: $(project)-benchmark.eventlog.html
.PHONY: $(project)-benchmark.eventlog
$(project)-benchmark.eventlog $(project)-benchmark.prof:
+ @echo "$$(tput setaf 1)WARNING: benchmarking with --enable-profiling can create significant biases$$(tput sgr0)"
cabal bench $(CABAL_BENCH_FLAGS) \
--benchmark-options "$(BENCHMARK_OPTIONS) +RTS $(RTS_OPTIONS)" \
--enable-profiling $(GHC_PROF_OPTIONS)
nix -L develop --command cabal repl
nix-shell:
nix -L develop
+
+.PHONY: debug-ppr
+debug-ppr: debug-ppr/PprSplice.hs debug-ppr/AutoSplice.hs
+debug-ppr/PprSplice.hs.ppr: parsers/Parsers/Brainfuck/SymanticParser/PprSplice.hs.ppr Makefile
+ mkdir -p $(@D)
+ sed $< >$@ -e '1s/^/parser = /' -e 's/\x00//g'
+debug-ppr/AutoSplice.dump-splices: dist-newstyle/build/x86_64-linux/ghc-9.0.1/symantic-parser-$(version)/l/parsers/build/parsers/parsers/Parsers/Brainfuck/SymanticParser/AutoSplice.dump-splices Makefile
+ mkdir -p $(@D)
+ sed $< >$@ -e '1,/^ ======>/d;' -e '4s/^/parser = /' -e 's/\x00//g'
+%.hs: %.hs.ppr
+ ormolu -m stdout >$@ -o -XBangPatterns -o -XUnboxedTuples -o -XMagicHash -o -XTypeApplications -o -XUnboxedTuples <$<
+ #sed -i $@ -e 'N;s/\n\s*#)/ #)/;P;D'
+%.hs: %.dump-splices
+ ormolu -m stdout >$@ -o -XBangPatterns -o -XUnboxedTuples -o -XMagicHash -o -XTypeApplications -o -XUnboxedTuples <$<
+ #sed -i $@ -e 'N;s/\n\s*#)/ #)/;P;D'
hs.hs-speedscope
hs.profiteur
hs.eventlog2html
+ hs.ghcid
#hs.threadscope
#hs.ghc-events-analyze
#hs.haskell-language-server
import Data.Either (Either)
import qualified Data.ByteString as BS
import qualified Symantic.Parser as SP
+import qualified GHC.Word
-import Parsers.Brainfuck.SymanticParser.Grammar (grammar)
+import Parsers.Brainfuck.SymanticParser.Grammar (grammar, reproGrammar)
import Parsers.Brainfuck.Types (Instruction)
parserByteString :: BS.ByteString -> Either (SP.ParsingError BS.ByteString) [Instruction]
parserByteString = $$(SP.runParser @BS.ByteString grammar)
+
+{-
+parserByteStringRepro :: BS.ByteString -> Either (SP.ParsingError BS.ByteString) [GHC.Word.Word8]
+parserByteStringRepro = $$(SP.runParser @BS.ByteString reproGrammar)
+-}
import qualified Prelude
import qualified Symantic.Parser as SP
import qualified Symantic.Parser.Grammar.Combinators
-import qualified Symantic.Parser.Haskell
+import qualified Symantic.Univariant.Lang
import qualified Symantic.Parser.Machine
import qualified Symantic.Parser.Machine.Generate
import qualified Symantic.Parser.Machine.Input
= input_ama8
next_amai i_amaj@(GHC.Types.I# i_amak#)
= case
- ((GHC.Prim.readWord8OffAddr#
- (addr_amae# `GHC.Prim.plusAddr#` i_amak#))
- 0#)
+ GHC.Prim.readWord8OffAddr#
+ (addr_amae# `GHC.Prim.plusAddr#` i_amak#)
+ 0#
GHC.Prim.realWorld#
of {
(# s'_amal, x_amam #)
- -> case (GHC.Prim.touch# final_amaf) s'_amal of {
+ -> case GHC.Prim.touch# final_amaf s'_amal of {
_ -> (# GHC.Word.W8# x_amam, (i_amaj GHC.Num.+ 1) #) } }
in (# off_amag, (GHC.Classes.< size_amah), next_amai #)
finalRet_ama9
let
name_1
= \ !ok_amcU !inp_amcV !koByLabel_amcW
- -> ((name_4
+ -> name_4
(let _ = "suspend"
in
\ farInp_amcX farExp_amcY v_amcZ !inp_amd0
-> let _ = "resume"
in
- (((ok_amcU farInp_amcX) farExp_amcY)
- (let _ = "resume.genCode" in ()))
- inp_amd0))
- inp_amcV)
- (((((Data.Map.Internal.Bin 1) SP.ExceptionFailure)
- (((Data.Map.Strict.Internal.findWithDefault finalRaise_amad)
- SP.ExceptionFailure)
- koByLabel_amcW))
- Data.Map.Internal.Tip)
+ ok_amcU farInp_amcX farExp_amcY
+ (let _ = "resume.genCode" in ())
+ inp_amd0)
+ inp_amcV
+ (Data.Map.Internal.Bin 1 SP.ExceptionFailure
+ (Data.Map.Strict.Internal.findWithDefault finalRaise_amad
+ SP.ExceptionFailure
+ koByLabel_amcW)
+ Data.Map.Internal.Tip
Data.Map.Internal.Tip)
name_2
= \ !ok_amcN !inp_amcO !koByLabel_amcP
- -> ((name_3
+ -> name_3
(let _ = "suspend"
in
\ farInp_amcQ farExp_amcR v_amcS !inp_amcT
-> let _ = "resume"
in
- (((ok_amcN farInp_amcQ) farExp_amcR)
- (let _ = "resume.genCode" in v_amcS []))
- inp_amcT))
- inp_amcO)
- (((((Data.Map.Internal.Bin 1) SP.ExceptionFailure)
- (((Data.Map.Strict.Internal.findWithDefault finalRaise_amad)
- SP.ExceptionFailure)
- koByLabel_amcP))
- Data.Map.Internal.Tip)
+ ok_amcN farInp_amcQ farExp_amcR
+ (let _ = "resume.genCode" in v_amcS [])
+ inp_amcT)
+ inp_amcO
+ (Data.Map.Internal.Bin 1 SP.ExceptionFailure
+ (Data.Map.Strict.Internal.findWithDefault finalRaise_amad
+ SP.ExceptionFailure
+ koByLabel_amcP)
+ Data.Map.Internal.Tip
Data.Map.Internal.Tip)
name_3
= \ !ok_amaS !inp_amaT !koByLabel_amaU
!farExp_amaZ
= let _ = "catch.ko ExceptionFailure"
in
- if (((GHC.Classes.==) @GHC.Types.Int) inp_amaT) failInp_amaX then
+ if (GHC.Classes.==) @GHC.Types.Int inp_amaT failInp_amaX then
let _ = "choicesBranch.then" in
let _ = "resume"
in
- (((ok_amaS farInp_amaY) farExp_amaZ)
- (let _ = "resume.genCode" in \ x_amb0 -> x_amb0))
+ ok_amaS farInp_amaY farExp_amaZ
+ (let _ = "resume.genCode" in \ x_amb0 -> x_amb0)
failInp_amaX
else
let _ = "choicesBranch.else"
in
- ((((((Data.Map.Strict.Internal.findWithDefault finalRaise_amad)
- SP.ExceptionFailure)
- koByLabel_amaU)
- SP.ExceptionFailure)
- failInp_amaX)
- farInp_amaY)
+ Data.Map.Strict.Internal.findWithDefault finalRaise_amad
+ SP.ExceptionFailure
+ koByLabel_amaU
+ SP.ExceptionFailure
+ failInp_amaX
+ farInp_amaY
farExp_amaZ in
let
join_1s
= \ farInp_amb1 farExp_amb2 v_amb3 !inp_amb4
- -> ((name_1
+ -> name_1
(let _ = "suspend"
in
\ farInp_amb5 farExp_amb6 v_amb7 !inp_amb8
- -> ((name_3
+ -> (name_3
(let _ = "suspend"
in
\ farInp_amb9 farExp_amba v_ambb !inp_ambc
-> let _ = "resume"
in
- (((ok_amaS farInp_amb9) farExp_amba)
+ ok_amaS farInp_amb9 farExp_amba
(let _ = "resume.genCode"
in
\ x_ambd
- -> (v_amb3 : v_ambb x_ambd)))
- inp_ambc))
+ -> (v_amb3 : v_ambb x_ambd))
+ inp_ambc)
inp_amb8)
- (((((Data.Map.Internal.Bin 1) SP.ExceptionFailure)
- catchHandler_amaV)
- Data.Map.Internal.Tip)
- Data.Map.Internal.Tip)))
- inp_amb4)
- (((((Data.Map.Internal.Bin 1) SP.ExceptionFailure)
- catchHandler_amaV)
- Data.Map.Internal.Tip)
+ (Data.Map.Internal.Bin 1 SP.ExceptionFailure
+ catchHandler_amaV
+ Data.Map.Internal.Tip
+ Data.Map.Internal.Tip))
+ inp_amb4
+ (Data.Map.Internal.Bin 1 SP.ExceptionFailure
+ catchHandler_amaV
+ Data.Map.Internal.Tip
Data.Map.Internal.Tip) in
let readFail_ambe = catchHandler_amaV
in
let _ = "checkToken.else" in
let
failExp_ambm
- = (((Data.Set.Internal.Bin 1)
+ = Data.Set.Internal.Bin 1
(SP.SomeFailure
(case inputToken of {
(Data.Proxy.Proxy :: Data.Proxy.Proxy tok'_aLiK)
- -> SP.FailureAny @tok'_aLiK })))
- Data.Set.Internal.Tip)
+ -> SP.FailureAny @tok'_aLiK }))
+ Data.Set.Internal.Tip
Data.Set.Internal.Tip in
let
(# farInp_ambn, farExp_ambo #)
-> (# init_amaa,
Data.Set.Internal.empty #)
in
- (((readFail_ambi SP.ExceptionFailure) inp_amaT)
- farInp_ambn)
+ readFail_ambi SP.ExceptionFailure inp_amaT
+ farInp_ambn
farExp_ambo
else
let _ = "checkHorizon.else" in
let
failExp_ambp
- = (((Data.Set.Internal.Bin 1)
+ = Data.Set.Internal.Bin 1
(SP.SomeFailure
(case inputToken of {
(Data.Proxy.Proxy :: Data.Proxy.Proxy tok'_aLiK)
- -> (SP.FailureHorizon @tok'_aLiK) 1 })))
- Data.Set.Internal.Tip)
+ -> SP.FailureHorizon @tok'_aLiK 1 }))
+ Data.Set.Internal.Tip
Data.Set.Internal.Tip in
let
(# farInp_ambq, farExp_ambr #)
GHC.Types.GT
-> (# init_amaa, Data.Set.Internal.empty #)
in
- (((readFail_ambi SP.ExceptionFailure) inp_amaT)
- farInp_ambq)
+ readFail_ambi SP.ExceptionFailure inp_amaT
+ farInp_ambq
farExp_ambr
else
let _ = "choicesBranch.else"
if (\ x_ambv -> GHC.Types.True) c_ambt then
let _ = "resume"
in
- (((join_1s init_amaa)
- Data.Set.Internal.empty)
+ join_1s init_amaa
+ Data.Set.Internal.empty
(let _ = "resume.genCode"
- in Parsers.Brainfuck.Types.Forward))
+ in Parsers.Brainfuck.Types.Forward)
cs_ambu
else
let _ = "checkToken.else" in
let
failExp_ambw
- = (((Data.Set.Internal.Bin 1)
+ = Data.Set.Internal.Bin 1
(SP.SomeFailure
(case inputToken of {
(Data.Proxy.Proxy :: Data.Proxy.Proxy tok'_aLiK)
-> SP.FailureAny
- @tok'_aLiK })))
- Data.Set.Internal.Tip)
+ @tok'_aLiK }))
+ Data.Set.Internal.Tip
Data.Set.Internal.Tip in
let
(# farInp_ambx, farExp_amby #)
= case
- ((GHC.Classes.compare
- @GHC.Types.Int)
- init_amaa)
+ GHC.Classes.compare
+ @GHC.Types.Int
+ init_amaa
inp_amaT
of
GHC.Types.LT
let _ = "checkHorizon.else" in
let
failExp_ambz
- = (((Data.Set.Internal.Bin 1)
+ = Data.Set.Internal.Bin 1
(SP.SomeFailure
(case inputToken of {
(Data.Proxy.Proxy :: Data.Proxy.Proxy tok'_aLiK)
- -> (SP.FailureHorizon @tok'_aLiK)
- 1 })))
- Data.Set.Internal.Tip)
+ -> SP.FailureHorizon @tok'_aLiK
+ 1 }))
+ Data.Set.Internal.Tip
Data.Set.Internal.Tip in
let
(# farInp_ambA, farExp_ambB #)
= case
- ((GHC.Classes.compare @GHC.Types.Int)
- init_amaa)
+ GHC.Classes.compare @GHC.Types.Int
+ init_amaa
inp_amaT
of
GHC.Types.LT -> (# inp_amaT, failExp_ambz #)
-> (# init_amaa,
Data.Set.Internal.empty #)
in
- (((readFail_ambs SP.ExceptionFailure) inp_amaT)
- farInp_ambA)
+ readFail_ambs SP.ExceptionFailure inp_amaT
+ farInp_ambA
farExp_ambB
else
let _ = "choicesBranch.else"
if (\ x_ambF -> GHC.Types.True) c_ambD then
let _ = "resume"
in
- (((join_1s init_amaa)
- Data.Set.Internal.empty)
+ join_1s init_amaa
+ Data.Set.Internal.empty
(let _ = "resume.genCode"
in
- Parsers.Brainfuck.Types.Increment))
+ Parsers.Brainfuck.Types.Increment)
cs_ambE
else
let _ = "checkToken.else" in
let
failExp_ambG
- = (((Data.Set.Internal.Bin 1)
+ = Data.Set.Internal.Bin 1
(SP.SomeFailure
(case inputToken of {
(Data.Proxy.Proxy :: Data.Proxy.Proxy tok'_aLiK)
-> SP.FailureAny
- @tok'_aLiK })))
- Data.Set.Internal.Tip)
+ @tok'_aLiK }))
+ Data.Set.Internal.Tip
Data.Set.Internal.Tip in
let
(# farInp_ambH, farExp_ambI #)
= case
- ((GHC.Classes.compare
- @GHC.Types.Int)
- init_amaa)
+ GHC.Classes.compare
+ @GHC.Types.Int
+ init_amaa
inp_amaT
of
GHC.Types.LT
-> (# init_amaa,
Data.Set.Internal.empty #)
in
- (((readFail_ambC SP.ExceptionFailure)
- inp_amaT)
- farInp_ambH)
+ readFail_ambC SP.ExceptionFailure
+ inp_amaT
+ farInp_ambH
farExp_ambI
else
let _ = "checkHorizon.else" in
let
failExp_ambJ
- = (((Data.Set.Internal.Bin 1)
+ = Data.Set.Internal.Bin 1
(SP.SomeFailure
(case inputToken of {
(Data.Proxy.Proxy :: Data.Proxy.Proxy tok'_aLiK)
- -> (SP.FailureHorizon
- @tok'_aLiK)
- 1 })))
- Data.Set.Internal.Tip)
+ -> SP.FailureHorizon
+ @tok'_aLiK
+ 1 }))
+ Data.Set.Internal.Tip
Data.Set.Internal.Tip in
let
(# farInp_ambK, farExp_ambL #)
-> (# init_amaa,
Data.Set.Internal.empty #)
in
- (((readFail_ambC SP.ExceptionFailure)
- inp_amaT)
- farInp_ambK)
+ readFail_ambC SP.ExceptionFailure
+ inp_amaT
+ farInp_ambK
farExp_ambL
else
let _ = "choicesBranch.else"
c_ambN then
let _ = "resume"
in
- (((join_1s init_amaa)
- Data.Set.Internal.empty)
+ join_1s init_amaa
+ Data.Set.Internal.empty
(let _ = "resume.genCode"
in
- Parsers.Brainfuck.Types.Decrement))
+ Parsers.Brainfuck.Types.Decrement)
cs_ambO
else
let _ = "checkToken.else" in
let
failExp_ambQ
- = (((Data.Set.Internal.Bin 1)
+ = Data.Set.Internal.Bin 1
(SP.SomeFailure
(case inputToken of {
(Data.Proxy.Proxy :: Data.Proxy.Proxy tok'_aLiK)
-> SP.FailureAny
- @tok'_aLiK })))
- Data.Set.Internal.Tip)
+ @tok'_aLiK }))
+ Data.Set.Internal.Tip
Data.Set.Internal.Tip in
let
(# farInp_ambR, farExp_ambS #)
= case
- ((GHC.Classes.compare
- @GHC.Types.Int)
- init_amaa)
+ GHC.Classes.compare
+ @GHC.Types.Int
+ init_amaa
inp_amaT
of
GHC.Types.LT
-> (# init_amaa,
Data.Set.Internal.empty #)
in
- (((readFail_ambM
- SP.ExceptionFailure)
- inp_amaT)
- farInp_ambR)
+ readFail_ambM
+ SP.ExceptionFailure
+ inp_amaT
+ farInp_ambR
farExp_ambS
else
let _ = "checkHorizon.else" in
let
failExp_ambT
- = (((Data.Set.Internal.Bin 1)
+ = Data.Set.Internal.Bin 1
(SP.SomeFailure
(case inputToken of {
(Data.Proxy.Proxy :: Data.Proxy.Proxy tok'_aLiK)
- -> (SP.FailureHorizon
- @tok'_aLiK)
- 1 })))
- Data.Set.Internal.Tip)
+ -> SP.FailureHorizon
+ @tok'_aLiK
+ 1 }))
+ Data.Set.Internal.Tip
Data.Set.Internal.Tip in
let
(# farInp_ambU, farExp_ambV #)
= case
- ((GHC.Classes.compare
- @GHC.Types.Int)
- init_amaa)
+ GHC.Classes.compare
+ @GHC.Types.Int
+ init_amaa
inp_amaT
of
GHC.Types.LT
-> (# init_amaa,
Data.Set.Internal.empty #)
in
- (((readFail_ambM SP.ExceptionFailure)
- inp_amaT)
- farInp_ambU)
+ readFail_ambM SP.ExceptionFailure
+ inp_amaT
+ farInp_ambU
farExp_ambV
else
let _ = "choicesBranch.else"
c_ambX then
let _ = "resume"
in
- (((join_1s init_amaa)
- Data.Set.Internal.empty)
+ join_1s init_amaa
+ Data.Set.Internal.empty
(let
_ = "resume.genCode"
in
- Parsers.Brainfuck.Types.Input))
+ Parsers.Brainfuck.Types.Input)
cs_ambY
else
let _ = "checkToken.else" in
let
failExp_amc0
- = (((Data.Set.Internal.Bin
- 1)
+ = Data.Set.Internal.Bin
+ 1
(SP.SomeFailure
(case
inputToken
of {
(Data.Proxy.Proxy :: Data.Proxy.Proxy tok'_aLiK)
-> SP.FailureAny
- @tok'_aLiK })))
- Data.Set.Internal.Tip)
+ @tok'_aLiK }))
+ Data.Set.Internal.Tip
Data.Set.Internal.Tip in
let
(# farInp_amc1,
farExp_amc2 #)
= case
- ((GHC.Classes.compare
- @GHC.Types.Int)
- init_amaa)
+ GHC.Classes.compare
+ @GHC.Types.Int
+ init_amaa
inp_amaT
of
GHC.Types.LT
-> (# init_amaa,
Data.Set.Internal.empty #)
in
- (((readFail_ambW
- SP.ExceptionFailure)
- inp_amaT)
- farInp_amc1)
+ readFail_ambW
+ SP.ExceptionFailure
+ inp_amaT
+ farInp_amc1
farExp_amc2
else
let _ = "checkHorizon.else" in
let
failExp_amc3
- = (((Data.Set.Internal.Bin 1)
+ = Data.Set.Internal.Bin 1
(SP.SomeFailure
(case inputToken of {
(Data.Proxy.Proxy :: Data.Proxy.Proxy tok'_aLiK)
- -> (SP.FailureHorizon
- @tok'_aLiK)
- 1 })))
- Data.Set.Internal.Tip)
+ -> SP.FailureHorizon
+ @tok'_aLiK
+ 1 }))
+ Data.Set.Internal.Tip
Data.Set.Internal.Tip in
let
(# farInp_amc4, farExp_amc5 #)
= case
- ((GHC.Classes.compare
- @GHC.Types.Int)
- init_amaa)
+ GHC.Classes.compare
+ @GHC.Types.Int
+ init_amaa
inp_amaT
of
GHC.Types.LT
-> (# init_amaa,
Data.Set.Internal.empty #)
in
- (((readFail_ambW
- SP.ExceptionFailure)
- inp_amaT)
- farInp_amc4)
+ readFail_ambW
+ SP.ExceptionFailure
+ inp_amaT
+ farInp_amc4
farExp_amc5
else
let _ = "choicesBranch.else"
c_amc7 then
let _ = "resume"
in
- (((join_1s
- init_amaa)
- Data.Set.Internal.empty)
+ join_1s
+ init_amaa
+ Data.Set.Internal.empty
(let
_ = "resume.genCode"
in
- Parsers.Brainfuck.Types.Output))
+ Parsers.Brainfuck.Types.Output)
cs_amc8
else
let
_ = "checkToken.else" in
let
failExp_amca
- = (((Data.Set.Internal.Bin
- 1)
+ = Data.Set.Internal.Bin
+ 1
(SP.SomeFailure
(case
inputToken
of {
(Data.Proxy.Proxy :: Data.Proxy.Proxy tok'_aLiK)
-> SP.FailureAny
- @tok'_aLiK })))
- Data.Set.Internal.Tip)
+ @tok'_aLiK }))
+ Data.Set.Internal.Tip
Data.Set.Internal.Tip in
let
(# farInp_amcb,
farExp_amcc #)
= case
- ((GHC.Classes.compare
- @GHC.Types.Int)
- init_amaa)
+ GHC.Classes.compare
+ @GHC.Types.Int
+ init_amaa
inp_amaT
of
GHC.Types.LT
-> (# init_amaa,
Data.Set.Internal.empty #)
in
- (((readFail_amc6
- SP.ExceptionFailure)
- inp_amaT)
- farInp_amcb)
+ readFail_amc6
+ SP.ExceptionFailure
+ inp_amaT
+ farInp_amcb
farExp_amcc
else
let
_ = "checkHorizon.else" in
let
failExp_amcd
- = (((Data.Set.Internal.Bin
- 1)
+ = Data.Set.Internal.Bin
+ 1
(SP.SomeFailure
(case
inputToken
of {
(Data.Proxy.Proxy :: Data.Proxy.Proxy tok'_aLiK)
- -> (SP.FailureHorizon
- @tok'_aLiK)
- 1 })))
- Data.Set.Internal.Tip)
+ -> SP.FailureHorizon
+ @tok'_aLiK
+ 1 }))
+ Data.Set.Internal.Tip
Data.Set.Internal.Tip in
let
(# farInp_amce,
farExp_amcf #)
= case
- ((GHC.Classes.compare
- @GHC.Types.Int)
- init_amaa)
+ GHC.Classes.compare
+ @GHC.Types.Int
+ init_amaa
inp_amaT
of
GHC.Types.LT
-> (# init_amaa,
Data.Set.Internal.empty #)
in
- (((readFail_amc6
- SP.ExceptionFailure)
- inp_amaT)
- farInp_amce)
+ readFail_amc6
+ SP.ExceptionFailure
+ inp_amaT
+ farInp_amce
farExp_amcf
else
let _ = "choicesBranch.else"
= readFail_ambe
in
if readMore_amab
- ((((GHC.Num.+)
- @GHC.Types.Int)
- 1)
+ ((GHC.Num.+)
+ @GHC.Types.Int
+ 1
inp_amaT) then
let
!(# c_amch,
if (\ x_amcj
-> GHC.Types.True)
c_amch then
- ((name_1
+ name_1
(let
_ = "suspend"
in
farExp_amcl
v_amcm
!inp_amcn
- -> ((name_2
+ -> name_2
(let
_ = "suspend"
in
let
_ = "resume"
in
- (((join_1s
- farInp_amco)
- farExp_amcp)
+ join_1s
+ farInp_amco
+ farExp_amcp
(let
_ = "resume.genCode"
in
Parsers.Brainfuck.Types.Loop
- v_amcq))
+ v_amcq)
cs_amcu
else
let
_ = "checkToken.else"
in
- (((readFail_amcs
- SP.ExceptionFailure)
- inp_amcr)
- farInp_amco)
+ readFail_amcs
+ SP.ExceptionFailure
+ inp_amcr
+ farInp_amco
farExp_amcp
else
let
_ = "checkHorizon.else" in
let
failExp_amcv
- = (((Data.Set.Internal.Bin
- 1)
+ = Data.Set.Internal.Bin
+ 1
(SP.SomeFailure
(case
inputToken
of {
(Data.Proxy.Proxy :: Data.Proxy.Proxy tok'_aLiK)
- -> (SP.FailureHorizon
- @tok'_aLiK)
- 1 })))
- Data.Set.Internal.Tip)
+ -> SP.FailureHorizon
+ @tok'_aLiK
+ 1 }))
+ Data.Set.Internal.Tip
Data.Set.Internal.Tip in
let
(# farInp_amcw,
farExp_amcx #)
= case
- ((GHC.Classes.compare
- @GHC.Types.Int)
- farInp_amco)
+ GHC.Classes.compare
+ @GHC.Types.Int
+ farInp_amco
inp_amcr
of
GHC.Types.LT
-> (# farInp_amco,
farExp_amcp #)
in
- (((readFail_amcs
- SP.ExceptionFailure)
- inp_amcr)
- farInp_amcw)
- farExp_amcx))
- inp_amcn)
- (((((Data.Map.Internal.Bin
- 1)
- SP.ExceptionFailure)
- readFail_amcg)
- Data.Map.Internal.Tip)
- Data.Map.Internal.Tip)))
- cs_amci)
- (((((Data.Map.Internal.Bin
- 1)
- SP.ExceptionFailure)
- readFail_amcg)
- Data.Map.Internal.Tip)
+ readFail_amcs
+ SP.ExceptionFailure
+ inp_amcr
+ farInp_amcw
+ farExp_amcx)
+ inp_amcn
+ (Data.Map.Internal.Bin
+ 1
+ SP.ExceptionFailure
+ readFail_amcg
+ Data.Map.Internal.Tip
+ Data.Map.Internal.Tip))
+ cs_amci
+ (Data.Map.Internal.Bin
+ 1
+ SP.ExceptionFailure
+ readFail_amcg
+ Data.Map.Internal.Tip
Data.Map.Internal.Tip)
else
let
_ = "checkToken.else" in
let
failExp_amcy
- = (((Data.Set.Internal.Bin
- 1)
+ = Data.Set.Internal.Bin
+ 1
(SP.SomeFailure
(case
inputToken
of {
(Data.Proxy.Proxy :: Data.Proxy.Proxy tok'_aLiK)
-> SP.FailureAny
- @tok'_aLiK })))
- Data.Set.Internal.Tip)
+ @tok'_aLiK }))
+ Data.Set.Internal.Tip
Data.Set.Internal.Tip in
let
(# farInp_amcz,
farExp_amcA #)
= case
- ((GHC.Classes.compare
- @GHC.Types.Int)
- init_amaa)
+ GHC.Classes.compare
+ @GHC.Types.Int
+ init_amaa
inp_amaT
of
GHC.Types.LT
-> (# init_amaa,
Data.Set.Internal.empty #)
in
- (((readFail_amcg
- SP.ExceptionFailure)
- inp_amaT)
- farInp_amcz)
+ readFail_amcg
+ SP.ExceptionFailure
+ inp_amaT
+ farInp_amcz
farExp_amcA
else
let
_ = "checkHorizon.else" in
let
failExp_amcB
- = (((Data.Set.Internal.Bin
- 1)
+ = Data.Set.Internal.Bin
+ 1
(SP.SomeFailure
(case
inputToken
of {
(Data.Proxy.Proxy :: Data.Proxy.Proxy tok'_aLiK)
- -> (SP.FailureHorizon
- @tok'_aLiK)
- 2 })))
- Data.Set.Internal.Tip)
+ -> SP.FailureHorizon
+ @tok'_aLiK
+ 2 }))
+ Data.Set.Internal.Tip
Data.Set.Internal.Tip in
let
(# farInp_amcC,
farExp_amcD #)
= case
- ((GHC.Classes.compare
- @GHC.Types.Int)
- init_amaa)
+ GHC.Classes.compare
+ @GHC.Types.Int
+ init_amaa
inp_amaT
of
GHC.Types.LT
-> (# init_amaa,
Data.Set.Internal.empty #)
in
- (((readFail_amcg
- SP.ExceptionFailure)
- inp_amaT)
- farInp_amcC)
+ readFail_amcg
+ SP.ExceptionFailure
+ inp_amaT
+ farInp_amcC
farExp_amcD
else
let
_ = "choicesBranch.else" in
let
failExp_amcE
- = (((Data.Set.Internal.Bin
- 1)
+ = Data.Set.Internal.Bin
+ 1
(SP.SomeFailure
- SP.FailureEmpty))
- Data.Set.Internal.Tip)
+ SP.FailureEmpty)
+ Data.Set.Internal.Tip
Data.Set.Internal.Tip in
let
(# farInp_amcF,
-> (# init_amaa,
Data.Set.Internal.empty #)
in
- (((readFail_ambe
- SP.ExceptionFailure)
- inp_amaT)
- farInp_amcF)
+ readFail_ambe
+ SP.ExceptionFailure
+ inp_amaT
+ farInp_amcF
farExp_amcG
else
let _ = "checkToken.else" in
let
failExp_amcH
- = (((Data.Set.Internal.Bin 1)
+ = Data.Set.Internal.Bin 1
(SP.SomeFailure
(case inputToken of {
(Data.Proxy.Proxy :: Data.Proxy.Proxy tok'_aLiK)
- -> SP.FailureAny @tok'_aLiK })))
- Data.Set.Internal.Tip)
+ -> SP.FailureAny @tok'_aLiK }))
+ Data.Set.Internal.Tip
Data.Set.Internal.Tip in
let
(# farInp_amcI, farExp_amcJ #)
= case
- ((GHC.Classes.compare @GHC.Types.Int) init_amaa) inp_amaT
+ GHC.Classes.compare @GHC.Types.Int init_amaa inp_amaT
of
GHC.Types.LT -> (# inp_amaT, failExp_amcH #)
GHC.Types.EQ
GHC.Base.<> Data.Set.Internal.empty) #)
GHC.Types.GT -> (# init_amaa, Data.Set.Internal.empty #)
in
- (((readFail_ambe SP.ExceptionFailure) inp_amaT) farInp_amcI)
+ readFail_ambe SP.ExceptionFailure inp_amaT farInp_amcI
farExp_amcJ
else
let _ = "checkHorizon.else" in
let
failExp_amcK
- = (((Data.Set.Internal.Bin 1)
+ = Data.Set.Internal.Bin 1
(SP.SomeFailure
(case inputToken of {
(Data.Proxy.Proxy :: Data.Proxy.Proxy tok'_aLiK)
- -> (SP.FailureHorizon @tok'_aLiK) 1 })))
- Data.Set.Internal.Tip)
+ -> SP.FailureHorizon @tok'_aLiK 1 }))
+ Data.Set.Internal.Tip
Data.Set.Internal.Tip in
let
(# farInp_amcL, farExp_amcM #)
- = case ((GHC.Classes.compare @GHC.Types.Int) init_amaa) inp_amaT of
+ = case GHC.Classes.compare @GHC.Types.Int init_amaa inp_amaT of
GHC.Types.LT -> (# inp_amaT, failExp_amcK #)
GHC.Types.EQ
-> (# init_amaa,
(failExp_amcK GHC.Base.<> Data.Set.Internal.empty) #)
GHC.Types.GT -> (# init_amaa, Data.Set.Internal.empty #)
in
- (((readFail_ambe SP.ExceptionFailure) inp_amaT) farInp_amcL)
+ readFail_ambe SP.ExceptionFailure inp_amaT farInp_amcL
farExp_amcM
name_4
= \ !ok_amax !inp_amay !koByLabel_amaz
!farExp_amaE
= let _ = "catch.ko ExceptionFailure"
in
- if (((GHC.Classes.==) @GHC.Types.Int) inp_amay) failInp_amaC then
+ if (GHC.Classes.==) @GHC.Types.Int inp_amay failInp_amaC then
let _ = "choicesBranch.then" in
let _ = "resume"
in
- (((ok_amax farInp_amaD) farExp_amaE)
- (let _ = "resume.genCode" in \ x_amaF -> x_amaF))
+ ok_amax farInp_amaD farExp_amaE
+ (let _ = "resume.genCode" in \ x_amaF -> x_amaF)
failInp_amaC
else
let _ = "choicesBranch.else"
in
- ((((((Data.Map.Strict.Internal.findWithDefault finalRaise_amad)
- SP.ExceptionFailure)
- koByLabel_amaz)
- SP.ExceptionFailure)
- failInp_amaC)
- farInp_amaD)
+ Data.Map.Strict.Internal.findWithDefault finalRaise_amad
+ SP.ExceptionFailure
+ koByLabel_amaz
+ SP.ExceptionFailure
+ failInp_amaC
+ farInp_amaD
farExp_amaE in
let readFail_amaG = catchHandler_amaA
in
GHC.Classes.||
GHC.Types.False)))))))))
c_amaH then
- ((name_4
+ name_4
(let _ = "suspend"
in
\ farInp_amaK farExp_amaL v_amaM !inp_amaN
-> let _ = "resume"
in
- (((ok_amax farInp_amaK) farExp_amaL)
+ ok_amax farInp_amaK farExp_amaL
(let _ = "resume.genCode"
- in \ x_amaO -> v_amaM x_amaO))
- inp_amaN))
- cs_amaI)
- (((((Data.Map.Internal.Bin 1) SP.ExceptionFailure) readFail_amaG)
- Data.Map.Internal.Tip)
+ in \ x_amaO -> v_amaM x_amaO)
+ inp_amaN)
+ cs_amaI
+ (Data.Map.Internal.Bin 1 SP.ExceptionFailure readFail_amaG
+ Data.Map.Internal.Tip
Data.Map.Internal.Tip)
else
let _ = "checkToken.else"
in
- (((readFail_amaG SP.ExceptionFailure) inp_amay) init_amaa)
+ readFail_amaG SP.ExceptionFailure inp_amay init_amaa
Data.Set.Internal.empty
else
let _ = "checkHorizon.else" in
let
failExp_amaP
- = (((Data.Set.Internal.Bin 1)
+ = Data.Set.Internal.Bin 1
(SP.SomeFailure
(case inputToken of {
(Data.Proxy.Proxy :: Data.Proxy.Proxy tok'_aLiK)
- -> (SP.FailureHorizon @tok'_aLiK) 1 })))
- Data.Set.Internal.Tip)
+ -> SP.FailureHorizon @tok'_aLiK 1 }))
+ Data.Set.Internal.Tip
Data.Set.Internal.Tip in
let
(# farInp_amaQ, farExp_amaR #)
- = case ((GHC.Classes.compare @GHC.Types.Int) init_amaa) inp_amay of
+ = case GHC.Classes.compare @GHC.Types.Int init_amaa inp_amay of
GHC.Types.LT -> (# inp_amay, failExp_amaP #)
GHC.Types.EQ
-> (# init_amaa,
(failExp_amaP GHC.Base.<> Data.Set.Internal.empty) #)
GHC.Types.GT -> (# init_amaa, Data.Set.Internal.empty #)
in
- (((readFail_amaG SP.ExceptionFailure) inp_amay) farInp_amaQ)
+ readFail_amaG SP.ExceptionFailure inp_amay farInp_amaQ
farExp_amaR
in
- ((name_1
+ name_1
(let _ = "suspend"
in
\ farInp_amd1 farExp_amd2 v_amd3 !inp_amd4
- -> ((name_2
+ -> name_2
(let _ = "suspend"
in
\ farInp_amd5 farExp_amd6 v_amd7 !inp_amd8
-> let _ = "resume"
in
- (((finalRet_ama9 farInp_amd5) farExp_amd6)
- (let _ = "resume.genCode" in v_amd7))
- inp_amd8))
- inp_amd4)
- Data.Map.Internal.Tip))
- init_amaa)
+ finalRet_ama9 farInp_amd5 farExp_amd6
+ (let _ = "resume.genCode" in v_amd7)
+ inp_amd8)
+ inp_amd4
+ Data.Map.Internal.Tip)
+ init_amaa
Data.Map.Internal.Tip
import Symantic.Univariant.Trans
import qualified Symantic.Parser as SP
-import qualified Symantic.Parser.Haskell as H
import Parsers.Utils
import Parsers.Brainfuck.Types
-haskell :: TH.Lift a => a -> SP.TermGrammar a
-haskell a = H.Term (H.ValueCode a [||a||])
-
-- | Use with @$$(runParser @Text grammar)@,
-- but in another Haskell module to avoid
-- GHC stage restriction on such top-level splice.
lexeme p = p SP.<* whitespace
bf :: repr [Instruction]
bf = SP.many (lexeme (SP.match (SP.look (SP.item @tok))
- (haskell . coerceEnum Prelude.<$> "<>+-,.[")
+ (SP.prod . coerceEnum Prelude.<$> "<>+-,.[")
op SP.empty))
- op :: H.Term H.ValueCode tok -> repr Instruction
- op (trans -> H.ValueCode c _) = case coerceEnum c of
- '<' -> SP.item @tok SP.$> SP.code Backward
- '>' -> SP.item @tok SP.$> SP.code Forward
- '+' -> SP.item @tok SP.$> SP.code Increment
- '-' -> SP.item @tok SP.$> SP.code Decrement
- ',' -> SP.item @tok SP.$> SP.code Input
- '.' -> SP.item @tok SP.$> SP.code Output
+ op :: SP.Production tok -> repr Instruction
+ op prod = case coerceEnum (SP.runValue prod) of
+ '<' -> SP.item @tok SP.$> SP.prod Backward
+ '>' -> SP.item @tok SP.$> SP.prod Forward
+ '+' -> SP.item @tok SP.$> SP.prod Increment
+ '-' -> SP.item @tok SP.$> SP.prod Decrement
+ ',' -> SP.item @tok SP.$> SP.prod Input
+ '.' -> SP.item @tok SP.$> SP.prod Output
'[' -> SP.between (lexeme (SP.item @tok))
(SP.token (coerceEnum @_ @tok ']'))
- (H.Term (H.ValueCode Loop [||Loop||]) SP.<$> bf)
+ (SP.production Loop [||Loop||] SP.<$> bf)
_ -> Prelude.undefined
+
+reproGrammar :: forall tok repr.
+ CoerceEnum Char tok =>
+ CoerceEnum tok Char =>
+ SP.Grammarable tok repr =>
+ repr [tok]
+reproGrammar = SP.many (SP.item @tok)
import qualified Prelude
import qualified Symantic.Parser as SP
import qualified Symantic.Parser.Grammar.Combinators
-import qualified Symantic.Parser.Haskell
import qualified Symantic.Parser.Machine
import qualified Symantic.Parser.Machine.Generate
import qualified Symantic.Parser.Machine.Input
import Symantic.Univariant.Trans
import qualified Symantic.Parser as P
-import qualified Symantic.Parser.Haskell as H
+import qualified Symantic.Univariant.Lang as H
type Parser a = P.Parser Text.Text a
charLit = P.between (P.char '\'') (symbol '\'') charChar
charChar :: repr ()
charChar = P.void (P.satisfy
- (trans (H.ValueCode nandStringLetter [||nandStringLetter||]))) P.<|> esc
+ (P.production nandStringLetter [||nandStringLetter||])) P.<|> esc
esc :: repr ()
esc = P.char '\\' P.*> P.void (P.oneOf "0tnvfr")
expr :: repr ()
identifier :: repr ()
identifier = P.try (identStart P.*> P.skipMany identLetter) P.*> whitespace
identStart = P.satisfy
- (trans (H.ValueCode nandIdentStart [||nandIdentStart||]))
+ (P.production nandIdentStart [||nandIdentStart||])
exprlist = commaSep expr
exprlist1 = commaSep1 expr
notIdentLetter = P.negLook identLetter
-}
identLetter = P.satisfy
- (trans (H.ValueCode nandIdentLetter [||nandIdentLetter||]))
+ (P.production nandIdentLetter [||nandIdentLetter||])
-- hexadecimal = P.oneOf "xX" P.*> number (P.oneOf (['a'..'f'] <> ['A'..'F'] <> ['0'..'9']))
-- octal = P.oneOf "oO" P.*> number (P.oneOf ['0'..'7'])
commaSep1 p = p P.*> P.skipMany (comma P.*> p)
space :: repr ()
- space = P.void (P.satisfy
- (trans (H.ValueCode isSpace [||isSpace||])))
+ space = P.void (P.satisfy (P.production isSpace [||isSpace||]))
whitespace :: repr ()
whitespace = spaces
{-
whitespace = P.skipMany (spaces P.<|> oneLineComment)
oneLineComment :: repr ()
oneLineComment = P.void (P.string "//" P.*> P.skipMany (P.satisfy
- (trans (H.ValueCode (/= '\n') [||(/= '\n')||]))))
+ (P.production (/= '\n') [||(/= '\n')||])))
-}
spaces :: repr ()
spaces = P.skipSome space
module Parsers.Playground where
import Symantic.Parser
-import qualified Symantic.Parser.Haskell as H
+import qualified Symantic.Univariant.Lang as H
boom :: CombApplicable repr => repr ()
boom =
class HideName a where
-- | Map all 'Name's to a constant in order to overcome
- -- cases where reseting 'TH.counter' is not enough
+ -- cases where resetting 'TH.counter' is not enough
-- to get deterministic 'TH.Name's.
hideName :: a -> a
instance HideName Body where
, module Symantic.Parser.Grammar.Fixity
, module Symantic.Parser.Grammar.Optimize
, module Symantic.Parser.Grammar.ObserveSharing
+ , module Symantic.Parser.Grammar.Production
, module Symantic.Parser.Grammar.Write
, module Symantic.Parser.Grammar.View
, Letable(..)
, Letsable(..)
) where
import Symantic.Parser.Grammar.Combinators
-import Symantic.Parser.Grammar.View
import Symantic.Parser.Grammar.Fixity
import Symantic.Parser.Grammar.ObserveSharing
import Symantic.Parser.Grammar.Optimize
+import Symantic.Parser.Grammar.Production
+import Symantic.Parser.Grammar.View
import Symantic.Parser.Grammar.Write
import Control.DeepSeq (NFData)
import qualified Language.Haskell.TH.Syntax as TH
import qualified Symantic.Univariant.Trans as Sym
-import qualified Symantic.Parser.Haskell as H
-
--- * Type 'TermGrammar'
-type TermGrammar = H.Term H.ValueCode
+import qualified Symantic.Univariant.Lang as H
+import qualified Symantic.Univariant.Data as Prod
+import qualified Symantic.Univariant.View
+import Symantic.Parser.Grammar.Production
-- * Type 'ReprComb'
type ReprComb = Type -> Type
-code :: TH.Lift a => a -> TermGrammar a
-code x = H.Term (H.ValueCode x [||x||])
-
-- * Class 'CombAlternable'
class CombAlternable repr where
-- | @('alt' es l r)@ parses @(l)@ and return its return value or,
infixl 3 <|>, <+>
-optionally :: CombApplicable repr => CombAlternable repr => repr a -> TermGrammar b -> repr b
+optionally :: CombApplicable repr => CombAlternable repr => repr a -> Production b -> repr b
optionally p x = p $> x <|> pure x
optional :: CombApplicable repr => CombAlternable repr => repr a -> repr ()
optional = flip optionally H.unit
-option :: CombApplicable repr => CombAlternable repr => TermGrammar a -> repr a -> repr a
+option :: CombApplicable repr => CombAlternable repr => Production a -> repr a -> repr a
option x p = p <|> pure x
choice :: CombAlternable repr => [repr a] -> repr a
manyTill :: CombApplicable repr => CombAlternable repr => repr a -> repr b -> repr [a]
manyTill p end = let go = end $> H.nil <|> p <:> go in go
+{-
+class CombProductionable repr where
+infixl 4 <$>, <&>, <$, $>
+data instance Failure CombProductionable
+-}
+
-- * Class 'CombApplicable'
-- | This is like the usual 'Functor' and 'Applicative' type classes
--- from the @base@ package, but using @('TermGrammar' a)@ instead of just @(a)@
+-- from the @base@ package, but using @('Production' a)@ instead of just @(a)@
-- to be able to use and pattern match on some usual terms of type @(a)@ (like 'H.id')
-- and thus apply some optimizations.
-- @(repr)@, for "representation", is the usual tagless-final abstraction
-- of type class like this one) will be interpreted.
class CombApplicable repr where
-- | @(a2b '<$>' ra)@ parses like @(ra)@ but maps its returned value with @(a2b)@.
- (<$>) :: TermGrammar (a -> b) -> repr a -> repr b
+ (<$>) :: Production (a -> b) -> repr a -> repr b
(<$>) f = (pure f <*>)
-- | Like '<$>' but with its arguments 'flip'-ped.
- (<&>) :: repr a -> TermGrammar (a -> b) -> repr b
+ (<&>) :: repr a -> Production (a -> b) -> repr b
(<&>) = flip (<$>)
-- | @(a '<$' rb)@ parses like @(rb)@ but discards its returned value by replacing it with @(a)@.
- (<$) :: TermGrammar a -> repr b -> repr a
+ (<$) :: Production a -> repr b -> repr a
(<$) x = (pure x <*)
-- | @(ra '$>' b)@ parses like @(ra)@ but discards its returned value by replacing it with @(b)@.
- ($>) :: repr a -> TermGrammar b -> repr b
+ ($>) :: repr a -> Production b -> repr b
($>) = flip (<$)
-- | @('pure' a)@ parses the empty string, always succeeding in returning @(a)@.
- pure :: TermGrammar a -> repr a
+ pure :: Production a -> repr a
default pure ::
Sym.Liftable repr => CombApplicable (Sym.Output repr) =>
- TermGrammar a -> repr a
+ Production a -> repr a
pure = Sym.lift . pure
-- | @(ra2b '<*>' ra)@ parses sequentially @(ra2b)@ and then @(ra)@,
repr (a -> b) -> repr a -> repr b
(<*>) = Sym.lift2 (<*>)
- -- | @('liftA2' a2b2c ra rb)@ parses sequentially @(ra)@ and then @(rb)@,
- -- and returns the application of @(a2b2c)@ to the values returned by those parsers.
- liftA2 :: TermGrammar (a -> b -> c) -> repr a -> repr b -> repr c
- liftA2 f x = (<*>) (f <$> x)
-
-- | @(ra '<*' rb)@ parses sequentially @(ra)@ and then @(rb)@,
-- and returns like @(ra)@, discarding the return value of @(rb)@.
(<*) :: repr a -> repr b -> repr a
(<**>) :: repr a -> repr (a -> b) -> repr b
(<**>) = liftA2 (\a f -> f a)
-}
-infixl 4 <$>, <&>, <$, $>, <*>, <*, *>, <**>
+ -- | @('liftA2' a2b2c ra rb)@ parses sequentially @(ra)@ and then @(rb)@,
+ -- and returns the application of @(a2b2c)@ to the values returned by those parsers.
+ liftA2 :: Production (a -> b -> c) -> repr a -> repr b -> repr c
+ liftA2 f x = (<*>) (f <$> x)
+
+infixl 4 <*>, <*, *>, <**>
data instance Failure CombApplicable
{-# INLINE (<:>) #-}
data instance Failure CombFoldable
{-
-conditional :: CombSelectable repr => [(TermGrammar (a -> Bool), repr b)] -> repr a -> repr b -> repr b
+conditional :: CombSelectable repr => [(Production (a -> Bool), repr b)] -> repr a -> repr b -> repr b
conditional cs p def = match p fs qs def
where (fs, qs) = List.unzip cs
-}
-- Parser Folds
pfoldr ::
CombApplicable repr => CombFoldable repr =>
- TermGrammar (a -> b -> b) -> TermGrammar b -> repr a -> repr b
+ Production (a -> b -> b) -> Production b -> repr a -> repr b
pfoldr f k p = chainPre (f <$> p) (pure k)
pfoldr1 ::
CombApplicable repr => CombFoldable repr =>
- TermGrammar (a -> b -> b) -> TermGrammar b -> repr a -> repr b
+ Production (a -> b -> b) -> Production b -> repr a -> repr b
pfoldr1 f k p = f <$> p <*> pfoldr f k p
pfoldl ::
CombApplicable repr => CombFoldable repr =>
- TermGrammar (b -> a -> b) -> TermGrammar b -> repr a -> repr b
+ Production (b -> a -> b) -> Production b -> repr a -> repr b
pfoldl f k p = chainPost (pure k) ((H.flip <$> pure f) <*> p)
pfoldl1 ::
CombApplicable repr => CombFoldable repr =>
- TermGrammar (b -> a -> b) -> TermGrammar b -> repr a -> repr b
+ Production (b -> a -> b) -> Production b -> repr a -> repr b
pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((H.flip <$> pure f) <*> p)
-- Chain Combinators
chainl1' ::
CombApplicable repr => CombFoldable repr =>
- TermGrammar (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
+ Production (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
chainl1' f p op = chainPost (f <$> p) (H.flip <$> op <*> p)
chainl1 ::
chainr1 :: repr a -> repr (a -> a -> a) -> repr a
chainr1 = chainr1' H.id
-chainr :: repr a -> repr (a -> a -> a) -> TermGrammar a -> repr a
+chainr :: repr a -> repr (a -> a -> a) -> Production a -> repr a
chainr p op x = option x (chainr1 p op)
-}
chainl ::
CombApplicable repr => CombAlternable repr => CombFoldable repr =>
- repr a -> repr (a -> a -> a) -> TermGrammar a -> repr a
+ repr a -> repr (a -> a -> a) -> Production a -> repr a
chainl p op x = option x (chainl1 p op)
-- Derived Combinators
-- * Class 'CombMatchable'
class CombMatchable repr where
conditional ::
- Eq a => repr a -> [TermGrammar (a -> Bool)] -> [repr b] -> repr b -> repr b
+ Eq a => repr a -> [Production (a -> Bool)] -> [repr b] -> repr b -> repr b
default conditional ::
Sym.Unliftable repr => Sym.Liftable1 repr => CombMatchable (Sym.Output repr) =>
- Eq a => repr a -> [TermGrammar (a -> Bool)] -> [repr b] -> repr b -> repr b
+ Eq a => repr a -> [Production (a -> Bool)] -> [repr b] -> repr b -> repr b
conditional a ps bs = Sym.lift1 (conditional (Sym.unlift a) ps (Sym.unlift Functor.<$> bs))
- match :: Eq a => repr a -> [TermGrammar a] -> (TermGrammar a -> repr b) -> repr b -> repr b
- match a as a2b = conditional a ((H.eq H..@) Functor.<$> as) (a2b Functor.<$> as)
+ match :: Eq a => repr a -> [Production a] -> (Production a -> repr b) -> repr b -> repr b
+ match a as a2b = conditional a ((H.equal H..@) Functor.<$> as) (a2b Functor.<$> as)
-- match a as a2b = conditional a (((H.eq H..@ H.qual) H..@) Functor.<$> as) (a2b Functor.<$> as)
data instance Failure CombMatchable
-- * Class 'CombSatisfiable'
class CombSatisfiable tok repr where
-- | Like 'satisfyOrFail' but with no custom failure.
- satisfy :: TermGrammar (tok -> Bool) -> repr tok
+ satisfy :: Production (tok -> Bool) -> repr tok
satisfy = satisfyOrFail Set.empty
-- | Like 'satisfy' but with a custom set of 'SomeFailure's.
satisfyOrFail ::
Set SomeFailure ->
- TermGrammar (tok -> Bool) -> repr tok
+ Production (tok -> Bool) -> repr tok
default satisfyOrFail ::
Sym.Liftable repr => CombSatisfiable tok (Sym.Output repr) =>
Set SomeFailure ->
- TermGrammar (tok -> Bool) -> repr tok
+ Production (tok -> Bool) -> repr tok
satisfyOrFail fs = Sym.lift . satisfyOrFail fs
data instance Failure (CombSatisfiable tok)
CombApplicable repr =>
CombSatisfiable Char repr =>
Char -> repr Char
-char c = satisfyOrFail (Set.singleton (SomeFailure (FailureToken c)))
- (H.eq H..@ H.char c) $> H.char c
+char c = satisfyOrFail
+ (Set.singleton (SomeFailure (FailureToken c)))
+ ((H.equal H..@ H.char c))
+ $> H.char c
item :: forall tok repr.
Eq tok => Show tok => Typeable tok => TH.Lift tok => NFData tok =>
CombSatisfiable tok repr => repr tok
-item = satisfyOrFail (Set.singleton (SomeFailure (FailureAny @tok)))
- (H.const H..@ H.bool True)
+item = satisfyOrFail
+ (Set.singleton (SomeFailure (FailureAny @tok)))
+ (H.const H..@ H.bool True)
anyChar ::
CombAlternable repr =>
[tok] -> repr tok
oneOf ts = satisfyOrFail
(Set.fromList (SomeFailure . FailureToken Functor.<$> ts))
- (Sym.trans H.ValueCode
- { value = (`List.elem` ts)
- , code = [||\t -> $$(ofChars ts [||t||])||] })
+ (production
+ (`List.elem` ts)
+ [||\t -> $$(ofChars ts [||t||])||])
noneOf ::
TH.Lift tok => Eq tok =>
CombSatisfiable tok repr =>
[tok] -> repr tok
-noneOf cs = satisfy (Sym.trans H.ValueCode
- { value = not . (`List.elem` cs)
- , code = [||\c -> not $$(ofChars cs [||c||])||]
- })
+noneOf cs = satisfy (production
+ (not . (`List.elem` cs))
+ [||\c -> not $$(ofChars cs [||c||])||])
ofChars ::
TH.Lift tok => Eq tok =>
more = look (void (item @Char))
token ::
- TH.Lift tok => Show tok => Eq tok =>
+ TH.Lift tok => Show tok => Eq tok => Typeable tok =>
CombAlternable repr =>
CombApplicable repr =>
CombSatisfiable tok repr =>
tok -> repr tok
-token tok = satisfy (H.eq H..@ H.char tok) $> H.char tok
+token tok = satisfy (H.equal H..@ H.constant tok) $> H.constant tok
-- token tok = satisfy [ExceptionToken tok] (H.eq H..@ H.qual H..@ H.char tok) $> H.char tok
tokens ::
- TH.Lift tok => Eq tok => Show tok =>
+ TH.Lift tok => Eq tok => Show tok => Typeable tok =>
CombApplicable repr => CombAlternable repr =>
CombSatisfiable tok repr => [tok] -> repr [tok]
tokens = try . traverse token
-- Lift Operations
liftA2 ::
CombApplicable repr =>
- TermGrammar (a -> b -> c) -> repr a -> repr b -> repr c
+ Production (a -> b -> c) -> repr a -> repr b -> repr c
liftA2 f x = (<*>) (fmap f x)
liftA3 ::
CombApplicable repr =>
- TermGrammar (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
+ Production (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
liftA3 f a b c = liftA2 f a b <*> c
-}
import Data.Bool (Bool(..))
import Data.Either (Either(..), either)
import Data.Eq (Eq(..))
-import Data.Function ((.))
+import Data.Function (($), (.))
import Data.Kind (Constraint)
import Data.Maybe (Maybe(..))
import Data.Set (Set)
+import Data.Functor.Identity (Identity(..))
import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..))
import qualified Data.Foldable as Foldable
import qualified Data.Functor as Functor
import qualified Data.List as List
import Symantic.Parser.Grammar.Combinators hiding (code)
-import Symantic.Parser.Haskell ()
+import qualified Symantic.Parser.Grammar.Production as Prod
+import Symantic.Parser.Grammar.Production
import Symantic.Univariant.Letable
import Symantic.Univariant.Trans
-import qualified Symantic.Parser.Haskell as H
+import qualified Symantic.Univariant.Lang as H
+import qualified Symantic.Univariant.Data as H
{-
import Data.Function (($), flip)
-- This is an extensible data-type.
data family Comb
(comb :: ReprComb -> Constraint)
- (repr :: ReprComb)
- :: ReprComb
+ :: ReprComb -> ReprComb
-- | Convenient utility to pattern-match a 'SomeComb'.
pattern Comb :: Typeable comb => Comb comb repr a -> SomeComb repr a
-- CombApplicable
data instance Comb CombApplicable repr a where
- Pure :: TermGrammar a -> Comb CombApplicable repr a
+ Pure :: Production a -> Comb CombApplicable repr a
(:<*>:) :: SomeComb repr (a -> b) -> SomeComb repr a -> Comb CombApplicable repr b
(:<*:) :: SomeComb repr a -> SomeComb repr b -> Comb CombApplicable repr a
(:*>:) :: SomeComb repr a -> SomeComb repr b -> Comb CombApplicable repr b
infixl 4 :<*>:, :<*:, :*>:
-pattern (:<$>:) :: TermGrammar (a -> b) -> SomeComb repr a -> Comb CombApplicable repr b
+pattern (:<$>:) :: Production (a -> b) -> SomeComb repr a -> Comb CombApplicable repr b
pattern t :<$>: x <- Comb (Pure t) :<*>: x
-pattern (:$>:) :: SomeComb repr a -> TermGrammar b -> Comb CombApplicable repr b
+pattern (:$>:) :: SomeComb repr a -> Production b -> Comb CombApplicable repr b
pattern x :$>: t <- x :*>: Comb (Pure t)
instance CombApplicable repr => Trans (Comb CombApplicable repr) repr where
trans = \case
- Pure x -> pure (H.optimizeTerm x)
+ Pure x -> pure (optimizeProduction x)
f :<*>: x -> trans f <*> trans x
x :<*: y -> trans x <* trans y
x :*>: y -> trans x *> trans y
data instance Comb CombMatchable repr a where
Conditional :: Eq a =>
SomeComb repr a ->
- [TermGrammar (a -> Bool)] ->
+ [Production (a -> Bool)] ->
[SomeComb repr b] ->
SomeComb repr b ->
Comb CombMatchable repr b
trans = \case
Conditional a ps bs b ->
conditional (trans a)
- (H.optimizeTerm Functor.<$> ps)
+ (optimizeProduction Functor.<$> ps)
(trans Functor.<$> bs) (trans b)
instance
( CombApplicable repr
conditional a _ps bs (Comb Empty)
| Foldable.all (\case { Comb Empty -> True; _ -> False }) bs = a *> empty
-- & trace "Conditional Weakening Law"
- conditional (Comb (Pure (trans -> a))) ps bs d =
- Foldable.foldr (\(trans -> p, b) next ->
- if H.value p (H.value a) then b else next
+ conditional (Comb (Pure a)) ps bs d =
+ Foldable.foldr (\(p, b) next ->
+ if runValue (p H..@ a) then b else next
) d (List.zip ps bs)
-- & trace "Conditional Pure Law"
conditional a ps bs d = SomeComb (Conditional a ps bs d)
SatisfyOrFail ::
CombSatisfiable tok repr =>
Set SomeFailure ->
- TermGrammar (tok -> Bool) ->
+ Production (tok -> Bool) ->
Comb (CombSatisfiable tok) repr tok
instance
CombSatisfiable tok repr =>
Trans (Comb (CombSatisfiable tok) repr) repr where
trans = \case
- SatisfyOrFail fs p -> satisfyOrFail fs (H.optimizeTerm p)
+ SatisfyOrFail fs p -> satisfyOrFail fs (optimizeProduction p)
instance
(CombSatisfiable tok repr, Typeable tok) =>
CombSatisfiable tok (SomeComb repr) where
-- & trace "Branch Absorption Law"
branch b (Comb Empty) (Comb Empty) = b *> empty
-- & trace "Branch Weakening Law"
- branch (Comb (Pure (trans -> lr))) l r =
- case H.value lr of
- Left value -> l <*> pure (trans H.ValueCode{..})
- where code = [|| case $$(H.code lr) of Left x -> x ||]
- Right value -> r <*> pure (trans H.ValueCode{..})
- where code = [|| case $$(H.code lr) of Right x -> x ||]
- -- & trace "Branch Pure Left/Right Law"
- branch b (Comb (Pure (trans -> l))) (Comb (Pure (trans -> r))) =
- trans H.ValueCode{..} <$> b
+ branch (Comb (Pure lr)) l r =
+ case runValue lr of
+ Left value -> l <*> pure Production{..}
+ where
+ prodValue = H.SomeData $ H.Var $ Identity value
+ prodCode = H.SomeData $ H.Var
+ [|| case $$(runCode lr) of Left x -> x ||]
+ Right value -> r <*> pure Production{..}
+ where
+ prodValue = H.SomeData $ H.Var $ Identity value
+ prodCode = H.SomeData $ H.Var
+ [|| case $$(runCode lr) of Right x -> x ||]
+ -- & trace "Branch Pure Either Law"
+ branch b (Comb (Pure l)) (Comb (Pure r)) =
+ Production{..} <$> b
-- & trace "Branch Generalised Identity Law"
where
- value = either (H.value l) (H.value r)
- code = [|| either $$(H.code l) $$(H.code r) ||]
+ prodValue = H.SomeData $ H.Var $ Identity $ either (runValue l) (runValue r)
+ prodCode = H.SomeData $ H.Var [|| either $$(runCode l) $$(runCode r) ||]
branch (Comb (x :*>: y)) p q = x *> branch y p q
-- & trace "Interchange Law"
branch b l (Comb Empty) =
- branch (pure (trans (H.ValueCode{..})) <*> b) empty l
+ branch (pure Production{..} <*> b) empty l
-- & trace "Negated Branch Law"
where
- value = either Right Left
- code = [||either Right Left||]
- branch (Comb (Branch b (Comb Empty) (Comb (Pure (trans -> lr))))) (Comb Empty) br =
- branch (pure (trans H.ValueCode{..}) <*> b) empty br
+ prodValue = H.SomeData $ H.Var $ Identity $ either Right Left
+ prodCode = H.SomeData $ H.Var $ [||either Right Left||]
+ branch (Comb (Branch b (Comb Empty) (Comb (Pure lr)))) (Comb Empty) br =
+ branch (pure Production{..} <*> b) empty br
-- & trace "Branch Fusion Law"
where
- value Left{} = Left ()
- value (Right r) = case H.value lr r of
- Left _ -> Left ()
- Right rr -> Right rr
- code = [|| \case Left{} -> Left ()
- Right r -> case $$(H.code lr) r of
- Left _ -> Left ()
- Right rr -> Right rr ||]
+ prodValue = H.SomeData $ H.Var $ Identity $ \case
+ Left{} -> Left ()
+ Right r ->
+ case runValue lr r of
+ Left{} -> Left ()
+ Right rr -> Right rr
+ prodCode = H.SomeData $ H.Var
+ [|| \case Left{} -> Left ()
+ Right r -> case $$(runCode lr) r of
+ Left{} -> Left ()
+ Right rr -> Right rr ||]
branch b l r = SomeComb (Branch b l r)
--- /dev/null
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Symantic.Parser.Grammar.Production where
+
+import Data.Bool (Bool(..))
+import Data.Char (Char)
+import Data.Eq (Eq)
+import Data.Functor.Identity (Identity(..))
+import Prelude (undefined)
+import Text.Show (Show(..), showString)
+import qualified Data.Either as Either
+import qualified Data.Eq as Eq
+import qualified Data.Function as Fun
+import qualified Data.Maybe as Maybe
+import qualified Language.Haskell.TH as TH
+import qualified Language.Haskell.TH.Syntax as TH
+import Type.Reflection (Typeable)
+
+import Symantic.Univariant.Data
+import Symantic.Univariant.Lang
+import Symantic.Univariant.Optim
+import Symantic.Univariant.Trans
+import Symantic.Univariant.View
+
+import Debug.Trace
+
+-- * Type 'Production'
+data Production a
+ = Production
+ { prodValue :: SomeData Identity a
+ , prodCode :: SomeData TH.CodeQ a
+ --, prodView :: SomeData View a
+ }
+
+production :: a -> TH.CodeQ a -> Production a
+production v c = Production
+ { prodValue = SomeData (Var (Identity v))
+ , prodCode = SomeData (Var c)
+ }
+
+prod :: TH.Lift a => a -> Production a
+prod x = production x [||x||]
+
+runValue :: Production a -> a
+runValue x = runIdentity (trans x)
+runCode :: Production a -> TH.CodeQ a
+runCode = trans
+
+instance Trans Production Identity where
+ trans Production{prodValue = SomeData x} = trans x
+instance Trans Production TH.CodeQ where
+ trans Production{prodCode = SomeData x} = trans x
+
+instance Abstractable Production where
+ var = Fun.id
+ f .@ x = Production
+ { prodValue = prodValue f .@ prodValue x
+ , prodCode = prodCode f .@ prodCode x
+ }
+ lam f = Production
+ { prodValue = lam (\x -> prodValue (f Production{prodValue = x}))
+ , prodCode = lam (\x -> prodCode (f Production{prodCode = x}))
+ }
+ lam1 f = Production
+ { prodValue = lam1 (\x -> prodValue (f Production{prodValue = x}))
+ , prodCode = lam1 (\x -> prodCode (f Production{prodCode = x}))
+ }
+ const = Production const const
+ ($) = Production ($) ($)
+ (.) = Production (.) (.)
+ flip = Production flip flip
+ id = Production id id
+instance Eitherable Production where
+ left = Production left left
+ right = Production right right
+instance (TH.Lift c, Typeable c) => Constantable c Production where
+ constant c = Production (constant c) (constant c)
+instance Maybeable Production where
+ nothing = Production nothing nothing
+ just = Production just just
+instance Listable Production where
+ nil = Production nil nil
+ cons = Production cons cons
+instance Equalable Production where
+ equal = Production equal equal
+
+optimizeProduction :: Production a -> Production a
+optimizeProduction p = Production
+ { prodValue = normalOrderReduction (prodValue p)
+ , prodCode = normalOrderReduction (prodCode p)
+ }
+
+{-
+class Tokenable repr where
+ token :: tok -> repr tok
+ default token ::
+ Liftable repr => Tokenable (Output repr) =>
+ tok -> repr tok
+ token = lift Fun.. token
+
+instance Show (SomeData ValueCode a) where
+ showsPrec p (SomeData x) = showsPrec p (trans @_ @View x)
+-}
+
+{-
+-- * Type 'ValueCode'
+data ValueCode a = ValueCode
+ { value :: a
+ , code :: TH.CodeQ a
+ }
+instance Trans ValueCode ValueCode where
+ trans = Fun.id
+instance Abstractable ValueCode where
+ f .@ x = ValueCode
+ { value = runIdentity (Identity (value f) .@ (Identity (value x)))
+ , code = code f .@ code x
+ }
+ lam f = ValueCode
+ { value = runIdentity (lam (Identity Fun.. value Fun.. f Fun.. (`ValueCode` undefined) Fun.. runIdentity))
+ , code = lam (code Fun.. f Fun.. ValueCode undefined)
+ }
+ lam1 = lam
+ const = ValueCode (runIdentity const) const
+ flip = ValueCode (runIdentity flip) flip
+ id = ValueCode (runIdentity id) id
+ ($) = ValueCode (runIdentity ($)) ($)
+ (.) = ValueCode (runIdentity (.)) (.)
+instance Anythingable ValueCode
+instance TH.Lift c => Constantable c ValueCode where
+ constant c = ValueCode (runIdentity (constant c)) (constant c)
+instance Listable ValueCode where
+ cons = ValueCode (runIdentity cons) cons
+ nil = ValueCode (runIdentity nil) nil
+instance Equalable ValueCode where
+ equal = ValueCode (runIdentity equal) equal
+instance Eitherable ValueCode where
+ left = ValueCode (runIdentity left) left
+ right = ValueCode (runIdentity right) right
+instance Maybeable ValueCode where
+ nothing = ValueCode (runIdentity nothing) nothing
+ just = ValueCode (runIdentity just) just
+-}
+
+-- Identity
+instance Anythingable Identity
+instance Abstractable Identity where
+ f .@ x = Identity (runIdentity f (runIdentity x))
+ lam f = Identity (runIdentity Fun.. f Fun.. Identity)
+ lam1 = lam
+ var = Fun.id
+ const = Identity Fun.const
+ flip = Identity Fun.flip
+ id = Identity Fun.id
+ ($) = Identity (Fun.$)
+ (.) = Identity (Fun..)
+instance Constantable c Identity where
+ constant = Identity
+instance Eitherable Identity where
+ left = Identity Either.Left
+ right = Identity Either.Right
+instance Equalable Identity where
+ equal = Identity (Eq.==)
+instance Listable Identity where
+ cons = Identity (:)
+ nil = Identity []
+instance Maybeable Identity where
+ nothing = Identity Maybe.Nothing
+ just = Identity Maybe.Just
+
+-- TH.CodeQ
+instance Anythingable TH.CodeQ
+instance Abstractable TH.CodeQ where
+ (.@) f x = [|| $$f $$x ||]
+ lam f = [|| \x -> $$(f [||x||]) ||]
+ lam1 = lam
+ var = Fun.id
+ id = [|| \x -> x ||]
+ const = [|| Fun.const ||]
+ flip = [|| \f x y -> f y x ||]
+ ($) = [|| (Fun.$) ||]
+ (.) = [|| (Fun..) ||]
+instance TH.Lift c => Constantable c TH.CodeQ where
+ constant c = [|| c ||]
+instance Eitherable TH.CodeQ where
+ left = [|| Either.Left ||]
+ right = [|| Either.Right ||]
+instance Equalable TH.CodeQ where
+ equal = [|| (Eq.==) ||]
+instance Listable TH.CodeQ where
+ cons = [|| (:) ||]
+ nil = [|| [] ||]
+instance Maybeable TH.CodeQ where
+ nothing = [|| Maybe.Nothing ||]
+ just = [|| Maybe.Just ||]
import Data.String (String)
import Data.Tuple (fst)
import Text.Show (Show(..))
-import qualified Control.Applicative as Fct
import qualified Data.Functor as Functor
import qualified Data.HashMap.Strict as HM
import qualified Data.List as List
import qualified Data.Tree as Tree
import Symantic.Univariant.Letable
+import qualified Symantic.Univariant.Trans as Sym
+import qualified Symantic.Univariant.Data as Sym
+import qualified Symantic.Univariant.View as Sym
import Symantic.Parser.Grammar.Combinators
+import qualified Symantic.Parser.Grammar.Production as Prod
-- * Type 'ViewGrammar'
newtype ViewGrammar (showName::Bool) a = ViewGrammar { unViewGrammar ::
try x = ViewGrammar $ Tree.Node ("try", "") [unViewGrammar x]
instance CombApplicable (ViewGrammar sN) where
_f <$> x = ViewGrammar $ Tree.Node ("<$>", "") [unViewGrammar x]
- pure a = ViewGrammar $ Tree.Node ("pure "<>showsPrec 10 a "", "") []
+ pure a = ViewGrammar $ Tree.Node ("pure "{-FIXME: <>showsPrec 10 a ""-}, "") []
x <*> y = ViewGrammar $ Tree.Node ("<*>", "") [unViewGrammar x, unViewGrammar y]
x <* y = ViewGrammar $ Tree.Node ("<*", "") [unViewGrammar x, unViewGrammar y]
x *> y = ViewGrammar $ Tree.Node ("*>", "") [unViewGrammar x, unViewGrammar y]
instance CombMatchable (ViewGrammar sN) where
conditional a _ps bs b = ViewGrammar $ Tree.Node ("conditional", "")
[ unViewGrammar a
- , Tree.Node ("branches", "") (unViewGrammar Fct.<$> bs)
+ , Tree.Node ("branches", "") (unViewGrammar Functor.<$> bs)
, unViewGrammar b
]
instance CombSatisfiable tok (ViewGrammar sN) where
+++ /dev/null
-module Symantic.Parser.Haskell
- ( module Symantic.Parser.Haskell.Optimize
- , module Symantic.Parser.Haskell.Term
- , module Symantic.Parser.Haskell.View
- ) where
-import Symantic.Parser.Haskell.Optimize
-import Symantic.Parser.Haskell.Term
-import Symantic.Parser.Haskell.View
Lam1 f -> whnf (f y)
x' -> x' :@ y
x -> x
-
-instance Trans (Term Identity) Identity where
- trans = \case
- Cons -> cons
- Char t -> char t
- Eq -> eq
- Term repr -> repr
- x :@ y -> Identity (runIdentity (trans x) (runIdentity (trans y)))
- Lam f -> Identity (runIdentity Fun.. trans Fun.. f Fun.. Term Fun.. Identity)
- Lam1 f -> trans (Lam f)
- Var{} -> undefined
- {-
- Const -> const
- Flip -> flip
- Id -> id
- (:$) -> ($)
- -}
-instance Trans (Term TH.CodeQ) TH.CodeQ where
- -- Superfluous pattern-matches are only here
- -- for cosmetic concerns when reading *.dump-splices,
- -- not for optimizing, which is done in 'optimizeTerm'.
- trans = \case
- Cons :@ x :@ y -> [|| $$(trans x) : $$(trans y) ||]
- Cons :@ x -> [|| ($$(trans x) :) ||]
- Cons -> cons
- Char t -> char t
- Eq :@ x :@ y -> [|| $$(trans x) Eq.== $$(trans y) ||]
- Eq :@ x -> [|| ($$(trans x) Eq.==) ||]
- Eq -> eq
- Term repr -> repr
- -- (:$) :@ x -> [|| ($$(trans x) Fun.$) ||]
- -- (:.) :@ f :@ g -> [|| \xx -> $$(trans f) ($$(trans g) xx) ||]
- -- (:.) :@ (:.) -> [|| \f x -> (\g y -> (f x) (g y)) ||]
- -- (:.) :@ x :@ y -> [|| $$(trans x) Fun.. $$(trans y) ||]
- -- (:.) :@ x -> [|| ($$(trans x) Fun..) ||]
- -- (:.) :@ f -> [|| \g x -> $$(trans f) (g x) ||]
- -- (:.) -> (.)
- x :@ y -> [|| $$(trans x) $$(trans y) ||]
- Lam f -> [|| \x -> $$(trans (f (Term [||x||]))) ||]
- Lam1 f -> trans (Lam f)
- Var{} -> undefined
- {-
- Const -> const
- Flip -> flip
- Id -> id
- (:$) -> ($)
- -}
-instance Trans (Term ValueCode) ValueCode where
- trans = \case
- Term x -> x
- Char c -> char c
- Cons -> cons
- Eq -> eq
- (:@) f x -> (.@) (trans f) (trans x)
- Lam f -> ValueCode
- { value = value Fun.. trans Fun.. f Fun.. Term Fun.. (`ValueCode` undefined)
- , code = [|| \x -> $$(code Fun.. trans Fun.. f Fun.. Term Fun.. (undefined `ValueCode`) Fun.$ [||x||]) ||]
- }
- Lam1 f -> trans (Lam f)
- Var{} -> undefined
- {-
- Const -> const
- Flip -> flip
- Id -> id
- (:$) -> ($)
- -}
-instance Trans (Term ValueCode) (Term TH.CodeQ) where
- trans = \case
- Term x -> Term (code x)
- Char c -> char c
- Cons -> cons
- Eq -> eq
- (:@) f x -> (.@) (trans f) (trans x)
- Lam f -> Lam (\x -> trans (f (trans x)))
- Lam1 f -> Lam1 (\x -> trans (f (trans x)))
- Var v -> Var v
- {-
- Const -> const
- Flip -> flip
- Id -> id
- (:$) -> ($)
- -}
-instance Trans (Term TH.CodeQ) (Term ValueCode) where
- trans = \case
- Term x -> Term (ValueCode undefined x)
- Char c -> char c
- Cons -> cons
- Eq -> eq
- (:@) f x -> (.@) (trans f) (trans x)
- Lam f -> Lam (\x -> trans (f (trans x)))
- Lam1 f -> Lam1 (\x -> trans (f (trans x)))
- Var v -> Var v
- {-
- Const -> const
- Flip -> flip
- Id -> id
- (:$) -> ($)
- -}
module Symantic.Parser.Haskell.Term where
import Data.Bool (Bool(..))
+import Data.Char (Char)
import Data.Either (Either(..))
import Data.Eq (Eq)
import Data.Maybe (Maybe(..))
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
-import qualified Symantic.Univariant.Trans as Sym
-
--- * Class 'Termable'
--- | Single-out some Haskell terms in order to
-class Termable repr where
+import Symantic.Univariant.Trans
+{-
+class Abstractable repr where
-- | Application, aka. unabstract.
- (.@) :: repr (a->b) -> repr a -> repr b
+ (.@) :: repr (a->b) -> repr a -> repr b; infixl 9 .@
-- | Lambda term abstraction, in HOAS (Higher-Order Abstract Syntax) style.
lam :: (repr a -> repr b) -> repr (a->b)
-- | Like 'lam' but whose argument is used only once,
-- hence safe to beta-reduce (inline) without duplicating work.
lam1 :: (repr a -> repr b) -> repr (a->b)
-
- -- Singled-out terms
- bool :: Bool -> repr Bool
- char :: (TH.Lift tok, Show tok) => tok -> repr tok
- cons :: repr (a -> [a] -> [a])
- nil :: repr [a]
- eq :: Eq a => repr (a -> a -> Bool)
- unit :: repr ()
- left :: repr (l -> Either l r)
- right :: repr (r -> Either l r)
- nothing :: repr (Maybe a)
- just :: repr (a -> Maybe a)
const :: repr (a -> b -> a)
flip :: repr ((a -> b -> c) -> b -> a -> c)
id :: repr (a->a)
- (.) :: repr ((b->c) -> (a->b) -> a -> c)
- ($) :: repr ((a->b) -> a -> b)
-
+ (.) :: repr ((b->c) -> (a->b) -> a -> c); infixr 9 .
+ ($) :: repr ((a->b) -> a -> b); infixr 0 $
default (.@) ::
- Sym.Liftable2 repr => Termable (Sym.Output repr) =>
+ Liftable2 repr => Abstractable (Output repr) =>
repr (a->b) -> repr a -> repr b
default lam ::
- Sym.Liftable repr => Sym.Unliftable repr => Termable (Sym.Output repr) =>
+ Liftable repr => Unliftable repr => Abstractable (Output repr) =>
(repr a -> repr b) -> repr (a->b)
default lam1 ::
- Sym.Liftable repr => Sym.Unliftable repr => Termable (Sym.Output repr) =>
+ Liftable repr => Unliftable repr => Abstractable (Output repr) =>
(repr a -> repr b) -> repr (a->b)
+ default const ::
+ Liftable repr => Abstractable (Output repr) =>
+ repr (a -> b -> a)
+ default flip ::
+ Liftable repr => Abstractable (Output repr) =>
+ repr ((a -> b -> c) -> b -> a -> c)
+ default id ::
+ Liftable repr => Abstractable (Output repr) =>
+ repr (a->a)
+ default (.) ::
+ Liftable repr => Abstractable (Output repr) =>
+ repr ((b->c) -> (a->b) -> a -> c)
+ default ($) ::
+ Liftable repr => Abstractable (Output repr) =>
+ repr ((a->b) -> a -> b)
+ (.@) = lift2 (.@)
+ lam f = lift (lam (trans Fun.. f Fun.. trans))
+ lam1 f = lift (lam1 (trans Fun.. f Fun.. trans))
+ const = lift const
+ flip = lift flip
+ id = lift id
+ (.) = lift (.)
+ ($) = lift ($)
+class Boolable repr where
+ bool :: Bool -> repr Bool
default bool ::
- Sym.Liftable repr => Termable (Sym.Output repr) =>
+ Liftable repr => Boolable (Output repr) =>
Bool -> repr Bool
+ bool = lift Fun.. bool
+class Charable repr where
+ char :: Char -> repr Char
default char ::
- Sym.Liftable repr => Termable (Sym.Output repr) =>
- TH.Lift tok => Show tok =>
- tok -> repr tok
- default cons ::
- Sym.Liftable repr => Termable (Sym.Output repr) =>
- repr (a -> [a] -> [a])
- default nil ::
- Sym.Liftable repr => Termable (Sym.Output repr) =>
- repr [a]
- default eq ::
- Sym.Liftable repr => Termable (Sym.Output repr) =>
- Eq a => repr (a -> a -> Bool)
- default unit ::
- Sym.Liftable repr => Termable (Sym.Output repr) =>
- repr ()
+ Liftable repr => Charable (Output repr) =>
+ Char -> repr Char
+ char = lift Fun.. char
+class Eitherable repr where
+ left :: repr (l -> Either l r)
+ right :: repr (r -> Either l r)
default left ::
- Sym.Liftable repr => Termable (Sym.Output repr) =>
+ Liftable repr => Eitherable (Output repr) =>
repr (l -> Either l r)
default right ::
- Sym.Liftable repr => Termable (Sym.Output repr) =>
+ Liftable repr => Eitherable (Output repr) =>
repr (r -> Either l r)
+ left = lift left
+ right = lift right
+class Equalable repr where
+ eq :: Eq a => repr (a -> a -> Bool)
+ default eq ::
+ Liftable repr => Equalable (Output repr) =>
+ Eq a => repr (a -> a -> Bool)
+ eq = lift eq
+class Listable repr where
+ cons :: repr (a -> [a] -> [a])
+ nil :: repr [a]
+ default cons ::
+ Liftable repr => Listable (Output repr) =>
+ repr (a -> [a] -> [a])
+ default nil ::
+ Liftable repr => Listable (Output repr) =>
+ repr [a]
+ cons = lift cons
+ nil = lift nil
+class Maybeable repr where
+ nothing :: repr (Maybe a)
+ just :: repr (a -> Maybe a)
default nothing ::
- Sym.Liftable repr => Termable (Sym.Output repr) =>
+ Liftable repr => Maybeable (Output repr) =>
repr (Maybe a)
default just ::
- Sym.Liftable repr => Termable (Sym.Output repr) =>
+ Liftable repr => Maybeable (Output repr) =>
repr (a -> Maybe a)
- default const ::
- Sym.Liftable repr => Termable (Sym.Output repr) =>
- repr (a -> b -> a)
- default flip ::
- Sym.Liftable repr => Termable (Sym.Output repr) =>
- repr ((a -> b -> c) -> b -> a -> c)
- default id ::
- Sym.Liftable repr => Termable (Sym.Output repr) =>
- repr (a->a)
- default (.) ::
- Sym.Liftable repr => Termable (Sym.Output repr) =>
- repr ((b->c) -> (a->b) -> a -> c)
- default ($) ::
- Sym.Liftable repr => Termable (Sym.Output repr) =>
- repr ((a->b) -> a -> b)
-
- (.@) = Sym.lift2 (.@)
- lam f = Sym.lift (lam (Sym.trans Fun.. f Fun.. Sym.trans))
- lam1 f = Sym.lift (lam1 (Sym.trans Fun.. f Fun.. Sym.trans))
- bool = Sym.lift Fun.. bool
- char = Sym.lift Fun.. char
- cons = Sym.lift cons
- nil = Sym.lift nil
- eq = Sym.lift eq
- unit = Sym.lift unit
- left = Sym.lift left
- right = Sym.lift right
- nothing = Sym.lift nothing
- just = Sym.lift just
- const = Sym.lift const
- flip = Sym.lift flip
- id = Sym.lift id
- (.) = Sym.lift (.)
- ($) = Sym.lift ($)
-infixr 0 $
-infixr 9 .
-infixl 9 .@
+ nothing = lift nothing
+ just = lift just
+class Unitable repr where
+ unit :: repr ()
+ default unit ::
+ Liftable repr => Unitable (Output repr) =>
+ repr ()
+ unit = lift unit
--- * Type 'ValueCode'
-data ValueCode a = ValueCode
- { value :: a
- , code :: TH.CodeQ a
- }
-instance Termable ValueCode where
- f .@ x = ValueCode
- { value = runIdentity (Identity (value f) .@ (Identity (value x)))
- , code = code f .@ code x
- }
- lam f = ValueCode
- { value = runIdentity (lam (Identity Fun.. value Fun.. f Fun.. (`ValueCode` undefined) Fun.. runIdentity))
- , code = lam (code Fun.. f Fun.. ValueCode undefined)
- }
- lam1 = lam
- bool b = ValueCode (runIdentity (bool b)) (bool b)
- char c = ValueCode (runIdentity (char c)) (char c)
- cons = ValueCode (runIdentity cons) cons
- nil = ValueCode (runIdentity nil) nil
- eq = ValueCode (runIdentity eq) eq
- unit = ValueCode (runIdentity unit) unit
- left = ValueCode (runIdentity left) left
- right = ValueCode (runIdentity right) right
- nothing = ValueCode (runIdentity nothing) nothing
- just = ValueCode (runIdentity just) just
- const = ValueCode (runIdentity const) const
- flip = ValueCode (runIdentity flip) flip
- id = ValueCode (runIdentity id) id
- ($) = ValueCode (runIdentity ($)) ($)
- (.) = ValueCode (runIdentity (.)) (.)
-instance Termable Identity where
- f .@ x = Identity (runIdentity f (runIdentity x))
- lam f = Identity (runIdentity Fun.. f Fun.. Identity)
- lam1 = lam
- bool = Identity
- char = Identity
- cons = Identity (:)
- nil = Identity []
- eq = Identity (Eq.==)
- unit = Identity ()
- left = Identity Left
- right = Identity Right
- nothing = Identity Nothing
- just = Identity Just
- const = Identity Fun.const
- flip = Identity Fun.flip
- id = Identity Fun.id
- ($) = Identity (Fun.$)
- (.) = Identity (Fun..)
-instance Termable TH.CodeQ where
- (.@) f x = [|| $$f $$x ||]
- lam f = [|| \x -> $$(f [||x||]) ||]
- lam1 = lam
- bool b = [|| b ||]
- char c = [|| c ||]
- cons = [|| (:) ||]
- nil = [|| [] ||]
- eq = [|| (Eq.==) ||]
- unit = [|| () ||]
- left = [|| Left ||]
- right = [|| Right ||]
- nothing = [|| Nothing ||]
- just = [|| Just ||]
- const = [|| Fun.const ||]
- id = [|| \x -> x ||]
- flip = [|| \f x y -> f y x ||]
- ($) = [|| (Fun.$) ||]
- (.) = [|| (Fun..) ||]
+-}
+++ /dev/null
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Symantic.Parser.Haskell.View where
-
-import Data.Bool
-import Data.Function (($), (.))
-import Data.Int (Int)
-import Data.Semigroup (Semigroup(..))
-import Data.String (IsString(..), String)
-import Prelude ((+))
-import Text.Show (Show(..), ShowS, shows, showParen, showString)
-import qualified Data.Function as Fun
-
-import Symantic.Parser.Grammar.Fixity
-import qualified Symantic.Parser.Haskell.Optimize as H
-
--- * Type 'ViewTerm'
-newtype ViewTerm a = ViewTerm { unViewTerm ::
- ViewTermInh -> ShowS }
-
-instance IsString (ViewTerm a) where
- fromString s = ViewTerm $ \_inh -> showString s
-
--- ** Type 'ViewTermInh'
-data ViewTermInh
- = ViewTermInh
- { viewTermInh_op :: (Infix, Side)
- , viewTermInh_pair :: Pair
- , viewTermInh_lamDepth :: Int
- }
-
-pairViewTerm :: ViewTermInh -> Infix -> ShowS -> ShowS
-pairViewTerm inh op s =
- if isPairNeeded (viewTermInh_op inh) op
- then showString o . s . showString c
- else s
- where (o,c) = viewTermInh_pair inh
-
-instance Show (ViewTerm a) where
- showsPrec p v = unViewTerm v ViewTermInh
- { viewTermInh_op = (infixN p, SideL)
- , viewTermInh_pair = pairParen
- , viewTermInh_lamDepth = 1
- }
-instance Show (H.Term repr a) where
- showsPrec p = showsPrec p . go
- where
- go :: forall b. H.Term repr b -> ViewTerm b
- go = \case
- H.Term{} -> "Term"
- {-
- (H.:.) H.:@ f H.:@ g -> ViewTerm $ \inh ->
- pairViewTerm inh op Fun.$
- unViewTerm (go f) inh{viewTermInh_op=op} Fun..
- showString " . " Fun..
- unViewTerm (go g) inh{viewTermInh_op=op}
- where op = infixR 9
- (H.:.) -> "(.)"
- -}
- {-
- H.Char t -> ViewTerm $ \_inh ->
- showString "(char " .
- shows t .
- showString ")"
- -}
- H.Char t -> ViewTerm $ \_inh -> shows t
- H.Cons H.:@ x H.:@ xs -> ViewTerm $ \inh ->
- pairViewTerm inh op Fun.$
- unViewTerm (go x) inh{viewTermInh_op=(op, SideL)} Fun..
- showString " : " Fun..
- unViewTerm (go xs) inh{viewTermInh_op=(op, SideR)}
- where op = infixN 5
- H.Cons -> "cons"
- H.Eq H.:@ x H.:@ y -> ViewTerm $ \inh ->
- pairViewTerm inh op Fun.$
- unViewTerm (go x) inh{viewTermInh_op=(op, SideL)} Fun..
- showString " == " Fun..
- unViewTerm (go y) inh{viewTermInh_op=(op, SideR)}
- where op = infixN 4
- H.Eq H.:@ x -> ViewTerm $ \inh ->
- showParen True Fun.$
- unViewTerm (go x) inh{viewTermInh_op=(op, SideL)} Fun..
- showString " =="
- where op = infixN 4
- H.Eq -> "(==)"
- H.Var v -> fromString v
- H.Lam1 f -> viewLam "u" f
- H.Lam f -> viewLam "x" f
- f H.:@ x -> ViewTerm $ \inh ->
- pairViewTerm inh op $
- unViewTerm (go f) inh{viewTermInh_op = (op, SideL) } .
- -- showString " :@ " .
- showString " " .
- unViewTerm (go x) inh{viewTermInh_op = (op, SideR) }
- where op = infixN 10
- {-
- H.Const -> "const"
- H.Flip -> "flip"
- H.Id -> "id"
- (H.:$) -> "($)"
- -}
- viewLam :: forall b c. String -> (H.Term repr b -> H.Term repr c) -> ViewTerm (b -> c)
- viewLam v f = ViewTerm $ \inh ->
- pairViewTerm inh op $
- let x = v<>show (viewTermInh_lamDepth inh) in
- -- showString "Lam1 (" .
- showString "\\" . showString x . showString " -> " .
- (unViewTerm (go (f (H.Var x))) inh
- { viewTermInh_op = (op, SideL)
- , viewTermInh_lamDepth = viewTermInh_lamDepth inh + 1
- })
- -- . showString ")"
- where op = infixN 0
import Symantic.Univariant.Letable
import Symantic.Univariant.Trans
+import Symantic.Univariant.Optim
import Symantic.Parser.Grammar.Combinators (Exception(..), Failure(..), SomeFailure(..), inputTokenProxy)
import Symantic.Parser.Machine.Input
import Symantic.Parser.Machine.Instructions
+import qualified Symantic.Parser.Grammar.Production as Prod
import qualified Language.Haskell.TH.HideName as TH
-import qualified Symantic.Parser.Haskell as H
+import qualified Symantic.Univariant.Data as H
+import qualified Symantic.Univariant.Lang as H
--import Debug.Trace
-genCode :: TermInstr a -> CodeQ a
+genCode :: Splice a -> CodeQ a
genCode = trans
-- * Type 'Gen'
data ValueStack vs where
ValueStackEmpty :: ValueStack '[]
ValueStackCons ::
- { valueStackHead :: TermInstr v
+ { valueStackHead :: Splice v
, valueStackTail :: ValueStack vs
} -> ValueStack (v ': vs)
{ unGen = \ctx -> {-trace "unGen.lift2Value" $-} unGen k ctx
{ valueStack =
let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
- ValueStackCons (f H.:@ x H.:@ y) vs
+ ValueStackCons (f H..@ x H..@ y) vs
}
}
swapValue k = k
let ValueStackCons v vs = valueStack ctx in
[||
case $$(genCode v) of
- Left x -> $$(unGen kx ctx{ valueStack = ValueStackCons (H.Term [||x||]) vs })
- Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons (H.Term [||y||]) vs })
+ Left x -> $$(unGen kx ctx{ valueStack = ValueStackCons (splice [||x||]) vs })
+ Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons (splice [||y||]) vs })
||]
}
choicesBranch fs ks kd = Gen
}
where
go ctx x (f:fs') (k:ks') = [||
- if $$(genCode (H.optimizeTerm (f H.:@ x)))
+ if $$(genCode (normalOrderReduction (f H..@ x)))
then
let _ = "choicesBranch.then" in
$$({-trace "unGen.choicesBranch.k" $-} unGen k ctx)
-- as they were when entering 'catch',
-- they will be available to 'loadInput', if any.
{ valueStack =
- ValueStackCons (H.Term (input ctx)) $
+ ValueStackCons (splice (input ctx)) $
--ValueStackCons (H.Term [||exn||]) $
valueStack ctx
, horizonStack =
{ unGen = \ctx ->
{-trace "unGen.pushInput" $-}
unGen k ctx
- { valueStack = H.Term (input ctx) `ValueStackCons` valueStack ctx
+ { valueStack = splice (input ctx) `ValueStackCons` valueStack ctx
, horizonStack = checkedHorizon ctx : horizonStack ctx
}
}
let _ = $$(liftTypedString $ "suspend") in
\farInp farExp v !inp ->
$$({-trace "unGen.generateSuspend" $-} unGen k ctx
- { valueStack = ValueStackCons ({-trace "unGen.generateSuspend.value" $-} H.Term [||v||]) (valueStack ctx)
+ { valueStack = ValueStackCons ({-trace "unGen.generateSuspend.value" $-} splice [||v||]) (valueStack ctx)
, input = [||inp||]
, farthestInput = [||farInp||]
, farthestExpecting = [||farExp||]
$$k
$$(farthestInput ctx)
$$(farthestExpecting ctx)
- (let _ = "resume.genCode" in $$({-trace "unGen.generateResume.genCode" $-} genCode $ H.optimizeTerm $
- valueStackHead $ valueStack ctx))
+ (let _ = "resume.genCode" in $$({-trace "unGen.generateResume.genCode" $-}
+ genCode $ normalOrderReduction $ valueStackHead $ valueStack ctx))
$$(input ctx)
||]
}
-- Called by 'generateResume'.
\farInp farExp v !inp ->
$$({-trace ("unGen.defJoin.next: "<>show n) $-} unGen sub ctx
- { valueStack = ValueStackCons (H.Term [||v||]) (valueStack ctx)
+ { valueStack = ValueStackCons (splice [||v||]) (valueStack ctx)
, input = [||inp||]
, farthestInput = [||farInp||]
, farthestExpecting = [||farExp||]
checkToken ::
Set SomeFailure ->
- {-predicate-}TermInstr (InputToken inp -> Bool) ->
+ {-predicate-}Splice (InputToken inp -> Bool) ->
{-ok-}Gen inp (InputToken inp ': vs) a ->
Gen inp vs a
checkToken fs p ok = ok
let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in
if $$(genCode p) c
then $$(unGen ok ctx
- { valueStack = ValueStackCons (H.Term [||c||]) (valueStack ctx)
+ { valueStack = ValueStackCons (splice [||c||]) (valueStack ctx)
, input = [||cs||]
})
else let _ = "checkToken.else" in
import Data.Function ((.))
import Data.Kind (Type)
import Data.Set (Set)
-import Text.Show (Show(..))
+import Text.Show (Show(..), showString)
import qualified Language.Haskell.TH as TH
-import qualified Symantic.Parser.Haskell as H
import Symantic.Parser.Grammar
import Symantic.Parser.Machine.Input
+import qualified Symantic.Univariant.Lang as H
+import qualified Symantic.Univariant.Data as Sym
--- * Type 'TermInstr'
-type TermInstr = H.Term TH.CodeQ
+-- * Type 'Splice'
+type Splice = Sym.SomeData TH.CodeQ
+instance Show (Splice a) where
+ showsPrec _p _ = showString "<hidden>"
+
+splice :: TH.CodeQ a -> Splice a
+splice x = Sym.SomeData (Sym.Var x)
-- ** Type 'ReprInstr'
type ReprInstr = {-input-}Type -> {-valueStack-}[Type] -> {-a-}Type -> Type
-- | @('pushValue' x k)@ pushes @(x)@ on the 'valueStack'
-- and continues with the next 'Instr'uction @(k)@.
pushValue ::
- TermInstr v ->
+ Splice v ->
repr inp (v ': vs) a ->
repr inp vs a
-- | @('popValue' k)@ pushes @(x)@ on the 'valueStack'.
-- | @('lift2Value' f k)@ pops two values from the 'valueStack',
-- and pushes the result of @(f)@ applied to them.
lift2Value ::
- TermInstr (x -> y -> z) ->
+ Splice (x -> y -> z) ->
repr inp (z ': vs) a ->
repr inp (y ': x ': vs) a
-- | @('swapValue' k)@ pops two values on the 'valueStack',
repr inp (y ': x ': vs) a
-- | @('mapValue' f k)@.
mapValue ::
- TermInstr (x -> y) ->
+ Splice (x -> y) ->
repr inp (y ': vs) a ->
repr inp (x ': vs) a
mapValue f = pushValue f . lift2Value (H.flip H..@ (H.$))
repr inp (Either x y ': vs) r
-- | @('choicesBranch' ps bs d)@.
choicesBranch ::
- [TermInstr (v -> Bool)] ->
+ [Splice (v -> Bool)] ->
[repr inp vs a] ->
repr inp vs a ->
repr inp (v ': vs) a
read ::
tok ~ InputToken inp =>
Set SomeFailure ->
- TermInstr (tok -> Bool) ->
+ Splice (tok -> Bool) ->
repr inp (tok ': vs) a ->
repr inp vs a
import Symantic.Parser.Machine.Instructions
import Symantic.Univariant.Trans
+import Debug.Trace
+
-- * Data family 'Instr'
-- | 'Instr'uctions of the 'Machine'.
-- This is an extensible data-type.
data family Instr
(instr :: ReprInstr -> Constraint)
- (repr :: ReprInstr)
- :: ReprInstr
+ :: ReprInstr -> ReprInstr
-- | Convenient utility to pattern-match a 'SomeInstr'.
pattern Instr :: Typeable comb =>
-- InstrValuable
data instance Instr InstrValuable repr inp vs a where
PushValue ::
- TermInstr v ->
+ Splice v ->
SomeInstr repr inp (v ': vs) a ->
Instr InstrValuable repr inp vs a
PopValue ::
SomeInstr repr inp vs a ->
Instr InstrValuable repr inp (v ': vs) a
Lift2Value ::
- TermInstr (x -> y -> z) ->
+ Splice (x -> y -> z) ->
SomeInstr repr inp (z : vs) a ->
Instr InstrValuable repr inp (y : x : vs) a
SwapValue ::
Instr InstrValuable repr inp (y ': x ': vs) a
instance InstrValuable repr => Trans (Instr InstrValuable repr inp vs) (repr inp vs) where
trans = \case
- PushValue x k -> pushValue x (trans k)
+ PushValue x k -> trace "trans.pushValue" (pushValue x (trans k))
PopValue k -> popValue (trans k)
Lift2Value f k -> lift2Value f (trans k)
SwapValue k -> swapValue (trans k)
SomeInstr repr inp (y ': vs) a ->
Instr InstrBranchable repr inp (Either x y ': vs) a
ChoicesBranch ::
- [TermInstr (v -> Bool)] ->
+ [Splice (v -> Bool)] ->
[SomeInstr repr inp vs a] ->
SomeInstr repr inp vs a ->
Instr InstrBranchable repr inp (v ': vs) a
data instance Instr (InstrReadable tok) repr inp vs a where
Read ::
Set SomeFailure ->
- TermInstr (InputToken inp -> Bool) ->
+ Splice (InputToken inp -> Bool) ->
SomeInstr repr inp (InputToken inp ': vs) a ->
Instr (InstrReadable tok) repr inp vs a
instance
import qualified Data.Traversable as Traversable
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
-import qualified Symantic.Parser.Haskell as H
+import qualified Symantic.Univariant.Lang as H
import Symantic.Parser.Grammar
import Symantic.Parser.Machine.Input
import Symantic.Parser.Machine.Instructions
import Symantic.Parser.Machine.Optimize
import Symantic.Univariant.Trans
+import Debug.Trace
-- * Type 'Program'
-- | A 'Program' is a tree of 'Instr'uctions,
Alt ExceptionFailure
(Comb (SatisfyOrFail _fs p :: Comb (CombSatisfiable (InputToken inp)) (Program repr inp) a))
(Comb (Failure sf)) ->
- Program $ return . read (Set.singleton sf) (trans p)
+ Program $ return . trace "trans.read" . read (Set.singleton sf) (trace "read.prodCode" (prodCode p))
Alt exn x y -> alt exn (trans x) (trans y)
Empty -> empty
Failure sf -> failure sf
SomeInstr repr inp (Cursor inp ': vs) ret
failIfConsumed exn k =
pushInput $
- lift2Value (H.Term sameOffset) $
+ lift2Value (splice sameOffset) $
ifBranch k $
case exn of
ExceptionLabel lbl -> raise lbl
instance
InstrValuable repr =>
CombApplicable (Program repr inp) where
- pure x = Program $ return . pushValue (trans x)
+ pure x = Program $ return . pushValue (prodCode (trace "pushValue.prodCode" x))
Program f <*> Program x = Program $ (f <=< x) . applyValue
- liftA2 f (Program x) (Program y) = Program $ (x <=< y) . lift2Value (trans f)
+ liftA2 f (Program x) (Program y) = Program $ (x <=< y) . lift2Value (prodCode f)
Program x *> Program y = Program (x <=< return . popValue <=< y)
Program x <* Program y = Program (x <=< y <=< return . popValue)
instance
) => CombMatchable (Program repr inp) where
conditional (Program a) ps bs (Program d) = joinNext $ Program $ \next -> do
bs' <- Control.Monad.sequence $ (\(Program b) -> b next) Functor.<$> bs
- a =<< liftM (choicesBranch (trans Functor.<$> ps) bs') (d next)
+ a =<< liftM (choicesBranch (prodCode Functor.<$> ps) bs') (d next)
instance
( tok ~ InputToken inp
, InstrReadable tok repr
, Typeable tok
) => CombSatisfiable tok (Program repr inp) where
- satisfyOrFail fs p = Program $ return . read fs (trans p)
+ satisfyOrFail fs p = Program $ return . read fs (trace "satisfyOrFail.read.prodCode" (prodCode p))
instance
( InstrBranchable repr
, InstrJoinable repr
--- /dev/null
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+--{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RankNTypes #-}
+--{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-} -- For Abstractable (SomeData repr)
+{-# LANGUAGE ViewPatterns #-}
+module Symantic.Univariant.Data where
+
+import Data.Kind
+import Type.Reflection
+import Data.Char (Char)
+import Data.Bool (Bool)
+import Data.Either (Either)
+import Data.Maybe (Maybe)
+import Data.Functor.Identity (Identity(..))
+import Data.String (String)
+import Prelude (undefined)
+import Text.Show (Show(..))
+import qualified Data.Eq as Eq
+import qualified Data.Maybe as Maybe
+import qualified Data.Function as Fun
+import Data.Coerce
+
+import Symantic.Univariant.Lang
+import Symantic.Univariant.Trans
+
+data SomeData repr a =
+ forall able.
+ ( Trans (Data able repr) repr
+ , Typeable able
+ ) => SomeData (Data able repr a)
+
+instance Trans (SomeData repr) repr where
+ trans (SomeData x) = trans x
+
+type UnivariantRepr = Type -> Type
+
+-- TODO: neither data families nor data instances
+-- can have phantom roles with GHC-9's RoleAnnotations,
+-- hence 'Data.Coerce.coerce' cannot be used on them for now.
+-- https://gitlab.haskell.org/ghc/ghc/-/issues/8177
+-- https://gitlab.haskell.org/ghc/ghc/-/wikis/roles#proposal-roles-for-type-families
+-- Would be useful for @Trans (Data able repr) (Data able repr')@ instances.
+data family Data
+ (able :: UnivariantRepr -> Constraint)
+ :: UnivariantRepr -> UnivariantRepr
+--instance Trans (Data able repr) (Data able repr) where
+-- trans = Fun.id
+
+-- | Convenient utility to pattern-match a 'SomeData'.
+pattern Data :: Typeable able => Data able repr a -> SomeData repr a
+pattern Data x <- (unSomeData -> Maybe.Just x)
+
+{-
+class TransUnit able where
+ -- | The 'Bottomable' constraint is needed when a @(repr)@ value
+ -- has to be constructed.
+ reprFromUnit :: Bottomable repr => Data able Unit a -> SomeData repr a
+ -- | The 'Bottomable' constraint is also needed here
+ -- to call 'reprFromUnit' in the 'Lam' case.
+ unitFromRepr :: Bottomable repr => Data able repr a -> SomeData Unit a
+
+coerceRepr ::
+ Bottomable repr => Bottomable repr' =>
+ SomeData repr a -> SomeData repr' a
+coerceRepr (SomeData r) =
+ case unitFromRepr r of
+ SomeData d -> reprFromUnit d
+-}
+
+-- | @(unSomeData c :: 'Maybe' ('Data' able repr a))@
+-- extract the data-constructor from the given 'SomeData'
+-- iif. it belongs to the @('Data' able repr a)@ data-instance.
+unSomeData ::
+ forall able repr a.
+ Typeable able =>
+ SomeData repr a -> Maybe (Data able repr a)
+unSomeData (SomeData (c::Data c repr a)) =
+ case typeRep @able `eqTypeRep` typeRep @c of
+ Maybe.Just HRefl -> Maybe.Just c
+ Maybe.Nothing -> Maybe.Nothing
+
+-- Abstractable
+data instance Data Abstractable repr a where
+ (:@) :: SomeData repr (a->b) -> SomeData repr a -> Data Abstractable repr b
+ Lam :: (SomeData repr a -> SomeData repr b) -> Data Abstractable repr (a->b)
+ Lam1 :: (SomeData repr a -> SomeData repr b) -> Data Abstractable repr (a->b)
+ Var :: repr a -> Data Abstractable repr a
+ -- FIXME: add constructors
+instance
+ ( Abstractable repr
+ --, Trans (SomeData repr) repr
+ --, Trans repr (SomeData repr)
+ ) => Trans (Data Abstractable repr) repr where
+ trans = \case
+ f :@ x -> trans f .@ trans x
+ Lam f -> lam (\x -> trans (f (SomeData (Var x))))
+ Lam1 f -> lam1 (\x -> trans (f (SomeData (Var x))))
+ Var x -> var x
+instance
+ ( Abstractable repr
+ --, Trans (SomeData repr) repr
+ --, Trans repr (SomeData repr)
+ ) => Abstractable (SomeData repr) where
+ f .@ x = SomeData (f :@ x)
+ lam f = SomeData (Lam f)
+ lam1 f = SomeData (Lam1 f)
+ var = Fun.id
+ ($) = lam1 (\f -> lam1 (\x -> f .@ x))
+ (.) = lam1 (\f -> lam1 (\g -> lam1 (\x -> f .@ (g .@ x))))
+ const = lam1 (\x -> lam1 (\_y -> x))
+ flip = lam1 (\f -> lam1 (\x -> lam1 (\y -> f .@ y .@ x)))
+ id = lam1 (\x -> x)
+
+{-
+instance
+ ( Abstractable repr
+ ) =>
+ Abstractable (Data Abstractable repr) where
+ var = Var Fun.. SomeData
+ f .@ x = SomeData f :@ SomeData x
+ lam f = Lam (SomeData Fun.. f Fun.. Var)
+ lam1 f = Lam1 (SomeData Fun.. f Fun.. Var)
+ ($) = lam1 (\f -> lam1 (\x -> f .@ x))
+ (.) = lam1 (\f -> lam1 (\g -> lam1 (\x -> f .@ (g .@ x))))
+ const = lam1 (\x -> lam1 (\_y -> x))
+ flip = lam1 (\f -> lam1 (\x -> lam1 (\y -> f .@ y .@ x)))
+ id = lam1 (\x -> x)
+-}
+{-
+instance Bottomable repr => Morph (SomeData repr) (SomeData Unit) where
+ morph (SomeData x) = morph x
+instance Bottomable repr => Morph (SomeData Unit) (SomeData repr) where
+ morph (SomeData x) = morph x
+instance Abstractable Unit where
+ (.@) _f _x = Unit
+ lam _f = Unit
+ lam1 _f = Unit
+ ($) = Unit
+ (.) = Unit
+ const = Unit
+ flip = Unit
+ id = Unit
+instance Abstractable (Data Abstractable Unit) where
+ f .@ x = SomeData f :@ SomeData x
+ lam f = Lam (\(SomeData x) -> SomeData (f (trans x)))
+ lam1 f = Lam1 (\(SomeData x) -> SomeData (f (trans x)))
+ ($) = ($)
+ (.) = (.)
+ const = const
+ flip = flip
+ id = id
+-}
+
+-- Anythingable
+data instance Data Anythingable repr a where
+ Anything :: repr a -> Data Anythingable repr a
+instance
+ ( Anythingable repr
+ ) =>
+ Trans (Data Anythingable repr) repr where
+ trans = \case
+ Anything x -> anything x
+instance Anythingable (SomeData repr)
+instance Anythingable (Data Anythingable repr)
+
+-- Bottomable
+class Bottomable repr where
+ bottom :: repr a
+data instance Data Bottomable repr a where
+ Bottom :: Data Bottomable repr a
+instance Bottomable repr => Trans (Data Bottomable repr) repr where
+ trans Bottom{} = bottom
+
+-- Constantable
+data instance Data (Constantable c) repr a where
+ Constant :: c -> Data (Constantable c) repr c
+instance Constantable c repr => Trans (Data (Constantable c) repr) repr where
+ trans = \case
+ Constant x -> constant x
+instance
+ ( Constantable c repr
+ , Typeable c
+ ) => Constantable c (SomeData repr) where
+ constant c = SomeData (Constant c)
+instance Constantable c (Data (Constantable c) repr) where
+ constant = Constant
+
+-- Eitherable
+data instance Data Eitherable repr a where
+ Left :: Data Eitherable repr (l -> Either l r)
+ Right :: Data Eitherable repr (r -> Either l r)
+instance Eitherable repr => Trans (Data Eitherable repr) repr where
+ trans = \case
+ Left -> left
+ Right -> right
+instance
+ ( Eitherable repr
+ ) => Eitherable (SomeData repr) where
+ left = SomeData Left
+ right = SomeData Right
+instance Eitherable (Data Eitherable repr) where
+ left = Left
+ right = Right
+
+-- Equalable
+data instance Data Equalable repr a where
+ Equal :: Eq.Eq a => Data Equalable repr (a -> a -> Bool)
+instance Equalable repr => Trans (Data Equalable repr) repr where
+ trans = \case
+ Equal -> equal
+instance
+ ( Equalable repr
+ ) => Equalable (SomeData repr) where
+ equal = SomeData Equal
+instance Equalable (Data Equalable repr) where
+ equal = Equal
+
+-- Listable
+data instance Data Listable repr a where
+ Cons :: Data Listable repr (a -> [a] -> [a])
+ Nil :: Data Listable repr [a]
+infixr 4 `Cons`
+instance Listable repr => Trans (Data Listable repr) repr where
+ trans = \case
+ Cons -> cons
+ Nil -> nil
+instance
+ ( Listable repr
+ ) => Listable (SomeData repr) where
+ cons = SomeData Cons
+ nil = SomeData Nil
+instance Listable (Data Listable repr) where
+ cons = Cons
+ nil = Nil
+
+-- Maybeable
+data instance Data Maybeable repr a where
+ Nothing :: Data Maybeable repr (Maybe a)
+ Just :: Data Maybeable repr (a -> Maybe a)
+instance Maybeable repr => Trans (Data Maybeable repr) repr where
+ trans = \case
+ Nothing -> nothing
+ Just -> just
+instance
+ ( Maybeable repr
+ ) => Maybeable (SomeData repr) where
+ nothing = SomeData Nothing
+ just = SomeData Just
+instance Maybeable (Data Maybeable repr) where
+ nothing = Nothing
+ just = Just
--- /dev/null
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module Symantic.Univariant.Lang where
+
+import Data.Char (Char)
+import Data.Bool (Bool(..))
+import Data.Either (Either(..))
+import Data.Eq (Eq)
+import Data.Kind
+import Data.Maybe (Maybe(..))
+import Prelude (undefined)
+import Text.Show (Show(..))
+import qualified Data.Eq as Eq
+import qualified Data.Function as Fun
+import qualified Prelude
+
+import Symantic.Univariant.Trans
+
+class Abstractable repr where
+ -- | Application, aka. unabstract.
+ (.@) :: repr (a->b) -> repr a -> repr b; infixl 9 .@
+ -- | Lambda term abstraction, in HOAS (Higher-Order Abstract Syntax) style.
+ lam :: (repr a -> repr b) -> repr (a->b)
+ -- | Like 'lam' but whose argument is used only once,
+ -- hence safe to beta-reduce (inline) without duplicating work.
+ lam1 :: (repr a -> repr b) -> repr (a->b)
+ const :: repr (a -> b -> a)
+ flip :: repr ((a -> b -> c) -> b -> a -> c)
+ id :: repr (a->a)
+ (.) :: repr ((b->c) -> (a->b) -> a -> c); infixr 9 .
+ ($) :: repr ((a->b) -> a -> b); infixr 0 $
+ var :: repr a -> repr a
+ default (.@) ::
+ Liftable2 repr => Abstractable (Output repr) =>
+ repr (a->b) -> repr a -> repr b
+ default lam ::
+ Liftable repr => Unliftable repr => Abstractable (Output repr) =>
+ (repr a -> repr b) -> repr (a->b)
+ default lam1 ::
+ Liftable repr => Unliftable repr => Abstractable (Output repr) =>
+ (repr a -> repr b) -> repr (a->b)
+ default const ::
+ Liftable repr => Abstractable (Output repr) =>
+ repr (a -> b -> a)
+ default flip ::
+ Liftable repr => Abstractable (Output repr) =>
+ repr ((a -> b -> c) -> b -> a -> c)
+ default id ::
+ Liftable repr => Abstractable (Output repr) =>
+ repr (a->a)
+ default (.) ::
+ Liftable repr => Abstractable (Output repr) =>
+ repr ((b->c) -> (a->b) -> a -> c)
+ default ($) ::
+ Liftable repr => Abstractable (Output repr) =>
+ repr ((a->b) -> a -> b)
+ default var ::
+ Liftable1 repr => Abstractable (Output repr) =>
+ repr a -> repr a
+ (.@) = lift2 (.@)
+ lam f = lift (lam (trans Fun.. f Fun.. trans))
+ lam1 f = lift (lam1 (trans Fun.. f Fun.. trans))
+ const = lift const
+ flip = lift flip
+ id = lift id
+ (.) = lift (.)
+ ($) = lift ($)
+ var = lift1 var
+class Anythingable repr where
+ anything :: repr a -> repr a
+ anything = Fun.id
+class Constantable c repr where
+ constant :: c -> repr c
+ default constant ::
+ Liftable repr => Constantable c (Output repr) =>
+ c -> repr c
+ constant = lift Fun.. constant
+bool = constant @Bool
+char = constant @Char
+unit = constant @() ()
+class Eitherable repr where
+ left :: repr (l -> Either l r)
+ right :: repr (r -> Either l r)
+ default left ::
+ Liftable repr => Eitherable (Output repr) =>
+ repr (l -> Either l r)
+ default right ::
+ Liftable repr => Eitherable (Output repr) =>
+ repr (r -> Either l r)
+ left = lift left
+ right = lift right
+class Equalable repr where
+ equal :: Eq a => repr (a -> a -> Bool)
+ default equal ::
+ Liftable repr => Equalable (Output repr) =>
+ Eq a => repr (a -> a -> Bool)
+ equal = lift equal
+infix 4 `equal`, ==
+(==) = lam (\x -> lam (\y -> equal .@ x .@ y))
+class Listable repr where
+ cons :: repr (a -> [a] -> [a])
+ nil :: repr [a]
+ default cons ::
+ Liftable repr => Listable (Output repr) =>
+ repr (a -> [a] -> [a])
+ default nil ::
+ Liftable repr => Listable (Output repr) =>
+ repr [a]
+ cons = lift cons
+ nil = lift nil
+class Maybeable repr where
+ nothing :: repr (Maybe a)
+ just :: repr (a -> Maybe a)
+ default nothing ::
+ Liftable repr => Maybeable (Output repr) =>
+ repr (Maybe a)
+ default just ::
+ Liftable repr => Maybeable (Output repr) =>
+ repr (a -> Maybe a)
+ nothing = lift nothing
+ just = lift just
--- /dev/null
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ViewPatterns #-}
+module Symantic.Univariant.Optim where
+
+import Data.Kind
+import Type.Reflection
+import Data.Char (Char)
+import Data.Bool (Bool(..))
+import Data.Maybe (Maybe(..))
+import Data.Functor.Identity (Identity(..))
+import Data.String (String)
+import Prelude (undefined)
+import Text.Show (Show(..))
+import qualified Data.Eq as Eq
+import qualified Data.Function as Fun
+
+import Symantic.Univariant.Trans
+import Symantic.Univariant.Lang
+import Symantic.Univariant.Data
+
+-- | Beta-reduce the left-most outer-most lambda abstraction (aka. normal-order reduction),
+-- but to avoid duplication of work, only those manually marked
+-- as using their variable at most once.
+--
+-- DOC: Demonstrating Lambda Calculus Reduction, Peter Sestoft, 2001,
+-- https://www.itu.dk/people/sestoft/papers/sestoft-lamreduce.pdf
+normalOrderReduction :: forall repr a.
+ Abstractable repr =>
+ SomeData repr a -> SomeData repr a
+normalOrderReduction = nor
+ where
+ -- | normal-order reduction
+ nor :: SomeData repr b -> SomeData repr b
+ nor = \case
+ Data (Lam f) -> lam (nor Fun.. f)
+ Data (Lam1 f) -> lam1 (nor Fun.. f)
+ Data (x :@ y) -> case whnf x of
+ Data (Lam1 f) -> nor (f y)
+ x' -> nor x' .@ nor y
+ x -> x
+ -- | weak-head normal-form
+ whnf :: SomeData repr b -> SomeData repr b
+ whnf = \case
+ Data (x :@ y) -> case whnf x of
+ Data (Lam1 f) -> whnf (f y)
+ x' -> x' .@ y
+ x -> x
{-# LANGUAGE ConstraintKinds #-} -- For type class synonyms
+{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DefaultSignatures #-} -- For adding Trans* constraints
module Symantic.Univariant.Trans where
type family Output (repr :: Type -> Type) :: Type -> Type
-- * Class 'Trans'
--- | A 'trans'lation from an interpreter @(from)@ to an interpreter @(to)@.
+-- | A 'trans'formation from an interpreter @(from)@ to an interpreter @(to)@.
class Trans from to where
trans :: from a -> to a
+class MetaTrans some from to where
+ meta :: some from a -> some to a
+{-
+newtype Compo some repr a = Compo { getCompo :: some repr a }
+type family UnSome s where
+ UnSome (some m) =
+-}
-- * Class 'BiTrans'
-- | Convenient type class synonym.
lift3 = trans3 @(Output repr)
{-# INLINE lift3 #-}
+{-
-- * Type 'Any'
-- | A newtype to disambiguate the 'Trans' instance to any other interpreter when there is also one or more 'Trans's to other interpreters with a different interpretation than the generic one.
newtype Any repr a = Any { unAny :: repr a }
instance Trans1 repr (Any repr)
instance Trans2 repr (Any repr)
instance Trans3 repr (Any repr)
+-}
--- /dev/null
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ImplicitPrelude #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-} -- For Show (SomeData a)
+module Symantic.Univariant.View where
+
+import Data.Int (Int)
+import Data.Semigroup (Semigroup(..))
+import Data.String
+import Prelude (undefined)
+import Text.Show
+import Type.Reflection (Typeable)
+import qualified Data.Function as Fun
+import qualified Prelude
+
+import Symantic.Parser.Grammar.Fixity
+import Symantic.Univariant.Lang
+import Symantic.Univariant.Data
+import Symantic.Univariant.Trans
+
+data View a where
+ View :: (ViewEnv -> ShowS) -> View a
+ ViewUnifix :: Unifix -> String -> String -> View (a -> b)
+ ViewInfix :: Infix -> String -> String -> View (a -> b -> c)
+ ViewApp :: View (b -> a) -> View b -> View a
+
+runView :: View a -> ViewEnv -> ShowS
+runView (View f) env = f env
+runView (ViewInfix _op name _infixName) env = showString name
+runView (ViewApp f x) env =
+ pairView env op Fun.$
+ runView f env{viewEnv_op = (op, SideL) } Fun..
+ showString " " Fun..
+ runView x env{viewEnv_op = (op, SideR) }
+ where op = infixN 10
+
+type instance Output View = View
+instance Trans View View where
+ trans = Fun.id
+
+instance IsString (View a) where
+ fromString s = View Fun.$ \_env -> showString s
+instance Show (View a) where
+ showsPrec p (View v) = v ViewEnv
+ { viewEnv_op = (infixN p, SideL)
+ , viewEnv_pair = pairParen
+ , viewEnv_lamDepth = 1
+ }
+instance Show (SomeData View a) where
+ showsPrec p (SomeData x) = showsPrec p (trans @_ @View x)
+
+data ViewEnv
+ = ViewEnv
+ { viewEnv_op :: (Infix, Side)
+ , viewEnv_pair :: Pair
+ , viewEnv_lamDepth :: Int
+ }
+
+pairView :: ViewEnv -> Infix -> ShowS -> ShowS
+pairView env op s =
+ if isPairNeeded (viewEnv_op env) op
+ then showString o Fun.. s Fun.. showString c
+ else s
+ where (o,c) = viewEnv_pair env
+
+instance Abstractable View where
+ var = Fun.id
+ lam f = viewLam "x" f
+ lam1 f = viewLam "u" f
+ ViewInfix op _name infixName .@ ViewApp x y = View Fun.$ \env ->
+ pairView env op Fun.$
+ runView x env{viewEnv_op=(op, SideL)} Fun..
+ showString " " Fun.. showString infixName Fun.. showString " " Fun..
+ runView y env{viewEnv_op=(op, SideR)}
+ ViewInfix op name _infixName .@ x = View Fun.$ \env ->
+ showParen Prelude.True Fun.$
+ runView x env{viewEnv_op=(op, SideL)} Fun..
+ showString " " Fun.. showString name
+ f .@ x = ViewApp f x
+viewLam :: String -> (View a -> View b) -> View (a -> b)
+viewLam varPrefix f = View Fun.$ \env ->
+ pairView env op Fun.$
+ let x = showString varPrefix Fun..
+ showsPrec 0 (viewEnv_lamDepth env) in
+ -- showString "Lam1 (" .
+ showString "\\" Fun.. x Fun.. showString " -> " Fun..
+ runView (f (View (\_env -> x))) env
+ { viewEnv_op = (op, SideL)
+ , viewEnv_lamDepth = Prelude.succ (viewEnv_lamDepth env)
+ }
+ -- . showString ")"
+ where
+ op = infixN 0
+instance Anythingable View
+instance Bottomable View where
+ bottom = "<hidden>"
+instance Show c => Constantable c View where
+ constant c = View Fun.$ \_env -> shows c
+instance Eitherable View where
+ left = "Left"
+ right = "Right"
+instance Equalable View where
+ equal = ViewInfix (infixN 4) "(==)" "=="
+instance Listable View where
+ cons = ViewInfix (infixR 5) "(:)" ":"
+ nil = "[]"
+instance Maybeable View where
+ nothing = "Nothing"
+ just = "Just"
Selective Parser
Combinators](https://icfp20.sigplan.org/details/icfp-2020-papers/20/Staged-Selective-Parser-Combinators).
license: AGPL-3.0-or-later
-author: Julien Moutinho <julm+symantic-parser@sourcephile.fr>
-maintainer: Julien Moutinho <julm+symantic-parser@sourcephile.fr>
-bug-reports: Julien Moutinho <julm+symantic-parser@sourcephile.fr>
-copyright: Julien Moutinho <julm+symantic-parser@sourcephile.fr>
+author: Julien Moutinho <julm+symantic-parser@sourcephile.fr>
+maintainer: Julien Moutinho <julm+symantic-parser@sourcephile.fr>
+bug-reports: https://mails.sourcephile.fr/inbox/symantic-parser
+copyright: Julien Moutinho <julm+symantic-parser@sourcephile.fr>
stability: experimental
category: Parsing
extra-doc-files:
-Wincomplete-record-updates
-Wpartial-fields
-fhide-source-paths
- -freverse-errors
- ghc-prof-options:
- -eventlog -fprof-auto -fprof-auto-calls
+ ---freverse-errors
+ -fprint-potential-instances
+ ghc-prof-options: -eventlog -fprof-auto
+ -- -fprof-auto-calls
library
import: boilerplate
Symantic.Parser.Grammar.Fixity
Symantic.Parser.Grammar.ObserveSharing
Symantic.Parser.Grammar.Optimize
+ Symantic.Parser.Grammar.Production
Symantic.Parser.Grammar.View
Symantic.Parser.Grammar.Write
- Symantic.Parser.Haskell
- Symantic.Parser.Haskell.Optimize
- Symantic.Parser.Haskell.Term
- Symantic.Parser.Haskell.View
Symantic.Parser.Machine
Symantic.Parser.Machine.Generate
Symantic.Parser.Machine.Input
Symantic.Parser.Machine.Optimize
Symantic.Parser.Machine.Program
Symantic.Parser.Machine.View
+ Symantic.Univariant.Data
+ Symantic.Univariant.Lang
Symantic.Univariant.Letable
+ Symantic.Univariant.Optim
Symantic.Univariant.Trans
+ Symantic.Univariant.View
default-extensions:
BangPatterns,
DataKinds,
TypeApplications,
TypeFamilies,
TypeOperators
- ghc-options: -O2 -ddump-to-file -ddump-simpl-stats -ddump-splices
+ ghc-options: -O2
+ -- -ddump-to-file -ddump-simpl-stats -ddump-splices
build-depends:
symantic-parser,
attoparsec >= 0.13,
autogen-modules:
Paths_symantic_parser
ghc-options: -O2
- ghc-prof-options:
- -fexternal-interpreter
+ ghc-prof-options: -fexternal-interpreter
build-depends:
symantic-parser,
symantic-parser:parsers,
autogen-modules:
Paths_symantic_parser
default-extensions:
- ghc-options: -O2
- ghc-prof-options:
- -fexternal-interpreter
+ ghc-options: -O2 -fno-enable-th-splice-warnings
+ ghc-prof-options: -fexternal-interpreter
build-depends:
base >= 4.6 && < 5,
symantic-parser,
sourcephile / git / haskell / symantic-parser.git / commitdiff