regular-web (empty) → 0.1

raw patch · 10 files changed

+461/−0 lines, 10 filesdep +applicative-extrasdep +basedep +fclabelssetup-changedbinary-added

Dependencies added: applicative-extras, base, fclabels, formlets, json, mtl, regular, xhtml

Files

.DS_Store binary
LICENSE +28/−0
Setup.hs +2/−0
regular-web.cabal +78/−0
src/.DS_Store binary
src/Generics/.DS_Store binary
src/Generics/Regular/Extras.hs +23/−0
src/Generics/Regular/Formlets.hs +153/−0
src/Generics/Regular/JSON.hs +73/−0
src/Generics/Regular/Views.hs +104/−0

+ .DS_Store view

binary file changed (absent → 6148 bytes)

+ LICENSE view

@@ -0,0 +1,28 @@+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Tupil nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ regular-web.cabal view

@@ -0,0 +1,78 @@+Name:            regular-web+Version:         0.1+Synopsis:        Generic programming for the web+License:         BSD3+License-file:    LICENSE+Category:        Generics, Web+Copyright:       (c) Chris Eidhof+Author:          Chris Eidhof+Maintainer:      Chris Eidhof <chris+hackage@eidhof.nl>+Homepage:        http://github.com/chriseidhof/basil+Exposed-Modules:   Generics.Regular.Formlets+                 , Generics.Regular.Views+                 , Generics.Regular.JSON+Other-Modules:   Generics.Regular.Extras+Build-Type:      Simple+hs-source-dirs:  src+Build-Depends:   base >= 4 && < 5, +                 mtl,+                 xhtml,+                 formlets == 0.6.1,+                 applicative-extras,+                 regular >= 0.1.0.2,+                 fclabels >= 0.4.2,+                 json >= 0.4.3++Description: +  This package implements generic functions for web programming.+  Based on the @regular@ library [1], we provide generic functions for generating @HTML@, @Formlets@, and @JSON@.+  For a larger example, see the @Example.lhs@ [2] file on github.+  .+    1. <http://hackage.haskell.org/package/regular>+  .+    2. <http://github.com/chriseidhof/regular-web/blob/master/Example.lhs>+  .+  /Example/+  .+  Consider the following datatypes:+  .+  > data Person = Person {+  >     _name   :: String+  >   , _age    :: Int+  >   , _isMale :: Bool+  >   , _place  :: Place+  >   }+  +  > data Place = Place {+  >     _city      :: String+  >   , _country   :: String+  >   , _continent :: String+  > }+  .+  We can now derive a @Regular@ instance for the @Person@ datatype using Template+  Haskell:+  .+  > $(deriveAll ''Place  "PFPlace")+  > $(deriveAll ''Person "PFPerson")+  .+  >+  > type instance PF Place  = PFPlace+  > type instance PF Person = PFPerson+  .+  We can construct an example person:+  .+  > location :: Place+  > location = Place "Utrecht" "The Netherlands" "Europe"+  > chris    :: Person+  > chris    = Person "chris" 25 True location+  .+  > And, as an example, we can generate |HTML| and |JSON| values:+  .+  > locationHtml :: X.Html+  > locationHtml = ghtml location+  .+  > personHtml :: X.Html+  > personHtml = ghtml chris+  .+  > locationJSON :: JSValue+  > locationJSON = gto location

+ src/.DS_Store view

binary file changed (absent → 6148 bytes)

+ src/Generics/.DS_Store view

binary file changed (absent → 6148 bytes)

+ src/Generics/Regular/Extras.hs view

@@ -0,0 +1,23 @@+{-# LANGUAGE KindSignatures #-}+module Generics.Regular.Extras where++import Generics.Regular+import Data.Char (isAlpha, toUpper)++prodFst :: (:*:) l r t1 -> l t1+prodSnd :: (:*:) l r t1 -> r t1+prodFst (x :*: _) = x+prodSnd (_ :*: y) = y++-- | Capitalizes the first letter and filters out all the non-alpha characters.+humanReadable :: String -> String+humanReadable = filter isAlpha . capitalize++-- | Capitalize the first letter of the string.+capitalize :: String -> String+capitalize "" = ""+capitalize (c:cs) = toUpper c : cs++-- | Generates a human-readable version of a selector.+h :: Selector s => t s (f :: * -> *) r -> String	+h = humanReadable . selName

+ src/Generics/Regular/Formlets.hs view

@@ -0,0 +1,153 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeOperators, TypeSynonymInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.Regular.Formlets+-- Copyright   :  (c) 2010 Chris Eidhof+-- License     :  BSD3+--+-- Maintainer  :  chris@eidhof.nl+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Generic generation of formlets <http://hackage.haskell.org/package/formlets>. +-- These functions are only defined for record datatypes that contain+-- a single constructor.+--+-- Consider the datatype @Person@:+--  +-- > data Person = Person {+-- >    _name   :: String+-- >  , _age    :: Int+-- >  , _isMale :: Bool+-- > } deriving (Show, Eq)+--+-- We prefix all our fields with an underscore (@_@), so that our datatype will play nice with @fclabels@. +-- +-- > $(deriveAll ''Person "PFPerson")+-- +-- > type instance PF Person = PFPerson+-- +-- We can construct an example person:+-- +-- > chris    :: Person+-- > chris    = Person "chris" 25 True+-- +-- > personForm :: XFormlet Identity Person+-- > personForm = gformlet+-- +-- We can print @formHtml@ to get the @Html@ of the form with the @chris@ value+-- already filled in:+-- +-- > formHtml :: X.Html+-- > (_, Identity formHtml, _) = F.runFormState [] (personForm (Just chris))+-----------------------------------------------------------------------------+module Generics.Regular.Formlets (+  -- * Generic forms+  gform,+  gformlet,+  GFormlet,+  XForm,+  XFormlet,+  -- * Generic forms with fclabels+  projectedForm,+  -- * Default Formlet typeclass+  Formlet (..),+  -- * Extra form types+  -- | Currently, this section is very limited. We expect to add more types in the future, suggestions are welcome.+  YesNo (..),+  boolToYesNo+  ) where++import Control.Applicative+import Control.Monad.Identity+import Text.XHtml.Strict ((+++), (<<))+import qualified Text.XHtml.Strict as X+import qualified Text.XHtml.Strict.Formlets as F+import Generics.Regular+import Generics.Regular.Extras+import Data.Record.Label+++gform :: (Regular a, GFormlet (PF a), Functor m, Applicative m, Monad m) => Maybe a -> XForm m a+gform x = to <$> (gformf gformlet (from <$> x))++gformlet :: (Regular a, GFormlet (PF a), Functor m, Applicative m, Monad m) => XFormlet m a+gformlet x = to <$> (gformf gformlet (from <$> x))++-- |+-- Generic forms almost never match the real world. If you want to change a generic form, you can either implement it from scratch, or use the 'projectedForm' function.+-- +-- As an example, we will to remove the 'age' field from the form, and change the '_isMale' field to a Yes\/No choice instead of a True\/False choice. The datatype 'YesNo' is defined in this module.+-- +-- > data PersonView = PersonView {+-- >    __name   :: String+-- >  , __isMale :: YesNo+-- > }+-- +-- +-- > $(deriveAll ''PersonView "PFPersonView")+-- > type instance PF PersonView = PFPersonView+-- +-- We can now use @fclabels@ to convert back and forth between @Person@ and+-- @PersonView@. First, we use Template Haskell to generate some accessor functions:+-- +-- > $(mkLabels [''Person])+-- +-- This is the bidirectional function between @Person@ and @PersonView@. How to write such a function is explained in the well-documented @fclabels@ package at <http://hackage.haskell.org/package/fclabels>.+-- +-- > toView :: Person :-> PersonView+-- > toView = Label (PersonView <$> __name `for` name <*> __isMale `for` (boolToYesNo `iso` isMale))+-- +-- Now that we have a function with type @Person :-> PersonView@, we can render a+-- form for @personView@ and update the original person. Note that the argument is+-- not a @Maybe@ value, in contrast with the @gformlet@ function.+-- +-- > personForm' :: Person -> XForm Identity Person+-- > personForm' = projectedForm toView+-- +-- > formHtml' :: X.Html+-- > (_, Identity formHtml', _) = F.runFormState [] (personForm' chris)++projectedForm :: (Regular a, GFormlet (PF a), Applicative m, Monad m) +              => (b :-> a) -> b -> XForm m b+projectedForm toView x = (flip (set toView) x) <$> (gform (get toView <$> (Just x)))++type XForm m a = F.XHtmlForm m a+type XFormlet m a = F.XHtmlFormlet m a++class    Formlet a      where  formlet :: (Functor m, Applicative m, Monad m) => XFormlet m a++instance Formlet Bool   where  formlet   = F.enumSelect []+instance Formlet Int    where  formlet x = fromIntegral <$> F.inputInteger (toInteger <$> x)+instance Formlet String where  formlet   = F.input++class GFormlet f where+  gformf :: (Functor m, Applicative m, Monad m) => XFormlet m a -> XFormlet m (f a)++instance (Constructor c, GFormlet f) => GFormlet (C c f) where+  gformf f x = C <$> (gformf f $ unC <$> x)++instance Formlet a => GFormlet (K a) where+  gformf _ x = K <$> (formlet (unK <$> x))++instance (GFormlet (S s f), GFormlet g) => GFormlet ((S s f) :*: g) where+  gformf f x = (:*:) <$> (gformf f (prodFst <$> x)) <* F.xml X.br <*> (gformf f (prodSnd <$> x))++ +instance (Selector s, GFormlet f) => GFormlet (S s f) where+  gformf f x = F.plug ((X.label << (h (fromJust x) ++ ": ")) +++) $ S <$> gformf f (unS <$> x)+   where fromJust (Just y) = y+         fromJust _        = error "Generic formlets fromJust should not be computed."++-- | This datatype is used to display 'Bool' values as @Yes@ or @No@.+data YesNo = Yes | No +  deriving (Eq, Show, Bounded, Enum)+instance Formlet YesNo where formlet = F.enumSelect []++-- | This is an @fclabels@ function that converts between 'Bool' and 'YesNo' values.+boolToYesNo :: Bool :<->: YesNo+boolToYesNo = to <-> from+ where  from Yes = True+        from No  = False+        to x  = if x then Yes else No

+ src/Generics/Regular/JSON.hs view

@@ -0,0 +1,73 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.Regular.Views+-- Copyright   :  (c) 2010 Chris Eidhof+-- License     :  BSD3+--+-- Maintainer  :  chris@eidhof.nl+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Generic generation of 'JSON' values. Note that the generic+-- functions are only defined for record datatypes that contain+-- a single constructor.+--+-- The code that is generated by 'gto' should be parseable by 'gfrom'.+-----------------------------------------------------------------------------+module Generics.Regular.JSON (gfrom, gto, GJSON) where++import Text.JSON+import Generics.Regular+import Generics.Regular.Extras+import Control.Applicative+import Data.List (unionBy)++-- | The function 'gfrom' tries to parse a 'JSValue'. The 'Result' datatype is used for error-messages if parsing fails.+gfrom :: (Regular a, GJSON (PF a)) => JSValue -> Result a+gfrom = fmap to . gfrom'++-- | The function 'gto' generates a 'JSValue' for all types that are an instance of 'GJSON'.+gto :: (Regular a, GJSON (PF a)) => a -> JSValue+gto = gto' . from++-- | This class is used for both generation and parsing of 'JSON'.+class GJSON f where+  gto'   :: f a -> JSValue+  gfrom' :: JSValue -> Result (f a)++instance GJSON U where+  gto'   U = JSNull+  gfrom' JSNull = Ok U+  gfrom' _      = Error "could not parse U"++instance JSON a => GJSON (K a) where+  gto' (K x) = showJSON x+  gfrom' x = K <$> readJSON x++instance (GJSON (S s f), GJSON g) => GJSON ((S s f) :*: g) where+  gto' (a :*: b) = merge (gto' a) (gto' b)+  gfrom' x       = do (:*:) <$> gfrom' x <*> gfrom' x++instance (Selector s, GJSON f) => GJSON (S s f) where+  gto' s@(S x) = JSObject $ toJSObject [(humanReadable $ selName s, gto' x)]+  gfrom' (JSObject obj) = let s = humanReadable $ selName (undefined :: S s f x) +                         in case valFromObj s obj of+                                 Ok x    -> S <$> gfrom' x+                                 Error e -> Error e+  gfrom' x              = Error $ "Expected json object, got " ++ show x++instance GJSON f => GJSON (C c f) where+  gto' (C x) = gto' x+  gfrom' x   = C <$> gfrom' x++merge :: JSValue -> JSValue -> JSValue+merge (JSObject l) (JSObject r) = JSObject (toJSObject $ mergeList (fromJSObject l) (fromJSObject r))+merge _            _            = error "Cannot merge objects."++mergeList :: [(String, JSValue)] -> [(String, JSValue)] -> [(String, JSValue)]+mergeList = unionBy (\x y -> fst x == fst y)

+ src/Generics/Regular/Views.hs view

@@ -0,0 +1,104 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.Regular.Views+-- Copyright   :  (c) 2010 Chris Eidhof+-- License     :  BSD3+--+-- Maintainer  :  chris@eidhof.nl+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Summary: Functions for generating HTML.+-----------------------------------------------------------------------------+++module Generics.Regular.Views (+  -- * Generic HTML generation.+  ghtml, +  Html (..),+  GHtml+  -- gtable, +  -- gtableRow,+  -- Table (..),+  -- GTable+  ) where++import Text.XHtml.Strict ((+++), (<<))+import qualified Text.XHtml.Strict as X++import Generics.Regular+import Generics.Regular.Extras++-- | The function 'ghtml' converts an 'a' value into 'X.Html'+ghtml :: (Regular a, GHtml (PF a)) => a -> X.Html+ghtml x = ghtmlf ghtml (from x)++-- | The function 'gtable' converts a list of 'a's into an 'X.Html' table with a row for each element.+gtable :: (Regular a, GTable (PF a)) => [a] -> X.Html+gtable xs = X.table << map gtableRow xs++-- | The class 'Html' converts a simple value 'a' into 'X.Html'.+class Html a where+  html :: a -> X.Html++instance Html Float  where html = X.toHtml . show+instance Html Int    where html = X.toHtml . show+instance Html Bool   where html = X.toHtml . show+instance Html String where html = X.toHtml ++-- | The class 'GHtml' converts a simple value 'a' into 'X.Html'.+class GHtml f where+  ghtmlf :: (a -> X.Html) -> f a -> X.Html++instance GHtml I where+  ghtmlf f (I r) = f r++instance (Constructor c, GHtml f) => GHtml (C c f) where+  ghtmlf f cx@(C x) = (X.h1 << capitalize (conName cx)) +++ ghtmlf f x++instance Html a => GHtml (K a) where+  ghtmlf _ (K x) = html x++instance (GHtml f, GHtml g) => GHtml (f :*: g) where+  ghtmlf f (x :*: y) = ghtmlf f x +++ X.br +++ ghtmlf f y++instance (GHtml f, GHtml g) => GHtml (f :+: g) where+  ghtmlf f (L x) = ghtmlf f x+  ghtmlf f (R y) = ghtmlf f y++instance (Selector s, GHtml f) => GHtml (S s f) where+  ghtmlf f s@(S x) = X.label << ((h s) ++ ": ") +++ ghtmlf f x+++class Table a where+  table :: a -> X.Html++instance Table Float  where table = html+instance Table String where table = html+instance Table Int    where table = html+instance Table Bool   where table = html++class GTable f where+  gtablef :: (a -> X.Html) -> f a -> X.Html++instance GTable I where+  gtablef f (I r) = f r++instance (Constructor c, GTable f) => GTable (C c f) where+  gtablef f (C x) = X.tr << (gtablef f x)++instance Table a => GTable (K a) where+  gtablef _ (K x) = table x++instance (GTable f, GTable g) => GTable (f :*: g) where+  gtablef f (x :*: y) = gtablef f x +++ gtablef f y++instance (Selector s, GTable f) => GTable (S s f) where+  gtablef f (S x) = X.td << gtablef f x++gtableRow :: (Regular a, GTable (PF a)) => a -> X.Html+gtableRow x = gtablef gtableRow (from x)