Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

split template haskell stuff into sec-th #1

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
4 changes: 3 additions & 1 deletion .gitignore
Original file line number Diff line number Diff line change
@@ -1 +1,3 @@
dist/
dist/
.cabal-sandbox/
cabal.sandbox.config
5 changes: 1 addition & 4 deletions README
Original file line number Diff line number Diff line change
Expand Up @@ -3,8 +3,6 @@ Semantic Editor Combinators

Semantic Editor Combinators as described by Conal Elliott
(See: <http://conal.net/blog/posts/semantic-editor-combinators/>)
and Template Haskell support for automatically creating semantic
editor combinators from Algebraic Data Types

Installation
============
Expand All @@ -18,7 +16,6 @@ Installation

# or download zip:
wget http://github.com/urso/sec/zipball/master

2.) In sec-directory install using cabal:
$ cabal install

3 changes: 0 additions & 3 deletions Setup.hs

This file was deleted.

7 changes: 3 additions & 4 deletions sec.cabal
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
Name: sec
Version: 0.0.1
Version: 0.1.0
Description: Semantic Editor Combinators as described by Conal Elliott
(See: <http://conal.net/blog/posts/semantic-editor-combinators/>)
and Template Haskell support for automatically creating semantic
Expand All @@ -14,6 +14,5 @@ cabal-version: >= 1.6
library
hs-source-dirs: src
exposed-modules: Data.SemanticEditors
build-depends: base >= 3 && < 5,
template-haskell == 2.*

build-depends: base >= 3 && < 5
ghc-options: -Wall
95 changes: 1 addition & 94 deletions src/Data/SemanticEditors.hs
Original file line number Diff line number Diff line change
@@ -1,16 +1,14 @@

module Data.SemanticEditors(result, first, second, each, editIf, set, argument,
left, right, ioref, maybe, just, monad, bind,
applicative,
mkEditors, mkEditor, mkConstrTests)
applicative)
where

import Control.Applicative
import Control.Arrow (first, second, left, right)
import Control.Monad (liftM)
import Data.Char (toUpper)
import Data.Maybe (isJust, fromJust, maybe)
import Language.Haskell.TH.Syntax
import Data.IORef

-- |Semantic Editor Combinator on the result of an unary function
Expand Down Expand Up @@ -53,94 +51,3 @@ ioref = flip modifyIORef
-- yields true for an input value.
editIf :: (a -> Bool) -> (a -> a) -> (a -> a)
editIf p f a = if p a then f a else a

infix 1 <.> -- chosen arbitrarily
f <.> g = (f <$>) . g

-- |mkEditors creates Semantic Editor Combinators for each data type given.
-- More information see mkEditor
mkEditors :: [Name] -> Q [Dec]
mkEditors = concat <.> mapM mkEditor

-- |mkEditor creates Semantic Editor Combinators for each named field in a given data type by
-- appending the fields name (first letter is converted to uppercase) to the name \"edit\".
-- If a fields name starts with an underscore \'_\' no editor will be generated
--
-- for example:
--
-- > data Person = Person { age :: Integer, name :: String, _sex :: String }
--
-- will generate the lifters editAge and editName:
--
-- @
-- editAge f p = p { age = f (age p) }
-- editName f p = p { name = f (name p) }
-- @
--
mkEditor :: Name -> Q [Dec]
mkEditor name = do
i <- reify name
map (fromJust) . filter (isJust) <.> mapM mkEditor' . concatMap vars $
case i of
TyConI (DataD _ _ _ cs _) -> cs
TyConI (NewtypeD _ _ _ c _) -> [c]
_ -> []

where vars (RecC _ v) = v

mkEditor' (name, _, _) = case nameBase name of
('_':_) -> return Nothing
(c:rest) -> Just <$> mkEditor'' ("edit" ++ (toUpper c:rest))
where
mkEditor'' :: String -> Q Dec
mkEditor'' name' = return $
FunD (mkName name')
[Clause [VarP (mkName "f"), VarP (mkName "r")] (NormalB $
RecUpdE (VarE (mkName "r"))
[(name,
AppE (VarE (mkName "f"))
(AppE (VarE name) (VarE $ mkName "r")))
]) []]

-- |Template Haskell function for automatically creating predicates testing the constructors of a
-- given data type.
-- for example:
--
-- @
-- data Color = Red | Green | Blue
-- $(mkConstrTests [''Color])
-- @
--
-- will generate the following functions:
--
-- @
-- isRed Red = True
-- isRed _ = False
-- isGreen Green = True
-- isGreen _ = False
-- isBlue Blue = True
-- isBlue _ = False
-- @
--
mkConstrTests :: [Name] -> Q [Dec]
mkConstrTests = concat <.> mapM mk
where
mk name = do
i <- reify name
map fromJust . filter isJust <.> mapM mkPredicate $
case i of
TyConI (DataD _ _ _ cs _) -> cs
_ -> []

mkPredicate (NormalC name ts) = Just <$> mkPredicate' name (length ts)
mkPredicate (RecC name ts) = Just <$> mkPredicate' name (length ts)
mkPredicate _ = return Nothing

mkPredicate' name argc = return $
FunD (predName name)
[ Clause [ConP name $ replicate argc WildP] (NormalB $ ConE (mkName "True")) []
, Clause [WildP] (NormalB $ ConE (mkName "False")) []
]

predName name = mkName ("is" ++ nameBase name)