WIP

src/Servant/QQ.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
@@ -28,7 +30,10 @@
 -- Note the @/@ before a @QueryParam@!
 module Servant.QQ (sitemap) where
 
+import Control.Applicative ( (<$>) )
 import Control.Monad ( void )
+import Data.Monoid ( Monoid(..), (<>) )
+import Data.Maybe ( mapMaybe )
 import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
 import Language.Haskell.TH
     ( mkName, Type(AppT, ConT, LitT), TyLit(StrTyLit) )
@@ -62,6 +67,115 @@ import Servant.API.ReqBody ( ReqBody )
 import Servant.API.Sub ( (:>) )
 import Servant.API.Alternative ( (:<|>) )
 
+data MethodE
+data PathElemE
+data OptsE
+data SitemapE
+
+
+data Validation e a = Failure e
+                    | Success a
+
+instance Functor (Validation e) where
+    fmap _ (Failure e) = Failure e
+    fmap f (Success a) = Success (f a)
+
+data Exp a where
+    Method   :: String -> Exp MethodE
+    Slash    :: Exp PathElemE -> Exp PathElemE -> Exp PathElemE
+    PathElem :: String -> Exp PathElemE
+    Opts     :: String -> Exp OptsE
+    JoinOpts :: Exp OptsE -> Exp OptsE -> Exp OptsE
+    AddOpts  :: Exp SitemapE -> Exp OptsE -> Exp SitemapE
+    Line     :: Exp MethodE -> Exp PathElemE -> Exp SitemapE
+    Sitemap  :: Exp SitemapE -> Exp SitemapE -> Exp SitemapE
+
+data ParseError = ParseError Int String
+
+parseEverything :: String -> Exp SitemapE
+parseEverything str = removeComments <$> lines str
+    where removeComments = takeWhile (/= '#')
+          parseLines _  [] = []
+          parseLines lineno (x:xs) = case opts of
+                                         [] -> (parseUrlLine x):parseLines rest
+                                         xs -> (parseUrlLine x `AddOpts`
+            where (opts, rest) = span (startsWith ' ') xs
+
+
+
+parsePath :: String -> Exp PathElemE
+parsePath line = foldr1 Slash $ PathElem <$> wordsBy '/' line
+
+parseOpts :: Int -> [String] -> Either ParseError (Exp OptsE)
+parseOpts lineno lines = foldr1 JoinOpts $ Opts <$> lines
+
+parseUrlLine :: Int -> String -> Either ParseError (Exp SitemapE)
+parseUrlLine lineno line = case span '>' line of
+    ([], x) ->  Left $ ParseError lineno "Expected method and url before '>'"
+    (xs, ">") -> Left $ ParseError lineno "Expected type after '>'"
+    (xs, '>':ys) | length (words xs) /= 2 -> Left $ ParseError lineno "Expected method and url before '>'"
+                 | otherwise -> Line (Method met) (parsePath url)
+                     where met:url = words xs
+
+wordsBy :: Char -> String -> [String]
+wordsBy c s =  case dropWhile (== c) s of
+    "" -> []
+    s' -> w : words s''
+          where (w, s'') = break (== c) s'
+
+
+data SitemapParser = SitemapParser
+                   { methodParsers :: [String -> Maybe Type]
+                   , pathParsers   :: [String -> Maybe Type]
+                   , optsParsers   :: [String -> Maybe Type]
+                   }
+
+
+pFirstWE :: [a -> Maybe b] -> a -> c -> Validation c b
+pFirstWE fn a c = maybe (Failure c) Success $ pFirst fn a
+    where pFirst :: [a -> Maybe b] -> a -> Maybe b
+          pFirst fns s = case mapMaybe ($ s) fns of
+                           [] -> Nothing
+                           x:_ -> Just x
+
+
+joinWith :: Monoid err => (typ -> typ -> typ)
+                       -> Validation err typ
+                       -> Validation err typ
+                       -> Validation err typ
+joinWith mult (Success s1) (Success s2) = Success (s1 `mult` s2)
+joinWith _    (Failure e1) (Failure e2) = Failure (e1 <> e2)
+joinWith _    (Failure e1) _            = Failure e1
+joinWith _    _            (Failure e2) = Failure e2
+
+pathUnion :: Type -> Type -> Type
+pathUnion a = AppT (AppT (ConT ''(:>)) a)
+
+optsUnion :: Type -> Type -> Type
+optsUnion a = AppT (AppT (ConT ''(:<|>)) a)
+
+data UndefinedError = UndefinedPath String
+                    | UndefinedMethod String
+                    | UndefinedOpts String
+                    deriving (Eq, Show)
+
+evalPath :: SitemapParser -> Exp PathElemE -> Validation [UndefinedError] Type
+evalPath SitemapParser{..} (PathElem path) = pFirstWE pathParsers path [UndefinedPath path]
+evalPath sp (p1 `Slash` p2) = joinWith pathUnion (evalPath sp p1) (evalPath sp p2)
+
+evalMethod :: SitemapParser -> Exp MethodE -> Validation [UndefinedError] Type
+evalMethod SitemapParser{..} (Method met) = pFirstWE methodParsers met [UndefinedMethod met]
+
+evalOpts :: SitemapParser -> Exp OptsE -> Validation [UndefinedError] Type
+evalOpts SitemapParser{..} (Opts opt) = pFirstWE optsParsers opt [UndefinedOpts opt]
+evalOpts sp (o1 `JoinOpts` o2) = joinWith optsUnion (evalOpts sp o1) (evalOpts sp o2)
+
+
+addMethodParser, addPathParser, addOptsParser :: (String -> Maybe Type) -> SitemapParser -> SitemapParser
+addMethodParser a x@SitemapParser{..} = x{ methodParsers = methodParsers ++ [a] }
+addOptsParser a x@SitemapParser{..} = x{ optsParsers = optsParsers ++ [a] }
+addPathParser a x@SitemapParser{..} = x{ pathParsers = pathParsers ++ [a] }
+
 -- | Finally-tagless encoding for our DSL.
 -- Keeping 'repr'' and 'repr' distinct when writing functions with an
 -- @ExpSYM@ context ensures certain invariants (for instance, that there is