{-# LANGUAGE NamedFieldPuns, FlexibleInstances, TemplateHaskell #-}
module URITH where
import Data.String (IsString(..))
import Language.Haskell.TH.Syntax (Q, TExp(..), lift)
import Network.URI (URI(..), parseURI, URIAuth(..))
instance IsString (Q (TExp URI)) where
  fromString i =
    case parseURI i of
      Nothing -> fail ("Invalid URI: " ++ show i)
      Just uri -> liftURI uri
liftURI :: URI -> Q (TExp URI)
liftURI URI {uriScheme, uriAuthority, uriPath, uriQuery, uriFragment} =
  fmap TExp [|URI {uriScheme, uriAuthority = $(mauthority), uriPath, uriQuery, uriFragment}|]
  where
    mauthority = maybe [|Nothing|] liftAuthority uriAuthority
    liftAuthority URIAuth {uriUserInfo, uriRegName, uriPort} =
      [|Just (URIAuth {uriUserInfo, uriRegName, uriPort})|]