different parser for duckduckgo's bang format, and our own

2 files changed, 28 insertions, 7 deletions

diff --git a/src/Bangs.hs b/src/Bangs.hs
index 017d03b..274e96b 100644
--- a/src/Bangs.hs
+++ b/src/Bangs.hs
@@ -1,7 +1,13 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, DeriveGeneric, GeneralizedNewtypeDeriving #-}
 
-module Bangs (Bangs) where
+module Bangs (
+    DDGBangs,
+    toBangs,
+    Bangs
+) where
 
+import GHC.Prim
+import GHC.Generics (Generic)
 import Data.Aeson
 import Data.Aeson.Types (Parser)
 import Data.Text (Text)
@@ -10,10 +16,24 @@ import qualified Data.Map.Strict as M
 -- The map stored is equivalent to `HM.HashMap Shortcut URL`.
 -- For now, we're omitting category information as I don't want to force our
 -- own custom bangs to need that info.
-data Bangs = Bangs (M.Map Text Text) deriving (Show)
-instance FromJSON Bangs where
-    parseJSON b = fmap (Bangs . M.fromList) $
+newtype Bangs = Bangs {
+    unBangs :: M.Map Text Text
+} deriving (Show, Generic, FromJSON, ToJSON)
+
+newtype DDGBangs = DDGBangs (M.Map Text Text) deriving (Show)
+toBangs :: DDGBangs -> Bangs
+toBangs = coerce
+
+instance FromJSON DDGBangs where
+    parseJSON b = fmap (DDGBangs . M.fromList) $
         (parseJSON b :: Parser [Value])
             >>= mapM (withObject "Bang" $ \ob ->
                 (,) <$> ob .: "t" <*> ob .: "u")
 
+-- left-biased union
+instance Semigroup Bangs where
+    Bangs a <> Bangs b = Bangs $ a `M.union` b
+
+instance Monoid Bangs where
+    mempty = Bangs M.empty
+    mconcat = Bangs . M.unions . map unBangs
diff --git a/src/Main.hs b/src/Main.hs
index 997bbf5..1517ebd 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -2,10 +2,11 @@
 
 module Main (main) where
 
-import Yesod
+import Data.Aeson
 import Data.ByteString (ByteString)
 import Data.IORef
 import Network.HTTP.Simple
+import Yesod
 
 import Bangs
 
@@ -17,5 +18,5 @@ data Search = Search {
 
 main :: IO ()
 main = do
-    ans <- (httpJSON "https://duckduckgo.com/bang.v255.js") :: IO (Response Bangs)
+    ans <- (httpJSON "https://duckduckgo.com/bang.v255.js") :: IO (Response DDGBangs)
     print ans