diff --git a/dist/build/GoldenStub/GoldenStub-tmp/GoldenStub.hs b/dist/build/GoldenStub/GoldenStub-tmp/GoldenStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/GoldenStub/GoldenStub-tmp/GoldenStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import Golden ( tests ) +main :: IO () +main = stubMain tests diff --git a/dist/build/ShouldNotTypecheckStub/ShouldNotTypecheckStub-tmp/ShouldNotTypecheckStub.hs b/dist/build/ShouldNotTypecheckStub/ShouldNotTypecheckStub-tmp/ShouldNotTypecheckStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/ShouldNotTypecheckStub/ShouldNotTypecheckStub-tmp/ShouldNotTypecheckStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import ShouldNotTypecheck ( tests ) +main :: IO () +main = stubMain tests diff --git a/src/Text/XML/Twiml.hs b/src/Text/XML/Twiml.hs --- a/src/Text/XML/Twiml.hs +++ b/src/Text/XML/Twiml.hs @@ -1,43 +1,19 @@ -{-#LANGUAGE FlexibleContexts #-} -{-#LANGUAGE FlexibleInstances #-} -{-#LANGUAGE MultiParamTypeClasses #-} -{-#LANGUAGE RankNTypes #-} - +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +------------------------------------------------------------------------------- module Text.XML.Twiml - ( Response - , respond - , module Text.XML.Twiml.Verbs - , module Text.XML.Twiml.Types - , module Text.XML.Twiml.Internal + ( MessagingTwiml(..) + , VoiceTwiml(..) + , response + , module X ) where -import Text.XML.Twiml.Internal -import Text.XML.Twiml.Verbs -import Text.XML.Twiml.Types hiding - ( Lens - , Lens' - , lens - , (^.) - , over - , to' - , Fix - , Foldable - , Base - , Yes - , No - ) - -{- Twiml Response -} - --- | The root element of Twilio's XML Markup is the @\@ element. See --- . -newtype Response = Response { fromResponse :: Twiml' Response } - -instance Twiml Response Response where - toTwiml' = fromResponse - -instance Show Response where - show = show . toTwiml' - -respond :: Twiml Response t => t -> Response -respond = Response . toTwiml' +import Text.XML.Twiml.Internal.Twiml +import Text.XML.Twiml.Lenses as X +import Text.XML.Twiml.Types as X +import Text.XML.Twiml.Verbs as X diff --git a/src/Text/XML/Twiml/Internal.hs b/src/Text/XML/Twiml/Internal.hs --- a/src/Text/XML/Twiml/Internal.hs +++ b/src/Text/XML/Twiml/Internal.hs @@ -1,233 +1,363 @@ -{-#LANGUAGE EmptyDataDecls #-} -{-#LANGUAGE FlexibleContexts #-} -{-#LANGUAGE FlexibleInstances #-} -{-#LANGUAGE FunctionalDependencies #-} -{-#LANGUAGE GADTs #-} -{-#LANGUAGE MultiParamTypeClasses #-} -{-#LANGUAGE RankNTypes #-} -{-#LANGUAGE TypeFamilies #-} -{-#LANGUAGE UndecidableInstances #-} -{-#LANGUAGE TypeOperators #-} - +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml.Internal +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +-- +-- This module exports the machinery necessary to define TwiML in an extensible +-- way. +------------------------------------------------------------------------------- module Text.XML.Twiml.Internal - ( TwimlF(..) - , Twiml(..) - , Twiml' + ( -- * Data types à la carte + -- $datatypes + (:+:)(..) + , (:<:)(..) + -- * Elem (∉) + , Elem + , type (∉) + -- * Indexed + -- $indexed + , Functor1(..) + , NFData1(..) + , Show1(..) + -- ** Applicative + , IxApplicative(..) + -- ** Monad + , IxMonad(..) + -- ** Free + , IxFree(..) + , iliftF + , type (++) + -- * XML + -- $xml + , SomeNode(..) + , ToSomeNode(..) + , ToXML(..) + , ToElement(..) + , ToAttrs(..) + , ToAttrValue(..) + , makeAttr + , makeAttr' + , makeAttrs + , makeElement ) where -import Text.XML.Twiml.Types - -import Data.Maybe (catMaybes, fromMaybe) +import Control.DeepSeq (NFData(..)) +import Data.Data +import Data.Maybe (mapMaybe) +import GHC.Generics (Generic) import Text.XML.Light -{- TwimlF -} +{- Data types à la carte -} --- | This is the 'Functor' we use when folding 'Twiml'. -data TwimlF p a where - EndF :: TwimlF p a - SayF :: SayAttributes - -> String - -> a - -> TwimlF p a - PlayF :: PlayAttributes - -> Maybe URL - -> a - -> TwimlF p a - GatherF :: (p :/~ Gather') - => GatherAttributes - -> Twiml' Gather' - -> a - -> TwimlF p a - RecordF :: (p :/~ Gather') - => RecordAttributes - -> a - -> TwimlF p a - SmsF :: (p :/~ Gather') - => SmsAttributes - -> String - -> a - -> TwimlF p a - DialF :: (p :/~ Gather') - => DialAttributes - -> Either DialNoun String - -> a - -> TwimlF p a - EnqueueF :: (p :/~ Gather') - => EnqueueAttributes - -> String - -> a - -> TwimlF p a - LeaveF :: (p :/~ Gather') - => TwimlF p a - HangupF :: (p :/~ Gather') - => TwimlF p a - RedirectF :: (p :/~ Gather') - => RedirectAttributes - -> URL - -> TwimlF p a - RejectF :: (p :/~ Gather') - => RejectAttributes - -> TwimlF p a - PauseF :: PauseAttributes - -> a - -> TwimlF p a +-- $datatypes The @(':+:')@ data type and @(':<:')@ type class come from +-- Swierstra's +-- . -instance Functor (TwimlF p) where - fmap f EndF = EndF - fmap f (SayF a b c) = SayF a b $ f c - fmap f (PlayF a b c) = PlayF a b $ f c - fmap f (GatherF a b c) = GatherF a b $ f c - fmap f (RecordF a b) = RecordF a $ f b - fmap f (SmsF a b c) = SmsF a b $ f c - fmap f (DialF a b c) = DialF a b $ f c - fmap f (EnqueueF a b c) = EnqueueF a b $ f c - fmap f LeaveF = LeaveF - fmap f HangupF = HangupF - fmap f (RedirectF a b) = RedirectF a b - fmap f (RejectF a) = RejectF a - fmap f (PauseF a b) = PauseF a $ f b +data (f :+: g) a = InL (f a) | InR (g a) + deriving (Eq, Functor, Generic, NFData, Ord, Read, Show) -type instance Base (Fix (TwimlF p)) = TwimlF p +infixr 7 :+: -instance Foldable (Fix (TwimlF p)) where - project = unFix +deriving instance (Data a, Data (f a), Data (g a), Typeable f, Typeable g) => Data ((f :+: g) a) -{- Twiml -} +class (Functor sub, Functor sup) => sub :<: sup where + inj :: sub a -> sup a + prj :: sup a -> Maybe (sub a) -type Twiml' p = Fix (TwimlF p) +instance Functor f => f :<: f where + inj = id + prj = Just -class Twiml p t | t -> p where - toTwiml' :: t -> Twiml' p +instance (Functor f, Functor g) => f :<: (f :+: g) where + inj = InL + prj (InL f) = Just f + prj _ = Nothing -instance Twiml p (Twiml' p) where - toTwiml' = id +instance (Functor f, Functor g, Functor h, f :<: g) => f :<: (h :+: g) where + inj = InR . inj + prj (InR g) = prj g + prj _ = Nothing -instance Show (Twiml' p) where - show twiml = "\n" ++ (ppElement . unode "Response" $ toXML twiml) ++ "\n" +{- Elem -} -(&) :: a -> (a -> b) -> b -a & f = f a -{-# INLINE (&) #-} +-- $elem 'TwimlF uses @∉@ in order to enforce nesting rules. -string :: String -> Content -string str = Text $ CData CDataText str Nothing +-- | 'Elem' is like a promoted @elem@: it allows us to check whether a type +-- constructor @t@ is present in a list of type constructors @ts@. +type family Elem (t :: k) (ts :: [k]) :: Bool where + Elem t '[] = 'False + Elem t (t ': ts) = 'True + Elem t (u ': ts) = Elem t ts -showBool :: Bool -> String -showBool True = "true" -showBool False = "false" +{- @(∉)@ -} -showVoice :: Voice -> String -showVoice (Man _) = "man" -showVoice (Woman _) = "woman" -showVoice (Alice _) = "alice" +-- | @t ∉ ts@ is shorthand for asserting that a type constructor @t@ is not +-- present in a list of types constructors @ts@. +type t ∉ ts = Elem t ts ~ 'False -showLang :: Voice -> Maybe String -showLang (Man lang) = fmap show lang -showLang (Woman lang) = fmap show lang -showLang (Alice lang) = fmap show lang +{- Indexed -} -dialNoun :: Either DialNoun String -> Content -dialNoun (Left (Number a b)) - = Elem $ unode "Number" (string b) & add_attrs (catMaybes - [ fmap ((Attr $ unqual "sendDigits") . concatMap show) $ numberSendDigits a - , fmap ((Attr $ unqual "url") . show) $ numberURL a - , fmap ((Attr $ unqual "method") . show) $ numberMethod a - ]) -dialNoun (Left (Sip a b)) - = Elem $ unode "Sip" (string $ show b) & add_attrs (catMaybes - [ fmap ((Attr $ unqual "url") . show) $ sipURL a - , fmap ((Attr $ unqual "method") . show) $ sipMethod a - ]) -dialNoun (Left (Client a b)) - = Elem $ unode "Client" (string b) & add_attrs (catMaybes - [ fmap ((Attr $ unqual "url") . show) $ clientURL a - , fmap ((Attr $ unqual "method") . show) $ clientMethod a - ]) -dialNoun (Left (Conference a b)) - = Elem $ unode "Conference" (string b) & add_attrs (catMaybes - [ fmap ((Attr $ unqual "muted") . showBool) $ conferenceMuted a - , fmap ((Attr $ unqual "beep") . show) $ conferenceBeep a - , fmap ((Attr $ unqual "startConferenceOnEnter") . showBool) $ conferenceStartOnEnter a - , fmap ((Attr $ unqual "endConferenceOnExit") . showBool) $ conferenceEndOnExit a - , fmap ((Attr $ unqual "waitUrl") . show) $ conferenceWaitURL a - , fmap ((Attr $ unqual "waitMethod") . show) $ conferenceWaitMethod a - , fmap ((Attr $ unqual "maxParticipants") . show) $ conferenceMaxParticipants a - ]) -dialNoun (Left (Queue a b)) - = Elem $ unode "Queue" (string b) & add_attrs (catMaybes - [ fmap ((Attr $ unqual "url") . show) $ queueURL a - , fmap ((Attr $ unqual "method") . show) $ queueMethod a - ]) -dialNoun (Right str) = string str +-- $indexed Everything in this section comes from +-- on a +-- StackOverflow question about indexed free monads. Some names have been +-- changed to follow the patterns established by +-- and +-- . -toXML :: Twiml' p -> [Element] -toXML = cata go where - go EndF = [] - go (SayF a b c) = unode "Say" (string b) & add_attrs (catMaybes - [ fmap ((Attr $ unqual "voice") . showVoice) $ sayVoice a - , fmap ((Attr $ unqual "loop") . show) $ sayLoop a - , fmap (Attr $ unqual "language") $ (sayVoice a >>= showLang) - ]) : c - go (PlayF a b c) = (fromMaybe (unode "Play" ()) (fmap (unode "Play" . string . show) b)) - & add_attrs (catMaybes - [ fmap ((Attr $ unqual "loop") . show) $ playLoop a - , fmap ((Attr $ unqual "digits") . concatMap show) $ playDigits a - ]) : c - go (GatherF a b c) = unode "Gather" (toXML b) & add_attrs (catMaybes - [ fmap ((Attr $ unqual "action") . show) $ gatherAction a - , fmap ((Attr $ unqual "method") . show) $ gatherMethod a - , fmap ((Attr $ unqual "timeout") . show) $ gatherTimeout a - , fmap ((Attr $ unqual "finishOnKey") . show) $ gatherFinishOnKey a - , fmap ((Attr $ unqual "numDigits") . show) $ gatherNumDigits a - ]) : c - go (RecordF a b) = unode "Record" () & add_attrs (catMaybes - [ fmap ((Attr $ unqual "action") . show) $ recordAction a - , fmap ((Attr $ unqual "method") . show) $ recordMethod a - , fmap ((Attr $ unqual "timeout") . show) $ recordTimeout a - , fmap ((Attr $ unqual "finishOnKey") . show) $ recordFinishOnKey a - , fmap ((Attr $ unqual "maxLength") . show) $ recordMaxLength a - , fmap ((Attr $ unqual "transcribe") . showBool) $ recordTranscribe a - , fmap ((Attr $ unqual "transcribeCallback") . show) $ recordTranscribeCallback a - , fmap ((Attr $ unqual "playBeep") . show) $ recordPlayBeep a - ]) : b - go (SmsF a b c) = unode "Sms" (string b) & add_attrs (catMaybes - [ fmap ((Attr $ unqual "to") . show) $ smsTo a - , fmap ((Attr $ unqual "from") . show) $ smsFrom a - , fmap ((Attr $ unqual "action") . show) $ smsAction a - , fmap ((Attr $ unqual "method") . show) $ smsMethod a - , fmap ((Attr $ unqual "statusCallback") . show) $ smsStatusCallback a - ]) : c - go (DialF a b c) = unode "Dial" (dialNoun b) & add_attrs (catMaybes - [ fmap ((Attr $ unqual "action") . show) $ dialAction a - , fmap ((Attr $ unqual "method") . show) $ dialMethod a - , fmap ((Attr $ unqual "timeout") . show) $ dialTimeout a - , fmap ((Attr $ unqual "hangupOnStar") . showBool) $ dialHangupOnStar a - , fmap ((Attr $ unqual "timeLimit") . show) $ dialTimeLimit a - , fmap (Attr $ unqual "callerId") $ dialCallerId a - , fmap ((Attr $ unqual "record") . showBool) $ dialRecord a - ]) : c - go (EnqueueF a b c) = unode "Enqueue" (string b) & add_attrs (catMaybes - [ fmap ((Attr $ unqual "action") . show) $ enqueueAction a - , fmap ((Attr $ unqual "method") . show) $ enqueueMethod a - , fmap ((Attr $ unqual "waitUrl") . show) $ enqueueWaitURL a - , fmap ((Attr $ unqual "waitUrlMethod") . show) $ enqueueWaitURLMethod a - ]) : c - go LeaveF = [unode "Leave" ()] - go HangupF = [unode "Hangup" ()] - go (RedirectF a b) = [unode "Redirect" (string $ show b) & add_attrs (catMaybes - [ fmap ((Attr $ unqual "method") . show) $ redirectMethod a - ])] - go (RejectF a) = [unode "Reject" () & add_attrs (catMaybes - [ fmap ((Attr $ unqual "reason") . show) $ rejectReason a - ])] - go (PauseF a b) = unode "Pause" () & add_attrs (catMaybes - [ fmap ((Attr $ unqual "length") . show) $ pauseLength a - ]) : b +class Functor1 f where + fmap1 :: (a -> b) -> f i a -> f i b -{- Twiml Attributes -} +class Show1 f where + show1 :: Show a => f i a -> String --- FIXME: Rename `PlayKey`. +{- Applicative -} -number :: String -> Maybe DialNoun -number = Just . Number defaultNumberAttributes +-- | An applicative functor @f@ indexed by a monoid @(M,'<>','Identity')@ +-- +-- If you import @Prelude@ hiding @(\<*>)@ and @pure@, you can redefine +-- @(\<*>)@ and @pure@ to use their indexed equivalents. For example, +-- +-- @ +-- import Prelude hiding ((\<*>), pure) +-- +-- pure :: 'IxApplicative' f -> a -> f 'Identity' a +-- pure = 'ipure' +-- +-- (\<*>) :: 'IxApplicative' f => f i (a -> b) -> f j a -> f (i '<>' j) b +-- (\<*>) = 'iap' +-- @ +class Functor1 f => IxApplicative (f :: k -> * -> *) where + type Identity :: k + type (i :: k) <> (j :: k) :: k + + -- | The indexed equivalent of @pure@ + ipure :: a -> f Identity a + + -- | The indexed equivalent of @(\<*>)@ + iap :: f i (a -> b) -> f j a -> f (i <> j) b + +{- Monad -} + +-- | A monad @m@ indexed by a monoid @(M,'<>','Identity')@ +-- +-- You can use do-notation with 'IxMonad' by enabling the RebindableSyntax +-- extension and redefining @(>>=)@, @(>>)@, and @return@. For example, +-- +-- @ +-- {-\#LANGUAGE RebindableSyntax #-} +-- +-- import Prelude hiding ((>>=), (>>), return) +-- +-- (>>=) :: 'IxMonad' m => m i a -> (a -> m j b) -> m (i '<>' j) b +-- (>>=) = 'ibind' +-- +-- (>>) :: 'IxMonad' m => m i a -> m j b -> m (i '<>' j) b +-- a >> b = a >>= const b +-- +-- return :: 'IxApplicative' m => a -> m 'Identity' a +-- return = 'ipure' +-- @ +-- +-- This is the technique employed by the +-- module. +class IxApplicative m => IxMonad (m :: k -> * -> *) where + -- | The indexed equivalent of @(>>=)@ + ibind :: m i a -> (a -> m j b) -> m (i <> j) b + +{- Free -} + +-- | A free monad indexed by a monoid @(M,'++',[])@ +data IxFree f (i :: [k]) a where + IxPure :: a -> IxFree f '[] a + IxFree :: WitnessList i => f i (IxFree f j a) -> IxFree f (i ++ j) a + +instance (Show1 f, Show a) => Show (IxFree f i a) where + show (IxPure a) = "IxPure (" ++ show a ++ ")" + show (IxFree fa) = "IxFree (" ++ show1 fa ++ ")" + +instance Show1 f => Show1 (IxFree f) where + show1 = show + +instance Functor1 f => Functor (IxFree f i) where + fmap = fmap1 + +instance Functor1 f => Functor1 (IxFree f) where + fmap1 = fmap + +instance Functor1 f => IxApplicative (IxFree f) where + type Identity = '[] + + type i <> j = i ++ j + + ipure = IxPure + + iap = iap' + +iap' + :: forall f i j a b. Functor1 f + => IxFree f i (a -> b) -> IxFree f j a -> IxFree f (i ++ j) b +iap' (IxPure f) (IxPure a) = IxPure $ f a +iap' (IxPure f) (IxFree mb) = IxFree $ fmap1 (fmap f) mb +iap' (IxFree (mf :: f i1 (IxFree f j1 (a -> b)))) a = + case associativity (witness :: SList i1) (Proxy :: Proxy j1) (Proxy :: Proxy j) + of Refl -> IxFree $ fmap1 (`iap'` a) mf + +instance (Functor1 m, IxApplicative (IxFree m)) => IxMonad (IxFree m) where + ibind = ibind' + +ibind' + :: forall f i j a b. Functor1 f + => IxFree f i a -> (a -> IxFree f j b) -> IxFree f (i ++ j) b +ibind' (IxPure a) f = f a +ibind' (IxFree (x :: f i1 (IxFree f j1 a))) f = + case associativity (witness :: SList i1) (Proxy :: Proxy j1) (Proxy :: Proxy j) + of Refl -> IxFree $ fmap1 (`ibind'` f) x + +-- | Lift an indexed functor into 'IxFree' +iliftF :: forall f i a . (WitnessList i, Functor1 f) => f i a -> IxFree f i a +iliftF = case rightIdentity (witness :: SList i) of Refl -> IxFree . fmap1 IxPure + +class NFData1 f where + rnf1 :: NFData a => f i a -> () + +instance NFData1 f => NFData1 (IxFree f) where + rnf1 = rnf + +instance (NFData1 f, NFData a) => NFData (IxFree f i a) where + rnf (IxPure a) = rnf a + rnf (IxFree fa) = rnf1 fa + +{- Promoted Lists -} + +-- $promotedLists 'IxFree' relies on a promoted list of type constructors, so +-- we'll need +-- +-- * promoted list concatenation, @('++')@, +-- * a proof that @('++')@ associates (used by 'iap' and 'ibind'), and +-- * a right identity proof for @[]@ (used by 'iliftF). + +{- (++) -} + +-- | Promoted list concatenation +type family (++) (a :: [k]) (b :: [k]) :: [k] where + '[] ++ bs = bs + (a ': as) ++ bs = a ': as ++ bs + +-- | 'SList' is the singleton type for promoted lists. +data SList (i :: [k]) where + Nil :: SList '[] + Succ :: SList t -> SList (h ': t) + +class WitnessList (xs :: [k]) where + witness :: SList xs + +instance WitnessList '[] where + witness = Nil + +instance WitnessList xs => WitnessList (x ': xs) where + witness = Succ witness + +-- | A proof that @('++')@ associates, i.e. +-- +-- @ +-- xs ++ (ys ++ zs) ≡ (xs ++ ys) ++ zs +-- @ +associativity :: SList xs -> Proxy ys -> Proxy zs + -> (xs ++ (ys ++ zs)) :~: ((xs ++ ys) ++ zs) +associativity Nil _ _ = Refl +associativity (Succ xs) ys zs = + case associativity xs ys zs of Refl -> Refl + +-- | A proof that +-- +-- @ +-- xs ≡ xs ++ [] +-- @ +rightIdentity :: SList xs -> xs :~: (xs ++ '[]) +rightIdentity Nil = Refl +rightIdentity (Succ xs) = case rightIdentity xs of Refl -> Refl + +{- XML -} + +-- $xml The classes here simplify working with the +-- package. + +data SomeNode = forall n. Node n => SomeNode n + +class ToSomeNode a where + toSomeNode :: a -> SomeNode + +instance ToSomeNode a => ToSomeNode (Maybe a) where + toSomeNode (Just a) = toSomeNode a + toSomeNode _ = SomeNode () + +instance Node SomeNode where + node qName (SomeNode n) = node qName n + +instance ToSomeNode String where + toSomeNode str = SomeNode . Text $ CData CDataText str Nothing + +instance ToSomeNode () where + toSomeNode = SomeNode + +instance ToSomeNode n => Node n where + node qName n = node qName (toSomeNode n) + +class ToXML a where + toXML :: a -> [Element] + +instance (ToXML (f a), ToXML (g a)) => ToXML ((f :+: g) a) where + toXML (InL f) = toXML f + toXML (InR g) = toXML g + +class ToElement a where + toElement :: a -> Element + +class ToAttrs a where + toAttrs :: a -> [Attr] + +-- | 'toAttrValue' transforms a data type into a @String@ that can be set as the +-- value of an attribute. +class ToAttrValue a where + toAttrValue :: a -> String + +instance ToAttrValue Bool where + toAttrValue True = "true" + toAttrValue False = "false" + +instance ToAttrValue String where + toAttrValue = id + +makeAttr :: ToAttrValue b => String -> (a -> Maybe b) -> a -> Maybe Attr +makeAttr str f a = Attr (unqual str) . toAttrValue <$> f a + +makeAttr' :: String -> (a -> Maybe b) -> (b -> String) -> a -> Maybe Attr +makeAttr' str f g a = Attr (unqual str) . g <$> f a + +makeAttrs :: a -> [a -> Maybe Attr] -> [Attr] +makeAttrs a = mapMaybe ($ a) + +makeElement :: Node t => String -> t -> [Attr] -> Element +makeElement str c attrs = add_attrs attrs $ unode str c diff --git a/src/Text/XML/Twiml/Internal/TH.hs b/src/Text/XML/Twiml/Internal/TH.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/Twiml/Internal/TH.hs @@ -0,0 +1,414 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml.Internal.TH +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +-- +-- The code for defining TwiML verbs is highly-repetitive and follows a pattern. +-- This module defines a little TwiML definition format and Template Haskell +-- function for generating this code. +-- +-- For example, data types 'Pause', 'PauseF', and 'PauseAttributes' can all be +-- generated from the following definition: +-- +-- @ +-- Pause +-- attributes +-- duration, Natural, length +-- recursive +-- toXMLForGADT +-- toAttrsForAttributes +-- @ +-- +-- You should never need to import this module; it is only used during +-- compilation of the library. +------------------------------------------------------------------------------- +module Text.XML.Twiml.Internal.TH + ( TwimlSpec(..) + , example + , exampleSpec + , runTwimlSpecParser + , twimlSpecToData + , twimlSpecStringToData + , s + ) where + +import Control.Monad +import Data.Char +import Data.Default +import Data.Maybe +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Language.Haskell.TH.Syntax +import Text.Parsec + +example :: String +example = unlines [ + "Say", + " required", + " String", + " attributes", + " voice, Voice", + " loop, Bool", + " recursive" ] + +exampleSpec :: TwimlSpec +exampleSpec = case runTwimlSpecParser example of + Right exampleSpec' -> exampleSpec' + Left parseError -> error $ show parseError + +data TwimlSpec = TwimlSpec + { twimlName :: String + , parameters :: [Parameters] + , recursive :: Bool + , toXMLForGADT :: Bool + , toAttrsForAttributes :: Bool + } deriving Show + +instance Default TwimlSpec where + def = TwimlSpec def def False False False + +data Parameters + = Required { getRequiredTypes :: [String] } + | Attributes { getAttributes :: [Attribute] } + deriving Show + +data Attribute = Attribute + { attributeName :: String + , attributeType :: String + , overrideName :: Maybe String + } deriving Show + +isRequired :: Parameters -> Bool +isRequired (Required _) = True +isRequired _ = False + +isAttributes :: Parameters -> Bool +isAttributes (Attributes _) = True +isAttributes _ = False + +getAllRequired :: [Parameters] -> [String] +getAllRequired = concatMap getRequiredTypes . filter isRequired + +getAllAttributes :: [Parameters] -> [Attribute] +getAllAttributes = concatMap getAttributes . filter isAttributes + +hasAttributes :: TwimlSpec -> Bool +hasAttributes = not . null . getAllAttributes . parameters + +attributeToVarStrictType :: (String -> String) -> Attribute -> VarStrictType +attributeToVarStrictType f Attribute{..} = + ( mkName $ f attributeName + , IsStrict + , AppT (ConT $ mkName "Maybe") (ConT $ mkName attributeType) + ) + +parametersToVarStrictTypes :: (String -> String) -> [Parameters] -> [VarStrictType] +parametersToVarStrictTypes f = map (attributeToVarStrictType f) . getAllAttributes + +rnfI :: Int -> Exp +rnfI i = rnfNames . take i $ map (mkName . return) ['a'..'z'] + +rnfNames :: [Name] -> Exp +rnfNames [] = TupE [] +rnfNames [a] = rnfName a +rnfNames (a:as) = AppE (AppE (VarE $ mkName "seq") (rnfName a)) (rnfNames as) + +rnfName :: Name -> Exp +rnfName name = AppE (VarE $ mkName "rnf") (VarE name) + +specToGADTName :: TwimlSpec -> Name +specToGADTName TwimlSpec{..} = mkName $ twimlName ++ "F" + +specToAttributesName :: TwimlSpec -> Name +specToAttributesName TwimlSpec{..} = mkName $ twimlName ++ "Attributes" + +specToGADTArity :: TwimlSpec -> Int +specToGADTArity spec@(TwimlSpec{..}) = length (getAllRequired parameters) + (if hasAttributes spec then 1 else 0) + (if recursive then 1 else 0) + +specToGADTNames :: TwimlSpec -> [Name] +specToGADTNames spec@(TwimlSpec{..}) = + take (specToGADTArity spec) $ map (mkName . return) ['a'..'z'] + +specToGADTAttributesName :: TwimlSpec -> Maybe Name +specToGADTAttributesName spec@(TwimlSpec{..}) = go $ zip parameters $ specToGADTNames spec where + go [] = Nothing + go ((Required _, _):rest) = go rest + go ((Attributes _, name):_) = Just name + +specToGADTChildName :: TwimlSpec -> Maybe Name +specToGADTChildName spec@(TwimlSpec{..}) = go $ zip parameters $ specToGADTNames spec where + go [] = Nothing + go ((Required _, name):_) = Just name + go ((Attributes _, name):rest) = go rest + +specToGADTPat :: TwimlSpec -> Pat +specToGADTPat spec@(TwimlSpec{..}) = ConP (specToGADTName spec) varPs where + varPs = map VarP $ specToGADTNames spec + +specToAttributesListE :: TwimlSpec -> Exp +specToAttributesListE spec@(TwimlSpec{..}) = ListE . map go $ getAllAttributes parameters where + go (Attribute{..}) = + let name = LitE . StringL $ fromMaybe attributeName overrideName + in AppE (AppE (VarE $ mkName "makeAttr") name) (VarE . mkName $ makeAttr attributeName) + attrPrefix = '_' : map toLower twimlName + makeAttr (a:ttrName) = attrPrefix ++ toUpper a : ttrName + makeAttr _ = error "Unsupported" + +specToToXML :: TwimlSpec -> Exp +specToToXML spec@(TwimlSpec{..}) = UInfixE (AppE (AppE (AppE (VarE $ mkName "makeElement") (LitE $ StringL twimlName)) (AppE (VarE $ mkName "toSomeNode") child)) attributesE) (ConE $ mkName ":") next where + child = maybe (TupE []) VarE $ specToGADTChildName spec + attributesE = maybe (ListE []) (AppE (VarE $ mkName "toAttrs") . VarE) $ specToGADTAttributesName spec + next = if recursive + then AppE (VarE $ mkName "toXML") (VarE . last $ specToGADTNames spec) + else ListE [] + +specToStrictTypes :: TwimlSpec -> [StrictType] +specToStrictTypes spec@(TwimlSpec{..}) = go parameters ++ [(NotStrict, VarT $ mkName "a") | recursive] where + go [] = [] + go (Required as :bs) = map stringToStrictType as ++ go bs + go (Attributes _ :bs) = (NotStrict, ConT $ specToAttributesName spec) : go bs + stringToStrictType a = (NotStrict, ConT $ mkName a) + +gadtToDefExp :: TwimlSpec -> [Parameters] -> Exp +gadtToDefExp spec@(TwimlSpec{..}) = go (ConE $ specToGADTName spec) . foldr ((+) . count) (if recursive then 1 else 0) where + go conE 0 = conE + go conE n = go (AppE conE defE) (n-1) + defE = VarE $ mkName "def" + count (Required r) = length r + count _ = 1 + +attributesToDefExp :: Exp -> [Parameters] -> Exp +attributesToDefExp conE = go conE . length . getAllAttributes where + go conE 0 = conE + go conE n = go (AppE conE defE) (n-1) + defE = VarE $ mkName "def" + +instance Default Attribute where + def = Attribute def def def + +parseTwimlSpec :: Parsec String () TwimlSpec +parseTwimlSpec = do + twimlName <- parseTwimlName + parameters <- parseParameters + recursive <- option False $ try parseRecursive + toXMLForGADT <- option False parseToXMLForGADT + toAttrsForAttributes <- option False parseToAttrsForAttributes + eof + return $ TwimlSpec twimlName parameters recursive toXMLForGADT toAttrsForAttributes + +parseTwimlName :: Parsec String () String +parseTwimlName = many1 letter <* newline + +parseParameters :: Parsec String () [Parameters] +parseParameters = many (try parseRequiredSection <|> try parseAttributesSection) + +parseRequiredSection :: Parsec String () Parameters +parseRequiredSection = do + string " required"; newline + Required <$> many (try parseRequired) + +parseRequired :: Parsec String () String +parseRequired = + string " " >> many1 (noneOf "\n") <* newline + +parseAttributesSection :: Parsec String () Parameters +parseAttributesSection = do + string " attributes"; newline + Attributes <$> many (try parseAttribute) + +parseAttribute :: Parsec String () Attribute +parseAttribute = do + string " " + abc <- many1 (noneOf ",\n") `sepBy` string ", " <* newline + case abc of + [a,b] -> return $ Attribute a b Nothing + a:b:[c] -> return . Attribute a b $ Just c + _ -> mzero + +parseRecursive :: Parsec String () Bool +parseRecursive = + const True <$> string " recursive" <* newline + +parseToXMLForGADT :: Parsec String () Bool +parseToXMLForGADT = + const True <$> string " toXMLForGADT" <* newline + +parseToAttrsForAttributes :: Parsec String () Bool +parseToAttrsForAttributes = + const True <$> string " toAttrsForAttributes" <* newline + +runTwimlSpecParser :: String -> Either ParseError TwimlSpec +runTwimlSpecParser = runParser parseTwimlSpec () "" + +s :: QuasiQuoter +s = QuasiQuoter {quoteExp = stringE . trim} + +trim :: String -> String +trim = trimTail . dropWhile isSpace + +trimTail :: String -> String +trimTail "" = "\n" +trimTail s = take (lastNonBlank s) s ++ "\n" + where lastNonBlank = (+1) . fst . foldl acc (0, 0) + acc (l, n) c | isSpace c = (l, n + 1) + | otherwise = (n, n + 1) + +twimlSpecStringToData :: String -> DecsQ +twimlSpecStringToData str = case runTwimlSpecParser str of + Right twimlSpec -> twimlSpecToData twimlSpec + Left msg -> error $ show msg + +-- | Create an indexed GADT from a name. For example, given "Foo", this +-- generates (roughly) +-- +-- @@ +-- data Foo +-- data FooF i a where +-- FooF :: a -> FooF '[Foo] a +-- @@ +twimlSpecToData :: TwimlSpec -> DecsQ +twimlSpecToData spec@(TwimlSpec{..}) = pure $ + [ emptyDataDecl + , gadt +-- , deriveDataForGADT + -- , instanceDefaultForGADT +-- , deriveEqForGADT + , deriveFunctorForGADT + , instanceFunctor1ForGADT +-- , instanceNFDataForGADT +-- , deriveOrdForGADT +-- , deriveReadForGADT + , deriveShowForGADT +-- , instanceToXMLForGADT + , attributes + , instanceDefaultForAttributes + ] + ++ [instanceToXMLForGADT | toXMLForGADT] + ++ [instanceToAttrsForAttributes | toAttrsForAttributes] + where + conName = mkName twimlName + + -- | @data Foo@ + emptyDataDecl = DataD [] conName [] [] [] + + -- | Type variables @i :: [*]@ and @a@ + i' = mkName "i" + a' = mkName "a" + i = VarT i' + a = VarT a' + tyVarBndrs = [KindedTV i' $ AppT ListT StarT, PlainTV a'] + + -- | @Proxy@ + proxy = ConT $ mkName "Proxy" + + -- | @Proxy i@ + proxyI = AppT proxy i + + -- | @'[Foo]@ + list = AppT (AppT PromotedConsT (ConT conName)) PromotedNilT + + -- | @Proxy '[Foo]@ + proxyList = AppT proxy list + + -- | @Proxy i ~ Proxy '[Foo]@ + -- + -- Unfortunately, this is the only way I know of to constrain the kind of + -- @i@. + cxt' = [AppT (AppT EqualityT proxyI) proxyList] + + conNameF = mkName $ twimlName ++ "F" + con = ForallC [] cxt' + . NormalC conNameF $ specToStrictTypes spec + + -- | @data FooF i a where FooF :: a -> FooF '[Foo] a@ + gadt = DataD [] conNameF tyVarBndrs [con] [] + + dataN = mkName "Data" + dataC = ConT dataN + + defaultN = mkName "Default" + defaultC = ConT defaultN + + -- enumN = mkName "Enum" + -- enumC = ConT enumN + + eqN = mkName "Eq" + eqC = ConT eqN + + functorN = mkName "Functor" + functorC = ConT functorN + + functor1N = mkName "Functor1" + functor1C = ConT functor1N + + genericN = mkName "Generic" + genericC = ConT genericN + + nfdataN = mkName "NFData" + nfdataC = ConT nfdataN + + ordN = mkName "Ord" + ordC = ConT ordN + + readN = mkName "Read" + readC = ConT readN + + showN = mkName "Show" + showC = ConT showN + + toAttrsN = mkName "ToAttrs" + toAttrsC = ConT toAttrsN + + toXMLN = mkName "ToXML" + toXMLC = ConT toXMLN + + -- | @instance Default a => Default (FooF i a) where def = FooF def ...@ + instanceDefaultForGADT = InstanceD [AppT defaultC a] (AppT defaultC (AppT (AppT (ConT conNameF) list) a)) [ValD (VarP $ mkName "def") (NormalB $ gadtToDefExp spec parameters) []] + + -- | @deriving instance Data a => Data (FooF i a)@ + deriveDataForGADT = StandaloneDerivD [AppT dataC a] $ AppT dataC (AppT (AppT (ConT conNameF) list) a) + + -- | @deriving instance Eq a => Eq (FooF i a)@ + deriveEqForGADT = StandaloneDerivD [AppT eqC a] $ AppT eqC (AppT (AppT (ConT conNameF) i) a) + + -- | @deriving instance Functor (FooF i)@ + deriveFunctorForGADT = StandaloneDerivD [] $ AppT functorC (AppT (ConT conNameF) i) + + -- | @instance Functor1 FooF where fmap1 = fmap@ + instanceFunctor1ForGADT = InstanceD [] (AppT functor1C $ ConT conNameF) [ValD (VarP $ mkName "fmap1") (NormalB . VarE $ mkName "fmap") []] + + -- | @instance NFData a => NFData (FooF i a) where rnf (FooF a ...) = rnf a `seq` ...@ + instanceNFDataForGADT = InstanceD [AppT nfdataC a] (AppT nfdataC (AppT (AppT (ConT conNameF) list) a)) [FunD (mkName "rnf") [Clause [specToGADTPat spec] (NormalB . rnfI $ specToGADTArity spec) []]] + + -- | @deriving instance Ord a => Ord (FooF i a)@ + deriveOrdForGADT = StandaloneDerivD [AppT ordC a] $ AppT ordC (AppT (AppT (ConT conNameF) i) a) + + -- | @deriving instance Read a => Read (FooF i a)@ + deriveReadForGADT = StandaloneDerivD [AppT readC a] $ AppT readC (AppT (AppT (ConT conNameF) list) a) + + -- | @deriving instance Show a => Show (FooF i a)@ + deriveShowForGADT = StandaloneDerivD [AppT showC a] $ AppT showC (AppT (AppT (ConT conNameF) i) a) + + -- | @instance ToXML a => ToXML (FooF i a) where toXML (FooF a ...) = makeElement "Foo" a ...@ + instanceToXMLForGADT = InstanceD [AppT toXMLC a | recursive] (AppT toXMLC (AppT (AppT (ConT conNameF) i) a)) + [FunD (mkName "toXML") [Clause [specToGADTPat spec] (NormalB $ specToToXML spec) []]] + + attrPrefix = '_' : map toLower twimlName + makeAttr (a:ttrName) = attrPrefix ++ toUpper a : ttrName + makeAttr _ = error "Unsupported" + attributesName = specToAttributesName spec + + -- | @data FooAttributes = FooAttributes{..} deriving (Data, Eq, Ord, Read, Show)@ + -- + -- All record fields should be camelCased and prefixed with "_foo". + attributes = DataD [] attributesName [] [RecC attributesName (parametersToVarStrictTypes makeAttr parameters)] [dataN, eqN, genericN, nfdataN, ordN, readN, showN] + + -- | @instance Default FooAttributes where def = FooAttributes def ...@ + instanceDefaultForAttributes = InstanceD [] (AppT defaultC $ ConT attributesName) [ValD (VarP $ mkName "def") (NormalB $ attributesToDefExp (ConE attributesName) parameters) []] + + instanceToAttrsForAttributes = InstanceD [] (AppT toAttrsC $ ConT attributesName) [ValD (VarP $ mkName "toAttrs") (NormalB (AppE (AppE (VarE $ mkName "flip") (VarE $ mkName "makeAttrs")) (specToAttributesListE spec))) []] diff --git a/src/Text/XML/Twiml/Internal/Twiml.hs b/src/Text/XML/Twiml/Internal/Twiml.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/Twiml/Internal/Twiml.hs @@ -0,0 +1,693 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml.Internal.Twiml +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +-- +-- This module defines all of the TwiML verbs and nouns in a single place +-- (mainly due to a few mutually-recursive definitions). This modules also +-- exposeses the internals of each TwiML's attributes. +-- +-- Prefer the definitions re-exported by the +-- and +-- modules to those exported +-- here. +------------------------------------------------------------------------------- +module Text.XML.Twiml.Internal.Twiml + ( -- * TwiML + MessagingTwiml(..) + , MessagingVerbsF(..) + , VoiceTwiml(..) + , VoiceVerbsF(..) + , Base + , IsTwimlLike + , TwimlLike + , TwimlLike' + , response + -- ** Nouns + , DialNoun(..) + , DialNounF(..) + -- *** Client + , Client + , ClientF(..) + , ClientAttributes(..) + -- *** Conference + , Conference + , ConferenceF(..) + , ConferenceAttributes(..) + -- *** Number + , Number + , NumberF(..) + , NumberAttributes(..) + -- *** Queue + , Queue + , QueueF(..) + , QueueAttributes(..) + -- *** Sip + , Sip + , SipF(..) + , SipAttributes(..) + -- ** Verbs + -- *** Dial + , Dial + , DialF(..) + , DialAttributes(..) + -- *** End + , End + , EndF(..) + -- *** Enqueue + , Enqueue + , EnqueueF(..) + , EnqueueAttributes(..) + -- *** Hangup + , Gather + , GatherF(..) + , GatherAttributes(..) + , Nest + , In + -- *** Hangup + , Hangup + , HangupF(..) + -- *** Leave + , Leave + , LeaveF(..) + -- *** Message + , Message + , MessageF(..) + , MessageAttributes(..) + -- *** Pause + , Pause + , PauseF(..) + , PauseAttributes(..) + -- *** Play + , Play + , PlayF(..) + , PlayAttributes(..) + -- *** Record + , Record + , RecordF(..) + , RecordAttributes(..) + -- *** Redirect + , Redirect + , RedirectF(..) + , RedirectAttributes(..) + -- *** Reject + , Reject + , RejectF(..) + , RejectAttributes(..) + -- *** Say + , Say + , SayF(..) + , SayAttributes(..) + -- *** Sms + , Sms + , SmsF(..) + , SmsAttributes(..) + ) where + +import Control.Monad +import Control.DeepSeq +import Data.Data +import Data.Default +import Data.Void +import GHC.Generics (Generic) +import Text.XML.Light +import Text.XML.Twiml.Internal +import Text.XML.Twiml.Internal.TH +import Text.XML.Twiml.Types + +------------------------------------------------------------------------------- +-- Nouns +------------------------------------------------------------------------------- + +------------------------------------------------------------------------------- +-- Client +------------------------------------------------------------------------------- + +twimlSpecStringToData [s| +Client + required + String + attributes + url, URL + method, Method + toXMLForGADT + toAttrsForAttributes +|] + +------------------------------------------------------------------------------- +-- Conference +------------------------------------------------------------------------------- + +twimlSpecStringToData [s| +Conference + required + String + attributes + muted, Bool + beep, Bool + startOnEnter, Bool, startConferenceOnEnter + endOnExit, Bool, endConferenceOnExit + waitURL, URL + waitMethod, Method + maxParticipants, Natural + toXMLForGADT + toAttrsForAttributes +|] + +------------------------------------------------------------------------------- +-- Number +------------------------------------------------------------------------------- + +type Digits = [Digit] + +twimlSpecStringToData [s| +Number + required + String + attributes + sendDigits, Digits + url, URL + method, Method + toXMLForGADT + toAttrsForAttributes +|] + +------------------------------------------------------------------------------- +-- Queue +------------------------------------------------------------------------------- + +twimlSpecStringToData [s| +Queue + required + String + attributes + url, URL + method, Method + toXMLForGADT + toAttrsForAttributes +|] + +------------------------------------------------------------------------------- +-- Sip +------------------------------------------------------------------------------- + +twimlSpecStringToData [s| +Sip + required + URL + attributes + username, String + password, String + transport, Transport + headers, String + url, URL + method, Method + toXMLForGADT + toAttrsForAttributes +|] + +data DialNoun = forall i. DialNoun (IxFree DialNounF i Void) + +instance ToSomeNode DialNoun where + toSomeNode (DialNoun dialNoun) = SomeNode $ toXML dialNoun + +instance ToSomeNode EitherDialNounString where + toSomeNode = either toSomeNode toSomeNode + +instance ToXML DialNoun where + toXML (DialNoun dialNoun) = toXML dialNoun + +instance Show DialNoun where + show = showDialNoun + +showDialNoun :: DialNoun -> String +showDialNoun = concatMap ppElement . toXML + +newtype DialNounF i a = DialNounF + { getDialNounF :: + ( ClientF i :+: + ConferenceF i :+: + NumberF i :+: + QueueF i :+: + SipF i ) a + } deriving (Functor, Generic, Show, Typeable) + +instance (f i :<: ( ClientF i :+: + ConferenceF i :+: + NumberF i :+: + QueueF i :+: + SipF i ) + ) => f i :<: DialNounF i where + inj = DialNounF . inj + prj = prj . getDialNounF + +instance Functor1 DialNounF where + fmap1 = fmap + +instance Show1 DialNounF where + show1 = show + +instance ToXML a => ToXML (DialNounF i a) where + toXML = toXML . getDialNounF + +instance ToXML (IxFree DialNounF i Void) where + toXML (IxFree f) = toXML f + toXML _ = error "Impossible" + +------------------------------------------------------------------------------- +-- Verbs +------------------------------------------------------------------------------- + +------------------------------------------------------------------------------- +-- Dial +------------------------------------------------------------------------------- + +type EitherDialNounString = Either DialNoun String + +twimlSpecStringToData [s| +Dial + required + EitherDialNounString + attributes + action, URL + method, Method + timeout, Natural + hangupOnStar, Bool + timeLimit, Natural + callerId, String + record', Bool, record + recursive + toXMLForGADT + toAttrsForAttributes +|] + +------------------------------------------------------------------------------- +-- End +------------------------------------------------------------------------------- + +twimlSpecStringToData [s| +End +|] + +instance ToXML (EndF i a) where + toXML EndF = [] + +------------------------------------------------------------------------------- +-- Enqueue +------------------------------------------------------------------------------- + +twimlSpecStringToData [s| +Enqueue + required + String + attributes + action, URL + method, Method + waitURL, URL, waitUrl + waitMethod, Method, waitUrlMethod + recursive + toXMLForGADT + toAttrsForAttributes +|] + +------------------------------------------------------------------------------- +-- Hangup +------------------------------------------------------------------------------- + +twimlSpecStringToData [s| +Hangup + toXMLForGADT +|] + +------------------------------------------------------------------------------- +-- Leave +------------------------------------------------------------------------------- + +twimlSpecStringToData [s| +Leave + toXMLForGADT +|] + +------------------------------------------------------------------------------- +-- Message +------------------------------------------------------------------------------- + +twimlSpecStringToData [s| +Message + required + String + attributes + to, String + from, String + action, URL + method, Method + statusCallback, URL + recursive + toXMLForGADT + toAttrsForAttributes +|] + +------------------------------------------------------------------------------- +-- Pause +------------------------------------------------------------------------------- + +twimlSpecStringToData [s| +Pause + attributes + duration, Natural, length + recursive + toXMLForGADT + toAttrsForAttributes +|] + +------------------------------------------------------------------------------- +-- Play +------------------------------------------------------------------------------- + +type MaybeURL = Maybe URL + +twimlSpecStringToData [s| +Play + required + MaybeURL + attributes + loop, Natural + digits, Digits + recursive + toXMLForGADT + toAttrsForAttributes +|] + +------------------------------------------------------------------------------- +-- Record +------------------------------------------------------------------------------- + +twimlSpecStringToData [s| +Record + attributes + action, URL + method, Method + timeout, Natural + finishOnKey, Key + maxLength, Natural + transcribe, Bool + transcribeCallback, URL + playBeep, Bool + recursive + toXMLForGADT + toAttrsForAttributes +|] + +------------------------------------------------------------------------------- +-- Redirect +------------------------------------------------------------------------------- + +twimlSpecStringToData [s| +Redirect + required + URL + attributes + method, Method + toXMLForGADT + toAttrsForAttributes +|] + +------------------------------------------------------------------------------- +-- Reject +------------------------------------------------------------------------------- + +twimlSpecStringToData [s| +Reject + attributes + reason, Reason + toXMLForGADT + toAttrsForAttributes +|] + +------------------------------------------------------------------------------- +-- Say +------------------------------------------------------------------------------- + +twimlSpecStringToData [s| +Say + required + String + attributes + voice, Voice + loop, Natural + recursive + toXMLForGADT +|] + +lang :: Voice -> Maybe (Either Lang LangAlice) +lang (Man l) = Left <$> l +lang (Woman l) = Left <$> l +lang (Alice r) = Right <$> r + +instance ToAttrs SayAttributes where + toAttrs = flip makeAttrs + [ makeAttr "voice" _sayVoice + , makeAttr "loop" _sayLoop + , makeAttr' "language" (_sayVoice >=> lang) (either toAttrValue toAttrValue) + ] + +------------------------------------------------------------------------------- +-- Sms +------------------------------------------------------------------------------- + +twimlSpecStringToData [s| +Sms + required + String + attributes + to, String + from, String + action, URL + method, Method + statusCallback, URL + recursive + toXMLForGADT + toAttrsForAttributes +|] + +------------------------------------------------------------------------------- +-- Gather +------------------------------------------------------------------------------- + +data Gather + +data In + +type family Nest a i b where + Nest i In Gather = + ( Record ∉ i + , Gather ∉ i + , Sms ∉ i + , Dial ∉ i + , Enqueue ∉ i + , Leave ∉ i + , Hangup ∉ i + , Redirect ∉ i + , Reject ∉ i + ) + +data GatherF i a where + GatherF :: Nest i In Gather + => GatherAttributes + -> IxFree VoiceVerbsF i Void + -> a + -> GatherF '[Gather] a + +deriving instance Functor (GatherF i) + +instance Functor1 GatherF where + fmap1 = fmap + +deriving instance Show a => Show (GatherF i a) + +instance ToXML a => ToXML (GatherF i a) where + toXML (GatherF attrs a b) = makeElement "Gather" (toXML a) (toAttrs attrs) : toXML b + +-- | See . +data GatherAttributes = GatherAttributes + { _gatherAction :: Maybe URL + , _gatherMethod :: Maybe Method + , _gatherTimeout :: Maybe Natural + , _gatherFinishOnKey :: Maybe Key + , _gatherNumDigits :: Maybe Natural + } deriving (Data, Eq, Generic, NFData, Ord, Read, Show, Typeable) + +instance Default GatherAttributes where + def = GatherAttributes + { _gatherAction = def + , _gatherMethod = def + , _gatherTimeout = def + , _gatherFinishOnKey = def + , _gatherNumDigits = def + } + +instance ToAttrs GatherAttributes where + toAttrs = flip makeAttrs + [ makeAttr "action" _gatherAction + , makeAttr "method" _gatherMethod + , makeAttr "timeout" _gatherTimeout + , makeAttr "finishOnKey" _gatherFinishOnKey + , makeAttr "numDigits" _gatherNumDigits + ] + +------------------------------------------------------------------------------- +-- TwiML +------------------------------------------------------------------------------- + +data VoiceTwiml = forall i. VoiceTwiml (IxFree VoiceVerbsF i Void) + +instance ToElement VoiceTwiml where + toElement (VoiceTwiml twiml) = unode "Response" $ toXML twiml + +instance Show VoiceTwiml where + show = showTwiml + +showTwiml :: VoiceTwiml -> String +showTwiml twiml = "\n" ++ ppElement (toElement twiml) ++ "\n" + +newtype VoiceVerbsF i a = VoiceVerbsF + { getVoiceVerbsF :: + ( SayF i :+: + PlayF i :+: + GatherF i :+: + SmsF i :+: -- Shared between Voice and Messaging TwiML + DialF i :+: + EnqueueF i :+: + LeaveF i :+: + HangupF i :+: + RecordF i :+: + RedirectF i :+: -- Shared between Voice and Messaging TwiML + RejectF i :+: + PauseF i :+: + EndF i ) a -- Shared between Voice and Messaging TwiML + } deriving (Functor, Generic, Show, Typeable) + +instance (f i :<: ( SayF i :+: + PlayF i :+: + GatherF i :+: + SmsF i :+: + DialF i :+: + EnqueueF i :+: + LeaveF i :+: + HangupF i :+: + RecordF i :+: + RedirectF i :+: + RejectF i :+: + PauseF i :+: + EndF i ) + ) => f i :<: VoiceVerbsF i where + inj = VoiceVerbsF . inj + prj = prj . getVoiceVerbsF + +instance Functor1 VoiceVerbsF where + fmap1 = fmap + +instance Show1 VoiceVerbsF where + show1 = show + +instance ToXML a => ToXML (VoiceVerbsF i a) where + toXML = toXML . getVoiceVerbsF + +instance ToXML (IxFree VoiceVerbsF i Void) where + toXML (IxFree f) = toXML f + toXML _ = error "Impossible" + +data MessagingTwiml = forall i. MessagingTwiml (IxFree MessagingVerbsF i Void) + +instance ToElement MessagingTwiml where + toElement (MessagingTwiml twiml) = unode "Response" $ toXML twiml + +instance Show MessagingTwiml where + show = showMessagingTwiml + +showMessagingTwiml :: MessagingTwiml -> String +showMessagingTwiml twiml = "\n" ++ ppElement (toElement twiml) ++ "\n" + +newtype MessagingVerbsF i a = MessagingVerbsF + { getMessagingVerbsF :: + ( MessageF i :+: + RedirectF i :+: -- Shared between Voice and Messaging TwiML + SmsF i :+: -- Shared between Voice and Messaging TwiML + EndF i ) a -- Shared between Voice and Messaging TwiML + } deriving (Functor, Generic, Show, Typeable) + +instance (f i :<: ( MessageF i :+: + RedirectF i :+: + SmsF i :+: + EndF i ) + ) => f i :<: MessagingVerbsF i where + inj = MessagingVerbsF . inj + prj = prj . getMessagingVerbsF + +instance Functor1 MessagingVerbsF where + fmap1 = fmap + +instance Show1 MessagingVerbsF where + show1 = show + +instance ToXML a => ToXML (MessagingVerbsF i a) where + toXML = toXML . getMessagingVerbsF + +instance ToXML (IxFree MessagingVerbsF i Void) where + toXML (IxFree f) = toXML f + toXML _ = error "Impossible" + +-- | 'Base' maps the empty data declaration for a TwiML verb to its +-- corresponding base functor. +type family Base d where + Base Dial = DialF + Base End = EndF + Base Enqueue = EnqueueF + Base Gather = GatherF + Base Hangup = HangupF + Base Leave = LeaveF + Base Message = MessageF + Base Pause = PauseF + Base Play = PlayF + Base Record = RecordF + Base Redirect = RedirectF + Base Reject = RejectF + Base Say = SayF + Base Sms = SmsF + + Base Client = ClientF + Base Conference = ConferenceF + Base Number = NumberF + Base Queue = QueueF + Base Sip = SipF + +type IsTwimlLike f i = (Functor1 f, (Base i) '[i] :<: f '[i]) + +type TwimlLike f i = TwimlLike' f '[i] + +type TwimlLike' f = IxFree f + +response :: IxFree VoiceVerbsF i Void -> VoiceTwiml +response = VoiceTwiml diff --git a/src/Text/XML/Twiml/Lenses.hs b/src/Text/XML/Twiml/Lenses.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/Twiml/Lenses.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml.Lenses +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +-- +-- This module defines lenses for use with TwiML attributes. Lenses are +-- re-exported by the @ modules. +------------------------------------------------------------------------------- +module Text.XML.Twiml.Lenses where + +import Control.Lens hiding (to) +import Text.XML.Twiml.Types hiding (ClientAttributes(..), ConferenceAttributes(..), NumberAttributes(..), QueueAttributes(..), SipAttributes(..), DialNoun(..)) +import Text.XML.Twiml.Internal.Twiml + +makeLensesWith abbreviatedFields ''SayAttributes +makeLensesWith abbreviatedFields ''PlayAttributes +makeLensesWith abbreviatedFields ''GatherAttributes +makeLensesWith abbreviatedFields ''RecordAttributes +makeLensesWith abbreviatedFields ''SmsAttributes +makeLensesWith abbreviatedFields ''DialAttributes +makeLensesWith abbreviatedFields ''DialNoun +makeLensesWith abbreviatedFields ''NumberAttributes +makeLensesWith abbreviatedFields ''SipAttributes +makeLensesWith abbreviatedFields ''ClientAttributes +makeLensesWith abbreviatedFields ''ConferenceAttributes +makeLensesWith abbreviatedFields ''QueueAttributes +makeLensesWith abbreviatedFields ''EnqueueAttributes +makeLensesWith abbreviatedFields ''RedirectAttributes +makeLensesWith abbreviatedFields ''RejectAttributes +makeLensesWith abbreviatedFields ''PauseAttributes +makeLensesWith abbreviatedFields ''MessageAttributes diff --git a/src/Text/XML/Twiml/Syntax.hs b/src/Text/XML/Twiml/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/Twiml/Syntax.hs @@ -0,0 +1,50 @@ +{-#LANGUAGE DataKinds #-} +{-#LANGUAGE KindSignatures #-} +{-#LANGUAGE NoImplicitPrelude #-} +{-#LANGUAGE PolyKinds #-} +{-#LANGUAGE RankNTypes #-} +{-#LANGUAGE TypeOperators #-} +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml.Syntax +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +-- +-- This module, in combination with the @RebindableSyntax@ and @RecordWilCards@ +-- extensions, allows you to write TwiML using do-notation. For example, +-- +-- @ +-- {-\# LANGUAGE RebindableSyntax \#-} +-- {-\# LANGUAGE RecordWildCards \#-} +-- +-- import Prelude +-- import Text.XML.Twiml +-- import qualified Text.XML.Twiml.Syntax as Twiml +-- +-- example :: 'VoiceTwiml' +-- example = +-- 'response' $ do +-- 'say' "Hello World" def +-- 'end' +-- where Twiml.'Syntax'{..} = def +-- @ +-- +-- This pattern is due to a +-- . +------------------------------------------------------------------------------- +module Text.XML.Twiml.Syntax where + +import Data.Default +import Prelude (const) +import Text.XML.Twiml.Internal + +data Syntax (m :: [k] -> * -> *) (i :: [k]) (j :: [k]) (a :: *) (b :: *) = Syntax { + (>>=) :: m i a -> (a -> m j b) -> m (i <> j) b + , (>>) :: m i a -> m j b -> m (i <> j) b + , return :: a -> m Identity a + } + +instance IxMonad m => Default (Syntax m i j a b) where + def = Syntax ibind (\a b -> a `ibind` const b) ipure diff --git a/src/Text/XML/Twiml/Types.hs b/src/Text/XML/Twiml/Types.hs --- a/src/Text/XML/Twiml/Types.hs +++ b/src/Text/XML/Twiml/Types.hs @@ -1,126 +1,153 @@ -{-#LANGUAGE EmptyDataDecls #-} -{-#LANGUAGE FlexibleContexts #-} -{-#LANGUAGE EmptyDataDecls #-} -{-#LANGUAGE FlexibleContexts #-} -{-#LANGUAGE FlexibleInstances #-} -{-#LANGUAGE FunctionalDependencies #-} -{-#LANGUAGE GADTs #-} -{-#LANGUAGE MultiParamTypeClasses #-} -{-#LANGUAGE RankNTypes #-} -{-#LANGUAGE TypeFamilies #-} -{-#LANGUAGE TypeOperators #-} -{-#LANGUAGE UndecidableInstances #-} - +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml.Types +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +------------------------------------------------------------------------------- module Text.XML.Twiml.Types - ( Natural + ( Digit(..) + , Key(..) + , Method(..) + , Natural , URL , parseURL - , Method(..) - , Key(..) - , Digit(..) - -- * @\@ - , SayAttributes(..) - , defaultSayAttributes , Voice(..) , Lang(..) , LangAlice(..) - -- * @\@ - , PlayAttributes(..) - , defaultPlayAttributes - -- * @\@ - , GatherAttributes(..) - , defaultGatherAttributes - , Gather' - -- * @\@ - , RecordAttributes(..) - , defaultRecordAttributes - -- * @\@ - , SmsAttributes(..) - , defaultSmsAttributes - -- * @\@ - , DialAttributes(..) - , defaultDialAttributes - , DialNoun(..) - -- ** @\@ - , NumberAttributes(..) - , defaultNumberAttributes - -- ** @\@ - , SipAttributes(..) - , defaultSipAttributes , Transport(..) - -- ** @\@ - , ClientAttributes(..) - , defaultClientAttributes - -- ** @\@ - , ConferenceAttributes(..) - , defaultConferenceAttributes , ConferenceBeep(..) - -- ** @\@ - , QueueAttributes(..) - , defaultQueueAttributes - -- * @\@ - , EnqueueAttributes(..) - , defaultEnqueueAttributes - -- * @\@ - , RedirectAttributes(..) - , defaultRedirectAttributes - -- * @\@ - , RejectAttributes(..) - , defaultRejectAttributes , Reason(..) - -- * @\@ - , PauseAttributes(..) - , defaultPauseAttributes - -- * Lens Classes - , HasLoop(..) - , HasAction(..) - , HasMethod(..) - , HasTimeout(..) - , HasFinishOnKey(..) - -- * Internal - -- ** Lens - -- $lens - , Lens - , Lens' - , lens - , (^.) - , over - , to' - -- ** Fix & Foldable - -- $fix - , Fix(..) - , Foldable(..) - , Base(..) - -- ** Type Inequality - -- $type - , (:/~) - , Yes - , No ) where +import Control.DeepSeq (NFData(..)) +import Data.Data +import Data.Default +import GHC.Generics (Generic) import Network.URI (URI(..), parseURIReference) -import Unsafe.Coerce (unsafeCoerce) -{- Attributes -} +import Text.XML.Twiml.Internal --- | See . -data SayAttributes = SayAttributes - { sayVoice :: Maybe Voice - , sayLoop :: Maybe Natural - } +-- | The ‘digits’ attribute lets you play DTMF tones during a call. See +-- . +data Digit + = D0 -- ^ 0 + | D1 -- ^ 1 + | D2 -- ^ 2 + | D3 -- ^ 3 + | D4 -- ^ 4 + | D5 -- ^ 5 + | D6 -- ^ 6 + | D7 -- ^ 7 + | D8 -- ^ 8 + | D9 -- ^ 9 + | W -- ^ w + deriving (Bounded, Data, Enum, Eq, Generic, NFData, Ord, Read, Show, Typeable) -defaultSayAttributes :: SayAttributes -defaultSayAttributes = SayAttributes - { sayVoice = Nothing - , sayLoop = Nothing - } +instance ToAttrValue Digit where + toAttrValue D0 = "0" + toAttrValue D1 = "1" + toAttrValue D2 = "2" + toAttrValue D3 = "3" + toAttrValue D4 = "4" + toAttrValue D5 = "5" + toAttrValue D6 = "6" + toAttrValue D7 = "7" + toAttrValue D8 = "8" + toAttrValue D9 = "9" + toAttrValue W = "w" +instance ToAttrValue [Digit] where + toAttrValue = concatMap toAttrValue + +data Key + = K0 -- ^ 0 + | K1 -- ^ 1 + | K2 -- ^ 2 + | K3 -- ^ 3 + | K4 -- ^ 4 + | K5 -- ^ 5 + | K6 -- ^ 6 + | K7 -- ^ 7 + | K8 -- ^ 8 + | K9 -- ^ 9 + | KStar -- ^ \* + | KPound -- ^ # + deriving (Bounded, Data, Enum, Eq, Generic, NFData, Ord, Read, Show, Typeable) + +instance ToAttrValue Key where + toAttrValue K0 = "0" + toAttrValue K1 = "1" + toAttrValue K2 = "2" + toAttrValue K3 = "3" + toAttrValue K4 = "4" + toAttrValue K5 = "5" + toAttrValue K6 = "6" + toAttrValue K7 = "7" + toAttrValue K8 = "8" + toAttrValue K9 = "9" + toAttrValue KStar = "*" + toAttrValue KPound = "#" + +type Natural = Int + +instance ToAttrValue Natural where + toAttrValue = show + +data Method = GET | POST + deriving (Bounded, Data, Enum, Eq, Generic, NFData, Ord, Read, Show, Typeable) + +instance ToAttrValue Method where + toAttrValue = show + +newtype URL = URL { getURL :: String } + deriving (Data, Eq, Generic, NFData, Ord, Read, Show, Typeable) + +instance ToSomeNode URL where + toSomeNode = toSomeNode . getURL + +instance ToAttrValue URL where + toAttrValue = getURL + +-- | Checks whether a @URI@'s scheme, if any, is one of @"http:"@ or @"https:"@. +isHttp :: URI -> Bool +isHttp uri = case uriScheme uri of + "" -> True + "http:" -> True + "https:" -> True + _ -> False + +parseURL :: String -> Maybe URL +parseURL url = parseURIReference url + >>= (\uri -> if isHttp uri then Just (URL url) else Nothing) + -- | Voices supported by @\@. See -- . data Voice = Man (Maybe Lang) | Woman (Maybe Lang) | Alice (Maybe LangAlice) + deriving (Data, Eq, Generic, NFData, Ord, Read, Show, Typeable) -- | Languages spoken by voices 'Man' and 'Woman'. See -- . @@ -131,14 +158,15 @@ | French | German | Italian + deriving (Data, Eq, Generic, NFData, Ord, Read, Show, Typeable) -instance Show Lang where - show English = "en" - show EnglishUK = "en-gb" - show Spanish = "es" - show French = "fr" - show German = "de" - show Italian = "it" +instance ToAttrValue Lang where + toAttrValue English = "en" + toAttrValue EnglishUK = "en-gb" + toAttrValue Spanish = "es" + toAttrValue French = "fr" + toAttrValue German = "de" + toAttrValue Italian = "it" -- | Languages spoken by 'Alice'. See -- . @@ -169,204 +197,43 @@ | ZhCN -- ^ Chinese (Mandarin) | ZhHK -- ^ Chinese (Cantonese) | ZhTW -- ^ Chinese (Taiwanese Mandarin) - -instance Show LangAlice where - show DaDK = "da-DK" - show DeDE = "de-DE" - show EnAU = "en-AU" - show EnCA = "en-CA" - show EnGB = "en-GB" - show EnIN = "en-IN" - show EnUS = "en-US" - show CaES = "ca-ES" - show EsES = "es-ES" - show EsMX = "es-MX" - show FiFI = "fi-FI" - show FrCA = "fr-CA" - show FrFR = "fr-FR" - show ItIT = "it-IT" - show JaJP = "ja-JP" - show KoKR = "ko-KR" - show NbNO = "nb-NO" - show NlNL = "nl-NL" - show PlPL = "pl-PL" - show PtBR = "pt-BR" - show PtPT = "pt-PT" - show RuRU = "ru-RU" - show SvSE = "sv-SE" - show ZhCN = "zh-CN" - show ZhHK = "zh-HK" - show ZhTW = "zh-TW" - --- | See . -data PlayAttributes = PlayAttributes - { playLoop :: Maybe Natural - , playDigits :: Maybe [Digit] - } - -defaultPlayAttributes :: PlayAttributes -defaultPlayAttributes = PlayAttributes - { playLoop = Nothing - , playDigits = Nothing - } - --- | See . -data GatherAttributes = GatherAttributes - { gatherAction :: Maybe URL - , gatherMethod :: Maybe Method - , gatherTimeout :: Maybe Natural - , gatherFinishOnKey :: Maybe Key - , gatherNumDigits :: Maybe Natural - } - -defaultGatherAttributes :: GatherAttributes -defaultGatherAttributes = GatherAttributes - { gatherAction = Nothing - , gatherMethod = Nothing - , gatherTimeout = Nothing - , gatherFinishOnKey = Nothing - , gatherNumDigits = Nothing - } - --- | For some @Twiml p t@, the constraint @(p ':/~' 'Gather'')@ lets us enforce --- TwiML nesting rules. -data Gather' - --- | See . -data RecordAttributes = RecordAttributes - { recordAction :: Maybe URL - , recordMethod :: Maybe Method - , recordTimeout :: Maybe Natural - , recordFinishOnKey :: Maybe Key - , recordMaxLength :: Maybe Natural - , recordTranscribe :: Maybe Bool - , recordTranscribeCallback :: Maybe URL - , recordPlayBeep :: Maybe Bool - } - -defaultRecordAttributes :: RecordAttributes -defaultRecordAttributes = RecordAttributes - { recordAction = Nothing - , recordMethod = Nothing - , recordTimeout = Nothing - , recordFinishOnKey = Nothing - , recordMaxLength = Nothing - , recordTranscribe = Nothing - , recordTranscribeCallback = Nothing - , recordPlayBeep = Nothing - } - --- | See . -data SmsAttributes = SmsAttributes - { smsTo :: Maybe String - , smsFrom :: Maybe String - , smsAction :: Maybe URL - , smsMethod :: Maybe Method - , smsStatusCallback :: Maybe URL - } - -defaultSmsAttributes :: SmsAttributes -defaultSmsAttributes = SmsAttributes - { smsTo = Nothing - , smsFrom = Nothing - , smsAction = Nothing - , smsMethod = Nothing - , smsStatusCallback = Nothing - } - --- | See . -data DialAttributes = DialAttributes - { dialAction :: Maybe URL - , dialMethod :: Maybe Method - , dialTimeout :: Maybe Natural - , dialHangupOnStar :: Maybe Bool - , dialTimeLimit :: Maybe Natural - , dialCallerId :: Maybe String - , dialRecord :: Maybe Bool - } - -defaultDialAttributes :: DialAttributes -defaultDialAttributes = DialAttributes - { dialAction = Nothing - , dialMethod = Nothing - , dialTimeout = Nothing - , dialHangupOnStar = Nothing - , dialTimeLimit = Nothing - , dialCallerId = Nothing - , dialRecord = Nothing - } - --- | See . -data NumberAttributes = NumberAttributes - { numberSendDigits :: Maybe [Digit] - , numberURL :: Maybe URL - , numberMethod :: Maybe Method - } - -defaultNumberAttributes :: NumberAttributes -defaultNumberAttributes = NumberAttributes - { numberSendDigits = Nothing - , numberURL = Nothing - , numberMethod = Nothing - } - --- | See . -data SipAttributes = SipAttributes - { sipUsername :: Maybe String - , sipPassword :: Maybe String - , sipTransport :: Maybe Transport - , sipHeaders :: Maybe String -- NOTE: Under 1024 characters. - , sipURL :: Maybe URL - , sipMethod :: Maybe Method - } + deriving (Data, Eq, Generic, NFData, Ord, Read, Show, Typeable) -defaultSipAttributes :: SipAttributes -defaultSipAttributes = SipAttributes - { sipUsername = Nothing - , sipPassword = Nothing - , sipTransport = Nothing - , sipHeaders = Nothing - , sipURL = Nothing - , sipMethod = Nothing - } +instance ToAttrValue LangAlice where + toAttrValue DaDK = "da-DK" + toAttrValue DeDE = "de-DE" + toAttrValue EnAU = "en-AU" + toAttrValue EnCA = "en-CA" + toAttrValue EnGB = "en-GB" + toAttrValue EnIN = "en-IN" + toAttrValue EnUS = "en-US" + toAttrValue CaES = "ca-ES" + toAttrValue EsES = "es-ES" + toAttrValue EsMX = "es-MX" + toAttrValue FiFI = "fi-FI" + toAttrValue FrCA = "fr-CA" + toAttrValue FrFR = "fr-FR" + toAttrValue ItIT = "it-IT" + toAttrValue JaJP = "ja-JP" + toAttrValue KoKR = "ko-KR" + toAttrValue NbNO = "nb-NO" + toAttrValue NlNL = "nl-NL" + toAttrValue PlPL = "pl-PL" + toAttrValue PtBR = "pt-BR" + toAttrValue PtPT = "pt-PT" + toAttrValue RuRU = "ru-RU" + toAttrValue SvSE = "sv-SE" + toAttrValue ZhCN = "zh-CN" + toAttrValue ZhHK = "zh-HK" + toAttrValue ZhTW = "zh-TW" -- | See . data Transport = TCP | UDP - deriving Show - --- | See . -data ClientAttributes = ClientAttributes - { clientURL :: Maybe URL - , clientMethod :: Maybe Method - } - -defaultClientAttributes :: ClientAttributes -defaultClientAttributes = ClientAttributes - { clientURL = Nothing - , clientMethod = Nothing - } - --- | See . -data ConferenceAttributes = ConferenceAttributes - { conferenceMuted :: Maybe Bool - , conferenceBeep :: Maybe Bool - , conferenceStartOnEnter :: Maybe Bool - , conferenceEndOnExit :: Maybe Bool - , conferenceWaitURL :: Maybe URL - , conferenceWaitMethod :: Maybe Method - , conferenceMaxParticipants :: Maybe Natural -- FIXME: Non-zero, less than 40. - } + deriving (Bounded, Data, Enum, Eq, Generic, NFData, Ord, Read, Show, Typeable) -defaultConferenceAttributes :: ConferenceAttributes -defaultConferenceAttributes = ConferenceAttributes - { conferenceMuted = Nothing - , conferenceBeep = Nothing - , conferenceStartOnEnter = Nothing - , conferenceEndOnExit = Nothing - , conferenceWaitURL = Nothing - , conferenceWaitMethod = Nothing - , conferenceMaxParticipants = Nothing - } +instance ToAttrValue Transport where + toAttrValue TCP = "tcp" + toAttrValue UDP = "udp" -- | See . data ConferenceBeep @@ -374,68 +241,13 @@ | No | OnExit | OnEnter - -instance Show ConferenceBeep where - show Yes = "yes" - show No = "no" - show OnExit = "onExit" - show OnEnter = "onEnter" - --- | See . -data QueueAttributes = QueueAttributes - { queueURL :: Maybe URL - , queueMethod :: Maybe Method - } - -defaultQueueAttributes :: QueueAttributes -defaultQueueAttributes = QueueAttributes - { queueURL = Nothing - , queueMethod = Nothing - } - --- | See . -data DialNoun - = Number NumberAttributes String - | Sip SipAttributes URL -- NOTE: URL must be under 255 characters. - | Client ClientAttributes String - | Conference ConferenceAttributes String - | Queue QueueAttributes String - --- | See . -data EnqueueAttributes = EnqueueAttributes - { enqueueAction :: Maybe URL - , enqueueMethod :: Maybe Method - , enqueueWaitURL :: Maybe URL - , enqueueWaitURLMethod :: Maybe Method - } - -defaultEnqueueAttributes :: EnqueueAttributes -defaultEnqueueAttributes = EnqueueAttributes - { enqueueAction = Nothing - , enqueueMethod = Nothing - , enqueueWaitURL = Nothing - , enqueueWaitURLMethod = Nothing - } - --- | See . -data RedirectAttributes = RedirectAttributes - { redirectMethod :: Maybe Method - } - -defaultRedirectAttributes :: RedirectAttributes -defaultRedirectAttributes = RedirectAttributes - { redirectMethod = Nothing - } - --- | See . -data RejectAttributes = RejectAttributes - { rejectReason :: Maybe Reason - } + deriving (Bounded, Data, Enum, Eq, Generic, NFData, Ord, Read, Show, Typeable) -defaultRejectAttributes :: RejectAttributes -defaultRejectAttributes = RejectAttributes - { rejectReason = Nothing - } +instance ToAttrValue ConferenceBeep where + toAttrValue Yes = "yes" + toAttrValue No = "no" + toAttrValue OnExit = "on-exit" + toAttrValue OnEnter = "on-enter" -- | The reason attribute takes the values \"rejected\" and \"busy.\" This tells -- Twilio what message to play when rejecting a call. Selecting \"busy\" will @@ -443,245 +255,13 @@ -- standard not-in-service response. -- See . data Reason = Rejected | Busy - -instance Show Reason where - show Rejected = "rejected" - show Busy = "busy" - --- | See . -data PauseAttributes = PauseAttributes - { pauseLength :: Maybe Natural - } - -defaultPauseAttributes :: PauseAttributes -defaultPauseAttributes = PauseAttributes - { pauseLength = Nothing - } - -{- Attribute Lens Classes -} - -class HasLoop t where - loop :: Lens t t (Maybe Natural) Natural - -class HasAction t where - action :: Lens t t (Maybe URL) URL - -class HasMethod t where - method :: Lens t t (Maybe Method) Method - -class HasTimeout t where - timeout :: Lens t t (Maybe Natural) Natural - -class HasFinishOnKey t where - finishOnKey :: Lens t t (Maybe Key) Key - -{- URL, Method & Transport -} - -data URL = URL { getURL :: String } - -instance Show URL where - show = getURL - --- | Checks whether a @URI@'s scheme, if any, is one of @"http:"@ or @"https:"@. -isHttp :: URI -> Bool -isHttp uri = case uriScheme uri of - "" -> True - "http:" -> True - "https:" -> True - _ -> False - -parseURL :: String -> Maybe URL -parseURL url = parseURIReference url - >>= (\uri -> if isHttp uri then Just (URL url) else Nothing) - -data Method = GET | POST - deriving Show - -type Natural = Int - -{- Twiml Datatypes -} - -data Key - = K0 -- ^ 0 - | K1 -- ^ 1 - | K2 -- ^ 2 - | K3 -- ^ 3 - | K4 -- ^ 4 - | K5 -- ^ 5 - | K6 -- ^ 6 - | K7 -- ^ 7 - | K8 -- ^ 8 - | K9 -- ^ 9 - | KStar -- ^ \* - | KPound -- ^ # - -instance Show Key where - show K0 = "0" - show K1 = "1" - show K2 = "2" - show K3 = "3" - show K4 = "4" - show K5 = "5" - show K6 = "6" - show K7 = "7" - show K8 = "8" - show K9 = "9" - show KStar = "*" - show KPound = "#" - -{- Voices & Languages -} - -data GatherNoun - --- | The ‘digits’ attribute lets you play DTMF tones during a call. See --- . -data Digit - = D0 -- ^ 0 - | D1 -- ^ 1 - | D2 -- ^ 2 - | D3 -- ^ 3 - | D4 -- ^ 4 - | D5 -- ^ 5 - | D6 -- ^ 6 - | D7 -- ^ 7 - | D8 -- ^ 8 - | D9 -- ^ 9 - | W -- ^ w - -instance Show Digit where - show D0 = "0" - show D1 = "1" - show D2 = "2" - show D3 = "3" - show D4 = "4" - show D5 = "5" - show D6 = "6" - show D7 = "7" - show D8 = "8" - show D9 = "9" - show W = "w" - -{- Basic Lens Functionality -} - --- $lens The following section extracts a number of definitions required to get --- lenses, as defined in the lens package, working, without relying on the lens --- package itself. Rather than use the following functions, consider installing --- lens. See . - --- The following definitions were extracted from the lens package. - -type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t - -lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b -lens sa sbt afb s = fmap (sbt s) $ afb (sa s) -{-# INLINE lens #-} - -type Lens' s a = Lens s s a a - -newtype Accessor r a = Accessor { runAccessor :: r } - -instance Functor (Accessor r) where - fmap _ (Accessor m) = Accessor m - {-# INLINE fmap #-} - -instance Contravariant (Accessor r) where - contramap _ (Accessor m) = Accessor m - {-# INLINE contramap #-} - -type Getting r s a = (a -> Accessor r a) -> s -> Accessor r s - -infixl 8 ^. - -(^.) :: s -> Getting a s a -> a -s ^. l = runAccessor (l Accessor s) -{-# INLINE (^.) #-} - -type Setting p s t a b = p a (Mutator b) -> s -> Mutator t - -newtype Mutator a = Mutator { runMutator :: a } - -instance Functor Mutator where - fmap f (Mutator a) = Mutator $ f a - {-# INLINE fmap #-} - -over :: Profunctor p => Setting p s t a b -> p a b -> s -> t -over l f = runMutator #. l (Mutator #. f) - -type IndexPreservingGetter s a - = forall p f. (Profunctor p, Contravariant f, Functor f) => p a (f a) -> p s (f s) - -to' :: (s -> a) -> IndexPreservingGetter s a -to' f = dimap f coerce -{-# INLINE to' #-} - -coerce :: (Contravariant f, Functor f) => f a -> f b -coerce a = fmap absurd $ contramap absurd a - --- The following definition was extracted from the contravariant package. - -class Contravariant f where - contramap :: (a -> b) -> f b -> f a - --- The following definitions were extracted from the void package. - -newtype Void = Void Void - -absurd :: Void -> a -absurd (Void a) = absurd a - --- The following definitions were extracted from the profunctors package. - -class Profunctor h where - lmap :: (a -> b) -> h b c -> h a c - rmap :: (b -> c) -> h a b -> h a c - dimap :: (a -> b) -> (c -> d) -> h b c -> h a d - dimap f g = lmap f . rmap g - (#.) :: (b -> c) -> h a b -> h a c - (#.) = \f -> \p -> p `seq` rmap f p - -instance Profunctor (->) where - dimap ab cd bc = cd . bc . ab - {-# INLINE dimap #-} - lmap = flip (.) - {-# INLINE lmap #-} - rmap = (.) - {-# INLINE rmap #-} - (#.) _ = unsafeCoerce - {-# INLINE (#.) #-} - -{- Fix & Foldable -} - --- $fix The following definitions were extracted from the recursion-schemes --- package. See . - -newtype Fix f = Fix { unFix :: f (Fix f) } - -type family Base t :: * -> * - -class Functor (Base t) => Foldable t where - project :: t -> Base t t - cata :: (Base t a -> a) -> t -> a - cata f = c where c = f . fmap c . project - -{- Type Inequality -} - --- $type The following defines ':/~' to mean inequality at the type level. --- Borrowed from HList. See . - -data Yes - -data No - -class TypeCast a b | a -> b - -instance TypeCast a a - -class TypeEq a b c | a b -> c - -instance TypeEq x x Yes - -instance TypeCast No b => TypeEq x y b + deriving (Bounded, Data, Enum, Eq, Generic, NFData, Ord, Read, Show, Typeable) -class TypeEq x y No => (:/~) x y +instance ToAttrValue Reason where + toAttrValue Rejected = "rejected" + toAttrValue Busy = "busy" -instance TypeEq x y No => (:/~) x y +instance ToAttrValue Voice where + toAttrValue (Man _) = "man" + toAttrValue (Woman _) = "woman" + toAttrValue (Alice _) = "alice" diff --git a/src/Text/XML/Twiml/Verbs.hs b/src/Text/XML/Twiml/Verbs.hs --- a/src/Text/XML/Twiml/Verbs.hs +++ b/src/Text/XML/Twiml/Verbs.hs @@ -1,47 +1,28 @@ -{-#LANGUAGE FlexibleInstances #-} -{-#LANGUAGE RankNTypes #-} - -module Text.XML.Twiml.Verbs - ( -- * Verbs - module Text.XML.Twiml.Verbs.End - -- ** Primary - , module Text.XML.Twiml.Verbs.Say - , module Text.XML.Twiml.Verbs.Play - , module Text.XML.Twiml.Verbs.Gather - , module Text.XML.Twiml.Verbs.Record - , module Text.XML.Twiml.Verbs.Sms - , module Text.XML.Twiml.Verbs.Dial - -- ** Secondary - , module Text.XML.Twiml.Verbs.Enqueue - , module Text.XML.Twiml.Verbs.Leave - , module Text.XML.Twiml.Verbs.Hangup - , module Text.XML.Twiml.Verbs.Redirect - , module Text.XML.Twiml.Verbs.Reject - , module Text.XML.Twiml.Verbs.Pause - ) where - -import Text.XML.Twiml.Verbs.End - -import Text.XML.Twiml.Verbs.Say -import Text.XML.Twiml.Verbs.Play -import Text.XML.Twiml.Verbs.Gather -import Text.XML.Twiml.Verbs.Record -import Text.XML.Twiml.Verbs.Sms -import Text.XML.Twiml.Verbs.Dial - -import Text.XML.Twiml.Verbs.Enqueue -import Text.XML.Twiml.Verbs.Leave -import Text.XML.Twiml.Verbs.Hangup -import Text.XML.Twiml.Verbs.Redirect -import Text.XML.Twiml.Verbs.Reject -import Text.XML.Twiml.Verbs.Pause - -import Text.XML.Twiml.Types (URL(..), Method(..), Key(..), Natural) --- import Text.XML.Twiml.Internal (Twiml, setSayLoop, sayLoop, setPlayLoop, playLoop, gatherAction, setGatherAction, recordAction, setRecordAction, smsAction, setSmsAction, dialAction, setDialAction, gatherMethod, setGatherMethod, recordMethod, setRecordMethod, smsMethod, setSmsMethod, dialMethod, setDialMethod, redirectMethod, setRedirectMethod, gatherTimeout, setGatherTimeout, recordTimeout, setRecordTimeout, dialTimeout, setDialTimeout, gatherFinishOnKey, setGatherFinishOnKey, recordFinishOnKey, setRecordFinishOnKey) -import Text.XML.Twiml.Internal - -{- Lenses -} - --- $lenses The following classes and lenses abstract over attributes shared by --- two or more TwiML verbs. +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml.Verbs +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional -- +-- This module re-exports all the TwiML verbs. For more information, refer to +-- Twilio's documentation on +-- . +------------------------------------------------------------------------------- +module Text.XML.Twiml.Verbs (module X) where + +import Text.XML.Twiml.Verbs.Dial as X +import Text.XML.Twiml.Verbs.End as X +import Text.XML.Twiml.Verbs.Enqueue as X +import Text.XML.Twiml.Verbs.Gather as X +import Text.XML.Twiml.Verbs.Hangup as X +import Text.XML.Twiml.Verbs.Leave as X +import Text.XML.Twiml.Verbs.Message as X +import Text.XML.Twiml.Verbs.Pause as X +import Text.XML.Twiml.Verbs.Play as X +import Text.XML.Twiml.Verbs.Record as X +import Text.XML.Twiml.Verbs.Redirect as X +import Text.XML.Twiml.Verbs.Reject as X +import Text.XML.Twiml.Verbs.Say as X +import Text.XML.Twiml.Verbs.Sms as X diff --git a/src/Text/XML/Twiml/Verbs/Dial.hs b/src/Text/XML/Twiml/Verbs/Dial.hs --- a/src/Text/XML/Twiml/Verbs/Dial.hs +++ b/src/Text/XML/Twiml/Verbs/Dial.hs @@ -1,141 +1,97 @@ -{-#LANGUAGE FlexibleContexts #-} -{-#LANGUAGE FlexibleInstances #-} -{-#LANGUAGE MultiParamTypeClasses #-} -{-#LANGUAGE TypeOperators #-} - +{-# OPTIONS_GHC -cpp -optP -P -Itest/examples #-} +{-# LANGUAGE FlexibleContexts #-} +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml.Verbs.Dial +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +-- +-- The examples in this file assume +-- +-- @ +-- {-\# LANGUAGE RebindableSyntax \#-} +-- {-\# LANGUAGE RecordWildCards \#-} +-- +-- import Prelude +-- import Text.XML.Twiml +-- import qualified Text.XML.Twiml.Syntax as Twiml +-- @ +-- +-- For more information, refer to Twilio's +-- >. +------------------------------------------------------------------------------- module Text.XML.Twiml.Verbs.Dial - ( -- * @\@ - -- $dial - Dial - -- ** Constructors - , dial + ( dial , dial' - -- ** Attributes - , DialAttributes(..) - , defaultDialAttributes - -- *** Lenses - , dialAttributes - , hangupOnStar - , timeLimit - , callerId - , recordDial - , action - , method - , timeout - -- ** Dial Nouns - , DialNoun(..) - -- *** @\@ - , NumberAttributes(..) - , defaultNumberAttributes - -- *** @\@ - , SipAttributes(..) - , defaultSipAttributes - -- *** @\@ - , ClientAttributes(..) - , defaultClientAttributes - -- *** @\@ - , ConferenceAttributes(..) - , defaultConferenceAttributes - -- *** @\@ - , QueueAttributes(..) - , defaultQueueAttributes + , Dial + , DialF + , DialAttributes + -- * Nouns + , dialNoun + , DialNoun + , DialNounF + -- ** Client + , client + , Client + , ClientF + , ClientAttributes + -- ** Conference + , conference + , Conference + , ConferenceF + , ConferenceAttributes + -- ** Number + , number + , Number + , NumberF + , NumberAttributes + -- ** Queue + , queue + , Queue + , QueueF + , QueueAttributes + -- ** Sip + , sip + , Sip + , SipF + , SipAttributes ) where +import Data.Void +import Text.XML.Twiml.Internal +import Text.XML.Twiml.Internal.Twiml import Text.XML.Twiml.Types -import Text.XML.Twiml.Internal (Twiml(..), Twiml', TwimlF(..)) -{- $dial This example - -@ -module Example where - -import Control.Lens -import Text.XML.Twiml - -example - = respond - . (dial (Right \"415-123-4567\") \<&\> timeout .~ 10 - \<&\> record .~ True) - $ end -@ - -produces the following TwiML response: +{- | Dial a number. Example: -@ -\ -\ - \415-123-4567\<\/Dial\> -\<\/Response\> -@ +#include "dialExample1.txt" -} - -newtype Dial p = Dial { fromDial :: Twiml' p } -instance (p :/~ Gather') => Twiml p (Dial p) where toTwiml' = fromDial - -dial :: (Twiml p t, p :/~ Gather') => Either DialNoun String -> t -> Dial p -dial = dial' defaultDialAttributes - -dial' :: (Twiml p t, p :/~ Gather') - => DialAttributes -> Either DialNoun String -> t -> Dial p -dial' attrs n = Dial . Fix . DialF attrs n . toTwiml' - -dialAttributes :: Lens' (Dial p) DialAttributes -dialAttributes = lens - (\(Dial (Fix (DialF attributes _ _))) -> attributes) - (\(Dial (Fix (DialF _ n a))) attributes -> - Dial (Fix (DialF attributes n a))) - -setDialAction :: DialAttributes -> URL -> DialAttributes -setDialAction attrs action = attrs { dialAction = Just action } - -setDialMethod :: DialAttributes -> Method -> DialAttributes -setDialMethod attrs method = attrs { dialMethod = Just method } - -setDialTimeout :: DialAttributes -> Natural -> DialAttributes -setDialTimeout attrs timeout = attrs { dialTimeout = Just timeout } - -setDialHangupOnStar :: DialAttributes -> Bool -> DialAttributes -setDialHangupOnStar attrs hangupOnStar - = attrs { dialHangupOnStar = Just hangupOnStar } - -setDialTimeLimit :: DialAttributes -> Natural -> DialAttributes -setDialTimeLimit attrs timeLimit = attrs { dialTimeLimit = Just timeLimit } - -setDialCallerId :: DialAttributes -> String -> DialAttributes -setDialCallerId attrs callerId = attrs { dialCallerId = Just callerId } - -setDialRecord :: DialAttributes -> Bool -> DialAttributes -setDialRecord attrs record = attrs { dialRecord = Just record } - -hangupOnStar :: Lens (Dial p) (Dial p) (Maybe Bool) Bool -hangupOnStar = lens (^. dialAttributes . to' dialHangupOnStar) - (\t v -> over dialAttributes (flip setDialHangupOnStar v) t) +dial :: IsTwimlLike f Dial => String -> DialAttributes -> TwimlLike f Dial () +dial a b = iliftF . inj $ DialF (pure a) b () -timeLimit :: Lens (Dial p) (Dial p) (Maybe Natural) Natural -timeLimit = lens (^. dialAttributes . to' dialTimeLimit) - (\t v -> over dialAttributes (flip setDialTimeLimit v) t) +{- | Dial a number or 'DialNoun'. Example: -callerId :: Lens (Dial p) (Dial p) (Maybe String) String -callerId = lens (^. dialAttributes . to' dialCallerId) - (\t v -> over dialAttributes (flip setDialCallerId v) t) +#include "dialExample3.txt" +-} +dial' :: IsTwimlLike f Dial => Either DialNoun String -> DialAttributes -> TwimlLike f Dial () +dial' a b = iliftF . inj $ DialF a b () -recordDial :: Lens (Dial p) (Dial p) (Maybe Bool) Bool -recordDial = lens (^. dialAttributes . to' dialRecord) - (\t v -> over dialAttributes (flip setDialRecord v) t) +dialNoun :: TwimlLike DialNounF i Void -> DialNoun +dialNoun = DialNoun -instance HasAction (Dial p) where - action = lens getAction setAction where - getAction = (^. dialAttributes . to' dialAction) - setAction t v = over dialAttributes (flip setDialAction v) t +client :: IsTwimlLike f Client => String -> ClientAttributes -> TwimlLike f Client a +client a b = iliftF . inj $ ClientF a b -instance HasMethod (Dial p) where - method = lens getMethod setMethod where - getMethod = (^. dialAttributes . to' dialMethod) - setMethod t v = over dialAttributes (flip setDialMethod v) t +conference :: IsTwimlLike f Conference => String -> ConferenceAttributes -> TwimlLike f Conference a +conference a b = iliftF . inj $ ConferenceF a b -instance HasTimeout (Dial p) where - timeout = lens getTimeout setTimeout where - getTimeout = (^. dialAttributes . to' dialTimeout) - setTimeout t v = over dialAttributes (flip setDialTimeout v) t +number :: IsTwimlLike f Number => String -> NumberAttributes -> TwimlLike f Number a +number a b = iliftF . inj $ NumberF a b +queue :: IsTwimlLike f Queue => String -> QueueAttributes -> TwimlLike f Queue a +queue a b = iliftF . inj $ QueueF a b +sip :: IsTwimlLike f Sip => URL -> SipAttributes -> TwimlLike f Sip a +sip a b = iliftF . inj $ SipF a b diff --git a/src/Text/XML/Twiml/Verbs/End.hs b/src/Text/XML/Twiml/Verbs/End.hs --- a/src/Text/XML/Twiml/Verbs/End.hs +++ b/src/Text/XML/Twiml/Verbs/End.hs @@ -1,40 +1,49 @@ -{-#LANGUAGE FlexibleInstances #-} -{-#LANGUAGE MultiParamTypeClasses #-} - +{-# OPTIONS_GHC -cpp -optP -P -Itest/examples #-} +{-# LANGUAGE FlexibleContexts #-} +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml.Verbs.End +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +-- +-- The example in this file assumes +-- +-- @ +-- {-\# LANGUAGE RebindableSyntax \#-} +-- {-\# LANGUAGE RecordWildCards \#-} +-- +-- import Prelude +-- import Text.XML.Twiml +-- import qualified Text.XML.Twiml.Syntax as Twiml +-- @ +-- +-- End is not actually a TwiML verb; it is used for terminating TwiML. +------------------------------------------------------------------------------- module Text.XML.Twiml.Verbs.End - ( -- * End - -- $end - End - -- ** Constructor - , end + ( end + , End + , EndF ) where -import Text.XML.Twiml.Types -import Text.XML.Twiml.Internal (Twiml(..), Twiml', TwimlF(..)) +import Text.XML.Twiml.Internal +import Text.XML.Twiml.Internal.Twiml -{- $end 'End' is not actually a TwiML verb, but this library uses it to -terminate 'Twiml'. This example +{- | Terminate a TwiML response, or construct an empty TwiML response. Example: @ -module Example where - -import Text.XML.Twiml - -example - = respond - $ end +example :: VoiceTwiml +example = + response $ do + 'end' + where Twiml.Syntax{..} = def @ -produces the following empty TwiML response: - -@ -\ -\ -@ +>>> show example + + + -} - -newtype End p = End { fromEnd :: Twiml' p } -instance Twiml p (End p) where toTwiml' = fromEnd - -end :: End p -end = End . Fix $ EndF +end :: IsTwimlLike f End => TwimlLike f End a +end = iliftF $ inj EndF diff --git a/src/Text/XML/Twiml/Verbs/Enqueue.hs b/src/Text/XML/Twiml/Verbs/Enqueue.hs --- a/src/Text/XML/Twiml/Verbs/Enqueue.hs +++ b/src/Text/XML/Twiml/Verbs/Enqueue.hs @@ -1,95 +1,40 @@ -{-#LANGUAGE FlexibleContexts #-} -{-#LANGUAGE FlexibleInstances #-} -{-#LANGUAGE MultiParamTypeClasses #-} -{-#LANGUAGE TypeOperators #-} - +{-# OPTIONS_GHC -cpp -optP -P -Itest/examples #-} +{-# LANGUAGE FlexibleContexts #-} +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml.Verbs.Enqueue +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +-- +-- The example in this file assumes +-- +-- @ +-- {-\# LANGUAGE RebindableSyntax \#-} +-- {-\# LANGUAGE RecordWildCards \#-} +-- +-- import Prelude +-- import Text.XML.Twiml +-- import qualified Text.XML.Twiml.Syntax as Twiml +-- @ +-- +-- For more information, refer to Twilio's +-- >. +------------------------------------------------------------------------------- module Text.XML.Twiml.Verbs.Enqueue - ( -- * @\@ - -- $enqueue - Enqueue - -- ** Constructors - , enqueue - , enqueue' - -- ** Attributes - , EnqueueAttributes(..) - , defaultEnqueueAttributes - -- *** Lenses - , enqueueAttributes - , action - , method - , waitURL - , waitURLMethod + ( enqueue + , Enqueue + , EnqueueF + , EnqueueAttributes ) where -import Text.XML.Twiml.Types -import Text.XML.Twiml.Internal (Twiml(..), Twiml', TwimlF(..)) - -{- $enqueue This example - -@ -module Example where - -import Control.Lens -import Data.Maybe (fromJust) -import Text.XML.Twiml - -example - = respond - . (enqueue \"support\" \<&\> waitURL .~ (fromJust $ parseURL \"wait-music.xml\")) - $ end -@ +import Text.XML.Twiml.Internal +import Text.XML.Twiml.Internal.Twiml -produces the following TwiML response: +{- | Enqueue a caller in a queue. Example: -@ -\ -\ - \support\<\/Enqueue\> -\<\/Response\> -@ +#include "enqueueExample1.txt" -} - -newtype Enqueue p = Enqueue { fromEnqueue :: Twiml' p } -instance (p :/~ Gather') => Twiml p (Enqueue p) where toTwiml' = fromEnqueue - -enqueue :: (Twiml p t, p :/~ Gather') => String -> t -> Enqueue p -enqueue name = Enqueue . Fix . EnqueueF defaultEnqueueAttributes name . toTwiml' - -enqueue' :: (Twiml p t, p :/~ Gather') => EnqueueAttributes -> String -> t -> Enqueue p -enqueue' attrs name = Enqueue . Fix . EnqueueF attrs name . toTwiml' - -enqueueAttributes :: Lens' (Enqueue p) EnqueueAttributes -enqueueAttributes = lens - (\(Enqueue (Fix (EnqueueF attributes _ _))) -> attributes) - (\(Enqueue (Fix (EnqueueF _ n a))) attributes -> - Enqueue (Fix (EnqueueF attributes n a))) - -setEnqueueAction :: EnqueueAttributes -> URL -> EnqueueAttributes -setEnqueueAction attrs action = attrs { enqueueAction = Just action } - -setEnqueueMethod :: EnqueueAttributes -> Method -> EnqueueAttributes -setEnqueueMethod attrs method = attrs { enqueueMethod = Just method } - -setEnqueueWaitURL :: EnqueueAttributes -> URL -> EnqueueAttributes -setEnqueueWaitURL attrs url = attrs { enqueueWaitURL = Just url } - -setEnqueueWaitURLMethod :: EnqueueAttributes -> Method -> EnqueueAttributes -setEnqueueWaitURLMethod attrs meth = attrs { enqueueWaitURLMethod = Just meth } - -instance HasAction (Enqueue p) where - action = lens getAction setAction where - getAction = (^. enqueueAttributes . to' enqueueAction) - setAction t v = over enqueueAttributes (flip setEnqueueAction v) t - -instance HasMethod (Enqueue p) where - method = lens getMethod setMethod where - getMethod = (^. enqueueAttributes . to' enqueueMethod) - setMethod t v = over enqueueAttributes (flip setEnqueueMethod v) t - -waitURL :: Lens (Enqueue p) (Enqueue p) (Maybe URL) URL -waitURL = lens (^. enqueueAttributes . to' enqueueWaitURL) - (\t v -> over enqueueAttributes (flip setEnqueueWaitURL v) t) - -waitURLMethod :: Lens (Enqueue p) (Enqueue p) (Maybe Method) Method -waitURLMethod = lens (^. enqueueAttributes . to' enqueueWaitURLMethod) - (\t v -> over enqueueAttributes (flip setEnqueueWaitURLMethod v) t) +enqueue :: IsTwimlLike f Enqueue => String -> EnqueueAttributes -> TwimlLike f Enqueue () +enqueue a b = iliftF . inj $ EnqueueF a b () diff --git a/src/Text/XML/Twiml/Verbs/Gather.hs b/src/Text/XML/Twiml/Verbs/Gather.hs --- a/src/Text/XML/Twiml/Verbs/Gather.hs +++ b/src/Text/XML/Twiml/Verbs/Gather.hs @@ -1,116 +1,41 @@ -{-#LANGUAGE FlexibleContexts #-} -{-#LANGUAGE FlexibleInstances #-} -{-#LANGUAGE MultiParamTypeClasses #-} -{-#LANGUAGE RankNTypes #-} -{-#LANGUAGE TypeOperators #-} - +{-# OPTIONS_GHC -cpp -optP -P -Itest/examples #-} +{-# LANGUAGE FlexibleContexts #-} +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml.Verbs.Gather +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +-- +-- The example in this file assumes +-- +-- @ +-- {-\# LANGUAGE RebindableSyntax \#-} +-- {-\# LANGUAGE RecordWildCards \#-} +-- +-- import Prelude +-- import Text.XML.Twiml +-- import qualified Text.XML.Twiml.Syntax as Twiml +-- @ +-- +-- For more information, refer to Twilio's +-- >. +------------------------------------------------------------------------------- module Text.XML.Twiml.Verbs.Gather - ( -- * @\@ - -- $gather - Gather - -- ** Constructors - , gather - , gather' - -- ** Attributes - , GatherAttributes(..) - , defaultGatherAttributes - -- *** Lenses - , gatherAttributes - , numDigits - , action - , method - , timeout - , finishOnKey + ( gather + , Gather + , GatherF + , GatherAttributes ) where -import Text.XML.Twiml.Types -import Text.XML.Twiml.Internal (Twiml(..), Twiml', TwimlF(..)) -import Text.XML.Twiml.Verbs.End - -import Unsafe.Coerce (unsafeCoerce) - -{- $gather This example - -@ -module Example where - -import Control.Lens -import Text.XML.Twiml - -example - = respond - . (gather \<&\> timeout .~ 10 - \<&\> finishOnKey .~ KStar - $ say \"Please enter your pin number and then press star.\" - $ end) - $ end -@ +import Data.Void +import Text.XML.Twiml.Internal +import Text.XML.Twiml.Internal.Twiml -produces the following TwiML response: +{- | Example: -@ -\ -\ - \ - \Please enter your pin number and then press star.\<\/Say\> - \<\/Gather\> -\<\/Response\> -@ +#include "gatherExample2.txt" -} - -newtype Gather p = Gather { fromGather :: Twiml' p } -instance (p :/~ Gather') => Twiml p (Gather p) where toTwiml' = fromGather - -gather :: (Twiml Gather' n, Twiml p t, p :/~ Gather') => n -> t -> Gather p -gather = gather' defaultGatherAttributes - -gather' :: (Twiml Gather' n, Twiml p t, p :/~ Gather') - => GatherAttributes -> n -> t -> Gather p -gather' attrs n - = Gather . Fix . GatherF attrs (toTwiml' n) . toTwiml' - -gatherAttributes :: Lens' (Gather p) GatherAttributes -gatherAttributes = lens - (\(Gather (Fix (GatherF attributes _ _))) -> attributes) - (\(Gather (Fix (GatherF _ n a))) attributes -> - Gather (Fix (GatherF attributes n a))) - -setGatherAction :: GatherAttributes -> URL -> GatherAttributes -setGatherAction attrs action = attrs { gatherAction = Just action } - -setGatherMethod :: GatherAttributes -> Method -> GatherAttributes -setGatherMethod attrs method = attrs { gatherMethod = Just method } - -setGatherTimeout :: GatherAttributes -> Natural -> GatherAttributes -setGatherTimeout attrs timeout = attrs { gatherTimeout = Just timeout } - -setGatherFinishOnKey :: GatherAttributes -> Key -> GatherAttributes -setGatherFinishOnKey attrs finishOnKey - = attrs { gatherFinishOnKey = Just finishOnKey } - -setGatherNumDigits :: GatherAttributes -> Natural -> GatherAttributes -setGatherNumDigits attrs numDigits = attrs { gatherNumDigits = Just numDigits } - -numDigits :: Lens (Gather p) (Gather p) (Maybe Natural) Natural -numDigits = lens (^. gatherAttributes . to' gatherNumDigits) - (\t v -> over gatherAttributes (flip setGatherNumDigits v) t) - -instance forall p t. HasAction (t -> Gather p) where - action = lens getAction setAction where - getAction f = (^. gatherAttributes . to' gatherAction) (f $ unsafeCoerce end) - setAction f v = fmap (over gatherAttributes (flip setGatherAction v)) f - -instance forall p t. Twiml p t => HasMethod (t -> Gather p) where - method = lens getMethod setMethod where - getMethod f = (^. gatherAttributes . to' gatherMethod) (f $ unsafeCoerce end) - setMethod f v = fmap (over gatherAttributes (flip setGatherMethod v)) f - -instance forall p t. Twiml p t => HasTimeout (t -> Gather p) where - timeout = lens getTimeout setTimeout where - getTimeout f = (^. gatherAttributes . to' gatherTimeout) (f $ unsafeCoerce end) - setTimeout f v = fmap (over gatherAttributes (flip setGatherTimeout v)) f - -instance forall p t. Twiml p t => HasFinishOnKey (t -> Gather p) where - finishOnKey = lens getFinishOnKey setFinishOnKey where - getFinishOnKey f = (^. gatherAttributes . to' gatherFinishOnKey) (f $ unsafeCoerce end) - setFinishOnKey f v = fmap (over gatherAttributes (flip setGatherFinishOnKey v)) f +gather :: (IsTwimlLike f Gather, Nest i In Gather) => GatherAttributes -> TwimlLike' VoiceVerbsF i Void -> TwimlLike f Gather () +gather a b = iliftF . inj $ GatherF a b () diff --git a/src/Text/XML/Twiml/Verbs/Hangup.hs b/src/Text/XML/Twiml/Verbs/Hangup.hs --- a/src/Text/XML/Twiml/Verbs/Hangup.hs +++ b/src/Text/XML/Twiml/Verbs/Hangup.hs @@ -1,45 +1,39 @@ -{-#LANGUAGE FlexibleContexts #-} -{-#LANGUAGE FlexibleInstances #-} -{-#LANGUAGE MultiParamTypeClasses #-} -{-#LANGUAGE TypeOperators #-} - +{-# OPTIONS_GHC -cpp -optP -P -Itest/examples #-} +{-# LANGUAGE FlexibleContexts #-} +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml.Verbs.Hangup +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +-- +-- The example in this file assumes +-- +-- @ +-- {-\# LANGUAGE RebindableSyntax \#-} +-- {-\# LANGUAGE RecordWildCards \#-} +-- +-- import Prelude +-- import Text.XML.Twiml +-- import qualified Text.XML.Twiml.Syntax as Twiml +-- @ +-- +-- For more information, refer to Twilio's +-- >. +------------------------------------------------------------------------------- module Text.XML.Twiml.Verbs.Hangup - ( -- * @\@ - -- $hangup - Hangup - -- ** Constructor - , hangup + ( hangup + , Hangup + , HangupF ) where -import Text.XML.Twiml.Types -import Text.XML.Twiml.Verbs.End (End) -import Text.XML.Twiml.Internal (Twiml(..), Twiml', TwimlF(..)) - -{- $hangup This example - -@ -module Example where - -import Text.XML.Twiml - -example - = respond - . hangup - $ end -@ +import Text.XML.Twiml.Internal +import Text.XML.Twiml.Internal.Twiml -produces the following TwiML response: +{- | Hangup a call. Example: -@ -\ -\ - \ -\<\/Response\> -@ +#include "hangupExample1.txt" -} - -newtype Hangup p = Hangup { fromHangup :: Twiml' p } -instance (p :/~ Gather') => Twiml p (Hangup p) where toTwiml' = fromHangup - -hangup :: (p :/~ Gather') => End p -> Hangup p -hangup = const . Hangup $ Fix HangupF +hangup :: IsTwimlLike f Hangup => TwimlLike f Hangup a +hangup = iliftF . inj $ HangupF diff --git a/src/Text/XML/Twiml/Verbs/Leave.hs b/src/Text/XML/Twiml/Verbs/Leave.hs --- a/src/Text/XML/Twiml/Verbs/Leave.hs +++ b/src/Text/XML/Twiml/Verbs/Leave.hs @@ -1,45 +1,39 @@ -{-#LANGUAGE FlexibleContexts #-} -{-#LANGUAGE FlexibleInstances #-} -{-#LANGUAGE MultiParamTypeClasses #-} -{-#LANGUAGE TypeOperators #-} - +{-# OPTIONS_GHC -cpp -optP -P -Itest/examples #-} +{-# LANGUAGE FlexibleContexts #-} +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml.Verbs.Leave +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +-- +-- The example in this file assumes +-- +-- @ +-- {-\# LANGUAGE RebindableSyntax \#-} +-- {-\# LANGUAGE RecordWildCards \#-} +-- +-- import Prelude +-- import Text.XML.Twiml +-- import qualified Text.XML.Twiml.Syntax as Twiml +-- @ +-- +-- For more information, refer to Twilio's +-- >. +------------------------------------------------------------------------------- module Text.XML.Twiml.Verbs.Leave - ( -- * @\@ - -- $leave - Leave - -- ** Constructor - , leave + ( leave + , Leave + , LeaveF ) where -import Text.XML.Twiml.Types -import Text.XML.Twiml.Verbs.End (End) -import Text.XML.Twiml.Internal (Twiml(..), Twiml', TwimlF(..)) - -{- $leave This example - -@ -module Example where - -import Text.XML.Twiml - -example - = respond - . leave - $ end -@ +import Text.XML.Twiml.Internal +import Text.XML.Twiml.Internal.Twiml -produces the following TwiML response: +{- | Leave a queue. Example: -@ -\ -\ - \ -\<\/Response\> -@ +#include "leaveExample1.txt" -} - -newtype Leave p = Leave { fromLeave :: Twiml' p } -instance (p :/~ Gather') => Twiml p (Leave p) where toTwiml' = fromLeave - -leave :: (p :/~ Gather') => End p -> Leave p -leave = const . Leave $ Fix LeaveF +leave :: IsTwimlLike f Leave => TwimlLike f Leave a +leave = iliftF . inj $ LeaveF diff --git a/src/Text/XML/Twiml/Verbs/Message.hs b/src/Text/XML/Twiml/Verbs/Message.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/Twiml/Verbs/Message.hs @@ -0,0 +1,51 @@ +{-# OPTIONS_GHC -cpp -optP -P -Itest/examples #-} +{-# LANGUAGE FlexibleContexts #-} +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml.Verbs.Message +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +-- +-- The example in this file assumes +-- +-- @ +-- {-\# LANGUAGE RebindableSyntax \#-} +-- {-\# LANGUAGE RecordWildCards \#-} +-- +-- import Prelude +-- import Text.XML.Twiml +-- import qualified Text.XML.Twiml.Syntax as Twiml +-- @ +-- +-- For more information, refer to Twilio's +-- >. +------------------------------------------------------------------------------- +module Text.XML.Twiml.Verbs.Message + ( message + , Message + , MessageF + , MessageAttributes + ) where + +import Text.XML.Twiml.Internal +import Text.XML.Twiml.Internal.Twiml + +{- | Example: + +@ +example :: MessagingTwiml +example = + response $ do + 'end' + where Twiml.Syntax{..} = def +@ + +> +> +> Store Location: 123 Easy St. +> +-} +message :: IsTwimlLike f Message => String -> MessageAttributes -> TwimlLike f Message () +message a b = iliftF . inj $ MessageF a b () diff --git a/src/Text/XML/Twiml/Verbs/Pause.hs b/src/Text/XML/Twiml/Verbs/Pause.hs --- a/src/Text/XML/Twiml/Verbs/Pause.hs +++ b/src/Text/XML/Twiml/Verbs/Pause.hs @@ -1,71 +1,40 @@ -{-#LANGUAGE FlexibleInstances #-} -{-#LANGUAGE MultiParamTypeClasses #-} - +{-# OPTIONS_GHC -cpp -optP -P -Itest/examples #-} +{-# LANGUAGE FlexibleContexts #-} +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml.Verbs.Pause +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +-- +-- The example in this file assumes +-- +-- @ +-- {-\# LANGUAGE RebindableSyntax \#-} +-- {-\# LANGUAGE RecordWildCards \#-} +-- +-- import Prelude +-- import Text.XML.Twiml +-- import qualified Text.XML.Twiml.Syntax as Twiml +-- @ +-- +-- For more information, refer to Twilio's +-- >. +------------------------------------------------------------------------------- module Text.XML.Twiml.Verbs.Pause - ( -- * @\@ - -- $pause - Pause - -- ** Constructors - , pause - , pause' - -- ** Attributes - , PauseAttributes(..) - , defaultPauseAttributes - -- *** Lenses - , pauseAttributes - , duration + ( pause + , Pause + , PauseF + , PauseAttributes ) where -import Text.XML.Twiml.Types -import Text.XML.Twiml.Verbs.End (End) -import Text.XML.Twiml.Internal (Twiml(..), Twiml', TwimlF(..)) - -{- $pause This example - -@ -module Example where - -import Control.Lens -import Text.XML.Twiml - -example - = respond - . say \"I will pause 10 seconds starting now!\" - . (pause \<&\> duration .~ 10) - . say \"I just paused 10 seconds\" - $ end -@ +import Text.XML.Twiml.Internal +import Text.XML.Twiml.Internal.Twiml -produces the following TwiML response: +{- | Example: -@ -\ -\ - \I will pause 10 seconds starting now!\<\/Say\> - \ - \I just paused 10 seconds\<\/Say\> -\<\/Response\> -@ +#include "pauseExample1.txt" -} - -newtype Pause p = Pause { fromPause :: Twiml' p } -instance Twiml p (Pause p) where toTwiml' = fromPause - -pause :: Twiml p t => t -> Pause p -pause = pause' defaultPauseAttributes - -pause' :: Twiml p t => PauseAttributes -> t -> Pause p -pause' attrs = Pause . Fix . PauseF attrs . toTwiml' - -pauseAttributes :: Lens' (Pause p) PauseAttributes -pauseAttributes = lens - (\(Pause (Fix (PauseF attributes _))) -> attributes) - (\(Pause (Fix (PauseF _ a))) attributes -> - Pause (Fix (PauseF attributes a))) - -setPauseLength :: PauseAttributes -> Natural -> PauseAttributes -setPauseLength attrs length = attrs { pauseLength = Just length } - -duration :: Lens (Pause p) (Pause p) (Maybe Natural) Natural -duration = lens (^. pauseAttributes . to' pauseLength) - (\t v -> over pauseAttributes (flip setPauseLength v) t) +pause :: IsTwimlLike f Pause => PauseAttributes -> TwimlLike f Pause () +pause a = iliftF . inj $ PauseF a () diff --git a/src/Text/XML/Twiml/Verbs/Play.hs b/src/Text/XML/Twiml/Verbs/Play.hs --- a/src/Text/XML/Twiml/Verbs/Play.hs +++ b/src/Text/XML/Twiml/Verbs/Play.hs @@ -1,75 +1,49 @@ -{-#LANGUAGE FlexibleInstances #-} -{-#LANGUAGE MultiParamTypeClasses #-} - +{-# OPTIONS_GHC -cpp -optP -P -Itest/examples #-} +{-# LANGUAGE FlexibleContexts #-} +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml.Verbs.Play +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +-- +-- The example in this file assumes +-- +-- @ +-- {-\# LANGUAGE RebindableSyntax \#-} +-- {-\# LANGUAGE RecordWildCards \#-} +-- +-- import Prelude +-- import Text.XML.Twiml +-- import qualified Text.XML.Twiml.Syntax as Twiml +-- @ +-- +-- For more information, refer to Twilio's +-- >. +------------------------------------------------------------------------------- module Text.XML.Twiml.Verbs.Play - ( -- * @\@ - -- $play - Play - -- ** Constructors - , play + ( play , play' - -- ** Attributes - , PlayAttributes(..) - , defaultPlayAttributes - -- *** Lenses - , playAttributes - , digits - , loop + , Play + , PlayF + , PlayAttributes ) where +import Text.XML.Twiml.Internal +import Text.XML.Twiml.Internal.Twiml import Text.XML.Twiml.Types -import Text.XML.Twiml.Internal (Twiml(..), Twiml', TwimlF(..)) -{- $play This example - -@ -module Example where - -import Control.Lens -import Text.XML.Twiml - -example - = respond - . (play (parseURL \"https:\/\/api.twilio.com\/cowbell.mp3\") \<&\> loop .~ 10) - $ end -@ - -produces the following TwiML response: +{- | Example: -@ -\ -\ - \https:\/\/api.twilio.com\/cowbell.mp3\<\/Play\> -\<\/Response\> -@ +#include "playExample1.txt" -} - -newtype Play p = Play { fromPlay :: Twiml' p } -instance Twiml p (Play p) where toTwiml' = fromPlay - -play :: Twiml p t => Maybe URL -> t -> Play p -play = play' defaultPlayAttributes - -play' :: Twiml p t => PlayAttributes -> Maybe URL -> t -> Play p -play' attrs n = Play . Fix . PlayF attrs n . toTwiml' - -playAttributes :: Lens' (Play p) PlayAttributes -playAttributes = lens - (\(Play (Fix (PlayF attributes _ _))) -> attributes) - (\(Play (Fix (PlayF _ n a))) attributes -> - Play (Fix (PlayF attributes n a))) - -setPlayLoop :: PlayAttributes -> Natural -> PlayAttributes -setPlayLoop attrs loop = attrs { playLoop = Just loop } - -setPlayDigits :: PlayAttributes -> [Digit] -> PlayAttributes -setPlayDigits attrs digits = attrs { playDigits = Just digits } +play :: IsTwimlLike f Play => URL -> PlayAttributes -> TwimlLike f Play () +play a b = iliftF . inj $ PlayF (pure a) b () -digits :: Lens (Play p) (Play p) (Maybe [Digit]) [Digit] -digits = lens (^. playAttributes . to' playDigits) - (\t v -> over playAttributes (flip setPlayDigits v) t) +{- | Example: -instance HasLoop (Play p) where - loop = lens getLoop setLoop where - getLoop = (^. playAttributes . to' playLoop) - setLoop t v = over playAttributes (flip setPlayLoop v) t +#include "playExample2.txt" +-} +play' :: IsTwimlLike f Play => Maybe URL -> PlayAttributes -> TwimlLike f Play () +play' a b = iliftF . inj $ PlayF a b () diff --git a/src/Text/XML/Twiml/Verbs/Record.hs b/src/Text/XML/Twiml/Verbs/Record.hs --- a/src/Text/XML/Twiml/Verbs/Record.hs +++ b/src/Text/XML/Twiml/Verbs/Record.hs @@ -1,133 +1,40 @@ -{-#LANGUAGE FlexibleContexts #-} -{-#LANGUAGE FlexibleInstances #-} -{-#LANGUAGE MultiParamTypeClasses #-} -{-#LANGUAGE TypeOperators #-} - +{-# OPTIONS_GHC -cpp -optP -P -Itest/examples #-} +{-# LANGUAGE FlexibleContexts #-} +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml.Verbs.Record +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +-- +-- The example in this file assumes +-- +-- @ +-- {-\# LANGUAGE RebindableSyntax \#-} +-- {-\# LANGUAGE RecordWildCards \#-} +-- +-- import Prelude +-- import Text.XML.Twiml +-- import qualified Text.XML.Twiml.Syntax as Twiml +-- @ +-- +-- For more information, refer to Twilio's +-- >. +------------------------------------------------------------------------------- module Text.XML.Twiml.Verbs.Record - ( -- * @\@ - -- $record - Record - -- ** Constructors - , record - , record' - -- ** Attributes - , RecordAttributes(..) - , defaultRecordAttributes - -- *** Lenses - , recordAttributes - , maxLength - , transcribe - , transcribeCallback - , playBeep - , action - , method - , timeout - , finishOnKey + ( record + , Record + , RecordF + , RecordAttributes ) where -import Text.XML.Twiml.Types -import Text.XML.Twiml.Internal (Twiml(..), Twiml', TwimlF(..)) - -{- $record This example - -@ -module Example where - -import Control.Lens -import Text.XML.Twiml - -example - = respond - . (record \<&\> timeout .~ 10 - \<&\> transcribe .~ True) - $ end -@ +import Text.XML.Twiml.Internal +import Text.XML.Twiml.Internal.Twiml -produces the following TwiML response: +{- | Example: -@ -\ -\ - \ -\<\/Response\> -@ +#include "recordExample2.txt" -} - -newtype Record p = Record { fromRecord :: Twiml' p } -instance (p :/~ Gather') => Twiml p (Record p) where toTwiml' = fromRecord - -record :: (Twiml p t, p :/~ Gather') => t -> Record p -record = record' defaultRecordAttributes - -record' :: (Twiml p t, p :/~ Gather') - => RecordAttributes -> t -> Record p -record' attrs - = Record . Fix . RecordF attrs . toTwiml' - -recordAttributes :: Lens' (Record p) RecordAttributes -recordAttributes = lens - (\(Record (Fix (RecordF attributes _))) -> attributes) - (\(Record (Fix (RecordF _ a))) attributes -> - Record (Fix (RecordF attributes a))) - -setRecordAction :: RecordAttributes -> URL -> RecordAttributes -setRecordAction attrs action = attrs { recordAction = Just action } - -setRecordMethod :: RecordAttributes -> Method -> RecordAttributes -setRecordMethod attrs method = attrs { recordMethod = Just method } - -setRecordTimeout :: RecordAttributes -> Natural -> RecordAttributes -setRecordTimeout attrs timeout = attrs { recordTimeout = Just timeout } - -setRecordFinishOnKey :: RecordAttributes -> Key -> RecordAttributes -setRecordFinishOnKey attrs key = attrs { recordFinishOnKey = Just key } - -setRecordMaxLength :: RecordAttributes -> Natural -> RecordAttributes -setRecordMaxLength attrs length = attrs { recordMaxLength = Just length } - -setRecordTranscribe :: RecordAttributes -> Bool -> RecordAttributes -setRecordTranscribe attrs transcribe - = attrs { recordTranscribe = Just transcribe } - -setRecordTranscribeCallback :: RecordAttributes -> URL -> RecordAttributes -setRecordTranscribeCallback attrs transcribeCallback - = attrs { recordTranscribeCallback = Just transcribeCallback } - -setRecordPlayBeep :: RecordAttributes -> Bool -> RecordAttributes -setRecordPlayBeep attrs playBeep = attrs { recordPlayBeep = Just playBeep } - -maxLength :: Lens (Record p) (Record p) (Maybe Natural) Natural -maxLength = lens (^. recordAttributes . to' recordMaxLength) - (\t v -> over recordAttributes (flip setRecordMaxLength v) t) - -transcribe :: Lens (Record p) (Record p) (Maybe Bool) Bool -transcribe = lens (^. recordAttributes . to' recordTranscribe) - (\t v -> over recordAttributes (flip setRecordTranscribe v) t) - -transcribeCallback :: Lens (Record p) (Record p) (Maybe URL) URL -transcribeCallback = lens (^. recordAttributes . to' recordTranscribeCallback) - (\t v -> over recordAttributes (flip setRecordTranscribeCallback v) t) - -playBeep :: Lens (Record p) (Record p) (Maybe Bool) Bool -playBeep = lens (^. recordAttributes . to' recordPlayBeep) - (\t v -> over recordAttributes (flip setRecordPlayBeep v) t) - -instance HasAction (Record p) where - action = lens getAction setAction where - getAction = (^. recordAttributes . to' recordAction) - setAction t v = over recordAttributes (flip setRecordAction v) t - -instance HasMethod (Record p) where - method = lens getMethod setMethod where - getMethod = (^. recordAttributes . to' recordMethod) - setMethod t v = over recordAttributes (flip setRecordMethod v) t - -instance HasTimeout (Record p) where - timeout = lens getTimeout setTimeout where - getTimeout = (^. recordAttributes . to' recordTimeout) - setTimeout t v = over recordAttributes (flip setRecordTimeout v) t - -instance HasFinishOnKey (Record p) where - finishOnKey = lens getFinishOnKey setFinishOnKey where - getFinishOnKey = (^. recordAttributes . to' recordFinishOnKey) - setFinishOnKey t v = over recordAttributes (flip setRecordFinishOnKey v) t +record :: IsTwimlLike f Record => RecordAttributes -> TwimlLike f Record () +record a = iliftF . inj $ RecordF a () diff --git a/src/Text/XML/Twiml/Verbs/Redirect.hs b/src/Text/XML/Twiml/Verbs/Redirect.hs --- a/src/Text/XML/Twiml/Verbs/Redirect.hs +++ b/src/Text/XML/Twiml/Verbs/Redirect.hs @@ -1,73 +1,41 @@ -{-#LANGUAGE FlexibleContexts #-} -{-#LANGUAGE FlexibleInstances #-} -{-#LANGUAGE MultiParamTypeClasses #-} -{-#LANGUAGE TypeOperators #-} - +{-# OPTIONS_GHC -cpp -optP -P -Itest/examples #-} +{-# LANGUAGE FlexibleContexts #-} +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml.Verbs.Redirect +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +-- +-- The example in this file assumes +-- +-- @ +-- {-\# LANGUAGE RebindableSyntax \#-} +-- {-\# LANGUAGE RecordWildCards \#-} +-- +-- import Prelude +-- import Text.XML.Twiml +-- import qualified Text.XML.Twiml.Syntax as Twiml +-- @ +-- +-- For more information, refer to Twilio's +-- >. +------------------------------------------------------------------------------- module Text.XML.Twiml.Verbs.Redirect - ( -- * @\@ - -- $redirect - Redirect - -- ** Constructors - , redirect - , redirect' - -- ** Attributes - , RedirectAttributes(..) - , defaultRedirectAttributes - -- *** Lenses - , redirectAttributes - , method + ( redirect + , Redirect + , RedirectF + , RedirectAttributes ) where +import Text.XML.Twiml.Internal +import Text.XML.Twiml.Internal.Twiml import Text.XML.Twiml.Types -import Text.XML.Twiml.Verbs.End (End) -import Text.XML.Twiml.Internal (Twiml(..), Twiml', TwimlF(..)) -{- $redirect This example - -@ -module Example where - -import Control.Lens -import Data.Maybe (fromJust) -import Text.XML.Twiml - -example - = respond - . (redirect (fromJust $ parseURL \"http:\/\/pigeons.com\/twiml.xml\") \<&\> method .~ POST) - $ end -@ - -produces the following TwiML response: +{- | Example: -@ -\ -\ - \http:\/\/pigeons.com\/twiml.xml\<\/Redirect\> -\<\/Response\> -@ +#include "redirectExample1.txt" -} - -newtype Redirect p = Redirect { fromRedirect :: Twiml' p } -instance (p :/~ Gather') => Twiml p (Redirect p) where toTwiml' = fromRedirect - -redirect :: (p :/~ Gather') => URL -> End p -> Redirect p -redirect = redirect' defaultRedirectAttributes - -redirect' :: (p :/~ Gather') => RedirectAttributes -> URL -> End p -> Redirect p -redirect' attrs url = const . Redirect . Fix $ RedirectF attrs url - -redirectAttributes :: Lens' (Redirect p) RedirectAttributes -redirectAttributes = lens - (\(Redirect (Fix (RedirectF attributes _))) -> attributes) - (\(Redirect (Fix (RedirectF _ n))) attributes -> - Redirect (Fix (RedirectF attributes n))) - -setRedirectMethod :: RedirectAttributes -> Method -> RedirectAttributes -setRedirectMethod attrs method = attrs { redirectMethod = Just method } - -instance HasMethod (Redirect p) where - method = lens getMethod setMethod where - getMethod = (^. redirectAttributes . to' redirectMethod) - setMethod t v = over redirectAttributes (flip setRedirectMethod v) t - - +redirect :: IsTwimlLike f Redirect => URL -> RedirectAttributes -> TwimlLike f Redirect a +redirect a b = iliftF . inj $ RedirectF a b diff --git a/src/Text/XML/Twiml/Verbs/Reject.hs b/src/Text/XML/Twiml/Verbs/Reject.hs --- a/src/Text/XML/Twiml/Verbs/Reject.hs +++ b/src/Text/XML/Twiml/Verbs/Reject.hs @@ -1,70 +1,40 @@ -{-#LANGUAGE FlexibleContexts #-} -{-#LANGUAGE FlexibleInstances #-} -{-#LANGUAGE MultiParamTypeClasses #-} -{-#LANGUAGE TypeOperators #-} - +{-# OPTIONS_GHC -cpp -optP -P -Itest/examples #-} +{-# LANGUAGE FlexibleContexts #-} +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml.Verbs.Reject +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +-- +-- The example in this file assumes +-- +-- @ +-- {-\# LANGUAGE RebindableSyntax \#-} +-- {-\# LANGUAGE RecordWildCards \#-} +-- +-- import Prelude +-- import Text.XML.Twiml +-- import qualified Text.XML.Twiml.Syntax as Twiml +-- @ +-- +-- For more information, refer to Twilio's +-- >. +------------------------------------------------------------------------------- module Text.XML.Twiml.Verbs.Reject - ( -- * @\@ - -- $reject - Reject - -- ** Constructors - , reject - , reject' - -- ** Attributes - , RejectAttributes(..) - , defaultRejectAttributes - -- *** Lenses - , rejectAttributes - , reason + ( reject + , Reject + , RejectF + , RejectAttributes ) where -import Text.XML.Twiml.Types -import Text.XML.Twiml.Verbs.End (End) -import Text.XML.Twiml.Internal (Twiml(..), Twiml', TwimlF(..)) - -{- $reject This example - -@ -module Example where - -import Control.Lens -import Text.XML.Twiml - -example - = respond - . (reject \<&\> reason .~ Busy) - $ end -@ +import Text.XML.Twiml.Internal +import Text.XML.Twiml.Internal.Twiml -produces the following TwiML response: +{- | Example: -@ -\ -\ - \ -\<\/Response\> -@ +#include "rejectExample2.txt" -} - -newtype Reject p = Reject { fromReject :: Twiml' p } -instance (p :/~ Gather') => Twiml p (Reject p) where toTwiml' = fromReject - -reject :: (p :/~ Gather') => End p -> Reject p -reject = reject' defaultRejectAttributes - -reject' :: (p :/~ Gather') => RejectAttributes -> End p -> Reject p -reject' attrs = const . Reject . Fix $ RejectF attrs - -rejectAttributes :: Lens' (Reject p) RejectAttributes -rejectAttributes = lens - (\(Reject (Fix (RejectF attributes))) -> attributes) - (\(Reject (Fix (RejectF _ ))) attributes -> - Reject (Fix (RejectF attributes))) - -setRejectReason :: RejectAttributes -> Reason -> RejectAttributes -setRejectReason attrs reason = attrs { rejectReason = Just reason } - -reason :: Lens (Reject p) (Reject p) (Maybe Reason) Reason -reason = lens (^. rejectAttributes . to' rejectReason) - (\t v -> over rejectAttributes (flip setRejectReason v) t) - +reject :: IsTwimlLike f Reject => RejectAttributes -> TwimlLike f Reject a +reject a = iliftF . inj $ RejectF a diff --git a/src/Text/XML/Twiml/Verbs/Say.hs b/src/Text/XML/Twiml/Verbs/Say.hs --- a/src/Text/XML/Twiml/Verbs/Say.hs +++ b/src/Text/XML/Twiml/Verbs/Say.hs @@ -1,127 +1,40 @@ -{-#LANGUAGE FlexibleInstances #-} -{-#LANGUAGE MultiParamTypeClasses #-} - +{-# OPTIONS_GHC -cpp -optP -P -Itest/examples #-} +{-# LANGUAGE FlexibleContexts #-} +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml.Verbs.Say +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +-- +-- The example in this file assumes +-- +-- @ +-- {-\# LANGUAGE RebindableSyntax \#-} +-- {-\# LANGUAGE RecordWildCards \#-} +-- +-- import Prelude +-- import Text.XML.Twiml +-- import qualified Text.XML.Twiml.Syntax as Twiml +-- @ +-- +-- For more information, refer to Twilio's +-- >. +------------------------------------------------------------------------------- module Text.XML.Twiml.Verbs.Say - ( -- * @\@ - -- $say - Say - -- ** Constructors - , say - , say' - , sayMan - , sayMan' - , sayWoman - , sayWoman' - , sayAlice - , sayAlice' - -- ** Attributes - , SayAttributes(..) - , defaultSayAttributes - -- *** Lenses - , sayAttributes - , voice - , loop + ( say + , Say + , SayF + , SayAttributes ) where -import Text.XML.Twiml.Types -import Text.XML.Twiml.Internal (Twiml(..), Twiml', TwimlF(..)) - -{- $say This example - -@ -module Example where - -import Text.XML.Twiml - -example - = respond - . sayWoman' French \"Chapeau\" - $ end -@ - -produces the following TwiML response: - -@ -\ -\ - \Chapeau\<\/Say\> -\<\/Response\> -@ --} - -newtype Say p = Say { fromSay :: Twiml' p } -instance Twiml p (Say p) where toTwiml' = fromSay - -say :: Twiml p t => String -> t -> Say p -say = say' defaultSayAttributes - -say' :: Twiml p t => SayAttributes -> String -> t -> Say p -say' a b = Say . Fix . SayF a b . toTwiml' - -sayMan :: Twiml p t => String -> t -> Say p -sayMan = say' (defaultSayAttributes { sayVoice = Just $ Man Nothing }) - -sayMan' :: Twiml p t => Lang -> String -> t -> Say p -sayMan' lang - = say' (defaultSayAttributes { sayVoice = Just . Man $ Just lang }) - -sayWoman :: Twiml p t => String -> t -> Say p -sayWoman = say' (defaultSayAttributes { sayVoice = Just $ Woman Nothing }) - -sayWoman' :: Twiml p t => Lang -> String -> t -> Say p -sayWoman' lang - = say' (defaultSayAttributes { sayVoice = Just . Woman $ Just lang }) - -sayAlice :: Twiml p t => String -> t -> Say p -sayAlice = say' (defaultSayAttributes { sayVoice = Just $ Alice Nothing }) - -sayAlice' :: Twiml p t => LangAlice -> String -> t -> Say p -sayAlice' lang - = say' (defaultSayAttributes { sayVoice = Just . Alice $ Just lang }) - -sayAttributes :: Lens' (Say p) SayAttributes -sayAttributes = lens - (\(Say (Fix (SayF attributes _ _))) -> attributes) - (\(Say (Fix (SayF _ n a))) attributes -> - Say (Fix (SayF attributes n a))) - -{- - -setDialAction :: DialAttributes -> URL -> DialAttributes -setDialAction attrs action = attrs { dialAction = Just action } - -setDialMethod :: DialAttributes -> Method -> DialAttributes -setDialMethod attrs method = attrs { dialMethod = Just method } - -setDialTimeout :: DialAttributes -> Natural -> DialAttributes -setDialTimeout attrs timeout = attrs { dialTimeout = Just timeout } - -setDialHangupOnStar :: DialAttributes -> Bool -> DialAttributes -setDialHangupOnStar attrs hangupOnStar - = attrs { dialHangupOnStar = Just hangupOnStar } - -setDialTimeLimit :: DialAttributes -> Natural -> DialAttributes -setDialTimeLimit attrs timeLimit = attrs { dialTimeLimit = Just timeLimit } - -setDialCallerId :: DialAttributes -> String -> DialAttributes -setDialCallerId attrs callerId = attrs { dialCallerId = Just callerId } +import Text.XML.Twiml.Internal +import Text.XML.Twiml.Internal.Twiml -setDialRecord :: DialAttributes -> Bool -> DialAttributes -setDialRecord attrs record = attrs { dialRecord = Just record } +{- | Example: +#include "sayExample2.txt" -} - -setSayVoice :: SayAttributes -> Voice -> SayAttributes -setSayVoice attrs voice = attrs { sayVoice = Just voice } - -setSayLoop :: SayAttributes -> Natural -> SayAttributes -setSayLoop attrs loop = attrs { sayLoop = Just loop } - -voice :: Lens (Say p) (Say p) (Maybe Voice) Voice -voice = lens (^. sayAttributes . to' sayVoice) - (\t v -> over sayAttributes (flip setSayVoice v) t) - -instance HasLoop (Say p) where - loop = lens getLoop setLoop where - getLoop = (^. sayAttributes . to' sayLoop) - setLoop t v = over sayAttributes (flip setSayLoop v) t +say :: IsTwimlLike f Say => String -> SayAttributes -> TwimlLike f Say () +say a b = iliftF . inj $ SayF a b () diff --git a/src/Text/XML/Twiml/Verbs/Sms.hs b/src/Text/XML/Twiml/Verbs/Sms.hs --- a/src/Text/XML/Twiml/Verbs/Sms.hs +++ b/src/Text/XML/Twiml/Verbs/Sms.hs @@ -1,104 +1,40 @@ -{-#LANGUAGE FlexibleContexts #-} -{-#LANGUAGE FlexibleInstances #-} -{-#LANGUAGE MultiParamTypeClasses #-} -{-#LANGUAGE TypeOperators #-} - +{-# OPTIONS_GHC -cpp -optP -P -Itest/examples #-} +{-# LANGUAGE FlexibleContexts #-} +------------------------------------------------------------------------------- +-- | +-- Module : Text.XML.Twiml.Verbs.Sms +-- Copyright : (C) 2014-15 Mark Andrus Roberts +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Mark Andrus Roberts +-- Stability : provisional +-- +-- The example in this file assumes +-- +-- @ +-- {-\# LANGUAGE RebindableSyntax \#-} +-- {-\# LANGUAGE RecordWildCards \#-} +-- +-- import Prelude +-- import Text.XML.Twiml +-- import qualified Text.XML.Twiml.Syntax as Twiml +-- @ +-- +-- For more information, refer to Twilio's +-- >. +------------------------------------------------------------------------------- module Text.XML.Twiml.Verbs.Sms - ( -- * @\@ - -- $sms - Sms - -- ** Constructors - , sms - , sms' - -- ** Attributes - , SmsAttributes(..) - , defaultSmsAttributes - -- *** Lenses - , smsAttributes - , to - , from - , statusCallback - , action - , method + ( sms + , Sms + , SmsF + , SmsAttributes ) where -import Text.XML.Twiml.Types -import Text.XML.Twiml.Internal (Twiml(..), Twiml', TwimlF(..)) - -{- $sms This example - -@ -module Example where - -import Control.Lens -import Text.XML.Twiml - -example - = respond - . (sms \"The king stay the king.\" \<&\> to .~ \"+14105551234\" - \<&\> from .~ \"+14105556789\") - $ end -@ +import Text.XML.Twiml.Internal +import Text.XML.Twiml.Internal.Twiml -produces the following TwiML response: +{- | Example: -@ -\ -\ - \The king stay the king.\<\/Sms\> -\<\/Response\> -@ +#include "smsExample2.txt" -} - -newtype Sms p = Sms { fromSms :: Twiml' p } -instance (p :/~ Gather') => Twiml p (Sms p) where toTwiml' = fromSms - -sms :: (Twiml p t, p :/~ Gather') => String -> t -> Sms p -sms = sms' defaultSmsAttributes - -sms' :: (Twiml p t, p :/~ Gather') => SmsAttributes -> String -> t -> Sms p -sms' attrs n = Sms . Fix . SmsF attrs n . toTwiml' - -smsAttributes :: Lens' (Sms p) SmsAttributes -smsAttributes = lens - (\(Sms (Fix (SmsF attributes _ _))) -> attributes) - (\(Sms (Fix (SmsF _ n a))) attributes -> - Sms (Fix (SmsF attributes n a))) - -setSmsTo :: SmsAttributes -> String -> SmsAttributes -setSmsTo attrs to = attrs { smsTo = Just to } - -setSmsFrom :: SmsAttributes -> String -> SmsAttributes -setSmsFrom attrs from = attrs { smsFrom = Just from } - -setSmsAction :: SmsAttributes -> URL -> SmsAttributes -setSmsAction attrs action = attrs { smsAction = Just action } - -setSmsMethod :: SmsAttributes -> Method -> SmsAttributes -setSmsMethod attrs method = attrs { smsMethod = Just method } - -setSmsStatusCallback :: SmsAttributes -> URL -> SmsAttributes -setSmsStatusCallback attrs statusCallback - = attrs { smsStatusCallback = Just statusCallback } - -to :: Lens (Sms p) (Sms p) (Maybe String) String -to = lens (^. smsAttributes . to' smsTo) - (\t v -> over smsAttributes (flip setSmsTo v) t) - -from :: Lens (Sms p) (Sms p) (Maybe String) String -from = lens (^. smsAttributes . to' smsFrom) - (\t v -> over smsAttributes (flip setSmsFrom v) t) - -statusCallback :: Lens (Sms p) (Sms p) (Maybe URL) URL -statusCallback = lens (^. smsAttributes . to' smsStatusCallback) - (\t v -> over smsAttributes (flip setSmsStatusCallback v) t) - -instance HasAction (Sms p) where - action = lens getAction setAction where - getAction = (^. smsAttributes . to' smsAction) - setAction t v = over smsAttributes (flip setSmsAction v) t - -instance HasMethod (Sms p) where - method = lens getMethod setMethod where - getMethod = (^. smsAttributes . to' smsMethod) - setMethod t v = over smsAttributes (flip setSmsMethod v) t +sms :: IsTwimlLike f Sms => String -> SmsAttributes -> TwimlLike f Sms () +sms a b = iliftF . inj $ SmsF a b () diff --git a/test/Golden.hs b/test/Golden.hs new file mode 100644 --- /dev/null +++ b/test/Golden.hs @@ -0,0 +1,411 @@ +{-# OPTIONS_GHC -cpp -optP -P -Itest/examples #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE RecordWildCards #-} + +module Golden where + +import Text.XML.Twiml +import qualified Text.XML.Twiml.Syntax as Twiml + +import Control.Monad +import Control.Lens +import Data.Algorithm.Diff +import Data.Algorithm.DiffOutput +import Data.Default +import Data.Maybe (fromJust) +import Data.String +import Distribution.TestSuite +import System.IO + +import Prelude + +{- Say -} + +sayExample1 :: VoiceTwiml +sayExample1 = + response $ do + say "Hello World" def + end + where Twiml.Syntax{..} = def + +{- +sayExample2 :: VoiceTwiml +sayExample2 = + response $ do + say "Bom dia." $ def & voice .~ Just (Alice $ Just PtBR) + & loop .~ Just 2 + end + where Twiml.Syntax{..} = def +-} + +#include "sayExample2.hs" + +sayExamples :: [(VoiceTwiml, FilePath)] +sayExamples = + [ (sayExample1, "test/xml/sayExample1.xml") + , (sayExample2, "test/xml/sayExample2.xml") + ] + +{- Play -} + +{- +playExample1 :: VoiceTwiml +playExample1 = + response $ do + play (fromJust $ parseURL "https://api.twilio.com/cowbell.mp3") def + end + where Twiml.Syntax{..} = def +-} + +#include "playExample1.hs" + +{- +playExample2 :: VoiceTwiml +playExample2 = + response $ do + play' Nothing $ def & digits .~ Just [W, W, W, W, D3] + end + where Twiml.Syntax{..} = def +-} + +#include "playExample2.hs" + +playExamples :: [(VoiceTwiml, FilePath)] +playExamples = + [ (playExample1, "test/xml/playExample1.xml") + , (playExample2, "test/xml/playExample2.xml") + ] + +{- Gather -} + +gatherExample1 :: VoiceTwiml +gatherExample1 = + response $ do + gather def end + end + where Twiml.Syntax{..} = def + +{- +gatherExample2 :: VoiceTwiml +gatherExample2 = + response $ do + gather (def & action .~ parseURL "/process_gather.php" + & method .~ Just GET) $ do + say "Please enter your account number, followed by the pound sign" def + end + say "We didn't receive any input. Goodbye!" def + end + where Twiml.Syntax{..} = def +-} + +#include "gatherExample2.hs" + +gatherExamples :: [(VoiceTwiml, FilePath)] +gatherExamples = + [ (gatherExample1, "test/xml/gatherExample1.xml") + , (gatherExample2, "test/xml/gatherExample2.xml") + ] + +{- Record -} + +recordExample1 :: VoiceTwiml +recordExample1 = + response $ do + record def + end + where Twiml.Syntax{..} = def + +{- +recordExample2 :: VoiceTwiml +recordExample2 = + response $ do + say "Please leave a message at the beep. Press the star key when finished." def + record $ def & action .~ parseURL "http://foo.edu/handleRecording.php" + & method .~ Just GET + & maxLength .~ Just 20 + & finishOnKey .~ Just KStar + say "I did not receive a recording" def + end + where Twiml.Syntax{..} = def +-} + +#include "recordExample2.hs" + +recordExample3 :: VoiceTwiml +recordExample3 = + response $ do + record $ def & transcribe .~ Just True + & transcribeCallback .~ parseURL "/handle_transcribe.php" + end + where Twiml.Syntax{..} = def + +recordExamples :: [(VoiceTwiml, FilePath)] +recordExamples = + [ (recordExample1, "test/xml/recordExample1.xml") + , (recordExample2, "test/xml/recordExample2.xml") + , (recordExample3, "test/xml/recordExample3.xml") + ] + +{- Sms -} + +smsExample1 :: VoiceTwiml +smsExample1 = + response $ do + say "Our store is located at 123 Easy St." def + sms "Store Location: 123 Easy St." def + end + where Twiml.Syntax{..} = def + +{- +smsExample2 :: VoiceTwiml +smsExample2 = + response $ do + say "Our store is located at 123 Easy St." def + sms "Store Location: 123 Easy St." $ def + & action .~ parseURL "/smsHandler.php" + & method .~ Just POST + end + where Twiml.Syntax{..} = def +-} + +#include "smsExample2.hs" + +smsExample3 :: VoiceTwiml +smsExample3 = + response $ do + say "Our store is located at 123 Easy St." def + sms "Store Location: 123 Easy St." $ def + & statusCallback .~ parseURL "/smsHandler.php" + end + where Twiml.Syntax{..} = def + +smsExamples :: [(VoiceTwiml, FilePath)] +smsExamples = + [ (smsExample1, "test/xml/smsExample1.xml") + , (smsExample2, "test/xml/smsExample2.xml") + , (smsExample3, "test/xml/smsExample3.xml") + ] + +{- Dial -} + +{- +dialExample1 :: VoiceTwiml +dialExample1 = + response $ do + dial "415-123-4567" def + say "Goodbye" def + end + where Twiml.Syntax{..} = def +-} + +#include "dialExample1.hs" + +dialExample2 :: VoiceTwiml +dialExample2 = + response $ do + dial "415-123-4567" $ def + & action .~ parseURL "/handleDialCallStatus.php" + & method .~ Just GET + say "I am unreachable" def + end + where Twiml.Syntax{..} = def + +{- +dialExample3 :: VoiceTwiml +dialExample3 = + response $ do + dial' (Left . dialNoun $ number "+15558675309" def) $ def + & callerId .~ Just "+15551112222" + end + where Twiml.Syntax{..} = def +-} + +#include "dialExample3.hs" + +dialExamples :: [(VoiceTwiml, FilePath)] +dialExamples = + [ (dialExample1, "test/xml/dialExample1.xml") + , (dialExample2, "test/xml/dialExample2.xml") + , (dialExample3, "test/xml/dialExample3.xml") + ] + +-- TODO: Dial nouns... + +{- Enqueue -} + +{- +enqueueExample1 :: VoiceTwiml +enqueueExample1 = + response $ do + enqueue "support" $ def & waitURL .~ parseURL "wait-music.xml" + end + where Twiml.Syntax{..} = def +-} + +#include "enqueueExample1.hs" + +enqueueExamples :: [(VoiceTwiml, FilePath)] +enqueueExamples = + [ (enqueueExample1, "test/xml/enqueueExample1.xml") + ] + +{- Leave -} + +{- +leaveExample1 :: VoiceTwiml +leaveExample1 = + response $ do + leave + end + where Twiml.Syntax{..} = def +-} + +#include "leaveExample1.hs" + +leaveExamples :: [(VoiceTwiml, FilePath)] +leaveExamples = + [ (leaveExample1, "test/xml/leaveExample1.xml") + ] + +{- Hangup -} + +{- +hangupExample1 :: VoiceTwiml +hangupExample1 = + response $ do + hangup + end + where Twiml.Syntax{..} = def +-} + +#include "hangupExample1.hs" + +hangupExamples :: [(VoiceTwiml, FilePath)] +hangupExamples = + [ (hangupExample1, "test/xml/hangupExample1.xml") + ] + +{- Redirect -} + +{- +redirectExample1 :: VoiceTwiml +redirectExample1 = + response $ do + dial "415-123-4567" def + redirect (fromJust $ parseURL "http://www.foo.com/nextInstructions") def + end + where Twiml.Syntax{..} = def +-} + +#include "redirectExample1.hs" + +redirectExample2 :: VoiceTwiml +redirectExample2 = + response $ do + redirect (fromJust $ parseURL "../nextInstructions") def + end + where Twiml.Syntax{..} = def + +redirectExamples :: [(VoiceTwiml, FilePath)] +redirectExamples = + [ (redirectExample1, "test/xml/redirectExample1.xml") + , (redirectExample2, "test/xml/redirectExample2.xml") + ] + +{- Reject -} + +rejectExample1 :: VoiceTwiml +rejectExample1 = + response $ do + reject def + end + where Twiml.Syntax{..} = def + +{- +rejectExample2 :: VoiceTwiml +rejectExample2 = + response $ do + reject $ def & reason .~ Just Busy + end + where Twiml.Syntax{..} = def +-} + +#include "rejectExample2.hs" + +rejectExamples :: [(VoiceTwiml, FilePath)] +rejectExamples = + [ (rejectExample1, "test/xml/rejectExample1.xml") + , (rejectExample2, "test/xml/rejectExample2.xml") + ] + +{- Pause -} + +{- +pauseExample1 :: VoiceTwiml +pauseExample1 = + response $ do + say "I will pause 10 seconds starting now!" def + pause $ def & duration .~ Just 10 + say "I just paused 10 seconds" def + end + where Twiml.Syntax{..} = def +-} + +#include "pauseExample1.hs" + +pauseExample2 :: VoiceTwiml +pauseExample2 = + response $ do + pause $ def & duration .~ Just 5 + say "Hi there." def + end + where Twiml.Syntax{..} = def + +pauseExamples :: [(VoiceTwiml, FilePath)] +pauseExamples = + [ (pauseExample1, "test/xml/pauseExample1.xml") + , (pauseExample2, "test/xml/pauseExample2.xml") + ] + +{- Main -} + +examples :: [(VoiceTwiml, FilePath)] +examples = concat + [ sayExamples + , playExamples + , gatherExamples + , recordExamples + , smsExamples + , dialExamples + , enqueueExamples + , leaveExamples + , hangupExamples + , redirectExamples + , rejectExamples + ] + +ifThenElse :: Bool -> t -> t -> t +ifThenElse b x y | b = x + | otherwise = y + +tests :: IO [Test] +tests = return $ map check examples + +check :: (VoiceTwiml, FilePath) -> Test +check (twiml, filePath) = Test test + where test = TestInstance { + run = do + let a = show twiml + b <- readFile filePath + let equal = a == b + unless equal $ do + putStrLn "" + putStrLn . ppDiff $ getGroupedDiff (lines b) (lines a) + return . Finished $ if equal + then Pass + else Error "Check preceding diff", + name = filePath, + tags = [], + options = [], + setOption = \_ _ -> Right test + } diff --git a/test/ShouldNotTypecheck.hs b/test/ShouldNotTypecheck.hs new file mode 100644 --- /dev/null +++ b/test/ShouldNotTypecheck.hs @@ -0,0 +1,75 @@ +{-#OPTIONS_GHC -fdefer-type-errors -fno-defer-typed-holes #-} +{-#LANGUAGE DataKinds #-} +{-#LANGUAGE RebindableSyntax #-} +{-#LANGUAGE RecordWildCards #-} + +module ShouldNotTypecheck where + +import Text.XML.Twiml +import qualified Text.XML.Twiml.Syntax as Twiml + +import Control.DeepSeq (NFData) +import Data.Default +import Data.Void +import Distribution.TestSuite +import qualified Test.HUnit as H +import Test.ShouldNotTypecheck + +import Prelude + +-- NOTE: I don't really understand why these aren't working. I see the warning +-- when the module is compiled. + +tests :: IO [Test] +tests = return + [] +{- + [ makeTest "\"Cannot nest in \"" gatherInGather + -- , makeTest "\"Cannot nest in \"" recordInGather + -- , makeTest "\"Cannot nest in \"" smsInGather + -- , makeTest "\"Cannot nest in \"" dialInGather + -- , makeTest "\"Cannot nest in \"" enqueueInGather + -- , makeTest "\"Cannot nest in \"" leaveInGather + -- , makeTest "\"Cannot nest in \"" hangupInGather + -- , makeTest "\"Cannot nest in \"" redirectInGather + -- , makeTest "\"Cannot nest in \"" rejectInGather + ] +-} + +makeTest :: NFData a => String -> a -> Test +makeTest name twiml = Test test + where test = TestInstance { + run = runTest . H.TestCase $ shouldNotTypecheck twiml, + name = name, + tags = [], + options = [], + setOption = \_ _ -> Right test + } + +runTest :: H.Test -> IO Progress +runTest = fmap snd . H.performTest onStart onError onFailure (Finished Pass) + where + onStart :: H.State -> Progress -> IO Progress + onStart _ = return + + onError :: String -> H.State -> Progress -> IO Progress + onError msg _ _ = return $ Finished (Error msg) + + onFailure :: String -> H.State -> Progress -> IO Progress + onFailure msg _ _ = return $ Finished (Fail msg) + +{- +someGather :: Twiml' '[Gather] Void +someGather = + do + gather def end + end + where Twiml.Syntax{..} = def + +gatherInGather :: Twiml +gatherInGather = + response $ do + gather def someGather + end + where Twiml.Syntax{..} = def +-} diff --git a/test/Test.hs b/test/Test.hs deleted file mode 100644 --- a/test/Test.hs +++ /dev/null @@ -1,264 +0,0 @@ -module Main where - -import Text.XML.Twiml - -import Data.Functor ((<$>)) -import Control.Lens -import Control.Monad (when) -import Data.Maybe (fromJust) -import System.IO - -{- Say -} - -sayExample1 = - ( respond - . say "Hello World" - $ end - , "test/xml/sayExample1.xml" ) - -sayExample2 = - ( respond - . (sayAlice' PtBR "Bom dia." <&> loop .~ 2) - $ end - , "test/xml/sayExample2.xml" ) - -sayExamples = [ sayExample1, sayExample2 ] - -{- Play -} - -playExample1 = - ( respond - . play (parseURL "https://api.twilio.com/cowbell.mp3") - $ end - , "test/xml/playExample1.xml" ) - -playExample2 = - ( respond - . (play Nothing <&> digits .~ [W, W, W, W, D3]) - $ end - , "test/xml/playExample2.xml" ) - -playExamples = [ playExample1, playExample2 ] - -{- Gather -} - -gatherExample1 = - ( respond - . gather end - $ end - , "test/xml/gatherExample1.xml" ) - --- FIXME: Ugly. -gatherExample2 = - ( respond - . (gather <&> action .~ (fromJust $ parseURL "/process_gather.php") - <&> method .~ GET - $ say "Please enter your account number, followed by the pound sign" - $ end) - . say "We didn't receive any input. Goodbye!" - $ end - , "test/xml/gatherExample2.xml" ) - -gatherExamples = [ gatherExample1, gatherExample2 ] - -{- Record -} - -recordExample1 = - ( respond - . record - $ end - , "test/xml/recordExample1.xml" ) - -recordExample2 = - ( respond - . say "Please leave a message at the beep. Press the star key when finished." - . (record <&> action .~ (fromJust $ parseURL "http://foo.edu/handleRecording.php") - <&> method .~ GET - <&> maxLength .~ 20 - <&> finishOnKey .~ KStar) - . say "I did not receive a recording" - $ end - , "test/xml/recordExample2.xml" ) - -recordExample3 = - ( respond - . (record <&> transcribe .~ True - <&> transcribeCallback .~ (fromJust $ parseURL "/handle_transcribe.php")) - $ end - , "test/xml/recordExample3.xml" ) - -recordExamples = [ recordExample1, recordExample2, recordExample3 ] - -{- Sms -} - -smsExample1 = - ( respond - . say "Our store is located at 123 Easy St." - . sms "Store Location: 123 Easy St." - $ end - , "test/xml/smsExample1.xml" ) - -smsExample2 = - ( respond - . say "Our store is located at 123 Easy St." - . (sms "Store Location: 123 Easy St." <&> action .~ (fromJust $ parseURL "/smsHandler.php") - <&> method .~ POST) - $ end - , "test/xml/smsExample2.xml" ) - -smsExample3 = - ( respond - . say "Our store is located at 123 Easy St." - . (sms "Store Location: 123 Easy St." <&> statusCallback .~ (fromJust $ parseURL "/smsHandler.php")) - $ end - , "test/xml/smsExample3.xml" ) - -smsExamples = [ smsExample1, smsExample2, smsExample3 ] - -{- Dial -} - --- FIXME: Ugly. -dialExample1 = - ( respond - . dial (Right "415-123-4567") - . say "Goodbye" - $ end - , "test/xml/dialExample1.xml" ) - -dialExample2 = - ( respond - . (dial (Right "415-123-4567") <&> action .~ (fromJust $ parseURL "/handleDialCallStatus.php") - <&> method .~ GET) - . say "I am unreachable" - $ end - , "test/xml/dialExample2.xml" ) - -dialExample3 = - ( respond - . (dial - (Left $ Number (NumberAttributes Nothing Nothing Nothing) "+15558675309") - <&> callerId .~ "+15551112222") - $ end - , "test/xml/dialExample3.xml" ) - -dialExamples = [ dialExample1, dialExample2, dialExample3 ] - --- TODO: Dial nouns... - -{- Enqueue -} - -enqueueExample1 = - ( respond - . (enqueue "support" <&> waitURL .~ (fromJust $ parseURL "wait-music.xml")) - $ end - , "test/xml/enqueueExample1.xml" ) - -enqueueExamples = [ enqueueExample1 ] - -{- Leave -} - -leaveExample1 = - ( respond - . leave - $ end - , "test/xml/leaveExample1.xml" ) - -leaveExamples = [ leaveExample1 ] - -{- Hangup -} - -hangupExample1 = - ( respond - . hangup - $ end - , "test/xml/hangupExample1.xml" ) - -hangupExamples = [ hangupExample1 ] - -{- Redirect -} - --- FIXME: Ugly. -redirectExample1 = - ( respond - . dial (Right "415-123-4567") - . redirect (fromJust $ parseURL "http://www.foo.com/nextInstructions") - $ end - , "test/xml/redirectExample1.xml" ) - -redirectExample2 = - ( respond - . redirect (fromJust $ parseURL "../nextInstructions") - $ end - , "test/xml/redirectExample2.xml" ) - -redirectExamples = [ redirectExample1, redirectExample2 ] - -{- Reject -} - -rejectExample1 = - ( respond - . reject - $ end - , "test/xml/rejectExample1.xml" ) - -rejectExample2 = - ( respond - . (reject <&> reason .~ Busy) - $ end - , "test/xml/rejectExample2.xml" ) - -rejectExamples = [ rejectExample1, rejectExample2 ] - -{- Pause -} - -pauseExample1 = - ( respond - . say "I will pause 10 seconds starting now!" - . (pause <&> duration .~ 10) - . say "I just paused 10 seconds" - $ end - , "test/xml/pauseExample1.xml" ) - -pauseExample2 = - ( respond - . (pause <&> duration .~ 5) - . say "Hi there." - $ end - , "test/xml/pauseExample2.xml" ) - -pauseExamples = [ pauseExample1, pauseExample2 ] - -{- Main -} - -examples = concat - [ sayExamples - , playExamples - , gatherExamples - , recordExamples - , smsExamples - , dialExamples - , enqueueExamples - , leaveExamples - , hangupExamples - , redirectExamples - , rejectExamples - ] - -main :: IO () -main = do - results <- sequence $ map check examples - when (not $ and results) $ error "Failed" - -check :: (Response, FilePath) -> IO Bool -check (twiml, filePath) = do - let a = show twiml - b <- readFile filePath - let equal = a == b - if (not equal) - then do - putStrLn $ "Failed: " ++ filePath - putStrLn $ "Expected:\n" ++ b - putStrLn $ "Got:\n" ++ a ++ "\n" - else do - putStrLn $ "Passed: " ++ filePath - return equal diff --git a/test/examples/dialExample1.txt b/test/examples/dialExample1.txt new file mode 100644 --- /dev/null +++ b/test/examples/dialExample1.txt @@ -0,0 +1,14 @@ +> example :: VoiceTwiml +> example = +> response $ do +> dial "415-123-4567" def +> say "Goodbye" def +> end +> where Twiml.Syntax{..} = def + +>>> show example + + + 415-123-4567 + Goodbye + diff --git a/test/examples/dialExample3.txt b/test/examples/dialExample3.txt new file mode 100644 --- /dev/null +++ b/test/examples/dialExample3.txt @@ -0,0 +1,15 @@ +> example :: VoiceTwiml +> example = +> response $ do +> dial' (Left $ Number def "+15558675309") $ def +> & callerId .~ Just "+15551112222" +> end +> where Twiml.Syntax{..} = def + +>>> show example + + + + +15558675309 + + diff --git a/test/examples/enqueueExample1.txt b/test/examples/enqueueExample1.txt new file mode 100644 --- /dev/null +++ b/test/examples/enqueueExample1.txt @@ -0,0 +1,12 @@ +> example :: VoiceTwiml +> example = +> response $ do +> enqueue "support" $ def & waitURL .~ parseURL "wait-music.xml" +> end +> where Twiml.Syntax{..} = def + +>>> show example + + + support + diff --git a/test/examples/gatherExample2.txt b/test/examples/gatherExample2.txt new file mode 100644 --- /dev/null +++ b/test/examples/gatherExample2.txt @@ -0,0 +1,19 @@ +> example :: VoiceTwiml +> example = +> response $ do +> gather (def & action .~ parseURL "/process_gather.php" +> & method .~ Just GET) $ do +> say "Please enter your account number, followed by the pound sign" def +> end +> say "We didn't receive any input. Goodbye!" def +> end +> where Twiml.Syntax{..} = def + +>>> show example + + + + Please enter your account number, followed by the pound sign + + We didn't receive any input. Goodbye! + diff --git a/test/examples/hangupExample1.txt b/test/examples/hangupExample1.txt new file mode 100644 --- /dev/null +++ b/test/examples/hangupExample1.txt @@ -0,0 +1,12 @@ +> example :: VoiceTwiml +> example = +> response $ do +> hangup +> end +> where Twiml.Syntax{..} = def + +>>> show example + + + + diff --git a/test/examples/leaveExample1.txt b/test/examples/leaveExample1.txt new file mode 100644 --- /dev/null +++ b/test/examples/leaveExample1.txt @@ -0,0 +1,12 @@ +> example :: VoiceTwiml +> example = +> response $ do +> leave +> end +> where Twiml.Syntax{..} = def + +>>> show example + + + + diff --git a/test/examples/pauseExample1.txt b/test/examples/pauseExample1.txt new file mode 100644 --- /dev/null +++ b/test/examples/pauseExample1.txt @@ -0,0 +1,16 @@ +> example :: VoiceTwiml +> example = +> response $ do +> say "I will pause 10 seconds starting now!" def +> pause $ def & duration .~ Just 10 +> say "I just paused 10 seconds" def +> end +> where Twiml.Syntax{..} = def + +>>> show example + + + I will pause 10 seconds starting now! + + I just paused 10 seconds + diff --git a/test/examples/playExample1.txt b/test/examples/playExample1.txt new file mode 100644 --- /dev/null +++ b/test/examples/playExample1.txt @@ -0,0 +1,12 @@ +> example :: VoiceTwiml +> example = +> response $ do +> play (fromJust $ parseURL "https://api.twilio.com/cowbell.mp3") def +> end +> where Twiml.Syntax{..} = def + +>>> show example + + + https://api.twilio.com/cowbell.mp3 + diff --git a/test/examples/playExample2.txt b/test/examples/playExample2.txt new file mode 100644 --- /dev/null +++ b/test/examples/playExample2.txt @@ -0,0 +1,12 @@ +> example :: VoiceTwiml +> example = +> response $ do +> play' Nothing $ def & digits .~ Just [W, W, W, W, D3] +> end +> where Twiml.Syntax{..} = def + +>>> show example + + + + diff --git a/test/examples/recordExample2.txt b/test/examples/recordExample2.txt new file mode 100644 --- /dev/null +++ b/test/examples/recordExample2.txt @@ -0,0 +1,19 @@ +> example :: VoiceTwiml +> example = +> response $ do +> say "Please leave a message at the beep. Press the star key when finished." def +> record $ def & action .~ parseURL "http://foo.edu/handleRecording.php" +> & method .~ Just GET +> & maxLength .~ Just 20 +> & finishOnKey .~ Just KStar +> say "I did not receive a recording" def +> end +> where Twiml.Syntax{..} = def + +>>> show example + + + Please leave a message at the beep. Press the star key when finished. + + I did not receive a recording + diff --git a/test/examples/redirectExample1.txt b/test/examples/redirectExample1.txt new file mode 100644 --- /dev/null +++ b/test/examples/redirectExample1.txt @@ -0,0 +1,14 @@ +> example :: VoiceTwiml +> example = +> response $ do +> dial "415-123-4567" def +> redirect (fromJust $ parseURL "http://www.foo.com/nextInstructions") def +> end +> where Twiml.Syntax{..} = def + +>>> show example + + + 415-123-4567 + http://www.foo.com/nextInstructions + diff --git a/test/examples/rejectExample2.txt b/test/examples/rejectExample2.txt new file mode 100644 --- /dev/null +++ b/test/examples/rejectExample2.txt @@ -0,0 +1,12 @@ +> example :: VoiceTwiml +> example = +> response $ do +> reject $ def & reason .~ Just Busy +> end +> where Twiml.Syntax{..} = def + +>>> show example + + + + diff --git a/test/examples/sayExample2.txt b/test/examples/sayExample2.txt new file mode 100644 --- /dev/null +++ b/test/examples/sayExample2.txt @@ -0,0 +1,13 @@ +> example :: VoiceTwiml +> example = +> response $ do +> say "Bom dia." $ def & voice .~ Just (Alice $ Just PtBR) +> & loop .~ Just 2 +> end +> where Twiml.Syntax{..} = def + +>>> show example + + + Bom dia. + diff --git a/test/examples/smsExample2.txt b/test/examples/smsExample2.txt new file mode 100644 --- /dev/null +++ b/test/examples/smsExample2.txt @@ -0,0 +1,16 @@ +> example :: VoiceTwiml +> example = +> response $ do +> say "Our store is located at 123 Easy St." def +> sms "Store Location: 123 Easy St." $ def +> & action .~ parseURL "/smsHandler.php" +> & method .~ Just POST +> end +> where Twiml.Syntax{..} = def + +>>> show example + + + Our store is located at 123 Easy St. + Store Location: 123 Easy St. + diff --git a/test/xml/dialExample1.xml b/test/xml/dialExample1.xml deleted file mode 100644 --- a/test/xml/dialExample1.xml +++ /dev/null @@ -1,5 +0,0 @@ - - - 415-123-4567 - Goodbye - diff --git a/test/xml/dialExample2.xml b/test/xml/dialExample2.xml deleted file mode 100644 --- a/test/xml/dialExample2.xml +++ /dev/null @@ -1,5 +0,0 @@ - - - 415-123-4567 - I am unreachable - diff --git a/test/xml/dialExample3.xml b/test/xml/dialExample3.xml deleted file mode 100644 --- a/test/xml/dialExample3.xml +++ /dev/null @@ -1,6 +0,0 @@ - - - - +15558675309 - - diff --git a/test/xml/enqueueExample1.xml b/test/xml/enqueueExample1.xml deleted file mode 100644 --- a/test/xml/enqueueExample1.xml +++ /dev/null @@ -1,4 +0,0 @@ - - - support - diff --git a/test/xml/gatherExample1.xml b/test/xml/gatherExample1.xml deleted file mode 100644 --- a/test/xml/gatherExample1.xml +++ /dev/null @@ -1,4 +0,0 @@ - - - - diff --git a/test/xml/gatherExample2.xml b/test/xml/gatherExample2.xml deleted file mode 100644 --- a/test/xml/gatherExample2.xml +++ /dev/null @@ -1,7 +0,0 @@ - - - - Please enter your account number, followed by the pound sign - - We didn't receive any input. Goodbye! - diff --git a/test/xml/hangupExample1.xml b/test/xml/hangupExample1.xml deleted file mode 100644 --- a/test/xml/hangupExample1.xml +++ /dev/null @@ -1,4 +0,0 @@ - - - - diff --git a/test/xml/leaveExample1.xml b/test/xml/leaveExample1.xml deleted file mode 100644 --- a/test/xml/leaveExample1.xml +++ /dev/null @@ -1,4 +0,0 @@ - - - - diff --git a/test/xml/pauseExample1.xml b/test/xml/pauseExample1.xml deleted file mode 100644 --- a/test/xml/pauseExample1.xml +++ /dev/null @@ -1,6 +0,0 @@ - - - I will pause 10 seconds starting now! - - I just paused 10 seconds - diff --git a/test/xml/pauseExample2.xml b/test/xml/pauseExample2.xml deleted file mode 100644 --- a/test/xml/pauseExample2.xml +++ /dev/null @@ -1,5 +0,0 @@ - - - - Hi there. - diff --git a/test/xml/playExample1.xml b/test/xml/playExample1.xml deleted file mode 100644 --- a/test/xml/playExample1.xml +++ /dev/null @@ -1,4 +0,0 @@ - - - https://api.twilio.com/cowbell.mp3 - diff --git a/test/xml/playExample2.xml b/test/xml/playExample2.xml deleted file mode 100644 --- a/test/xml/playExample2.xml +++ /dev/null @@ -1,4 +0,0 @@ - - - - diff --git a/test/xml/recordExample1.xml b/test/xml/recordExample1.xml deleted file mode 100644 --- a/test/xml/recordExample1.xml +++ /dev/null @@ -1,4 +0,0 @@ - - - - diff --git a/test/xml/recordExample2.xml b/test/xml/recordExample2.xml deleted file mode 100644 --- a/test/xml/recordExample2.xml +++ /dev/null @@ -1,6 +0,0 @@ - - - Please leave a message at the beep. Press the star key when finished. - - I did not receive a recording - diff --git a/test/xml/recordExample3.xml b/test/xml/recordExample3.xml deleted file mode 100644 --- a/test/xml/recordExample3.xml +++ /dev/null @@ -1,4 +0,0 @@ - - - - diff --git a/test/xml/redirectExample1.xml b/test/xml/redirectExample1.xml deleted file mode 100644 --- a/test/xml/redirectExample1.xml +++ /dev/null @@ -1,5 +0,0 @@ - - - 415-123-4567 - http://www.foo.com/nextInstructions - diff --git a/test/xml/redirectExample2.xml b/test/xml/redirectExample2.xml deleted file mode 100644 --- a/test/xml/redirectExample2.xml +++ /dev/null @@ -1,4 +0,0 @@ - - - ../nextInstructions - diff --git a/test/xml/rejectExample1.xml b/test/xml/rejectExample1.xml deleted file mode 100644 --- a/test/xml/rejectExample1.xml +++ /dev/null @@ -1,4 +0,0 @@ - - - - diff --git a/test/xml/rejectExample2.xml b/test/xml/rejectExample2.xml deleted file mode 100644 --- a/test/xml/rejectExample2.xml +++ /dev/null @@ -1,4 +0,0 @@ - - - - diff --git a/test/xml/sayExample1.xml b/test/xml/sayExample1.xml deleted file mode 100644 --- a/test/xml/sayExample1.xml +++ /dev/null @@ -1,4 +0,0 @@ - - - Hello World - diff --git a/test/xml/sayExample2.xml b/test/xml/sayExample2.xml deleted file mode 100644 --- a/test/xml/sayExample2.xml +++ /dev/null @@ -1,4 +0,0 @@ - - - Bom dia. - diff --git a/test/xml/smsExample1.xml b/test/xml/smsExample1.xml deleted file mode 100644 --- a/test/xml/smsExample1.xml +++ /dev/null @@ -1,5 +0,0 @@ - - - Our store is located at 123 Easy St. - Store Location: 123 Easy St. - diff --git a/test/xml/smsExample2.xml b/test/xml/smsExample2.xml deleted file mode 100644 --- a/test/xml/smsExample2.xml +++ /dev/null @@ -1,5 +0,0 @@ - - - Our store is located at 123 Easy St. - Store Location: 123 Easy St. - diff --git a/test/xml/smsExample3.xml b/test/xml/smsExample3.xml deleted file mode 100644 --- a/test/xml/smsExample3.xml +++ /dev/null @@ -1,5 +0,0 @@ - - - Our store is located at 123 Easy St. - Store Location: 123 Easy St. - diff --git a/twiml.cabal b/twiml.cabal --- a/twiml.cabal +++ b/twiml.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: twiml -version: 0.1.0.0 +version: 0.2.0.0 synopsis: TwiML library for Haskell description: TwiML library for Haskell homepage: https://github.com/markandrus/twiml-haskell @@ -14,30 +14,7 @@ category: Text, Web, XML build-type: Simple cabal-version: >=1.8 -data-files: test/xml/dialExample1.xml, - test/xml/dialExample2.xml, - test/xml/dialExample3.xml, - test/xml/enqueueExample1.xml, - test/xml/gatherExample1.xml, - test/xml/gatherExample2.xml, - test/xml/hangupExample1.xml, - test/xml/leaveExample1.xml, - test/xml/pauseExample1.xml, - test/xml/pauseExample2.xml, - test/xml/playExample1.xml, - test/xml/playExample2.xml, - test/xml/recordExample1.xml, - test/xml/recordExample2.xml, - test/xml/recordExample3.xml, - test/xml/redirectExample1.xml, - test/xml/redirectExample2.xml, - test/xml/rejectExample1.xml, - test/xml/rejectExample2.xml, - test/xml/sayExample1.xml, - test/xml/sayExample2.xml, - test/xml/smsExample1.xml, - test/xml/smsExample2.xml, - test/xml/smsExample3.xml +data-files: test/examples/*.txt source-repository head type: git @@ -45,28 +22,64 @@ library exposed-modules: Text.XML.Twiml, + Text.XML.Twiml.Internal, + Text.XML.Twiml.Internal.Twiml, + Text.XML.Twiml.Lenses, + Text.XML.Twiml.Syntax, Text.XML.Twiml.Types, Text.XML.Twiml.Verbs, - Text.XML.Twiml.Verbs.End, - Text.XML.Twiml.Verbs.Say, - Text.XML.Twiml.Verbs.Play, - Text.XML.Twiml.Verbs.Gather, - Text.XML.Twiml.Verbs.Record, - Text.XML.Twiml.Verbs.Sms, Text.XML.Twiml.Verbs.Dial, + Text.XML.Twiml.Verbs.End, Text.XML.Twiml.Verbs.Enqueue, - Text.XML.Twiml.Verbs.Leave, + Text.XML.Twiml.Verbs.Gather, Text.XML.Twiml.Verbs.Hangup, + Text.XML.Twiml.Verbs.Leave, + Text.XML.Twiml.Verbs.Message, + Text.XML.Twiml.Verbs.Pause, + Text.XML.Twiml.Verbs.Play, + Text.XML.Twiml.Verbs.Record, Text.XML.Twiml.Verbs.Redirect, Text.XML.Twiml.Verbs.Reject, - Text.XML.Twiml.Verbs.Pause, - Text.XML.Twiml.Internal + Text.XML.Twiml.Verbs.Say, + Text.XML.Twiml.Verbs.Sms + other-modules: Text.XML.Twiml.Internal.TH hs-source-dirs: src -- other-modules: - build-depends: base ==4.6.*, xml >=1.3, network >=2.4 + build-depends: base ==4.*, + data-default ==0.5.*, + deepseq ==1.4.*, + lens ==4.*, + network-uri >=2.6, + parsec ==3.*, + text ==1.*, + template-haskell ==2.*, + void ==0.*, + xml >=1.3 + ghc-options: -Wall -fno-warn-unused-do-bind -test-suite Tests +test-suite Golden hs-source-dirs: test - main-is: Test.hs - Type: exitcode-stdio-1.0 - build-depends: base ==4.6.*, Cabal >=1.16.0, lens >=3.9, twiml + type: detailed-0.9 + test-module: Golden + build-depends: base ==4.*, + Cabal >=1.16.0, + data-default ==0.5.*, + Diff ==0.3.2, + lens ==4.*, + twiml + ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing + +test-suite ShouldNotTypecheck + hs-source-dirs: test + type: detailed-0.9 + test-module: ShouldNotTypecheck + build-depends: base ==4.*, + Cabal >=1.16.0, + data-default ==0.5.*, + deepseq ==1.4.*, + HUnit ==1.2.*, + lens ==4.*, + should-not-typecheck ==2.0.*, + twiml, + void ==0.* + ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing