├── README.md ├── sexp-grammar ├── CHANGELOG.md ├── Setup.hs ├── src │ └── Language │ │ ├── SexpGrammar │ │ ├── TH.hs │ │ ├── Generic.hs │ │ ├── Class.hs │ │ └── Base.hs │ │ ├── Sexp │ │ ├── Encode.hs │ │ ├── Pretty.hs │ │ ├── Token.hs │ │ ├── Parser.y │ │ ├── Types.hs │ │ ├── Located.hs │ │ └── Lexer.x │ │ ├── Sexp.hs │ │ └── SexpGrammar.hs ├── LICENSE ├── README.md ├── hackage-docs.sh ├── sexp-grammar.cabal ├── bench │ └── Main.hs └── test │ └── Main.hs ├── invertible-grammar ├── Setup.hs ├── README.md ├── src │ ├── Data │ │ ├── InvertibleGrammar.hs │ │ └── InvertibleGrammar │ │ │ ├── TH.hs │ │ │ ├── Combinators.hs │ │ │ ├── Monad.hs │ │ │ ├── Base.hs │ │ │ └── Generic.hs │ └── Control │ │ └── Monad │ │ └── ContextError.hs ├── LICENSE └── invertible-grammar.cabal ├── cabal.project ├── .gitignore ├── stack.yaml ├── examples ├── Misc.hs ├── Expr.hs ├── ExprTH2.hs ├── ExprTH.hs └── Lang.hs └── .github └── workflows └── haskell-ci.yml /README.md: -------------------------------------------------------------------------------- 1 | sexp-grammar/README.md -------------------------------------------------------------------------------- /sexp-grammar/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 2.3.4.0 2 | 3 | - Support datum comments `#;` 4 | -------------------------------------------------------------------------------- /sexp-grammar/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /invertible-grammar/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | invertible-grammar/invertible-grammar.cabal 3 | sexp-grammar/sexp-grammar.cabal 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | dist 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | .virtualenv 9 | .hsenv 10 | .cabal-sandbox/ 11 | cabal.sandbox.config 12 | cabal.config 13 | .stack-work 14 | packages/ 15 | -------------------------------------------------------------------------------- /sexp-grammar/src/Language/SexpGrammar/TH.hs: -------------------------------------------------------------------------------- 1 | 2 | module Language.SexpGrammar.TH 3 | ( -- * TemplateHaskell helpers 4 | grammarFor 5 | , match 6 | ) where 7 | 8 | import Data.InvertibleGrammar.TH 9 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.8 2 | packages: 3 | - 'sexp-grammar' 4 | - 'invertible-grammar' 5 | extra-deps: 6 | - 'prettyprinter-1.7.0@sha256:6a9569e21fa61163a7f066d23d701e23e917893e8f39733d6e617ec72787ae5f,6007' 7 | -------------------------------------------------------------------------------- /invertible-grammar/README.md: -------------------------------------------------------------------------------- 1 | 2 | invertible-grammar 3 | ================== 4 | 5 | Framework to build invertible parsing combinator libraries. 6 | 7 | See [`sexp-grammar`](http://github.com/esmolanka/sexp-grammar). 8 | -------------------------------------------------------------------------------- /sexp-grammar/src/Language/SexpGrammar/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Language.SexpGrammar.Generic 4 | ( -- * GHC.Generics helpers 5 | with 6 | , match 7 | , Coproduct (..) 8 | ) where 9 | 10 | import Data.InvertibleGrammar.Generic 11 | -------------------------------------------------------------------------------- /invertible-grammar/src/Data/InvertibleGrammar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Data.InvertibleGrammar 4 | ( -- * Base 5 | Grammar, (:-), forward, backward 6 | -- * Combinators 7 | , module Data.InvertibleGrammar.Combinators 8 | -- * Running grammars 9 | , runGrammar 10 | , runGrammarDoc 11 | , runGrammarString 12 | -- ** Error messages 13 | , ErrorMessage(..) 14 | , ContextError, Propagation , GrammarError 15 | , Mismatch, expected, unexpected 16 | ) where 17 | 18 | import Data.InvertibleGrammar.Base 19 | import Data.InvertibleGrammar.Combinators 20 | import Data.InvertibleGrammar.Monad 21 | -------------------------------------------------------------------------------- /sexp-grammar/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Eugene Smolanka, Sergey Vinokurov. 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of multiple nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /invertible-grammar/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Eugene Smolanka, Sergey Vinokurov. 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of multiple nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /invertible-grammar/invertible-grammar.cabal: -------------------------------------------------------------------------------- 1 | name: invertible-grammar 2 | version: 0.1.3.5 3 | license: BSD3 4 | license-file: LICENSE 5 | author: Yevhen Smolanka, Sergey Vinokurov 6 | maintainer: Yevhen Smolanka 7 | homepage: https://github.com/esmolanka/invertible-grammar 8 | category: Language 9 | build-type: Simple 10 | extra-source-files: README.md 11 | cabal-version: >=1.10 12 | synopsis: 13 | Invertible parsing combinators framework 14 | description: 15 | Grammar combinator framework to build invertible parsing libraries 16 | for concrete syntax. 17 | tested-with: 18 | GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8, GHC == 9.4.8, GHC == 9.6.6, GHC == 9.8.4, GHC == 9.10.1, GHC == 9.12.2 19 | 20 | source-repository head 21 | type: git 22 | location: https://github.com/esmolanka/sexp-grammar 23 | 24 | library 25 | hs-source-dirs: src 26 | default-language: Haskell2010 27 | ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind 28 | exposed-modules: 29 | Data.InvertibleGrammar 30 | Data.InvertibleGrammar.Base 31 | Data.InvertibleGrammar.Combinators 32 | Data.InvertibleGrammar.Generic 33 | Data.InvertibleGrammar.TH 34 | 35 | other-modules: 36 | Control.Monad.ContextError 37 | Data.InvertibleGrammar.Monad 38 | 39 | build-depends: 40 | base >=4.11 && <5.0 41 | , bifunctors >=4.2 && <6.0 42 | , containers >=0.5.5 && <0.8 43 | , mtl >=2.2 && <2.4 44 | , prettyprinter >=1.7 && <2.0 45 | , profunctors >=4.4 && <5.7 46 | , semigroups >=0.16 && <0.21 47 | , tagged >=0.7 && <0.9 48 | , template-haskell >=2.9 && <2.24 49 | , transformers >=0.3 && <0.7 50 | , text >=1.2 && <1.3 || >=2.0 && <2.2 51 | -------------------------------------------------------------------------------- /sexp-grammar/src/Language/Sexp/Encode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeSynonymInstances #-} 7 | 8 | module Language.Sexp.Encode (encode) where 9 | 10 | import Data.Functor.Foldable (cata) 11 | import Data.List (intersperse) 12 | import Data.Scientific 13 | import qualified Data.Text.Encoding as T (encodeUtf8) 14 | import qualified Data.Text.Lazy as TL 15 | import qualified Data.Text.Lazy.Encoding as TL (encodeUtf8) 16 | import Data.ByteString.Lazy.Char8 (ByteString) 17 | #if MIN_VERSION_bytestring(0,11,0) 18 | import Data.ByteString.Builder 19 | #else 20 | import Data.ByteString.Lazy.Builder.ASCII 21 | #endif 22 | 23 | import Language.Sexp.Types 24 | import Language.Sexp.Token (escape) 25 | 26 | buildSexp :: Fix SexpF -> Builder 27 | buildSexp = cata alg 28 | where 29 | hsep :: [Builder] -> Builder 30 | hsep = mconcat . intersperse (char8 ' ') 31 | 32 | alg :: SexpF Builder -> Builder 33 | alg = \case 34 | AtomF atom -> case atom of 35 | AtomNumber a 36 | | isInteger a -> string8 (formatScientific Fixed (Just 0) a) 37 | | otherwise -> string8 (formatScientific Fixed Nothing a) 38 | AtomString a -> char8 '"' <> lazyByteString (TL.encodeUtf8 (escape (TL.fromStrict a))) <> char8 '"' 39 | AtomSymbol a -> byteString (T.encodeUtf8 a) 40 | ParenListF ss -> char8 '(' <> hsep ss <> char8 ')' 41 | BracketListF ss -> char8 '[' <> hsep ss <> char8 ']' 42 | BraceListF ss -> char8 '{' <> hsep ss <> char8 '}' 43 | ModifiedF q a -> case q of 44 | Quote -> char8 '\'' <> a 45 | Backtick -> char8 '`' <> a 46 | Comma -> char8 ',' <> a 47 | CommaAt -> char8 ',' <> char8 '@' <> a 48 | Hash -> char8 '#' <> a 49 | 50 | encode :: Fix SexpF -> ByteString 51 | encode = toLazyByteString . buildSexp 52 | -------------------------------------------------------------------------------- /sexp-grammar/src/Language/Sexp/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | {-# OPTIONS_GHC -fno-warn-orphans #-} 6 | 7 | module Language.Sexp.Pretty 8 | ( format 9 | ) where 10 | 11 | import Data.ByteString.Lazy.Char8 (ByteString) 12 | import Data.Functor.Foldable (para) 13 | import Data.Scientific 14 | import qualified Data.Text.Lazy as TL 15 | import Data.Text.Lazy.Encoding (encodeUtf8) 16 | import Prettyprinter 17 | import Prettyprinter.Internal (unsafeTextWithoutNewlines) 18 | import qualified Prettyprinter.Render.Text as Render 19 | 20 | import Language.Sexp.Types 21 | import Language.Sexp.Token (escape) 22 | 23 | instance Pretty Atom where 24 | pretty = \case 25 | AtomNumber a 26 | | isInteger a -> pretty $ formatScientific Fixed (Just 0) a 27 | | otherwise -> pretty $ formatScientific Fixed Nothing $ a 28 | AtomString a -> dquotes (unsafeTextWithoutNewlines . TL.toStrict . escape . TL.fromStrict $ a) 29 | AtomSymbol a -> pretty a 30 | 31 | ppList :: [(Fix SexpF, Doc ann)] -> Doc ann 32 | ppList ls = case ls of 33 | ((Fix (AtomF _),_) : _) -> 34 | group $ align $ nest 1 $ vsep $ map snd ls 35 | _other -> 36 | group $ align $ vsep $ map snd ls 37 | 38 | ppSexp :: Fix SexpF -> Doc ann 39 | ppSexp = para $ \case 40 | AtomF a -> pretty a 41 | ParenListF ss -> parens $ ppList ss 42 | BracketListF ss -> brackets $ ppList ss 43 | BraceListF ss -> braces $ ppList ss 44 | ModifiedF q a -> 45 | case q of 46 | Quote -> "'" <> snd a 47 | Backtick -> "`" <> snd a 48 | Comma -> "," <> snd a 49 | CommaAt -> ",@" <> snd a 50 | Hash -> "#" <> snd a 51 | 52 | instance Pretty (Fix SexpF) where 53 | pretty = ppSexp 54 | 55 | -- | Serialize a 'Sexp' into a pretty-printed string 56 | format :: Fix SexpF -> ByteString 57 | format = 58 | encodeUtf8 . 59 | Render.renderLazy . 60 | layoutSmart (LayoutOptions (AvailablePerLine 79 0.75)) . 61 | ppSexp 62 | -------------------------------------------------------------------------------- /examples/Misc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | {-# OPTIONS_GHC -fno-warn-orphans #-} 7 | 8 | module Misc where 9 | 10 | import Prelude hiding ((.), id) 11 | 12 | import Control.Category 13 | import qualified Data.ByteString.Lazy.Char8 as B8 14 | import Data.Text (Text) 15 | 16 | import qualified Language.Sexp.Located as Sexp 17 | import Language.SexpGrammar 18 | import Language.SexpGrammar.Generic 19 | 20 | import GHC.Generics 21 | 22 | newtype Ident = Ident String 23 | deriving (Show, Generic) 24 | 25 | data Pair a b = Pair a b 26 | deriving (Show, Generic) 27 | 28 | data Person = Person 29 | { pName :: Text 30 | , pAddress :: Text 31 | , pAge :: Maybe Int 32 | } deriving (Show, Generic) 33 | 34 | instance (SexpIso a, SexpIso b) => SexpIso (Pair a b) where 35 | sexpIso = 36 | -- Combinator 'with' matches the single constructor of a datatype to a grammar 37 | with $ \_Pair -> -- pops b, pops a, applies a to Pair, 38 | -- apply b to (Pair a): (Pair a b :- t) 39 | list ( -- begin list 40 | el sexpIso >>> -- consume and push first element to stack: (a :- t) 41 | el sexpIso -- consume and push second element to stack: (b :- a :- t) 42 | ) >>> _Pair 43 | 44 | instance SexpIso Person where 45 | sexpIso = with $ \person -> 46 | list ( 47 | el (sym "person") >>> 48 | el string >>> 49 | props ( 50 | "address" .: string >>> 51 | "age" .:? int)) >>> 52 | person 53 | 54 | 55 | data FooBar a 56 | = Foo Int Double 57 | | Bar a 58 | deriving (Show, Generic) 59 | 60 | foobarSexp :: SexpGrammar (FooBar Int) 61 | foobarSexp = 62 | match $ 63 | With (\foo -> foo . list (el int >>> el double)) $ 64 | With (\bar -> bar . int) $ 65 | End 66 | 67 | test :: String -> SexpGrammar a -> (a, String) 68 | test str g = either error id $ do 69 | e <- decodeWith g "" (B8.pack str) 70 | sexp' <- toSexp g e 71 | return (e, B8.unpack (Sexp.format sexp')) 72 | -------------------------------------------------------------------------------- /sexp-grammar/src/Language/Sexp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | {-# LANGUAGE Trustworthy #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | {-# OPTIONS_GHC -fno-warn-orphans #-} 7 | 8 | module Language.Sexp 9 | ( 10 | -- * Parse and print 11 | decode 12 | , decodeMany 13 | , encode 14 | , format 15 | -- * Type 16 | , Sexp 17 | , pattern Atom 18 | , pattern Number 19 | , pattern Symbol 20 | , pattern String 21 | , pattern ParenList 22 | , pattern BracketList 23 | , pattern BraceList 24 | , pattern Modified 25 | -- ** Internal types 26 | , SexpF (..) 27 | , Atom (..) 28 | , Prefix (..) 29 | ) where 30 | 31 | import Data.ByteString.Lazy.Char8 (ByteString, unpack) 32 | import Data.Text (Text) 33 | import Data.Scientific (Scientific) 34 | 35 | import Language.Sexp.Types 36 | import Language.Sexp.Parser (parseSexp_, parseSexps_) 37 | import Language.Sexp.Lexer (lexSexp) 38 | import qualified Language.Sexp.Pretty as Internal 39 | import qualified Language.Sexp.Encode as Internal 40 | 41 | type Sexp = Fix SexpF 42 | 43 | instance {-# OVERLAPPING #-} Show Sexp where 44 | show = unpack . encode 45 | 46 | -- | Deserialise a 'Sexp' from a string 47 | decode :: ByteString -> Either String Sexp 48 | decode = fmap stripLocation . parseSexp_ . lexSexp (Position "" 1 0) 49 | 50 | -- | Deserialise potentially multiple 'Sexp' from a string 51 | decodeMany :: ByteString -> Either String [Sexp] 52 | decodeMany = fmap (fmap stripLocation) . parseSexps_ . lexSexp (Position "" 1 0) 53 | 54 | -- | Serialise a 'Sexp' into a compact string 55 | encode :: Sexp -> ByteString 56 | encode = Internal.encode 57 | 58 | -- | Serialise a 'Sexp' into a pretty-printed string 59 | format :: Sexp -> ByteString 60 | format = Internal.format 61 | 62 | ---------------------------------------------------------------------- 63 | 64 | pattern Atom :: Atom -> Sexp 65 | pattern Atom a = Fix (AtomF a) 66 | 67 | pattern Number :: Scientific -> Sexp 68 | pattern Number a = Fix (AtomF (AtomNumber a)) 69 | 70 | pattern Symbol :: Text -> Sexp 71 | pattern Symbol a = Fix (AtomF (AtomSymbol a)) 72 | 73 | pattern String :: Text -> Sexp 74 | pattern String a = Fix (AtomF (AtomString a)) 75 | 76 | pattern ParenList :: [Sexp] -> Sexp 77 | pattern ParenList ls = Fix (ParenListF ls) 78 | 79 | pattern BracketList :: [Sexp] -> Sexp 80 | pattern BracketList ls = Fix (BracketListF ls) 81 | 82 | pattern BraceList :: [Sexp] -> Sexp 83 | pattern BraceList ls = Fix (BraceListF ls) 84 | 85 | pattern Modified :: Prefix -> Sexp -> Sexp 86 | pattern Modified q s = Fix (ModifiedF q s) 87 | -------------------------------------------------------------------------------- /sexp-grammar/README.md: -------------------------------------------------------------------------------- 1 | [![Build](https://github.com/esmolanka/sexp-grammar/actions/workflows/build.yml/badge.svg)](https://github.com/esmolanka/sexp-grammar/actions/workflows/build.yml) 2 | 3 | sexp-grammar 4 | ============ 5 | 6 | Library of invertible parsing combinators for S-expressions. The 7 | combinators define primitive grammars and ways to compose them. A 8 | grammar constructed with these combinators can be run in two 9 | directions: parsing from S-expressions direction (forward) and 10 | serialising to S-expressions direction (backward). 11 | 12 | The approach used in `sexp-grammar` is inspired by the paper 13 | [Invertible syntax descriptions: Unifying parsing and pretty printing](http://www.informatik.uni-marburg.de/~rendel/unparse/) 14 | and a similar implementation of invertible grammar approach for JSON, library by 15 | Martijn van Steenbergen called [JsonGrammar2](https://github.com/MedeaMelana/JsonGrammar2). 16 | 17 | Let's have a look at `sexp-grammar` at work: 18 | 19 | ```haskell 20 | {-# LANGUAGE DeriveGeneric #-} 21 | {-# LANGUAGE OverloadedStrings #-} 22 | {-# LANGUAGE TypeOperators #-} 23 | 24 | import GHC.Generics 25 | import Data.Text (Text) 26 | import Language.SexpGrammar 27 | import Language.SexpGrammar.Generic 28 | 29 | data Person = Person 30 | { pName :: Text 31 | , pAddress :: Text 32 | , pAge :: Maybe Int 33 | } deriving (Show, Generic) 34 | 35 | instance SexpIso Person where 36 | sexpIso = with $ \person -> -- Person is isomorphic to: 37 | list ( -- a list with 38 | el (sym "person") >>> -- a symbol "person", 39 | el string >>> -- a string, and 40 | props ( -- a property-list with 41 | "address" .: string >>> -- a keyword :address and a string value, and 42 | "age" .:? int)) >>> -- an optional keyword :age with int value. 43 | person 44 | ``` 45 | 46 | We've just defined an isomorphism between S-expression representation 47 | and Haskell data record representation of the same information. 48 | 49 | ```haskell 50 | ghci> :set -XTypeApplications 51 | ghci> import Language.SexpGrammar 52 | ghci> import Data.ByteString.Lazy.Char8 (pack, unpack) 53 | ghci> person <- either error return . decode @Person . pack =<< getLine 54 | (person "John Doe" :address "42 Whatever str." :age 25) 55 | ghci> person 56 | Person {pName = "John Doe", pAddress = "42 Whatever str.", pAge = Just 25} 57 | ghci> putStrLn (either id unpack (encode person)) 58 | (person "John Doe" :address "42 Whatever str." :age 25) 59 | ``` 60 | 61 | See more [examples](https://github.com/esmolanka/sexp-grammar/tree/master/examples) 62 | in the repository. 63 | -------------------------------------------------------------------------------- /sexp-grammar/hackage-docs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | # This is a MacOS compiant fork of https://github.com/phadej/binary-orphans/blob/master/hackage-docs.sh, 5 | # which is a stack-enabled fork of https://github.com/ekmett/lens/blob/master/scripts/hackage-docs.sh 6 | # :-) 7 | 8 | if [ "$#" -ne 1 ]; then 9 | echo "Usage: scripts/hackage-docs.sh HACKAGE_USER" 10 | exit 1 11 | fi 12 | 13 | user=$1 14 | 15 | cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit) 16 | if [ ! -f "$cabal_file" ]; then 17 | echo "Run this script in the top-level package directory" 18 | exit 1 19 | fi 20 | 21 | pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name" { print $2 }' < "$cabal_file") 22 | ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file") 23 | 24 | if [ -z "$pkg" ]; then 25 | echo "Unable to determine package name" 26 | exit 1 27 | fi 28 | 29 | if [ -z "$ver" ]; then 30 | echo "Unable to determine package version" 31 | exit 1 32 | fi 33 | 34 | echo "Detected package: $pkg-$ver" 35 | 36 | dir=$(mktemp -d build-docs.XXXXXX) 37 | trap 'rm -r "$dir"' EXIT 38 | 39 | export PATH=$(stack path --bin-path) 40 | 41 | ghc --version 42 | cabal --version 43 | stack --version 44 | 45 | if haddock --hyperlinked-source >/dev/null 46 | then 47 | echo "Using fancy hyperlinked source" 48 | HYPERLINK_FLAG="--haddock-option=--hyperlinked-source" 49 | else 50 | echo "Using boring hyperlinked source" 51 | HYPERLINK_FLAG="--hyperlink-source" 52 | fi 53 | 54 | # Cabal dist in temporary location 55 | builddir=$dir/dist 56 | 57 | # Build dependencies haddocks with stack, so we get links 58 | stack haddock --only-dependencies 59 | 60 | # Configure using stack databases 61 | snapshotpkgdb=$(stack path --snapshot-pkg-db) 62 | localpkgdb=$(stack path --local-pkg-db) 63 | cabal configure -v2 --builddir=$builddir --package-db=clear --package-db=global --package-db=$snapshotpkgdb --package-db=$localpkgdb 64 | 65 | # Build Hadckage compatible docs 66 | cabal haddock -v2 --builddir=$builddir $HYPERLINK_FLAG --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version' 67 | 68 | # Copy into right directory 69 | cp -R $builddir/doc/html/$pkg/ $dir/$pkg-$ver-docs 70 | 71 | EXTRAFLAGS="" 72 | if [[ $(uname) == "Darwin" ]] 73 | then 74 | EXTRAFLAGS="--disable-copyfile" 75 | fi 76 | 77 | # Tar and gzip 78 | tar cvz -C $dir $EXTRAFLAGS --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs 79 | 80 | # Upload 81 | curl -X PUT \ 82 | -H 'Content-Type: application/x-tar' \ 83 | -H 'Content-Encoding: gzip' \ 84 | -u "$user" \ 85 | --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \ 86 | "https://hackage.haskell.org/package/$pkg-$ver/docs" 87 | -------------------------------------------------------------------------------- /examples/Expr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | 6 | {-# OPTIONS_GHC -fno-warn-orphans #-} 7 | 8 | module Expr where 9 | 10 | import Prelude hiding ((.), id) 11 | import Control.Category 12 | import Data.Data (Data) 13 | import qualified Data.ByteString.Lazy.Char8 as B8 14 | import Data.Text (Text) 15 | 16 | import qualified Language.Sexp.Located as Sexp 17 | import Language.SexpGrammar 18 | import Language.SexpGrammar.Generic 19 | import GHC.Generics 20 | 21 | newtype Ident = Ident Text 22 | deriving (Show, Generic) 23 | 24 | data Expr 25 | = Var Ident 26 | | Lit Int 27 | | Add Expr Expr 28 | | Mul Expr Expr 29 | | Neg Expr 30 | | Inv Expr 31 | | IfZero Expr Expr (Maybe Expr) 32 | | Apply [Expr] String Prim -- inconvenient ordering: arguments, useless annotation, identifier 33 | deriving (Show, Generic) 34 | 35 | data Prim 36 | = SquareRoot 37 | | Factorial 38 | | Fibonacci 39 | deriving (Eq, Enum, Bounded, Data, Show, Generic) 40 | 41 | instance SexpIso Prim where 42 | sexpIso = match 43 | $ With (sym "square-root" >>>) 44 | $ With (sym "factorial" >>>) 45 | $ With (sym "fibonacci" >>>) 46 | $ End 47 | 48 | instance SexpIso Ident where 49 | sexpIso = with (\ident -> ident . symbol) 50 | 51 | instance SexpIso Expr where 52 | sexpIso = match 53 | $ With (\var -> var . sexpIso) 54 | $ With (\lit -> lit . int) 55 | $ With (\add -> add . list (el (sym "+") >>> el sexpIso >>> el sexpIso)) 56 | $ With (\mul -> mul . list (el (sym "*") >>> el sexpIso >>> el sexpIso)) 57 | $ With (\neg -> neg . list (el (sym "negate") >>> el sexpIso)) 58 | $ With (\inv -> inv . list (el (sym "invert") >>> el sexpIso)) 59 | $ With (\ifz -> ifz . list (el (sym "cond") >>> props ( "pred" .: sexpIso 60 | >>> "true" .: sexpIso 61 | >>> "false" .:? sexpIso ))) 62 | $ With (\app -> app . list 63 | (el (sexpIso :: SexpGrammar Prim) >>> -- Push prim: prim :- () 64 | el (kwd "args") >>> -- Recognize :args, push nothing 65 | rest (sexpIso :: SexpGrammar Expr) >>> -- Push args: args :- prim :- () 66 | onTail (swap >>> push "dummy" 67 | (const True) 68 | (const (expected "dummy")) >>> swap) 69 | )) 70 | $ End 71 | 72 | exprGrammar :: SexpGrammar Expr 73 | exprGrammar = sexpIso 74 | 75 | test :: String -> SexpGrammar a -> (a, String) 76 | test str g = either error id $ do 77 | e <- decodeWith g "" (B8.pack str) 78 | sexp' <- toSexp g e 79 | return (e, B8.unpack (Sexp.format sexp')) 80 | 81 | -- > test "(cond :pred 1 :true (+ 42 10) :false (* 2 (* 2 2)))" 82 | -- (IfZero (Lit 1) (Add (Lit 42) (Lit 10)) (Mul (Lit 2) (Mul (Lit 2) (Lit 2))),"(cond 1 (+ 42 10) (* 2 (* 2 2)))") 83 | -------------------------------------------------------------------------------- /sexp-grammar/sexp-grammar.cabal: -------------------------------------------------------------------------------- 1 | name: sexp-grammar 2 | version: 2.3.4.2 3 | license: BSD3 4 | license-file: LICENSE 5 | author: Yevhen Smolanka, Sergey Vinokurov 6 | maintainer: Yevhen Smolanka 7 | homepage: https://github.com/esmolanka/sexp-grammar 8 | category: Language 9 | build-type: Simple 10 | extra-source-files: README.md 11 | cabal-version: >=1.10 12 | synopsis: 13 | Invertible grammar combinators for S-expressions 14 | description: 15 | Serialisation to and deserialisation from S-expressions derived from 16 | a single grammar definition. 17 | tested-with: 18 | GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8, GHC == 9.4.8, GHC == 9.6.6, GHC == 9.8.4, GHC == 9.10.1, GHC == 9.12.2 19 | 20 | source-repository head 21 | type: git 22 | location: https://github.com/esmolanka/sexp-grammar 23 | 24 | library 25 | hs-source-dirs: src 26 | default-language: Haskell2010 27 | ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind 28 | exposed-modules: 29 | Language.Sexp 30 | Language.Sexp.Located 31 | Language.SexpGrammar 32 | Language.SexpGrammar.TH 33 | Language.SexpGrammar.Generic 34 | 35 | other-modules: 36 | Language.Sexp.Encode 37 | Language.Sexp.Lexer 38 | Language.Sexp.Parser 39 | Language.Sexp.Pretty 40 | Language.Sexp.Token 41 | Language.Sexp.Types 42 | Language.SexpGrammar.Base 43 | Language.SexpGrammar.Class 44 | 45 | build-depends: 46 | array >=0.5 && <0.6 47 | , base >=4.11 && <5.0 48 | , bytestring >=0.10 && <0.13 49 | , containers >=0.5.5 && <0.8 50 | , data-fix >=0.3 && <0.4 51 | , deepseq >=1.4.3 && <2.0 52 | , invertible-grammar >=0.1.3 && <0.2 53 | , prettyprinter >=1.7 && <1.8 54 | , recursion-schemes >=5.2 && <5.3 55 | , scientific >=0.3.3 && <0.4 56 | , semigroups >=0.16 && <0.21 57 | , text >=1.2 && <1.3 || >=2.0 && <2.2 58 | , utf8-string >=1.0 && <2.0 59 | 60 | build-tools: alex, happy 61 | 62 | test-suite sexp-grammar-test 63 | type: exitcode-stdio-1.0 64 | build-depends: 65 | QuickCheck 66 | , base 67 | , bytestring 68 | , containers 69 | , invertible-grammar 70 | , prettyprinter 71 | , scientific 72 | , semigroups 73 | , sexp-grammar 74 | , tasty 75 | , tasty-hunit 76 | , tasty-quickcheck 77 | , text 78 | main-is: Main.hs 79 | hs-source-dirs: test 80 | default-language: Haskell2010 81 | 82 | benchmark sexp-grammar-bench 83 | type: exitcode-stdio-1.0 84 | build-depends: 85 | base 86 | , bytestring 87 | , criterion 88 | , deepseq 89 | , sexp-grammar 90 | , text 91 | main-is: Main.hs 92 | hs-source-dirs: bench 93 | default-language: Haskell2010 94 | -------------------------------------------------------------------------------- /examples/ExprTH2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | {-# OPTIONS_GHC -fno-warn-orphans #-} 7 | 8 | module ExprTH2 where 9 | 10 | import Prelude hiding ((.), id) 11 | 12 | import Control.Category 13 | import qualified Data.ByteString.Lazy.Char8 as B8 14 | import Data.Data (Data) 15 | import Data.Text (Text) 16 | import qualified Language.Sexp.Located as Sexp 17 | import Language.SexpGrammar 18 | import Language.SexpGrammar.TH 19 | 20 | newtype Ident = Ident Text 21 | deriving (Show) 22 | 23 | data Expr 24 | = Var Ident 25 | | Lit Int 26 | | Add Expr Expr 27 | | Mul Expr Expr 28 | | Inv Expr 29 | | IfZero Expr Expr (Maybe Expr) 30 | | Apply [Expr] String Prim -- inconvenient ordering: arguments, useless annotation, identifier 31 | deriving (Show) 32 | 33 | data Prim 34 | = SquareRoot 35 | | Factorial 36 | | Fibonacci 37 | deriving (Eq, Enum, Bounded, Data, Show) 38 | 39 | return [] 40 | 41 | instance SexpIso Prim where 42 | sexpIso = $(match ''Prim) 43 | (sym "square-root" >>>) 44 | (sym "factorial" >>>) 45 | (sym "fibonacci" >>>) 46 | 47 | instance SexpIso Ident where 48 | sexpIso = $(match ''Ident) 49 | (\_Ident -> _Ident . symbol) 50 | 51 | instance SexpIso Expr where 52 | sexpIso = $(match ''Expr) 53 | (\_Var -> _Var . sexpIso) 54 | (\_Lit -> _Lit . int) 55 | (\_Add -> _Add . list (el (sym "+") >>> el sexpIso >>> el sexpIso)) 56 | (\_Mul -> _Mul . list (el (sym "*") >>> el sexpIso >>> el sexpIso)) 57 | (\_Inv -> _Inv . list (el (sym "invert") >>> el sexpIso)) 58 | (\_IfZero -> _IfZero . list (el (sym "cond") >>> props ( "pred" .: sexpIso 59 | >>> "true" .: sexpIso 60 | >>> "false" .:? sexpIso ))) 61 | (\_Apply -> _Apply . -- Convert prim :- "dummy" :- args :- () to Apply node 62 | list 63 | (el (sexpIso :: SexpGrammar Prim) >>> -- Push prim: prim :- () 64 | el (kwd "args") >>> -- Recognize :args, push nothing 65 | rest (sexpIso :: SexpGrammar Expr) >>> -- Push args: args :- prim :- () 66 | onTail ( 67 | swap >>> -- Swap: prim :- args :- () 68 | push "dummy" -- Push "dummy": "dummy" :- prim :- args :- () 69 | (const True) 70 | (const (expected "dummy")) >>> 71 | swap) -- Swap: prim :- "dummy" :- args :- () 72 | )) 73 | 74 | test :: String -> SexpGrammar a -> (a, String) 75 | test str g = either error id $ do 76 | e <- decodeWith g "" (B8.pack str) 77 | sexp' <- toSexp g e 78 | return (e, B8.unpack (Sexp.format sexp')) 79 | 80 | -- λ> test "(cond :pred 1 :true (+ 42 10) :false (* 2 (* 2 2)))" (sexpIso :: SexpG Expr) 81 | -- (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))") 82 | -------------------------------------------------------------------------------- /examples/ExprTH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | {-# OPTIONS_GHC -fno-warn-orphans #-} 7 | 8 | module ExprTH where 9 | 10 | import Prelude hiding ((.), id) 11 | 12 | import Control.Category 13 | import qualified Data.ByteString.Lazy.Char8 as B8 14 | import Data.Data (Data) 15 | import Data.Text (Text) 16 | import qualified Language.Sexp.Located as Sexp 17 | import Language.SexpGrammar 18 | import Language.SexpGrammar.TH 19 | 20 | newtype Ident = Ident Text 21 | deriving (Show) 22 | 23 | data Expr 24 | = Var Ident 25 | | Lit Int 26 | | Add Expr Expr 27 | | Mul Expr Expr 28 | | Inv Expr 29 | | IfZero Expr Expr (Maybe Expr) 30 | | Apply [Expr] String Prim -- inconvenient ordering: arguments, useless annotation, identifier 31 | deriving (Show) 32 | 33 | data Prim 34 | = SquareRoot 35 | | Factorial 36 | | Fibonacci 37 | deriving (Eq, Enum, Bounded, Data, Show) 38 | 39 | return [] 40 | 41 | instance SexpIso Prim where 42 | sexpIso = coproduct 43 | [ $(grammarFor 'SquareRoot) . sym "square-root" 44 | , $(grammarFor 'Factorial) . sym "factorial" 45 | , $(grammarFor 'Fibonacci) . sym "fibonacci" 46 | ] 47 | 48 | instance SexpIso Ident where 49 | sexpIso = $(grammarFor 'Ident) . symbol 50 | 51 | instance SexpIso Expr where 52 | sexpIso = coproduct 53 | [ $(grammarFor 'Var) . sexpIso 54 | , $(grammarFor 'Lit) . int 55 | , $(grammarFor 'Add) . list (el (sym "+") >>> el sexpIso >>> el sexpIso) 56 | , $(grammarFor 'Mul) . list (el (sym "*") >>> el sexpIso >>> el sexpIso) 57 | , $(grammarFor 'Inv) . list (el (sym "invert") >>> el sexpIso) 58 | , $(grammarFor 'IfZero) . list (el (sym "cond") >>> props ( "pred" .: sexpIso 59 | >>> "true" .: sexpIso 60 | >>> "false" .:? sexpIso )) 61 | , $(grammarFor 'Apply) . -- Convert prim :- "dummy" :- args :- () to Apply node 62 | list 63 | (el (sexpIso :: SexpGrammar Prim) >>> -- Push prim: prim :- () 64 | el (kwd "args") >>> -- Recognize :args, push nothing 65 | rest (sexpIso :: SexpGrammar Expr) >>> -- Push args: args :- prim :- () 66 | onTail ( 67 | swap >>> -- Swap: prim :- args :- () 68 | push "dummy" -- Push "dummy": "dummy" :- prim :- args :- () 69 | (const True) 70 | (const (expected "dummy")) >>> 71 | swap) -- Swap: prim :- "dummy" :- args :- () 72 | ) 73 | ] 74 | 75 | test :: String -> SexpGrammar a -> (a, String) 76 | test str g = either error id $ do 77 | e <- decodeWith g "" (B8.pack str) 78 | sexp' <- toSexp g e 79 | return (e, B8.unpack (Sexp.format sexp')) 80 | 81 | -- λ> test "(cond :pred 1 :true (+ 42 10) :false (* 2 (* 2 2)))" (sexpIso :: SexpG Expr) 82 | -- (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))") 83 | -------------------------------------------------------------------------------- /sexp-grammar/src/Language/Sexp/Token.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Language.Sexp.Token 5 | ( Token (..) 6 | , Prefix (..) 7 | , escape 8 | , unescape 9 | ) where 10 | 11 | import Data.Scientific 12 | import Data.Text (Text) 13 | import qualified Data.Text.Lazy as TL 14 | import Prettyprinter 15 | 16 | import Language.Sexp.Types (Prefix(..)) 17 | 18 | data Token 19 | = TokLParen -- ( 20 | | TokRParen -- ) 21 | | TokLBracket -- [ 22 | | TokRBracket -- ] 23 | | TokLBrace -- { 24 | | TokRBrace -- } 25 | | TokCommentIntro -- #; 26 | | TokPrefix { getPrefix :: !Prefix } -- e.g. a quote in '(foo bar) 27 | | TokNumber { getNumber :: !Scientific } -- 42.0, -1.0, 3.14, -1e10 28 | | TokString { getString :: !Text } -- "foo", "", "hello world" 29 | | TokSymbol { getSymbol :: !Text } -- foo, bar 30 | | TokUnknown { getUnknown :: !Text } -- for unknown lexemes 31 | | TokEOF 32 | deriving (Show, Eq) 33 | 34 | instance Pretty Token where 35 | pretty TokLParen = "left paren '('" 36 | pretty TokRParen = "right paren ')'" 37 | pretty TokLBracket = "left bracket '['" 38 | pretty TokRBracket = "right bracket '['" 39 | pretty TokLBrace = "left brace '{'" 40 | pretty TokRBrace = "right brace '}'" 41 | pretty TokCommentIntro = "datum comment" 42 | pretty (TokPrefix c) = "modifier" <+> pretty (show c) 43 | pretty (TokSymbol s) = "symbol" <+> squotes (pretty s) <> squote 44 | pretty (TokNumber n) = "number" <+> pretty (show n) 45 | pretty (TokString s) = "string" <+> pretty (show s) 46 | pretty (TokUnknown u) = "unrecognized" <+> pretty u <> "..." 47 | pretty TokEOF = "end of file" 48 | 49 | 50 | newtype DText = DText (TL.Text -> TL.Text) 51 | 52 | instance Semigroup DText where 53 | DText a <> DText b = DText (a . b) 54 | 55 | instance Monoid DText where 56 | mempty = DText id 57 | mappend = (<>) 58 | 59 | delay :: TL.Text -> DText 60 | delay t = DText (t `TL.append`) 61 | 62 | force :: DText -> TL.Text 63 | force (DText f) = f TL.empty 64 | 65 | 66 | unescape :: TL.Text -> TL.Text 67 | unescape = force . go mempty 68 | where 69 | go :: DText -> TL.Text -> DText 70 | go acc text 71 | | TL.null text = acc 72 | | otherwise = 73 | let (chunk, rest) = TL.break (== '\\') text in 74 | case TL.uncons rest of 75 | Nothing -> acc <> delay chunk 76 | Just (_, rest') -> 77 | case TL.uncons rest' of 78 | Nothing -> error "Invalid escape sequence" 79 | Just ('n', rest'') -> go (acc <> delay (chunk `TL.snoc` '\n')) rest'' 80 | Just ('r', rest'') -> go (acc <> delay (chunk `TL.snoc` '\r')) rest'' 81 | Just ('t', rest'') -> go (acc <> delay (chunk `TL.snoc` '\t')) rest'' 82 | Just (lit, rest'') -> go (acc <> delay (chunk `TL.snoc` lit )) rest'' 83 | 84 | 85 | escape :: TL.Text -> TL.Text 86 | escape = force . go mempty 87 | where 88 | go :: DText -> TL.Text -> DText 89 | go acc text 90 | | TL.null text = acc 91 | | otherwise = 92 | let (chunk, rest) = TL.break (\c -> c == '"' || c == '\\') text 93 | in case TL.uncons rest of 94 | Nothing -> acc <> delay chunk 95 | Just ('"', rest') -> go (acc <> delay chunk <> delay "\\\"") rest' 96 | Just ('\\',rest') -> go (acc <> delay chunk <> delay "\\\\") rest' 97 | Just (other, rest') -> go (acc <> delay chunk <> delay (TL.singleton other)) rest' 98 | -------------------------------------------------------------------------------- /sexp-grammar/src/Language/Sexp/Parser.y: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} 6 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 7 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 8 | {-# OPTIONS_GHC -fno-warn-tabs #-} 9 | {-# OPTIONS_GHC -fno-warn-unused-binds #-} 10 | {-# OPTIONS_GHC -fno-warn-unused-matches #-} 11 | 12 | module Language.Sexp.Parser 13 | ( parseSexp_ 14 | , parseSexps_ 15 | ) where 16 | 17 | import qualified Data.ByteString.Lazy.Char8 as B8 18 | import qualified Data.List.NonEmpty as NE 19 | import Data.Maybe (catMaybes) 20 | import qualified Data.Scientific 21 | import Data.Text (Text) 22 | import qualified Data.Text as T 23 | import Data.Text.Prettyprint.Doc 24 | 25 | #if MIN_VERSION_prettyprinter(1,7,0) 26 | import qualified Data.Text.Prettyprint.Doc.Render.String as Render 27 | #else 28 | import qualified Data.Text.Prettyprint.Doc.Render.ShowS as Render 29 | #endif 30 | 31 | import Language.Sexp.Token 32 | import Language.Sexp.Lexer 33 | import Language.Sexp.Types 34 | } 35 | 36 | %name parseSexp_ Sexp_ 37 | %name parseSexps_ Sexps_ 38 | %error { parseError } 39 | %tokentype { LocatedBy Position Token } 40 | %monad { Either String } 41 | 42 | %token 43 | '(' { _ :< TokLParen } 44 | ')' { _ :< TokRParen } 45 | '[' { _ :< TokLBracket } 46 | ']' { _ :< TokRBracket } 47 | '{' { _ :< TokLBrace } 48 | '}' { _ :< TokRBrace } 49 | 50 | PREFIX { _ :< (TokPrefix _) } 51 | SYMBOL { _ :< (TokSymbol _) } 52 | NUMBER { _ :< (TokNumber _) } 53 | STRING { _ :< (TokString _) } 54 | 55 | COMMENT { _ :< TokCommentIntro } 56 | 57 | EOF { _ :< TokEOF } 58 | 59 | %% 60 | 61 | Sexps_ :: { [Sexp] } 62 | : Sexps EOF { $1 } 63 | 64 | Sexps :: { [Sexp] } 65 | : list(MSexp) { catMaybes $1 } 66 | 67 | Sexp_ :: { Sexp } 68 | : Sexp EOF { $1 } 69 | 70 | Sexp :: { Sexp } 71 | : Atom { AtomF @@ $1 } 72 | | '(' Sexps ')' { const (ParenListF $2) @@ $1 } 73 | | '[' Sexps ']' { const (BracketListF $2) @@ $1 } 74 | | '{' Sexps '}' { const (BraceListF $2) @@ $1 } 75 | | PREFIX Sexp { const (ModifiedF 76 | (getPrefix (extract $1)) 77 | $2) @@ $1 } 78 | 79 | MSexp :: { Maybe Sexp } 80 | : Sexp { Just $1 } 81 | | COMMENT Sexp { Nothing } 82 | 83 | Atom :: { LocatedBy Position Atom } 84 | : NUMBER { fmap (AtomNumber . getNumber) $1 } 85 | | STRING { fmap (AtomString . getString) $1 } 86 | | SYMBOL { fmap (AtomSymbol . getSymbol) $1 } 87 | 88 | -- Utils 89 | 90 | rev_list1(p) 91 | : p { [$1] } 92 | | rev_list1(p) p { $2 : $1 } 93 | 94 | list1(p) 95 | : rev_list1(p) { reverse $1 } 96 | 97 | list(p) 98 | : {- empty -} { [] } 99 | | list1(p) { $1 } 100 | 101 | { 102 | 103 | type Sexp = Fix (Compose (LocatedBy Position) SexpF) 104 | 105 | (@@) :: (a -> e (Fix (Compose (LocatedBy p) e))) -> LocatedBy p a -> Fix (Compose (LocatedBy p) e) 106 | (@@) f (p :< a) = Fix . Compose . (p :<) . f $ a 107 | 108 | parseError :: [LocatedBy Position Token] -> Either String b 109 | parseError toks = case toks of 110 | [] -> 111 | Left "EOF: Unexpected end of file" 112 | (pos :< tok : _) -> 113 | Left $ flip Render.renderShowS [] . layoutPretty (LayoutOptions (AvailablePerLine 80 0.8)) $ 114 | pretty pos <> colon <+> "Unexpected token:" <+> pretty tok 115 | } 116 | -------------------------------------------------------------------------------- /sexp-grammar/src/Language/Sexp/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DeriveTraversable #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | 8 | module Language.Sexp.Types 9 | ( Atom (..) 10 | , Prefix (..) 11 | , Fix (..) 12 | , SexpF (..) 13 | , Compose (..) 14 | , Position (..) 15 | , dummyPos 16 | , LocatedBy (..) 17 | , location 18 | , extract 19 | , stripLocation 20 | , addLocation 21 | ) where 22 | 23 | import Control.DeepSeq 24 | 25 | import Data.Bifunctor 26 | 27 | import Data.Fix (Fix (..)) 28 | import Data.Functor.Classes 29 | import Data.Functor.Compose 30 | import Data.Functor.Foldable (cata) 31 | import Data.Scientific (Scientific) 32 | import Data.Text (Text) 33 | import GHC.Generics 34 | import Prettyprinter (Pretty (..), colon) 35 | 36 | ---------------------------------------------------------------------- 37 | -- Positions 38 | 39 | -- | Position: file name, line number, column number 40 | data Position = 41 | Position FilePath {-# UNPACK #-} !Int {-# UNPACK #-} !Int 42 | deriving (Ord, Eq, Generic) 43 | 44 | dummyPos :: Position 45 | dummyPos = Position "" 1 0 46 | 47 | instance Pretty Position where 48 | pretty (Position fn line col) = 49 | pretty fn <> colon <> pretty line <> colon <> pretty col 50 | 51 | instance Show Position where 52 | show (Position fn line col) = 53 | fn ++ ":" ++ show line ++ ":" ++ show col 54 | 55 | ---------------------------------------------------------------------- 56 | -- Annotations 57 | 58 | -- | Annotation functor for positions 59 | data LocatedBy a e = !a :< e 60 | deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) 61 | 62 | instance Bifunctor LocatedBy where 63 | bimap f g (a :< e) = f a :< g e 64 | 65 | instance (Eq p) => Eq1 (LocatedBy p) where 66 | liftEq eq (p :< a) (q :< b) = p == q && a `eq` b 67 | 68 | instance (NFData p, NFData e) => NFData (LocatedBy p e) 69 | 70 | instance NFData p => NFData1 (LocatedBy p) where 71 | liftRnf f (p :< a) = rnf p `seq` f a 72 | 73 | location :: LocatedBy a e -> a 74 | location (a :< _) = a 75 | 76 | extract :: LocatedBy a e -> e 77 | extract (_ :< e) = e 78 | 79 | stripLocation :: (Functor f) => Fix (Compose (LocatedBy p) f) -> Fix f 80 | stripLocation = cata (Fix . extract . getCompose) 81 | 82 | addLocation :: (Functor f) => p -> Fix f -> Fix (Compose (LocatedBy p) f) 83 | addLocation p = cata (Fix . Compose . (p :<)) 84 | 85 | ---------------------------------------------------------------------- 86 | -- Sexp 87 | 88 | -- | S-expression atom type 89 | data Atom 90 | = AtomNumber {-# UNPACK #-} !Scientific 91 | | AtomString {-# UNPACK #-} !Text 92 | | AtomSymbol {-# UNPACK #-} !Text 93 | deriving (Show, Eq, Ord, Generic) 94 | 95 | -- | S-expression quotation type 96 | data Prefix 97 | = Quote 98 | | Backtick 99 | | Comma 100 | | CommaAt 101 | | Hash 102 | deriving (Show, Eq, Ord, Generic) 103 | 104 | instance NFData Prefix 105 | 106 | -- | S-expression functor 107 | data SexpF e 108 | = AtomF !Atom 109 | | ParenListF [e] 110 | | BracketListF [e] 111 | | BraceListF [e] 112 | | ModifiedF !Prefix e 113 | deriving (Functor, Foldable, Traversable, Generic) 114 | 115 | instance Eq a => Eq (SexpF a) where 116 | (==) = liftEq (==) 117 | 118 | instance Eq1 SexpF where 119 | liftEq eq = go 120 | where 121 | go (AtomF a) (AtomF b) = a == b 122 | go (ParenListF as) (ParenListF bs) = liftEq eq as bs 123 | go (BracketListF as) (BracketListF bs) = liftEq eq as bs 124 | go (BraceListF as) (BraceListF bs) = liftEq eq as bs 125 | go (ModifiedF q a) (ModifiedF p b) = q == p && a `eq` b 126 | go _ _ = False 127 | 128 | instance NFData Atom 129 | 130 | instance NFData Position 131 | 132 | instance NFData e => NFData (SexpF e) 133 | 134 | instance NFData1 SexpF where 135 | liftRnf f = \case 136 | AtomF a -> rnf a 137 | ParenListF as -> liftRnf f as 138 | BracketListF as -> liftRnf f as 139 | BraceListF as -> liftRnf f as 140 | ModifiedF q a -> rnf q `seq` f a 141 | -------------------------------------------------------------------------------- /sexp-grammar/src/Language/SexpGrammar/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE Safe #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | module Language.SexpGrammar.Class 7 | ( SexpGrammar 8 | , SexpIso(..) 9 | ) where 10 | 11 | import Prelude hiding ((.), id) 12 | 13 | import Control.Arrow 14 | import Control.Category 15 | 16 | import Data.InvertibleGrammar 17 | import qualified Data.List.NonEmpty as NE 18 | import Data.Map (Map) 19 | import Data.Scientific 20 | import Data.Set (Set) 21 | import Data.Text (Text) 22 | import qualified Data.Map as Map 23 | import qualified Data.Set as Set 24 | 25 | import Language.Sexp.Located 26 | import Language.SexpGrammar.Base 27 | import Language.SexpGrammar.Generic 28 | 29 | -- | A common type of grammar that operates on S-expressions. This grammar 30 | -- accepts a single 'Sexp' value and converts it into a value of type 31 | -- @a@. 32 | type SexpGrammar a = forall t. Grammar Position (Sexp :- t) (a :- t) 33 | 34 | -- | A class for types that could be converted to and inferred from 35 | -- s-expressions defined by 'Sexp'. 36 | class SexpIso a where 37 | sexpIso :: SexpGrammar a 38 | 39 | instance SexpIso () where 40 | sexpIso = with $ \unit -> 41 | sym "nil" >>> unit 42 | 43 | instance SexpIso Bool where 44 | sexpIso = match 45 | $ With (\false_ -> sym "false" >>> false_) 46 | $ With (\true_ -> sym "true" >>> true_) 47 | $ End 48 | 49 | instance SexpIso Int where 50 | sexpIso = int 51 | 52 | instance SexpIso Integer where 53 | sexpIso = integer 54 | 55 | instance SexpIso Double where 56 | sexpIso = double 57 | 58 | instance SexpIso Scientific where 59 | sexpIso = real 60 | 61 | instance SexpIso Text where 62 | sexpIso = string 63 | 64 | instance (SexpIso a, SexpIso b) => SexpIso (a, b) where 65 | sexpIso = 66 | list ( 67 | el sexpIso >>> 68 | el sexpIso) >>> pair 69 | 70 | instance (SexpIso a, SexpIso b, SexpIso c) => SexpIso (a, b, c) where 71 | sexpIso = with $ \tuple3 -> 72 | list ( 73 | el sexpIso >>> 74 | el sexpIso >>> 75 | el sexpIso) >>> tuple3 76 | 77 | instance (SexpIso a, SexpIso b, SexpIso c, SexpIso d) => SexpIso (a, b, c, d) where 78 | sexpIso = with $ \tuple4 -> 79 | list ( 80 | el sexpIso >>> 81 | el sexpIso >>> 82 | el sexpIso >>> 83 | el sexpIso) >>> tuple4 84 | 85 | instance (SexpIso a, SexpIso b, SexpIso c, SexpIso d, SexpIso e) => SexpIso (a, b, c, d, e) where 86 | sexpIso = with $ \tuple5 -> 87 | list ( 88 | el sexpIso >>> 89 | el sexpIso >>> 90 | el sexpIso >>> 91 | el sexpIso >>> 92 | el sexpIso) >>> tuple5 93 | 94 | instance (SexpIso a, SexpIso b, SexpIso c, SexpIso d, SexpIso e, SexpIso f) => SexpIso (a, b, c, d, e, f) where 95 | sexpIso = with $ \tuple6 -> 96 | list ( 97 | el sexpIso >>> 98 | el sexpIso >>> 99 | el sexpIso >>> 100 | el sexpIso >>> 101 | el sexpIso >>> 102 | el sexpIso) >>> tuple6 103 | 104 | instance (SexpIso a, SexpIso b, SexpIso c, SexpIso d, SexpIso e, SexpIso f, SexpIso g) => 105 | SexpIso (a, b, c, d, e, f, g) where 106 | sexpIso = with $ \tuple7 -> 107 | list ( 108 | el sexpIso >>> 109 | el sexpIso >>> 110 | el sexpIso >>> 111 | el sexpIso >>> 112 | el sexpIso >>> 113 | el sexpIso >>> 114 | el sexpIso) >>> tuple7 115 | 116 | instance (Ord k, SexpIso k, SexpIso v) => SexpIso (Map k v) where 117 | sexpIso = iso Map.fromList Map.toList . braceList (rest sexpIso) 118 | 119 | instance (Ord a, SexpIso a) => SexpIso (Set a) where 120 | sexpIso = iso Set.fromList Set.toList . braceList (rest sexpIso) 121 | 122 | instance (SexpIso a) => SexpIso (Maybe a) where 123 | sexpIso = match 124 | $ With (\nothing -> sym "nil" >>> nothing) 125 | $ With (\just -> list (el (sym "just") >>> el sexpIso) >>> just) 126 | $ End 127 | 128 | instance (SexpIso a, SexpIso b) => SexpIso (Either a b) where 129 | sexpIso = match 130 | $ With (\left -> list (el (sym "left") >>> el sexpIso) >>> left) 131 | $ With (\right -> list (el (sym "right") >>> el sexpIso) >>> right) 132 | $ End 133 | 134 | instance (SexpIso a) => SexpIso [a] where 135 | sexpIso = list $ rest sexpIso 136 | 137 | instance (SexpIso a) => SexpIso (NE.NonEmpty a) where 138 | sexpIso = 139 | list (el sexpIso >>> rest sexpIso) >>> 140 | pair >>> 141 | iso (\(x,xs) -> x NE.:| xs ) 142 | (\(x NE.:| xs) -> (x, xs)) 143 | -------------------------------------------------------------------------------- /sexp-grammar/src/Language/SexpGrammar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE Safe #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | {- | 6 | 7 | Write your grammar once and get both parser and pretty-printer, for 8 | free. 9 | 10 | > import GHC.Generics 11 | > import Data.Text (Text) 12 | > import Language.SexpGrammar 13 | > import Language.SexpGrammar.Generic 14 | > 15 | > data Person = Person 16 | > { pName :: Text 17 | > , pAddress :: Text 18 | > , pAge :: Maybe Int 19 | > } deriving (Show, Generic) 20 | > 21 | > instance SexpIso Person where 22 | > sexpIso = with $ \person -> -- Person is isomorphic to: 23 | > list ( -- a list with 24 | > el (sym "person") >>> -- a symbol "person", 25 | > el string >>> -- a string, and 26 | > props ( -- a property-list with 27 | > "address" .: string >>> -- a keyword :address and a string value, and 28 | > "age" .:? int)) >>> -- an optional keyword :age with int value. 29 | > person 30 | 31 | So now we can use this isomorphism to parse S-expessions to @Person@ 32 | record and pretty-print @Person@ records back to S-expression. 33 | 34 | > (person "John Doe" :address "42 Whatever str." :age 25) 35 | 36 | will parse into: 37 | 38 | > Person {pName = "John Doe", pAddress = "42 Whatever str.", pAge = Just 25} 39 | 40 | and the record will pretty-print back into: 41 | 42 | > (person "John Doe" :address "42 Whatever str." :age 25) 43 | 44 | -} 45 | 46 | module Language.SexpGrammar 47 | ( -- * Data types 48 | Sexp 49 | , Position 50 | , SexpGrammar 51 | , Grammar 52 | , (:-) 53 | , SexpIso (..) 54 | -- * Encoding 55 | , toSexp 56 | , encode 57 | , encodeWith 58 | , encodePretty 59 | , encodePrettyWith 60 | -- * Decoding 61 | , fromSexp 62 | , decode 63 | , decodeWith 64 | -- * Combinators 65 | , module Control.Category 66 | , module Data.InvertibleGrammar.Combinators 67 | , module Language.SexpGrammar.Base 68 | -- * Error reporting 69 | , Mismatch 70 | , expected 71 | , unexpected 72 | ) where 73 | 74 | import Control.Category ((<<<), (>>>)) 75 | 76 | import Data.ByteString.Lazy.Char8 (ByteString) 77 | import Data.InvertibleGrammar 78 | import Data.InvertibleGrammar.Combinators 79 | 80 | import Language.Sexp.Located (Sexp, Position) 81 | import qualified Language.Sexp.Located as Sexp 82 | 83 | import Language.SexpGrammar.Base 84 | import Language.SexpGrammar.Class 85 | 86 | ---------------------------------------------------------------------- 87 | -- Sexp interface 88 | 89 | -- | Run grammar in parsing (left-to-right) direction 90 | -- 91 | -- > fromSexp g = runGrammarString Sexp.dummyPos . forward (sealed g) 92 | fromSexp :: SexpGrammar a -> Sexp -> Either String a 93 | fromSexp g = 94 | runGrammarString Sexp.dummyPos . 95 | forward (sealed g) 96 | 97 | -- | Run grammar in generating (right-to-left) direction 98 | -- 99 | -- > toSexp g = runGrammarString Sexp.dummyPos . backward (sealed g) 100 | toSexp :: SexpGrammar a -> a -> Either String Sexp 101 | toSexp g = 102 | runGrammarString Sexp.dummyPos . 103 | backward (sealed g) 104 | 105 | ---------------------------------------------------------------------- 106 | 107 | -- | Serialize a value using 'SexpIso' instance 108 | encode :: SexpIso a => a -> Either String ByteString 109 | encode = 110 | encodeWith sexpIso 111 | 112 | -- | Serialise a value using a provided grammar 113 | encodeWith :: SexpGrammar a -> a -> Either String ByteString 114 | encodeWith g = 115 | fmap Sexp.encode . toSexp g 116 | 117 | -- | Serialise and pretty-print a value using its 'SexpIso' instance 118 | encodePretty :: SexpIso a => a -> Either String ByteString 119 | encodePretty = 120 | encodePrettyWith sexpIso 121 | 122 | -- | Serialise and pretty-print a value using a provided grammar 123 | encodePrettyWith :: SexpGrammar a -> a -> Either String ByteString 124 | encodePrettyWith g = 125 | fmap Sexp.format . toSexp g 126 | 127 | ---------------------------------------------------------------------- 128 | 129 | -- | Deserialise a value using its 'SexpIso' instance 130 | decode :: SexpIso a => ByteString -> Either String a 131 | decode = 132 | decodeWith sexpIso "" 133 | 134 | -- | Deserialise a value using provided grammar, use a provided file 135 | -- name for error messages 136 | decodeWith :: SexpGrammar a -> FilePath -> ByteString -> Either String a 137 | decodeWith g fn input = 138 | Sexp.parseSexp fn input >>= fromSexp g 139 | -------------------------------------------------------------------------------- /sexp-grammar/src/Language/Sexp/Located.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | {-# LANGUAGE Trustworthy #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | 6 | {-# OPTIONS_GHC -fno-warn-orphans #-} 7 | 8 | module Language.Sexp.Located 9 | ( 10 | -- * Parse and print 11 | decode 12 | , parseSexp 13 | , parseSexps 14 | , parseSexpWithPos 15 | , parseSexpsWithPos 16 | , encode 17 | , format 18 | -- * Type 19 | , Sexp 20 | , pattern Atom 21 | , pattern Number 22 | , pattern Symbol 23 | , pattern String 24 | , pattern ParenList 25 | , pattern BracketList 26 | , pattern BraceList 27 | , pattern Modified 28 | -- ** Internal types 29 | , SexpF (..) 30 | , Atom (..) 31 | , Prefix (..) 32 | , LocatedBy (..) 33 | , Position (..) 34 | , Compose (..) 35 | , Fix (..) 36 | , dummyPos 37 | -- * Conversion 38 | , fromSimple 39 | , toSimple 40 | ) where 41 | 42 | import Data.ByteString.Lazy.Char8 (ByteString, unpack) 43 | import Data.Functor.Compose 44 | import Data.Scientific (Scientific) 45 | import Data.Text (Text) 46 | 47 | import Language.Sexp.Types 48 | import Language.Sexp.Lexer (lexSexp) 49 | import Language.Sexp.Parser (parseSexp_, parseSexps_) 50 | import qualified Language.Sexp.Pretty as Internal 51 | import qualified Language.Sexp.Encode as Internal 52 | 53 | -- | S-expression type annotated with positions. Useful for further 54 | -- parsing. 55 | type Sexp = Fix (Compose (LocatedBy Position) SexpF) 56 | 57 | instance {-# OVERLAPPING #-} Show Sexp where 58 | show = unpack . encode 59 | 60 | -- | Deserialise a 'Sexp' from a string 61 | decode :: ByteString -> Either String Sexp 62 | decode = parseSexp "" 63 | 64 | -- | Serialise a 'Sexp' into a compact string 65 | encode :: Sexp -> ByteString 66 | encode = Internal.encode . stripLocation 67 | 68 | -- | Serialise a 'Sexp' into a pretty-printed string 69 | format :: Sexp -> ByteString 70 | format = Internal.format . stripLocation 71 | 72 | ---------------------------------------------------------------------- 73 | 74 | fromSimple :: Fix SexpF -> Fix (Compose (LocatedBy Position) SexpF) 75 | fromSimple = addLocation dummyPos 76 | 77 | toSimple :: Fix (Compose (LocatedBy Position) SexpF) -> Fix SexpF 78 | toSimple = stripLocation 79 | 80 | ---------------------------------------------------------------------- 81 | 82 | pattern Atom :: Atom -> Sexp 83 | pattern Atom a <- Fix (Compose (_ :< AtomF a)) 84 | where Atom a = Fix (Compose (dummyPos :< AtomF a)) 85 | 86 | pattern Number :: Scientific -> Sexp 87 | pattern Number a <- Fix (Compose (_ :< AtomF (AtomNumber a))) 88 | where Number a = Fix (Compose (dummyPos :< AtomF (AtomNumber a))) 89 | 90 | pattern Symbol :: Text -> Sexp 91 | pattern Symbol a <- Fix (Compose (_ :< AtomF (AtomSymbol a))) 92 | where Symbol a = Fix (Compose (dummyPos :< AtomF (AtomSymbol a))) 93 | 94 | pattern String :: Text -> Sexp 95 | pattern String a <- Fix (Compose (_ :< AtomF (AtomString a))) 96 | where String a = Fix (Compose (dummyPos :< AtomF (AtomString a))) 97 | 98 | pattern ParenList :: [Sexp] -> Sexp 99 | pattern ParenList ls <- Fix (Compose (_ :< ParenListF ls)) 100 | where ParenList ls = Fix (Compose (dummyPos :< ParenListF ls)) 101 | 102 | pattern BracketList :: [Sexp] -> Sexp 103 | pattern BracketList ls <- Fix (Compose (_ :< BracketListF ls)) 104 | where BracketList ls = Fix (Compose (dummyPos :< BracketListF ls)) 105 | 106 | pattern BraceList :: [Sexp] -> Sexp 107 | pattern BraceList ls <- Fix (Compose (_ :< BraceListF ls)) 108 | where BraceList ls = Fix (Compose (dummyPos :< BraceListF ls)) 109 | 110 | pattern Modified :: Prefix -> Sexp -> Sexp 111 | pattern Modified q s <- Fix (Compose (_ :< ModifiedF q s)) 112 | where Modified q s = Fix (Compose (dummyPos :< ModifiedF q s)) 113 | 114 | -- | Parse a 'Sexp' from a string. 115 | parseSexp :: FilePath -> ByteString -> Either String Sexp 116 | parseSexp fn inp = parseSexp_ (lexSexp (Position fn 1 0) inp) 117 | 118 | -- | Parse multiple 'Sexp' from a string. 119 | parseSexps :: FilePath -> ByteString -> Either String [Sexp] 120 | parseSexps fn inp = parseSexps_ (lexSexp (Position fn 1 0) inp) 121 | 122 | -- | Parse a 'Sexp' from a string, starting from a given 123 | -- position. Useful for embedding into other parsers. 124 | parseSexpWithPos :: Position -> ByteString -> Either String Sexp 125 | parseSexpWithPos pos inp = parseSexp_ (lexSexp pos inp) 126 | 127 | -- | Parse multiple 'Sexp' from a string, starting from a given 128 | -- position. Useful for embedding into other parsers. 129 | parseSexpsWithPos :: Position -> ByteString -> Either String [Sexp] 130 | parseSexpsWithPos pos inp = parseSexps_ (lexSexp pos inp) 131 | -------------------------------------------------------------------------------- /invertible-grammar/src/Data/InvertibleGrammar/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Data.InvertibleGrammar.TH where 5 | 6 | import Data.Foldable (toList) 7 | import Data.InvertibleGrammar.Base 8 | import Data.Maybe 9 | import Data.Text (pack) 10 | import Language.Haskell.TH as TH 11 | import Data.Set (Set) 12 | import qualified Data.Set as S 13 | 14 | 15 | {- | Build a prism and the corresponding grammar that will match on the 16 | given constructor and convert it to reverse sequence of :- stacks. 17 | 18 | E.g. consider a data type: 19 | 20 | > data FooBar a b c = Foo a b c | Bar 21 | 22 | For constructor Foo 23 | 24 | > fooGrammar = $(grammarFor 'Foo) 25 | 26 | will expand into 27 | 28 | > fooGrammar = PartialIso 29 | > (\(c :- b :- a :- t) -> Foo a b c :- t) 30 | > (\case { Foo a b c :- t -> Just $ c :- b :- a :- t; _ -> Nothing }) 31 | 32 | Note the order of elements on the stack: 33 | 34 | > ghci> :t fooGrammar 35 | > fooGrammar :: Grammar p (c :- (b :- (a :- t))) (FooBar a b c :- t) 36 | -} 37 | 38 | grammarFor :: Name -> ExpQ 39 | grammarFor constructorName = do 40 | DataConI realConstructorName _typ parentName <- reify constructorName 41 | TyConI dataDef <- reify parentName 42 | 43 | (single, constructorInfo) <- maybe (fail "Could not find the constructor") pure $ do 44 | (single, allConstr) <- constructors dataDef 45 | constr <- findConstructor realConstructorName allConstr 46 | return (single, constr) 47 | 48 | let ts = fieldTypes constructorInfo 49 | vs <- mapM (const $ newName "x") ts 50 | t <- newName "t" 51 | 52 | let matchStack [] = varP t 53 | matchStack (_v:vs) = [p| $(varP _v) :- $_vs' |] 54 | where 55 | _vs' = matchStack vs 56 | fPat = matchStack vs 57 | buildConstructor = foldr (\v acc -> appE acc (varE v)) (conE realConstructorName) vs 58 | fBody = [e| $buildConstructor :- $(varE t) |] 59 | fFunc = lamE [fPat] fBody 60 | 61 | let gPat = [p| $_matchConsructor :- $(varP t) |] 62 | where 63 | _matchConsructor = conP realConstructorName (map varP (reverse vs)) 64 | gBody = foldr (\v acc -> [e| $(varE v) :- $acc |]) (varE t) vs 65 | gFunc = lamCaseE $ catMaybes 66 | [ Just $ TH.match gPat (normalB [e| Right ($gBody) |]) [] 67 | , if single 68 | then Nothing 69 | else Just $ TH.match wildP (normalB [e| Left (expected $ "constructor " <> pack ( $(stringE (show constructorName))) ) |]) [] 70 | ] 71 | 72 | [e| PartialIso $fFunc $gFunc |] 73 | 74 | 75 | {- | Build prisms and corresponding grammars for all data constructors of given 76 | type. Expects grammars to zip built ones with. 77 | 78 | > $(match ''Maybe) 79 | 80 | Will expand into a lambda: 81 | 82 | > (\nothingG justG -> ($(grammarFor 'Nothing) . nothingG) <> 83 | > ($(grammarFor 'Just) . justG)) 84 | -} 85 | match :: Name -> ExpQ 86 | match tyName = do 87 | names <- concatMap (toList . constructorNames) <$> (extractConstructors =<< reify tyName) 88 | argTys <- mapM (\_ -> newName "a") names 89 | let grammars = map (\(con, arg) -> [e| $(varE arg) $(grammarFor con) |]) (zip names argTys) 90 | lamE (map varP argTys) (foldr1 (\e1 e2 -> [e| $e1 <> $e2 |]) grammars) 91 | where 92 | extractConstructors :: Info -> Q [Con] 93 | extractConstructors (TyConI dataDef) = 94 | case constructors dataDef of 95 | Just (_, cs) -> pure cs 96 | Nothing -> fail $ "Data type " ++ show tyName ++ " defines no constructors" 97 | extractConstructors _ = 98 | fail $ "Data definition expected for name " ++ show tyName 99 | 100 | ---------------------------------------------------------------------- 101 | -- Utils 102 | 103 | constructors :: Dec -> Maybe (Bool, [Con]) 104 | constructors (DataD _ _ _ _ cs _) = Just (length cs == 1, cs) 105 | constructors (NewtypeD _ _ _ _ c _) = Just (True, [c]) 106 | constructors _ = Nothing 107 | 108 | findConstructor :: Name -> [Con] -> Maybe Con 109 | findConstructor _ [] = Nothing 110 | findConstructor name (c:cs) 111 | | name `S.member` constructorNames c = Just c 112 | | otherwise = findConstructor name cs 113 | 114 | constructorNames :: Con -> Set Name 115 | constructorNames = \case 116 | NormalC name _ -> S.singleton name 117 | RecC name _ -> S.singleton name 118 | InfixC _ name _ -> S.singleton name 119 | ForallC _ _ con' -> constructorNames con' 120 | GadtC cs _ _ -> S.fromList cs 121 | RecGadtC cs _ _ -> S.fromList cs 122 | 123 | fieldTypes :: Con -> [Type] 124 | fieldTypes = \case 125 | NormalC _ fieldTypes -> map extractType fieldTypes 126 | RecC _ fieldTypes -> map extractType' fieldTypes 127 | InfixC (_,a) _b (_,b) -> [a, b] 128 | ForallC _ _ con' -> fieldTypes con' 129 | GadtC _ fs _ -> map extractType fs 130 | RecGadtC _ fs _ -> map extractType' fs 131 | where 132 | extractType (_, t) = t 133 | extractType' (_, _, t) = t 134 | -------------------------------------------------------------------------------- /sexp-grammar/src/Language/Sexp/Lexer.x: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 5 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 6 | {-# OPTIONS_GHC -fno-warn-tabs #-} 7 | {-# OPTIONS_GHC -fno-warn-unused-binds #-} 8 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 9 | {-# OPTIONS_GHC -fno-warn-unused-matches #-} 10 | 11 | module Language.Sexp.Lexer 12 | ( lexSexp 13 | ) where 14 | 15 | import Data.Bifunctor 16 | import qualified Data.ByteString.Lazy as BLW 17 | import Data.ByteString.Lazy.Char8 (ByteString) 18 | import qualified Data.ByteString.Lazy.Char8 as BL 19 | import qualified Data.ByteString.Lazy.UTF8 as UTF8 20 | import Data.Int 21 | import Data.Scientific (Scientific) 22 | import qualified Data.Text as T 23 | import qualified Data.Text.Lazy as TL 24 | import Data.Text.Lazy.Encoding (decodeUtf8) 25 | import Data.Text.Read 26 | import Data.Word 27 | 28 | import Language.Sexp.Token 29 | import Language.Sexp.Types (Position (..), LocatedBy (..)) 30 | 31 | } 32 | 33 | $hspace = [\ \t] 34 | $whitespace = [$hspace\n\r\f\v] 35 | 36 | $allgraphic = . # [\x00-\x20 \x7F-\xA0] 37 | 38 | $digit = 0-9 39 | $hex = [0-9 A-F a-f] 40 | $alpha = [a-z A-Z] 41 | 42 | @number = [\-\+]? $digit+ ([\.]$digit+)? 43 | 44 | @escape = \\ [nrt\\\"] 45 | @string = $allgraphic # [\"\\] | $whitespace | @escape 46 | 47 | $unicode = $allgraphic # [\x20-\x80] 48 | 49 | $syminitial = [$alpha $digit \\\:\@\!\$\%\&\*\/\<\=\>\?\~\_\^\.\|\+\- $unicode] 50 | $symsubseq = [$syminitial \#\'\`\,] 51 | @symbol = $syminitial ($symsubseq)* 52 | 53 | :- 54 | 55 | $whitespace+ ; 56 | ";" .* ; 57 | "#;" / $allgraphic { const TokCommentIntro } 58 | 59 | "(" { const TokLParen } 60 | ")" { const TokRParen } 61 | "[" { const TokLBracket } 62 | "]" { const TokRBracket } 63 | "{" { const TokLBrace } 64 | "}" { const TokRBrace } 65 | 66 | "'" / $allgraphic { const (TokPrefix Quote) } 67 | "`" / $allgraphic { const (TokPrefix Backtick) } 68 | ",@" / $allgraphic { const (TokPrefix CommaAt) } 69 | "," / $allgraphic { const (TokPrefix Comma) } 70 | "#" / $allgraphic { const (TokPrefix Hash) } 71 | 72 | @number { TokNumber . readNum } 73 | @symbol { TokSymbol . decode } 74 | \" @string* \" { TokString . readString } 75 | 76 | { 77 | 78 | ---------------------------------------------------------------------- 79 | -- Decoders 80 | 81 | readString :: ByteString -> T.Text 82 | readString = TL.toStrict . unescape . TL.tail . TL.init . decodeUtf8 83 | 84 | readNum :: ByteString -> Scientific 85 | readNum = read . TL.unpack . decodeUtf8 86 | 87 | decode :: ByteString -> T.Text 88 | decode = TL.toStrict . decodeUtf8 89 | 90 | ---------------------------------------------------------------------- 91 | -- Entry point 92 | 93 | lexSexp :: Position -> ByteString -> [LocatedBy Position Token] 94 | lexSexp (Position fn line1 col1) = 95 | map (bimap fixPos id) . alexScanTokens . mkAlexInput (LineCol line1 col1) 96 | where 97 | fixPos (LineCol l c) = Position fn l c 98 | 99 | ---------------------------------------------------------------------- 100 | -- Machinery 101 | 102 | type AlexAction = ByteString -> Token 103 | 104 | alexScanTokens :: AlexInput -> [LocatedBy LineCol Token] 105 | alexScanTokens input = 106 | case alexScan input defaultCode of 107 | AlexEOF -> 108 | [aiLineCol input :< TokEOF] 109 | AlexError (AlexInput {aiInput, aiLineCol}) -> 110 | let rest = T.takeWhile (/= '\n') $ decode $ UTF8.take 100 aiInput 111 | in [aiLineCol :< (TokUnknown rest)] 112 | AlexSkip input _ -> 113 | alexScanTokens input 114 | AlexToken input' tokLen action -> 115 | let inputText = UTF8.take (fromIntegral tokLen) (aiInput input) 116 | in (aiLineCol input :< action inputText) : alexScanTokens input' 117 | where 118 | defaultCode :: Int 119 | defaultCode = 0 120 | 121 | data LineCol = LineCol {-# UNPACK #-} !Int {-# UNPACK #-} !Int 122 | 123 | columnsInTab :: Int 124 | columnsInTab = 8 125 | 126 | advanceLineCol :: Char -> LineCol -> LineCol 127 | advanceLineCol '\n' (LineCol line _) = LineCol (line + 1) 1 128 | advanceLineCol '\t' (LineCol line col) = LineCol line (((col + columnsInTab - 1) `div` columnsInTab) * columnsInTab + 1) 129 | advanceLineCol _ (LineCol line col) = LineCol line (col + 1) 130 | 131 | data AlexInput = AlexInput 132 | { aiInput :: ByteString 133 | , aiPrevChar :: {-# UNPACK #-} !Char 134 | , aiBytesLeft :: {-# UNPACK #-} !Int64 135 | , aiLineCol :: !LineCol 136 | } 137 | 138 | mkAlexInput :: LineCol -> ByteString -> AlexInput 139 | mkAlexInput initPos source = AlexInput 140 | { aiInput = source 141 | , aiPrevChar = '\n' 142 | , aiBytesLeft = 0 143 | , aiLineCol = initPos 144 | } 145 | 146 | alexNextChar :: AlexInput -> Maybe AlexInput 147 | alexNextChar input 148 | | aiBytesLeft input > 1 = Just $ input { aiBytesLeft = aiBytesLeft input - 1 } 149 | | otherwise = case UTF8.decode (aiInput input) of 150 | Just (c, n) -> Just $ input 151 | { aiPrevChar = c 152 | , aiLineCol = advanceLineCol c (aiLineCol input) 153 | , aiBytesLeft = n 154 | } 155 | Nothing -> Nothing 156 | 157 | -- Alex interface - functions used by Alex 158 | alexInputPrevChar :: AlexInput -> Char 159 | alexInputPrevChar = aiPrevChar 160 | 161 | alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) 162 | alexGetByte input = 163 | alexNextChar input >>= getByte 164 | where 165 | getByte :: AlexInput -> Maybe (Word8, AlexInput) 166 | getByte input = 167 | case BLW.uncons (aiInput input) of 168 | Just (w, rest) -> Just (w, input { aiInput = rest }) 169 | Nothing -> Nothing 170 | } 171 | -------------------------------------------------------------------------------- /invertible-grammar/src/Data/InvertibleGrammar/Combinators.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE Trustworthy #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | module Data.InvertibleGrammar.Combinators 7 | ( iso 8 | , osi 9 | , partialIso 10 | , partialOsi 11 | , push 12 | , pair 13 | , swap 14 | , cons 15 | , nil 16 | , insert 17 | , insertMay 18 | , toDefault 19 | , coproduct 20 | , onHead 21 | , onTail 22 | , traversed 23 | , flipped 24 | , sealed 25 | , coerced 26 | , annotated 27 | ) where 28 | 29 | import Control.Category ((>>>)) 30 | import Data.Coerce 31 | import Data.Maybe 32 | import Data.Void 33 | import Data.Text (Text) 34 | import Data.InvertibleGrammar.Base 35 | 36 | -- | Isomorphism on the stack head. 37 | iso :: (a -> b) -> (b -> a) -> Grammar p (a :- t) (b :- t) 38 | iso f' g' = Iso f g 39 | where 40 | f (a :- t) = f' a :- t 41 | g (b :- t) = g' b :- t 42 | 43 | 44 | -- | Flipped isomorphism on the stack head. 45 | osi :: (b -> a) -> (a -> b) -> Grammar p (a :- t) (b :- t) 46 | osi f' g' = Iso g f 47 | where 48 | f (a :- t) = f' a :- t 49 | g (b :- t) = g' b :- t 50 | 51 | -- | Partial isomorphism (for backward run) on the stack head. 52 | partialIso :: (a -> b) -> (b -> Either Mismatch a) -> Grammar p (a :- t) (b :- t) 53 | partialIso f' g' = PartialIso f g 54 | where 55 | f (a :- t) = f' a :- t 56 | g (b :- t) = (:- t) <$> g' b 57 | 58 | 59 | -- | Partial isomorphism (for forward run) on the stack head. 60 | partialOsi :: (a -> Either Mismatch b) -> (b -> a) -> Grammar p (a :- t) (b :- t) 61 | partialOsi g' f' = Flip $ PartialIso f g 62 | where 63 | f (a :- t) = f' a :- t 64 | g (b :- t) = (:- t) <$> g' b 65 | 66 | 67 | -- | Push an element to the stack on forward run, check if the element 68 | -- satisfies predicate, otherwise report a mismatch. 69 | push :: a -> (a -> Bool) -> (a -> Mismatch) -> Grammar p t (a :- t) 70 | push a p e = PartialIso f g 71 | where 72 | f t = a :- t 73 | g (a' :- t) 74 | | p a' = Right t 75 | | otherwise = Left $ e a' 76 | 77 | 78 | -- | 2-tuple grammar. Construct on forward run, deconstruct on 79 | -- backward run. 80 | pair :: Grammar p (b :- a :- t) ((a, b) :- t) 81 | pair = Iso 82 | (\(b :- a :- t) -> (a, b) :- t) 83 | (\((a, b) :- t) -> b :- a :- t) 84 | 85 | 86 | -- | List cons-cell grammar. Construct on forward run, deconstruct on 87 | -- backward run. 88 | cons :: Grammar p ([a] :- a :- t) ([a] :- t) 89 | cons = PartialIso 90 | (\(lst :- el :- t) -> (el:lst) :- t) 91 | (\(lst :- t) -> 92 | case lst of 93 | [] -> Left (expected "list element") 94 | (el:rest) -> Right (rest :- el :- t)) 95 | 96 | 97 | -- | Empty list grammar. Construct empty list on forward run, check if 98 | -- list is empty on backward run. 99 | nil :: Grammar p t ([a] :- t) 100 | nil = PartialIso 101 | (\t -> [] :- t) 102 | (\(lst :- t) -> 103 | case lst of 104 | [] -> Right t 105 | (_el:_rest) -> Left (expected "end of list")) 106 | 107 | 108 | -- | Swap two topmost stack elements. 109 | swap :: Grammar p (a :- b :- t) (b :- a :- t) 110 | swap = Iso 111 | (\(a :- b :- t) -> (b :- a :- t)) 112 | (\(b :- a :- t) -> (a :- b :- t)) 113 | 114 | 115 | -- | Assoc-list element grammar. Inserts an element (with static key) 116 | -- on forward run, look up an element on backward run. 117 | insert :: (Eq k) => k -> Mismatch -> Grammar p (v :- [(k, v)] :- t) ([(k, v)] :- t) 118 | insert k m = PartialIso 119 | (\(v :- alist :- t) -> ((k, v) : alist) :- t) 120 | (\(alist :- t) -> 121 | case popKey k alist of 122 | Nothing -> Left m 123 | Just (v, alist') -> Right (v :- alist' :- t)) 124 | 125 | 126 | -- | Optional assoc-list element grammar. Like 'insert', but does not 127 | -- report a mismatch on backward run. Instead takes and produces a 128 | -- Maybe-value. 129 | insertMay :: (Eq k) => k -> Grammar p (Maybe v :- [(k, v)] :- t) ([(k, v)] :- t) 130 | insertMay k = PartialIso 131 | (\(mv :- alist :- t) -> 132 | case mv of 133 | Just v -> ((k, v) : alist) :- t 134 | Nothing -> alist :- t) 135 | (\(alist :- t) -> 136 | case popKey k alist of 137 | Nothing -> Right (Nothing :- alist :- t) 138 | Just (v, alist') -> Right (Just v :- alist' :- t)) 139 | 140 | 141 | popKey :: forall k v. Eq k => k -> [(k, v)] -> Maybe (v, [(k, v)]) 142 | popKey k' = go [] 143 | where 144 | go :: [(k, v)] -> [(k, v)] -> Maybe (v, [(k, v)]) 145 | go acc (x@(k, v) : xs) 146 | | k == k' = Just (v, reverse acc ++ xs) 147 | | otherwise = go (x:acc) xs 148 | go _ [] = Nothing 149 | 150 | 151 | -- | Default value grammar. Replaces 'Nothing' with a default value on 152 | -- forward run, an replaces a default value with 'Nothing' on backward 153 | -- run. 154 | toDefault :: (Eq a) => a -> Grammar p (Maybe a :- t) (a :- t) 155 | toDefault def = iso 156 | (fromMaybe def) 157 | (\val -> if val == def then Nothing else Just val) 158 | 159 | 160 | -- | Run a grammar operating on the stack head in a context where 161 | -- there is no stack. 162 | sealed :: Grammar p (a :- Void) (b :- Void) -> Grammar p a b 163 | sealed g = 164 | Iso (:- error "void") (\(a :- _) -> a) >>> 165 | g >>> 166 | Iso (\(a :- _) -> a) (:- error "void") 167 | 168 | 169 | -- | Focus a given grammar to the stack head. 170 | onHead :: Grammar p a b -> Grammar p (a :- t) (b :- t) 171 | onHead = OnHead 172 | 173 | 174 | -- | Focus a given grammar to the stack tail. 175 | onTail :: Grammar p ta tb -> Grammar p (h :- ta) (h :- tb) 176 | onTail = OnTail 177 | 178 | 179 | -- | Traverse a structure with a given grammar. 180 | traversed :: (Traversable f) => Grammar p a b -> Grammar p (f a) (f b) 181 | traversed = Traverse 182 | 183 | 184 | -- | Run a grammar with inputs and outputs flipped. 185 | flipped :: Grammar p a b -> Grammar p b a 186 | flipped = Flip 187 | 188 | 189 | -- | Run a grammar with an annotation. 190 | annotated :: Text -> Grammar p a b -> Grammar p a b 191 | annotated = Annotate 192 | 193 | 194 | -- | Run a grammar with the stack heads coerced to other ('Coercible') 195 | -- types. 196 | coerced 197 | :: (Coercible a c, Coercible b d) => 198 | Grammar p (a :- t) (b :- t') 199 | -> Grammar p (c :- t) (d :- t') 200 | coerced g = iso coerce coerce >>> g >>> iso coerce coerce 201 | 202 | 203 | -- | Join alternative grammars in parallel. 204 | coproduct :: [Grammar p a b] -> Grammar p a b 205 | coproduct = foldl1 (<>) 206 | -------------------------------------------------------------------------------- /invertible-grammar/src/Data/InvertibleGrammar/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE Safe #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | 7 | module Data.InvertibleGrammar.Monad 8 | ( module Control.Monad.ContextError 9 | , runGrammar 10 | , runGrammarDoc 11 | , runGrammarString 12 | , ErrorMessage (..) 13 | , doAnnotate 14 | , doDive 15 | , doStep 16 | , doLocate 17 | , doError 18 | , Propagation 19 | , GrammarError (..) 20 | , Mismatch 21 | , expected 22 | , unexpected 23 | ) where 24 | 25 | import Control.Arrow (left) 26 | import Control.Applicative 27 | import Control.Monad.ContextError 28 | 29 | import Data.Maybe 30 | import Data.Semigroup as Semi 31 | import Data.Set (Set) 32 | import qualified Data.Set as S 33 | import Data.Text (Text) 34 | import GHC.Generics 35 | 36 | import Prettyprinter 37 | ( Doc, Pretty, pretty, vsep, hsep, line, indent, fillSep, punctuate 38 | , comma, colon, (<+>), layoutSmart, PageWidth(..), LayoutOptions(..) 39 | ) 40 | 41 | import Prettyprinter.Render.String 42 | 43 | initPropagation :: p -> Propagation p 44 | initPropagation = Propagation [0] [] 45 | 46 | data Propagation p = Propagation 47 | { pProp :: [Int] 48 | , pAnns :: [Text] 49 | , pPos :: p 50 | } deriving (Show) 51 | 52 | instance Eq (Propagation p) where 53 | Propagation xs _ _ == Propagation ys _ _ = xs == ys 54 | {-# INLINE (==) #-} 55 | 56 | instance Ord (Propagation p) where 57 | compare (Propagation as _ _) (Propagation bs _ _) = 58 | reverse as `compare` reverse bs 59 | {-# INLINE compare #-} 60 | 61 | -- | Data type to encode mismatches during parsing or generation, kept 62 | -- abstract. Use 'expected' and 'unexpected' constructors to build a 63 | -- mismatch report. 64 | data Mismatch = Mismatch 65 | { mismatchExpected :: Set Text 66 | , mismatchGot :: Maybe Text 67 | } deriving (Show, Eq) 68 | 69 | -- | Construct a mismatch report with specified expectation. Can be 70 | -- appended to other expectations and 'unexpected' reports to clarify 71 | -- a mismatch. 72 | expected :: Text -> Mismatch 73 | expected a = Mismatch (S.singleton a) Nothing 74 | 75 | -- | Construct a mismatch report with information what occurred during 76 | -- the processing but was not expected. 77 | unexpected :: Text -> Mismatch 78 | unexpected a = Mismatch S.empty (Just a) 79 | 80 | instance Semigroup Mismatch where 81 | m <> m' = 82 | Mismatch 83 | (mismatchExpected m Semi.<> mismatchExpected m') 84 | (mismatchGot m <|> mismatchGot m') 85 | {-# INLINE (<>) #-} 86 | 87 | instance Monoid Mismatch where 88 | mempty = Mismatch mempty mempty 89 | {-# INLINE mempty #-} 90 | mappend = (<>) 91 | {-# INLINE mappend #-} 92 | 93 | -- | Run a 'forward' or 'backward' pass of a 'Grammar'. 94 | runGrammar :: p -> ContextError (Propagation p) (GrammarError p) a -> Either (ErrorMessage p) a 95 | runGrammar initPos m = 96 | case runContextError m (initPropagation initPos) of 97 | Left (GrammarError p mismatch) -> 98 | Left $ ErrorMessage 99 | (pPos p) 100 | (reverse (pAnns p)) 101 | (mismatchExpected mismatch) 102 | (mismatchGot mismatch) 103 | Right a -> 104 | Right a 105 | 106 | -- | Run a 'forward' or 'backward' pass of a 'Grammar', report errors 107 | -- as pretty printed 'Doc' message. 108 | runGrammarDoc :: (Pretty p) => p -> ContextError (Propagation p) (GrammarError p) a -> Either (Doc ann) a 109 | runGrammarDoc initPos m = 110 | left (ppError pretty) $ 111 | runGrammar initPos m 112 | 113 | -- | Run a 'forward' or 'backward' pass of a 'Grammar', report errors 114 | -- as 'String' message. 115 | runGrammarString :: (Show p) => p -> ContextError (Propagation p) (GrammarError p) a -> Either String a 116 | runGrammarString initPos m = 117 | left (renderString . layoutSmart (LayoutOptions (AvailablePerLine 79 0.75)) . ppError (pretty . show)) $ 118 | runGrammar initPos m 119 | 120 | -- | 'Grammar' run error messages type. 121 | data ErrorMessage p = ErrorMessage 122 | { emPosition :: p 123 | , emAnnotations :: [Text] 124 | , emExpected :: Set Text 125 | , emGot :: Maybe Text 126 | } deriving (Eq, Ord, Generic) 127 | 128 | instance (Pretty p) => Pretty (ErrorMessage p) where 129 | pretty = ppError pretty 130 | 131 | ppMismatch :: Set Text -> Maybe Text -> Doc ann 132 | ppMismatch (S.toList -> []) Nothing = 133 | "Unknown mismatch occurred" 134 | ppMismatch (S.toList -> []) unexpected = 135 | "Unexpected:" <+> pretty unexpected 136 | ppMismatch (S.toList -> expected) Nothing = 137 | "Expected:" <+> fillSep (punctuate comma $ map pretty expected) 138 | ppMismatch (S.toList -> expected) (Just got) = 139 | vsep 140 | [ "Expected:" <+> fillSep (punctuate comma $ map pretty expected) 141 | , "But got: " <+> pretty got 142 | ] 143 | 144 | ppError :: (p -> Doc ann) -> ErrorMessage p -> Doc ann 145 | ppError ppPosition (ErrorMessage pos annotations expected got) = 146 | vsep $ catMaybes 147 | [ Just $ ppPosition pos `mappend` ":" <+> "mismatch:" 148 | , if null annotations 149 | then Nothing 150 | else Just $ indent 2 $ "In" <+> hsep (punctuate (comma <> line <> "in") $ map pretty annotations) <> colon 151 | , Just $ indent 4 $ ppMismatch expected got 152 | ] 153 | 154 | data GrammarError p = GrammarError (Propagation p) Mismatch 155 | deriving (Show) 156 | 157 | instance Semigroup (GrammarError p) where 158 | GrammarError pos m <> GrammarError pos' m' 159 | | pos > pos' = GrammarError pos m 160 | | pos < pos' = GrammarError pos' m' 161 | | otherwise = GrammarError pos (m <> m') 162 | {-# INLINE (<>) #-} 163 | 164 | doAnnotate :: MonadContextError (Propagation p) e m => Text -> m a -> m a 165 | doAnnotate ann = 166 | localContext $ \propagation -> 167 | propagation { pAnns = ann : pAnns propagation } 168 | {-# INLINE doAnnotate #-} 169 | 170 | doDive :: MonadContextError (Propagation p) e m => m a -> m a 171 | doDive = 172 | localContext $ \propagation -> 173 | propagation { pProp = 0 : pProp propagation } 174 | {-# INLINE doDive #-} 175 | 176 | doStep :: MonadContextError (Propagation p) e m => m () 177 | doStep = 178 | modifyContext $ \propagation -> 179 | propagation 180 | { pProp = case pProp propagation of 181 | (x : xs) -> succ x : xs 182 | [] -> [0] 183 | } 184 | {-# INLINE doStep #-} 185 | 186 | doLocate :: MonadContextError (Propagation p) e m => p -> m () 187 | doLocate pos = 188 | modifyContext $ \propagation -> 189 | propagation { pPos = pos } 190 | {-# INLINE doLocate #-} 191 | 192 | doError :: MonadContextError (Propagation p) (GrammarError p) m => Mismatch -> m a 193 | doError mismatch = 194 | throwInContext $ \ctx -> 195 | GrammarError ctx mismatch 196 | {-# INLINE doError #-} 197 | -------------------------------------------------------------------------------- /examples/Lang.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE DeriveFoldable #-} 6 | {-# LANGUAGE DeriveTraversable #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | 12 | {-# OPTIONS_GHC -fno-warn-orphans #-} 13 | 14 | module Lang where 15 | 16 | import Prelude hiding ((.), id) 17 | import Control.Category 18 | import Control.Monad.Reader 19 | import Data.Data (Data) 20 | import qualified Data.ByteString.Lazy.Char8 as B8 21 | import Data.Text (Text) 22 | import qualified Data.Map as M 23 | import qualified Data.Set as S 24 | #if !MIN_VERSION_base(4,8,0) 25 | import Data.Monoid 26 | #endif 27 | #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 710 28 | import Data.Foldable (foldl) 29 | #endif 30 | #if !MIN_VERSION_base(4,11,0) 31 | import Data.Semigroup 32 | #endif 33 | import Data.Maybe 34 | 35 | import Language.SexpGrammar 36 | import Language.SexpGrammar.Generic 37 | import GHC.Generics 38 | import Data.Coerce 39 | 40 | newtype Fix f = Fix (f (Fix f)) 41 | 42 | unFix :: Fix f -> f (Fix f) 43 | unFix (Fix f) = f 44 | 45 | fx :: Grammar g (f (Fix f) :- t) (Fix f :- t) 46 | fx = iso coerce coerce 47 | 48 | cata :: (Functor f) => (f a -> a) -> Fix f -> a 49 | cata f = f . fmap (cata f) . unFix 50 | 51 | data Literal 52 | = LitInt Int 53 | | LitDouble Double 54 | deriving (Eq, Show, Generic) 55 | 56 | asInt :: Literal -> Maybe Int 57 | asInt (LitDouble _) = Nothing 58 | asInt (LitInt a) = Just a 59 | 60 | asDouble :: Literal -> Double 61 | asDouble (LitDouble a) = a 62 | asDouble (LitInt a) = fromIntegral a 63 | 64 | instance SexpIso Literal where 65 | sexpIso = match 66 | $ With (\i -> i . int) 67 | $ With (\d -> d . double) 68 | $ End 69 | 70 | newtype Ident = Ident Text 71 | deriving (Eq, Ord, Show, Generic) 72 | 73 | instance SexpIso Ident where 74 | sexpIso = with (\ident -> ident . symbol) 75 | 76 | data Func 77 | = Prim Prim 78 | | Named Ident 79 | deriving (Eq, Show, Generic) 80 | 81 | instance SexpIso Func where 82 | sexpIso = match 83 | $ With (\prim -> prim . sexpIso) 84 | $ With (\named -> named . sexpIso) 85 | $ End 86 | 87 | data Prim 88 | = Add 89 | | Mul 90 | | Sub 91 | | Div 92 | deriving (Eq, Show, Bounded, Enum, Data, Generic) 93 | 94 | instance SexpIso Prim where 95 | sexpIso = match 96 | $ With (\_Add -> _Add . sym "+") 97 | $ With (\_Mul -> _Mul . sym "*") 98 | $ With (\_Sub -> _Sub . sym "-") 99 | $ With (\_Div -> _Div . sym "/") 100 | $ End 101 | 102 | evalP :: Prim -> [Literal] -> Literal 103 | evalP p = 104 | case p of 105 | Add -> \ls -> fromMaybe (LitDouble $ sum $ map asDouble ls) 106 | (LitInt . sum <$> traverse asInt ls) 107 | Mul -> \ls -> fromMaybe (LitDouble $ product $ map asDouble ls) 108 | (LitInt . product <$> traverse asInt ls) 109 | Sub -> \[a,b] -> fromMaybe (LitDouble $ asDouble a - asDouble b) 110 | ((LitInt .) . (-) <$> asInt a <*> asInt b) 111 | Div -> \[a,b] -> fromMaybe (LitDouble $ asDouble a / asDouble b) 112 | ((LitInt .) . div <$> asInt a <*> asInt b) 113 | 114 | type Expr = Fix ExprF 115 | 116 | data ExprF e 117 | = Lit Literal 118 | | Var Ident 119 | | Let Ident e e 120 | | Apply Prim [e] 121 | | Cond e e e 122 | deriving (Eq, Show, Functor, Foldable, Traversable, Generic) 123 | 124 | exprIso :: SexpGrammar (ExprF (Fix ExprF)) 125 | exprIso = match 126 | $ With (\_Lit -> _Lit . sexpIso) 127 | $ With (\_Var -> _Var . sexpIso) 128 | $ With (\_Let -> _Let . list 129 | ( el (sym "let") >>> 130 | el sexpIso >>> 131 | el (fx . exprIso) >>> 132 | el (fx . exprIso) ) ) 133 | $ With (\_Apply -> _Apply . list 134 | ( el sexpIso >>> 135 | rest (fx . exprIso ) ) ) 136 | $ With (\_Cond -> _Cond . list 137 | ( el (sym "if") >>> 138 | el (fx . exprIso) >>> 139 | el (fx . exprIso) >>> 140 | el (fx . exprIso) ) ) 141 | $ End 142 | 143 | instance SexpIso (Fix ExprF) where 144 | sexpIso = fx . exprIso 145 | 146 | type PEvalM = Reader (M.Map Ident Literal) 147 | 148 | partialEval :: Expr -> Expr 149 | partialEval e = runReader (cata alg e) M.empty 150 | where 151 | alg :: ExprF (PEvalM Expr) -> PEvalM Expr 152 | alg (Lit a) = return (Fix $ Lit a) 153 | alg (Var v) = do 154 | val <- asks (M.lookup v) 155 | case val of 156 | Nothing -> return $ Fix (Var v) 157 | Just a -> return $ Fix (Lit a) 158 | alg (Let n e r) = do 159 | e' <- e 160 | r' <- case unFix e' of 161 | Lit a -> local (M.insert n a) r 162 | _ -> r 163 | case unFix r' of 164 | Lit a -> return (Fix $ Lit a) 165 | _ -> case M.findWithDefault 0 n (gatherFreeVars r') of 166 | 0 -> return r' 167 | 1 -> return $ inline (M.singleton n e') r' 168 | _ -> return (Fix $ Let n e' r') 169 | alg (Apply p args) = do 170 | args' <- sequence args 171 | let args'' = getLits args' 172 | return $ Fix $ maybe (Apply p args') (Lit . evalP p) args'' 173 | alg (Cond c t f) = do 174 | c' <- c 175 | t' <- t 176 | f' <- f 177 | case c' of 178 | Fix (Lit (LitInt 0)) -> return f' 179 | Fix (Lit (LitDouble 0.0)) -> return f' 180 | Fix (Lit _) -> return t' 181 | _ -> return $ Fix $ Cond c' t' f' 182 | 183 | type FreeVarsM = Reader (S.Set Ident) 184 | 185 | gatherFreeVars :: Expr -> M.Map Ident Int 186 | gatherFreeVars e = runReader (cata alg e) S.empty 187 | where 188 | alg :: ExprF (FreeVarsM (M.Map Ident Int)) -> FreeVarsM (M.Map Ident Int) 189 | alg (Let n e r) = do 190 | e' <- e 191 | r' <- local (S.insert n) r 192 | return $ e' <> r' 193 | alg (Var n) = do 194 | bound <- asks (S.member n) 195 | return $ if bound then M.empty else M.singleton n 1 196 | alg other = foldl (M.unionWith (+)) M.empty <$> sequence other 197 | 198 | getLits :: [Expr] -> Maybe [Literal] 199 | getLits = sequence . map getLit 200 | where 201 | getLit (Fix (Lit a)) = Just a 202 | getLit _ = Nothing 203 | 204 | type InlineM = Reader (M.Map Ident Expr) 205 | 206 | inline :: M.Map Ident Expr -> Expr -> Expr 207 | inline env e = runReader (cata alg e) env 208 | where 209 | alg :: ExprF (InlineM Expr) -> InlineM Expr 210 | alg (Var n) = do 211 | subst <- asks (M.lookup n) 212 | case subst of 213 | Nothing -> return $ Fix $ Var n 214 | Just e -> return e 215 | alg (Let n e r) = do 216 | e' <- e 217 | r' <- local (M.delete n) r 218 | return $ Fix $ Let n e' r' 219 | alg other = Fix <$> sequence other 220 | 221 | test :: String -> String 222 | test str = either error id $ do 223 | e <- decode (B8.pack str) 224 | either error (return . B8.unpack) (encodePretty (partialEval e)) 225 | 226 | -- λ> test "(let foo (/ 42 2) (let bar (* foo 1.5 baz) (if 0 foo (+ 1 bar))))" 227 | -- "(+ 1 (* 21 1.5 baz))" 228 | -------------------------------------------------------------------------------- /invertible-grammar/src/Data/InvertibleGrammar/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE Trustworthy #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module Data.InvertibleGrammar.Base 9 | ( Grammar (..) 10 | , (:-) (..) 11 | , forward 12 | , backward 13 | , GrammarError (..) 14 | , Mismatch 15 | , expected 16 | , unexpected 17 | ) where 18 | 19 | import Prelude hiding ((.), id) 20 | import Control.Category 21 | import Control.Monad 22 | import Data.Text (Text) 23 | import Data.Bifunctor 24 | import Data.Bifoldable 25 | import Data.Bitraversable 26 | import Data.InvertibleGrammar.Monad 27 | import qualified Debug.Trace 28 | 29 | -- | \"Cons\" pair of a heterogenous list or a stack with potentially 30 | -- polymophic tail. E.g. @"first" :- 2 :- (3,4) :- t@ 31 | -- 32 | -- Isomorphic to a tuple with two elments, but is much more 33 | -- convenient for nested pairs. 34 | data h :- t = h :- t deriving (Eq, Show, Functor, Foldable, Traversable) 35 | infixr 5 :- 36 | 37 | instance Bifunctor (:-) where 38 | bimap f g (a :- b) = f a :- g b 39 | 40 | instance Bifoldable (:-) where 41 | bifoldr f g x0 (a :- b) = a `f` (b `g` x0) 42 | 43 | instance Bitraversable (:-) where 44 | bitraverse f g (a :- b) = (:-) <$> f a <*> g b 45 | 46 | -- | Representation of an invertible grammar -- a grammar that can be 47 | -- run either "forwards" and "backwards". 48 | -- 49 | -- For a grammar @Grammar p a b@, running it forwards will take a 50 | -- value of type @a@ and possibly produce a value of type @b@. Running 51 | -- it backwards will take a value of type @b@ and possibly produce an 52 | -- @a@. If a value cannot be produced, an error message is generated. 53 | -- 54 | -- As a common example, running a 'Grammar' forwards corresponds to 55 | -- parsing and running backwards corresponds to prettyprinting. 56 | -- 57 | -- That is, the grammar defines a partial isomorphism between two 58 | -- values. 59 | data Grammar p a b where 60 | -- | Total isomorphism grammar. 61 | Iso :: (a -> b) -> (b -> a) -> Grammar p a b 62 | 63 | -- | Partial isomorphism. Use 'Flip' to change the direction of 64 | -- partiality. 65 | PartialIso :: (a -> b) -> (b -> Either Mismatch a) -> Grammar p a b 66 | 67 | -- | Flip forward and backward passes of an underlying grammar. 68 | Flip :: Grammar p a b -> Grammar p b a 69 | 70 | -- | Grammar composition. 71 | (:.:) :: Grammar p b c -> Grammar p a b -> Grammar p a c 72 | 73 | -- | Grammar alternation. Left operand is tried first. 74 | (:<>:) :: Grammar p a b -> Grammar p a b -> Grammar p a b 75 | 76 | -- | Application of a grammar on 'Traversable' functor. 77 | Traverse :: (Traversable f) => Grammar p a b -> Grammar p (f a) (f b) 78 | 79 | -- | Applicaiton of a grammar on stack head 80 | -- (first component of ':-'). 81 | OnHead :: Grammar p a b -> Grammar p (a :- t) (b :- t) 82 | 83 | -- | Applicaiton of a grammar on stack tail 84 | -- (second component of ':-'). 85 | OnTail :: Grammar p a b -> Grammar p (h :- a) (h :- b) 86 | 87 | -- | Application of a grammar inside a context of annotation, used 88 | -- for error messages. 89 | Annotate :: Text -> Grammar p a b -> Grammar p a b 90 | 91 | -- | Application of a grammar inside a context of a nested 92 | -- structure, used for error messages. E.g. JSON arrays. 93 | Dive :: Grammar p a b -> Grammar p a b 94 | 95 | -- | Propagate logical position inside a nested 96 | -- structure. E.g. after each successfully matched element of a JSON 97 | -- array. 98 | Step :: Grammar p a a 99 | 100 | -- | Update the position of grammar monad from value on grammar's 101 | -- input or output on forward or backward pass, respectively. Used 102 | -- for error messages. 103 | Locate :: Grammar p p p 104 | 105 | trace :: String -> a -> a 106 | trace = if False then Debug.Trace.trace else flip const 107 | 108 | 109 | instance Category (Grammar p) where 110 | id = Iso id id 111 | 112 | PartialIso f g . Iso f' g' = trace "p/i" $ PartialIso (f . f') (fmap g' . g) 113 | Iso f g . PartialIso f' g' = trace "i/p" $ PartialIso (f . f') (g' . g) 114 | 115 | Flip (PartialIso f g) . Iso f' g' = trace "fp/i" $ Flip $ PartialIso (g' . f) (g . f') 116 | Iso f g . Flip (PartialIso f' g') = trace "i/fp" $ Flip $ PartialIso (f' . g) (fmap f . g') 117 | 118 | PartialIso f g . (Iso f' g' :.: h) = trace "p/i2" $ PartialIso (f . f') (fmap g' . g) :.: h 119 | Iso f g . (PartialIso f' g' :.: h) = trace "i/p2" $ PartialIso (f . f') (g' . g) :.: h 120 | 121 | Flip (PartialIso f g) . (Iso f' g' :.: h) = trace "fp/i2" $ Flip (PartialIso (g' . f) (g . f')) :.: h 122 | Iso f g . (Flip (PartialIso f' g') :.: h) = trace "i/fp2" $ Flip (PartialIso (f' . g) (fmap f . g')) :.: h 123 | 124 | Flip g . Flip h = trace "f/f" $ Flip (h . g) 125 | Iso f g . Iso f' g' = trace "i/i" $ Iso (f . f') (g' . g) 126 | 127 | (g :.: h) . j = trace "assoc" $ g :.: (h . j) 128 | 129 | g . h = g :.: h 130 | 131 | 132 | instance Semigroup (Grammar p a b) where 133 | (<>) = (:<>:) 134 | 135 | -- | Run 'Grammar' forwards. 136 | -- 137 | -- For @Grammar p a b@, given a value of type @a@ tries to produce a 138 | -- value of type @b@, otherwise reports an error with position of type 139 | -- @p@. 140 | forward :: Grammar p a b -> a -> ContextError (Propagation p) (GrammarError p) b 141 | forward (Iso f _) = return . f 142 | forward (PartialIso f _) = return . f 143 | forward (Flip g) = backward g 144 | forward (g :.: f) = forward g <=< forward f 145 | forward (f :<>: g) = \x -> forward f x `mplus` forward g x 146 | forward (Traverse g) = traverse (forward g) 147 | forward (OnHead g) = \(a :- b) -> (:- b) <$> forward g a 148 | forward (OnTail g) = \(a :- b) -> (a :-) <$> forward g b 149 | forward (Annotate t g) = doAnnotate t . forward g 150 | forward (Dive g) = doDive . forward g 151 | forward Step = \x -> doStep >> return x 152 | forward Locate = \x -> doLocate x >> return x 153 | 154 | -- | Run 'Grammar' backwards. 155 | -- 156 | -- For @Grammar p a b@, given a value of type @b@ tries to produce a 157 | -- value of type @a@, otherwise reports an error with position of type 158 | -- @p@. 159 | backward :: Grammar p a b -> b -> ContextError (Propagation p) (GrammarError p) a 160 | backward (Iso _ g) = return . g 161 | backward (PartialIso _ g) = either doError return . g 162 | backward (Flip g) = forward g 163 | backward (g :.: f) = backward g >=> backward f 164 | backward (f :<>: g) = \x -> backward f x `mplus` backward g x 165 | backward (Traverse g) = traverse (backward g) 166 | backward (OnHead g) = \(a :- b) -> (:- b) <$> backward g a 167 | backward (OnTail g) = \(a :- b) -> (a :-) <$> backward g b 168 | backward (Annotate t g) = doAnnotate t . backward g 169 | backward (Dive g) = doDive . backward g 170 | backward Step = \x -> doStep >> return x 171 | backward Locate = \x -> doLocate x >> return x 172 | -------------------------------------------------------------------------------- /sexp-grammar/bench/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | {-# OPTIONS_GHC -fno-warn-orphans #-} 9 | 10 | module Main (main) where 11 | 12 | import Criterion.Main 13 | 14 | import Prelude hiding ((.), id) 15 | 16 | import Control.Arrow 17 | import Control.Category 18 | import Control.DeepSeq 19 | import Control.Exception 20 | 21 | import Data.ByteString.Lazy.Char8 (ByteString) 22 | import qualified Data.ByteString.Lazy.Char8 as B8 23 | import Data.Text (Text) 24 | import GHC.Generics (Generic) 25 | 26 | import qualified Language.Sexp.Located as Sexp 27 | 28 | import Language.SexpGrammar 29 | import qualified Language.SexpGrammar.TH as TH 30 | import qualified Language.SexpGrammar.Generic as G 31 | import Language.SexpGrammar.Generic (Coproduct(..)) 32 | 33 | newtype Ident = Ident Text 34 | deriving (Show, Eq, Generic) 35 | 36 | data Expr 37 | = Var Ident 38 | | Lit Int 39 | | Add Expr Expr 40 | | Mul Expr Expr 41 | | Inv Expr 42 | | IfZero Expr Expr (Maybe Expr) 43 | | Apply [Expr] String Prim -- inconvenient ordering: arguments, useless annotation, identifier 44 | deriving (Show, Eq, Generic) 45 | 46 | data Prim 47 | = SquareRoot 48 | | Factorial 49 | | Fibonacci 50 | deriving (Show, Eq, Generic) 51 | 52 | instance NFData Ident 53 | instance NFData Prim 54 | instance NFData Expr 55 | 56 | return [] 57 | 58 | type SexpG a = forall t. Grammar Position (Sexp :- t) (a :- t) 59 | 60 | instance SexpIso Prim where 61 | sexpIso = G.match 62 | $ With (sym "square-root" >>>) 63 | $ With (sym "factorial" >>>) 64 | $ With (sym "fibonacci" >>>) 65 | $ End 66 | 67 | instance SexpIso Ident where 68 | sexpIso = $(TH.match ''Ident) 69 | (\_Ident -> _Ident . symbol) 70 | 71 | exprGrammarTH :: SexpG Expr 72 | exprGrammarTH = go 73 | where 74 | go :: SexpG Expr 75 | go = $(TH.match ''Expr) 76 | (\_Var -> _Var . sexpIso) 77 | (\_Lit -> _Lit . int) 78 | (\_Add -> _Add . list (el (sym "+") >>> el go >>> el go)) 79 | (\_Mul -> _Mul . list (el (sym "*") >>> el go >>> el go)) 80 | (\_Inv -> _Inv . list (el (sym "invert") >>> el go)) 81 | (\_IfZero -> _IfZero . list (el (sym "cond") >>> props ( "pred" .: go 82 | >>> "true" .: go 83 | >>> "false" .:? go ))) 84 | (\_Apply -> _Apply . -- Convert prim :- "dummy" :- args :- () to Apply node 85 | list 86 | (el (sexpIso :: SexpG Prim) >>> -- Push prim: prim :- () 87 | el (sym ":args") >>> -- Recognize :args, push nothing 88 | rest (go :: SexpG Expr) >>> -- Push args: args :- prim :- () 89 | onTail ( 90 | swap >>> -- Swap: prim :- args :- () 91 | push "dummy" -- Push "dummy": "dummy" :- prim :- args :- () 92 | (const True) 93 | (const (expected "dummy")) >>> 94 | swap) -- Swap: prim :- "dummy" :- args :- () 95 | )) 96 | 97 | exprGrammarGeneric :: SexpG Expr 98 | exprGrammarGeneric = go 99 | where 100 | go :: SexpG Expr 101 | go = G.match 102 | $ With (\_Var -> _Var . sexpIso) 103 | $ With (\_Lit -> _Lit . int) 104 | $ With (\_Add -> _Add . list (el (sym "+") >>> el go >>> el go)) 105 | $ With (\_Mul -> _Mul . list (el (sym "*") >>> el go >>> el go)) 106 | $ With (\_Inv -> _Inv . list (el (sym "invert") >>> el go)) 107 | $ With (\_IfZero -> _IfZero . list (el (sym "cond") >>> props ( "pred" .: go 108 | >>> "true" .: go 109 | >>> "false" .:? go ))) 110 | $ With (\_Apply -> _Apply . -- Convert prim :- "dummy" :- args :- () to Apply node 111 | list 112 | (el (sexpIso :: SexpG Prim) >>> -- Push prim: prim :- () 113 | el (sym ":args") >>> -- Recognize :args, push nothing 114 | rest (go :: SexpG Expr) >>> -- Push args: args :- prim :- () 115 | onTail ( 116 | swap >>> -- Swap: prim :- args :- () 117 | push "dummy" -- Push "dummy": "dummy" :- prim :- args :- () 118 | (const True) 119 | (const (expected "dummy")) >>> 120 | swap) -- Swap: prim :- "dummy" :- args :- () 121 | )) 122 | $ End 123 | 124 | 125 | exprOf :: ByteString -> Expr 126 | exprOf = either error id . decodeWith exprGrammarTH "" 127 | 128 | benchCases :: [(String, ByteString)] 129 | benchCases = map (\a -> ("expression, size " ++ show (B8.length a) ++ " bytes", a)) 130 | [ "(+ 1 20)" 131 | , "(cond :pred (+ 42 x) :false (fibonacci :args 3) :true (factorial :args (* 10 (+ 1 2))))" 132 | , "(invert (* (+ (cond :pred (+ 42 314) :false (fibonacci :args 3) :true (factorial :args \ 133 | \(* 10 (+ 1 2)))) (cond :pred (+ 42 28) :false (fibonacci :args 3) :true (factorial :args \ 134 | \(* 10 (+ 1 2))))) (+ (cond :pred (+ 42 314) :false (fibonacci :args 3) :true (factorial \ 135 | \:args (* 10 (+ foo bar)))) (cond :pred (+ 42 314) :false (fibonacci :args 3) :true (factorial \ 136 | \:args (* 10 (+ 1 2)))))))" 137 | , "(fibonacci :args (* (+ (cond :pred (+ 42 314) :false (invert (* (+ (cond :pred (+ 42 314) :false \ 138 | \(fibonacci :args 3) :true (factorial :args \ 139 | \(* 10 (+ 1 2)))) (cond :pred (+ 42 28) :false (fibonacci :args 3) :true (factorial :args \ 140 | \(* 10 (+ 1 2))))) (+ (cond :pred (+ 42 314) :false (fibonacci :args 3) :true (factorial \ 141 | \:args (* 10 (+ foo bar)))) (cond :pred (invert (* (+ (cond :pred (+ 42 314) :false (invert (* \ 142 | \(+ (cond :pred (+ 42 314) :false (fibonacci :args 3) :true (factorial :args \ 143 | \(* 10 (+ 1 2)))) (cond :pred (+ 42 28) :false (fibonacci :args 3) :true (factorial :args \ 144 | \(* 10 (+ 1 2))))) (+ (cond :pred (+ 42 314) :false (fibonacci :args 3) :true (factorial \ 145 | \:args (* 10 (+ foo bar)))) (cond :pred (+ 42 314) :false (fibonacci :args 3) :true (factorial \ 146 | \:args (* 10 (+ 1 2))))))) :true (factorial :args \ 147 | \(* 10 (+ 1 2)))) (cond :pred (+ 42 28) :false (fibonacci :args 3) :true (factorial :args \ 148 | \(* 10 (+ 1 2))))) (+ (cond :pred (+ 42 314) :false (fibonacci :args 3) :true (factorial \ 149 | \:args (* 10 (+ foo bar)))) (cond :pred (+ 42 314) :false (fibonacci :args 3) :true (factorial \ 150 | \:args (* 10 (+ 1 2))))))) :false (fibonacci :args 3) :true (factorial \ 151 | \:args (* 10 (+ 1 2))))))) :true (factorial :args \ 152 | \(* 10 (+ 1 2)))) (cond :pred (+ 42 28) :false (fibonacci :args 3) :true (factorial :args \ 153 | \(* 10 (+ 1 2))))) (+ (cond :pred (+ 42 314) :false (fibonacci :args 3) :true (factorial \ 154 | \:args (* 10 (+ foo bar)))) (cond :pred (+ 42 314) :false (fibonacci :args 3) :true (factorial \ 155 | \:args (* 10 (+ 1 2)))))))" 156 | ] 157 | 158 | mkBenchmark :: String -> ByteString -> IO Benchmark 159 | mkBenchmark name str = do 160 | expr <- evaluate $ force $ exprOf str 161 | sexp <- evaluate $ force $ either error id (toSexp exprGrammarTH expr) 162 | return $ bgroup name 163 | [ bench "decode" $ nf (Sexp.decode) str 164 | , bench "encode" $ nf (Sexp.encode) sexp 165 | , bench "format" $ nf (Sexp.format) sexp 166 | , bench "toSexpTH" $ nf (toSexp exprGrammarTH) expr 167 | , bench "toSexpG" $ nf (toSexp exprGrammarGeneric) expr 168 | , bench "fromSexpTH" $ nf (fromSexp exprGrammarTH) sexp 169 | , bench "fromSexpG" $ nf (fromSexp exprGrammarGeneric) sexp 170 | ] 171 | 172 | main :: IO () 173 | main = do 174 | cases <- mapM (uncurry mkBenchmark) benchCases 175 | defaultMain cases 176 | -------------------------------------------------------------------------------- /invertible-grammar/src/Control/Monad/ContextError.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE Safe #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | 9 | module Control.Monad.ContextError 10 | ( ContextErrorT 11 | , runContextErrorT 12 | , ContextError 13 | , runContextError 14 | , MonadContextError (..) 15 | ) where 16 | 17 | import Control.Applicative 18 | import Control.Monad (MonadPlus, mplus, mzero) 19 | import Control.Monad.Trans.Class (MonadTrans, lift) 20 | import Control.Monad.Trans.Cont as Cont (ContT, liftLocal) 21 | import Control.Monad.Trans.Except (ExceptT, mapExceptT) 22 | import Control.Monad.Trans.Identity (IdentityT, mapIdentityT) 23 | import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT) 24 | import Control.Monad.Trans.Reader (ReaderT, mapReaderT) 25 | import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST, mapRWST) 26 | import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST, mapRWST) 27 | import qualified Control.Monad.Trans.State.Lazy as Lazy (StateT, mapStateT) 28 | import qualified Control.Monad.Trans.State.Strict as Strict (StateT, mapStateT) 29 | import Control.Monad.Trans.Writer.Lazy as Lazy (WriterT, mapWriterT) 30 | import Control.Monad.Trans.Writer.Strict as Strict (WriterT, mapWriterT) 31 | 32 | import Control.Monad.State (MonadState (..)) 33 | import Control.Monad.Reader (MonadReader (..)) 34 | import Control.Monad.Writer (MonadWriter (..)) 35 | 36 | import Data.Functor.Identity 37 | 38 | ---------------------------------------------------------------------- 39 | -- Monad 40 | 41 | newtype ContextErrorT c e m a = 42 | ContextErrorT { unContextErrorT :: forall b. c -> (e -> m b) -> (c -> a -> m b) -> m b } 43 | 44 | runContextErrorT :: (Monad m) => ContextErrorT c e m a -> c -> m (Either e a) 45 | runContextErrorT k c = unContextErrorT k c (return . Left) (const $ return . Right) 46 | 47 | type ContextError c e a = ContextErrorT c e Identity a 48 | 49 | runContextError :: ContextError c e a -> c -> Either e a 50 | runContextError k c = runIdentity $ unContextErrorT k c (return . Left) (const $ return . Right) 51 | 52 | instance Functor (ContextErrorT c e m) where 53 | fmap f e = ContextErrorT $ \c err ret -> unContextErrorT e c err (\c' -> ret c' . f) 54 | 55 | instance Applicative (ContextErrorT c e m) where 56 | pure a = ContextErrorT $ \c _ ret -> ret c a 57 | {-# INLINE pure #-} 58 | 59 | fe <*> ae = ContextErrorT $ \c err ret -> 60 | unContextErrorT fe c err (\c' f -> unContextErrorT ae c' err (\c'' -> ret c'' . f)) 61 | {-# INLINE (<*>) #-} 62 | 63 | instance (Semigroup e) => Alternative (ContextErrorT c e m) where 64 | -- FIXME: sane 'empty' needed! 65 | empty = ContextErrorT $ \_ err _ -> err (error "empty ContextErrorT") 66 | {-# INLINE empty #-} 67 | 68 | ae <|> be = ContextErrorT $ \c err ret -> 69 | unContextErrorT ae c (\e -> unContextErrorT be c (\e' -> err (e <> e')) ret) ret 70 | {-# INLINE (<|>) #-} 71 | 72 | instance Monad (ContextErrorT c e m) where 73 | ma >>= fb = 74 | ContextErrorT $ \c err ret -> 75 | unContextErrorT ma c err $ \c' a -> 76 | unContextErrorT (fb a) c' err ret 77 | {-# INLINE (>>=) #-} 78 | 79 | instance (Semigroup e) => MonadPlus (ContextErrorT c e m) where 80 | mzero = empty 81 | {-# INLINE mzero #-} 82 | 83 | mplus = (<|>) 84 | {-# INLINE mplus #-} 85 | 86 | instance MonadTrans (ContextErrorT c e) where 87 | lift act = ContextErrorT $ \c _ ret -> act >>= ret c 88 | {-# INLINE lift #-} 89 | 90 | instance MonadState s m => MonadState s (ContextErrorT c e m) where 91 | get = lift get 92 | put = lift . put 93 | state = lift . state 94 | 95 | instance MonadWriter w m => MonadWriter w (ContextErrorT c e m) where 96 | writer = lift . writer 97 | tell = lift . tell 98 | listen m = ContextErrorT $ \c err ret -> do 99 | (res, w) <- listen (unContextErrorT m c (return . Left) (curry (return . Right))) 100 | case res of 101 | Left e -> err e 102 | Right (c', a) -> ret c' (a, w) 103 | pass m = ContextErrorT $ \c err ret -> pass $ do 104 | res <- unContextErrorT m c (return . Left) (curry (return . Right)) 105 | case res of 106 | Right (c', (a, f)) -> liftA (\b -> (b, f)) $ ret c' a 107 | Left e -> liftA (\b -> (b, id)) $ err e 108 | 109 | instance MonadReader r m => MonadReader r (ContextErrorT c e m) where 110 | ask = lift ask 111 | local f m = ContextErrorT $ \c err ret -> 112 | local f (unContextErrorT m c err ret) 113 | reader = lift . reader 114 | 115 | ---------------------------------------------------------------------- 116 | -- Monad class stuff 117 | 118 | class (Monad m) => MonadContextError c e m | m -> c e where 119 | throwInContext :: (c -> e) -> m a 120 | askContext :: m c 121 | localContext :: (c -> c) -> m a -> m a 122 | modifyContext :: (c -> c) -> m () 123 | 124 | instance Monad m => 125 | MonadContextError c e (ContextErrorT c e m) where 126 | throwInContext f = ContextErrorT $ \c err _ -> err (f c) 127 | askContext = ContextErrorT $ \c _ ret -> ret c c 128 | localContext f m = ContextErrorT $ \c err ret -> 129 | unContextErrorT m (f c) err (\_ -> ret c) 130 | modifyContext f = ContextErrorT $ \c _ ret -> ret (f c) () 131 | 132 | instance MonadContextError c e m => 133 | MonadContextError c e (ContT r m) where 134 | throwInContext = lift . throwInContext 135 | askContext = lift askContext 136 | localContext = Cont.liftLocal askContext localContext 137 | modifyContext = lift . modifyContext 138 | 139 | instance MonadContextError c e m => 140 | MonadContextError c e (ExceptT e m) where 141 | throwInContext = lift . throwInContext 142 | askContext = lift askContext 143 | localContext = mapExceptT . localContext 144 | modifyContext = lift . modifyContext 145 | 146 | instance MonadContextError c e m => 147 | MonadContextError c e (IdentityT m) where 148 | throwInContext = lift . throwInContext 149 | askContext = lift askContext 150 | localContext = mapIdentityT . localContext 151 | modifyContext = lift . modifyContext 152 | 153 | instance MonadContextError c e m => 154 | MonadContextError c e (MaybeT m) where 155 | throwInContext = lift . throwInContext 156 | askContext = lift askContext 157 | localContext = mapMaybeT . localContext 158 | modifyContext = lift . modifyContext 159 | 160 | instance MonadContextError c e m => 161 | MonadContextError c e (ReaderT r m) where 162 | throwInContext = lift . throwInContext 163 | askContext = lift askContext 164 | localContext = mapReaderT . localContext 165 | modifyContext = lift . modifyContext 166 | 167 | instance (Monoid w, MonadContextError c e m) => 168 | MonadContextError c e (Lazy.WriterT w m) where 169 | throwInContext = lift . throwInContext 170 | askContext = lift askContext 171 | localContext = Lazy.mapWriterT . localContext 172 | modifyContext = lift . modifyContext 173 | 174 | instance (Monoid w, MonadContextError c e m) => 175 | MonadContextError c e (Strict.WriterT w m) where 176 | throwInContext = lift . throwInContext 177 | askContext = lift askContext 178 | localContext = Strict.mapWriterT . localContext 179 | modifyContext = lift . modifyContext 180 | 181 | instance MonadContextError c e m => 182 | MonadContextError c e (Lazy.StateT s m) where 183 | throwInContext = lift . throwInContext 184 | askContext = lift askContext 185 | localContext = Lazy.mapStateT . localContext 186 | modifyContext = lift . modifyContext 187 | 188 | instance MonadContextError c e m => 189 | MonadContextError c e (Strict.StateT s m) where 190 | throwInContext = lift . throwInContext 191 | askContext = lift askContext 192 | localContext = Strict.mapStateT . localContext 193 | modifyContext = lift . modifyContext 194 | 195 | instance (Monoid w, MonadContextError c e m) => 196 | MonadContextError c e (Lazy.RWST r w s m) where 197 | throwInContext = lift . throwInContext 198 | askContext = lift askContext 199 | localContext = Lazy.mapRWST . localContext 200 | modifyContext = lift . modifyContext 201 | 202 | instance (Monoid w, MonadContextError c e m) => 203 | MonadContextError c e (Strict.RWST r w s m) where 204 | throwInContext = lift . throwInContext 205 | askContext = lift askContext 206 | localContext = Strict.mapRWST . localContext 207 | modifyContext = lift . modifyContext 208 | -------------------------------------------------------------------------------- /invertible-grammar/src/Data/InvertibleGrammar/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE Safe #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE TypeOperators #-} 13 | 14 | -- NB: UndecidableInstances needed for nested type family application. :-/ 15 | {-# LANGUAGE UndecidableInstances #-} 16 | 17 | module Data.InvertibleGrammar.Generic 18 | ( with 19 | , match 20 | , Coproduct (..) 21 | ) where 22 | 23 | import Prelude hiding ((.), id) 24 | 25 | import Control.Applicative 26 | import Control.Category ((.)) 27 | 28 | import Data.Functor.Identity 29 | import Data.InvertibleGrammar.Base 30 | import Data.Kind (Type) 31 | import Data.Monoid (First(..)) 32 | import Data.Profunctor (Choice(..)) 33 | import Data.Profunctor.Unsafe 34 | import Data.Tagged 35 | import Data.Text (pack) 36 | 37 | 38 | import GHC.Generics 39 | 40 | -- | Provide a data constructor/stack isomorphism to a grammar working on 41 | -- stacks. Works for types with one data constructor. For sum types use 'match' 42 | -- and 'Coproduct'. 43 | with 44 | :: forall a b s t c d f p. 45 | ( Generic a 46 | , MkPrismList (Rep a) 47 | , MkStackPrism f 48 | , Rep a ~ M1 D d (M1 C c f) 49 | , StackPrismLhs f t ~ b 50 | , Constructor c 51 | ) => 52 | (Grammar p b (a :- t) -> Grammar p s (a :- t)) 53 | -> Grammar p s (a :- t) 54 | with g = 55 | let PrismList (P prism) = mkRevPrismList 56 | name = conName (undefined :: m c f e) 57 | in g (PartialIso 58 | (fwd prism) 59 | (maybe (Left $ expected ("constructor " <> pack name)) Right . bkwd prism)) 60 | 61 | -- | Combine all grammars provided in 'Coproduct' list into a single grammar. 62 | match 63 | :: ( Generic a 64 | , MkPrismList (Rep a) 65 | , Match (Rep a) bs t 66 | , bs ~ Coll (Rep a) t 67 | ) => 68 | Coproduct p s bs a t 69 | -> Grammar p s (a :- t) 70 | match = fst . match' mkRevPrismList 71 | 72 | -- | Heterogenous list of grammars, each one matches a data constructor of type 73 | -- @a@. 'With' is used to provide a data constructor/stack isomorphism to a 74 | -- grammar working on stacks. 'End' ends the list of matches. 75 | data Coproduct p s bs a t where 76 | 77 | With 78 | :: (Grammar p b (a :- t) -> Grammar p s (a :- t)) 79 | -> Coproduct p s bs a t 80 | -> Coproduct p s (b ': bs) a t 81 | 82 | End :: Coproduct p s '[] a t 83 | 84 | ---------------------------------------------------------------------- 85 | -- Machinery 86 | 87 | type family (:++) (as :: [k]) (bs :: [k]) :: [k] where 88 | (:++) (a ': as) bs = a ': (as :++ bs) 89 | (:++) '[] bs = bs 90 | 91 | type family Coll (f :: Type -> Type) (t :: Type) :: [Type] where 92 | Coll (f :+: g) t = Coll f t :++ Coll g t 93 | Coll (M1 D c f) t = Coll f t 94 | Coll (M1 C c f) t = '[StackPrismLhs f t] 95 | 96 | type family Trav (t :: Type -> Type) (l :: [Type]) :: [Type] where 97 | Trav (f :+: g) lst = Trav g (Trav f lst) 98 | Trav (M1 D c f) lst = Trav f lst 99 | Trav (M1 C c f) (l ': ls) = ls 100 | 101 | class Match (f :: Type -> Type) bs t where 102 | match' :: PrismList f a 103 | -> Coproduct p s bs a t 104 | -> ( Grammar p s (a :- t) 105 | , Coproduct p s (Trav f bs) a t 106 | ) 107 | 108 | instance (Match f bs t, Trav f bs ~ '[]) => Match (M1 D c f) bs t where 109 | match' (PrismList p) = match' p 110 | 111 | instance 112 | ( Match f bs t 113 | , Match g (Trav f bs) t 114 | ) => Match (f :+: g) bs t where 115 | match' (p :& q) lst = 116 | let (gp, rest) = match' p lst 117 | (qp, rest') = match' q rest 118 | in (gp <> qp, rest') 119 | 120 | instance (StackPrismLhs f t ~ b, Constructor c) => Match (M1 C c f) (b ': bs) t where 121 | match' (P prism) (With g rest) = 122 | let name = conName (undefined :: m c f e) 123 | p = fwd prism 124 | q = maybe (Left $ expected ("constructor " <> pack name)) Right . bkwd prism 125 | in (g $ PartialIso p q, rest) 126 | 127 | -- NB. The following machinery is heavily based on 128 | -- https://github.com/MedeaMelana/stack-prism/blob/master/Data/StackPrism/Generic.hs 129 | 130 | -- | Derive a list of stack prisms. For more information on the shape of a 131 | -- 'PrismList', please see the documentation below. 132 | mkRevPrismList :: (Generic a, MkPrismList (Rep a)) => StackPrisms a 133 | mkRevPrismList = mkPrismList' to (Just . from) 134 | 135 | type StackPrism a b = forall p f. (Choice p, Applicative f) => p a (f a) -> p b (f b) 136 | 137 | -- | Construct a prism. 138 | stackPrism :: (a -> b) -> (b -> Maybe a) -> StackPrism a b 139 | stackPrism f g = dimap (\b -> maybe (Left b) Right (g b)) (either pure (fmap f)) . right' 140 | 141 | -- | Apply a prism in forward direction. 142 | fwd :: StackPrism a b -> a -> b 143 | fwd l = runIdentity #. unTagged #. l .# Tagged .# Identity 144 | 145 | -- | Apply a prism in backward direction. 146 | bkwd :: StackPrism a b -> b -> Maybe a 147 | bkwd l = getFirst #. getConst #. l (Const #. First #. Just) 148 | 149 | -- | Convenient shorthand for a 'PrismList' indexed by a type and its generic 150 | -- representation. 151 | type StackPrisms a = PrismList (Rep a) a 152 | 153 | -- | A data family that is indexed on the building blocks from representation 154 | -- types from @GHC.Generics@. It builds up to a list of prisms, one for each 155 | -- constructor in the generic representation. The list is wrapped in the unary 156 | -- constructor @PrismList@. Within that constructor, the prisms are separated by 157 | -- the right-associative binary infix constructor @:&@. Finally, the individual 158 | -- prisms are wrapped in the unary constructor @P@. 159 | -- 160 | -- As an example, here is how to define the prisms @nil@ and @cons@ for @[a]@, 161 | -- which is an instance of @Generic@: 162 | -- 163 | -- > nil :: StackPrism t ([a] :- t) 164 | -- > cons :: StackPrism (a :- [a] :- t) ([a] :- t) 165 | -- > PrismList (P nil :& P cons) = mkPrismList :: StackPrisms [a] 166 | data family PrismList (f :: Type -> Type) (a :: Type) 167 | 168 | class MkPrismList (f :: Type -> Type) where 169 | mkPrismList' :: (f p -> a) -> (a -> Maybe (f q)) -> PrismList f a 170 | 171 | data instance PrismList (M1 D c f) a = PrismList (PrismList f a) 172 | 173 | instance MkPrismList f => MkPrismList (M1 D c f) where 174 | mkPrismList' f' g' = PrismList (mkPrismList' (f' . M1) (fmap unM1 . g')) 175 | 176 | infixr :& 177 | data instance PrismList (f :+: g) a = PrismList f a :& PrismList g a 178 | 179 | instance (MkPrismList f, MkPrismList g) => MkPrismList (f :+: g) where 180 | mkPrismList' f' g' = f f' g' :& g f' g' 181 | where 182 | f :: forall a p q. ((f :+: g) p -> a) -> (a -> Maybe ((f :+: g) q)) -> PrismList f a 183 | f _f' _g' = mkPrismList' (\fp -> _f' (L1 fp)) (matchL _g') 184 | g :: forall a p q. ((f :+: g) p -> a) -> (a -> Maybe ((f :+: g) q)) -> PrismList g a 185 | g _f' _g' = mkPrismList' (\gp -> _f' (R1 gp)) (matchR _g') 186 | 187 | matchL :: (a -> Maybe ((f :+: g) q)) -> a -> Maybe (f q) 188 | matchL _g' a = case _g' a of 189 | Just (L1 f'') -> Just f'' 190 | _ -> Nothing 191 | 192 | matchR :: (a -> Maybe ((f :+: g) q)) -> a -> Maybe (g q) 193 | matchR _g' a = case _g' a of 194 | Just (R1 g'') -> Just g'' 195 | _ -> Nothing 196 | 197 | data instance PrismList (M1 C c f) a = P (forall t. StackPrism (StackPrismLhs f t) (a :- t)) 198 | 199 | instance MkStackPrism f => MkPrismList (M1 C c f) where 200 | mkPrismList' f' g' = P (stackPrism (f f') (g g')) 201 | where 202 | f :: forall a p t. (M1 C c f p -> a) -> StackPrismLhs f t -> a :- t 203 | f _f' lhs = mapHead (_f' . M1) (mkR lhs) 204 | g :: forall a p t. (a -> Maybe (M1 C c f p)) -> (a :- t) -> Maybe (StackPrismLhs f t) 205 | g _g' (a :- t) = fmap (mkL . (:- t) . unM1) (_g' a) 206 | 207 | -- Deriving types and conversions for single constructors 208 | 209 | type family StackPrismLhs (f :: Type -> Type) (t :: Type) :: Type 210 | 211 | class MkStackPrism (f :: Type -> Type) where 212 | mkR :: forall p t. StackPrismLhs f t -> (f p :- t) 213 | mkL :: forall p t. (f p :- t) -> StackPrismLhs f t 214 | 215 | type instance StackPrismLhs U1 t = t 216 | instance MkStackPrism U1 where 217 | mkR t = U1 :- t 218 | mkL (U1 :- t) = t 219 | 220 | type instance StackPrismLhs (K1 i a) t = a :- t 221 | instance MkStackPrism (K1 i a) where 222 | mkR (h :- t) = K1 h :- t 223 | mkL (K1 h :- t) = h :- t 224 | 225 | type instance StackPrismLhs (M1 i c f) t = StackPrismLhs f t 226 | instance MkStackPrism f => MkStackPrism (M1 i c f) where 227 | mkR = mapHead M1 . mkR 228 | mkL = mkL . mapHead unM1 229 | 230 | type instance StackPrismLhs (f :*: g) t = StackPrismLhs g (StackPrismLhs f t) 231 | instance (MkStackPrism f, MkStackPrism g) => MkStackPrism (f :*: g) where 232 | mkR t = (hg :*: hf) :- tg 233 | where 234 | hf :- tf = mkR t 235 | hg :- tg = mkR tf 236 | mkL ((hf :*: hg) :- t) = mkL (hg :- mkL (hf :- t)) 237 | 238 | mapHead :: (a -> b) -> (a :- t) -> (b :- t) 239 | mapHead f (h :- t) = f h :- t 240 | -------------------------------------------------------------------------------- /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'cabal.project' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250330 12 | # 13 | # REGENDATA ("0.19.20250330",["github","cabal.project"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-24.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.12.2 32 | compilerKind: ghc 33 | compilerVersion: 9.12.2 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.10.1 37 | compilerKind: ghc 38 | compilerVersion: 9.10.1 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.8.4 42 | compilerKind: ghc 43 | compilerVersion: 9.8.4 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.6.6 47 | compilerKind: ghc 48 | compilerVersion: 9.6.6 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-9.4.8 52 | compilerKind: ghc 53 | compilerVersion: 9.4.8 54 | setup-method: ghcup 55 | allow-failure: false 56 | - compiler: ghc-9.2.8 57 | compilerKind: ghc 58 | compilerVersion: 9.2.8 59 | setup-method: ghcup 60 | allow-failure: false 61 | - compiler: ghc-9.0.2 62 | compilerKind: ghc 63 | compilerVersion: 9.0.2 64 | setup-method: ghcup 65 | allow-failure: false 66 | - compiler: ghc-8.10.7 67 | compilerKind: ghc 68 | compilerVersion: 8.10.7 69 | setup-method: ghcup 70 | allow-failure: false 71 | fail-fast: false 72 | steps: 73 | - name: apt-get install 74 | run: | 75 | apt-get update 76 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 77 | - name: Install GHCup 78 | run: | 79 | mkdir -p "$HOME/.ghcup/bin" 80 | curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup" 81 | chmod a+x "$HOME/.ghcup/bin/ghcup" 82 | - name: Install cabal-install 83 | run: | 84 | "$HOME/.ghcup/bin/ghcup" install cabal 3.14.1.1-p1 || (cat "$HOME"/.ghcup/logs/*.* && false) 85 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.1.1-p1 -vnormal+nowrap" >> "$GITHUB_ENV" 86 | - name: Install GHC (GHCup) 87 | if: matrix.setup-method == 'ghcup' 88 | run: | 89 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 90 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 91 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 92 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 93 | echo "HC=$HC" >> "$GITHUB_ENV" 94 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 95 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 96 | env: 97 | HCKIND: ${{ matrix.compilerKind }} 98 | HCNAME: ${{ matrix.compiler }} 99 | HCVER: ${{ matrix.compilerVersion }} 100 | - name: Set PATH and environment variables 101 | run: | 102 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 103 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 104 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 105 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 106 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 107 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 108 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 109 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 110 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 111 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 112 | env: 113 | HCKIND: ${{ matrix.compilerKind }} 114 | HCNAME: ${{ matrix.compiler }} 115 | HCVER: ${{ matrix.compilerVersion }} 116 | - name: env 117 | run: | 118 | env 119 | - name: write cabal config 120 | run: | 121 | mkdir -p $CABAL_DIR 122 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 155 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 156 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 157 | rm -f cabal-plan.xz 158 | chmod a+x $HOME/.cabal/bin/cabal-plan 159 | cabal-plan --version 160 | - name: checkout 161 | uses: actions/checkout@v4 162 | with: 163 | path: source 164 | - name: initial cabal.project for sdist 165 | run: | 166 | touch cabal.project 167 | echo "packages: $GITHUB_WORKSPACE/source/invertible-grammar" >> cabal.project 168 | echo "packages: $GITHUB_WORKSPACE/source/sexp-grammar" >> cabal.project 169 | cat cabal.project 170 | - name: sdist 171 | run: | 172 | mkdir -p sdist 173 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 174 | - name: unpack 175 | run: | 176 | mkdir -p unpacked 177 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 178 | - name: generate cabal.project 179 | run: | 180 | PKGDIR_invertible_grammar="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/invertible-grammar-[0-9.]*')" 181 | echo "PKGDIR_invertible_grammar=${PKGDIR_invertible_grammar}" >> "$GITHUB_ENV" 182 | PKGDIR_sexp_grammar="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/sexp-grammar-[0-9.]*')" 183 | echo "PKGDIR_sexp_grammar=${PKGDIR_sexp_grammar}" >> "$GITHUB_ENV" 184 | rm -f cabal.project cabal.project.local 185 | touch cabal.project 186 | touch cabal.project.local 187 | echo "packages: ${PKGDIR_invertible_grammar}" >> cabal.project 188 | echo "packages: ${PKGDIR_sexp_grammar}" >> cabal.project 189 | echo "package invertible-grammar" >> cabal.project 190 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 191 | echo "package sexp-grammar" >> cabal.project 192 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 193 | cat >> cabal.project <> cabal.project.local 196 | cat cabal.project 197 | cat cabal.project.local 198 | - name: dump install plan 199 | run: | 200 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 201 | cabal-plan 202 | - name: restore cache 203 | uses: actions/cache/restore@v4 204 | with: 205 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 206 | path: ~/.cabal/store 207 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 208 | - name: install dependencies 209 | run: | 210 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 211 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 212 | - name: build w/o tests 213 | run: | 214 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 215 | - name: build 216 | run: | 217 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 218 | - name: tests 219 | run: | 220 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 221 | - name: cabal check 222 | run: | 223 | cd ${PKGDIR_invertible_grammar} || false 224 | ${CABAL} -vnormal check 225 | cd ${PKGDIR_sexp_grammar} || false 226 | ${CABAL} -vnormal check 227 | - name: haddock 228 | run: | 229 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 230 | - name: unconstrained build 231 | run: | 232 | rm -f cabal.project.local 233 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 234 | - name: save cache 235 | if: always() 236 | uses: actions/cache/save@v4 237 | with: 238 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 239 | path: ~/.cabal/store 240 | -------------------------------------------------------------------------------- /sexp-grammar/src/Language/SexpGrammar/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE Trustworthy #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | module Language.SexpGrammar.Base 8 | ( position 9 | -- * Atoms 10 | , real 11 | , double 12 | , int 13 | , integer 14 | , string 15 | , symbol 16 | , keyword 17 | , sym 18 | , kwd 19 | -- * Lists 20 | , List 21 | , list 22 | , bracketList 23 | , braceList 24 | , el 25 | , rest 26 | -- * Property lists 27 | , PropertyList 28 | , props 29 | , key 30 | , optKey 31 | , (.:) 32 | , (.:?) 33 | , restKeys 34 | -- * Quotes, antiquotes, etc 35 | , Prefix (..) 36 | , prefixed 37 | , quoted 38 | , hashed 39 | ) where 40 | 41 | import Control.Category ((>>>)) 42 | 43 | import Data.Coerce 44 | import Data.InvertibleGrammar 45 | import Data.InvertibleGrammar.Base 46 | import Data.Scientific 47 | import Data.Text (Text) 48 | import qualified Data.Text as TS 49 | import qualified Data.Text.Lazy as TL 50 | import qualified Data.Text.Lazy.Encoding as TL 51 | 52 | import Language.Sexp.Located 53 | 54 | -- Setup code for doctest. 55 | -- $setup 56 | -- >>> :set -XOverloadedStrings 57 | -- >>> import Language.SexpGrammar (encodeWith) 58 | 59 | ---------------------------------------------------------------------- 60 | 61 | ppBrief :: Sexp -> Text 62 | ppBrief = TL.toStrict . \case 63 | atom@Atom{} -> 64 | TL.decodeUtf8 (encode atom) 65 | other -> 66 | let pp = TL.decodeUtf8 (encode other) 67 | in if TL.length pp > 25 68 | then TL.take 25 pp <> "..." 69 | else pp 70 | 71 | ppKey :: Text -> Text 72 | ppKey kw = "keyword :" <> kw 73 | 74 | ---------------------------------------------------------------------- 75 | 76 | -- | Key\/value pairs of a property list that is being parsed/constructed. 77 | newtype PropertyList = PropertyList [(Text, Sexp)] 78 | 79 | -- | Elements of a list that is being parsed/constructed. 80 | newtype List = List [Sexp] 81 | 82 | ---------------------------------------------------------------------- 83 | 84 | -- | Extract\/inject a position from\/to a 'Sexp'. 85 | position :: Grammar Position (Sexp :- t) (Position :- Sexp :- t) 86 | position = Iso 87 | (\(s@(Fix (Compose (p :< _))) :- t) -> p :- s :- t) 88 | (\(p :- Fix (Compose (_ :< s)) :- t) -> Fix (Compose (p :< s)) :- t) 89 | 90 | 91 | locate :: Grammar Position (Sexp :- t) (Sexp :- t) 92 | locate = 93 | position >>> 94 | onHead Locate >>> 95 | Iso (\(_ :- t) -> t) (\t -> dummyPos :- t) 96 | 97 | 98 | atom :: Grammar Position (Sexp :- t) (Atom :- t) 99 | atom = locate >>> partialOsi 100 | (\case 101 | Atom a -> Right a 102 | other -> Left (expected "atom" <> unexpected (ppBrief other))) 103 | Atom 104 | 105 | 106 | beginParenList :: Grammar Position (Sexp :- t) (List :- t) 107 | beginParenList = locate >>> partialOsi 108 | (\case 109 | ParenList a -> Right (List a) 110 | other -> Left (expected "list" <> unexpected (ppBrief other))) 111 | (ParenList . coerce) 112 | 113 | 114 | beginBracketList :: Grammar Position (Sexp :- t) (List :- t) 115 | beginBracketList = locate >>> partialOsi 116 | (\case 117 | BracketList a -> Right (List a) 118 | other -> Left (expected "bracket list" <> unexpected (ppBrief other))) 119 | (BracketList . coerce) 120 | 121 | 122 | beginBraceList :: Grammar Position (Sexp :- t) (List :- t) 123 | beginBraceList = locate >>> partialOsi 124 | (\case 125 | BraceList a -> Right (List a) 126 | other -> Left (expected "brace list" <> unexpected (ppBrief other))) 127 | (BraceList . coerce) 128 | 129 | 130 | endList :: Grammar Position (List :- t) t 131 | endList = Flip $ PartialIso 132 | (\t -> List [] :- t) 133 | (\(List lst :- t) -> 134 | case lst of 135 | [] -> Right t 136 | (el:_rest) -> Left (unexpected (ppBrief el))) 137 | 138 | 139 | -- | Parenthesis list grammar. Runs a specified grammar on a 140 | -- sequence of S-exps in a parenthesized list. 141 | -- 142 | -- >>> let grammar = list (el symbol >>> el int) >>> pair 143 | -- >>> encodeWith grammar ("foo", 42) 144 | -- Right "(foo 42)" 145 | list :: Grammar Position (List :- t) (List :- t') -> Grammar Position (Sexp :- t) t' 146 | list g = beginParenList >>> Dive (g >>> endList) 147 | 148 | 149 | -- | Bracket list grammar. Runs a specified grammar on a 150 | -- sequence of S-exps in a bracketed list. 151 | -- 152 | -- >>> let grammar = bracketList (rest int) 153 | -- >>> encodeWith grammar [2, 3, 5, 7, 11, 13] 154 | -- Right "[2 3 5 7 11 13]" 155 | bracketList :: Grammar Position (List :- t) (List :- t') -> Grammar Position (Sexp :- t) t' 156 | bracketList g = beginBracketList >>> Dive (g >>> endList) 157 | 158 | 159 | -- | Brace list grammar. Runs a specified grammar on a 160 | -- sequence of S-exps in a list enclosed in braces. 161 | -- 162 | -- >>> let grammar = braceList (props (key "x" real >>> key "y" real)) >>> pair 163 | -- >>> encodeWith grammar (3.1415, -1) 164 | -- Right "{:x 3.1415 :y -1}" 165 | braceList :: Grammar Position (List :- t) (List :- t') -> Grammar Position (Sexp :- t) t' 166 | braceList g = beginBraceList >>> Dive (g >>> endList) 167 | 168 | ---------------------------------------------------------------------- 169 | 170 | -- | Element of a sequence grammar. Runs a specified grammar on a next 171 | -- element of a sequence. The underlying grammar can produce zero or 172 | -- more values on the stack. 173 | -- 174 | -- E.g.: 175 | -- 176 | -- * @el (sym "lambda")@ consumes a symbol \"lambda\" and produces no 177 | -- values on the stack. 178 | -- 179 | -- * @el symbol@ consumes a symbol and produces a 'Text' value 180 | -- corresponding to the symbol. 181 | el :: Grammar Position (Sexp :- t) t' -> Grammar Position (List :- t) (List :- t') 182 | el g = coerced (Flip cons >>> onTail g >>> Step) 183 | 184 | 185 | -- | The rest of a sequence grammar. Runs a specified grammar on each 186 | -- of remaining elements of a sequence and collect them. Expects zero 187 | -- or more elements in the sequence. 188 | -- 189 | -- >>> let grammar = list (el (sym "check-primes") >>> rest int) 190 | -- >>> encodeWith grammar [2, 3, 5, 7, 11, 13] 191 | -- Right "(check-primes 2 3 5 7 11 13)" 192 | rest 193 | :: (forall t. Grammar Position (Sexp :- t) (a :- t)) 194 | -> Grammar Position (List :- t) (List :- [a] :- t) 195 | rest g = 196 | iso coerce coerce >>> 197 | onHead (Traverse (sealed g >>> Step)) >>> 198 | Iso (\a -> List [] :- a) (\(_ :- a) -> a) 199 | 200 | ---------------------------------------------------------------------- 201 | 202 | beginProperties 203 | :: Grammar Position (List :- t) (List :- PropertyList :- t) 204 | beginProperties = Flip $ PartialIso 205 | (\(List rest :- PropertyList alist :- t) -> 206 | List (concatMap (\(k, v) -> [Atom (AtomSymbol (':' `TS.cons` k)), v]) alist ++ rest) :- t) 207 | (\(List lst :- t) -> 208 | let (rest, alist) = takePairs lst [] in 209 | Right (List rest :- PropertyList (reverse alist) :- t)) 210 | where 211 | takePairs :: [Sexp] -> [(Text, Sexp)] -> ([Sexp], [(Text, Sexp)]) 212 | takePairs (Atom (AtomSymbol k) : v : rest) acc = 213 | case TS.uncons k of 214 | Just (':', k') -> takePairs rest ((k', v) : acc) 215 | _ -> (Atom (AtomSymbol k) : v : rest, acc) 216 | takePairs other acc = (other, acc) 217 | 218 | 219 | endProperties 220 | :: Grammar Position t (PropertyList :- t) 221 | endProperties = PartialIso 222 | (\t -> PropertyList [] :- t) 223 | (\(PropertyList lst :- t) -> 224 | case lst of 225 | [] -> Right t 226 | ((k, _) : _rest) -> Left (unexpected (ppKey k))) 227 | 228 | 229 | -- | Property list in a sequence grammar. Collects pairs of keywords 230 | -- and S-expressions from remaining sequence elements and runs a 231 | -- specified grammar on them. Expects zero or more pairs in the 232 | -- sequence. If sequence of pairs interrupts with a non-keyword, the 233 | -- rest of this sequence is left untouched. 234 | -- 235 | -- Collected 'PropertyList' is then available for random-access lookup 236 | -- combinators 'key', 'optKey', '.:', '.:?' or bulk extraction 237 | -- 'restKeys' combinator. 238 | -- 239 | -- >>> :{ 240 | -- let grammar = braceList ( 241 | -- props (key "real" real >>> key "img" real) >>> onTail pair >>> el (sym "/") >>> 242 | -- props (key "real" real >>> key "img" real) >>> onTail pair) >>> pair 243 | -- in encodeWith grammar ((0, -1), (1, 0)) 244 | -- :} 245 | -- Right "{:real 0 :img -1 / :real 1 :img 0}" 246 | props 247 | :: Grammar Position (PropertyList :- t) (PropertyList :- t') 248 | -> Grammar Position (List :- t) (List :- t') 249 | props g = beginProperties >>> Dive (onTail (g >>> Flip endProperties)) 250 | 251 | 252 | -- | Property by a key grammar. Looks up an S-expression by a 253 | -- specified key and runs a specified grammar on it. Expects the key 254 | -- to be present. 255 | -- 256 | -- Note: performs linear lookup, /O(n)/ 257 | key 258 | :: Text 259 | -> (forall t. Grammar Position (Sexp :- t) (a :- t)) 260 | -> Grammar Position (PropertyList :- t) (PropertyList :- a :- t) 261 | key k g = 262 | coerced ( 263 | Flip (insert k (expected $ ppKey k)) >>> 264 | Step >>> 265 | onHead (sealed g) >>> 266 | swap) 267 | 268 | 269 | -- | Optional property by a key grammar. Like 'key' but puts 'Nothing' 270 | -- in correspondence to the missing key and 'Just' to the present. 271 | -- 272 | -- Note: performs linear lookup, /O(n)/ 273 | optKey 274 | :: Text 275 | -> (forall t. Grammar Position (Sexp :- t) (a :- t)) 276 | -> Grammar Position (PropertyList :- t) (PropertyList :- Maybe a :- t) 277 | optKey k g = 278 | coerced (Flip (insertMay k) >>> 279 | Step >>> 280 | onHead (Traverse (sealed g)) >>> 281 | swap) 282 | 283 | infix 3 .: 284 | infix 3 .:? 285 | 286 | 287 | -- | Property by a key grammar. Infix version of 'key'. 288 | (.:) 289 | :: Text 290 | -> (forall t. Grammar Position (Sexp :- t) (a :- t)) 291 | -> Grammar Position (PropertyList :- t) (PropertyList :- a :- t) 292 | (.:) = key 293 | 294 | 295 | -- | Optional property by a key grammar. Infix version of 'optKey'. 296 | (.:?) 297 | :: Text 298 | -> (forall t. Grammar Position (Sexp :- t) (a :- t)) 299 | -> Grammar Position (PropertyList :- t) (PropertyList :- Maybe a :- t) 300 | (.:?) = optKey 301 | 302 | 303 | -- | Remaining properties grammar. Extracts all key-value pairs and 304 | -- applies a grammar on every element. 305 | restKeys 306 | :: (forall t. Grammar Position (Sexp :- Text :- t) (a :- t)) 307 | -> Grammar Position (PropertyList :- t) (PropertyList :- [a] :- t) 308 | restKeys f = 309 | iso coerce coerce >>> 310 | onHead (Traverse (sealed (Flip pair >>> f) >>> Step)) >>> 311 | Iso (\a -> PropertyList [] :- a) (\(_ :- a) -> a) 312 | 313 | 314 | ---------------------------------------------------------------------- 315 | -- Atoms 316 | 317 | -- | Grammar matching integer number atoms to 'Integer' values. 318 | -- 319 | -- >>> encodeWith integer (2^100) 320 | -- Right "1267650600228229401496703205376" 321 | integer :: Grammar Position (Sexp :- t) (Integer :- t) 322 | integer = atom >>> partialOsi 323 | (\case 324 | AtomNumber n | Right i <- (floatingOrInteger n :: Either Double Integer) -> Right i 325 | other -> Left (expected "integer" <> unexpected (ppBrief $ Atom other))) 326 | (AtomNumber . fromIntegral) 327 | 328 | 329 | -- | Grammar matching integer number atoms to 'Int' values. 330 | -- 331 | -- >>> encodeWith int (2^63) 332 | -- Right "-9223372036854775808" 333 | -- 334 | -- >>> encodeWith int (2^63-1) 335 | -- Right "9223372036854775807" 336 | int :: Grammar Position (Sexp :- t) (Int :- t) 337 | int = integer >>> iso fromIntegral fromIntegral 338 | 339 | 340 | -- | Grammar matching fractional number atoms to 'Scientific' values. 341 | -- 342 | -- >>> encodeWith real (3.141592653589793^3) 343 | -- Right "31.006276680299813114880451174049119330924860257" 344 | real :: Grammar Position (Sexp :- t) (Scientific :- t) 345 | real = atom >>> partialOsi 346 | (\case 347 | AtomNumber r -> Right r 348 | other -> Left (expected "real" <> unexpected (ppBrief $ Atom other))) 349 | AtomNumber 350 | 351 | 352 | -- | Grammar matching fractional number atoms to 'Double' values. 353 | -- 354 | -- >>> encodeWith double (3.141592653589793^3) 355 | -- Right "31.006276680299816" 356 | double :: Grammar Position (Sexp :- t) (Double :- t) 357 | double = real >>> iso toRealFloat fromFloatDigits 358 | 359 | 360 | -- | Grammar matching string literal atoms to 'Text' values. 361 | -- 362 | -- >>> let grammar = list (el string >>> el int) >>> pair 363 | -- >>> encodeWith grammar ("some-string", 42) 364 | -- Right "(\"some-string\" 42)" 365 | string :: Grammar Position (Sexp :- t) (Text :- t) 366 | string = atom >>> partialOsi 367 | (\case 368 | AtomString s -> Right s 369 | other -> Left (expected "string" <> unexpected (ppBrief $ Atom other))) 370 | AtomString 371 | 372 | 373 | -- | Grammar matching symbol literal atoms to 'Text' values. 374 | -- 375 | -- >>> encodeWith symbol "some-symbol" 376 | -- Right "some-symbol" 377 | symbol :: Grammar Position (Sexp :- t) (Text :- t) 378 | symbol = atom >>> partialOsi 379 | (\case 380 | AtomSymbol s -> Right s 381 | other -> Left (expected "symbol" <> unexpected (ppBrief $ Atom other))) 382 | AtomSymbol 383 | 384 | 385 | -- | Grammar matching symbol literal atoms starting with \':\' to 386 | -- 'Text' values without the colon char. 387 | -- 388 | -- >>> encodeWith keyword "username" 389 | -- Right ":username" 390 | keyword :: Grammar Position (Sexp :- t) (Text :- t) 391 | keyword = atom >>> partialOsi 392 | (\case 393 | AtomSymbol s | Just (':', k) <- TS.uncons s -> Right k 394 | other -> Left (expected "keyword" <> 395 | unexpected (ppBrief $ Atom other))) 396 | (AtomSymbol . TS.cons ':') 397 | 398 | 399 | -- | Grammar matching symbol literal atoms to a specified symbol. 400 | -- 401 | -- >>> let grammar = list (el (sym "username") >>> el string) 402 | -- >>> encodeWith grammar "Julius Caesar" 403 | -- Right "(username \"Julius Caesar\")" 404 | sym :: Text -> Grammar Position (Sexp :- t) t 405 | sym s = atom >>> Flip (PartialIso 406 | (AtomSymbol s :-) 407 | (\(a :- t) -> 408 | case a of 409 | AtomSymbol s' | s == s' -> Right t 410 | other -> Left $ expected ("symbol " <> s) <> 411 | unexpected (ppBrief $ Atom other))) 412 | 413 | 414 | -- | Grammar matching symbol literal atoms to a specified symbol 415 | -- prepended with \':\'. 416 | -- 417 | -- >>> let grammar = list (el (kwd "password") >>> el int) 418 | -- >>> encodeWith grammar 42 419 | -- Right "(:password 42)" 420 | kwd :: Text -> Grammar Position (Sexp :- t) t 421 | kwd s = 422 | let k = TS.cons ':' s 423 | in atom >>> Flip (PartialIso 424 | (AtomSymbol k :-) 425 | (\(a :- t) -> 426 | case a of 427 | AtomSymbol s' | k == s' -> Right t 428 | other -> Left $ expected (ppKey s) <> unexpected (ppBrief $ Atom other))) 429 | 430 | 431 | prefix :: Prefix -> Grammar Position (Sexp :- t) (Sexp :- t) 432 | prefix m = locate >>> partialOsi 433 | (\case 434 | Modified m' a | m' == m -> Right a 435 | other -> Left (expected (ppBrief (Modified m (Symbol "-prefixed"))) <> unexpected (ppBrief other))) 436 | (Modified m) 437 | 438 | -- | Grammar matching a prefixed S-expression, runs a sub-grammar on a 439 | -- @Sexp@ under the hash prefix. 440 | -- 441 | -- >>> encodeWith (hashed symbol) "foo" 442 | -- Right "#foo" 443 | hashed :: Grammar Position (Sexp :- t) t' -> Grammar Position (Sexp :- t) t' 444 | hashed g = prefix Hash >>> g 445 | 446 | -- | Grammar matching a prefixed S-expression, runs a sub-grammar on a 447 | -- @Sexp@ under the quotation. 448 | -- 449 | -- >>> encodeWith (quoted symbol) "foo" 450 | -- Right "'foo" 451 | quoted :: Grammar Position (Sexp :- t) t' -> Grammar Position (Sexp :- t) t' 452 | quoted g = prefix Quote >>> g 453 | 454 | 455 | -- | Grammar matching a prefixed S-expression, runs a sub-grammar on a 456 | -- @Sexp@ under the prefix. 457 | -- 458 | -- >>> encodeWith (prefixed Backtick symbol) "foo" 459 | -- Right "`foo" 460 | prefixed :: Prefix -> Grammar Position (Sexp :- t) t' -> Grammar Position (Sexp :- t) t' 461 | prefixed m g = prefix m >>> g 462 | -------------------------------------------------------------------------------- /sexp-grammar/test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedLists #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE PatternSynonyms #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE TypeSynonymInstances #-} 13 | 14 | {-# OPTIONS_GHC -fno-warn-orphans #-} 15 | 16 | module Main (main) where 17 | 18 | import Prelude hiding ((.), id) 19 | 20 | import Control.Category 21 | import qualified Data.ByteString.Lazy.Char8 as B8 22 | import Data.Char 23 | import Data.Scientific 24 | import Data.Semigroup 25 | import qualified Data.Set as S 26 | import qualified Data.Text as TS 27 | import Data.Text.Encoding (encodeUtf8) 28 | 29 | import Prettyprinter (Pretty, pretty) 30 | 31 | import GHC.Generics 32 | import Test.QuickCheck () 33 | import Test.Tasty 34 | import Test.Tasty.HUnit 35 | import Test.Tasty.QuickCheck as QC 36 | 37 | import Language.Sexp.Located as Sexp 38 | import Language.Sexp () -- for Show instance 39 | 40 | import Data.InvertibleGrammar (ErrorMessage(..), runGrammar, forward, backward) 41 | 42 | import Language.SexpGrammar as G 43 | import Language.SexpGrammar.Generic 44 | import Language.SexpGrammar.TH hiding (match) 45 | 46 | import Debug.Trace 47 | 48 | parseSexp' :: TS.Text -> Either String Sexp 49 | parseSexp' input = Sexp.decode (B8.fromStrict (encodeUtf8 input)) 50 | 51 | instance Arbitrary Atom where 52 | arbitrary = oneof 53 | [ AtomNumber . fromFloatDigits <$> (arbitrary :: Gen Double) 54 | , AtomNumber . fromIntegral <$> (arbitrary :: Gen Integer) 55 | , AtomString . TS.pack <$> listOf 56 | (oneof [ elements $ ['\n','\r','\t','"','\\', ' '] 57 | , arbitrary `suchThat` (\c -> isAlphaNum c || isPunctuation c) 58 | ]) 59 | , AtomSymbol . TS.pack <$> 60 | listOf (arbitrary `suchThat` (\c -> isAlphaNum c || c `elem` ("#',`\\:@!$%&*/<=>?~_^.|+-" :: [Char]))) 61 | `suchThat` isValidSymbol 62 | , pure (AtomSymbol ":foo") 63 | , pure (AtomSymbol "1e2") 64 | , pure (AtomSymbol "-1e2") 65 | , pure (AtomSymbol "1.0e-2") 66 | , pure (AtomSymbol "+.0E-2") 67 | , pure (AtomSymbol "bar") 68 | , pure (AtomSymbol "~qux") 69 | , pure (AtomSymbol "символ") 70 | , pure (AtomSymbol "@baz") 71 | ] 72 | where 73 | isValidSymbol = \case 74 | [] -> False 75 | p : _ | p `elem` ("#',`" :: String) -> False 76 | '+' : str -> not (isANumber str) 77 | str -> not (isANumber str) 78 | 79 | isANumber s = 80 | case reads s of 81 | [(_ :: Double, [])] -> True 82 | _ -> False 83 | 84 | instance Arbitrary Prefix where 85 | arbitrary = elements 86 | [ Quote 87 | , Backtick 88 | , Comma 89 | , CommaAt 90 | , Hash 91 | ] 92 | 93 | instance Arbitrary Sexp where 94 | arbitrary = 95 | frequency 96 | [ (3, Atom <$> arbitrary) 97 | , (1, ParenList <$> scale (`div` 2) (listOf arbitrary)) 98 | , (1, BracketList <$> scale (`div` 2) (listOf arbitrary)) 99 | , (1, BraceList <$> scale (`div` 2) (listOf arbitrary)) 100 | , (1, Modified <$> arbitrary <*> (arbitrary `suchThat` (\case {Symbol s -> not ("@" `TS.isPrefixOf` s); _other -> True}))) 101 | ] 102 | shrink = \case 103 | Atom a -> map Atom (shrink a) 104 | ParenList [x] -> shrink x 105 | ParenList xs -> map ParenList (shrinkList shrink xs) 106 | BracketList [x] -> shrink x 107 | BracketList xs -> map BracketList (shrinkList shrink xs) 108 | BraceList [x] -> shrink x 109 | BraceList xs -> map BraceList (shrinkList shrink xs) 110 | Modified m s -> shrink s ++ s : Modified m (Symbol "foo") : map (Modified m) (shrink s) 111 | other -> [other] 112 | 113 | 114 | fromSexp' :: SexpGrammar a -> Sexp.Sexp -> Either (ErrorMessage Position) a 115 | fromSexp' g = runGrammar Sexp.dummyPos . forward (G.sealed g) 116 | 117 | toSexp' :: SexpGrammar a -> a -> Either (ErrorMessage Position) Sexp.Sexp 118 | toSexp' g = runGrammar Sexp.dummyPos . backward (G.sealed g) 119 | 120 | data Pair a b = Pair a b 121 | deriving (Show, Eq, Ord, Generic) 122 | 123 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Pair a b) where 124 | arbitrary = Pair <$> arbitrary <*> arbitrary 125 | 126 | data Foo a b 127 | = Bar a b 128 | | Baz a b 129 | deriving (Show, Eq, Ord, Generic) 130 | 131 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Foo a b) where 132 | arbitrary = 133 | frequency 134 | [ (1, Bar <$> arbitrary <*> arbitrary) 135 | , (1, Baz <$> arbitrary <*> arbitrary) 136 | ] 137 | 138 | data ArithExpr = 139 | Lit Int 140 | | Add ArithExpr ArithExpr -- ^ (+ x y) 141 | | Mul [ArithExpr] -- ^ (* x1 ... xN) 142 | deriving (Show, Eq, Ord, Generic) 143 | 144 | return [] 145 | 146 | string' :: Grammar Position (Sexp :- t) (String :- t) 147 | string' = string >>> iso TS.unpack TS.pack 148 | 149 | instance Arbitrary ArithExpr where 150 | arbitrary = frequency 151 | [ (5, Lit <$> arbitrary) 152 | , (1, Add <$> arbitrary <*> arbitrary) 153 | , (1, do 154 | n <- choose (0, 7) 155 | Mul <$> vectorOf n arbitrary) 156 | ] 157 | 158 | instance (SexpIso a, SexpIso b) => SexpIso (Pair a b) where 159 | sexpIso = $(grammarFor 'Pair) . list (el sexpIso >>> el sexpIso) 160 | 161 | pairGenericIso 162 | :: (forall t. Grammar Position (Sexp :- t) (a :- t)) 163 | -> (forall t. Grammar Position (Sexp :- t) (b :- t)) -> Grammar Position (Sexp :- t) (Pair a b :- t) 164 | pairGenericIso a b = with (\pair -> pair . list (el a >>> el b)) 165 | 166 | instance (SexpIso a, SexpIso b) => SexpIso (Foo a b) where 167 | sexpIso = sconcat 168 | [ $(grammarFor 'Bar) . list (el (sym "bar") >>> el sexpIso >>> el sexpIso) 169 | , $(grammarFor 'Baz) . list (el (sym "baz") >>> el sexpIso >>> el sexpIso) 170 | ] 171 | 172 | fooGenericIso 173 | :: (forall t. Grammar Position (Sexp :- t) (a :- t)) 174 | -> (forall t. Grammar Position (Sexp :- t) (b :- t)) -> Grammar Position (Sexp :- t) (Foo a b :- t) 175 | fooGenericIso a b = match 176 | $ With (\bar -> bar . list (el (sym "bar") >>> el a >>> el b)) 177 | $ With (\baz -> baz . list (el (sym "baz") >>> el a >>> el b)) 178 | $ End 179 | 180 | 181 | arithExprTHIso :: Grammar Position (Sexp :- t) (ArithExpr :- t) 182 | arithExprTHIso = 183 | sconcat 184 | [ $(grammarFor 'Lit) . int 185 | , $(grammarFor 'Add) . list (el (sym "+") >>> el arithExprTHIso >>> el arithExprTHIso) 186 | , $(grammarFor 'Mul) . list (el (sym "*") >>> rest arithExprTHIso) 187 | ] 188 | 189 | arithExprGenericIso :: Grammar Position (Sexp :- t) (ArithExpr :- t) 190 | arithExprGenericIso = expr 191 | where 192 | expr :: Grammar Position (Sexp :- t) (ArithExpr :- t) 193 | expr = match 194 | $ With (\lit -> lit . int) 195 | $ With (\add -> add . list (el (sym "+") >>> el expr >>> el expr)) 196 | $ With (\mul -> mul . list (el (sym "*") >>> rest expr)) 197 | $ End 198 | 199 | data Person = Person 200 | { _pName :: String 201 | , _pAge :: Int 202 | , _pAddress :: String 203 | , _pChildren :: [Person] 204 | } deriving (Show, Eq, Generic) 205 | 206 | 207 | instance Arbitrary Person where 208 | arbitrary = 209 | Person 210 | <$> arbitrary 211 | <*> arbitrary 212 | <*> arbitrary 213 | <*> frequency 214 | [ (6, pure []) 215 | , (4, vectorOf 1 arbitrary) 216 | , (2, vectorOf 2 arbitrary) 217 | , (1, vectorOf 3 arbitrary) 218 | ] 219 | 220 | personGenericIso :: Grammar Position (Sexp :- t) (Person :- t) 221 | personGenericIso = with 222 | (\person -> 223 | list ( 224 | el (sym "person") >>> 225 | el string' >>> 226 | props ( 227 | ":age" .: int >>> 228 | ":address" .: string') >>> 229 | rest personGenericIso) >>> person) 230 | 231 | 232 | ---------------------------------------------------------------------- 233 | -- Test cases 234 | 235 | allTests :: TestTree 236 | allTests = testGroup "All tests" 237 | [ lexerParserTests 238 | , QC.testProperty "Format/decode invertibility" prop_decodeFormattedEq 239 | , grammarTests 240 | ] 241 | 242 | sexpEq :: (Pretty e, Eq e) => Either e Sexp -> Either e Sexp -> Assertion 243 | sexpEq a b = 244 | fmap toSimple a `otherEq` fmap toSimple b 245 | 246 | otherEq :: (Pretty e, Eq e, Show a, Eq a) => Either e a -> Either e a -> Assertion 247 | otherEq a b = do 248 | (flip assertBool) (a == b) $ 249 | unlines 250 | ["Output mismatch:" 251 | , ppOutput a 252 | , "vs." 253 | , ppOutput b 254 | ] 255 | where 256 | ppOutput o = case o of 257 | Left err -> "Error message: " ++ show (pretty err) 258 | Right v -> "Output: " ++ show v 259 | 260 | lexerParserTests :: TestTree 261 | lexerParserTests = testGroup "Sexp lexer/parser tests" 262 | [ testCase "123 is an integer number" $ 263 | parseSexp' "123" 264 | `sexpEq` Right (Number 123) 265 | , testCase "+123 is an integer number" $ 266 | parseSexp' "+123" 267 | `sexpEq` Right (Number 123) 268 | , testCase "-123 is an integer number" $ 269 | parseSexp' "-123" 270 | `sexpEq` Right (Number (- 123)) 271 | , testCase "+123.45 is a floating point number" $ 272 | parseSexp' "+123.45" 273 | `sexpEq` Right (Number (read "123.45" :: Scientific)) 274 | , testCase "0_1 is a symbol" $ 275 | parseSexp' "0_1" 276 | `sexpEq` Right (Symbol "0_1") 277 | , testCase "1e2 is a symbol" $ 278 | parseSexp' "1e2" 279 | `sexpEq` Right (Symbol "1e2") 280 | , testCase "-1e2 is a symbol" $ 281 | parseSexp' "-1e2" 282 | `sexpEq` Right (Symbol "-1e2") 283 | , testCase "comments" $ 284 | parseSexp' ";; hello, world\n 123" 285 | `sexpEq` Right (Number 123) 286 | , testCase "cyrillic characters in comments" $ 287 | parseSexp' ";; Я в серці маю те, що не вмирає!\n SS17" 288 | `sexpEq` Right (Symbol "SS17") 289 | , testCase "unicode math in comments" $ 290 | parseSexp' ";; Γ σ ⊢ → ∘ ℕ ∑ ∏ ẽ ∀\nfoobar" 291 | `sexpEq` Right (Symbol "foobar") 292 | , testCase "hello-world is symbol" $ 293 | parseSexp' "hello-world" 294 | `sexpEq` Right (Symbol "hello-world") 295 | , testCase "\\forall is a symbol" $ 296 | parseSexp' "∀" 297 | `sexpEq` Right (Symbol "∀") 298 | , testCase "\\Bbb{N} is a symbol" $ 299 | parseSexp' "ℕ" 300 | `sexpEq` Right (Symbol "ℕ") 301 | , testCase "whitespace and symbol" $ 302 | parseSexp' "\t\n hello-world\n" 303 | `sexpEq` Right (Symbol "hello-world") 304 | , testCase "cyrillic characters symbol" $ 305 | parseSexp' "символ" 306 | `sexpEq` Right (Symbol "символ") 307 | , testCase "greek characters symbol" $ 308 | parseSexp' "αβγΠΣΩ" 309 | `sexpEq` Right (Symbol "αβγΠΣΩ") 310 | , testCase "special-characters \"\\:$%^&*,\" symbol" $ 311 | parseSexp' "\\:$%^&*," 312 | `sexpEq` Right (Symbol "\\:$%^&*,") 313 | , testCase "string with arabic characters" $ 314 | parseSexp' "\"ي الخاطفة الجديدة، مع, بلديهم\"" 315 | `sexpEq` Right (String "ي الخاطفة الجديدة، مع, بلديهم") 316 | , testCase "string with japanese characters" $ 317 | parseSexp' "\"媯綩 づ竤バ り姥娩ぎょひ\"" 318 | `sexpEq` Right (String "媯綩 づ竤バ り姥娩ぎょひ") 319 | , testCase "string with newline" $ 320 | parseSexp' "\"foo\nbar\"" 321 | `sexpEq` Right (String "foo\nbar") 322 | , testCase "string with \\n" $ 323 | parseSexp' "\"foo\\nbar\"" 324 | `sexpEq` Right (String "foo\nbar") 325 | , testCase "string with \\t" $ 326 | parseSexp' "\"foo\\tbar\"" 327 | `sexpEq` Right (String "foo\tbar") 328 | , testCase "string with \\\"" $ 329 | parseSexp' "\"foo\\\"bar\"" 330 | `sexpEq` Right (String "foo\"bar") 331 | , testCase "string with \\\\" $ 332 | parseSexp' "\"foo\\\\bar\"" 333 | `sexpEq` Right (String "foo\\bar") 334 | , testCase "paren-list" $ 335 | parseSexp' "(foo bar)" 336 | `sexpEq` Right (ParenList [Symbol "foo", Symbol "bar"]) 337 | , testCase "bracket-list" $ 338 | parseSexp' "[foo bar]" 339 | `sexpEq` Right (BracketList [Symbol "foo", Symbol "bar"]) 340 | , testCase "brace-list" $ 341 | parseSexp' "{foo bar}" 342 | `sexpEq` Right (BraceList [Symbol "foo", Symbol "bar"]) 343 | , testCase "quoted" $ 344 | parseSexp' "'foo" 345 | `sexpEq` Right (Modified Quote (Symbol "foo")) 346 | , testCase "hashed" $ 347 | parseSexp' "#foo" 348 | `sexpEq` Right (Modified Hash (Symbol "foo")) 349 | , testCase "keyword" $ 350 | parseSexp' ":foo" 351 | `sexpEq` Right (Symbol ":foo") 352 | , testCase "datum comment" $ 353 | parseSexp' "(three #;(not four) element list)" 354 | `sexpEq` Right (ParenList [Symbol "three", Symbol "element", Symbol "list"]) 355 | ] 356 | 357 | 358 | prop_decodeFormattedEq :: Sexp -> Bool 359 | prop_decodeFormattedEq a = 360 | case Sexp.decode (Sexp.format a) of 361 | Left _ -> trace "Cannot parse" False 362 | Right b -> 363 | let a' = toSimple a 364 | b' = toSimple b 365 | in if a' == b' then True else trace ("Mismatch: " ++ show a' ++ " /= " ++ show b') False 366 | 367 | 368 | grammarTests :: TestTree 369 | grammarTests = testGroup "Grammar tests" 370 | [ baseTypeTests 371 | , listTests 372 | , prefixTests 373 | , dictTests 374 | , revStackPrismTests 375 | , parseTests 376 | , genTests 377 | , parseGenTests 378 | ] 379 | 380 | 381 | baseTypeTests :: TestTree 382 | baseTypeTests = testGroup "Base type combinator tests" 383 | [ testCase "bool/true" $ 384 | fromSexp' sexpIso (Symbol "true") `otherEq` 385 | Right True 386 | 387 | , testCase "bool/false" $ 388 | fromSexp' sexpIso (Symbol "false") `otherEq` 389 | Right False 390 | 391 | , testCase "integer" $ 392 | fromSexp' integer (Number (42 ^ (42 :: Integer))) `otherEq` 393 | Right (42 ^ (42 :: Integer)) 394 | 395 | , testCase "int" $ 396 | fromSexp' int (Number 65536) `otherEq` 397 | Right 65536 398 | 399 | , testCase "real" $ 400 | fromSexp' real (Number 3.14) `otherEq` 401 | Right 3.14 402 | 403 | , testCase "double" $ 404 | fromSexp' double (Number 3.14) `otherEq` 405 | Right 3.14 406 | 407 | , testCase "string" $ 408 | fromSexp' string (String "foo\nbar baz") `otherEq` 409 | Right "foo\nbar baz" 410 | 411 | , testCase "string'" $ 412 | fromSexp' string' (String "foo\nbar baz") `otherEq` 413 | Right "foo\nbar baz" 414 | 415 | , testCase "symbol" $ 416 | fromSexp' symbol (Symbol "foobarbaz") `otherEq` 417 | Right "foobarbaz" 418 | ] 419 | 420 | 421 | listTests :: TestTree 422 | listTests = testGroup "List combinator tests" 423 | [ testCase "empty list of ints" $ 424 | fromSexp' 425 | (list (rest int)) 426 | (ParenList []) `otherEq` 427 | Right [] 428 | 429 | , testCase "list of strings" $ 430 | fromSexp' 431 | (list (rest string)) 432 | (ParenList [String "tt", String "ff", String "ff"]) `otherEq` 433 | Right ["tt", "ff", "ff"] 434 | 435 | , testCase "bracket list of ints" $ 436 | fromSexp' 437 | (bracketList (rest int)) 438 | (BracketList [Number 123, Number 0, Number (-100)]) `otherEq` 439 | Right [123, 0, -100] 440 | 441 | , testCase "brace list of strings" $ 442 | fromSexp' 443 | (braceList (rest string)) 444 | (BraceList [String "foo", String "bar"]) `otherEq` 445 | Right ["foo", "bar"] 446 | ] 447 | 448 | 449 | dictTests :: TestTree 450 | dictTests = testGroup "Dict combinator tests" 451 | [ testCase "simple dict, present key" $ 452 | fromSexp' 453 | (braceList (props (key "foo" int))) 454 | (BraceList [Symbol ":foo", Number 42]) `otherEq` 455 | Right 42 456 | 457 | , testCase "simple dict, missing key" $ 458 | fromSexp' 459 | (braceList (props (key "bar" int))) 460 | (BraceList [Symbol ":foo", Number 42]) `otherEq` 461 | (Left (ErrorMessage dummyPos [] (S.fromList ["keyword :bar"]) Nothing)) 462 | 463 | , testCase "simple dict, missing optional key" $ 464 | fromSexp' 465 | (braceList (props (optKey "bar" int))) 466 | (BraceList []) `otherEq` 467 | Right Nothing 468 | 469 | , testCase "simple dict, extra key" $ 470 | fromSexp' 471 | (braceList (props (key "foo" int))) 472 | (BraceList [Symbol ":foo", Number 42, Symbol ":bar", Number 0]) `otherEq` 473 | (Left (ErrorMessage dummyPos [] mempty (Just "keyword :bar"))) 474 | 475 | , testCase "simple dict, remaining keys, from" $ 476 | fromSexp' 477 | (braceList (props (restKeys (int >>> pair)))) 478 | (BraceList [Symbol ":foo", Number 42, Symbol ":bar", Number 0]) `otherEq` 479 | (Right [("foo", 42), ("bar", 0)]) 480 | 481 | , testCase "simple dict, remaining keys, to" $ 482 | toSexp' 483 | (braceList (props (restKeys (int >>> pair)))) 484 | [("foo", 42), ("bar", 0)] `sexpEq` 485 | (Right (BraceList [Symbol ":foo", Number 42, Symbol ":bar", Number 0])) 486 | 487 | , testCase "simple dict, remaining keys then one more" $ 488 | fromSexp' 489 | (braceList (props (restKeys (int >>> pair) >>> key "baz" int)) >>> pair) 490 | (BraceList [Symbol ":foo", Number 42, Symbol ":bar", Number 0]) `otherEq` 491 | (Left (ErrorMessage dummyPos [] (S.fromList ["keyword :baz"]) Nothing)) 492 | ] 493 | 494 | 495 | prefixTests :: TestTree 496 | prefixTests = testGroup "Prefix combinator tests" 497 | [ testCase "quoted" $ 498 | fromSexp' 499 | (quoted (list (rest int))) 500 | (Modified Quote (ParenList [Number 1, Number 2])) `otherEq` 501 | Right [1, 2] 502 | 503 | , testCase "hashed" $ 504 | fromSexp' 505 | (hashed (bracketList (rest int))) 506 | (Modified Hash (BracketList [Number 1, Number 2])) `otherEq` 507 | Right [1, 2] 508 | 509 | , testCase "backticked" $ 510 | fromSexp' 511 | (prefixed Backtick (bracketList (rest int))) 512 | (Modified Backtick (BracketList [Number 123, Number 0, Number (-100)])) `otherEq` 513 | Right [123, 0, -100] 514 | 515 | , testCase "comma-ed" $ 516 | fromSexp' 517 | (prefixed Comma (bracketList (rest int))) 518 | (Modified Comma (BracketList [Number 123, Number 0, Number (-100)])) `otherEq` 519 | Right [123, 0, -100] 520 | 521 | , testCase "comma-at-ed" $ 522 | fromSexp' 523 | (prefixed CommaAt (bracketList (rest int))) 524 | (Modified CommaAt (BracketList [Number 123, Number 0, Number (-100)])) `otherEq` 525 | Right [123, 0, -100] 526 | ] 527 | 528 | 529 | revStackPrismTests :: TestTree 530 | revStackPrismTests = testGroup "Reverse stack prism tests" 531 | [ testCase "pair of two bools" $ 532 | fromSexp' sexpIso (ParenList [Symbol "false", Symbol "true"]) `otherEq` 533 | Right (Pair False True) 534 | 535 | , testCase "sum of products (Bar True 42)" $ 536 | fromSexp' sexpIso (ParenList [Symbol "bar", Symbol "true", Number 42]) `otherEq` 537 | Right (Bar True (42 :: Int)) 538 | 539 | , testCase "sum of products (Baz True False) tries to parse (baz #f 10)" $ 540 | fromSexp' (sexpIso :: SexpGrammar (Foo Bool Bool)) 541 | (ParenList [Symbol "baz", Symbol "false", Number 10]) `otherEq` 542 | (Left (ErrorMessage dummyPos [] (S.fromList ["symbol false", "symbol true"]) (Just "10"))) 543 | ] 544 | 545 | 546 | testArithExpr :: ArithExpr 547 | testArithExpr = 548 | Add (Lit 0) (Mul []) 549 | 550 | testArithExprSexp :: Sexp 551 | testArithExprSexp = 552 | ParenList [Symbol "+", Number 0, ParenList [Symbol "*"]] 553 | 554 | 555 | parseTests :: TestTree 556 | parseTests = testGroup "parse tests" 557 | [ testCase "(+ 0 (*))" $ 558 | fromSexp' arithExprGenericIso testArithExprSexp 559 | `otherEq` Right testArithExpr 560 | ] 561 | 562 | 563 | genTests :: TestTree 564 | genTests = testGroup "gen tests" 565 | [ testCase "(+ 0 (*))" $ 566 | toSexp' arithExprGenericIso testArithExpr 567 | `otherEq` Right testArithExprSexp 568 | ] 569 | 570 | 571 | genParseIdentityProp :: forall a. (Eq a) => (forall t. Grammar Position (Sexp :- t) (a :- t)) -> a -> Bool 572 | genParseIdentityProp iso expr = 573 | (toSexp' iso expr >>= fromSexp' iso :: Either (ErrorMessage Position) a) 574 | == 575 | Right expr 576 | 577 | 578 | parseGenTests :: TestTree 579 | parseGenTests = testGroup "parse . gen == id" 580 | [ QC.testProperty "ArithExprs/TH" $ 581 | genParseIdentityProp arithExprTHIso 582 | 583 | , QC.testProperty "ArithExprs/Generics" $ 584 | genParseIdentityProp arithExprGenericIso 585 | 586 | , QC.testProperty "Pair Int String" $ 587 | genParseIdentityProp (pairGenericIso int string') 588 | 589 | , QC.testProperty "Foo (Foo Int String) (Pair String Int)" $ 590 | genParseIdentityProp (fooGenericIso (fooGenericIso int string') (pairGenericIso string' int)) 591 | 592 | , QC.testProperty "Person" $ 593 | genParseIdentityProp personGenericIso 594 | ] 595 | 596 | 597 | main :: IO () 598 | main = defaultMain allTests 599 | --------------------------------------------------------------------------------