@@ -1,7 +1,9 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE FlexibleInstances #-}
33{-# LANGUAGE FunctionalDependencies #-}
4+{-# LANGUAGE GADTs #-}
45{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE RecordWildCards #-}
57{-# LANGUAGE ScopedTypeVariables #-}
68{-# LANGUAGE TemplateHaskell #-}
79{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
@@ -28,7 +30,10 @@
2830-- Note the @/@ before a @QueryParam@!
2931module Servant.QQ (sitemap) where
3032
33+import Control.Applicative ( (<$>) )
3134import Control.Monad ( void )
35+import Data.Monoid ( Monoid(..), (<>) )
36+import Data.Maybe ( mapMaybe )
3237import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
3338import Language.Haskell.TH
3439 ( mkName, Type(AppT, ConT, LitT), TyLit(StrTyLit) )
@@ -62,6 +67,115 @@ import Servant.API.ReqBody ( ReqBody )
6267import Servant.API.Sub ( (:>) )
6368import Servant.API.Alternative ( (:<|>) )
6469
70+data MethodE
71+data PathElemE
72+data OptsE
73+data SitemapE
74+
75+
76+data Validation e a = Failure e
77+ | Success a
78+
79+instance Functor (Validation e) where
80+ fmap _ (Failure e) = Failure e
81+ fmap f (Success a) = Success (f a)
82+
83+data Exp a where
84+ Method :: String -> Exp MethodE
85+ Slash :: Exp PathElemE -> Exp PathElemE -> Exp PathElemE
86+ PathElem :: String -> Exp PathElemE
87+ Opts :: String -> Exp OptsE
88+ JoinOpts :: Exp OptsE -> Exp OptsE -> Exp OptsE
89+ AddOpts :: Exp SitemapE -> Exp OptsE -> Exp SitemapE
90+ Line :: Exp MethodE -> Exp PathElemE -> Exp SitemapE
91+ Sitemap :: Exp SitemapE -> Exp SitemapE -> Exp SitemapE
92+
93+data ParseError = ParseError Int String
94+
95+parseEverything :: String -> Exp SitemapE
96+parseEverything str = removeComments <$> lines str
97+ where removeComments = takeWhile (/= '#')
98+ parseLines _ [] = []
99+ parseLines lineno (x:xs) = case opts of
100+ [] -> (parseUrlLine x):parseLines rest
101+ xs -> (parseUrlLine x `AddOpts`
102+ where (opts, rest) = span (startsWith ' ') xs
103+
104+
105+
106+parsePath :: String -> Exp PathElemE
107+parsePath line = foldr1 Slash $ PathElem <$> wordsBy '/' line
108+
109+parseOpts :: Int -> [String] -> Either ParseError (Exp OptsE)
110+parseOpts lineno lines = foldr1 JoinOpts $ Opts <$> lines
111+
112+parseUrlLine :: Int -> String -> Either ParseError (Exp SitemapE)
113+parseUrlLine lineno line = case span '>' line of
114+ ([], x) -> Left $ ParseError lineno "Expected method and url before '>'"
115+ (xs, ">") -> Left $ ParseError lineno "Expected type after '>'"
116+ (xs, '>':ys) | length (words xs) /= 2 -> Left $ ParseError lineno "Expected method and url before '>'"
117+ | otherwise -> Line (Method met) (parsePath url)
118+ where met:url = words xs
119+
120+wordsBy :: Char -> String -> [String]
121+wordsBy c s = case dropWhile (== c) s of
122+ "" -> []
123+ s' -> w : words s''
124+ where (w, s'') = break (== c) s'
125+
126+
127+data SitemapParser = SitemapParser
128+ { methodParsers :: [String -> Maybe Type]
129+ , pathParsers :: [String -> Maybe Type]
130+ , optsParsers :: [String -> Maybe Type]
131+ }
132+
133+
134+pFirstWE :: [a -> Maybe b] -> a -> c -> Validation c b
135+pFirstWE fn a c = maybe (Failure c) Success $ pFirst fn a
136+ where pFirst :: [a -> Maybe b] -> a -> Maybe b
137+ pFirst fns s = case mapMaybe ($ s) fns of
138+ [] -> Nothing
139+ x:_ -> Just x
140+
141+
142+joinWith :: Monoid err => (typ -> typ -> typ)
143+ -> Validation err typ
144+ -> Validation err typ
145+ -> Validation err typ
146+joinWith mult (Success s1) (Success s2) = Success (s1 `mult` s2)
147+joinWith _ (Failure e1) (Failure e2) = Failure (e1 <> e2)
148+joinWith _ (Failure e1) _ = Failure e1
149+joinWith _ _ (Failure e2) = Failure e2
150+
151+pathUnion :: Type -> Type -> Type
152+pathUnion a = AppT (AppT (ConT ''(:>)) a)
153+
154+optsUnion :: Type -> Type -> Type
155+optsUnion a = AppT (AppT (ConT ''(:<|>)) a)
156+
157+data UndefinedError = UndefinedPath String
158+ | UndefinedMethod String
159+ | UndefinedOpts String
160+ deriving (Eq, Show)
161+
162+evalPath :: SitemapParser -> Exp PathElemE -> Validation [UndefinedError] Type
163+evalPath SitemapParser{..} (PathElem path) = pFirstWE pathParsers path [UndefinedPath path]
164+evalPath sp (p1 `Slash` p2) = joinWith pathUnion (evalPath sp p1) (evalPath sp p2)
165+
166+evalMethod :: SitemapParser -> Exp MethodE -> Validation [UndefinedError] Type
167+evalMethod SitemapParser{..} (Method met) = pFirstWE methodParsers met [UndefinedMethod met]
168+
169+evalOpts :: SitemapParser -> Exp OptsE -> Validation [UndefinedError] Type
170+evalOpts SitemapParser{..} (Opts opt) = pFirstWE optsParsers opt [UndefinedOpts opt]
171+evalOpts sp (o1 `JoinOpts` o2) = joinWith optsUnion (evalOpts sp o1) (evalOpts sp o2)
172+
173+
174+addMethodParser, addPathParser, addOptsParser :: (String -> Maybe Type) -> SitemapParser -> SitemapParser
175+addMethodParser a x@SitemapParser{..} = x{ methodParsers = methodParsers ++ [a] }
176+addOptsParser a x@SitemapParser{..} = x{ optsParsers = optsParsers ++ [a] }
177+addPathParser a x@SitemapParser{..} = x{ pathParsers = pathParsers ++ [a] }
178+
65179-- | Finally-tagless encoding for our DSL.
66180-- Keeping 'repr'' and 'repr' distinct when writing functions with an
67181-- @ExpSYM@ context ensures certain invariants (for instance, that there is