{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.PublicSuffix.TH
( moduleDirectory
, mkRules
) where
import Control.Applicative
import Data.Char
import Data.PublicSuffix.Types
import Language.Haskell.TH
import qualified Language.Haskell.TH.Syntax as TH
import System.FilePath (dropFileName)
import Prelude
readRulesFile :: FilePath -> IO [Rule]
readRulesFile inputFile = do
body <- readFile inputFile
return $ parseRules body
isComment :: String -> Bool
isComment ('/':'/':_) = True
isComment _ = False
splitDot :: String -> [String]
splitDot [] = [""]
splitDot x =
let (y, z) = break (== '.') x in
y : (if z == "" then [] else splitDot $ drop 1 z)
parseRules :: String -> [Rule]
parseRules body =
map parseRule $
filter ruleLine $
map (takeWhile (not . isSpace)) $
lines body
where
ruleLine line = not $ isComment line || null line
parseRule :: String -> Rule
parseRule line = case line of
[] -> error "parseRule: unexpected empty line"
'!':rest -> Rule { isException = True, ruleLabels = splitDot rest }
_ -> Rule { isException = False, ruleLabels = splitDot line }
moduleDirectory :: Q Exp
moduleDirectory =
TH.LitE . TH.StringL . dropFileName . TH.loc_filename <$> TH.qLocation
mkRules :: String -> FilePath -> Q [Dec]
mkRules funName filePath = do
rules <- runIO $ readRulesFile filePath
rulesE <- mapM genRule rules
return
[ SigD (mkName "rules") (AppT ListT (ConT ''Rule))
, FunD (mkName funName) [Clause [] (NormalB $ ListE $ rulesE) []]
]
where
genRule :: Rule -> ExpQ
genRule rule = do
ruleE <- [| Rule |]
trueE <- [| True |]
falseE <- [| False |]
return $ foldl1 AppE
[ ruleE
, if isException rule then trueE else falseE
, ListE $ reverse $ map (\x -> LitE $ StringL x) (ruleLabels rule)
]