sexp-grammar 2.1.0 → 2.2.0
raw patch · 14 files changed
+110/−573 lines, 14 filesdep ~invertible-grammar
Dependency ranges changed: invertible-grammar
Files
- examples/Expr.hs +0/−82
- examples/ExprTH.hs +0/−82
- examples/ExprTH2.hs +0/−81
- examples/Lang.hs +0/−227
- examples/Misc.hs +0/−71
- sexp-grammar.cabal +7/−12
- src/Language/Sexp.hs +1/−0
- src/Language/Sexp/Lexer.x +4/−5
- src/Language/Sexp/Located.hs +1/−0
- src/Language/SexpGrammar.hs +1/−0
- src/Language/SexpGrammar/Base.hs +1/−0
- src/Language/SexpGrammar/Class.hs +58/−5
- src/Language/SexpGrammar/Generic.hs +1/−0
- test/Main.hs +36/−8
− examples/Expr.hs
@@ -1,82 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Expr where--import Prelude hiding ((.), id)-import Control.Category-import Data.Data (Data)-import qualified Data.ByteString.Lazy.Char8 as B8-import Data.Text (Text)--import qualified Language.Sexp.Located as Sexp-import Language.SexpGrammar-import Language.SexpGrammar.Generic-import GHC.Generics--newtype Ident = Ident Text- deriving (Show, Generic)--data Expr- = Var Ident- | Lit Int- | Add Expr Expr- | Mul Expr Expr- | Neg Expr- | Inv Expr- | IfZero Expr Expr (Maybe Expr)- | Apply [Expr] String Prim -- inconvenient ordering: arguments, useless annotation, identifier- deriving (Show, Generic)--data Prim- = SquareRoot- | Factorial- | Fibonacci- deriving (Eq, Enum, Bounded, Data, Show, Generic)--instance SexpIso Prim where- sexpIso = match- $ With (sym "square-root" >>>)- $ With (sym "factorial" >>>)- $ With (sym "fibonacci" >>>)- $ End--instance SexpIso Ident where- sexpIso = with (\ident -> ident . symbol)--instance SexpIso Expr where- sexpIso = match- $ With (\var -> var . sexpIso)- $ With (\lit -> lit . int)- $ With (\add -> add . list (el (sym "+") >>> el sexpIso >>> el sexpIso))- $ With (\mul -> mul . list (el (sym "*") >>> el sexpIso >>> el sexpIso))- $ With (\neg -> neg . list (el (sym "negate") >>> el sexpIso))- $ With (\inv -> inv . list (el (sym "invert") >>> el sexpIso))- $ With (\ifz -> ifz . list (el (sym "cond") >>> props ( "pred" .: sexpIso- >>> "true" .: sexpIso- >>> "false" .:? sexpIso )))- $ With (\app -> app . list- (el (sexpIso :: SexpGrammar Prim) >>> -- Push prim: prim :- ()- el (kwd "args") >>> -- Recognize :args, push nothing- rest (sexpIso :: SexpGrammar Expr) >>> -- Push args: args :- prim :- ()- onTail (swap >>> push "dummy"- (const True)- (const (expected "dummy")) >>> swap)- ))- $ End--exprGrammar :: SexpGrammar Expr-exprGrammar = sexpIso--test :: String -> SexpGrammar a -> (a, String)-test str g = either error id $ do- e <- decodeWith g "<stdio>" (B8.pack str)- sexp' <- toSexp g e- return (e, B8.unpack (Sexp.format sexp'))---- > test "(cond :pred 1 :true (+ 42 10) :false (* 2 (* 2 2)))"--- (IfZero (Lit 1) (Add (Lit 42) (Lit 10)) (Mul (Lit 2) (Mul (Lit 2) (Lit 2))),"(cond 1 (+ 42 10) (* 2 (* 2 2)))")
− examples/ExprTH.hs
@@ -1,82 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module ExprTH where--import Prelude hiding ((.), id)--import Control.Category-import qualified Data.ByteString.Lazy.Char8 as B8-import Data.Data (Data)-import Data.Text (Text)-import qualified Language.Sexp.Located as Sexp-import Language.SexpGrammar-import Language.SexpGrammar.TH--newtype Ident = Ident Text- deriving (Show)--data Expr- = Var Ident- | Lit Int- | Add Expr Expr- | Mul Expr Expr- | Inv Expr- | IfZero Expr Expr (Maybe Expr)- | Apply [Expr] String Prim -- inconvenient ordering: arguments, useless annotation, identifier- deriving (Show)--data Prim- = SquareRoot- | Factorial- | Fibonacci- deriving (Eq, Enum, Bounded, Data, Show)--return []--instance SexpIso Prim where- sexpIso = coproduct- [ $(grammarFor 'SquareRoot) . sym "square-root"- , $(grammarFor 'Factorial) . sym "factorial"- , $(grammarFor 'Fibonacci) . sym "fibonacci"- ]--instance SexpIso Ident where- sexpIso = $(grammarFor 'Ident) . symbol--instance SexpIso Expr where- sexpIso = coproduct- [ $(grammarFor 'Var) . sexpIso- , $(grammarFor 'Lit) . int- , $(grammarFor 'Add) . list (el (sym "+") >>> el sexpIso >>> el sexpIso)- , $(grammarFor 'Mul) . list (el (sym "*") >>> el sexpIso >>> el sexpIso)- , $(grammarFor 'Inv) . list (el (sym "invert") >>> el sexpIso)- , $(grammarFor 'IfZero) . list (el (sym "cond") >>> props ( "pred" .: sexpIso- >>> "true" .: sexpIso- >>> "false" .:? sexpIso ))- , $(grammarFor 'Apply) . -- Convert prim :- "dummy" :- args :- () to Apply node- list- (el (sexpIso :: SexpGrammar Prim) >>> -- Push prim: prim :- ()- el (kwd "args") >>> -- Recognize :args, push nothing- rest (sexpIso :: SexpGrammar Expr) >>> -- Push args: args :- prim :- ()- onTail (- swap >>> -- Swap: prim :- args :- ()- push "dummy" -- Push "dummy": "dummy" :- prim :- args :- ()- (const True)- (const (expected "dummy")) >>>- swap) -- Swap: prim :- "dummy" :- args :- ()- )- ]--test :: String -> SexpGrammar a -> (a, String)-test str g = either error id $ do- e <- decodeWith g "<stdio>" (B8.pack str)- sexp' <- toSexp g e- return (e, B8.unpack (Sexp.format sexp'))---- λ> test "(cond :pred 1 :true (+ 42 10) :false (* 2 (* 2 2)))" (sexpIso :: SexpG Expr)--- (IfZero (Lit 1) (Add (Lit 42) (Lit 10)) (Just (Mul (Lit 2) (Mul (Lit 2) (Lit 2)))),"(cond :false (* 2 (* 2 2)) :pred 1 :true (+ 42 10))")
− examples/ExprTH2.hs
@@ -1,81 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module ExprTH2 where--import Prelude hiding ((.), id)--import Control.Category-import qualified Data.ByteString.Lazy.Char8 as B8-import Data.Data (Data)-import Data.Text (Text)-import qualified Language.Sexp.Located as Sexp-import Language.SexpGrammar-import Language.SexpGrammar.TH--newtype Ident = Ident Text- deriving (Show)--data Expr- = Var Ident- | Lit Int- | Add Expr Expr- | Mul Expr Expr- | Inv Expr- | IfZero Expr Expr (Maybe Expr)- | Apply [Expr] String Prim -- inconvenient ordering: arguments, useless annotation, identifier- deriving (Show)--data Prim- = SquareRoot- | Factorial- | Fibonacci- deriving (Eq, Enum, Bounded, Data, Show)--return []--instance SexpIso Prim where- sexpIso = $(match ''Prim)- (sym "square-root" >>>)- (sym "factorial" >>>)- (sym "fibonacci" >>>)--instance SexpIso Ident where- sexpIso = $(match ''Ident)- (\_Ident -> _Ident . symbol)--instance SexpIso Expr where- sexpIso = $(match ''Expr)- (\_Var -> _Var . sexpIso)- (\_Lit -> _Lit . int)- (\_Add -> _Add . list (el (sym "+") >>> el sexpIso >>> el sexpIso))- (\_Mul -> _Mul . list (el (sym "*") >>> el sexpIso >>> el sexpIso))- (\_Inv -> _Inv . list (el (sym "invert") >>> el sexpIso))- (\_IfZero -> _IfZero . list (el (sym "cond") >>> props ( "pred" .: sexpIso- >>> "true" .: sexpIso- >>> "false" .:? sexpIso )))- (\_Apply -> _Apply . -- Convert prim :- "dummy" :- args :- () to Apply node- list- (el (sexpIso :: SexpGrammar Prim) >>> -- Push prim: prim :- ()- el (kwd "args") >>> -- Recognize :args, push nothing- rest (sexpIso :: SexpGrammar Expr) >>> -- Push args: args :- prim :- ()- onTail (- swap >>> -- Swap: prim :- args :- ()- push "dummy" -- Push "dummy": "dummy" :- prim :- args :- ()- (const True)- (const (expected "dummy")) >>>- swap) -- Swap: prim :- "dummy" :- args :- ()- ))--test :: String -> SexpGrammar a -> (a, String)-test str g = either error id $ do- e <- decodeWith g "<stdin>" (B8.pack str)- sexp' <- toSexp g e- return (e, B8.unpack (Sexp.format sexp'))---- λ> test "(cond :pred 1 :true (+ 42 10) :false (* 2 (* 2 2)))" (sexpIso :: SexpG Expr)--- (IfZero (Lit 1) (Add (Lit 42) (Lit 10)) (Just (Mul (Lit 2) (Mul (Lit 2) (Lit 2)))),"(cond :false (* 2 (* 2 2)) :pred 1 :true (+ 42 10))")
− examples/Lang.hs
@@ -1,227 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeOperators #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Lang where--import Prelude hiding ((.), id)-import Control.Category-import Control.Monad.Reader-import Data.Data (Data)-import qualified Data.ByteString.Lazy.Char8 as B8-import Data.Text (Text)-import qualified Data.Map as M-import qualified Data.Set as S-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-#endif-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 710-import Data.Foldable (foldl)-#endif-#if !MIN_VERSION_base(4,11,0)-import Data.Semigroup-#endif-import Data.Maybe--import Language.SexpGrammar-import Language.SexpGrammar.Generic-import GHC.Generics-import Data.Coerce--newtype Fix f = Fix (f (Fix f))--unFix :: Fix f -> f (Fix f)-unFix (Fix f) = f--fx :: Grammar g (f (Fix f) :- t) (Fix f :- t)-fx = iso coerce coerce--cata :: (Functor f) => (f a -> a) -> Fix f -> a-cata f = f . fmap (cata f) . unFix--data Literal- = LitInt Int- | LitDouble Double- deriving (Eq, Show, Generic)--asInt :: Literal -> Maybe Int-asInt (LitDouble _) = Nothing-asInt (LitInt a) = Just a--asDouble :: Literal -> Double-asDouble (LitDouble a) = a-asDouble (LitInt a) = fromIntegral a--instance SexpIso Literal where- sexpIso = match- $ With (\i -> i . int)- $ With (\d -> d . double)- $ End--newtype Ident = Ident Text- deriving (Eq, Ord, Show, Generic)--instance SexpIso Ident where- sexpIso = with (\ident -> ident . symbol)--data Func- = Prim Prim- | Named Ident- deriving (Eq, Show, Generic)--instance SexpIso Func where- sexpIso = match- $ With (\prim -> prim . sexpIso)- $ With (\named -> named . sexpIso)- $ End--data Prim- = Add- | Mul- | Sub- | Div- deriving (Eq, Show, Bounded, Enum, Data, Generic)--instance SexpIso Prim where- sexpIso = match- $ With (\_Add -> _Add . sym "+")- $ With (\_Mul -> _Mul . sym "*")- $ With (\_Sub -> _Sub . sym "-")- $ With (\_Div -> _Div . sym "/")- $ End--evalP :: Prim -> [Literal] -> Literal-evalP p =- case p of- Add -> \ls -> fromMaybe (LitDouble $ sum $ map asDouble ls)- (LitInt . sum <$> traverse asInt ls)- Mul -> \ls -> fromMaybe (LitDouble $ product $ map asDouble ls)- (LitInt . product <$> traverse asInt ls)- Sub -> \[a,b] -> fromMaybe (LitDouble $ asDouble a - asDouble b)- ((LitInt .) . (-) <$> asInt a <*> asInt b)- Div -> \[a,b] -> fromMaybe (LitDouble $ asDouble a / asDouble b)- ((LitInt .) . div <$> asInt a <*> asInt b)--type Expr = Fix ExprF--data ExprF e- = Lit Literal- | Var Ident- | Let Ident e e- | Apply Prim [e]- | Cond e e e- deriving (Eq, Show, Functor, Foldable, Traversable, Generic)--exprIso :: SexpGrammar (ExprF (Fix ExprF))-exprIso = match- $ With (\_Lit -> _Lit . sexpIso)- $ With (\_Var -> _Var . sexpIso)- $ With (\_Let -> _Let . list- ( el (sym "let") >>>- el sexpIso >>>- el (fx . exprIso) >>>- el (fx . exprIso) ) )- $ With (\_Apply -> _Apply . list- ( el sexpIso >>>- rest (fx . exprIso ) ) )- $ With (\_Cond -> _Cond . list- ( el (sym "if") >>>- el (fx . exprIso) >>>- el (fx . exprIso) >>>- el (fx . exprIso) ) )- $ End--instance SexpIso (Fix ExprF) where- sexpIso = fx . exprIso--type PEvalM = Reader (M.Map Ident Literal)--partialEval :: Expr -> Expr-partialEval e = runReader (cata alg e) M.empty- where- alg :: ExprF (PEvalM Expr) -> PEvalM Expr- alg (Lit a) = return (Fix $ Lit a)- alg (Var v) = do- val <- asks (M.lookup v)- case val of- Nothing -> return $ Fix (Var v)- Just a -> return $ Fix (Lit a)- alg (Let n e r) = do- e' <- e- r' <- case unFix e' of- Lit a -> local (M.insert n a) r- _ -> r- case unFix r' of- Lit a -> return (Fix $ Lit a)- _ -> case M.findWithDefault 0 n (gatherFreeVars r') of- 0 -> return r'- 1 -> return $ inline (M.singleton n e') r'- _ -> return (Fix $ Let n e' r')- alg (Apply p args) = do- args' <- sequence args- let args'' = getLits args'- return $ Fix $ maybe (Apply p args') (Lit . evalP p) args''- alg (Cond c t f) = do- c' <- c- t' <- t- f' <- f- case c' of- Fix (Lit (LitInt 0)) -> return f'- Fix (Lit (LitDouble 0.0)) -> return f'- Fix (Lit _) -> return t'- _ -> return $ Fix $ Cond c' t' f'--type FreeVarsM = Reader (S.Set Ident)--gatherFreeVars :: Expr -> M.Map Ident Int-gatherFreeVars e = runReader (cata alg e) S.empty- where- alg :: ExprF (FreeVarsM (M.Map Ident Int)) -> FreeVarsM (M.Map Ident Int)- alg (Let n e r) = do- e' <- e- r' <- local (S.insert n) r- return $ e' <> r'- alg (Var n) = do- bound <- asks (S.member n)- return $ if bound then M.empty else M.singleton n 1- alg other = foldl (M.unionWith (+)) M.empty <$> sequence other--getLits :: [Expr] -> Maybe [Literal]-getLits = sequence . map getLit- where- getLit (Fix (Lit a)) = Just a- getLit _ = Nothing--type InlineM = Reader (M.Map Ident Expr)--inline :: M.Map Ident Expr -> Expr -> Expr-inline env e = runReader (cata alg e) env- where- alg :: ExprF (InlineM Expr) -> InlineM Expr- alg (Var n) = do- subst <- asks (M.lookup n)- case subst of- Nothing -> return $ Fix $ Var n- Just e -> return e- alg (Let n e r) = do- e' <- e- r' <- local (M.delete n) r- return $ Fix $ Let n e' r'- alg other = Fix <$> sequence other--test :: String -> String-test str = either error id $ do- e <- decode (B8.pack str)- either error (return . B8.unpack) (encodePretty (partialEval e))---- λ> test "(let foo (/ 42 2) (let bar (* foo 1.5 baz) (if 0 foo (+ 1 bar))))"--- "(+ 1 (* 21 1.5 baz))"
− examples/Misc.hs
@@ -1,71 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeOperators #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Misc where--import Prelude hiding ((.), id)--import Control.Category-import qualified Data.ByteString.Lazy.Char8 as B8-import Data.Text (Text)--import qualified Language.Sexp.Located as Sexp-import Language.SexpGrammar-import Language.SexpGrammar.Generic--import GHC.Generics--newtype Ident = Ident String- deriving (Show, Generic)--data Pair a b = Pair a b- deriving (Show, Generic)--data Person = Person- { pName :: Text- , pAddress :: Text- , pAge :: Maybe Int- } deriving (Show, Generic)--instance (SexpIso a, SexpIso b) => SexpIso (Pair a b) where- sexpIso =- -- Combinator 'with' matches the single constructor of a datatype to a grammar- with $ \_Pair -> -- pops b, pops a, applies a to Pair,- -- apply b to (Pair a): (Pair a b :- t)- list ( -- begin list- el sexpIso >>> -- consume and push first element to stack: (a :- t)- el sexpIso -- consume and push second element to stack: (b :- a :- t)- ) >>> _Pair--instance SexpIso Person where- sexpIso = with $ \person ->- list (- el (sym "person") >>>- el string >>>- props (- "address" .: string >>>- "age" .:? int)) >>>- person---data FooBar a- = Foo Int Double- | Bar a- deriving (Show, Generic)--foobarSexp :: SexpGrammar (FooBar Int)-foobarSexp =- match $- With (\foo -> foo . list (el int >>> el double)) $- With (\bar -> bar . int) $- End--test :: String -> SexpGrammar a -> (a, String)-test str g = either error id $ do- e <- decodeWith g "<stdio>" (B8.pack str)- sexp' <- toSexp g e- return (e, B8.unpack (Sexp.format sexp'))
sexp-grammar.cabal view
@@ -1,25 +1,20 @@ name: sexp-grammar-version: 2.1.0+version: 2.2.0 license: BSD3 license-file: LICENSE-author: Eugene Smolanka, Sergey Vinokurov-maintainer: Eugene Smolanka <esmolanka@gmail.com>, Sergey Vinokurov <serg.foo@gmail.com>+author: Yevhen Smolanka, Sergey Vinokurov+maintainer: Yevhen Smolanka <ys@polymorphic.me> homepage: https://github.com/esmolanka/sexp-grammar category: Language build-type: Simple extra-source-files: README.md- examples/Expr.hs- examples/ExprTH.hs- examples/ExprTH2.hs- examples/Misc.hs- examples/Lang.hs cabal-version: >=1.10 synopsis: Invertible grammar combinators for S-expressions description: Serialisation to and deserialisation from S-expressions derived from a single grammar definition.-tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3+tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.5 source-repository head type: git@@ -53,10 +48,10 @@ , containers >=0.5.5 && <0.7 , deepseq >=1.0 && <2.0 , invertible-grammar >=0.1 && <0.2- , prettyprinter >=1 && <1.3- , recursion-schemes >=5.0 && <6.0+ , prettyprinter >=1 && <1.8+ , recursion-schemes >=5.0 && <5.2 , scientific >=0.3.3 && <0.4- , semigroups >=0.16 && <0.19+ , semigroups >=0.16 && <0.20 , text >=1.2 && <1.3 , utf8-string >=1.0 && <2.0
src/Language/Sexp.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
src/Language/Sexp/Lexer.x view
@@ -39,17 +39,16 @@ $hex = [0-9 A-F a-f] $alpha = [a-z A-Z] -@number = [\-\+]? $digit+ ([\.]$digit+)? ([eE] [\-\+]? $digit+)?+@number = [\-\+]? $digit+ ([\.]$digit+)? @escape = \\ [nrt\\\"] @string = $allgraphic # [\"\\] | $whitespace | @escape $unicode = $allgraphic # [\x20-\x80] -$syminitial = [$alpha \:\@\!\$\%\&\*\/\<\=\>\?\~\_\^\.\|\+\- $unicode]-$symsubseq = [$syminitial $digit \#\'\`\,]-@symescape = \\ [$alpha $digit \(\)\[\]\{\}\\\|\;\'\`\"\#\.\,]-@symbol = ($syminitial | @symescape) ($symsubseq | @symescape)*+$syminitial = [$alpha $digit \\\:\@\!\$\%\&\*\/\<\=\>\?\~\_\^\.\|\+\- $unicode]+$symsubseq = [$syminitial \#\'\`\,]+@symbol = $syminitial ($symsubseq)* :-
src/Language/Sexp/Located.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
src/Language/SexpGrammar.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Safe #-} {-# LANGUAGE TypeOperators #-} {- |
src/Language/SexpGrammar/Base.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeOperators #-} module Language.SexpGrammar.Base
src/Language/SexpGrammar/Class.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeOperators #-} module Language.SexpGrammar.Class@@ -40,10 +41,15 @@ class SexpIso a where sexpIso :: SexpGrammar a +instance SexpIso () where+ sexpIso = with $ \unit ->+ sym "nil" >>> unit+ instance SexpIso Bool where- sexpIso =- (sym "true" >>> push True (==True) (const $ expected "Bool")) <>- (sym "false" >>> push False (==False) (const $ expected "Bool"))+ sexpIso = match+ $ With (\false_ -> sym "false" >>> false_)+ $ With (\true_ -> sym "true" >>> true_)+ $ End instance SexpIso Int where sexpIso = int@@ -62,8 +68,55 @@ instance (SexpIso a, SexpIso b) => SexpIso (a, b) where sexpIso =- list (el sexpIso >>> el (sym ".") >>> el sexpIso) >>>- pair+ list (+ el sexpIso >>>+ el sexpIso) >>> pair++instance (SexpIso a, SexpIso b, SexpIso c) => SexpIso (a, b, c) where+ sexpIso = with $ \tuple3 ->+ list (+ el sexpIso >>>+ el sexpIso >>>+ el sexpIso) >>> tuple3++instance (SexpIso a, SexpIso b, SexpIso c, SexpIso d) => SexpIso (a, b, c, d) where+ sexpIso = with $ \tuple4 ->+ list (+ el sexpIso >>>+ el sexpIso >>>+ el sexpIso >>>+ el sexpIso) >>> tuple4++instance (SexpIso a, SexpIso b, SexpIso c, SexpIso d, SexpIso e) => SexpIso (a, b, c, d, e) where+ sexpIso = with $ \tuple5 ->+ list (+ el sexpIso >>>+ el sexpIso >>>+ el sexpIso >>>+ el sexpIso >>>+ el sexpIso) >>> tuple5++instance (SexpIso a, SexpIso b, SexpIso c, SexpIso d, SexpIso e, SexpIso f) => SexpIso (a, b, c, d, e, f) where+ sexpIso = with $ \tuple6 ->+ list (+ el sexpIso >>>+ el sexpIso >>>+ el sexpIso >>>+ el sexpIso >>>+ el sexpIso >>>+ el sexpIso) >>> tuple6++instance (SexpIso a, SexpIso b, SexpIso c, SexpIso d, SexpIso e, SexpIso f, SexpIso g) =>+ SexpIso (a, b, c, d, e, f, g) where+ sexpIso = with $ \tuple7 ->+ list (+ el sexpIso >>>+ el sexpIso >>>+ el sexpIso >>>+ el sexpIso >>>+ el sexpIso >>>+ el sexpIso >>>+ el sexpIso) >>> tuple7 instance (Ord k, SexpIso k, SexpIso v) => SexpIso (Map k v) where sexpIso = iso Map.fromList Map.toList . braceList (rest sexpIso)
src/Language/SexpGrammar/Generic.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE Safe #-} module Language.SexpGrammar.Generic ( -- * GHC.Generics helpers
test/Main.hs view
@@ -58,7 +58,14 @@ (oneof [ elements $ ['\n','\r','\t','"','\\', ' '] , arbitrary `suchThat` (\c -> isAlphaNum c || isPunctuation c) ])+ , AtomSymbol . TS.pack <$>+ listOf (arbitrary `suchThat` (\c -> isAlphaNum c || c `elem` ("#',`\\:@!$%&*/<=>?~_^.|+-" :: [Char])))+ `suchThat` (\s -> not $ all isDigit (drop 1 s) || null s || all (`elem` ("#',`" :: [Char])) (take 1 s)) , pure (AtomSymbol ":foo")+ , pure (AtomSymbol "1e2")+ , pure (AtomSymbol "-1e2")+ , pure (AtomSymbol "1.0e-2")+ , pure (AtomSymbol "+.0E-2") , pure (AtomSymbol "bar") , pure (AtomSymbol "~qux") , pure (AtomSymbol "символ")@@ -255,27 +262,48 @@ , testCase "-123 is an integer number" $ parseSexp' "-123" `sexpEq` Right (Number (- 123))- , testCase "+123.4e5 is a floating number" $- parseSexp' "+123.4e5"- `sexpEq` Right (Number (read "+123.4e5" :: Scientific))+ , testCase "+123.45 is a floating number" $+ parseSexp' "+123.45"+ `sexpEq` Right (Number (read "123.45" :: Scientific))+ , testCase "0_1 is a symbol" $+ parseSexp' "0_1"+ `sexpEq` Right (Symbol "0_1")+ , testCase "1e2 is a symbol" $+ parseSexp' "1e2"+ `sexpEq` Right (Symbol "1e2")+ , testCase "-1e2 is a symbol" $+ parseSexp' "-1e2"+ `sexpEq` Right (Symbol "-1e2") , testCase "comments" $ parseSexp' ";; hello, world\n 123" `sexpEq` Right (Number 123) , testCase "cyrillic characters in comments" $- parseSexp' ";; привет!\n 123"- `sexpEq` Right (Number 123)+ parseSexp' ";; Я в серці маю те, що не вмирає!\n SS17"+ `sexpEq` Right (Symbol "SS17") , testCase "unicode math in comments" $- parseSexp' ";; Γ ctx\n;; ----- Nat-formation\n;; Γ ⊦ Nat : Type\nfoobar"+ parseSexp' ";; Γ σ ⊢ → ∘ ℕ ∑ ∏ ẽ ∀\nfoobar" `sexpEq` Right (Symbol "foobar")- , testCase "symbol" $+ , testCase "hello-world is symbol" $ parseSexp' "hello-world" `sexpEq` Right (Symbol "hello-world")+ , testCase "\\forall is a symbol" $+ parseSexp' "∀"+ `sexpEq` Right (Symbol "∀")+ , testCase "\\Bbb{N} is a symbol" $+ parseSexp' "ℕ"+ `sexpEq` Right (Symbol "ℕ") , testCase "whitespace and symbol" $ parseSexp' "\t\n hello-world\n" `sexpEq` Right (Symbol "hello-world")- , testCase "cyrillic symbol" $+ , testCase "cyrillic characters symbol" $ parseSexp' "символ" `sexpEq` Right (Symbol "символ")+ , testCase "greek characters symbol" $+ parseSexp' "αβγΠΣΩ"+ `sexpEq` Right (Symbol "αβγΠΣΩ")+ , testCase "special-characters \"\\:$%^&*,\" symbol" $+ parseSexp' "\\:$%^&*,"+ `sexpEq` Right (Symbol "\\:$%^&*,") , testCase "string with arabic characters" $ parseSexp' "\"ي الخاطفة الجديدة، مع, بلديهم\"" `sexpEq` Right (String "ي الخاطفة الجديدة، مع, بلديهم")