module Data.SemanticEditors(result, first, second, each, editIf, set, argument,
left, right, ioref, maybe, just, monad, bind,
applicative,
mkEditors, mkEditor, mkConstrTests)
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
result :: (b -> b') -> ((a -> b) -> (a -> b'))
result = (.)
each :: (a -> b) -> ([a] -> [b])
each = fmap
set :: a -> b -> a
set = const
just :: (a -> b) -> Maybe a -> Maybe b
just = monad
monad :: Monad m => (a -> b) -> m a -> m b
monad = liftM
bind :: Monad m => (a -> m b) -> m a -> m b
bind f = (>>= f)
applicative :: Applicative f => (a -> b) -> f a -> f b
applicative = fmap
argument :: (a' -> a) -> ((a -> b) -> (a' -> b))
argument = flip (.)
ioref :: (a -> a) -> IORef a -> IO ()
ioref = flip modifyIORef
editIf :: (a -> Bool) -> (a -> a) -> (a -> a)
editIf p f a = if p a then f a else a
infix 1 <.>
f <.> g = (f <$>) . g
mkEditors :: [Name] -> Q [Dec]
mkEditors = concat <.> mapM mkEditor
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")))
]) []]
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)