├── src └── Data │ ├── Intertwine.purs │ └── Intertwine │ ├── Iso.purs │ ├── Route │ └── PathPiece.purs │ ├── Text.purs │ ├── Combinators.purs │ ├── MkIso.purs │ ├── Route.purs │ └── Syntax.purs ├── .gitignore ├── .editorconfig ├── package.json ├── test ├── Main.purs ├── Text.purs ├── Combinators.purs └── Route.purs ├── .github └── workflows │ └── build.yml ├── LICENSE.txt ├── bower.json └── README.md /src/Data/Intertwine.purs: -------------------------------------------------------------------------------- 1 | module Data.Intertwine 2 | ( module Data.Intertwine.Syntax 3 | 4 | ) where 5 | 6 | import Data.Intertwine.Syntax 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /bower_components/ 2 | /node_modules/ 3 | /.pulp-cache/ 4 | /output/ 5 | /generated-docs/ 6 | /.psc-package/ 7 | /.psc* 8 | /.purs* 9 | /.psa* 10 | -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | # This file should override whatever file you may have in your home dir 2 | root = true 3 | 4 | [*] 5 | end_of_line = lf 6 | insert_final_newline = true 7 | 8 | [*.{md,purs}] 9 | indent_style = space 10 | indent_size = 4 11 | trim_trailing_whitespace = true 12 | 13 | [{config.yml,package.json}] 14 | indent_size = 2 15 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "scripts": { 3 | "install": "bower install --allow-root", 4 | "build": "pulp build", 5 | "test": "pulp test" 6 | }, 7 | "devDependencies": { 8 | "acorn": "6.4.1", 9 | "bower": "^1.8.8", 10 | "elliptic": "^6.5.4", 11 | "lodash": "^4.17.21", 12 | "pulp": "^13.0.0", 13 | "purescript": "^0.13.6", 14 | "purescript-psa": "^0.7.3" 15 | } 16 | } 17 | -------------------------------------------------------------------------------- /test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Prelude 4 | 5 | import Effect (Effect) 6 | import Test.Combinators as Combinators 7 | import Test.Route as Route 8 | import Test.Spec.Reporter (consoleReporter) 9 | import Test.Spec.Runner (run) 10 | import Test.Text as Text 11 | 12 | main :: Effect Unit 13 | main = run [consoleReporter] do 14 | Text.allTests 15 | Route.allTests 16 | Combinators.allTests 17 | -------------------------------------------------------------------------------- /src/Data/Intertwine/Iso.purs: -------------------------------------------------------------------------------- 1 | module Data.Intertwine.Iso( 2 | Iso(..) 3 | ) where 4 | 5 | import Prelude 6 | import Data.Maybe (Maybe(..)) 7 | 8 | -- | Partial isomorphism - a pair of functions that can convert between two 9 | -- | types, with a possibility of failure. 10 | data Iso a b = Iso { 11 | apply :: a -> Maybe b, 12 | inverse :: b -> Maybe a 13 | } 14 | 15 | 16 | instance cIso :: Category Iso where 17 | identity = Iso { apply: Just, inverse: Just } 18 | 19 | instance smgIso :: Semigroupoid Iso where 20 | compose (Iso a) (Iso b) = Iso { 21 | apply: a.apply <=< b.apply, 22 | inverse: a.inverse >=> b.inverse 23 | } 24 | -------------------------------------------------------------------------------- /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | 3 | on: 4 | push: 5 | branches: [ master ] 6 | pull_request: 7 | branches: [ master ] 8 | 9 | jobs: 10 | build: 11 | runs-on: ubuntu-latest 12 | 13 | steps: 14 | - uses: actions/checkout@v2 15 | - uses: actions/cache@v2 16 | with: 17 | path: | 18 | bower_components 19 | output 20 | node_modules 21 | key: build-atrifacts-v1-${{ hashFiles('package-lock.json', 'bower.json') }} 22 | - uses: actions/setup-node@v1 23 | with: 24 | node-version: 10.15 25 | - run: npm i 26 | - run: npm run build 27 | - run: npm run test 28 | 29 | -------------------------------------------------------------------------------- /src/Data/Intertwine/Route/PathPiece.purs: -------------------------------------------------------------------------------- 1 | module Data.Intertwine.Route.PathPiece 2 | ( class PathPiece 3 | , toPathSegment 4 | , fromPathSegment 5 | ) where 6 | 7 | import Prelude 8 | import Data.Int as Int 9 | import Data.Maybe (Maybe(..)) 10 | 11 | -- | This class makes a type suitable for participating in route 12 | -- | printing/parsing - i.e. to be the type of path segments and querystring 13 | -- | parameters. 14 | class PathPiece a where 15 | toPathSegment :: a -> String 16 | fromPathSegment :: String -> Maybe a 17 | 18 | instance pathPieceString :: PathPiece String where 19 | toPathSegment = identity 20 | fromPathSegment = Just 21 | 22 | instance pathPieceInt :: PathPiece Int where 23 | toPathSegment = show 24 | fromPathSegment = Int.fromString 25 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2018 CollegeVine 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /bower.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-intertwine", 3 | "description": "Reversible printing/parsing", 4 | "authors": [ 5 | "Fyodor Soikin ", 6 | "CollegeVine" 7 | ], 8 | "license": "MIT", 9 | "repository": { 10 | "type": "git", 11 | "url": "https://github.com/collegevine/purescript-intertwine.git" 12 | }, 13 | "ignore": [ 14 | "**/.*", 15 | "node_modules", 16 | "bower_components", 17 | "output" 18 | ], 19 | "dependencies": { 20 | "purescript-foreign": "^5.0.0", 21 | "purescript-foreign-object": "^2.0.2", 22 | "purescript-generics-rep": "^6.1.1", 23 | "purescript-maybe": "^4.0.1", 24 | "purescript-prelude": "^4.1.1", 25 | "purescript-profunctor-lenses": "^6.2.0", 26 | "purescript-strings": "^4.0.1", 27 | "purescript-unicode": "^4.0.1" 28 | }, 29 | "devDependencies": { 30 | "purescript-psci-support": "^4.0.0", 31 | "purescript-spec": "^3.1.0", 32 | "purescript-spec-quickcheck": "^3.1.0", 33 | "purescript-quickcheck": "^5.0.0" 34 | }, 35 | "resolutions": { 36 | "purescript-typelevel-prelude": ">= 4.0.0 < 6.0.0", 37 | "purescript-record": "^2.0.0" 38 | } 39 | } 40 | -------------------------------------------------------------------------------- /src/Data/Intertwine/Text.purs: -------------------------------------------------------------------------------- 1 | -- | Syntax primitives for printing/parsing plain text 2 | module Data.Intertwine.Text 3 | ( str 4 | , followedBy 5 | , int 6 | , lit 7 | ) where 8 | 9 | import Prelude 10 | 11 | import Control.MonadZero (guard) 12 | import Data.Char.Unicode as Char 13 | import Data.Int as Int 14 | import Data.Intertwine.Iso (Iso(..)) 15 | import Data.Intertwine.Syntax (class Syntax, atom, parse, print) 16 | import Data.Maybe (Maybe(..)) 17 | import Data.String (Pattern(..)) 18 | import Data.String.CodeUnits as String 19 | import Data.Tuple (Tuple(..)) 20 | 21 | type Primitive a = forall syn. Syntax syn => syn String a 22 | 23 | followedBy :: forall a. Primitive a -> String -> Primitive a 24 | followedBy p suffix = atom $ Iso 25 | { apply: \(Tuple output a) -> do 26 | aPrinted <- print p "" a 27 | pure $ Tuple (output <> aPrinted <> suffix) unit 28 | 29 | , inverse: \(Tuple input _) -> do 30 | idx <- String.indexOf (Pattern suffix) input 31 | prefix <- String.slice 0 idx input 32 | Tuple a rest <- parse p prefix 33 | guard $ rest == "" 34 | let tail = String.drop (idx + String.length suffix) input 35 | pure $ Tuple tail a 36 | } 37 | 38 | str :: Primitive String 39 | str = atom $ Iso 40 | { apply: \(Tuple output s) -> Just $ Tuple (output <> s) unit 41 | , inverse: \(Tuple input _) -> Just $ Tuple "" input 42 | } 43 | 44 | int :: Primitive Int 45 | int = atom $ Iso 46 | { apply: \(Tuple output a) -> 47 | Just $ Tuple (output <> show a) unit 48 | , inverse: \(Tuple input _) -> do 49 | let head = String.takeWhile Char.isNumber input 50 | guard $ head /= "" 51 | num <- Int.fromString head 52 | let tail = String.drop (String.length head) input 53 | pure $ Tuple tail num 54 | } 55 | 56 | lit :: String -> Primitive Unit 57 | lit txt = atom $ Iso 58 | { apply: \(Tuple state _) -> 59 | Just $ Tuple (state <> txt) unit 60 | , inverse: \(Tuple state _) -> do 61 | tail <- String.stripPrefix (Pattern txt) state 62 | pure $ Tuple tail unit 63 | } 64 | -------------------------------------------------------------------------------- /test/Text.purs: -------------------------------------------------------------------------------- 1 | -- 2 | -- This test suite is a proof of concept, demonstrating how the Syntax machinery 3 | -- can be used to implement reversible printers/parsers for a simple case where 4 | -- the input of parsing (aka output of printing) is a text string. 5 | -- 6 | -- The test itself enumerates a few concrete examples, and for each one makes 7 | -- sure that `printer >>> parser == identity`. A better approach would be to 8 | -- employ QuickCheck to prove that this property holds for any input. This is 9 | -- TODO. 10 | -- 11 | module Test.Text where 12 | 13 | import Prelude 14 | 15 | import Data.Generic.Rep (class Generic) 16 | import Data.Generic.Rep.Show (genericShow) 17 | import Data.Intertwine.MkIso (iso) 18 | import Data.Intertwine.Syntax (class Syntax, parse, print, (*|>), (<|$|>), (<|*|>), (<|||>)) 19 | import Data.Intertwine.Text (int, lit, str, followedBy) 20 | import Data.Maybe (fromJust) 21 | import Data.Symbol (SProxy(..)) 22 | import Data.Tuple (fst) 23 | import Partial.Unsafe (unsafePartial) 24 | import Test.Spec (Spec, describe, it) 25 | import Test.Spec.Assertions (shouldEqual) 26 | 27 | data T 28 | = A 29 | | B String 30 | | C Int Int 31 | 32 | derive instance gT :: Generic T _ 33 | derive instance eqT :: Eq T 34 | instance showT :: Show T where show = genericShow 35 | 36 | p :: forall syn. Syntax syn => syn String T 37 | p = 38 | iso (SProxy :: SProxy "A") <|$|> lit "A:" 39 | <|||> iso (SProxy :: SProxy "B") <|$|> lit "B::" *|> (str `followedBy` "::") 40 | <|||> iso (SProxy :: SProxy "C") <|$|> lit "C--" *|> int <|*|> lit "/" *|> int 41 | 42 | allTests :: Spec Unit 43 | allTests = describe "Syntax for parsing/printing strings" do 44 | t A "A:" 45 | t (B "abc") "B::abc::" 46 | t (B "") "B::::" 47 | t (C 42 42) "C--42/42" 48 | t (C 42 5) "C--42/5" 49 | t (C 0 42) "C--0/42" 50 | where 51 | t value expected = unsafePartial do 52 | let printed = fromJust $ print p "" value 53 | parsed = fst $ fromJust $ parse p printed 54 | it (show value <> " <==> " <> expected) $ do 55 | shouldEqual value parsed 56 | shouldEqual printed expected 57 | 58 | 59 | -------------------------------------------------------------------------------- /test/Combinators.purs: -------------------------------------------------------------------------------- 1 | module Test.Combinators where 2 | 3 | import Prelude 4 | 5 | import Data.Either (Either(..)) 6 | import Data.Intertwine.Combinators (isoFlip, isoFrom, isoJust, isoTraverse, isoUnwrap, isoWrap) 7 | import Data.Intertwine.Iso (Iso(..)) 8 | import Data.Maybe (Maybe(..)) 9 | import Data.Newtype (class Newtype) 10 | import Test.Spec (Spec, describe, it) 11 | import Test.Spec.Assertions (shouldEqual) 12 | 13 | allTests :: Spec Unit 14 | allTests = describe "Combinators" do 15 | describe "isoTraverse" do 16 | it "traverses Array" do 17 | shouldEqual (ap arrPlus5 [0, 1, 42]) (Just [5, 6, 47]) 18 | shouldEqual (inv arrPlus5 [5, 6, 47]) (Just [0, 1, 42]) 19 | it "traverses Either" do 20 | shouldEqual (ap eitherPlus5 $ Right 42) (Just $ Right 47) 21 | shouldEqual (ap eitherPlus5 $ Left "foo") (Just $ Left "foo") 22 | shouldEqual (inv eitherPlus5 $ Right 42) (Just $ Right 37) 23 | shouldEqual (inv eitherPlus5 $ Left "foo") (Just $ Left "foo") 24 | describe "isoFlip" do 25 | it "inverses direction" do 26 | shouldEqual (ap (isoFlip plus5) 42) (Just 37) 27 | shouldEqual (inv (isoFlip plus5) 42) (Just 47) 28 | describe "isoWrap" do 29 | it "wraps newtype constructor" do 30 | shouldEqual (ap (isoWrap N) 42) (Just (N 42)) 31 | shouldEqual (inv (isoWrap N) (N 42)) (Just 42) 32 | describe "isoUnrap" do 33 | it "unwraps newtype constructor" do 34 | shouldEqual (ap (isoUnwrap N) (N 42)) (Just 42) 35 | shouldEqual (inv (isoUnwrap N) 42) (Just (N 42)) 36 | describe "isoJust" do 37 | it "wraps in Just" do 38 | shouldEqual (ap isoJust 42) (Just (Just 42)) 39 | shouldEqual (inv isoJust (Just 42)) (Just 42) 40 | shouldEqual (inv isoJust Nothing) (Nothing :: Maybe Int) 41 | where 42 | ap :: forall a b. Iso a b -> a -> Maybe b 43 | ap (Iso i) = i.apply 44 | 45 | inv :: forall a b. Iso a b -> b -> Maybe a 46 | inv (Iso i) = i.inverse 47 | 48 | newtype N a = N a 49 | derive instance newtypeN :: Newtype (N a) _ 50 | derive newtype instance showN :: Show a => Show (N a) 51 | derive newtype instance eqN :: Eq a => Eq (N a) 52 | 53 | plus5 :: Iso Int Int 54 | plus5 = isoFrom (_ + 5) (_ - 5) 55 | 56 | arrPlus5 :: Iso (Array Int) (Array Int) 57 | arrPlus5 = isoTraverse plus5 58 | 59 | eitherPlus5 :: Iso (Either String Int) (Either String Int) 60 | eitherPlus5 = isoTraverse plus5 61 | -------------------------------------------------------------------------------- /src/Data/Intertwine/Combinators.purs: -------------------------------------------------------------------------------- 1 | -- | Primitive combinators for Iso 2 | module Data.Intertwine.Combinators 3 | ( isoFlip 4 | , isoTraverse 5 | , isoFrom 6 | , isoWrap 7 | , isoUnwrap 8 | , isoJust 9 | ) where 10 | 11 | import Prelude 12 | 13 | import Data.Intertwine.Iso (Iso(..)) 14 | import Data.Maybe (Maybe(..)) 15 | import Data.Newtype (class Newtype, unwrap, wrap) 16 | import Data.Traversable (class Traversable, sequence) 17 | 18 | -- | Constructs a never-failing `Iso` out of given "apply" and 19 | -- | "inverse" functions 20 | isoFrom :: forall a b. (a -> b) -> (b -> a) -> Iso a b 21 | isoFrom apply inverse = Iso { apply: Just <<< apply, inverse: Just <<< inverse } 22 | 23 | -- | Revereses the direction of an `Iso` 24 | isoFlip :: forall a b. Iso a b -> Iso b a 25 | isoFlip (Iso i) = Iso { apply: i.inverse, inverse: i.apply } 26 | 27 | -- | Given a `Traversable` and an `Iso` that maps some values `a` and 28 | -- | `b`, produces a new `Iso` that maps those values wrapped in the 29 | -- | `Traversable` - `f a` and `f b`. This is handy for working for `Maybe`, for 30 | -- | example: 31 | -- | 32 | -- | -- First, define a never-failing Iso that maps a number 33 | -- | -- to a number 5 greater than it 34 | -- | plus5 :: Iso Int Int 35 | -- | plus5 = isoFrom (_ + 5) (_ - 5) 36 | -- | 37 | -- | > plus5.apply 37 == Just 42 38 | -- | > plus5.inverse 42 == Just 37 39 | -- | 40 | -- | -- Now, wrap it in a `Maybe` 41 | -- | mPlus5 :: Iso (Maybe Int) (Maybe Int) 42 | -- | mPlus5 = isoTraverse plus5 43 | -- | 44 | -- | > mPlus5.apply (Just 37) == Just (Just 42) 45 | -- | > mPlus5.inverse (Just 42) == Just (Just 37) 46 | -- | > mPlus5.apply Nothing == Just Nothing 47 | -- | > mPlus5.inverse Nothing == Just Nothing 48 | -- | 49 | -- | -- Or wrap it in an `Array` 50 | -- | aPlus5 :: Iso (Array Int) (Array Int) 51 | -- | aPlus5 = isoTraverse plus5 52 | -- | 53 | -- | > aPlus5.apply [37, 0] == Just [42, 5] 54 | -- | > aPlus5.inverse [42, 5] == Just [37, 0] 55 | -- | > aPlus5.apply [] == Just [] 56 | -- | > aPlus5.inverse [] == Just [] 57 | -- | 58 | isoTraverse :: forall f a b. Traversable f => Iso a b -> Iso (f a) (f b) 59 | isoTraverse (Iso i) = Iso { apply: sequence <<< map i.apply, inverse: sequence <<< map i.inverse } 60 | 61 | -- | Constructs a never-failing `Iso` mapping a `newtype` to the type 62 | -- | it wraps. The intended use is to provide the `newtype`'s constructor as 63 | -- | first argument for the purpose of type inference. 64 | -- | 65 | -- | Example: 66 | -- | 67 | -- | newtype N = N Int 68 | -- | derive instance newtypeN :: Newtype N _ 69 | -- | 70 | -- | isoN :: Iso Int N 71 | -- | isoN = isoWrap N 72 | -- | 73 | -- | > isoN.apply 42 == Just (N 42) 74 | -- | > isoN.inverse (N 42) == Just 42 75 | -- | 76 | isoWrap :: forall w a. Newtype w a => (a -> w) -> Iso a w 77 | isoWrap _ = isoFrom wrap unwrap 78 | 79 | -- | The opposite of `isoWrap`: constructs a never-failing `Iso` that 80 | -- | maps a value to a `newtype` that wraps it. The intended use is to provide 81 | -- | the `newtype`'s constructor as first argument for the purpose of type 82 | -- | inference. 83 | -- | 84 | -- | Example: 85 | -- | 86 | -- | newtype N = N Int 87 | -- | derive instance newtypeN :: Newtype N _ 88 | -- | 89 | -- | isoN :: Iso N Int 90 | -- | isoN = isoUnwrap N 91 | -- | 92 | -- | > isoN.apply (N 42) == Just 42 93 | -- | > isoN.inverse 42 == Just (N 42) 94 | -- | 95 | isoUnwrap :: forall w a. Newtype w a => (a -> w) -> Iso w a 96 | isoUnwrap = isoFlip <<< isoWrap 97 | 98 | -- | An `Iso` that wraps any value in a `Just`, and unwraps on 99 | -- | inverse, failing when given `Nothing`. 100 | -- | 101 | -- | Example: 102 | -- | 103 | -- | > isoJust.apply 42 == Just (Just 42) 104 | -- | > isoJust.inverse (Just 42) = Just 42 105 | -- | > isoJust.inverse Nothing = Nothing 106 | -- | 107 | isoJust :: forall a. Iso a (Maybe a) 108 | isoJust = Iso { apply: Just <<< Just, inverse: identity } 109 | -------------------------------------------------------------------------------- /src/Data/Intertwine/MkIso.purs: -------------------------------------------------------------------------------- 1 | module Data.Intertwine.MkIso( 2 | class MkIso, iso, 3 | class ArgsAsTuple, argsToTuple, tupleToArgs 4 | ) where 5 | 6 | import Prelude 7 | import Data.Generic.Rep (class Generic, Argument(..), Constructor(..), NoArguments(..), Product(..), Sum(..), from, to) 8 | import Data.Maybe (Maybe(..)) 9 | import Data.Symbol (SProxy(..)) 10 | import Data.Tuple (Tuple(..)) 11 | import Data.Intertwine.Iso (Iso(..)) 12 | 13 | -- | This type class provides the function `iso`, which operates on a sum type. 14 | -- | It takes the name of a constructor of that type and returns an `Iso` 15 | -- | instance that converts between the sum type itself and the chosen 16 | -- | constructor's parameters that are all tupled together, starting with the 17 | -- | right ones. 18 | -- | 19 | -- | For example: 20 | -- | 21 | -- | data T = A | B String | C Int Number | D Boolean Int String 22 | -- | 23 | -- | iso (SProxy :: SProxy "A") :: Iso Unit T 24 | -- | iso (SProxy :: SProxy "B") :: Iso String T 25 | -- | iso (SProxy :: SProxy "C") :: Iso (Tuple Int Number) T 26 | -- | iso (SProxy :: SProxy "D") :: Iso (Tuple Boolean (Tuple Int String)) T 27 | -- | 28 | -- | Such tupling is necessary for the implementation of both printers and 29 | -- | parsers from the same code structure. See 30 | -- | [`Syntax`](https://pursuit.purescript.org/packages/purescript-intertwine/docs/Data.Intertwine.Syntax) 31 | -- | for a more detailed explanation. 32 | -- | 33 | -- | The resulting `Iso` can always convert "forward" (i.e. from 34 | -- | tupled arguments to `T`), but it can only convert "backward" (i.e. from T 35 | -- | to the corresponding tuple) when the given `T` value was constructed with 36 | -- | the given constructor, returning `Nothing` for all other constructors. 37 | 38 | -- 39 | -- Class parameters: 40 | -- 41 | -- * t - the sum type for which to generate the Iso 42 | -- * ctor - name of the constructor for which to generate the Iso 43 | -- * tuple - type of the resulting tuple 44 | -- 45 | -- The implementation has two stages: first we implement the class for the 46 | -- Generic representation types, matching on `Constructor` and `Sum`, and then 47 | -- we use that as a base to implement the class for the sum type itself, using 48 | -- `to` and `from` to convert to/from the generic representation. 49 | -- 50 | -- NOTE: the implementation relies on the fact that the compiler generates 51 | -- `Sum` instances as a chain, even though they could technically form a tree. 52 | -- That is, we only consider the case when the first argument of `Sum` is a 53 | -- `Constructor`, disregarding the possibility of it being another `Sum`. As 54 | -- far as I can tell, the compiler always generates generic rep types this 55 | -- way. 56 | class MkIso t ctor tuple | t ctor -> tuple where 57 | iso :: SProxy ctor -> Iso tuple t 58 | 59 | -- Iso for a single constructor 60 | instance mkIsoCtor :: ArgsAsTuple args argsAsTuple => MkIso (Constructor name args) name argsAsTuple where 61 | iso _ = Iso 62 | { apply: Just <<< Constructor <<< tupleToArgs 63 | , inverse: \(Constructor args) -> Just $ argsToTuple args 64 | } 65 | 66 | -- Iso for a constructor that has a chain of other constructors attached. 67 | else instance mkIsoSumLeft :: ArgsAsTuple args argsAsTuple => MkIso (Sum (Constructor ctor args) rest) ctor argsAsTuple where 68 | iso _ = Iso 69 | { apply: 70 | Just <<< Inl <<< Constructor <<< tupleToArgs 71 | , inverse: \s -> case s of 72 | Inl (Constructor args) -> Just $ argsToTuple args 73 | Inr _ -> Nothing 74 | } 75 | 76 | -- Iso for a case when the first constructor in the chain doesn't match the 77 | -- given constructor name. In this case, we just delegate to the instance of 78 | -- this class for the rest of the chian (if such instance exists). 79 | else instance mkIsoSumRight :: MkIso rest ctor tuple => MkIso (Sum (Constructor anotherName y) rest) ctor tuple where 80 | iso _ = Iso 81 | { apply: 82 | map Inr <<< restIso.apply 83 | , inverse: \s -> case s of 84 | Inl _ -> Nothing 85 | Inr rest -> restIso.inverse rest 86 | } 87 | where 88 | Iso restIso = iso (SProxy :: SProxy ctor) 89 | 90 | -- The top-level instance: converts from the sum type to generic rep and then 91 | -- delegates to one of the instances above. 92 | else instance mkIso :: (Generic t rep, MkIso rep ctor tuple) => MkIso t ctor tuple where 93 | iso _ = Iso 94 | { apply: map to <<< repIso.apply 95 | , inverse: repIso.inverse <<< from 96 | } 97 | where 98 | Iso repIso = iso (SProxy :: SProxy ctor) 99 | 100 | 101 | -- | This type class takes the Generic-rep representation of sum type arguments 102 | -- | and converts them into a series of nested tuples. 103 | -- 104 | -- NOTE: similarly to the `MkIso` implementation, we rely here on the fact that 105 | -- the first argument of `Product` is always an `Argument`, even though 106 | -- technically it could be another `Product`. As far as I can tell, the compiler 107 | -- always generates representations this way. 108 | class ArgsAsTuple args tuple | args -> tuple where 109 | argsToTuple :: args -> tuple 110 | tupleToArgs :: tuple -> args 111 | 112 | instance a2tEmpty :: ArgsAsTuple NoArguments Unit where 113 | argsToTuple = const unit 114 | tupleToArgs = const NoArguments 115 | 116 | instance a2tSingle :: ArgsAsTuple (Argument a) a where 117 | argsToTuple (Argument a) = a 118 | tupleToArgs = Argument 119 | 120 | instance a2tRecursive :: (ArgsAsTuple a ax, ArgsAsTuple b bx) => ArgsAsTuple (Product a b) (Tuple ax bx) where 121 | argsToTuple (Product a b) = Tuple (argsToTuple a) (argsToTuple b) 122 | tupleToArgs (Tuple a b) = Product (tupleToArgs a) (tupleToArgs b) 123 | -------------------------------------------------------------------------------- /src/Data/Intertwine/Route.purs: -------------------------------------------------------------------------------- 1 | -- Syntax primitives and convenience wrappers for printing/parsing in-browser 2 | -- routes 3 | module Data.Intertwine.Route 4 | ( class IsRoute, routeEmpty, routeSegments, routeQueryString 5 | , PathInfo(..) 6 | , RoutesDef 7 | , parseRoute 8 | , printRoute 9 | 10 | , end 11 | , seg 12 | , segValue' 13 | , segValue 14 | , constValue 15 | , query' 16 | , query 17 | 18 | , module SyntaxReexport 19 | , module Data.Intertwine.Route.PathPiece 20 | ) where 21 | 22 | import Prelude 23 | 24 | import Control.MonadZero (guard, (<|>)) 25 | import Data.Array as Array 26 | import Data.Intertwine.Iso (Iso(..)) 27 | import Data.Intertwine.Route.PathPiece (class PathPiece, toPathSegment, fromPathSegment) 28 | import Data.Intertwine.Syntax (Ctor(..), (<|$|>), (<|:|>), (<|*|>), (*|>), (<|||>)) as SyntaxReexport 29 | import Data.Intertwine.Syntax (class Syntax, atom, parse, print) 30 | import Data.Lens (Lens', lens, (^.), (%~), (.~)) 31 | import Data.Maybe (Maybe(..)) 32 | import Data.Tuple (Tuple(..)) 33 | import Foreign.Object as Obj 34 | 35 | -- | This class abstracts the idea of the "route" data type, making it possible 36 | -- | for the primitive in this module to work with data types from other 37 | -- | libraries. 38 | class IsRoute r where 39 | routeEmpty :: r 40 | routeSegments :: Lens' r (Array String) 41 | routeQueryString :: Lens' r (Obj.Object String) 42 | 43 | 44 | -- | The default representation of a route: here the route is represented as a 45 | -- | sequence of path segments and a dictionary of querystring parameters. 46 | data PathInfo = PathInfo (Array String) (Obj.Object String) 47 | 48 | instance pathIsRoute :: IsRoute PathInfo where 49 | routeEmpty = PathInfo [] Obj.empty 50 | routeSegments = lens (\(PathInfo s _) -> s) (\(PathInfo _ q) s -> PathInfo s q) 51 | routeQueryString = lens (\(PathInfo _ q) -> q) (\(PathInfo s _) q -> PathInfo s q) 52 | 53 | 54 | -- | Syntax definition for a set of routes of type `a`. 55 | type RoutesDef route a = forall syntax. Syntax syntax => syntax route a 56 | 57 | parseRoute :: forall a route. IsRoute route => RoutesDef route a -> route -> Maybe a 58 | parseRoute def path = do 59 | Tuple a rt <- parse def path 60 | guard $ Array.null $ rt^.routeSegments 61 | pure a 62 | 63 | printRoute :: forall a route. IsRoute route => RoutesDef route a -> a -> Maybe route 64 | printRoute def = print def routeEmpty 65 | 66 | -- | Signifies the end of the route. During printing doesn't produce any output, 67 | -- | during parsing makes sure that there are no URL segments remaining. 68 | end :: forall route. IsRoute route => RoutesDef route Unit 69 | end = mkAtom prnt pars 70 | where 71 | prnt pi _ = Just pi 72 | pars r | Array.null (r^.routeSegments) = Just $ Tuple r unit 73 | pars _ = Nothing 74 | 75 | -- | Path segment that is a literal string. During printing outputs the given 76 | -- | string, during parsing consumes the next URL segment and makes sure it's 77 | -- | equal to the given string. 78 | seg :: forall route. IsRoute route => String -> RoutesDef route Unit 79 | seg str = mkAtom prnt pars 80 | where 81 | prnt pi _ = 82 | Just $ appendSeg str pi 83 | pars r = do 84 | l <- Array.uncons (r^.routeSegments) 85 | guard $ l.head == str 86 | pure $ Tuple (r # routeSegments .~ l.tail) unit 87 | 88 | -- | A primitive that encodes a constant value. During printing, the printer 89 | -- | succeeds iff the value beign printed is equal to `theValue`, otherwise 90 | -- | fails. During parsing, the parser returns `theValue` without consuming any 91 | -- | input. 92 | constValue :: forall a route. Eq a => a -> RoutesDef route a 93 | constValue theValue = mkAtom prnt pars 94 | where 95 | prnt pi a | a == theValue = Just pi 96 | prnt _ _ = Nothing 97 | pars pi = Just $ Tuple pi theValue 98 | 99 | -- | A value of the given type as URL segment. During printing, the printer 100 | -- | outputs the value as a URL segment, using the `PathPiece` instance to 101 | -- | convert it to a string. During parsing, the parser consumes a URL segment 102 | -- | and tries to parse it into a value of the given type using the `PathPiece` 103 | -- | instance. 104 | segValue :: forall a route. IsRoute route => PathPiece a => RoutesDef route a 105 | segValue = segValue' toPathSegment fromPathSegment 106 | 107 | -- | A value of the given type as URL segment. During printing, the printer 108 | -- | outputs the value as a URL segment, using the provided printing function to 109 | -- | convert it to a string. During parsing, the parser consumes a URL segment 110 | -- | and tries to parse it into a value of the given type using the provided 111 | -- | parsing function. 112 | segValue' :: forall a route. IsRoute route 113 | => (a -> String) 114 | -> (String -> Maybe a) 115 | -> RoutesDef route a 116 | segValue' printA parseA = mkAtom prnt pars 117 | where 118 | prnt pi a = 119 | Just $ appendSeg (printA a) pi 120 | pars r = do 121 | l <- Array.uncons (r^.routeSegments) 122 | a <- parseA l.head 123 | pure $ Tuple (r # routeSegments .~ l.tail) a 124 | 125 | -- | QueryString value. During printing adds the printed value to the 126 | -- | QueryString under given key. During parsing, looks up the value in the 127 | -- | QueryString. 128 | query :: forall a route. IsRoute route => PathPiece a => String -> RoutesDef route (Maybe a) 129 | query key = query' toPathSegment fromPathSegment key 130 | 131 | -- | QueryString value. During printing adds the printed value (converted via 132 | -- | the given printing function) to the QueryString under given key. During 133 | -- | parsing, looks up the value in the QueryString and attempts to parse it 134 | -- | with the given parsing function. 135 | query' :: forall a route. IsRoute route 136 | => (a -> String) 137 | -> (String -> Maybe a) 138 | -> String 139 | -> RoutesDef route (Maybe a) 140 | query' printA parseA key = mkAtom prnt \pi -> pars pi <|> fallback pi 141 | where 142 | prnt r Nothing = 143 | Just r 144 | prnt r (Just a) = 145 | Just $ r # routeQueryString %~ Obj.insert key (printA a) 146 | 147 | pars r = do 148 | v <- Obj.lookup key $ r^.routeQueryString 149 | a <- parseA v 150 | pure $ Tuple (r # routeQueryString %~ Obj.delete key) (Just a) 151 | 152 | fallback r = 153 | Just $ Tuple r Nothing 154 | 155 | 156 | 157 | -- 158 | -- Internal utilities 159 | -- 160 | 161 | appendSeg :: forall route. IsRoute route => String -> route -> route 162 | appendSeg s r = r # routeSegments %~ (_ `Array.snoc` s) 163 | 164 | -- | Helper function for producing an Iso out of a print function and a parse 165 | -- | function. It's here solely to shorten the code of primitives above by 166 | -- | removing some of the `Tuple` cruft from them. 167 | mkAtom :: forall a route 168 | . (route -> a -> Maybe route) -- ^ Printing function 169 | -> (route -> Maybe (Tuple route a)) -- ^ Parsing function 170 | -> RoutesDef route a 171 | mkAtom printA parseA = atom $ Iso { 172 | apply: \(Tuple route a) -> printA route a <#> \newRoute -> Tuple newRoute unit, 173 | inverse: \(Tuple route _) -> parseA route 174 | } 175 | -------------------------------------------------------------------------------- /test/Route.purs: -------------------------------------------------------------------------------- 1 | module Test.Route where 2 | 3 | import Prelude 4 | 5 | import Control.Alt ((<|>)) 6 | import Data.Generic.Rep (class Generic) 7 | import Data.Generic.Rep.Show (genericShow) 8 | import Data.Int as Int 9 | import Data.Intertwine.Combinators (isoTraverse, isoUnwrap) 10 | import Data.Intertwine.Route (class PathPiece, Ctor(..), PathInfo(..), RoutesDef, constValue, end, parseRoute, printRoute, query, query', seg, segValue, segValue', (*|>), (<|$|>), (<|*|>), (<|:|>), (<|||>)) 11 | import Data.Intertwine.Syntax ((<|*)) 12 | import Data.Maybe (Maybe(..)) 13 | import Data.Newtype (class Newtype, unwrap, wrap) 14 | import Data.String as String 15 | import Data.Tuple (Tuple(..)) 16 | import Foreign.Object as Obj 17 | import Test.QuickCheck (Result, (===)) 18 | import Test.QuickCheck.Arbitrary (class Arbitrary, genericArbitrary) 19 | import Test.Spec (Spec, describe, it) 20 | import Test.Spec.Assertions (shouldEqual) 21 | import Test.Spec.QuickCheck (quickCheck) 22 | 23 | data Route 24 | = StandardRoute StandardRoute 25 | | CT_Seg CustomType 26 | | CT_NewtypeSeg CustomType 27 | | CT_Query (Maybe CustomType) 28 | | CT_NewtypeQuery (Maybe CustomType) 29 | 30 | data StandardRoute 31 | = Root 32 | | A 33 | | B String 34 | | C Int (Maybe Int) 35 | | D SubRoute 36 | 37 | data SubRoute 38 | = X Int 39 | | Y (Maybe String) 40 | 41 | data R2 42 | = R2A (Maybe String) 43 | | R2B 44 | 45 | -- | I'm pretending that I don't control this type, so I can it how it works 46 | -- | with `segValue'`, `query'`, `newtypeSeg`, and `newtypeQuery` 47 | data CustomType 48 | = CT1 String 49 | | CT2 Int 50 | 51 | newtype Wrapper = Wrapper CustomType 52 | derive instance newtypeWrapper :: Newtype Wrapper _ 53 | 54 | derive instance gRoute :: Generic Route _ 55 | derive instance eqRoute :: Eq Route 56 | instance showRoute :: Show Route where show = genericShow 57 | 58 | derive instance gStandardRoute :: Generic StandardRoute _ 59 | derive instance eqStandardRoute :: Eq StandardRoute 60 | instance showStandardRoute :: Show StandardRoute where show = genericShow 61 | instance arbStandardRoute :: Arbitrary StandardRoute where arbitrary = genericArbitrary 62 | 63 | derive instance gSubRoute :: Generic SubRoute _ 64 | derive instance eqSubRoute :: Eq SubRoute 65 | instance showSubRoute :: Show SubRoute where show = genericShow 66 | instance arbSubRoute :: Arbitrary SubRoute where arbitrary = genericArbitrary 67 | 68 | derive instance gR2 :: Generic R2 _ 69 | derive instance eqR2 :: Eq R2 70 | instance showR2 :: Show R2 where show = genericShow 71 | 72 | derive instance gCustomType :: Generic CustomType _ 73 | derive instance eqCustomType :: Eq CustomType 74 | instance showCustomType :: Show CustomType where show = genericShow 75 | 76 | instance ppWrapper :: PathPiece Wrapper where 77 | toPathSegment = unwrap >>> printCustomType 78 | fromPathSegment = Just <<< wrap <<< CT1 79 | 80 | route :: RoutesDef PathInfo Route 81 | route = 82 | (Ctor::Ctor "StandardRoute") <|:|> standardRoute <|* end 83 | <|||> (Ctor::Ctor "CT_Seg") <|:|> seg "ct_seg" *|> segValue' printCustomType parsCustomType <|* end 84 | <|||> (Ctor::Ctor "CT_NewtypeSeg") <|:|> seg "ct_ntseg" *|> (asCustomType <|$|> segValue) <|* end 85 | <|||> (Ctor::Ctor "CT_Query") <|:|> seg "ct_q" *|> query' printCustomType parsCustomType "q" <|* end 86 | <|||> (Ctor::Ctor "CT_NewtypeQuery") <|:|> seg "ct_ntq" *|> (isoTraverse asCustomType <|$|> query "q") <|* end 87 | where 88 | asCustomType = isoUnwrap Wrapper 89 | 90 | standardRoute :: RoutesDef PathInfo StandardRoute 91 | standardRoute = 92 | (Ctor::Ctor "Root") <|:|> end 93 | <|||> (Ctor::Ctor "A") <|:|> seg "a" <|* end 94 | <|||> (Ctor::Ctor "B") <|:|> seg "b" *|> segValue <|* end 95 | <|||> (Ctor::Ctor "C") <|:|> seg "fourty-two" *|> constValue 42 <|*|> constValue (Just 42) <|* end 96 | <|||> (Ctor::Ctor "C") <|:|> seg "c" *|> seg "d" *|> segValue <|*|> query "second" <|* end 97 | <|||> (Ctor::Ctor "C") <|:|> seg "c" *|> seg "d" *|> segValue <|*|> query "second" <|* end 98 | <|||> (Ctor::Ctor "D") <|:|> seg "d" *|> subRoute <|* end 99 | 100 | subRoute :: RoutesDef PathInfo SubRoute 101 | subRoute = 102 | (Ctor::Ctor "X") <|:|> segValue 103 | <|||> (Ctor::Ctor "Y") <|:|> seg "y" *|> query "s" 104 | 105 | r2a :: RoutesDef PathInfo R2 106 | r2a = (Ctor::Ctor "R2A") <|:|> query "foo" <|* end 107 | 108 | r2b :: RoutesDef PathInfo R2 109 | r2b = (Ctor::Ctor "R2B") <|:|> seg "bar" <|* end 110 | 111 | parsCustomType :: String -> Maybe CustomType 112 | parsCustomType s = (CT2 <$> Int.fromString s) <|> (Just $ CT1 s) 113 | 114 | printCustomType :: CustomType -> String 115 | printCustomType (CT1 s) = s 116 | printCustomType (CT2 i) = show i 117 | 118 | isomorphicProp :: forall r. Eq r => Show r => RoutesDef PathInfo r -> r -> Result 119 | isomorphicProp rdef r = Just r === (printRoute rdef r >>= parseRoute rdef) 120 | 121 | allTests :: Spec Unit 122 | allTests = do 123 | describe "Quickcheck- isomorphic print/parse" do 124 | it "StandardRoute" $ quickCheck $ isomorphicProp standardRoute 125 | describe "Printing/parsing routes" do 126 | t route (StandardRoute Root) "/" 127 | t route (StandardRoute A) "/a" 128 | t route (StandardRoute (B "abc")) "/b/abc" 129 | t route (StandardRoute (B "")) "/b/" 130 | t route (StandardRoute (C 42 $ Just 42)) "/fourty-two" 131 | t route (StandardRoute (C 42 $ Just 5)) "/c/d/42?second=5" 132 | t route (StandardRoute (C 0 $ Just 42)) "/c/d/0?second=42" 133 | t route (StandardRoute (C 42 Nothing)) "/c/d/42" 134 | t route (StandardRoute (D $ X 42)) "/d/42" 135 | t route (StandardRoute (D $ Y $ Just "splat")) "/d/y?s=splat" 136 | t route (StandardRoute (D $ Y Nothing )) "/d/y" 137 | 138 | t route (CT_Seg $ CT1 "foo") "/ct_seg/foo" 139 | t route (CT_Seg $ CT2 42) "/ct_seg/42" 140 | t route (CT_NewtypeSeg $ CT1 "foo") "/ct_ntseg/foo" 141 | 142 | t route (CT_Query $ Just $ CT1 "foo") "/ct_q?q=foo" 143 | t route (CT_Query $ Just $ CT2 42) "/ct_q?q=42" 144 | t route (CT_Query Nothing) "/ct_q" 145 | t route (CT_NewtypeQuery $ Just $ CT1 "foo") "/ct_ntq?q=foo" 146 | t route (CT_NewtypeQuery Nothing) "/ct_ntq" 147 | 148 | let testR2 (r :: RoutesDef PathInfo R2) = do 149 | t r (R2A Nothing) "/" 150 | t r (R2A $ Just "baz") "/?foo=baz" 151 | t r R2B "/bar" 152 | testR2 $ r2a <|||> r2b 153 | testR2 $ r2b <|||> r2a 154 | where 155 | t :: forall r. Show r => Eq r => RoutesDef PathInfo r -> r -> String -> Spec Unit 156 | t syn value expectedUrl = it (show value <> " == " <> expectedUrl) do 157 | let printed = printRoute syn value 158 | parsed = parseRoute syn =<< printed 159 | shouldEqual (Just expectedUrl) (showPath <$> printed) 160 | shouldEqual (Just value) parsed 161 | 162 | showPath (PathInfo segs query) = "/" <> showSegs <> qMark <> showQuery 163 | where 164 | showSegs = String.joinWith "/" segs 165 | qMark = if showQuery == "" then "" else "?" 166 | showQuery = String.joinWith "&" do 167 | Tuple k v <- Obj.toUnfoldable query 168 | pure $ k <> "=" <> v 169 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Reversible printing/parsing 2 | [![build](https://github.com/collegevine/purescript-intertwine/actions/workflows/build.yml/badge.svg)](https://github.com/collegevine/purescript-intertwine/actions/workflows/build.yml) 3 | 4 | This is a library for encoding serialization format descriptions that can be used as both printers and parsers for that format, without duplicating the code. 5 | 6 | The library is implemented in an uber-abstract way that supports printing/parsing arbitrary data structures, both as input and output. Two targets are included in the box - (1) parsing from/printing to text strings, and (2) parsing from/printing to browser URLs, with support for path segments and querystring parameters. The latter target was the primary inspiration for developing the library, and the former target is, at the moment, a toy one, more of a proof-of-concept. 7 | 8 | The implementation is loosely based on a [2010 paper by Rendel and Ostermann](http://www.informatik.uni-marburg.de/~rendel/unparse/rendel10invertible.pdf). 9 | 10 | ### Standing example 11 | This is a working example that uses the library for printing/parsing browser URLs (aka "routes"). 12 | To see how all the pieces fit together, read on. 13 | 14 | ```purescript 15 | data Route 16 | = Home 17 | | Profile String 18 | | Foo Int String 19 | 20 | routesDef :: forall syntax. Syntax syntax => syntax PathInfo Route 21 | routesDef = 22 | (Ctor::Ctor "Home") <|:|> end 23 | <|||> (Ctor::Ctor "Profile") <|:|> seg "profile" *|> segValue <|* end 24 | <|||> (Ctor::Ctor "Foo") <|:|> seg "foo" *|> query "id" <|*|> segValue <|* end 25 | 26 | printRoute routesDef Home == "/" 27 | printRoute routesDef (Profile "john") == "/profile/john" 28 | printRoute routesDef (Foo 42 "bar") == "/foo/bar?id=42" 29 | 30 | parseRoute routesDef "/" == Home 31 | parseRoute routesDef "/profile/mary" == Profile "mary" 32 | parseRoute routesDef "/foo/blurp?id=5" == Foo 5 "blurp" 33 | ``` 34 | 35 | ### Syntax 36 | What is called "syntax" here is either a "printer" or a "parser". We have to give them one collective name, so that we can refer to them both by it, which is necessary for expressing the encoding format without repeating it twice. In other words, we have to call both printer and parser _something_, and that word is "syntax". 37 | In the code this is expressed by having both printer and parser implement the `Syntax` type class. 38 | 39 | As can be seen from the signature of `routesDef` above, a thing that is a "syntax" (i.e. printer or parser) has two parameters: 40 | * The first parameter (`PathInfo` in the example) is the "target" of the syntax - i.e. input of the parser and output of the printer. 41 | * The second parameter (`Route` in the example) is the data type whose encoding we're describing - i.e. output of the parser and input of the printer. 42 | 43 | Thus, a `syntax a b` can be seen as an isomorphism (of sorts) between `a` and `b`. 44 | 45 | ### Primitives 46 | The smallest building blocks of a syntax are primitive printing/parsing operations. 47 | In the example above three such operations are visible: 48 | * `seg` means "there should be a path segment with exactly this value here". 49 | * `segValue` means "this path segment matches the next route constructor parameter". 50 | * `query` means "this route constructor parameter matches querystring parameter with the given key". 51 | * `end` signifies end of the route. 52 | 53 | These primitives are provided in `Data.Intertwine.Route`, but it is also possible to define your own. 54 | 55 | ### Combining primitives 56 | Unlike regular parser combinators (think Parsec), syntax elements combine right-to-left via the `<|*|>` operator, which is right-associative. When two syntax elements of types `a` and `b` combine, they produce a syntax element of type `(a, b)` (_using Haskell tuple notation here, because it's not as cumbersome_): 57 | 58 | ```haskell 59 | x :: syntax PathInfo a 60 | y :: syntax PathInfo b 61 | x <|*|> y :: syntax PathInfo (a, b) 62 | ``` 63 | 64 | This can go on to produce nested tuples: 65 | 66 | ```haskell 67 | z :: syntax PathInfo c 68 | z <|*|> x <|*|> y :: syntax PathInfo (c, (a, b)) 69 | ``` 70 | 71 | ### Injecting/applying constructors 72 | Once a sufficiently nested tuple of values is assembled, it can be "applied" to a constructor of the ADT that we're encoding. This is done via the operator `<|:|>` and the special type `Ctor`. The result of such operation would be another syntax that describes the type of the constructor: 73 | 74 | ```purescript 75 | data Foo 76 | = Bar c a b 77 | | Baz p q 78 | 79 | r :: syntax PathInfo Foo 80 | r = (Ctor::Ctor "Bar") <|:|> z <|*|> x <|*|> y 81 | ``` 82 | 83 | Here the term "apply constructor", again, means both directions: when parsing, we need to "inject" the accumulated tuple of values into the constructor to produce a value, and when printing, we need to produce such tuple from the value by "deconstructing" the constructor. This means that we can't just apply the constructor as a function, the way we would with regular parsers. Instead, we need to create a thing that can convert both directions - tuple to ADT or ADT to tuple. Sort of a "partial isomorphism". 84 | 85 | ### Iso 86 | The thing that can convert from ADT to tuple and back again - is kind of like an isomorphism, but not exactly. The difference is that it can _fail_. When parsing, it can obviously fail when the input is unexpected, but when printing, it can _also_ fail for a less obvious reason: as noted above, such "partial isomorphism" represents only one constructor of a potentially multi-constructor ADT, and therefore, it would fail when given an ADT value constructed by a different constructor. 87 | 88 | In the code such "partial isomorphisms" are represented by the `Iso` type, which is just a pair of functions: 89 | 90 | ```purescript 91 | newtype Iso a b = Iso { apply :: a -> Maybe b, inverse :: b -> Maybe b } 92 | ``` 93 | 94 | If we were to encode such isomorphism by hand, it would look something like this (using the above definition of `Foo`): 95 | 96 | ```purescript 97 | iso_bar :: Iso (c, (a, b)) Foo 98 | iso_bar = Iso 99 | { apply: \(c, (a, b)) -> 100 | Just (Bar c a b) 101 | , inverse: \foo -> case foo of 102 | Bar c a b -> Just (c, (a, b)) 103 | _ -> Nothing 104 | } 105 | ``` 106 | 107 | And then we can inject/apply this `Iso` to the tuple-typed syntax with the `<|$|>` operator: 108 | 109 | ```purescript 110 | r :: syntax PathInfo Foo 111 | r = iso_bar <|$|> z <|*|> x <|*|> y 112 | ``` 113 | 114 | ### Autogenerating Iso 115 | But of course, encoding such isomorphisms for every constructor isn't a lot of fun. Not to mention that it kills the whole idea of not repeating the code twice :-) 116 | 117 | So, in order to help with that, the library provides a way to do that automatically, based on `Generic`: 118 | 119 | ```purescript 120 | iso_bar = iso (SProxy :: SProxy "Bar") 121 | ``` 122 | 123 | Armed with this automation, we can construct our syntax description like this: 124 | 125 | ```purescript 126 | r :: syntax PathInfo Foo 127 | r = iso (SProxy :: SProxy "Bar") <|$|> z <|*|> x <|*|> y 128 | ``` 129 | 130 | ### Slightly shorter syntax 131 | To make the whole thing slightly more readable, we can shorten the notation `iso (SProxy :: SProxy "Bar")` slightly: we can get rid of the `iso` call by itroducing a new type `Ctor` (which is just like `SProxy`) and a new operator `<|:|>`, which would combine the effects of `iso` and `<|$|>`, producing a notation that reads more intuitively: 132 | 133 | ```purescript 134 | r :: syntax PathInfo Foo 135 | r = (Ctor::Ctor "Bar") <|:|> z <|*|> x <|*|> y 136 | ``` 137 | 138 | ### Combining syntaxes as alernatives 139 | The final piece of the puzzle is combining several alternative syntaxes with the operator `<|||>`. This part works pretty much the same as combining parsers in Parsec: 140 | 141 | ```purescript 142 | u :: syntax PathInfo a 143 | v :: syntax PathInfo a 144 | u <|||> v :: syntax PathInfo a 145 | ``` 146 | 147 | And so, combining all of the above, we get the final result: 148 | 149 | ```purescript 150 | x :: syntax PathInfo a 151 | y :: syntax PathInfo b 152 | z :: syntax PathInfo c 153 | p :: syntax PathInfo p 154 | q :: syntax PathInfo q 155 | 156 | -- x <|*|> y :: syntax PathInfo (a, b) 157 | -- z <|*|> x <|*|> y :: syntax PathInfo (c, (a, b)) 158 | 159 | data Foo 160 | = Bar c a b 161 | | Baz p q 162 | 163 | r :: syntax PathInfo Foo 164 | r = 165 | (Ctor::Ctor "Bar") <|:|> z <|*|> x <|*|> y 166 | <|||> (Ctor::Ctor "Baz") <|:|> p <|*|> q 167 | ``` 168 | 169 | ### Actually using the syntax 170 | Once we have the syntax definition, we can use `printRoute` and `parseRoute` to print or parse: 171 | 172 | ```purescript 173 | r :: syntax PathInfo Foo 174 | 175 | i = printRoute r (Bar c a b) 176 | j = parseRoute r i 177 | -- j == Bar c a b 178 | ``` 179 | -------------------------------------------------------------------------------- /src/Data/Intertwine/Syntax.purs: -------------------------------------------------------------------------------- 1 | module Data.Intertwine.Syntax 2 | ( class Syntax, atom, synApply, synInject, alt, (<|*|>), (<|$|>), (<|||>) 3 | , dropUnitLeft, (*|>) 4 | , dropUnitRight, (<|*) 5 | , Ctor(..) 6 | , injectConstructor, (<|:|>) 7 | , Printer, print 8 | , Parser, parse 9 | ) where 10 | 11 | import Prelude 12 | 13 | import Control.Alt ((<|>)) 14 | import Data.Intertwine.Iso (Iso(..)) 15 | import Data.Intertwine.MkIso (class MkIso, iso) 16 | import Data.Maybe (Maybe(..)) 17 | import Data.Symbol (SProxy(..)) 18 | import Data.Tuple (Tuple(..), fst, snd, swap) 19 | 20 | -- | An implementation of reversible printer-parser. 21 | -- | 22 | -- | The goal is to provide the means for expressing representation of data 23 | -- | structures in a way that allows the same representation to be used for both 24 | -- | parsing and printing, thus eliminating the need for code duplication and 25 | -- | ensuring that the printer and the parser don't diverge. 26 | -- | 27 | -- | The type variable `syntax` here represents either a printer or a parser 28 | -- | (see instances below). This printer-or-parser type, in turn, takes two 29 | -- | generic parameters: parsing/printing state and the value being 30 | -- | parsed/printed. 31 | -- | 32 | -- | The thought process goes like this: first, we realize that all data is 33 | -- | representable as sum types, so we limit ourselves to working with sum 34 | -- | types, or at least with something functionally equivalent. 35 | -- | 36 | -- | Next, since our syntax has to convert the value both ways, it follows that 37 | -- | we need, for every constructor of the sum type, a way to convert from its 38 | -- | parameters to the type and back again. This concept is represented by the 39 | -- | partial isomorphisms defined in ./Iso.purs (partial, because the conversion 40 | -- | is not always possible). These isomorphisms are then automatically 41 | -- | generated for each constructor via `Generic` - this generation code is in 42 | -- | ./MkIso.purs 43 | -- | 44 | -- | Once we have an isomorphism for a constructor, it is tempting to follow the 45 | -- | familiar parser structure: 46 | -- | 47 | -- | data Foo = Foo Int String 48 | -- | parseFoo = Foo <$> parseInt <*> parseString 49 | -- | 50 | -- | However, the usual Functor style won't work here, because our syntax needs 51 | -- | not only to produce values (which is what Functors handle), but also to 52 | -- | _consume_ them. 53 | -- | 54 | -- | In order to do that, we work the other way around - instead of gradually 55 | -- | accumulating the partially applied function within the functor from left to 56 | -- | right, we work from from right to left, first accumulating all the 57 | -- | parsers/printers that need to be "applied" to the constructor, and only 58 | -- | then injecting the constructor itself. 59 | -- | 60 | -- | Thus: 61 | -- | 62 | -- | pa :: Printer a 63 | -- | pb :: Printer b 64 | -- | pa `synApply` pb :: Printer (a, b) 65 | -- | 66 | -- | Combining the two printers gives us a printer that can print a tuple (same 67 | -- | for parsers). After that, such printer can be applied to the 68 | -- | constructor-derived Iso: 69 | -- | 70 | -- | p :: Printer (a, b) 71 | -- | i :: Iso (a, b) T 72 | -- | i `synInject` p :: Printer T 73 | -- | 74 | -- | To accomodate this, we generate the Iso instances for every constructor in 75 | -- | such a way that converts the constructor's parameters into tuples, e.g.: 76 | -- | 77 | -- | data T = A Int String | B Int String Boolean 78 | -- | iso "A" :: Iso (Int, String) T 79 | -- | iso "B" :: Iso (Int, (String, Boolean)) T 80 | -- | 81 | -- | This structure nicely matches the structure that results from repeatedly 82 | -- | `synApply`ing printers/parsers, provided both `synApply` and `synInject` 83 | -- | are right-associative: 84 | -- | 85 | -- | pInt :: Printer Int 86 | -- | pString :: Printer String 87 | -- | pBoolean :: Printer Boolean 88 | -- | (iso "B") `synInject` pInt `synApply` pString `synApply` pBoolean 89 | -- | 90 | -- | The `alt` operation allows to combine multiple printers/parsers and try 91 | -- | them out in order - very similar to the (<|>) operator from `Control.Alt`. 92 | -- | 93 | -- | Finally, the `atom` operation can be used for creating primitive parsers by 94 | -- | providing an `Iso (state, a) (state, ())`. The meaning of such `Iso` is the 95 | -- | following. The signature of a printing function is `state -> a -> Maybe 96 | -- | state`, taken to mean that a printing function takes the state accumulated 97 | -- | so far (e.g. a string that has been printed so far), then takes a value to 98 | -- | be printed, and returns new state. The `Maybe` indicates that printing may 99 | -- | fail. Conversely, the signature of a parsing function is `state -> Maybe 100 | -- | (a, state)`, taken to mean that the function takes the state (e.g. the tail 101 | -- | of the input string that hasn't yet been consumed) and returns both the 102 | -- | parsed value and the new state (e.g. the new string tail, after consuming 103 | -- | whatever was needed to parse the value). To recap: 104 | -- | 105 | -- | print :: state -> a -> Maybe state 106 | -- | parse :: state -> Maybe (a, state) 107 | -- | 108 | -- | Applying isomorphic manipulations to the signature - specifically, 109 | -- | uncurrying the arguments, commuting tuples, and noting that `x` is 110 | -- | isomorphic to `(x,())` - we can get: 111 | -- | 112 | -- | print :: (state, a) -> Maybe (state, ()) 113 | -- | parse :: (state, ()) -> Maybe (state, a) 114 | -- | 115 | -- | Which is equivalent to `Iso (state, a) (state, ())`. Thus, we can treat an 116 | -- | `Iso` as a pair of print+parse functions, and thus we can use it to 117 | -- | construct a primitive parser/printer. 118 | class Syntax syntax where 119 | atom :: forall a state. Iso (Tuple state a) (Tuple state Unit) -> syntax state a 120 | synApply :: forall a b state. syntax state a -> syntax state b -> syntax state (Tuple a b) 121 | synInject :: forall a b state. Iso a b -> syntax state a -> syntax state b 122 | alt :: forall a state. syntax state a -> syntax state a -> syntax state a 123 | 124 | 125 | -- | Combines two printers/parsers together, iyelding a printer/parser that can 126 | -- | print/parse a tuple of the two combined values. 127 | -- | 128 | -- | a :: syntax a 129 | -- | b :: syntax b 130 | -- | a <|*|> b :: syntax (a, b) 131 | infixr 5 synApply as <|*|> 132 | 133 | -- | Injects an `Iso` into a printer/parser on the right side, producing a 134 | -- | printer/parser of the type that is left type of the `Iso`. 135 | -- | 136 | -- | i :: Iso a (b, (c, d)) 137 | -- | p :: syntax (b, (c, d)) 138 | -- | i <|$|> p :: syntax a 139 | infixr 5 synInject as <|$|> 140 | 141 | -- | Combines two printers/parsers of the same type in a way that first attempts 142 | -- | the left one, and if it fails, falls back to the right. 143 | infixl 2 alt as <|||> 144 | 145 | -- | Combines a printer/parser that consumes/returns a unit with another 146 | -- | printer/parser in a way that the unit is dropped instead of becoming part 147 | -- | of a tuple, as it would with `<|*|>` 148 | -- | 149 | -- | u :: syntax Unit 150 | -- | a :: syntax a 151 | -- | u *|> a :: syntax a 152 | infixr 5 dropUnitLeft as *|> 153 | 154 | -- | Combines two printers/parsers similarly to `synApply`, but ignoring the 155 | -- | left printer/parser, provided it returns/consumes a unit. 156 | dropUnitLeft :: forall a syntax state. Syntax syntax => syntax state Unit -> syntax state a -> syntax state a 157 | dropUnitLeft u ab = i <|$|> u <|*|> ab 158 | where i = Iso { inverse: Just <<< Tuple unit, apply: Just <<< snd } 159 | 160 | -- | Combines a printer/parser that consumes/returns a unit with another 161 | -- | printer/parser in a way that the unit is dropped instead of becoming part 162 | -- | of a tuple, as it would with `<|*|>` 163 | -- | 164 | -- | u :: syntax Unit 165 | -- | a :: syntax a 166 | -- | a <|* u :: syntax a 167 | infixr 5 dropUnitRight as <|* 168 | 169 | -- | Combines two printers/parsers similarly to `synApply`, but ignoring the 170 | -- | right printer/parser, provided it returns/consumes a unit. 171 | dropUnitRight :: forall a syntax state. Syntax syntax => syntax state a -> syntax state Unit -> syntax state a 172 | dropUnitRight ab u = i <|$|> ab <|*|> u 173 | where i = Iso { inverse: \a -> Just $ Tuple a unit, apply: Just <<< fst } 174 | 175 | 176 | -- | This type is equivalent to `SProxy`, but provided here separately for the 177 | -- | purpose of shortening the code in combination with the `<|:|>` operator 178 | -- | (see comments there). 179 | data Ctor (name :: Symbol) = Ctor 180 | 181 | -- | Binds a constructor, whose name is encoded in the `Ctor` value, to the 182 | -- | given parser/printer. 183 | -- | 184 | -- | For example: 185 | -- | 186 | -- | data T = A String | B (Maybe Int) 187 | -- | 188 | -- | syntax = 189 | -- | (Ctor::Ctor "A") <|:|> value 190 | -- | <|||> (Ctor::Ctor "B") <|:|> query "id" 191 | -- | 192 | infixr 5 injectConstructor as <|:|> 193 | 194 | -- | Meant to be used as infix operator `<|:|>`, see comments on it. 195 | injectConstructor :: forall name args a syntax route. MkIso a name args => Syntax syntax => Ctor name -> syntax route args -> syntax route a 196 | injectConstructor _ args = synInject (iso (SProxy :: SProxy name)) args 197 | 198 | 199 | -- 200 | -- Printer 201 | -- 202 | 203 | -- | An implementation of `Syntax` for printing. 204 | newtype Printer state a = Printer (Tuple state a -> Maybe state) 205 | 206 | instance printerSyntax :: Syntax Printer where 207 | atom (Iso i) = Printer $ map fst <<< i.apply 208 | synApply (Printer pa) (Printer pb) = Printer \(Tuple state (Tuple a b)) -> do 209 | s' <- pa $ Tuple state a 210 | pb $ Tuple s' b 211 | synInject (Iso i) (Printer pb) = Printer \(Tuple state a) -> do 212 | b <- i.inverse a 213 | pb $ Tuple state b 214 | alt (Printer p1) (Printer p2) = Printer \x -> p1 x <|> p2 x 215 | 216 | -- | Runs a reversible syntax definition for printing, given an initial printer 217 | -- | state. 218 | -- | 219 | -- | The first parameter is supposed to be a polymorphic reversible definition 220 | -- | such as: 221 | -- | 222 | -- | s :: forall syntax. Syntax syntax => syntax a b 223 | -- | 224 | -- | Passing such parameter to this function would instantiate the `syntax` type 225 | -- | variable to `Printer`, and the printing will commence. 226 | print :: forall state a. Printer state a -> state -> a -> Maybe state 227 | print (Printer p) state a = p $ Tuple state a 228 | 229 | 230 | -- 231 | -- Parser 232 | -- 233 | 234 | -- | An implementation of `Syntax` for parsing. 235 | newtype Parser state a = Parser (state -> Maybe (Tuple a state)) 236 | 237 | instance parserSyntax :: Syntax Parser where 238 | atom (Iso i) = Parser \state -> swap <$> i.inverse (Tuple state unit) 239 | synApply (Parser pa) (Parser pb) = Parser \s -> do 240 | Tuple a s' <- pa s 241 | Tuple b s'' <- pb s' 242 | pure $ Tuple (Tuple a b) s'' 243 | synInject (Iso i) (Parser pb) = Parser \s -> do 244 | Tuple b s' <- pb s 245 | a <- i.apply b 246 | pure $ Tuple a s' 247 | alt (Parser p1) (Parser p2) = Parser \s -> p1 s <|> p2 s 248 | 249 | -- | Runs a reversible syntax definition for parsing, given an initial parser 250 | -- | state. 251 | -- | 252 | -- | The first parameter is supposed to be a polymorphic reversible definition 253 | -- | such as: 254 | -- | 255 | -- | s :: forall syntax. Syntax syntax => syntax a b 256 | -- | 257 | -- | Passing such parameter to this function would instantiate the `syntax` type 258 | -- | variable to `Parser`, and the parsing will commence. 259 | parse :: forall state a. Parser state a -> state -> Maybe (Tuple a state) 260 | parse (Parser p) s = p s 261 | --------------------------------------------------------------------------------