Skip to content

Instantly share code, notes, and snippets.

@notcome
Created Feb 21, 2015
Embed
What would you like to do?
simplified boomerang in Haskell and PureScript
module Main where
import Prelude hiding (id, (.))
import Control.Category
import Control.Monad ((>=>))
import Data.List (stripPrefix)
type URL = [String]
type Route a = (URL, a)
data Boom a b = Boom (a -> Maybe b) (b -> Maybe a)
inverse :: Boom a b -> Boom b a
inverse (Boom f g) = Boom g f
apply :: Boom a b -> a -> Maybe b
apply (Boom f g) = f
unapply :: Boom a b -> b -> Maybe a
unapply (Boom f g) = g
instance Category Boom where
id = Boom Just Just
g . f = Boom (apply f >=> apply g)
(unapply g >=> unapply f)
mkPure :: Boom URL URL -> Boom (Route r) (Route r)
mkPure (Boom from to) = Boom from' to'
where
comb b = (\a -> (a, b))
from' = (\(url, raw) -> fmap (comb raw) $ from url)
to' = (\(url, raw) -> fmap (comb raw) $ to url)
lit :: String -> Boom (Route r) (Route r)
lit s = mkPure $ Boom from to
where
from [] = Nothing
from (x:xs) = case stripPrefix s x of
Nothing -> Nothing
Just x' -> Just (x':xs)
to (x:xs) = Just $ (s ++ x):xs
anyString :: Boom (Route r) (Route (String, r))
anyString = Boom from to
where
from ([], raw) = Nothing
from (x:xs, raw)
| length x == 0 = Nothing
| otherwise = Just ("":xs, (x, raw))
to (x:xs, (s, r)) = Just ((x ++ s):xs, r)
infixl 0 </>
(</>) :: Boom (Route a) (Route b) -> Boom (Route b) (Route c) -> Boom (Route a) (Route c)
f </> g = f >>> eos >>> g
eos :: Boom (Route r) (Route r)
eos = mkPure $ Boom from to
where
from [] = Nothing
from ("":xs) = Just xs
from _ = Nothing
to l = Just $ [""] ++ l
main = putStrLn "Hello"
module Main where
import Control.Bind
import Control.Apply
import Data.Char
import Data.String (length, drop)
import Data.Maybe
import Data.Tuple
type URL = [String]
type Route a = Tuple URL a
data Boom a b = Boom (a -> Maybe b) (b -> Maybe a)
inverse :: forall a b. Boom a b -> Boom b a
inverse (Boom f g) = Boom g f
apply :: forall a b. Boom a b -> a -> Maybe b
apply (Boom f g) = f
unapply :: forall a b. Boom a b -> b -> Maybe a
unapply (Boom f g) = g
instance boomSemigroupoid :: Semigroupoid Boom where
(<<<) g f = Boom (apply f >=> apply g)
(unapply g >=> unapply f)
instance boomCategory :: Category Boom where
id = Boom Just Just
mkPure :: forall r. Boom URL URL -> Boom (Route r) (Route r)
mkPure (Boom from to) = Boom from' to'
where
comb b = (\a -> Tuple a b)
from' = (\(Tuple url raw) -> (comb raw) <$> from url)
to' = (\(Tuple url raw) -> (comb raw) <$> to url)
lit :: forall r. String -> Boom (Route r) (Route r)
lit s = mkPure $ Boom from to
where
from [] = Nothing
from (x:xs) = case stripPrefix s x of
Nothing -> Nothing
Just x' -> Just (x':xs)
to (x:xs) = Just $ (s ++ x):xs
anyString :: forall r. Boom (Route r) (Route (Tuple String r))
anyString = Boom from to
where
from (Tuple [] raw) = Nothing
from (Tuple (x:xs) raw)
| length x == 0 = Nothing
| otherwise = Just $ Tuple ("":xs) (Tuple x raw)
to (Tuple (x:xs) (Tuple s r)) = Just $ Tuple ((x <> s):xs) r
infixl 0 </>
(</>) :: forall a b c. Boom (Route a) (Route b) -> Boom (Route b) (Route c) -> Boom (Route a) (Route c)
(</>) f g = f >>> eos >>> g
eos :: forall r. Boom (Route r) (Route r)
eos = mkPure $ Boom from to
where
from [] = Nothing
from ("":xs) = Just xs
from _ = Nothing
to l = Just $ [""] ++ l
foreign import isPrefix
"""
function isPrefix (prefix) {
return function (test) {
var i = 0;
while (i < prefix.length && i < test.length) {
if (prefix[i] != test[i])
return false;
i ++;
}
if (i == prefix.length)
return true;
else
return false;
}
}
""" :: String -> String -> Boolean
stripPrefix :: String -> String -> Maybe String
stripPrefix p s =
if isPrefix p s
then Just $ drop (length p) s
else Nothing
@paluh

This comment has been minimized.

Copy link

@paluh paluh commented Mar 24, 2018

I'm writing my next bidirectional routing library and I want to name it purescript-boomboom. Would you mind (I'm going to add you to Credits section ;-)) if I do this?

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment