concat [[1,2,3], [1,2,3]]
{{{
[1,2,3,1,2,3]
}}}

*Main> compare 1 2
LT
*Main> compare 3 2
GT
*Main> compare 3 3
EQ
*Main> compare 3.0 2.9
GT
*Main> compare 3.0 2
GT
*Main> :t (compare 1 1)
(compare 1 1) :: Ordering
*Main> :t compare
compare :: (Ord a) => a -> a -> Ordering

import EnableGUI -- from http://wxhaskell.sourceforge.net/download/EnableGUI.hs

import Graphics.UI.WXCore hiding (Var)
import Graphics.UI.WX hiding (Var, enter)
import Data.Bits ((.&.), complement)

myEventId = wxID_HIGHEST+1 -- the custom event ID
-- the custom event is registered as a menu event
createMyEvent = commandEventCreate wxEVT_COMMAND_MENU_SELECTED myEventId
registerMyEvent win io = evtHandlerOnMenuCommand win myEventId io

gui
  = do f <- frame [text := "custom event sample"]
       bt <- button f [text := "click to invoke a custom event"]
       set f [layout := column 1 [hfill (widget bt)]]
       set bt [on command := onClick f]
       registerMyEvent f (putStrLn "The custom event is fired!!")
       return ()
  where
      onClick f
        = do
          ev <- createMyEvent
          evtHandlerProcessEvent f ev
          return ()


main = enableGUI >> start gui

import EnableGUI -- from http://wxhaskell.sourceforge.net/download/EnableGUI.hs

import Graphics.UI.WXCore
import Graphics.UI.WX hiding
import Data.Bits ((.&.), complement)

textCtrlSetSingleLine ctrl = do
  style <- windowGetWindowStyleFlag ctrl
  windowSetWindowStyleFlag ctrl (style .&. (complement wxTE_MULTILINE))

gui
  = do f <- frame [text := "single line textbox sample"]
       input <- textCtrlRich f [bgcolor := black, textColor := white, font := fontFixed{ _fontSize = 12 }]
       set f [layout := column 1 [hfill (widget input)]]
       set input [processEnter := True]
       textCtrlSetSingleLine input
       set input [on command := onEnter input]
       return ()
  where
      onEnter input
        = do
          txt <- get input text
          putStrLn txt
          set input [text := ""]

main = enableGUI >> start gui

import Network.Socket
import Network.BSD
import System.IO (Handle, IOMode(ReadWriteMode), hPutStrLn, hGetLine, hClose)
import Control.Monad (liftM)
import Control.Concurrent (forkIO)
import Control.Exception (finally)

connectTo :: String -> Int -> IO Handle
connectTo host port_ = do
      let port = toEnum port_
      sock <- socket AF_INET Stream 0
      addrs <- liftM hostAddresses $ getHostByName host
      if null addrs then error $ "no such host : " ++ host else return ()
      connect sock $ SockAddrInet port (head addrs)
      handle <- socketToHandle sock ReadWriteMode
      return handle

listenAt :: Int -> (Handle -> IO ()) -> IO ()
listenAt port_ f = do
      let port = toEnum port_
      lsock <- socket AF_INET Stream 0
      bindSocket lsock $ SockAddrInet port iNADDR_ANY
      listen lsock sOMAXCONN
      loop lsock `finally` sClose lsock
   where
      loop lsock = do
      (sock,SockAddrInet _ _) <- accept lsock
      handle <- socketToHandle sock ReadWriteMode
      f handle
      loop lsock

server = withSocketsDo $ do
  listenAt 12345 (\h -> forkIO (do
      putStrLn "connection."
      hPutStrLn h "Hello, and Goodbye!"
   `finally` hClose h) >> return ())

client = withSocketsDo $ do
  h <- connectTo "localhost" 12345
  hGetLine h >>= putStrLn
  hClose h

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, FlexibleInstances, OverlappingInstances #-}
import Prelude (undefined,String,const,putStrLn,($))

data Zero = Zero
data Succ n = Succ n
data Yes = Yes
data No = No
data Nil = Nil
data Cons x xs = Cons

u = undefined

-- (<=)
class Lte a b c | a b -> c where
  lte :: a -> b -> c
  lte = u
instance Lte Zero b Yes
instance Lte (Succ n) Zero No
instance Lte a b c => Lte (Succ a) (Succ b) c

class Merge xs ys zs | xs ys -> zs where
  merge :: xs -> ys -> zs
  merge = u
instance Merge xs Nil xs
instance Merge Nil ys ys
instance (Lte x y b, Merge' b x y xs ys r) => Merge (Cons x xs) (Cons y ys) r
-- merge (Cons x xs) (Cons y ys) = merge' (x <= y) x y xs ys
class Merge' b x y xs ys r | b x y xs ys -> r
instance Merge xs (Cons y ys) zs => Merge' Yes x y xs ys (Cons x zs)
instance Merge (Cons x xs) ys zs => Merge' No  x y xs ys (Cons y zs)
-- merge' Yes x y xs ys = Cons x (merge xs (Cons y ys))
-- merge' No  x y xs ys = Cons y (merge (Cons x xs) ys)

class Sort xs ys | xs -> ys where
  sort :: xs -> ys
  sort = u
instance Sort Nil Nil
instance Sort (Cons x Nil) (Cons x Nil)
instance (Split xs ys zs, Sort ys ys', Sort zs zs', Merge ys' zs' r) => Sort xs r
-- sort Nil = Nil
-- sort (Cons x Nil) = Cons x Nil
-- sort xs = let (ys,zs) = split xs in merge (sort ys) (sort zs)

class Length xs n | xs -> n where
  length :: xs -> n
  length = u
instance Length Nil Zero
instance Length xs n => Length (Cons x xs) (Succ n)

class Split xs zs ws | xs -> zs ws where
instance Split' Nil xs zs ws => Split xs zs ws
-- split xs = split' Nil xs

class Split' xs ys zs ws | xs ys -> zs ws
instance (Length xs n, Length ys m, Lte m n b, Split'' b xs ys zs ws) => Split' xs ys zs ws
-- split' xs ys = split'' (length ys <= length xs) xs ys

class Split'' b xs ys zs ws | b xs ys -> zs ws where
instance Split'' Yes xs ys xs ys
instance Split' (Cons y xs) ys zs ws => Split'' No xs (Cons y ys) zs ws
-- split'' Yes xs ys = xs ys
-- split'' No  xs (Cons y ys) = split' (Cons y xs) ys

type One = Succ Zero
one :: One
one = u
type Two = Succ One
two :: Two
two = u
type Three = Succ Two
three :: Three
three = u
type Four = Succ Three
four :: Four
four = u

ls :: Cons Four (Cons Two (Cons Three (Cons One Nil)))
ls = u

ok :: Cons One (Cons Two (Cons Three (Cons Four Nil))) -> String
ok = const "ok"

main = putStrLn $ ok $ sort ls

data Tree a = Empty | Node a (Tree a) (Tree a) deriving (Show)

data Result a = Equal | NotEqual | Remains a deriving (Show, Eq)

cmp Empty Empty = Equal

cmp Empty t2    = NotEqual

cmp t1 Empty    = Remains t1

cmp t1@(Node v1 l1 r1) t2@(Node v2 l2 r2) 
          | v1 == v2  = case (cmp l1 l2) of
                        Equal -> (cmp r1 r2)
                        _     -> NotEqual

          | v1 < v2   = if l2 == Empty then NotEqual
                        else case (cmp t1 l2) of
                             Equal            -> NotEqual
                             NotEqual         -> NotEqual
                             Remains t1' -> cmp t1' (Node v2 Empty r2)

          | otherwise = if l1 == Empty then NotEqual
                        else case (cmp t2 l1) of
                             Equal            -> NotEqual
                             NotEqual         -> NotEqual
                             Remains t2' -> cmp (Node v1 Empty r1) t2'

instance (Ord a) => Eq (Tree a) where
   t1 == t2 = (cmp t1 t2) == Equal

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE IncoherentInstances #-} -- TypeEq requires incoherent instances

-- type-level boolean
data T = T
data F = F

-- type-level type equality
class TypeEq' () x y b => TypeEq x y b | x y -> b where
  type'eq :: x -> y -> b
  type'eq _ _ = undefined::b
class TypeEq' q x y b | q x y -> b
class TypeEq'' q x y b | q x y -> b
instance TypeEq' () x y b => TypeEq x y b
instance b ~ T => TypeEq' () x x b
instance TypeEq'' q x y b => TypeEq' q x y b
instance TypeEq'' () x y F

-- recursion binder and variable
data Rec n u = Rec n u deriving Show
data Var n = Var n deriving Show

-- folding
class RecFold m u r | m u -> r  where fold' :: m -> u -> r
instance RecFold m (Var n) (Var n) where fold' _ v = v 
instance (TypeEq m n b, RecFoldCont b m n a r) => RecFold m (Rec n a) r where -- fold if m = n
  fold' m (Rec n a) = fold'cont (type'eq m n) m n a

class RecFoldCont b m n a r | b m n a -> r where
   fold'cont :: b -> m -> n -> a -> r
instance RecFoldCont T m n a (Var m) where -- fold
   fold'cont b m n a = Var m
instance (RecFold m a r)
      => RecFoldCont F m n a (Rec n r) where -- do not fold
   fold'cont b m n a =  Rec n (fold' m a)


-- unfolding
class RecUnfold m r s u | m r s -> u where
  unfold' :: m -> r -> s -> u
instance (RecFold n s s', RecUnfold m a s' a') => RecUnfold m (Rec n a) s (Rec n a') where
  unfold' m (Rec n a) s = Rec n (unfold' m a (fold' n s))
instance (TypeEq m n b, RecUnfoldCont b m n s a) => RecUnfold m (Var n) s a where -- unfold if m = n
  unfold' m (Var n) s = unfoldCont (type'eq m n) m n s

class RecUnfoldCont b m n s a | b m n s -> a where
  unfoldCont :: b -> m -> n -> s -> a
instance RecUnfoldCont T m m s (Rec m s) where -- unfold
  unfoldCont _ m _ s = Rec m s
instance RecUnfoldCont F m n s (Var n) where -- do not unfold
  unfoldCont _ _ n _ = Var n

-- type level numerals
data Z = Z
data S n = S n
instance Show Z where show _ = "Z"
instance Show n => Show (S n) where show ~(S n) = "(S "++show n++")"

-- assign a natural number to each binder
class RecNumbering n r
instance (RecNumbering (S n) u1, m ~ n) => RecNumbering n (Rec m u1) where
instance RecNumbering n (Var m)

num :: RecNumbering (S Z) r => Rec Z r -> Rec Z r
num = id

rec :: (RecFold n u r, RecUnfold n r r u) => u -> Rec n r -- RecUnfold ensures that our fold/unfold is isomorphic
rec x = (\n -> Rec n (fold' n x)) undefined

unfold :: (RecFold m u r, RecUnfold m r r u) => Rec m r -> u
unfold (Rec m r) = unfold' m r r 

-- 再帰させたい型
data A x = A x deriving Show
data B x = B x deriving Show
data C x y = C x y deriving Show
unA (A x) = x; unB (B x) = x; unC1 (C x _) = x; unC2 (C _ y) = y

instance RecFold m x x' => RecFold m (A x) (A x') where
  fold' m (A x) = A (fold' m x)
instance RecFold m x x' => RecFold m (B x) (B x') where
  fold' m (B x) = B (fold' m x)
instance (RecFold m x x', RecFold m y y') => RecFold m (C x y) (C x' y') where
  fold' m (C x y) = C (fold' m x) (fold' m y)
instance RecUnfold m u s u' => RecUnfold m (A u) s (A u') where
  unfold' m (A u) s = A (unfold' m u s)
instance RecUnfold m u s u' => RecUnfold m (B u) s (B u') where
  unfold' m (B u) s = B (unfold' m u s)
instance (RecUnfold m u s u', RecUnfold m v s v') => RecUnfold m (C u v) s (C u' v') where
  unfold' m (C u v) s = C (unfold' m u s) (unfold' m v s)
instance RecNumbering n u => RecNumbering n (A u)
instance RecNumbering n u => RecNumbering n (B u)
instance (RecNumbering n u, RecNumbering n v) => RecNumbering n (C u v)



-- *Main> let x = rec (A y) ; y = rec (B (C x y)); _ = num x
-- *Main> :t x
-- x :: Rec Z (A (Rec (S Z) (B (C (Var Z) (Var (S Z))))))
-- *Main> x
-- Rec Z (A (Rec (S Z) (B (C (Var Z) (Var (S Z))))))
-- 
-- *Main> unfold x
-- A (Rec (S Z) (B (C (Rec Z (A (Var (S Z)))) (Var (S Z)))))
-- *Main> :t unfold x
-- unfold x
--   :: A (Rec (S Z) (B (C (Rec Z (A (Var (S Z)))) (Var (S Z)))))
-- 
-- *Main> unC1 $ unB $ unfold $ unA $ unfold x
-- Rec Z (A (Rec (S Z) (B (C (Var Z) (Var (S Z))))))
-- *Main> :t unC1 $ unB $ unfold $ unA $ unfold x
-- unC1 $ unB $ unfold $ unA $ unfold x
--   :: Rec Z (A (Rec (S Z) (B (C (Var Z) (Var (S Z))))))

#!/usr/bin/env runhaskell

import Char
import Data.List
import HSH
import Maybe
import Text.Feed.Import
import Text.Feed.Query
import Text.Regex.Posix

-- CONFIGURATION --
dlDir = "/path/to/download/dir/"
historyFile = "/path/to/download/history.log"

any_patterns = ["some.*thing", "something.*else", "etc"]
all_patterns = ["every.*thing"]
none_patterns = ["some.*boring.*thing"]

feed_url = "http://my/feed.rss"
                  
-- curl cli flags (see man curl)
curl_opts = ""

-- END CONFIGURATION --

curl = "curl -s " ++ curl_opts
fetchFeed = curl ++ "\"" ++ feed_url ++ "\""
fetchFiles = "(cd " ++ dlDir ++ " && xargs -r " ++ curl ++ " -O)"

withCurry f g           = curry $ f . uncurry g
matches patterns title  = map (\p -> title =~ p :: Bool) patterns
match_any               = any id `withCurry` matches
match_all               = all id `withCurry` matches 
match_none              = all not `withCurry` matches 

filters = [match_any any_patterns, match_all all_patterns, match_none none_patterns]

-- filter using a list of predicates
allPreds fs      = flip all fs . flip ($)

filterSubscriptions lines =
  case parseFeedString $ unlines lines of
       Just feed  -> map link $ doFilter $ mapMaybe titleAndLink (getFeedItems feed)
       Nothing    -> error "feed parse failed"
  where title (x, _) = x
        link (_,x) = x
        titleAndLink item = do title <- getItemTitle item
                               link  <- getItemLink item
                               return (title, link)
        doFilter          = filter (allPreds filters . map toLower . title)

checkHistory = "bash -c \"sort | diff <(sort " ++ historyFile ++ ") - | sed -n 's/^> //p' | tee -a " ++ historyFile ++ "\""

test = runIO $ "cat /tmp/feed.xml" -|- filterSubscriptions
main = runIO $ fetchFeed -|- "tee /tmp/feed.xml" -|- filterSubscriptions -|- checkHistory -|- fetchFiles

pam :: [a -> b] -> a -> [b]
pam f x = map g f
  where g h = h x