Rou(ting)

Rou.hs

{-# LANGUAGE TypeOperators, TupleSections, LambdaCase, RecordWildCards, RankNTypes #-}

module Rou where

import Control.Lens
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Monoid
import Control.Monad
import Control.Applicative

data Loc = Loc
  { segs :: [String]
  , params :: Map String String
  } deriving ( Eq, Ord, Show )

loc :: String -> Loc
loc s = Loc (break s) mempty where
  break s = go s [] []
  go [] word acc = reverse (reverse word : acc)
  go ('/':s) word acc = go s [] (reverse word : acc)
  go (c:s) word acc = go s (c:word) acc

loc0 :: Loc
loc0 = Loc mempty mempty

locDone :: Loc -> Bool
locDone l = null (segs l)

behead :: MonadPlus m => [a] -> m (a, [a])
behead [] = mzero
behead (x : xs) = return (x, xs)

locPop :: MonadPlus m => Loc -> m (String, Loc)
locPop l = do
  (s, ss) <- behead (segs l)
  return (s, l { segs = ss })

locPush :: String -> Loc -> Loc
locPush s l = l { segs = s : segs l }

locGet :: MonadPlus m => String -> Loc -> m String
locGet k l = maybe mzero return $ Map.lookup k (params l)

locSet :: String -> String -> (Loc -> Loc)
locSet k v l = l { params = Map.insert k v (params l) }

data R a = R { up :: Loc -> [(a, Loc)]
             , dn :: a -> Maybe (Loc -> Loc)
             }

unit :: Eq a => a -> R a
unit a = R (\l -> [(a, l)])
           (\a' -> if a == a' then Just id else Nothing)

zero :: R ()
zero = unit ()

never :: R a
never = R (\l -> mzero) (\a -> mzero)

par :: R a -> R a -> R a
par r1 r2 = R up' dn' where
  up' l = up r1 l <> up r2 l
  dn' a = dn r1 a <|> dn r2 a

(//) :: R a -> R b -> R (a, b)
r1 // r2 = R up' dn' where
  up' l = do
    (a, l') <- up r1 l
    (b, l'') <- up r2 l'
    return ((a, b), l'')
  dn' (a, b) = do
    f1 <- dn r1 a
    f2 <- dn r2 b
    return (f1 . f2)

seg :: String -> R ()
seg s = R up' dn' where
  up' l = do (sh, l') <- locPop l
             if sh == s
             then return ((), l')
             else mzero
  dn' () = return (locPush s)

param :: String -> R String
param k = R up' dn' where
  up' l = do v <- locGet k l
             return (v, l)
  dn' v = Just (locSet k v)

pa :: R a -> Loc -> [a]
pa r = map fst . up r

pr :: R a -> a -> Maybe Loc
pr r = fmap ($ loc0) . dn r

ex = seg "foo" // seg "bar"