{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} module Snap.Snaplet.MongoDB.Parse ( mongo ) where import Control.Applicative --import qualified Data.Bson as BSON --import Data.Bson (Field ((:=))) import Data.Char (isSpace, digitToInt) import Data.Text (Text) import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax.Internals import Language.Haskell.TH.Quote import qualified Language.Haskell.Exts as H import Snap.Snaplet.MongoDB.MongoValue import Snap.Snaplet.MongoDB.MongoEntity import Text.Parsec hiding (many, (<|>)) mongo :: QuasiQuoter mongo = QuasiQuoter { quoteExp = mongoQuote } mongoQuote :: String -> Q Exp mongoQuote input = do expr <- runParserT parseMongo () "" input case expr of Left err -> error $ show err Right e -> return e type Parser = ParsecT String () Q parseMongo :: Parser Exp parseMongo = do doc <- whitespace *> topObjectDef return ((VarE 'toDocument) `AppE` doc) where topObjectDef = singleField <|> multipleFields singleField = (ListE . (: [])) <$> objectField multipleFields = objectDef whitespace :: Parser () whitespace = skipMany . satisfy $ isSpace lexeme :: Parser a -> Parser a lexeme p = p <* whitespace objectDef :: Parser Exp objectDef = (lexeme (char '{') "'{' at start of JSON object") *> (lexeme objectFields) <* (lexeme (char '}') "'}' at end of JSON object") objectFields :: Parser Exp objectFields = do ListE <$> sepBy objectField (lexeme $ char ',') objectField :: Parser Exp objectField = do name <- lexeme (identifier <|> stringLiteral) "identifier for field definition" _ <- lexeme (char ':') val <- lexeme (fieldValue <|> arrayValue <|> objectDef) ("value for field `" ++ name ++ "'") return (InfixE (Just . LitE . StringL $ name) (ConE '(:=)) (Just (AppE (VarE 'toValue) val))) arrayValue :: Parser Exp arrayValue = do (lexeme (char '[') "'[' at start of JSON array") *> (lexeme arrayElements) <* (lexeme (char ']') "']' at end of JSON array") where arrayElements = ListE . map ((VarE 'toValue) `AppE`) <$> sepBy (fieldValue <|> arrayValue <|> objectDef) (lexeme $ char ',') fieldValue :: Parser Exp fieldValue = do (stringValue <|> altBaseIntegerValue <|> numericalValue <|> boolNullValue <|> pasteValue) "field value" where stringValue = ((`SigE` (ConT ''Text)) . LitE . StringL) <$> stringLiteral numericalValue = do int <- decimal rl <- do (Left . (+ fromIntegral int) <$> denom) <|> pure (Right int) mEx <- option Nothing (Just <$> (oneOf "eE" *> (option id ((char '-' *> pure negate) <|> (char '+' *> pure id)) <*> decimal))) case mEx of Just ex -> pure $! ((`SigE` (ConT ''Double)) . LitE . RationalL. toRational $ either id fromIntegral rl * (10 ** fromIntegral ex)) Nothing -> case rl of Left f -> pure $! ((`SigE` (ConT ''Double)) . LitE . RationalL . toRational $ f) Right i -> pure $! ((`SigE` (ConT ''Integer)) . LitE . IntegerL $ i) altBaseIntegerValue = ((`SigE` (ConT ''Integer)) . LitE . IntegerL) <$> (hexadecimal <|> octal <|> binary) hexadecimal = try (char '0' *> oneOf "xX" *> numberBuilder 16 hexDigit) octal = try (char '0' *> oneOf "oO" *> numberBuilder 8 octDigit) binary = try (char '0' *> oneOf "bB" *> numberBuilder 2 (char '0' <|> char '1')) denom = let op = ((/ 10) .) . ((+) . (fromIntegral . digitToInt)) in pure (foldr op 0.0) <*> (char '.' *> many1 digit) boolNullValue = identifier >>= (\i -> case i of "true" -> pure . ConE $ 'True "false" -> pure . ConE $ 'False "null" -> pure . ConE $ '() _ -> unexpected i) pasteValue = do text <- (char '#' *> betweenBraces) case H.parseExp text of H.ParseOk expr -> return (mapExpToTH expr) H.ParseFailed _ msg -> parserFail msg betweenBraces :: Parser String betweenBraces = do between (char '{') (char '}') (concat <$> many insideBraces) where insideBraces = do ((\s -> '{' : s ++ "}") <$> betweenBraces) <|> ((: []) <$> satisfy (/= '}')) identifier :: Parser String identifier = try (ident "identifier") where ident = do c <- (letter <|> char '_' <|> char '$') cs <- many (alphaNum <|> char '_') return (c : cs) stringLiteral :: Parser String stringLiteral = (do str <- between (char '"') (char '"' "end of string") (many stringChar) return . foldr (maybe id (:)) "" $ str) "string literal" stringChar :: Parser (Maybe Char) stringChar = ( do c <- stringLetter return $ Just c) <|> stringEscape "string character" stringLetter :: Parser Char stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) stringEscape :: Parser (Maybe Char) stringEscape = char '\\' *> ((escapeGap *> return Nothing) <|> (escapeEmpty *> return Nothing) <|> (Just <$> escapeCode )) where escapeEmpty = char '&' escapeGap = many1 space >> (char '\\' "end of string gap") escapeCode = charEsc <|> charNum <|> charAscii <|> charControl "escape code" charControl = char '^' *> ((\c -> toEnum (fromEnum c - fromEnum 'A')) <$> upper) charNum = (toEnum . fromInteger) <$> (decimal <|> (char 'o' *> numberBuilder 8 octDigit) <|> (char 'x' *> numberBuilder 16 hexDigit)) charEsc = choice (map parseEsc escMap) where parseEsc (c, code) = char c *> pure code charAscii = choice (map parseAscii asciiMap) where parseAscii (asc, code) = try (string asc *> pure code) escMap = zip "abfnrtv\\\"\'" "\a\b\f\n\r\t\v\\\"\'" asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) ascii2codes = [ "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", "EM", "FS", "GS", "RS", "US", "SP" ] ascii3codes = [ "NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", "CAN", "SUB", "ESC", "DEL" ] ascii2 = [ '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI', '\EM', '\FS', '\GS', '\RS', '\US', '\SP' ] ascii3 = [ '\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL', '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB', '\CAN', '\SUB', '\ESC', '\DEL' ] numberBuilder :: Integer -> Parser Char -> Parser Integer numberBuilder base baseDigit = do digits <- many1 baseDigit let n = foldl (\x d -> base * x + toInteger (digitToInt d)) 0 digits seq n (return n) decimal :: Parser Integer decimal = numberBuilder 10 digit ------------------------------------------------------------------------------------------------------------------------ mapQName :: H.QName -> Name mapQName (H.Qual modu name) = Name (OccName $ strFromName name) (NameQ (ModName $ strFromModule modu)) mapQName (H.UnQual name) = mkName (strFromName name) mapQName (H.Special con) = case con of H.UnitCon -> '() H.ListCon -> '[] H.FunCon -> mkName "(->)" H.TupleCon _ n -> mkName ('(' : replicate n ',' ++ ")") H.Cons -> '(:) -- H.UnboxedSingleCon -> '(# #) H.UnboxedSingleCon -> error "No name for unboxed constructor" mapName :: H.Name -> Name mapName = mkName . strFromName strFromName :: H.Name -> String strFromName (H.Ident str) = str strFromName (H.Symbol op) = op strFromModule :: H.ModuleName -> String strFromModule (H.ModuleName name) = name mapDecl :: H.Decl -> [Dec] mapDecl (H.TypeDecl _ name binds typ) = [TySynD (mapName name) (map mapTypeBind binds) (mapTypeToTH typ)] mapDecl (H.TypeFamDecl _ name binds mKind) = [FamilyD TypeFam (mapName name) (map mapTypeBind binds) (maybe Nothing (Just . mapKind) mKind)] mapDecl (H.DataDecl _ H.DataType ctx name binds qConDecl deriv) = [DataD (mapContext ctx) (mapName name) (map mapTypeBind binds) (map mapQCon qConDecl) (map (mapQName . fst) deriv)] mapDecl (H.DataDecl _ H.NewType ctx name binds qConDecl deriv) = [NewtypeD (mapContext ctx) (mapName name) (map mapTypeBind binds) (mapQCon (head qConDecl)) (map (mapQName . fst) deriv)] mapDecl (H.GDataDecl _ _ _ _ _ _ _ _) = error "No support for GADTs in Template Haskell" mapDecl (H.DataFamDecl _ _ name binds mKind) = [FamilyD DataFam (mapName name) (map mapTypeBind binds) (maybe Nothing (Just . mapKind) mKind)] mapDecl (H.TypeInsDecl _ _ _) = error "No support for type instances" mapDecl (H.DataInsDecl _ H.DataType _ _ _) = error "No support for data instances" mapDecl (H.DataInsDecl _ H.NewType _ _ _ ) = error "No support for data instances" mapDecl (H.GDataInsDecl _ _ _ _ _ _) = error "No support for GADTs in Template Haskell" mapDecl (H.ClassDecl _ ctx name binds funDeps classDecls) = [ClassD (mapContext ctx) (mapName name) (map mapTypeBind binds) (map mapFunDep funDeps) (map mapClassDecl classDecls)] mapDecl (H.InstDecl _ ctx _ types instDecls) = [InstanceD (mapContext ctx) (mapTypeToTH (head types)) (map mapInstDecl instDecls)] mapDecl (H.DerivDecl _ _ _ _) = error "No support for standalone deriving declarations in Template Haskell" mapDecl (H.InfixDecl _ _ _ _) = error "No support for operator fixity declarations in Template Haskell" mapDecl (H.DefaultDecl _ _) = error "No support for default declarations in Template Haskell" mapDecl (H.SpliceDecl _ _) = error "Template Haskell brackets cannot be nested (without intervening splices)" mapDecl (H.TypeSig _ names typ) = map (flip SigD (mapTypeToTH typ) . mapName) names mapDecl (H.FunBind matches) = [FunD (matchName (head matches)) (map mapClause matches)] mapDecl (H.PatBind _ pat _ rhs binds) = [ValD (mapPatToTH pat) (mapRhs rhs) (mapBinds binds)] mapDecl (H.ForImp _ cc safe str name typ) = [ForeignD (ImportF (mapCC cc) (mapSafety safe) str (mapName name) (mapTypeToTH typ))] mapDecl (H.ForExp _ cc str name typ) = [ForeignD (ExportF (mapCC cc) str (mapName name) (mapTypeToTH typ))] mapDecl (H.RulePragmaDecl _ _) = error "No support for RULES pragma in Template Haskell" mapDecl (H.DeprPragmaDecl _ _) = error "No support for DEPRECATED pragma in Template Haskell" mapDecl (H.WarnPragmaDecl _ _) = error "No support for WARNING pragma in Template Haskell" mapDecl (H.InlineSig _ _ _ name) = [PragmaD (InlineP (mapQName name) (InlineSpec True False Nothing))] mapDecl (H.InlineConlikeSig _ _ _) = error "No current support for INLINE CONLIKE pragma" mapDecl (H.SpecSig _ name types) = [PragmaD (SpecialiseP (mapQName name) (mapTypeToTH (head types)) Nothing)] mapDecl (H.SpecInlineSig _ _ _ name types) = [PragmaD (SpecialiseP (mapQName name) (mapTypeToTH (head types)) (Just (InlineSpec True False Nothing)))] mapDecl (H.InstSig _ _ _ _) = error "No support for SPECIALISE instance pragma in Template Haskell (I think...)" mapDecl (H.AnnPragma _ _) = error "No support for ANN pragma in Template Haskell" mapCC :: H.CallConv -> Callconv mapCC (H.StdCall) = StdCall mapCC (H.CCall ) = CCall mapSafety :: H.Safety -> Safety mapSafety (H.PlayRisky ) = Unsafe mapSafety (H.PlaySafe t) = if t then Threadsafe else Safe matchName :: H.Match -> Name matchName (H.Match _ name _ _ _ _) = mapName name mapClause :: H.Match -> Clause mapClause (H.Match _ _ pats _ rhs binds) = Clause (map mapPatToTH pats) (mapRhs rhs) (mapBinds binds) mapRhs :: H.Rhs -> Body mapRhs (H.UnGuardedRhs e) = NormalB (mapExpToTH e) mapRhs (H.GuardedRhss guards) = GuardedB (map mapGRhs guards) where mapGRhs (H.GuardedRhs _ stmts e) = (PatG (map mapStmt stmts), mapExpToTH e) mapInstDecl :: H.InstDecl -> Dec mapInstDecl (H.InsDecl decl) = head (mapDecl decl) mapInstDecl _ = error "Unsupported" mapClassDecl :: H.ClassDecl -> Dec mapClassDecl (H.ClsDecl decl) = head (mapDecl decl) mapClassDecl _ = error "Unsupported" mapFunDep :: H.FunDep -> FunDep mapFunDep (H.FunDep xs ys) = FunDep (map mapName xs) (map mapName ys) mapQCon :: H.QualConDecl -> Con mapQCon (H.QualConDecl _ [] [] conDecl) = mapCon conDecl mapQCon (H.QualConDecl _ binds ctx conDecl) = ForallC (map mapTypeBind binds) (mapContext ctx) (mapCon conDecl) mapCon :: H.ConDecl -> Con mapCon (H.ConDecl name args) = NormalC (mapName name) (map mapBangType args) mapCon (H.InfixConDecl x name y) = InfixC (mapBangType x) (mapName name) (mapBangType y) mapCon (H.RecDecl name fields) = RecC (mapName name) $ map (uncurry mapFieldDecl) $ concatMap (uncurry ((. repeat) . zip)) fields mapFieldDecl :: H.Name -> H.BangType -> VarStrictType mapFieldDecl name bType = let (strict, typ) = mapBangType bType in (mapName name, strict, typ) mapBangType :: H.BangType -> StrictType mapBangType (H.BangedTy t) = (IsStrict, mapTypeToTH t) mapBangType (H.UnBangedTy t) = (NotStrict, mapTypeToTH t) mapBangType (H.UnpackedTy _) = error "No support for unboxed type (via UNPACK pragma) in Template Haskell" mapExpToTH :: H.Exp -> Exp mapExpToTH (H.Var name) = VarE (mapQName name) mapExpToTH (H.IPVar _) = error "No implicit parameter support" mapExpToTH (H.Con name) = ConE (mapQName name) mapExpToTH (H.Lit lit) = LitE (mapLitToTH lit) mapExpToTH (H.InfixApp l op r) = InfixE (Just $ mapExpToTH l) (mapQOpToTH op) (Just $ mapExpToTH r) mapExpToTH (H.App l r) = (mapExpToTH l) `AppE` (mapExpToTH r) mapExpToTH (H.NegApp o) = AppE (VarE 'negate) (mapExpToTH o) mapExpToTH (H.Lambda _ pat e) = LamE (map mapPatToTH pat) (mapExpToTH e) mapExpToTH (H.Let bs e) = LetE (mapBinds bs) (mapExpToTH e) mapExpToTH (H.If e t f) = CondE (mapExpToTH e) (mapExpToTH t) (mapExpToTH f) mapExpToTH (H.Case e ms) = CaseE (mapExpToTH e) (map mapAlt ms) mapExpToTH (H.Do s) = DoE (map mapStmt s) mapExpToTH (H.MDo _) = error "No support for mdo expressions" mapExpToTH (H.Tuple es) = TupE (map mapExpToTH es) mapExpToTH (H.TupleSection _) = error "Tuple sections currently not supported by template haskell" mapExpToTH (H.List es) = ListE (map mapExpToTH es) mapExpToTH (H.Paren e) = mapExpToTH e mapExpToTH (H.LeftSection e o) = InfixE (Just (mapExpToTH e)) (mapQOpToTH o) Nothing mapExpToTH (H.RightSection o e) = InfixE Nothing (mapQOpToTH o) (Just (mapExpToTH e)) mapExpToTH (H.RecConstr n fs) = RecConE (mapQName n) (map mapFieldUpdate fs) mapExpToTH (H.RecUpdate e fs) = RecUpdE (mapExpToTH e) (map mapFieldUpdate fs) mapExpToTH (H.EnumFrom e) = ArithSeqE (FromR (mapExpToTH e)) mapExpToTH (H.EnumFromTo x y) = ArithSeqE (FromToR (mapExpToTH x) (mapExpToTH y)) mapExpToTH (H.EnumFromThen x y) = ArithSeqE (FromThenR (mapExpToTH x) (mapExpToTH y)) mapExpToTH (H.EnumFromThenTo x y z) = ArithSeqE (FromThenToR (mapExpToTH x) (mapExpToTH y) (mapExpToTH z)) mapExpToTH (H.ListComp e qs) = CompE (map mapQualStmt qs ++ [NoBindS $ mapExpToTH e]) mapExpToTH (H.ParComp _ _) = error "No support for parallel list comprehensions in Template Haskell" mapExpToTH (H.ExpTypeSig _ e t) = SigE (mapExpToTH e) (mapTypeToTH t) mapExpToTH (H.VarQuote _) = error "Template Haskell brackets cannot be nested (without intervening splices)" mapExpToTH (H.TypQuote _) = error "Template Haskell brackets cannot be nested (without intervening splices)" mapExpToTH (H.BracketExp _) = error "Template Haskell brackets cannot be nested (without intervening splices)" mapExpToTH (H.SpliceExp _) = error "Template Haskell brackets cannot be nested (without intervening splices)" mapExpToTH (H.QuasiQuote _ _) = error "Template Haskell brackets cannot be nested (without intervening splices)" mapExpToTH (H.XTag _ _ _ _ _) = error "No support for XML extension in Template Haskell" mapExpToTH (H.XETag _ _ _ _) = error "No support for XML extension in Template Haskell" mapExpToTH (H.XPcdata _) = error "No support for XML extension in Template Haskell" mapExpToTH (H.XExpTag _) = error "No support for XML extension in Template Haskell" mapExpToTH (H.XChildTag _ _) = error "No support for XML extension in Template Haskell" mapExpToTH (H.CorePragma _ _) = error "No support for pragmas in Template Haskell" mapExpToTH (H.SCCPragma _ _) = error "No support for pragmas in Template Haskell" mapExpToTH (H.GenPragma _ _ _ _) = error "No support for pragmas in Template Haskell" mapExpToTH (H.Proc _ _ _) = error "No support for arrows 'proc' in Template Haskell" mapExpToTH (H.LeftArrApp _ _) = error "No support for left arrow application in Template Haskell" mapExpToTH (H.RightArrApp _ _) = error "No support for right arrow application in Template Haskell" mapExpToTH (H.LeftArrHighApp _ _) = error "No support for higher-order left arrow application in Template Haskell" mapExpToTH (H.RightArrHighApp _ _) = error "No support for higher-order right arrow application in Template Haskell" mapQualStmt :: H.QualStmt -> Stmt mapQualStmt (H.QualStmt stmt) = mapStmt stmt mapQualStmt _ = error "No support for SQL-like generalized list comprehensions (not supported by Template Haskell)" mapFieldUpdate :: H.FieldUpdate -> FieldExp mapFieldUpdate (H.FieldUpdate n e) = (mapQName n, mapExpToTH e) mapFieldUpdate (H.FieldPun _) = error "No support for field puns in update expressions" mapFieldUpdate (H.FieldWildcard ) = error "No support for field wildcards in update expressions" mapAlt :: H.Alt -> Match mapAlt (H.Alt _ p g bs) = Match (mapPatToTH p) (mapGuard g) (mapBinds bs) mapGuard :: H.GuardedAlts -> Body mapGuard (H.UnGuardedAlt e) = NormalB (mapExpToTH e) mapGuard (H.GuardedAlts gs) = GuardedB (map mapGAlt gs) where mapGAlt (H.GuardedAlt _ stmts e) = (PatG (map mapStmt stmts), mapExpToTH e) mapStmt :: H.Stmt -> Stmt mapStmt (H.Generator _ p e) = BindS (mapPatToTH p) (mapExpToTH e) mapStmt (H.Qualifier e) = NoBindS (mapExpToTH e) mapStmt (H.LetStmt bs) = LetS (mapBinds bs) mapStmt (H.RecStmt rs) = ParS [map mapStmt rs] mapBinds :: H.Binds -> [Dec] mapBinds (H.BDecls decls) = concatMap mapDecl decls mapBinds (H.IPBinds _) = error "No support for implicit parameter bindings" mapQOpToTH :: H.QOp -> Exp mapQOpToTH (H.QVarOp name) = VarE (mapQName name) mapQOpToTH (H.QConOp name) = ConE (mapQName name) {- mapQOpToTHT :: H.QOp -> Type mapQOpToTHT (H.QVarOp name) = VarT (mapQName name) mapQOpToTHT (H.QConOp name) = ConT (mapQName name) -} mapPatToTH :: H.Pat -> Pat mapPatToTH (H.PVar name) = VarP (mapName name) mapPatToTH (H.PLit lit) = LitP (mapLitToTH lit) mapPatToTH (H.PNeg _) = error "What?! (http://trac.haskell.org/haskell-src-exts/ticket/209)" mapPatToTH (H.PNPlusK _ _) = error "No support for N+K patterns" mapPatToTH (H.PInfixApp l n r) = InfixP (mapPatToTH l) (mapQName n) (mapPatToTH r) mapPatToTH (H.PApp n p) = ConP (mapQName n) (map mapPatToTH p) mapPatToTH (H.PTuple p) = TupP (map mapPatToTH p) mapPatToTH (H.PList p) = ListP (map mapPatToTH p) mapPatToTH (H.PParen p) = mapPatToTH p mapPatToTH (H.PRec n pf) = RecP (mapQName n) (map mapPatFieldToTH pf) mapPatToTH (H.PAsPat n p) = AsP (mapName n) (mapPatToTH p) mapPatToTH (H.PWildCard ) = WildP mapPatToTH (H.PIrrPat p) = TildeP (mapPatToTH p) mapPatToTH (H.PatTypeSig _ p t) = SigP (mapPatToTH p) (mapTypeToTH t) mapPatToTH (H.PViewPat _ _) = error "No support for view patterns" mapPatToTH (H.PRPat _) = error "I don't know what a PR pattern is" mapPatToTH (H.PXTag _ _ _ _ _) = error "No support for XML" mapPatToTH (H.PXETag _ _ _ _) = error "No support for XML" mapPatToTH (H.PXPcdata _) = error "No support for XML" mapPatToTH (H.PXPatTag _) = error "No support for XML" mapPatToTH (H.PXRPats _) = error "No support for XML" mapPatToTH (H.PExplTypeArg _ _) = error "No support for explicit type arguments" mapPatToTH (H.PQuasiQuote _ _) = error "No support for quasi-quotation" mapPatToTH (H.PBangPat _) = error "No support for bang patterns" mapTypeToTH :: H.Type -> Type mapTypeToTH (H.TyForall vb ctx t) = ForallT (maybe [] (map mapTypeBind) vb) (mapContext ctx) (mapTypeToTH t) mapTypeToTH (H.TyFun l r) = AppT (AppT ArrowT (mapTypeToTH l)) (mapTypeToTH r) mapTypeToTH (H.TyTuple _ ts) = foldl AppT (TupleT (length ts)) (map mapTypeToTH ts) mapTypeToTH (H.TyList t) = AppT ListT (mapTypeToTH t) mapTypeToTH (H.TyApp l r) = AppT (mapTypeToTH l) (mapTypeToTH r) mapTypeToTH (H.TyVar v) = VarT (mapName v) mapTypeToTH (H.TyCon c) = ConT (mapQName c) mapTypeToTH (H.TyParen t) = mapTypeToTH t mapTypeToTH (H.TyInfix l op r) = AppT (AppT (ConT $ mapQName op) (mapTypeToTH l)) (mapTypeToTH r) mapTypeToTH (H.TyKind _ _) = error "No support for types with explicit type kinds" mapTypeBind :: H.TyVarBind -> TyVarBndr mapTypeBind (H.KindedVar n k) = KindedTV (mapName n) (mapKind k) mapTypeBind (H.UnkindedVar n) = PlainTV (mapName n) mapKind :: H.Kind -> Kind mapKind (H.KindStar ) = StarK mapKind (H.KindBang ) = error "No support for bang-kinds" mapKind (H.KindFn x y) = ArrowK (mapKind x) (mapKind y) mapKind (H.KindParen k) = mapKind k mapKind (H.KindVar _) = error "No support for kind variables" mapContext :: H.Context -> Cxt mapContext = map mapAssert where mapAssert (H.ClassA q ts) = ClassP (mapQName q) (map mapTypeToTH ts) mapAssert (H.InfixA x q y) = ClassP (mapQName q) [mapTypeToTH x, mapTypeToTH y] mapAssert (H.IParam _ _) = error "No support for implicit parameter assertion" mapAssert (H.EqualP x y) = EqualP (mapTypeToTH x) (mapTypeToTH y) mapPatFieldToTH :: H.PatField -> FieldPat mapPatFieldToTH (H.PFieldPat name pat) = (mapQName name, mapPatToTH pat) mapPatFieldToTH (H.PFieldPun _) = error "field puns not yet supported" mapPatFieldToTH (H.PFieldWildcard ) = (mkName "", WildP) mapLitToTH :: H.Literal -> Lit mapLitToTH (H.Char c) = CharL c mapLitToTH (H.String s) = StringL s mapLitToTH (H.Int i) = IntegerL i mapLitToTH (H.Frac r) = RationalL r mapLitToTH (H.PrimInt i) = IntPrimL i mapLitToTH (H.PrimWord w) = WordPrimL w mapLitToTH (H.PrimFloat f) = FloatPrimL f mapLitToTH (H.PrimDouble d) = DoublePrimL d mapLitToTH (H.PrimChar c) = CharL c mapLitToTH (H.PrimString s) = StringPrimL s -- Local Variables: -- mode : Haskell -- fill-column : 120 -- default-justification : left -- End: