This commit is contained in:
Julian K. Arni 2015-01-28 12:52:35 +08:00
parent a1e1de91a9
commit d7e1f1230e

View file

@ -1,7 +1,9 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
@ -28,7 +30,10 @@
-- Note the @/@ before a @QueryParam@! -- Note the @/@ before a @QueryParam@!
module Servant.QQ (sitemap) where module Servant.QQ (sitemap) where
import Control.Applicative ( (<$>) )
import Control.Monad ( void ) import Control.Monad ( void )
import Data.Monoid ( Monoid(..), (<>) )
import Data.Maybe ( mapMaybe )
import Language.Haskell.TH.Quote ( QuasiQuoter(..) ) import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
import Language.Haskell.TH import Language.Haskell.TH
( mkName, Type(AppT, ConT, LitT), TyLit(StrTyLit) ) ( mkName, Type(AppT, ConT, LitT), TyLit(StrTyLit) )
@ -62,6 +67,115 @@ import Servant.API.ReqBody ( ReqBody )
import Servant.API.Sub ( (:>) ) import Servant.API.Sub ( (:>) )
import Servant.API.Alternative ( (:<|>) ) 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. -- | Finally-tagless encoding for our DSL.
-- Keeping 'repr'' and 'repr' distinct when writing functions with an -- Keeping 'repr'' and 'repr' distinct when writing functions with an
-- @ExpSYM@ context ensures certain invariants (for instance, that there is -- @ExpSYM@ context ensures certain invariants (for instance, that there is