309 lines
7.7 KiB
Haskell
309 lines
7.7 KiB
Haskell
-- | cribbed from sexp-grammar:Language.SexpGrammar.Base
|
|
module Gyehoek.Sexp.Grammar.Base
|
|
( module Gyehoek.Sexp.Syntax
|
|
, module Data.InvertibleGrammar.Combinators
|
|
, expected, unexpected
|
|
-- * types
|
|
, G
|
|
, Grammar
|
|
, DatumGrammar
|
|
, DataGrammar
|
|
, Grammar
|
|
, ListContext
|
|
, (:-)((:-))
|
|
-- * lists
|
|
, list
|
|
, el
|
|
, rest
|
|
-- * atoms
|
|
, simple
|
|
, string
|
|
, symbol
|
|
, sym
|
|
, boolean
|
|
, number
|
|
, integer
|
|
, headTagged1'
|
|
, headTagged1
|
|
, headTagged2
|
|
, int
|
|
, letLike
|
|
, ifLike
|
|
, headTagged0'
|
|
, headTagged0
|
|
, lambdaLike
|
|
, lambdaKeyword
|
|
, kappaKeyword
|
|
, beginLike
|
|
, prismIso
|
|
, isoIso
|
|
) where
|
|
|
|
import Data.InvertibleGrammar
|
|
import Data.InvertibleGrammar.Base
|
|
import Data.InvertibleGrammar.Combinators
|
|
import Gyehoek.Prelude hiding (iso, cons, coerced, Iso, Simple, simple)
|
|
import Gyehoek.Sexp.Syntax hiding (position)
|
|
import Gyehoek.Sexp.Print (printDatum')
|
|
import Data.Scientific (Scientific)
|
|
import qualified Data.Scientific as Sci
|
|
import qualified Data.Text as T
|
|
import Control.Monad.RWS (modify)
|
|
|
|
|
|
-- $setup
|
|
-- >>> :set -XOverloadedStrings
|
|
-- >>> import Gyehoek.Sexp.Grammar
|
|
|
|
type G = Grammar Ann
|
|
|
|
type DatumGrammar a = forall t. G (Datum :- t) (a :- t)
|
|
type DataGrammar a = forall t. G (List Datum :- t) (a :- t)
|
|
|
|
-- | extract\/inject an annotation from\/into a 'Datum'.
|
|
position :: G (Datum :- t) (Ann :- Datum :- t)
|
|
position = Iso
|
|
(\(s :- t) -> view ann s :- s :- t)
|
|
(\(a :- s :- t) -> (s & ann .~ a) :- t)
|
|
|
|
locate :: G (Datum :- t) (Datum :- t)
|
|
locate =
|
|
position
|
|
>>> onHead Locate
|
|
>>> Iso
|
|
(\(_ :- t) -> t)
|
|
(\t -> noAnn :- t)
|
|
|
|
modifyAnn :: (Ann -> Ann) -> G (Datum :- t) (Datum :- t)
|
|
modifyAnn f = Iso
|
|
(\(d:-t) -> (d & ann %~ f) :- t)
|
|
(\(d:-t) -> (d & ann %~ f) :- t)
|
|
|
|
newtype ListContext = MkListContext (List Datum)
|
|
|
|
unexpectedSimple :: Simple -> Mismatch
|
|
unexpectedSimple = unexpected . printDatum' . Simple
|
|
|
|
unexpectedDatum :: Datum -> Mismatch
|
|
unexpectedDatum = unexpected . printDatum'
|
|
|
|
list
|
|
:: G (ListContext :- t) (ListContext :- t')
|
|
-> G (Datum :- t) t'
|
|
list = listWithIndentation Ordinary
|
|
|
|
listWithIndentation
|
|
:: Indentation
|
|
-> G (ListContext :- t) (ListContext :- t')
|
|
-> G (Datum :- t) t'
|
|
listWithIndentation ind g = begin >>> Dive (g >>> end)
|
|
where
|
|
begin = locate >>> partialOsi
|
|
(\case
|
|
List xs -> Right . MkListContext $ xs
|
|
_ -> Left $ expected "list")
|
|
(List' ind . coerce)
|
|
end = Flip $ PartialIso
|
|
(\t -> MkListContext [] :- t)
|
|
(\(MkListContext lst :- t) ->
|
|
case lst of
|
|
[] -> Right t
|
|
d:_ -> Left $ unexpectedDatum d)
|
|
|
|
-- |
|
|
-- >>> decodeTest (list $ el simple) "(in-here!)"
|
|
-- SimpleSymbol "in-here!"
|
|
el
|
|
:: G (Datum :- t) t'
|
|
-> G (ListContext :- t) (ListContext :- t')
|
|
el g = coerced (Flip cons >>> onTail g >>> Step)
|
|
|
|
-- | matches the remainder of a list
|
|
--
|
|
-- >>> decodeTest (list $ rest simple) "(ga na da ra)"
|
|
-- [ SimpleSymbol "ga"
|
|
-- , SimpleSymbol "na"
|
|
-- , SimpleSymbol "da"
|
|
-- , SimpleSymbol "ra"
|
|
-- ]
|
|
rest
|
|
:: (forall t'. G (Datum :- t') (a :- t'))
|
|
-> G (ListContext :- t) (ListContext :- List a :- t)
|
|
rest g =
|
|
iso coerce coerce >>>
|
|
onHead (Traverse (sealed g >>> Step)) >>>
|
|
Iso (\a -> MkListContext [] :- a) (\(_ :- a) -> a)
|
|
|
|
|
|
-- atoms
|
|
|
|
-- | matches simple forms — atomic S-expressions.
|
|
--
|
|
-- >>> decodeTest simple "call/cc"
|
|
-- SimpleSymbol "call/cc"
|
|
simple :: G (Datum :- t) (Simple :- t)
|
|
simple = locate >>> partialOsi
|
|
(\case Simple s -> Right s
|
|
_ -> Left . expected $ "atom")
|
|
Simple
|
|
|
|
prismGrammar
|
|
-- | expected
|
|
:: Text
|
|
-- | unexpected
|
|
-> (s -> Mismatch)
|
|
-> Prism' s a
|
|
-> Grammar p (s :- t) (a :- t)
|
|
prismGrammar exp unexp p =
|
|
partialOsi
|
|
((_Left %~ \x -> expected exp <> unexp x) . matching p)
|
|
(review p)
|
|
|
|
-- |
|
|
-- >>> decodeTest symbol "symbolic-of-what???"
|
|
-- "symbolic-of-what???"
|
|
symbol :: G (Datum :- t) (Text :- t)
|
|
symbol = simple >>> prismGrammar "symbol" unexpectedSimple #SimpleSymbol
|
|
|
|
-- |
|
|
-- >>> let grammar = list $ el (sym "a-specific-symbol") >>> el string
|
|
-- >>> decodeTest grammar "(a-specific-symbol \"this works\")"
|
|
-- "this works"
|
|
-- >>> decodeTest grammar "(some-other-symbol \"this does not\")"
|
|
-- *** Exception:
|
|
-- <none>:1:2: mismatch:
|
|
-- Expected: symbol a-specific-symbol
|
|
-- But got: some-other-symbol
|
|
-- ...
|
|
sym :: Text -> G (Datum :- t) t
|
|
sym s = simple >>> Flip (PartialIso
|
|
(SimpleSymbol s :-)
|
|
(\(a :- t) ->
|
|
case a of
|
|
SimpleSymbol s' | s == s' -> Right t
|
|
other -> Left $ expected ("symbol " <> s) <>
|
|
unexpectedSimple other))
|
|
|
|
-- |
|
|
-- >>> decodeTest string "\"these r annoying to escape\""
|
|
-- "these r annoying to escape"
|
|
-- >>> encodeTest string "john Haskell"
|
|
-- "john Haskell"
|
|
string :: G (Datum :- t) (Text :- t)
|
|
string = simple >>> prismGrammar "string" unexpectedSimple #SimpleString
|
|
|
|
-- |
|
|
-- >>> decodeTest boolean "#t"
|
|
-- True
|
|
-- >>> decodeTest boolean "#false"
|
|
-- False
|
|
-- >>> encodeTest boolean True
|
|
-- #t
|
|
boolean :: G (Datum :- t) (Bool :- t)
|
|
boolean = simple >>> prismGrammar "boolean" unexpectedSimple #SimpleBoolean
|
|
|
|
-- |
|
|
-- >>> decodeTest number "123"
|
|
-- 123.0
|
|
-- >>> encodeTest number (fromInteger 456)
|
|
-- 456
|
|
number :: G (Datum :- t) (Scientific :- t)
|
|
number = simple >>> prismGrammar "number" unexpectedSimple #SimpleNumber
|
|
|
|
-- |
|
|
-- >>> decodeTest integer "123"
|
|
-- 123
|
|
-- >>> encodeTest number 456
|
|
-- 456
|
|
integer :: G (Datum :- t) (Integer :- t)
|
|
integer = number >>> partialOsi
|
|
((_Left %~ (unexpected . T.pack . show @Double)) . Sci.floatingOrInteger)
|
|
fromIntegral
|
|
|
|
int :: G (Datum :- t) (Int :- t)
|
|
int = integer >>> iso fromIntegral fromIntegral
|
|
|
|
|
|
-- high-level combinators
|
|
|
|
headTagged0 :: Text -> G (Datum :- t) t
|
|
headTagged0 s = list $ el (sym s)
|
|
|
|
headTagged0' :: Text -> DatumGrammar a -> G (Datum :- t) (List a :- t)
|
|
headTagged0' s gt = list $ el (sym s) >>> rest gt
|
|
|
|
headTagged1 :: Text -> DatumGrammar a -> G (Datum :- t) (a :- t)
|
|
headTagged1 s g1 = list $ el (sym s) >>> el g1
|
|
|
|
headTagged1'
|
|
:: Text
|
|
-> DatumGrammar a -> DatumGrammar b
|
|
-> G (Datum :- t) (List b :- a :- t)
|
|
headTagged1' s g1 gt = list $ el (sym s) >>> el g1 >>> rest gt
|
|
|
|
headTagged2
|
|
:: Text
|
|
-> DatumGrammar a -> DatumGrammar b
|
|
-> G (Datum :- t) (b :- a :- t)
|
|
headTagged2 s g1 g2 = list $ el (sym s) >>> el g1 >>> el g2
|
|
|
|
ifLike
|
|
-- | keyword
|
|
:: Text
|
|
-- | condition
|
|
-> DatumGrammar a
|
|
-- | consequent (then-branch)
|
|
-> DatumGrammar b
|
|
-- | alternative (else-branch)
|
|
-> DatumGrammar c
|
|
-> G (Datum :- t) (c :- b :- a :- t)
|
|
ifLike kw c t f = list $ el (symBuiltin kw) >>> el c >>> el t >>> el f
|
|
|
|
symBuiltin :: Text -> G (Datum :- t) t
|
|
symBuiltin s = modifyAnn (#syntax .~ SynBuiltin) >>> sym s
|
|
|
|
letLike
|
|
:: Text
|
|
-> (forall t. G (Datum :- t) (a :- t))
|
|
-> (forall t. G (Datum :- t) (b :- t))
|
|
-> G (Datum :- (List (a, b) :- t1)) t2
|
|
-> G (Datum :- t1) t2
|
|
letLike kw name rhs e = listWithIndentation (NSpecial 1) $
|
|
el (symBuiltin kw) >>> el bindings >>> el e
|
|
where
|
|
bindings = list $ rest binding
|
|
binding :: G (Datum :- t) ((_, _) :- t)
|
|
binding = list (el name >>> el rhs) >>> pair
|
|
|
|
lambdaLike
|
|
:: (forall t. G (Datum :- t) t)
|
|
-> DatumGrammar a
|
|
-> G (ListContext :- a :- t) (ListContext :- t')
|
|
-> G (Datum :- t) t'
|
|
lambdaLike kw formals body = listWithIndentation (NSpecial 1) $
|
|
el (modifyAnn (#syntax .~ SynBuiltin) >>> kw)
|
|
>>> el formals
|
|
>>> body
|
|
|
|
lambdaKeyword :: G (Datum :- t) t
|
|
lambdaKeyword = coproduct [ sym "λ", sym "lambda" ]
|
|
|
|
kappaKeyword :: G (Datum :- t) t
|
|
kappaKeyword = coproduct [ sym "κ", sym "kappa" ]
|
|
|
|
beginLike
|
|
:: Text
|
|
-> DatumGrammar a
|
|
-> G (Datum :- t) (List a :- t)
|
|
beginLike kw g =
|
|
listWithIndentation (NSpecial 0) $
|
|
el (symBuiltin kw) >>> rest g
|
|
|
|
isoIso :: Iso' s a -> Grammar p (s :- t) (a :- t)
|
|
isoIso l = iso (view l) (review l)
|
|
|
|
prismIso :: Mismatch -> Prism' s a -> Grammar p (s :- t) (a :- t)
|
|
prismIso mm p = partialOsi
|
|
(maybe (Left mm) Right . preview p)
|
|
(review p)
|