├── .npmrc ├── .gitignore ├── package.json ├── README.md ├── bower.json ├── test └── Test │ ├── Main.purs │ └── Control │ └── Applicative │ ├── Free │ └── Validation.purs │ └── Free.purs ├── .github └── workflows │ └── ci.yml └── src └── Control └── Applicative ├── Free └── Gen.purs └── Free.purs /.npmrc: -------------------------------------------------------------------------------- 1 | tag-version-prefix=v 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | .psci 3 | .psci_modules 4 | .pulp-cache 5 | npm-debug.log 6 | node_modules/ 7 | bower_components/ 8 | tmp/ 9 | output/ 10 | .psc-ide-port 11 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "private": true, 3 | "scripts": { 4 | "clean": "rimraf output && rimraf .pulp-cache && rimraf bench/output && rimraf bench/.pulp-cache", 5 | "test": "pulp test", 6 | "build": "pulp build -- --censor-lib --strict" 7 | }, 8 | "devDependencies": { 9 | "pulp": "^16.0.0-1", 10 | "purescript-psa": "^0.8.2", 11 | "rimraf": "^3.0.2" 12 | } 13 | } 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # purescript-freeap 2 | 3 | Free applicative functors for PureScript. 4 | 5 | See the following reference for further information. 6 | * [Free Applicative Functors](http://arxiv.org/abs/1403.0749) (Capriotti and Kaposi 2014) 7 | 8 | ## Installation 9 | 10 | ``` 11 | bower install purescript-freeap 12 | ``` 13 | 14 | ## Documentation 15 | 16 | * Module documentation is [published on Pursuit](https://pursuit.purescript.org/packages/purescript-freeap). 17 | -------------------------------------------------------------------------------- /bower.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-freeap", 3 | "license": "MIT", 4 | "ignore": ["*", "!src/**/*"], 5 | "repository": { 6 | "type": "git", 7 | "url": "https://github.com/ethul/purescript-freeap.git" 8 | }, 9 | "dependencies": { 10 | "purescript-exists": "^6.0.0", 11 | "purescript-const": "^6.0.0", 12 | "purescript-lists": "^7.0.0", 13 | "purescript-gen": "^4.0.0" 14 | }, 15 | "devDependencies": { 16 | "purescript-either": "^6.0.0", 17 | "purescript-integers": "^6.0.0", 18 | "purescript-console": "^6.0.0", 19 | "purescript-exceptions": "^6.0.0", 20 | "purescript-quickcheck-laws": "^7.0.0" 21 | } 22 | } 23 | -------------------------------------------------------------------------------- /test/Test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Prelude 4 | import Effect (Effect) 5 | import Effect.Console (log, logShow) 6 | import Test.Control.Applicative.Free as FreeTest 7 | import Test.Control.Applicative.Free.Validation as Validation 8 | 9 | main :: Effect Unit 10 | main = do 11 | log "\nvalid case:" 12 | logShow (Validation.runForm "Joe" "Smith" "28") 13 | 14 | log "\nempty last name:" 15 | logShow (Validation.runForm "Larry" "" "45") 16 | 17 | log "\ninvalid age:" 18 | logShow (Validation.runForm "Sue" "Larry" "A") 19 | 20 | log "\nanalyze:" 21 | logShow FreeTest.checkAnalyze 22 | 23 | log "\nstack safety:" 24 | logShow FreeTest.checkStack 25 | 26 | log "\nlaws:" 27 | FreeTest.check 28 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | branches: [master] 6 | pull_request: 7 | 8 | jobs: 9 | build: 10 | runs-on: ubuntu-latest 11 | steps: 12 | - uses: actions/checkout@v2 13 | 14 | - uses: purescript-contrib/setup-purescript@main 15 | with: 16 | purescript: "unstable" 17 | 18 | - uses: actions/setup-node@v2 19 | with: 20 | node-version: "14" 21 | 22 | - name: Install dependencies 23 | run: | 24 | npm install -g bower 25 | npm install 26 | bower install --production 27 | 28 | - name: Build source 29 | run: npm run-script build 30 | 31 | - name: Run tests 32 | run: | 33 | bower install 34 | npm run-script test --if-present 35 | -------------------------------------------------------------------------------- /src/Control/Applicative/Free/Gen.purs: -------------------------------------------------------------------------------- 1 | module Control.Applicative.Free.Gen where 2 | 3 | import Prelude 4 | 5 | import Control.Applicative.Free as F 6 | import Control.Monad.Gen (class MonadGen, oneOf) 7 | import Control.Monad.Rec.Class (class MonadRec) 8 | import Data.NonEmpty (NonEmpty(..)) 9 | 10 | genFree :: forall m f a 11 | . MonadGen m 12 | => MonadRec m 13 | => m (f Unit) 14 | -> m a 15 | -> m (a -> a) 16 | -> m (F.FreeAp f a) 17 | genFree genF genA genA2A = oneOf $ NonEmpty 18 | ( genA <#> pure) 19 | [ do 20 | fUnit <- genF 21 | a <- genA 22 | pure $ 23 | pure (const a) <*> F.liftFreeAp fUnit 24 | , do 25 | fUnit <- genF 26 | a <- genA 27 | a2a <- genA2A 28 | pure $ 29 | (pure (const a) <*> F.liftFreeAp fUnit) <#> a2a 30 | , do 31 | fUnit <- genF 32 | a <- genA 33 | a2a <- genA2A 34 | pure $ 35 | F.liftFreeAp fUnit <#> const a <#> a2a 36 | , do 37 | a <- genA 38 | a2a <- genA2A 39 | pure $ pure a <#> a2a 40 | ] 41 | -------------------------------------------------------------------------------- /test/Test/Control/Applicative/Free/Validation.purs: -------------------------------------------------------------------------------- 1 | module Test.Control.Applicative.Free.Validation 2 | ( User 3 | , runForm 4 | ) where 5 | 6 | import Prelude (class Show, show, (<<<), (==), (<$>), (<*>), (<>)) 7 | 8 | import Control.Applicative.Free (FreeAp, foldFreeAp, liftFreeAp) 9 | import Effect.Exception.Unsafe (unsafeThrow) 10 | 11 | import Data.Either (Either(..)) 12 | import Data.Int (fromString) 13 | import Data.Maybe (maybe) 14 | 15 | type Validator a = String -> Either String a 16 | 17 | newtype Field a = Field { name :: String, validator :: Validator a } 18 | 19 | type Form = FreeAp Field 20 | 21 | field :: forall a. String -> Validator a -> Form a 22 | field n v = liftFreeAp (Field { name: n, validator: v }) 23 | 24 | nes :: String -> Form String 25 | nes n = field n (\v -> if v == "" then Left (n <> ": Invalid NES") else Right v) 26 | 27 | int :: String -> Form Int 28 | int n = field n (maybe (Left (n <> ": Invalid Int")) Right <<< fromString) 29 | 30 | newtype User = User { firstName :: String, lastName :: String, age :: Int } 31 | 32 | form :: Form User 33 | form = 34 | User <$> ({ firstName: _ 35 | , lastName: _ 36 | , age: _ 37 | } <$> nes "First name" 38 | <*> nes "Last name" 39 | <*> int "Age") 40 | 41 | runForm :: String -> String -> String -> Either String User 42 | runForm first last age = 43 | foldFreeAp (\(Field x) -> validate x.name x.validator) form 44 | where 45 | validate :: forall a. String -> Validator a -> Either String a 46 | validate n v = 47 | case n of 48 | "First name" -> v first 49 | "Last name" -> v last 50 | "Age" -> v age 51 | _ -> unsafeThrow ("Unexpected field: " <> n) 52 | 53 | instance showUser :: Show User where 54 | show (User m) = m.firstName <> " " <> m.lastName <> " " <> show m.age 55 | -------------------------------------------------------------------------------- /test/Test/Control/Applicative/Free.purs: -------------------------------------------------------------------------------- 1 | module Test.Control.Applicative.Free 2 | ( checkAnalyze 3 | , checkStack 4 | , check 5 | ) where 6 | 7 | import Prelude 8 | 9 | import Control.Applicative.Free (FreeAp, liftFreeAp, analyzeFreeAp, retractFreeAp) 10 | import Control.Applicative.Free.Gen as GenF 11 | import Data.Either (Either(..)) 12 | import Data.Tuple (Tuple) 13 | import Effect (Effect) 14 | import Test.QuickCheck (class Arbitrary, class Coarbitrary, arbitrary) 15 | import Test.QuickCheck.Gen (Gen) 16 | import Test.QuickCheck.Laws (A, checkLaws) 17 | import Test.QuickCheck.Laws.Control as Control 18 | import Test.QuickCheck.Laws.Data as Data 19 | import Type.Proxy (Proxy(..)) 20 | 21 | 22 | data M r = A r | B r 23 | 24 | ma :: FreeAp M Unit 25 | ma = liftFreeAp (A unit) 26 | 27 | mb :: FreeAp M Unit 28 | mb = liftFreeAp (B unit) 29 | 30 | printM :: forall a. FreeAp M a -> String 31 | printM fr = 32 | analyzeFreeAp go fr 33 | where 34 | go (A _) = "A" 35 | go (B _) = "B" 36 | 37 | build :: Int -> FreeAp M Unit -> FreeAp M Unit -> FreeAp M Unit 38 | build 0 _ acc = acc 39 | build n x acc = build (n - 1) x (acc *> x) 40 | 41 | buildExpected :: Int -> String -> String -> String 42 | buildExpected 0 _ acc = acc 43 | buildExpected n x acc = buildExpected (n - 1) x (acc <> x) 44 | 45 | checkAnalyze :: Either String String 46 | checkAnalyze = 47 | if result == expected 48 | then Right result 49 | else Left (result <> " is not " <> expected) 50 | where 51 | result :: String 52 | result = printM (build 10 (ma *> mb) mb) 53 | 54 | expected :: String 55 | expected = buildExpected 10 "AB" "B" 56 | 57 | 58 | checkStack :: Either String String 59 | checkStack = 60 | if result == expected 61 | then Right "safe for 100000 node" 62 | else Left (result <> " is not " <> expected) 63 | where 64 | result :: String 65 | result = printM (build 100000 (ma *> mb) mb) 66 | 67 | expected :: String 68 | expected = buildExpected 100000 "AB" "B" 69 | 70 | 71 | newtype ArbFreeAp a = ArbFreeAp (FreeAp (Tuple (Array String)) a) 72 | 73 | instance arbitraryArbFreeAp :: (Coarbitrary a, Arbitrary a) => Arbitrary (ArbFreeAp a) where 74 | arbitrary = ArbFreeAp <$> 75 | GenF.genFree 76 | arbitrary 77 | (arbitrary :: Gen a) 78 | (arbitrary :: Gen (a -> a)) 79 | 80 | instance eqArbFreeAp :: Eq a => Eq (ArbFreeAp a) where 81 | eq (ArbFreeAp a) (ArbFreeAp b) = retractFreeAp a == retractFreeAp b 82 | 83 | derive newtype instance functorArbFreeAp :: Functor ArbFreeAp 84 | derive newtype instance applyArbFreeAp :: Apply ArbFreeAp 85 | derive newtype instance applicativeArbFreeAp :: Applicative ArbFreeAp 86 | 87 | check ∷ Effect Unit 88 | check = checkLaws "FreeAp" do 89 | Data.checkEq prxFree 90 | Data.checkFunctor prx2Free 91 | Control.checkApply prx2Free 92 | Control.checkApplicative prx2Free 93 | where 94 | prxFree = Proxy ∷ Proxy (ArbFreeAp A) 95 | prx2Free = Proxy ∷ Proxy ArbFreeAp 96 | -------------------------------------------------------------------------------- /src/Control/Applicative/Free.purs: -------------------------------------------------------------------------------- 1 | module Control.Applicative.Free 2 | ( FreeAp 3 | , liftFreeAp 4 | , retractFreeAp 5 | , foldFreeAp 6 | , hoistFreeAp 7 | , analyzeFreeAp 8 | ) where 9 | 10 | import Prelude 11 | 12 | import Data.Const (Const(..)) 13 | import Data.Either (Either(..)) 14 | import Data.List (List(..)) 15 | import Data.List.NonEmpty as NEL 16 | import Data.Newtype (unwrap) 17 | import Data.NonEmpty ((:|)) 18 | import Data.Tuple (Tuple(..)) 19 | import Unsafe.Coerce (unsafeCoerce) 20 | 21 | -- | The free applicative functor for a type constructor `f`. 22 | data FreeAp f a 23 | = Pure a 24 | | Lift (f a) 25 | | Ap (FreeAp f (Val -> a)) (FreeAp f Val) 26 | 27 | data Val 28 | 29 | -- | Lift a value described by the type constructor `f` into 30 | -- | the free applicative functor. 31 | liftFreeAp :: forall f a. f a -> FreeAp f a 32 | liftFreeAp = Lift 33 | 34 | type ApFunc g = { func :: g (Val -> Val), count :: Int } 35 | type FuncStack g = List (ApFunc g) 36 | type ValStack f = NEL.NonEmptyList (FreeAp f Val) 37 | type Stack f g = Tuple (FuncStack g) (ValStack f) 38 | 39 | -- | Run a free applicative functor with a natural transformation from 40 | -- | the type constructor `f` to the applicative functor `g`. 41 | foldFreeAp :: forall f g a. Applicative g => (f ~> g) -> FreeAp f a -> g a 42 | foldFreeAp nat z = 43 | unsafeToG $ go $ Tuple Nil (NEL.singleton $ unsafeToFVal z) 44 | where 45 | unsafeToG :: g Val -> g a 46 | unsafeToG = unsafeCoerce 47 | 48 | unsafeToFVal :: forall f' a'. FreeAp f' a' -> FreeAp f' Val 49 | unsafeToFVal = unsafeCoerce 50 | 51 | go :: Stack f g -> g Val 52 | go (Tuple fStack (NEL.NonEmptyList (val :| vals))) = 53 | case val of 54 | Pure a -> case goApply fStack vals (pure a) of 55 | Left x -> x 56 | Right s -> go s 57 | Lift a -> case goApply fStack vals (nat a) of 58 | Left x -> x 59 | Right s -> go s 60 | Ap l r -> 61 | let nextVals = NEL.NonEmptyList (r :| vals) 62 | in go $ goLeft fStack nextVals nat l 1 63 | 64 | goApply 65 | :: forall f g 66 | . Applicative g 67 | => FuncStack g 68 | -> List (FreeAp f Val) 69 | -> g Val 70 | -> Either (g Val) (Stack f g) 71 | goApply fStack vals gVal = 72 | case fStack of 73 | Nil -> Left gVal 74 | Cons f fs -> 75 | let gRes = f.func <*> gVal 76 | in if f.count == 1 then 77 | case fs of 78 | Nil -> 79 | -- here vals must be empty 80 | Left gRes 81 | _ -> goApply fs vals gRes 82 | else 83 | case vals of 84 | Nil -> Left gRes 85 | Cons val vals' -> 86 | Right $ Tuple 87 | (Cons { func: unsafeToGFunc gRes, count: f.count - 1 } fs) 88 | (NEL.NonEmptyList (val :| vals')) 89 | where 90 | unsafeToGFunc :: g Val -> g (Val -> Val) 91 | unsafeToGFunc = unsafeCoerce 92 | 93 | goLeft 94 | :: forall f g 95 | . Applicative g 96 | => FuncStack g 97 | -> ValStack f 98 | -> (f ~> g) 99 | -> FreeAp f (Val -> Val) 100 | -> Int 101 | -> Stack f g 102 | goLeft fStack valStack nat func count = case func of 103 | Pure a -> Tuple (Cons { func: pure a, count } fStack) valStack 104 | Lift a -> Tuple (Cons { func: nat a, count } fStack) valStack 105 | Ap l r -> goLeft fStack (NEL.cons r valStack) nat (unsafeToFunc l) (count + 1) 106 | where 107 | unsafeToFunc :: FreeAp f (Val -> Val -> Val) -> FreeAp f (Val -> Val) 108 | unsafeToFunc = unsafeCoerce 109 | 110 | -- | Run a free applicative functor using the applicative instance for 111 | -- | the type constructor `f`. 112 | retractFreeAp :: forall f a. Applicative f => FreeAp f a -> f a 113 | retractFreeAp = foldFreeAp identity 114 | 115 | -- | Natural transformation from `FreeAp f a` to `FreeAp g a` given a 116 | -- | natural transformation from `f` to `g`. 117 | hoistFreeAp :: forall f g a. (f ~> g) -> FreeAp f a -> FreeAp g a 118 | hoistFreeAp f = foldFreeAp (f >>> liftFreeAp) 119 | 120 | -- | Perform monoidal analysis over the free applicative functor `f`. 121 | analyzeFreeAp :: forall f m a. Monoid m => (forall b. f b -> m) -> FreeAp f a -> m 122 | analyzeFreeAp k = unwrap <<< foldFreeAp (Const <<< k) 123 | 124 | mkAp :: forall f a b. FreeAp f (b -> a) -> FreeAp f b -> FreeAp f a 125 | mkAp fba fb = Ap (coerceFunc fba) (coerceValue fb) 126 | where 127 | coerceFunc :: FreeAp f (b -> a) -> FreeAp f (Val -> a) 128 | coerceFunc = unsafeCoerce 129 | 130 | coerceValue :: FreeAp f b -> FreeAp f Val 131 | coerceValue = unsafeCoerce 132 | 133 | instance functorFreeAp :: Functor (FreeAp f) where 134 | map f x = mkAp (Pure f) x 135 | 136 | instance applyFreeAp :: Apply (FreeAp f) where 137 | apply fba fb = mkAp fba fb 138 | 139 | instance applicativeFreeAp :: Applicative (FreeAp f) where 140 | pure = Pure 141 | --------------------------------------------------------------------------------