├── Zepto.hs ├── attoparsec-conduit.hs ├── attoparsec-example.hs ├── attoparsec-feeding.hs ├── boxed-vectors.hs ├── builder-example.hs ├── components.hs ├── conduit-atto.hs ├── conduit-server-stream-csv.hs ├── conduit-tcp-server.hs ├── dependently-typed-printf.idr ├── diff-list-vs-regular-list-weigh.hs ├── diff-list-vs-regular-list.hs ├── dynamically-sized-vector-in-idris.idr ├── finite-list.hs ├── hask-tok-2.hs ├── hask-tok.hs ├── hask-tok3.hs ├── hkd-examples.hs ├── holey-monoid.hs ├── http-client.hs ├── indexed-fields-for-db-validation-etc.hs ├── lazy-length.hs ├── liquid-haskell-dates.hs ├── money-pennies.hs ├── mutable-containers.hs ├── nonempty.hs ├── optparse.hs ├── origami.hs ├── proj.hs ├── rest-request.hs ├── rest-response.hs ├── resumable-parser.hs ├── simple-baysian-spam-filter.hs ├── st-array.hs ├── terminal-type.hs ├── type-inequality-operator.hs ├── unboxed-vectors.hs ├── use-of-ghc-api.hs ├── use-of-the-reflection-package.hs ├── warp.hs └── zeckendorf.hs /Zepto.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if __GLASGOW_HASKELL__ >= 702 3 | {-# LANGUAGE Trustworthy #-} -- Data.ByteString.Unsafe 4 | #endif 5 | {-# LANGUAGE BangPatterns #-} 6 | 7 | -- | 8 | -- Module : Data.Attoparsec.Zepto 9 | -- Copyright : Bryan O'Sullivan 2007-2015 10 | -- License : BSD3 11 | -- 12 | -- Maintainer : bos@serpentine.com 13 | -- Stability : experimental 14 | -- Portability : unknown 15 | -- 16 | -- A tiny, highly specialized combinator parser for 'B.ByteString' 17 | -- strings. 18 | -- 19 | -- While the main attoparsec module generally performs well, this 20 | -- module is particularly fast for simple non-recursive loops that 21 | -- should not normally result in failed parses. 22 | -- 23 | -- /Warning/: on more complex inputs involving recursion or failure, 24 | -- parsers based on this module may be as much as /ten times slower/ 25 | -- than regular attoparsec! You should /only/ use this module when you 26 | -- have benchmarks that prove that its use speeds your code up. 27 | module Zepto 28 | ( 29 | Parser 30 | , ZeptoT 31 | , parse 32 | , parseT 33 | , atEnd 34 | , string 35 | , take 36 | , takeWhile 37 | , gets 38 | ) where 39 | 40 | import Control.Applicative 41 | import Control.Monad (MonadPlus(..), ap) 42 | import qualified Control.Monad.Fail as Fail 43 | import Control.Monad.IO.Class (MonadIO(..)) 44 | import Control.Monad.Trans 45 | import Data.ByteString (ByteString) 46 | import qualified Data.ByteString as B 47 | import qualified Data.ByteString.Unsafe as B 48 | import Data.Functor.Identity (Identity(runIdentity)) 49 | import Data.Monoid as Mon (Monoid(..)) 50 | import Data.Semigroup (Semigroup(..)) 51 | import Data.Word (Word8) 52 | import Prelude hiding (take, takeWhile) 53 | 54 | newtype S = S { 55 | input :: ByteString 56 | } 57 | 58 | data Result a = Fail String 59 | | OK !a S 60 | 61 | -- | A simple parser. 62 | -- 63 | -- This monad is strict in its state, and the monadic bind operator 64 | -- ('>>=') evaluates each result to weak head normal form before 65 | -- passing it along. 66 | newtype ZeptoT m a = Parser { 67 | runParser :: S -> m (Result a) 68 | } 69 | 70 | type Parser a = ZeptoT Identity a 71 | 72 | instance MonadTrans ZeptoT where 73 | lift m = Parser (\s -> fmap (\a -> OK a s) m) 74 | {-# INLINE lift #-} 75 | 76 | instance Monad m => Functor (ZeptoT m) where 77 | fmap f m = Parser $ \s -> do 78 | result <- runParser m s 79 | case result of 80 | OK a s' -> return (OK (f a) s') 81 | Fail err -> return (Fail err) 82 | {-# INLINE fmap #-} 83 | 84 | instance MonadIO m => MonadIO (ZeptoT m) where 85 | liftIO act = Parser $ \s -> do 86 | result <- liftIO act 87 | return (OK result s) 88 | {-# INLINE liftIO #-} 89 | 90 | instance Monad m => Monad (ZeptoT m) where 91 | return = pure 92 | {-# INLINE return #-} 93 | 94 | m >>= k = Parser $ \(s) -> do 95 | result <- runParser m s 96 | case result of 97 | OK a s' -> runParser (k a) s' 98 | Fail err -> return (Fail err) 99 | {-# INLINE (>>=) #-} 100 | 101 | #if !(MIN_VERSION_base(4,13,0)) 102 | fail = Fail.fail 103 | {-# INLINE fail #-} 104 | #endif 105 | 106 | instance Monad m => Fail.MonadFail (ZeptoT m) where 107 | fail msg = Parser $ \_ -> return (Fail msg) 108 | {-# INLINE fail #-} 109 | 110 | instance Monad m => MonadPlus (ZeptoT m) where 111 | mzero = fail "mzero" 112 | {-# INLINE mzero #-} 113 | 114 | mplus a b = Parser $ \s -> do 115 | result <- runParser a s 116 | case result of 117 | ok@(OK _ _) -> return ok 118 | _ -> runParser b s 119 | {-# INLINE mplus #-} 120 | 121 | instance (Monad m) => Applicative (ZeptoT m) where 122 | pure a = Parser $ \s -> return (OK a s) 123 | {-# INLINE pure #-} 124 | (<*>) = ap 125 | {-# INLINE (<*>) #-} 126 | 127 | gets :: Monad m => (S -> a) -> ZeptoT m a 128 | gets f = Parser $ \s -> return (OK (f s) s) 129 | {-# INLINE gets #-} 130 | 131 | put :: Monad m => S -> ZeptoT m () 132 | put s = Parser $ \_ -> return (OK () s) 133 | {-# INLINE put #-} 134 | 135 | -- | Run a parser. 136 | parse :: Parser a -> ByteString -> Either String a 137 | parse p bs = case runIdentity (runParser p (S bs)) of 138 | (OK a _) -> Right a 139 | (Fail err) -> Left err 140 | {-# INLINE parse #-} 141 | 142 | -- | Run a parser on top of the given base monad. 143 | parseT :: Monad m => ZeptoT m a -> ByteString -> m (Either String a) 144 | parseT p bs = do 145 | result <- runParser p (S bs) 146 | case result of 147 | OK a _ -> return (Right a) 148 | Fail err -> return (Left err) 149 | {-# INLINE parseT #-} 150 | 151 | instance Monad m => Semigroup (ZeptoT m a) where 152 | (<>) = mplus 153 | {-# INLINE (<>) #-} 154 | 155 | instance Monad m => Mon.Monoid (ZeptoT m a) where 156 | mempty = fail "mempty" 157 | {-# INLINE mempty #-} 158 | mappend = (<>) 159 | {-# INLINE mappend #-} 160 | 161 | instance Monad m => Alternative (ZeptoT m) where 162 | empty = fail "empty" 163 | {-# INLINE empty #-} 164 | (<|>) = mplus 165 | {-# INLINE (<|>) #-} 166 | 167 | -- | Consume input while the predicate returns 'True'. 168 | takeWhile :: Monad m => (Word8 -> Bool) -> ZeptoT m ByteString 169 | takeWhile p = do 170 | (h,t) <- gets (B.span p . input) 171 | put (S t) 172 | return h 173 | {-# INLINE takeWhile #-} 174 | 175 | -- | Consume @n@ bytes of input. 176 | take :: Monad m => Int -> ZeptoT m ByteString 177 | take !n = do 178 | s <- gets input 179 | if B.length s >= n 180 | then put (S (B.unsafeDrop n s)) >> return (B.unsafeTake n s) 181 | else fail "insufficient input" 182 | {-# INLINE take #-} 183 | 184 | -- | Match a string exactly. 185 | string :: Monad m => ByteString -> ZeptoT m () 186 | string s = do 187 | i <- gets input 188 | if s `B.isPrefixOf` i 189 | then put (S (B.unsafeDrop (B.length s) i)) >> return () 190 | else fail "string" 191 | {-# INLINE string #-} 192 | 193 | -- | Indicate whether the end of the input has been reached. 194 | atEnd :: Monad m => ZeptoT m Bool 195 | atEnd = do 196 | i <- gets input 197 | return $! B.null i 198 | {-# INLINE atEnd #-} 199 | -------------------------------------------------------------------------------- /attoparsec-conduit.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack 2 | -- stack --resolver lts-12.12 script 3 | {-# LANGUAGE OverloadedStrings #-} 4 | import qualified Data.ByteString as S 5 | import qualified Data.Attoparsec.ByteString as P 6 | import Conduit 7 | import Data.Conduit.List 8 | import Data.Conduit.Attoparsec 9 | 10 | main = do 11 | result <- runConduit (sourceList chunks .| sinkParserEither myparser) 12 | case result of 13 | Left err -> print err 14 | Right val -> print val 15 | where 16 | chunks = [S.pack [2], S.pack [97], S.pack [98]] 17 | myparser = do 18 | len <- P.anyWord8 19 | bytes <- P.take (fromIntegral len) 20 | return bytes 21 | -------------------------------------------------------------------------------- /attoparsec-example.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack 2 | -- stack --resolver lts-12.12 script 3 | {-# LANGUAGE OverloadedStrings #-} 4 | import qualified Data.ByteString as S 5 | import qualified Data.Attoparsec.ByteString as P 6 | 7 | main = 8 | case P.parseOnly myparser (S.pack [2, 97, 98]) of 9 | Right result -> print result 10 | Left err -> putStrLn err 11 | where 12 | myparser = do 13 | len <- P.anyWord8 14 | bytes <- P.take (fromIntegral len) 15 | return bytes 16 | -------------------------------------------------------------------------------- /attoparsec-feeding.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack 2 | -- stack --resolver lts-12.12 script 3 | {-# LANGUAGE OverloadedStrings #-} 4 | import Control.Applicative 5 | import qualified Data.ByteString as S 6 | import qualified Data.Attoparsec.ByteString as P 7 | 8 | main = loop (P.parse myparser) (S.pack [1,3]) 9 | where 10 | loop eater input = 11 | do putStrLn ("Chunk " ++ show (S.unpack chunk)) 12 | case eater chunk of 13 | P.Done _ value -> print value 14 | P.Fail _ _ err -> putStrLn err 15 | P.Partial next -> do 16 | putStrLn "Waiting for more ..." 17 | loop next remaining 18 | where (chunk, remaining) = S.splitAt 1 input 19 | myparser = do 20 | len <- (P.word8 1 *> P.word8 2) <|> (P.word8 1 *> P.word8 3) 21 | return len 22 | -------------------------------------------------------------------------------- /boxed-vectors.hs: -------------------------------------------------------------------------------- 1 | -- This module demonstrates boxed vectors. That means they 2 | -- contain values which are thunks, aka values of kind *, aka 3 | -- values which may contain _|_. You can write any Haskell 4 | -- value in here. 5 | -- 6 | -- Optimizations: 7 | -- 8 | -- 1) Use unsafeFreeze to avoid copying. See its haddocks. 9 | 10 | -- 2) Use unsafeRead/unsafeWrite. These are, clearly, unsafe 11 | -- operations. Use your discretion. And write tests! Or better yet, 12 | -- use Liquid Haskell so that you have a proof of bounds checks. 13 | 14 | module Main where 15 | import Control.Monad.ST 16 | import qualified Data.Vector as V 17 | import qualified Data.Vector.Mutable as MV 18 | main :: IO () 19 | main = do 20 | -- Using the IO monad: 21 | vec <- 22 | do v <- MV.new 1 23 | MV.write v 0 (1 :: Int) 24 | V.freeze v 25 | print vec 26 | -- Using the ST monad: 27 | print 28 | (runST 29 | (do v <- MV.new 1 30 | MV.write v 0 (1 :: Int) 31 | V.freeze v)) 32 | 33 | {- 34 | Output: 35 | 36 | > main 37 | [1] 38 | [1] 39 | 40 | -} 41 | -------------------------------------------------------------------------------- /builder-example.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack 2 | -- stack --resolver lts-12.12 script 3 | {-# LANGUAGE OverloadedStrings #-} 4 | import System.IO 5 | import Data.Conduit 6 | import qualified Data.Conduit.List as CL 7 | import qualified Data.Conduit.Binary as CB 8 | import qualified Data.ByteString.Lazy as L 9 | import qualified Data.Conduit.ByteString.Builder as CB 10 | import qualified Data.ByteString.Lazy.Builder as L 11 | main = 12 | runConduitRes 13 | (CL.sourceList [L.word8 2 <> L.byteString "ab"] .| CB.builderToByteString .| 14 | CB.sinkHandle stdout) 15 | -------------------------------------------------------------------------------- /components.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE Rank2Types #-} 6 | import Control.Lens.TH 7 | import Data.These 8 | import Control.Lens 9 | import Data.Bifunctor 10 | import Data.Profunctor 11 | 12 | data Component state down up 13 | 14 | data Tree state down up where 15 | Slot 16 | :: Traversal' parentDown childDown 17 | -> Review parentUp childUp 18 | -> Traversal' parentState childState 19 | -> Component childState childDown childUp 20 | -> Tree parentState parentDown parentUp 21 | Mappend :: Tree state down up -> Tree state down up -> Tree state down up 22 | Ceiling :: (up -> Behavior down up) -> Tree state down up -> Tree state down up 23 | Floor :: (down -> Behavior down up) -> Tree state down up -> Tree state down up 24 | 25 | data Behavior down up 26 | = SendUp [up] 27 | | SendDown [down] 28 | | SendUpAndDown [up] [down] 29 | | SendNothing 30 | 31 | data ButtonUp 32 | = Click 33 | | DblClick 34 | 35 | data ButtonDown 36 | = SetTitle String 37 | | SetDisabled Bool 38 | 39 | data Button = 40 | Button 41 | { buttonTitle :: String 42 | } 43 | 44 | button :: String -> Component Button ButtonDown ButtonUp 45 | button = undefined 46 | 47 | data TextDown = 48 | SetText String 49 | 50 | data Text = 51 | Text 52 | { textText :: String 53 | } 54 | 55 | text :: Component Text TextDown () 56 | text = undefined 57 | 58 | data PageDown 59 | = ButtonDown ButtonDown 60 | | TextDown TextDown 61 | | Reset 62 | 63 | $(makePrisms ''PageDown) 64 | 65 | data PageUp 66 | = ButtonUp ButtonUp 67 | | TextUp () 68 | 69 | $(makePrisms ''PageUp) 70 | 71 | data Page = 72 | Page 73 | { _pageButton :: Button 74 | , _pageText :: Text 75 | } 76 | 77 | $(makeLenses ''Page) 78 | 79 | page :: Tree Page PageDown PageUp 80 | page = 81 | Ceiling 82 | (\case 83 | ButtonUp Click -> 84 | SendDown 85 | [ ButtonDown (SetTitle "Click me again!") 86 | , TextDown (SetText "Clicked!") 87 | ] 88 | _ -> SendNothing) 89 | (Mappend 90 | (Slot _ButtonDown _ButtonUp pageButton (button "Click me!")) 91 | (Floor 92 | (\case 93 | Reset -> SendDown [TextDown (SetText "Resetted.")]) 94 | (Slot _TextDown _TextUp pageText text))) 95 | -------------------------------------------------------------------------------- /conduit-atto.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack 2 | -- stack --resolver lts-12.12 script 3 | {-# LANGUAGE OverloadedStrings #-} 4 | import Data.Conduit.Network 5 | import qualified Data.ByteString as S 6 | import qualified Data.Attoparsec.ByteString as P 7 | import Conduit 8 | import Data.Conduit.Attoparsec 9 | 10 | main = 11 | runTCPServer 12 | (serverSettings 2019 "*") 13 | (\app -> do 14 | putStrLn "Someone connected!" 15 | runConduit (appSource app .| conduitParserEither parser .| handlerSink app)) 16 | where 17 | 18 | 19 | handlerSink output = do 20 | mnext <- await 21 | case mnext of 22 | Nothing -> liftIO (putStrLn "Connection closed.") 23 | Just eithermessage -> 24 | case eithermessage of 25 | Left err -> liftIO (print err) 26 | Right (position, message) -> do 27 | liftIO (print message) 28 | liftIO (runConduit (yield "Thanks!\n" .| appSink app)) 29 | handlerSink app 30 | 31 | parser = do 32 | len <- P.anyWord8 33 | bytes <- P.take (fromIntegral len) 34 | return bytes 35 | -------------------------------------------------------------------------------- /conduit-server-stream-csv.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | import qualified Data.Map.Strict as M 4 | import Data.Map.Strict (Map) 5 | import Data.ByteString (ByteString) 6 | import qualified Data.Conduit.List as CL 7 | import Data.CSV.Conduit 8 | import qualified Data.Conduit.Binary as CB 9 | import Data.Conduit.Network 10 | import qualified Data.Attoparsec.ByteString as P 11 | import Conduit 12 | import Data.Conduit.Attoparsec 13 | 14 | main = 15 | runTCPServer 16 | (serverSettings 2019 "*") 17 | (\app -> do 18 | putStrLn "Someone connected!" 19 | runConduit 20 | (appSource app .| conduitParserEither parser .| handlerSink app)) 21 | where 22 | handlerSink app = do 23 | mnext <- await 24 | case mnext of 25 | Nothing -> liftIO (putStrLn "Connection closed.") 26 | Just eithermessage -> 27 | case eithermessage of 28 | Left err -> liftIO (print err) 29 | Right (position, lineCount) -> do 30 | liftIO (print lineCount) 31 | liftIO 32 | (runConduitRes 33 | (CB.sourceFile "fake-db.csv" .| intoCSV defCSVSettings .| 34 | CL.mapMaybe 35 | (M.lookup "Name" :: Map ByteString ByteString -> Maybe ByteString) .| 36 | CL.map (<> "\n") .| 37 | CL.isolate lineCount .| 38 | appSink app)) 39 | handlerSink app 40 | parser = do 41 | len <- P.anyWord8 42 | return (fromIntegral len * 1000) 43 | -------------------------------------------------------------------------------- /conduit-tcp-server.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack 2 | -- stack --resolver lts-12.12 script 3 | {-# LANGUAGE OverloadedStrings #-} 4 | import Data.Conduit.Network 5 | import Conduit 6 | 7 | main = 8 | runTCPServer 9 | (serverSettings 2019 "*") 10 | (\app -> do 11 | putStrLn "Someone connected!" 12 | let loop = do 13 | oneMessageMaybe <- 14 | runConduit (appSource app .| mapMC print .| await) 15 | case oneMessageMaybe of 16 | Nothing -> putStrLn "No more messages in upstream, done!" 17 | Just message -> do 18 | print message 19 | loop 20 | loop) 21 | where 22 | myparser = do 23 | len <- P.anyWord8 24 | bytes <- P.take (fromIntegral len) 25 | return bytes 26 | -------------------------------------------------------------------------------- /dependently-typed-printf.idr: -------------------------------------------------------------------------------- 1 | module Printf 2 | 3 | %default total 4 | 5 | -- Formatting AST. 6 | data Format 7 | = FInt Format 8 | | FString Format 9 | | FOther Char Format 10 | | FEnd 11 | 12 | -- Parse the format string (list of characters) into an AST. 13 | -- Example: "%d,%s" → (FInt (FOther ',' (FString FEnd))) 14 | format : List Char -> Format 15 | format ('%' :: 'd' :: cs ) = FInt ( format cs ) 16 | format ('%' :: 's' :: cs ) = FString ( format cs ) 17 | format ( c :: cs ) = FOther c ( format cs ) 18 | format [] = FEnd 19 | 20 | -- Convenience function to unpack a string into a list of chars, then 21 | -- run format on it. 22 | formatString : String -> Format 23 | formatString s = format ( unpack s ) 24 | 25 | -- Convert a format AST into a type. 26 | -- Example: FInt (FOther ',' (FString FEnd)) → Int -> String -> String 27 | interpFormat : Format -> Type 28 | interpFormat (FInt f) = Int -> interpFormat f 29 | interpFormat (FString f) = String -> interpFormat f 30 | interpFormat (FOther _ f) = interpFormat f 31 | interpFormat FEnd = String 32 | 33 | -- Dependently-typed part: turn a formatting AST into a well-typed 34 | -- function accepting n arguments. 35 | -- Example: 36 | -- toFunction (FInt (FString FEnd)) 37 | -- → 38 | -- \a i s => a ++ (show i) ++ s 39 | toFunction : (fmt : Format) -> String -> interpFormat fmt 40 | toFunction ( FInt f ) a = \i => toFunction f ( a ++ show i ) 41 | toFunction ( FString f ) a = \s => toFunction f ( a ++ s ) 42 | toFunction ( FOther c f ) a = toFunction f ( a ++ singleton c ) 43 | toFunction FEnd a = a 44 | 45 | -- Dependently-typed part: turn a formatting string into a well-typed 46 | -- function accepting n arguments. 47 | -- Example: printf "%d%s" → \i s => (show i) ++ s 48 | printf : (s : String) -> interpFormat ( formatString s ) 49 | printf s = toFunction ( formatString s ) "" 50 | -------------------------------------------------------------------------------- /diff-list-vs-regular-list-weigh.hs: -------------------------------------------------------------------------------- 1 | -- | Demonstration of dlist vs regular list+reverse memory use. 2 | -- 3 | -- chris@precision:~/Work/chrisdone/sandbox$ ./diff-list-vs-regular-list-weigh 4 | 5 | -- Case Allocated GCs 6 | -- list 1000 64,000 0 7 | -- list 10000 640,000 0 8 | -- list 100000 6,400,000 6 9 | -- dlist 1000 64,000 0 10 | -- dlist 10000 640,000 0 11 | -- dlist 100000 6,400,000 6 12 | 13 | {-# LANGUAGE BangPatterns #-} 14 | {-# OPTIONS_GHC -Wall #-} 15 | import Weigh 16 | 17 | main :: IO () 18 | main = 19 | mainWith 20 | (sequence_ 21 | (concat 22 | [ [ func 23 | ("list " ++ show i) 24 | (\n0 -> 25 | reverse 26 | (let loop :: Int -> [Int] -> [Int] 27 | loop 0 acc = acc 28 | loop n acc = loop (n - 1) (n : acc) 29 | in loop n0 [])) 30 | i 31 | | i <- iters' 32 | ] 33 | , [ func 34 | ("dlist " ++ show i) 35 | (\n0 -> 36 | let loop :: Int -> ([Int] -> [Int]) -> [Int] 37 | loop 0 f = f [] 38 | loop n f = loop (n - 1) (f . (n :)) 39 | in loop n0 id) 40 | i 41 | | i <- iters' 42 | ] 43 | ])) 44 | where 45 | iters' = [1000, 10000, 100000] 46 | -------------------------------------------------------------------------------- /diff-list-vs-regular-list.hs: -------------------------------------------------------------------------------- 1 | -- | Demonstration that dlists are not faster than cons and then reverse. 2 | 3 | -- benchmarking deepseq/list/100000 4 | -- time 5.194 ms (5.129 ms .. 5.263 ms) 5 | -- 0.999 R² (0.999 R² .. 1.000 R²) 6 | -- mean 5.191 ms (5.169 ms .. 5.227 ms) 7 | -- std dev 86.42 μs (57.85 μs .. 113.8 μs) 8 | 9 | -- benchmarking deepseq/dlist/100000 10 | -- time 5.314 ms (5.257 ms .. 5.398 ms) 11 | -- 0.999 R² (0.997 R² .. 1.000 R²) 12 | -- mean 5.298 ms (5.265 ms .. 5.340 ms) 13 | -- std dev 114.7 μs (79.13 μs .. 185.2 μs) 14 | 15 | -- benchmarking head/list/100000 16 | -- time 4.914 ms (4.845 ms .. 4.980 ms) 17 | -- 0.999 R² (0.999 R² .. 1.000 R²) 18 | -- mean 4.943 ms (4.923 ms .. 4.972 ms) 19 | -- std dev 71.90 μs (56.73 μs .. 100.1 μs) 20 | 21 | -- benchmarking head/dlist/100000 22 | -- time 5.040 ms (4.950 ms .. 5.153 ms) 23 | -- 0.999 R² (0.998 R² .. 1.000 R²) 24 | -- mean 4.980 ms (4.950 ms .. 5.011 ms) 25 | -- std dev 93.72 μs (62.24 μs .. 143.6 μs) 26 | 27 | {-# LANGUAGE BangPatterns #-} 28 | {-# OPTIONS_GHC -Wall #-} 29 | import Criterion 30 | import Criterion.Main 31 | 32 | main :: IO () 33 | main = 34 | defaultMain 35 | [ bgroup 36 | "deepseq" 37 | [ bgroup 38 | "list" 39 | [ bench 40 | (show iters) 41 | (nf 42 | (\n0 -> 43 | reverse 44 | (let loop :: Int -> [Int] -> [Int] 45 | loop 0 acc = acc 46 | loop n acc = loop (n - 1) (n : acc) 47 | in loop n0 [])) 48 | iters) 49 | ] 50 | , bgroup 51 | "dlist" 52 | [ bench 53 | (show iters) 54 | (nf 55 | (\n0 -> 56 | let loop :: Int -> ([Int] -> [Int]) -> [Int] 57 | loop 0 f = f [] 58 | loop n f = loop (n - 1) (f . (n :)) 59 | in loop n0 id) 60 | iters) 61 | ] 62 | ] 63 | , bgroup 64 | "head" 65 | [ bgroup 66 | "list" 67 | [ bench 68 | (show iters) 69 | (nf 70 | (\n0 -> 71 | head (reverse 72 | (let loop :: Int -> [Int] -> [Int] 73 | loop 0 acc = acc 74 | loop n acc = loop (n - 1) (n : acc) 75 | in loop n0 []))) 76 | iters) 77 | ] 78 | , bgroup 79 | "dlist" 80 | [ bench 81 | (show iters) 82 | (nf 83 | (\n0 -> 84 | let loop :: Int -> ([Int] -> [Int]) -> [Int] 85 | loop 0 f = f [] 86 | loop n f = loop (n - 1) (f . (n :)) 87 | in head (loop n0 id)) 88 | iters) 89 | ] 90 | ] 91 | ] 92 | where 93 | iters :: Int 94 | iters = 100000 95 | -------------------------------------------------------------------------------- /dynamically-sized-vector-in-idris.idr: -------------------------------------------------------------------------------- 1 | -- This language is Idris. 2 | -- 3 | -- This program does the following steps: 4 | -- 5 | -- 1) Accept a line of input, parses it as an integer. 6 | -- 2) Creates a vector of that size (populated with numbers up to n). 7 | -- 8 | -- In a loop: 9 | -- 10 | -- 1) Accepts an integer, attempts to cast it to a "Fin n" (as in 11 | -- finite) number, which is within the bounds of the vector. 12 | -- 2) Looks-up the value of the vector at index n and prints it. 13 | 14 | main : IO () 15 | main = do 16 | putStrLn "How big should the vector be?" 17 | sizeString <- getLine 18 | case parseInt sizeString of 19 | Nothing => 20 | putStrLn "Couldn't parse an integer." 21 | Just int => 22 | do let size = fromInteger (cast int) 23 | let myvector = the (Vect size Integer) -- This is the magic part. 24 | (enumVector size) 25 | print size 26 | print myvector 27 | forever 28 | (do putStrLn "Enter an index to look at: " 29 | indexString <- getLine 30 | case parseInt indexString of 31 | Nothing => putStrLn "Couldn't parse an integer." 32 | Just int => 33 | case integerToFin (the Integer (cast int)) size of 34 | Nothing => putStrLn "Couldn't convert to number within bounds." 35 | Just idx => 36 | do putStrLn "The value is:" 37 | print (index idx myvector)) -- This line cannot crash. 38 | 39 | -- Things that Idris doesn't have out of the box: 40 | 41 | charToInt : Char -> Maybe Int 42 | charToInt c = let i = cast {to=Int} c in 43 | let zero = cast {to=Int} '0' in 44 | let nine = cast {to=Int} '9' in 45 | if i < zero || i > nine 46 | then Nothing 47 | else Just (i - zero) 48 | 49 | total 50 | parse' : Int -> List Int -> Maybe Int 51 | parse' _ [] = Nothing 52 | parse' acc [d] = Just (10 * acc + d) 53 | parse' acc (d::ds) = parse' (10 * acc + d) ds 54 | 55 | 56 | total parseInt : String -> Maybe Int 57 | parseInt str = (sequence (map charToInt (takeWhile isDigit (unpack str)))) >>= parse' 0 58 | 59 | forever : IO () -> IO () 60 | forever m = m >>= \_ => forever m 61 | 62 | enumVector : (n : Nat) -> Vect n Integer 63 | enumVector x = reverse (go x) where 64 | go Z = [] 65 | go (S n) = [toIntegerNat n] ++ go n 66 | -------------------------------------------------------------------------------- /finite-list.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE DeriveTraversable #-} 5 | {-# LANGUAGE DeriveFoldable #-} 6 | {-# LANGUAGE DeriveFunctor #-} 7 | 8 | -- | Lists that are of finite length. 9 | 10 | module Data.List.Finite 11 | ( FiniteList(Empty, (:%)) 12 | , maxed 13 | , cons 14 | , empty 15 | ) where 16 | 17 | -- | A list of finite length. 18 | data FiniteList a = 19 | FiniteList 20 | { finiteListMaxLength :: !Int 21 | , finiteList :: ![a] 22 | } 23 | deriving (Functor, Foldable, Traversable) 24 | 25 | -- | Make a finite list. 26 | empty :: Int -> FiniteList a 27 | empty size = 28 | FiniteList {finiteListMaxLength = size, finiteListLength = 0, finiteList = []} 29 | 30 | -- | Is the list maxed out? 31 | maxed :: FiniteList a -> Bool 32 | maxed (FiniteList {finiteListMaxLength, finiteListLength}) = 33 | finiteListLength == finiteListMaxLength 34 | 35 | -- | Cons onto the list. Ignores if we reached the max already. 36 | cons :: a -> FiniteList a -> FiniteList a 37 | cons a list = 38 | if maxed list 39 | then list 40 | else list 41 | { finiteListLength = finiteListLength list + 1 42 | , finiteList = a : finiteList list 43 | } 44 | 45 | -- | Uncons from the list. 46 | uncons :: FiniteList a -> Maybe (a, FiniteList a) 47 | uncons list = 48 | case finiteList list of 49 | (x:xs) -> 50 | let !len = finiteListLength list - 1 51 | in Just (x, list {finiteList = xs, finiteListLength = len}) 52 | _ -> Nothing 53 | 54 | -- | A bidirectional pattern synonym matching an empty sequence. 55 | pattern Empty :: Int -> FiniteList a 56 | pattern Empty a = 57 | FiniteList {finiteListMaxLength = a, finiteListLength = 0, finiteList = []} 58 | 59 | -- | A bidirectional pattern synonym viewing the front of a finite list. 60 | pattern (:%) :: a -> FiniteList a -> FiniteList a 61 | pattern x :% xs <- (uncons -> Just (x, xs)) 62 | -------------------------------------------------------------------------------- /hask-tok-2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | 4 | import Control.Monad 5 | import Data.ByteString (ByteString) 6 | import qualified Data.ByteString as S 7 | import Data.Word 8 | 9 | data S = 10 | S 11 | { byteString :: {-# UNPACK #-}!ByteString 12 | , position :: !Int 13 | , line :: !Int 14 | , column :: !Int 15 | } 16 | deriving (Show, Eq) 17 | newtype Lex a = Lex { runLex :: forall r. S -> (a, S) } 18 | instance Functor Lex where fmap = liftM 19 | instance Applicative Lex where (<*>) = ap; pure = return 20 | instance Monad Lex where 21 | return a = Lex (\s -> (a, s)) 22 | m >>= f = 23 | Lex 24 | (\s -> 25 | let (a, !s') = runLex m s 26 | in runLex (f a) s') 27 | 28 | {- 29 | 30 | Exercise: 31 | 32 | 1. Consume input, keeping the line, column and positions up to date. 33 | 2. Do this in a way that is fast. 34 | 35 | Consider reparsec with ByteString 36 | 37 | plus a strict StateT monad? 38 | 39 | Or consider Zepto, which already exists and is a transformer: 40 | http://hackage.haskell.org/package/attoparsec-0.13.2.3/docs/Data-Attoparsec-Zepto.html 41 | 42 | -} 43 | 44 | takeWhile :: (Word8 -> Bool) -> Lex ByteString 45 | takeWhile p = undefined 46 | -------------------------------------------------------------------------------- /hask-tok.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | import Control.Monad 4 | import Data.ByteString (ByteString) 5 | import qualified Data.ByteString as S 6 | import Data.Word 7 | 8 | data S = 9 | S 10 | { byteString :: {-# UNPACK #-}!ByteString 11 | , position :: !Int 12 | , line :: !Int 13 | , column :: !Int 14 | } 15 | deriving (Show, Eq) 16 | newtype Lex a = Lex { runLex :: forall r. S -> (S -> a -> r) -> r } 17 | instance Functor Lex where fmap = liftM 18 | instance Applicative Lex where (<*>) = ap; pure = return 19 | instance Monad Lex where 20 | return a = Lex (\s k -> k s a) 21 | m >>= f = Lex (\s k -> runLex m s (\s' a -> runLex (f a) s' k)) 22 | 23 | {- 24 | 25 | Exercise: 26 | 27 | 1. Consume input, keeping the line, column and positions up to date. 28 | 2. Do this in a way that is fast. 29 | 3. Is the continuation style faster than merely returning a new S? Likely not? 30 | 31 | -} 32 | -------------------------------------------------------------------------------- /hask-tok3.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# LANGUAGE NamedFieldPuns #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | 7 | module Main (main) where 8 | 9 | import Control.Applicative 10 | import Control.DeepSeq 11 | import Control.Exception 12 | import Control.Monad.State.Strict 13 | import Data.ByteString (ByteString) 14 | import qualified Data.ByteString as S 15 | import qualified Data.ByteString.Char8 as S8 16 | import Data.Functor.Identity 17 | import Data.Maybe 18 | import Data.Word 19 | import GHC.Generics 20 | import Prelude hiding (dropWhile) 21 | import System.Environment 22 | import Zepto 23 | 24 | data Point = 25 | Point 26 | { line :: !Int 27 | , column :: !Int 28 | , indentation :: !Int 29 | } 30 | deriving (Show, Eq, Generic) 31 | instance NFData Point 32 | newtype P m a = P (ZeptoT (StateT Point m) a) 33 | deriving (Functor, Applicative, Monad, Alternative, MonadIO) 34 | 35 | instance MonadTrans P where 36 | lift m = P (lift (lift m)) 37 | {-# INLINE lift #-} 38 | 39 | data Token = 40 | Token 41 | { byteString :: {-# UNPACK #-}!ByteString 42 | , start :: {-# UNPACK #-}!Point 43 | , end :: {-# UNPACK #-}!Point 44 | } deriving (Show, Generic) 45 | instance NFData Token 46 | takeToken :: Monad m => (Word8 -> Bool) -> P m Token 47 | takeToken p = do 48 | start@(Point {line}) <- P (lift get) 49 | byteString <- P (Zepto.takeWhile p) 50 | let !newlines = S8.count '\n' byteString 51 | !lastLine = 52 | if newlines == 0 53 | then byteString 54 | else fromMaybe 55 | byteString 56 | (fmap 57 | (flip S.drop byteString . (+ 1)) 58 | (S8.elemIndexEnd '\n' byteString)) 59 | !indentation = S.length (S.takeWhile (== 32) lastLine) 60 | !column = S.length lastLine 61 | !end = start {line = line + newlines, column, indentation} 62 | P (lift (put end)) 63 | pure (Token {start, end, byteString}) 64 | {-# INLINE takeToken #-} 65 | 66 | dropWhile :: Monad m => (Word8 -> Bool) -> P m () 67 | dropWhile p = void (P (Zepto.takeWhile p)) 68 | {-# INLINE dropWhile #-} 69 | 70 | run :: Monad m => P m a -> ByteString -> m (Either String a) 71 | run (P m) i = 72 | evalStateT (parseT m i) (Point {line = 1, column = 1, indentation = 0}) 73 | {-# INLINE run #-} 74 | 75 | simple :: P IO () 76 | simple = do 77 | word *> spaces 78 | end <- P atEnd 79 | unless end simple 80 | 81 | simple_ :: Monad m => P m () 82 | simple_ = do 83 | (_, end)<- couple 84 | unless end simple_ 85 | 86 | simple_count :: P (State Int) () 87 | simple_count = do 88 | (Token { start = Point {line, column, indentation} 89 | , end = Point { line = line1 90 | , column = column2 91 | , indentation = indentation2 92 | } 93 | }, end) <- couple 94 | lift 95 | (modify 96 | (+ (line + column + indentation + line1 + column2 +indentation2 97 | ))) 98 | unless end simple_count 99 | 100 | 101 | couple :: Monad m => P m (Token, Bool) 102 | couple = do 103 | token<- word' <* spaces 104 | end <- P atEnd 105 | pure (token, end) 106 | {-# INLINE couple #-} 107 | 108 | word :: P IO () 109 | word = do 110 | token <- (takeToken (not . isSpace8)) 111 | liftIO (print token) 112 | 113 | word' :: Monad m => P m Token 114 | word' = do 115 | !w <- takeToken (not . isSpace8) 116 | pure w 117 | 118 | spaces :: Monad m => P m () 119 | spaces = dropWhile isSpace8 120 | {-# INLINE spaces #-} 121 | 122 | isSpace8 :: (Eq a, Num a) => a -> Bool 123 | isSpace8 c = c==13 || c==32 || c==10 124 | 125 | main :: IO () 126 | main = do 127 | fp:mode:_ <- getArgs 128 | case mode of 129 | "print" -> do 130 | S.readFile fp >>= void . run simple 131 | "silent" -> do 132 | void (S.readFile fp >>= evaluate . runIdentity . run simple_) 133 | "count" -> do 134 | void (S.readFile fp >>= print . flip execState 0 . run simple_count) 135 | _ -> pure () 136 | 137 | -- With only evaluate 138 | 139 | -- 6,655,456 bytes allocated in the heap 140 | -- 11,184 bytes copied during GC 141 | -- 46,720 bytes maximum residency (1 sample(s)) 142 | -- 31,104 bytes maximum slop 143 | -- 9 MB total memory in use (0 MB lost due to fragmentation) 144 | 145 | -- With simple_ 146 | 147 | -- 6,655,592 bytes allocated in the heap 148 | -- 11,184 bytes copied during GC 149 | -- 46,720 bytes maximum residency (1 sample(s)) 150 | -- 31,104 bytes maximum slop 151 | -- 9 MB total memory in use (0 MB lost due to fragmentation) 152 | 153 | -- Tot time (elapsed) Avg pause Max pause 154 | -- Gen 0 1 colls, 0 par 0.000s 0.000s 0.0000s 0.0000s 155 | -- Gen 1 1 colls, 0 par 0.000s 0.000s 0.0001s 0.0001s 156 | 157 | -- INIT time 0.000s ( 0.000s elapsed) 158 | -- MUT time 0.027s ( 0.030s elapsed) 159 | -- GC time 0.000s ( 0.000s elapsed) 160 | -- EXIT time 0.000s ( 0.000s elapsed) 161 | -- Total time 0.027s ( 0.031s elapsed) 162 | 163 | -- %GC time 0.3% (0.3% elapsed) 164 | 165 | -- Alloc rate 250,210,225 bytes per MUT second 166 | 167 | -- Productivity 99.4% of total user, 99.5% of total elapsed 168 | -------------------------------------------------------------------------------- /hkd-examples.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, FlexibleInstances, StandaloneDeriving, TypeFamilies #-} 2 | import Control.Monad.Trans 3 | import Control.Monad.State.Strict 4 | import Data.Data 5 | import Data.Functor.Identity 6 | import Data.Maybe 7 | type family HKD f a where 8 | HKD Identity a = a 9 | HKD f a = f a 10 | 11 | data Wibble f = Wibble { foo :: HKD f Int , bar :: HKD f Bool} deriving (Typeable) 12 | deriving instance Data (Wibble Maybe) 13 | deriving instance Data (Wibble Identity) 14 | deriving instance Show (Wibble Identity) 15 | 16 | -- | Produce all missing fields that are Nothing. 17 | missingFields :: Data (t Maybe) => t Maybe -> [String] 18 | missingFields v = 19 | map 20 | fst 21 | (filter 22 | ((== toConstr (Nothing :: Maybe ())) . snd) 23 | (zip fields (gmapQ toConstr v))) 24 | where 25 | fields = constrFields (toConstr v) 26 | 27 | runMaybe :: (Data (t Identity), Data (t Maybe)) => t Maybe -> Maybe (t Identity) 28 | runMaybe tMaybe = 29 | evalStateT 30 | (fromConstrM 31 | (do i <- get 32 | modify (+ 1) 33 | case gmapQi i cast tMaybe of 34 | Nothing -> lift Nothing 35 | Just v -> lift v) 36 | (toConstr tMaybe)) 37 | 0 38 | -------------------------------------------------------------------------------- /holey-monoid.hs: -------------------------------------------------------------------------------- 1 | -- | Monoids with holes. The 'HoleyMonoid' allows building monoidal values of which certain components are to be filled in later. For example: 2 | -- 3 | -- > > let holey :: (Show a, Show b) => HoleyMonoid String r (a -> b -> r) 4 | -- > holey = now "x = " . later show . now ", y = " . later show 5 | -- > 6 | -- > > run holey 3 5 7 | -- > "x = 3, y = 5" 8 | -- 9 | -- This module is intended to be imported in qualified fashion, e.g. 10 | -- 11 | -- > import qualified Data.HoleyMonoid as HM 12 | 13 | import Prelude hiding (id, (.), map) 14 | import Control.Applicative 15 | import Control.Category 16 | import Data.Monoid 17 | 18 | -- | The type of a monoid with holes. The underlying monoid is represented by 19 | -- type parameter @m@. The @r@ is the result type and stays polymorphic until the 20 | -- very last moment when 'run' is called. The last argument @a@ is always a 21 | -- function with zero or more arguments, finally resulting in @r@. Ordering the 22 | -- arguments in this order allows holey monoids to be composed using `.`, stacking the 23 | -- expected arguments. Note that the `Monoid` constraint is only used in the 24 | -- identity 'HoleyMonoid' and in composing two 'HoleyMonoid's. 25 | newtype HoleyMonoid m r a = HoleyMonoid { runHM :: (m -> r) -> a } 26 | 27 | instance Monoid m => Category (HoleyMonoid m) where 28 | id = now mempty 29 | f . g = f `bind` \a -> g `bind` \b -> now (a `mappend` b) 30 | 31 | instance Functor (HoleyMonoid m r) where 32 | fmap f (HoleyMonoid g) = HoleyMonoid (f . g) 33 | 34 | instance Applicative (HoleyMonoid m r) where 35 | pure x = HoleyMonoid (pure x) 36 | HoleyMonoid f <*> HoleyMonoid g = HoleyMonoid (f <*> g) 37 | 38 | instance Monad (HoleyMonoid m r) where 39 | return x = HoleyMonoid (return x) 40 | HoleyMonoid f >>= g = HoleyMonoid (f >>= \x -> runHM (g x)) 41 | 42 | -- | Insert a constant monoidal value. 43 | now :: m -> HoleyMonoid m r r 44 | now a = HoleyMonoid ($ a) 45 | 46 | -- | Insert a monoidal value that is not specified until the computation is 47 | -- 'run'. The argument that is expected later is converted to the monoid type 48 | -- using the given conversion function. 49 | later :: (a -> m) -> HoleyMonoid m r (a -> r) 50 | later f = HoleyMonoid (. f) 51 | 52 | -- | Monadic indexed bind on the underlying 'Monoid' types. 53 | bind :: HoleyMonoid m b c -> (m -> HoleyMonoid n a b) -> HoleyMonoid n a c 54 | m `bind` f = HoleyMonoid $ \k -> runHM m (\a -> runHM (f a) k) 55 | 56 | -- | Map between underlying 'Monoid' types. 57 | map :: (m -> n) -> HoleyMonoid m r a -> HoleyMonoid n r a 58 | map g m = HoleyMonoid (\k -> runHM m (k . g)) 59 | 60 | -- | Run the computation, resulting in a function that still expects some 61 | -- arguments. The number of arguments that is still expected will be equal to 62 | -- the number of 'later's the computation is built of. 63 | run :: HoleyMonoid m m a -> a 64 | run m = runHM m id 65 | -------------------------------------------------------------------------------- /http-client.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack 2 | -- stack --resolver lts-12.12 script 3 | 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | import Network.HTTP.Simple 7 | import qualified Data.ByteString.Char8 as B8 8 | 9 | main :: IO () 10 | main = do 11 | response <- httpBS "http://example.com" 12 | B8.putStrLn (getResponseBody response) 13 | -------------------------------------------------------------------------------- /indexed-fields-for-db-validation-etc.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE DeriveGeneric #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE FlexibleInstances #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | 14 | -- | Indexed fields, for DB DSLs, validation DSLs and regular 15 | -- usage. Minimal type magic needed. Just a regular old type family. 16 | 17 | import Control.Monad.State 18 | import Control.Monad.Trans.Reader 19 | import Data.Functor.Identity 20 | import Data.List 21 | import Data.Map.Strict (Map) 22 | import qualified Data.Map.Strict as M 23 | import Data.Validation 24 | import GHC.Generics (Generic) 25 | import Text.Read 26 | 27 | -------------------------------------------------------------------------------- 28 | -- A class for indexed types 29 | 30 | -- We begin with a trivial class called indexed with an associated 31 | -- type function Index. 32 | class Indexed i a where 33 | type Index i (a :: *) 34 | 35 | -------------------------------------------------------------------------------- 36 | -- Making values from Haskell 37 | 38 | instance Indexed Identity a where 39 | type Index Identity a = a 40 | 41 | identityArticle :: Article Identity 42 | identityArticle = 43 | Article {articleTitle = "Some article", articleId = ArticleId 123} 44 | -- Note the undecorated field value. Sweet! 45 | 46 | reverseTitle :: Article Identity -> String 47 | reverseTitle (Article{articleTitle=title}) = title 48 | 49 | -------------------------------------------------------------------------------- 50 | -- Optional fields (a simple example) 51 | 52 | instance Indexed Maybe a where 53 | type Index Maybe a = Maybe a 54 | 55 | optionalArticle :: Article Maybe 56 | optionalArticle = 57 | Article {articleTitle = Nothing, articleId = Just (ArticleId 1)} 58 | 59 | -------------------------------------------------------------------------------- 60 | -- Consuming values from forms 61 | 62 | -- | Imagine replacing this with an Applicative formlet. 63 | newtype Formlet a = 64 | Formlet (ReaderT (Map String String) (Validation [String]) a) 65 | deriving (Functor, Applicative) 66 | 67 | field :: String -> (String -> Either String a) -> Formlet a 68 | field name parser = 69 | Formlet 70 | (ReaderT 71 | (\fields -> 72 | case M.lookup name fields of 73 | Nothing -> Failure ["Missing field"] 74 | Just str -> 75 | case parser str of 76 | Left e -> Failure [e] 77 | Right v -> Success v)) 78 | 79 | instance Indexed Formlet a where 80 | type Index Formlet a = Formlet a 81 | 82 | -- Now we don't have to care about order! This is an alternative to 83 | -- applicative-do + recordwildcards. 84 | validateArticle :: Article Formlet 85 | validateArticle = 86 | Article 87 | { articleTitle = field "title" pure 88 | , articleId = field "id" (fmap ArticleId . readEither) 89 | } 90 | 91 | -- | Go from a record describing a formlet, to a formlet producing a record. 92 | -- 93 | -- NOTE: We could generate this trivially with template-haskell (or 94 | -- perhaps Generics). 95 | articleValidation :: Article Formlet -> Formlet (Article Identity) 96 | articleValidation (Article x y) = Article <$> x <*> y 97 | 98 | -- This idea might be generalizable. Perhaps any @Article f -> f 99 | -- (Article Identity)@? 100 | 101 | -------------------------------------------------------------------------------- 102 | -- Meta 103 | 104 | -- Record meta data that can be recovered at runtime by simply using a 105 | -- record field. No type-level labels magic needed. 106 | 107 | -- See database example below. 108 | 109 | newtype Meta a = Meta { getMeta :: String } 110 | 111 | instance Indexed Meta a where 112 | type Index Meta a = Meta a 113 | 114 | -------------------------------------------------------------------------------- 115 | -- Querying values as database records 116 | 117 | -- See use of this in DB example. 118 | 119 | data Expr a where 120 | Null :: Expr (Maybe a) 121 | Val :: Render a => a -> Expr a 122 | Get :: (r Meta -> Meta f) -> Selected r -> Expr f 123 | Equal :: Render a => Expr a -> Expr a -> Expr Bool 124 | And :: Expr a -> Expr a -> Expr Bool 125 | 126 | instance Indexed Expr a where 127 | type Index Expr a = Expr a 128 | 129 | -------------------------------------------------------------------------------- 130 | -- Updating records 131 | 132 | -- See use of this in DB example. 133 | 134 | data Updating a = Default | Set a 135 | 136 | instance Indexed Updating a where 137 | type Index Updating a = Updating a 138 | 139 | -- Could be generated with TH (possibly Generics), like making lenses. 140 | updatingArticle :: Article Updating 141 | updatingArticle = Article {articleId = Default, articleTitle = Default} 142 | 143 | -- A class also works: 144 | 145 | class Updateable f where 146 | update :: f Updating 147 | 148 | instance Updateable Article where 149 | update = Article {articleId = Default, articleTitle = Default} 150 | 151 | -- See below for example use, but it's pretty predictable. 152 | 153 | -------------------------------------------------------------------------------- 154 | -- DB library 155 | 156 | -- Values declared at top-level scope for each database entity. 157 | data Entity a = Entity { entityVal :: a Meta, entityMeta :: String } 158 | 159 | -- Values are produced in the Relational DSL which have unique names. 160 | data Selected a = Selected { selectedVal :: a Meta, selectedMeta :: (String, Int) } 161 | 162 | -- Can render to SQL. We use String for simplicity, but this could be 163 | -- another AST or a Builder. 164 | class Render e where 165 | render :: e -> String 166 | 167 | instance Render Int where render = show 168 | 169 | renderExpr :: Expr a -> String 170 | renderExpr = 171 | \case 172 | Null -> "NULL" 173 | (Val a) -> render a 174 | (Get key (Selected obj (name,idx))) -> name <> "_" <> show idx <> "." <> getMeta (key obj) 175 | (Equal a b) -> "(" <> renderExpr a <> " = " <> renderExpr b <> ")" 176 | (And a b) -> "(" <> renderExpr a <> " AND " <> renderExpr b <> ")" 177 | 178 | -- A simple query DSL that supports joins and filtering. 179 | data Relational a where 180 | SelectFrom :: Entity a -> Relational (Selected a) 181 | Filter :: Expr Bool -> Relational () 182 | Bind :: Relational a -> (a -> Relational b) -> Relational b 183 | Pure :: a -> Relational a 184 | 185 | -- Generate a plan from a query. 186 | planRelational :: Relational (Projection a) -> Plan 187 | planRelational r = let (proj,plan) = runState (go r) (Plan mempty [] []) 188 | in plan {planProjection = collapseProjection proj} 189 | where 190 | go :: Relational a -> State Plan a 191 | go = 192 | \case 193 | SelectFrom entity -> do 194 | selects <- gets planSelects 195 | i <- 196 | case M.lookup (entityMeta entity) selects of 197 | Just i -> pure i 198 | Nothing -> do 199 | modify 200 | (\plan -> 201 | plan 202 | { planSelects = 203 | M.insert (entityMeta entity) (M.size selects) selects 204 | }) 205 | pure (M.size selects) 206 | pure (Selected (entityVal entity) (entityMeta entity, i)) 207 | Filter bool -> 208 | modify (\plan -> plan {planFilters = bool : planFilters plan}) 209 | Pure a -> return a 210 | Bind m f -> go m >>= go . f 211 | 212 | -- The plan is simply a set of entities to select, filters on them and 213 | -- a final projection. 214 | data Plan = 215 | Plan 216 | { planSelects :: Map String Int 217 | , planFilters :: [Expr Bool] 218 | , planProjection :: [SomeProjection] 219 | } 220 | 221 | -- Render the query to string. Dumb implementation. 222 | renderPlan :: Plan -> String 223 | renderPlan plan = "SELECT " <> project <> "\nFROM " <> select <> filters 224 | where 225 | project = 226 | intercalate 227 | ", " 228 | (map 229 | (\case 230 | SomeExpr e -> renderExpr e 231 | SomeSelected (Selected _ (name, idx)) -> name <> "_" <> show idx) 232 | (planProjection plan)) 233 | select = 234 | intercalate 235 | ", " 236 | (map 237 | (\(t, index) -> t ++ " AS " ++ t ++ "_" ++ show index) 238 | (M.toList (planSelects plan))) 239 | filters = 240 | if null (planFilters plan) 241 | then "" 242 | else "\nWHERE " <> 243 | intercalate "\nAND " (map renderExpr (planFilters plan)) 244 | 245 | instance Applicative Relational where 246 | pure = return 247 | (<*>) = ap 248 | 249 | instance Functor Relational where 250 | fmap = liftM 251 | 252 | instance Monad Relational where 253 | (>>=) = Bind 254 | return = Pure 255 | 256 | -- A final projection at the end of a query. We can return expressions 257 | -- (i.e. constants or fields), or return whole records, and combine 258 | -- them together as tuples. 259 | data Projection a where 260 | ProjectExpr :: Expr a -> Projection a 261 | ConsProj :: Projection a -> Projection b -> Projection (a, b) 262 | ProjectSelected :: Selected e -> Projection (e Identity) 263 | 264 | data SomeProjection 265 | = forall e. SomeExpr (Expr e) 266 | | forall e. SomeSelected (Selected e) 267 | 268 | collapseProjection :: Projection a -> [SomeProjection] 269 | collapseProjection = 270 | \case 271 | ProjectExpr e -> [SomeExpr e] 272 | ConsProj e es -> collapseProjection e <> collapseProjection es 273 | ProjectSelected e -> [SomeSelected e] 274 | 275 | -------------------------------------------------------------------------------- 276 | -- Example 277 | 278 | -- Declare our entity types 279 | 280 | data Article i = 281 | Article 282 | { articleId :: Index (Defaulted i) ArticleId 283 | , articleTitle :: Index i String 284 | } deriving (Generic) 285 | newtype ArticleId = ArticleId Int deriving (Show, Eq, Render) 286 | 287 | -- Just because we can: 288 | 289 | deriving instance Show (Article Identity) 290 | deriving instance Eq (Article Identity) 291 | 292 | data Author i = 293 | Author 294 | { authorId :: Index i AuthorId 295 | , authorName :: Index i String 296 | } deriving (Generic) 297 | newtype AuthorId = AuthorId Int deriving (Show, Eq, Render) 298 | 299 | data Authorship i = 300 | Authorship 301 | { authorshipArticle :: Index i ArticleId 302 | , authorshipAuthor :: Index i AuthorId 303 | } deriving (Generic) 304 | 305 | -- Declare value-level references for each entity (can be 306 | -- TH-generated, or perhaps Generics) like deriving lenses, or 307 | -- implemented manually for special cases. 308 | 309 | entityArticle :: Entity Article 310 | entityArticle = 311 | Entity 312 | { entityVal = Article {articleTitle = Meta "title", articleId = Meta "id"} 313 | , entityMeta = "article" 314 | } 315 | 316 | entityAuthor :: Entity Author 317 | entityAuthor = 318 | Entity 319 | { entityVal = Author {authorName = Meta "name", authorId = Meta "id"} 320 | , entityMeta = "author" 321 | } 322 | 323 | entityAuthorship :: Entity Authorship 324 | entityAuthorship = 325 | Entity 326 | { entityVal = 327 | Authorship 328 | {authorshipArticle = Meta "article", authorshipAuthor = Meta "author"} 329 | , entityMeta = "authorship" 330 | } 331 | 332 | -- Or if you want to be really terse, just have a class. Example below of this too. 333 | 334 | class Table a where table :: Entity a 335 | instance Table Article where table = entityArticle 336 | instance Table Author where table = entityAuthor 337 | instance Table Authorship where table = entityAuthorship 338 | 339 | 340 | -- Write a simple query that joins on several tables. 341 | -- Imagine we have e.g. 342 | -- 343 | -- >>> filter (article ! articleId ==. authorship ! authorshipArticle) 344 | --- 345 | -- Handy operators to make the code look more concise. Same for the projection. 346 | 347 | articleQuery :: Relational (Projection (Article Identity, String)) 348 | -- ^ Note how easy this type could be converted to a 349 | -- FromRow instance (postgresql-simple, mysql-simple, etc). 350 | articleQuery = do 351 | article <- SelectFrom entityArticle 352 | author <- SelectFrom table -- The class with method 'table' also works fine. 353 | authorship <- SelectFrom entityAuthorship 354 | Filter (Equal (Get articleId article) (Get authorshipArticle authorship)) 355 | Filter (Equal (Get authorId author) (Get authorshipAuthor authorship)) 356 | pure 357 | (ConsProj (ProjectSelected article) (ProjectExpr (Get authorName author))) 358 | 359 | -- Plan the query 360 | 361 | planArticle :: Plan 362 | planArticle = planRelational articleQuery 363 | 364 | -- SQL Output 365 | 366 | -- > putStrLn $ renderPlan planArticle 367 | -- SELECT article_0, author_1.name 368 | -- FROM article AS article_0, author AS author_1, authorship AS authorship_2 369 | -- WHERE (author_1.id = authorship_2.author) 370 | -- AND (article_0.id = authorship_2.article) 371 | 372 | -- I haven't fleshed out an API (time not permitting), but you can 373 | -- imagine making a simple UPDATE API using the Updating type: 374 | 375 | updateArticleExample :: Article Updating 376 | updateArticleExample = update { articleTitle = Set "Article!"} 377 | 378 | -- And you could do WHERE .. as with did above. 379 | 380 | -------------------------------------------------------------------------------- 381 | -- Some playing around with defaultable fields 382 | 383 | data Insertable a 384 | 385 | type family Defaulted x where 386 | Defaulted Insertable = InsertOrDefault 387 | Defaulted x = x 388 | 389 | instance Indexed Insertable a where 390 | type Index Insertable a = InsertOnly a 391 | 392 | data InsertOnly a where 393 | InsertOnly :: a -> InsertOnly a 394 | 395 | data InsertOrDefault a where 396 | Insert :: a -> InsertOrDefault a 397 | Defaulting :: InsertOrDefault a 398 | 399 | instance Indexed InsertOrDefault a where 400 | type Index InsertOrDefault a = InsertOrDefault a 401 | 402 | insertArticle :: Article Insertable 403 | insertArticle = Article 404 | { articleId = Defaulting -- Here I can use defaulting. 405 | , articleTitle = InsertOnly "" -- Here I cannot. 406 | } 407 | -------------------------------------------------------------------------------- /lazy-length.hs: -------------------------------------------------------------------------------- 1 | -- Lazy natural numbers for an efficient length comparison. 2 | 3 | {- 4 | 5 | Equal-sized lists: 6 | 7 | > genericLength [1..3] == (genericLength [1..3] :: Nat) 8 | True 9 | 10 | With infinite lists: 11 | 12 | > genericLength [1..3] < (genericLength [1..] :: Nat) 13 | True 14 | > genericLength [1..3] == (genericLength [1..] :: Nat) 15 | False 16 | > genericLength [1..3] > (genericLength [1..] :: Nat) 17 | False 18 | 19 | -} 20 | 21 | import Data.List 22 | 23 | -- A natural number in peano style. 24 | -- 25 | -- 0 = Zero 26 | -- 1 = Add1 Zero 27 | -- 2 = Add1 (Add1 Zero) 28 | -- 3 = Add1 (Add1 (Add1 Zero)) 29 | -- .. 30 | data Nat = Zero | Add1 Nat 31 | 32 | instance Num Nat where 33 | Zero + y = y 34 | Add1 x + y = x + (Add1 y) 35 | 36 | fromInteger 0 = Zero 37 | fromInteger n = Add1 (fromInteger (n - 1)) 38 | 39 | -- This instance can be derived automatically, but we include a manual 40 | -- implementation to demonstrate the idea: 41 | instance Ord Nat where 42 | compare Zero Zero = EQ 43 | compare Zero (Add1 _) = LT 44 | compare (Add1 l) (Add1 r) = compare l r 45 | 46 | -- This instance can be derived automatically, too. 47 | instance Eq Nat where 48 | Zero == Zero = True 49 | Add1 x == Add1 y = x == y 50 | _ == _ = False 51 | -------------------------------------------------------------------------------- /liquid-haskell-dates.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | -- | Modelling a calendar date statically. 4 | 5 | module Date where 6 | 7 | -- We define invariants on dates, such as how many days per month, including leap years. 8 | 9 | {-@ type Day = 10 | {v:Int | v > 0 && v <= 31 } @-} 11 | 12 | {-@ type Month day = 13 | {v:Int | v > 0 && v <= 12 && (day < 31 || not (v = 04 || v = 06 || v = 09 || v = 11)) } @-} 14 | 15 | {-@ type Year month day = 16 | {v:Int | v > 0 && (month /= 2 || (day < 30 && (day < 29 || v mod 400 = 0 || (v mod 4 = 0 && v mod 100 /= 0)))) } @-} 17 | 18 | -- We define a date type with a shadow liquid type encoding our invariants. 19 | 20 | data Date = Date 21 | { day :: !Int 22 | , month :: !Int 23 | , year :: !Int 24 | } deriving (Show) 25 | {-@ data Date = Date 26 | { day :: Day 27 | , month :: Month day 28 | , year :: Year month day 29 | } @-} 30 | 31 | -- In order to construct a valid `Date`, we need to do all the proper runtime tests, or 32 | -- else Liquid Haskell complains at compile time that they're not satisfied. 33 | 34 | main :: IO () 35 | main = do 36 | year :: Int <- readLn 37 | month :: Int <- readLn 38 | day :: Int <- readLn 39 | if year > 0 40 | then if month > 0 && month <= 12 && (day < 31 || not (month == 04 || month == 06 || month == 09 || month == 11)) 41 | then if day > 0 && day <= 31 && valid_leap_days day month year 42 | then print (Date day month year) 43 | else error "Day is out of range!" 44 | else error "Month is out of range." 45 | else error "Year is out of range." 46 | where 47 | valid_leap_days day month year = 48 | (month /= 2 || 49 | (day < 30 && (day < 29 || mod year 400 == 0 || (mod year 4 == 0 && mod year 100 /= 0)))) 50 | 51 | 52 | -- Examples: 53 | 54 | works :: Date 55 | works = Date 12 03 2017 56 | 57 | works2 :: Date 58 | works2 = Date 31 03 2017 59 | 60 | works3 :: Date 61 | works3 = Date 30 04 2017 62 | 63 | works_leap_day :: Date 64 | works_leap_day = Date 29 02 2016 65 | 66 | -- Does not compile: 67 | -- invalid_nov_day = Date 11 31 2017 68 | -- invalid_month = Date 12 15 2017 69 | -- invalid_leap_day = Date 29 02 2017 70 | -- invalid_days d m y = Date 30 2 2000 71 | -- invalid_bound = Date 31 04 2017 72 | -------------------------------------------------------------------------------- /money-pennies.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | -- | Represent money as pennies. 4 | 5 | module Money 6 | ( Pennies 7 | , Pounds 8 | , addPennies 9 | , multPennies 10 | , divPennies 11 | , penniesToPounds 12 | ) where 13 | 14 | import Text.Printf 15 | 16 | newtype Pennies = 17 | Pennies 18 | { penniesCount :: Int 19 | } 20 | deriving (Eq, Ord, Enum) 21 | 22 | instance Show Pennies where 23 | show (Pennies p) = show p ++ "p" 24 | 25 | newtype Pounds = 26 | Pounds 27 | { poundsToPennies :: Pennies 28 | } 29 | deriving (Eq, Ord, Enum) 30 | 31 | instance Show Pounds where 32 | show (Pounds (Pennies pennies)) = 33 | "£" ++ printf "%.2f" (fromIntegral pennies / 100 :: Double) 34 | 35 | addPennies :: Pennies -> Pennies -> Pennies 36 | addPennies (Pennies x) (Pennies y) = Pennies (x+y) 37 | 38 | multPennies :: Int -> Pennies -> Pennies 39 | multPennies y (Pennies x) = Pennies (x * y) 40 | 41 | divPennies :: Int -> Pennies -> Pennies 42 | divPennies y (Pennies x) = Pennies (div x y) 43 | 44 | penniesToPounds :: Pennies -> Pounds 45 | penniesToPounds = Pounds 46 | -------------------------------------------------------------------------------- /mutable-containers.hs: -------------------------------------------------------------------------------- 1 | -- This module demonstrates a few mutable cells in Haskell, using the 2 | -- mutable-containers package which provides a general interface. 3 | module Main where 4 | import Data.Mutable 5 | import Control.Monad.ST 6 | main = do 7 | -- IORef contains any boxed value. Pretty fast. Only works in IO. 8 | do ioref <- fmap asIORef (newRef 123) 9 | writeRef ioref 456 10 | v <- readRef ioref 11 | print v 12 | -- STRef contains any boxed value. Pretty fast. Only works in ST. 13 | print (runST (do stref <- fmap asSTRef (newRef 123) 14 | writeRef stref 456 15 | v <- readRef stref 16 | return v)) 17 | -- Unboxed reference. This will shave off some performance overhead 18 | -- on very tight loops. Works in either IO or ST. You can only put 19 | -- instances of Unbox in here: http://hackage.haskell.org/package/mutable-containers-0.3.3/docs/Data-Mutable.html#t:Unbox 20 | do uref <- fmap asURef (newRef (123::Int)) 21 | writeRef uref 456 22 | v <- readRef uref 23 | print v 24 | print (runST (do uref <- fmap asURef (newRef (123::Int)) 25 | writeRef uref 456 26 | v <- readRef uref 27 | return v)) 28 | -------------------------------------------------------------------------------- /nonempty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | 7 | -- | A trivial non-empty text value. 8 | 9 | -- import qualified Base.NonEmptyText as NET 10 | 11 | module Base.NonEmptyText 12 | (NonEmptyText 13 | ,KnownNonEmptyString 14 | ,get 15 | ,append 16 | ,mk 17 | ,static) where 18 | 19 | import Data.Proxy 20 | import Data.String 21 | import Data.Text (Text) 22 | import qualified Data.Text as S 23 | import GHC.TypeLits 24 | 25 | -- | Handy constraint kind. 26 | type KnownNonEmptyString string = (KnownSymbol string, CmpSymbol string "" ~ 'GT) 27 | 28 | -- | A text that is not empty. 29 | newtype NonEmptyText = 30 | NonEmptyText 31 | { get :: Text 32 | } deriving (Eq, Show, Ord, Semigroup) 33 | 34 | -- | Append regular text to a non-empty. 35 | append :: NonEmptyText -> Text -> NonEmptyText 36 | append (NonEmptyText x) y = NonEmptyText (x <> y) 37 | 38 | -- | Runtime smart constructor. 39 | mk :: Text -> Maybe NonEmptyText 40 | mk x = 41 | if S.null x 42 | then Nothing 43 | else Just (NonEmptyText x) 44 | 45 | -- | Statically checked string construction: NET.static (Proxy @"foo") 46 | static :: 47 | forall string. KnownNonEmptyString string 48 | => Proxy string 49 | -> NonEmptyText 50 | static p = NonEmptyText (fromString (symbolVal p)) 51 | -------------------------------------------------------------------------------- /optparse.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack 2 | -- stack --resolver lts-12.12 script 3 | 4 | import Options.Applicative.Simple 5 | import Data.Semigroup ((<>)) 6 | 7 | data Config = 8 | Config 9 | { configEnable :: Bool 10 | , configUrl :: String 11 | } deriving (Show) 12 | 13 | main = do 14 | (opts, ()) <- 15 | simpleOptions 16 | "1.0" 17 | "Demo opts program" 18 | "This program demonstrates commandline options." 19 | (Config 20 | <$> flag False True (long "enable-the-thing" <> short 'e' <> help "Enable it!") 21 | <*> strArgument (metavar "URLHERE" <> help "The URL")) 22 | empty 23 | print opts 24 | -------------------------------------------------------------------------------- /origami.hs: -------------------------------------------------------------------------------- 1 | -- | Fold over the input, folding left or right depending on the element. 2 | origami :: (s -> l -> s) -> (r -> s -> s) -> s -> [Either l r] -> s 3 | origami _ _ nil [] = nil 4 | origami fl fr nil (x:xs) = 5 | case x of 6 | Left l -> origami fl fr (fl nil l) xs 7 | Right r -> fr r (origami fl fr nil xs) 8 | -------------------------------------------------------------------------------- /proj.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE DataKinds #-} 7 | {-# LANGUAGE OverloadedLists #-} 8 | {-# LANGUAGE LambdaCase #-} 9 | {-# OPTIONS_GHC -Wall #-} 10 | 11 | import Data.List.NonEmpty (NonEmpty(..)) 12 | import Data.String 13 | 14 | newtype Title = 15 | Title String 16 | deriving (IsString, Show) 17 | 18 | data CompletionKey 19 | = VariableName 20 | | OperatorName 21 | deriving (Show) 22 | 23 | newtype Delim = 24 | Delim String 25 | deriving (Show, IsString) 26 | 27 | data Tree 28 | = Keyword String 29 | | IntLit (Maybe Int) 30 | | ArbitraryText (Maybe String) 31 | | Variable CompletionKey (Maybe String) 32 | | Choice Title (NonEmpty Tree) (Maybe Tree) 33 | | List 34 | Title 35 | Tree 36 | Delim 37 | (Maybe (NonEmpty Tree)) 38 | | Composite 39 | Title 40 | (NonEmpty Tree) 41 | (Maybe (NonEmpty Tree)) 42 | deriving (Show) 43 | 44 | data Cursor 45 | = InList Int Cursor 46 | | InComposite Int Cursor 47 | | InChoice Cursor 48 | | Here 49 | deriving (Show) 50 | 51 | data Preview 52 | = KeywordPreview String 53 | | CompletionType String 54 | | Choices Title 55 | | ListOf Title 56 | | CompositePreview Title 57 | | IntLitPreview 58 | | ArbitraryTextPreview 59 | deriving (Show) 60 | 61 | grammar :: Tree 62 | grammar = expr 63 | where 64 | expr = Choice "expression" [let', app, op, list, tuple, parens, lit] Nothing 65 | parens = Composite "(..)" [Keyword "(", expr, Keyword ")"] Nothing 66 | let' = 67 | Composite 68 | "let" 69 | [Keyword "let", List "definitions" def ";" Nothing] 70 | Nothing 71 | def = 72 | Composite 73 | "definition" 74 | [Variable VariableName Nothing, Keyword "=", expr, Keyword "in", expr] 75 | Nothing 76 | app = Composite "application" [expr, expr] Nothing 77 | op = Composite "infix" [expr, Variable OperatorName Nothing, expr] Nothing 78 | list = 79 | Composite 80 | "list" 81 | [Keyword "[", List "list" expr "," Nothing, Keyword "]"] 82 | Nothing 83 | tuple = 84 | Composite 85 | "tuple" 86 | [Keyword "(", List "tuple" expr "," Nothing, Keyword ")"] 87 | Nothing 88 | lit = Choice "literal" [int, string] Nothing 89 | int = IntLit Nothing 90 | string = 91 | Composite 92 | "string" 93 | [Keyword "\"", ArbitraryText Nothing, Keyword "\""] 94 | Nothing 95 | 96 | previewTree :: Tree -> Preview 97 | previewTree = 98 | \case 99 | Keyword kw -> KeywordPreview kw 100 | Variable completionKey _ -> previewCompletionKey completionKey 101 | Choice title _ _ -> Choices title 102 | List title _ _ _ -> ListOf title 103 | Composite title _ _ -> CompositePreview title 104 | IntLit _ -> IntLitPreview 105 | ArbitraryText _ -> ArbitraryTextPreview 106 | 107 | previewCompletionKey :: CompletionKey -> Preview 108 | previewCompletionKey = 109 | \case 110 | VariableName -> CompletionType "variable-name" 111 | OperatorName -> CompletionType "operator" 112 | -------------------------------------------------------------------------------- /rest-request.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | {- 5 | 6 | > execWriterT $ document api 7 | PathDoc "users" (PathDoc "profile" (MappendDoc [GetCaptureDoc "id",GetParamDoc "private_or_public"])) 8 | 9 | -} 10 | 11 | module RestRequest where 12 | 13 | import Control.Applicative 14 | import Control.Monad.Trans.Writer 15 | import Control.Monad.Trans 16 | 17 | data Request m a where 18 | Path :: String -> Request m a -> Request m a 19 | GetCapture :: String -> Request m String 20 | GetHeader :: String -> Request m String 21 | GetParam :: String -> Request m (Maybe String) 22 | GetBody :: Request m String 23 | Lift :: m a -> Request m a 24 | Fmap :: (z -> a) -> Request m z -> Request m a 25 | LiftA2 :: (y -> z -> a) -> Request m y -> Request m z -> Request m a 26 | Pure :: a -> Request m a 27 | 28 | instance Functor (Request f) where 29 | fmap = Fmap 30 | 31 | instance Applicative (Request f) where 32 | pure = Pure 33 | liftA2 = LiftA2 34 | 35 | data Doc 36 | = PathDoc String Doc 37 | | GetHeaderDoc String 38 | | GetParamDoc String 39 | | GetCaptureDoc String 40 | | WriteHeaderDoc String 41 | | WriteBodyDoc 42 | | GetBodyDoc 43 | | MappendDoc [Doc] 44 | deriving (Show) 45 | 46 | instance Monoid Doc where 47 | mempty = MappendDoc [] 48 | mappend (MappendDoc xs) (MappendDoc ys) = MappendDoc (xs <> ys) 49 | mappend (MappendDoc xs) (ys) = MappendDoc (xs <> [ys]) 50 | mappend xs (MappendDoc ys) = MappendDoc ([xs] <> ys) 51 | mappend x y = MappendDoc [x,y] 52 | 53 | instance Semigroup Doc where 54 | (<>) = mappend 55 | 56 | document :: Monad m => Request m a -> WriterT Doc m a 57 | document = 58 | \case 59 | Lift m -> lift m 60 | Pure a -> pure a 61 | Fmap f x -> fmap f (document x) 62 | LiftA2 f x y -> liftA2 f (document x) (document y) 63 | Path piece rest -> censor (PathDoc piece) (document rest) 64 | GetHeader key -> do 65 | tell (GetHeaderDoc key) 66 | pure mempty 67 | GetCapture key -> do 68 | tell (GetCaptureDoc key) 69 | pure mempty 70 | GetParam key -> do 71 | tell (GetParamDoc key) 72 | pure mempty 73 | GetBody -> do 74 | tell GetBodyDoc 75 | pure mempty 76 | 77 | api :: Request m (String, Maybe String) 78 | api = 79 | Path 80 | "users" 81 | (Path "profile" ((,) <$> GetCapture "id" <*> GetParam "private_or_public")) 82 | -------------------------------------------------------------------------------- /rest-response.hs: -------------------------------------------------------------------------------- 1 | {- 2 | 3 | > :t (header "X-Header" % body) 4 | (header "X-Header" % body) :: Response r2 (String -> String -> r2) 5 | 6 | > meta (header "X-Header" % body) 7 | MappendM [HeaderM "X-Header",BodyM] 8 | 9 | > run (header "X-Header" % body) "Header Value" "Hello, Body!" 10 | Mappend [Header "X-Header" "Header Value",Body "Hello, Body!"] 11 | 12 | -} 13 | 14 | module RestResponse 15 | ( Output(..) 16 | , Meta(..) 17 | , (%) 18 | , header 19 | , body 20 | , meta 21 | , run 22 | ) where 23 | 24 | -- A response generator. 25 | data Response r a = Response { meta :: Meta, runHM :: (Output -> r) -> a } 26 | 27 | data Output = Body String | Header String String | Mappend [Output] deriving (Show) 28 | 29 | instance Semigroup Output where x <> y = Mappend [x, y] 30 | 31 | data Meta = BodyM | HeaderM String | MappendM [Meta] deriving (Show) 32 | 33 | instance Semigroup Meta where x <> y = MappendM [x,y] 34 | 35 | -- | Combine two responses. 36 | (%) :: Response r1 a -> Response r2 r1 -> Response r2 a 37 | r1 % r2 = 38 | Response (meta r1 <> meta r2) (\k -> runHM r1 (\output -> runHM r2 (\output2 -> k (output <> output2)))) 39 | infixr 9 % 40 | 41 | -- | Run the response on arguments. 42 | run :: Response Output a -> a 43 | run m = runHM m id 44 | 45 | -- | Declare a header. 46 | header :: String -> Response r (String -> r) 47 | header key = later (HeaderM key) (Header key) 48 | 49 | -- | Declare body output. 50 | body :: Response r (String -> r) 51 | body = later BodyM Body 52 | 53 | -- Do something later. 54 | later :: Meta -> (a -> Output) -> Response r (a -> r) 55 | later m f = Response m (. f) 56 | -------------------------------------------------------------------------------- /resumable-parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | 8 | {- 9 | 10 | A very simple, "core" resumable parser with backtracking-by-default. 11 | 12 | > parseOnly (letters <> digits) "abc" :: Either [Text] String 13 | Right "abc" 14 | > parseOnly (letters <> digits) "123" :: Either [Text] String 15 | Right "123" 16 | > parseOnly (letters <> digits) "!!!" :: Either [Text] String 17 | Left ["non-letter","non-digit"] 18 | > parseOnly (letters <> digits) "abc!" :: Either [Text] String 19 | Right "abc" 20 | > parseOnly ((letters <> digits) <* endOfInput) "abc!" :: Either [Text] String 21 | Left ["Expected end of input"] 22 | > parseOnly ((letters <> digits) <* endOfInput) "abc" :: Either [Text] String 23 | Right "abc" 24 | -} 25 | 26 | module Resumable where 27 | 28 | import Control.Monad 29 | import Data.Char 30 | import Data.Maybe 31 | import Data.Semigroup 32 | import Data.Text (Text) 33 | 34 | -------------------------------------------------------------------------------- 35 | -- Parser type 36 | 37 | -- | A parser. Takes as input maybe a value. Nothing terminates the 38 | -- input. Takes two continuations: one for success and one for failure. 39 | newtype Parser input error value = Parser 40 | { runParser :: forall result. 41 | Maybe input 42 | -> (Maybe input -> value -> Result input error result) 43 | -> (Maybe input -> error -> Result input error result) 44 | -> Result input error result 45 | } 46 | 47 | -- | Result of a parser. Maybe be partial (expecting more input). 48 | data Result i e r 49 | = Done !(Maybe i) !r 50 | | Failed !(Maybe i) !e 51 | | Partial (Maybe i -> Result i e r) 52 | 53 | instance Monad (Parser i e) where 54 | return x = Parser (\mi done _failed -> done mi x) 55 | {-# INLINABLE return #-} 56 | m >>= f = 57 | Parser 58 | (\mi done failed -> 59 | runParser m mi (\mi' v -> runParser (f v) mi' done failed) failed) 60 | {-# INLINABLE (>>=) #-} 61 | 62 | instance Semigroup e => Semigroup (Parser i e a) where 63 | left <> right = 64 | Parser 65 | (\mi done failed -> 66 | runParser 67 | left 68 | mi 69 | done 70 | (\_mi e -> runParser right mi done (\mi' e' -> failed mi' (e <> e')))) 71 | {-# INLINABLE (<>) #-} 72 | 73 | instance Applicative (Parser i e) where 74 | (<*>) = ap 75 | {-# INLINABLE (<*>) #-} 76 | pure = return 77 | {-# INLINABLE pure #-} 78 | 79 | instance Functor (Parser i e) where 80 | fmap = liftM 81 | {-# INLINABLE fmap #-} 82 | 83 | -------------------------------------------------------------------------------- 84 | -- API 85 | 86 | class NoMoreInput e where noMoreInput :: e 87 | instance NoMoreInput e => NoMoreInput [e] where noMoreInput = pure noMoreInput 88 | 89 | parseOnly :: Parser i e a -> i -> Either e a 90 | parseOnly p i = 91 | terminate (runParser p (Just i) Done Failed) 92 | where 93 | terminate r = 94 | case r of 95 | Partial f -> terminate (f Nothing) 96 | Done _ d -> Right d 97 | Failed _ e -> Left e 98 | 99 | -------------------------------------------------------------------------------- 100 | -- Combinators 101 | 102 | class ExpectedEof e where expectedEof :: e 103 | instance ExpectedEof e => ExpectedEof [e] where expectedEof = pure expectedEof 104 | class SomeError e where someError :: Text -> e 105 | instance SomeError e => SomeError [e] where someError = pure . someError 106 | 107 | instance NoMoreInput Text where noMoreInput = "No more input" 108 | instance ExpectedEof Text where expectedEof = "Expected end of input" 109 | instance SomeError Text where someError = id 110 | 111 | nextElement :: NoMoreInput e => Parser [a] e a 112 | nextElement = 113 | Parser (\mi0 done failed -> 114 | let go mi = 115 | case mi of 116 | Nothing -> failed Nothing noMoreInput 117 | Just (x:xs) -> done (Just xs) x 118 | Just [] -> Partial go 119 | in go mi0) 120 | {-# INLINABLE nextElement #-} 121 | 122 | endOfInput :: ExpectedEof e => Parser [a] e () 123 | endOfInput = 124 | Parser (\mi0 done failed -> 125 | let go mi = 126 | case mi of 127 | Just [] -> Partial go 128 | Just (_:_) -> failed mi expectedEof 129 | Nothing -> done Nothing () 130 | in go mi0) 131 | {-# INLINABLE endOfInput #-} 132 | 133 | digit :: (SomeError e, NoMoreInput e) => Parser [Char] e Char 134 | digit = do 135 | c <- nextElement 136 | if isDigit c 137 | then pure c 138 | else Parser (\mi _done failed -> failed mi (someError "non-digit")) 139 | 140 | letter :: (SomeError e, NoMoreInput e) => Parser [Char] e Char 141 | letter = do 142 | c <- nextElement 143 | if isLetter c 144 | then pure c 145 | else Parser (\mi _done failed -> failed mi (someError "non-letter")) 146 | 147 | letters :: (SomeError e, NoMoreInput e) => Parser [Char] [e] [Char] 148 | letters = do 149 | c <- letter 150 | d <- fmap Just letters <> pure Nothing 151 | pure (c : fromMaybe [] d) 152 | 153 | digits :: (NoMoreInput e, SomeError e) => Parser [Char] [e] [Char] 154 | digits = do 155 | c <- digit 156 | d <- fmap Just digits <> pure Nothing 157 | pure (c : fromMaybe [] d) 158 | -------------------------------------------------------------------------------- /simple-baysian-spam-filter.hs: -------------------------------------------------------------------------------- 1 | -- | An implementation of the spam filter from Paul Graham's A Plan for Spam. 2 | module Spam where 3 | 4 | import Data.List 5 | import Data.Map.Strict (Map) 6 | import qualified Data.Map.Strict as M 7 | import Data.Maybe 8 | import Data.Monoid 9 | 10 | newtype Token = Token String 11 | deriving (Ord,Eq,Show) 12 | 13 | data Corpus = 14 | Corpus {corpusMessages :: Double 15 | ,corpusHistogram :: Map Token Double} 16 | deriving (Show) 17 | 18 | instance Monoid Corpus where 19 | mempty = Corpus 0 mempty 20 | mappend (Corpus a x) (Corpus b y) = 21 | Corpus (a + b) (M.unionWith (+) x y) 22 | 23 | corpus :: [String] -> Corpus 24 | corpus = foldl' (<>) mempty . map (Corpus 1 . histogram . tokenize) 25 | 26 | tokenize :: String -> [Token] 27 | tokenize = map Token . words 28 | 29 | histogram :: [Token] -> Map Token Double 30 | histogram = foldl' (\m t -> M.insertWith (+) t 1 m) mempty 31 | 32 | occurances :: Double 33 | occurances = 1 -- Turn this up to 5 when the corpus gets bigger. 34 | 35 | probability :: Corpus -> Corpus -> Token -> Maybe Double 36 | probability bad good token = 37 | if g + b < occurances 38 | then Nothing 39 | else Just 40 | (max 0.01 41 | (min 0.99 ((min 1 (b / nbad)) / 42 | (min 1 (g / ngood) + (min 1 (b / nbad)))))) 43 | where g = 2 * M.findWithDefault 0 token (corpusHistogram good) 44 | b = M.findWithDefault 0 token (corpusHistogram bad) 45 | ngood = corpusMessages good 46 | nbad = corpusMessages bad 47 | 48 | combine :: [Double] -> Double 49 | combine [] = 0 50 | combine probs = prod / (prod + foldl1' (*) (map (1 -) probs)) 51 | where prod = foldl1' (*) probs 52 | 53 | classify :: Corpus -> Corpus -> String -> Double 54 | classify bad good = combine . mapMaybe (probability bad good) . tokenize 55 | 56 | spam :: Corpus 57 | spam = 58 | corpus ["TV Shows Subtitles English TV Subs English Subtitles Subtitles English TV Subs TV Subtitles" 59 | ,"million tv and movie download links list" 60 | ,"james may the reassembler s01e04 web dl x264 om" 61 | ,"james may the reassembler s01e04 web dl x264 om"] 62 | 63 | ham :: Corpus 64 | ham = 65 | corpus ["zmap :: (a->b) -> ([a],[a]) -> ([b],[b])" 66 | ,"data ListZipper a = ListZipper {future::[a],past::[a]} " 67 | ,"instance Show a => Show (ListZipper a) where"] 68 | -------------------------------------------------------------------------------- /st-array.hs: -------------------------------------------------------------------------------- 1 | import Data.Array.ST 2 | import Data.Array.Unboxed 3 | 4 | someArray :: UArray Int Int 5 | someArray = 6 | runSTUArray 7 | (do arr <- newArray (0, 10) 0 8 | writeArray arr 0 666 9 | writeArray arr 1 42 10 | return arr) 11 | 12 | value :: Int 13 | value = (someArray ! 0) + (someArray ! 1) 14 | -------------------------------------------------------------------------------- /terminal-type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | -- Simple exmaple of a terminal type as an ADT. 4 | 5 | import Prelude hiding (print) 6 | import Control.Monad 7 | 8 | -------------------------------------------------------------------------------- 9 | -- Trivial 10 | 11 | data Terminal a 12 | = Print String (Terminal a) 13 | | GetLine (String -> Terminal a) 14 | | Return a 15 | 16 | interpret :: Terminal a -> IO a 17 | interpret = 18 | \case 19 | Return a -> return a 20 | Print str next -> do 21 | putStrLn str 22 | interpret next 23 | GetLine f -> do 24 | line <- getLine 25 | interpret (f line) 26 | 27 | main :: IO () 28 | main = 29 | interpret 30 | (Print 31 | "Please enter your name: " 32 | (GetLine (\name -> Print ("Hello, " ++ name ++ "!") (Return ())))) 33 | 34 | -------------------------------------------------------------------------------- 35 | -- Monadic 36 | 37 | main2 :: IO () 38 | main2 = 39 | interpret (do printline "Enter your name" 40 | line <- getline 41 | line2 <- getline 42 | printline ("Hi " ++ line ++ ", " ++ line2) 43 | return ()) 44 | 45 | printline :: String -> Terminal () 46 | printline str = Print str (Return ()) 47 | 48 | getline :: Terminal String 49 | getline = GetLine (\str -> Return str) 50 | 51 | instance Functor Terminal where 52 | fmap f = 53 | \case 54 | Return x -> Return (f x) 55 | Print str x -> Print str (fmap f x) 56 | GetLine g -> GetLine (\line -> fmap f (g line)) 57 | 58 | instance Applicative Terminal where 59 | (<*>) = ap 60 | pure = return 61 | 62 | instance Monad Terminal where 63 | return = Return 64 | m >>= f = 65 | case m of 66 | Return a -> f a 67 | GetLine g -> GetLine (\line -> g line >>= f) 68 | Print str m' -> Print str (m' >>= f) 69 | -------------------------------------------------------------------------------- /type-inequality-operator.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE DataKinds #-} 4 | 5 | -- Lets you write functions that accept all types but this specific 6 | -- one. 7 | 8 | import Data.Word 9 | 10 | type family a /~ b where 11 | a /~ a = 'False 12 | _ /~ _ = 'True 13 | 14 | foo :: (Integral i, i /~ Word8 ~ 'True) => i -> () 15 | foo = undefined 16 | 17 | bar = foo (undefined :: Int) 18 | 19 | -- As expected, the below is not allowed: 20 | -- bad = foo (undefined :: Word8) 21 | -------------------------------------------------------------------------------- /unboxed-vectors.hs: -------------------------------------------------------------------------------- 1 | -- This module demonstrates unboxed vectors. That means that they can 2 | -- contain only unboxable values. That's basically Int, Char, Bool, 3 | -- (Int,Int), etc. 4 | -- 5 | -- Use this one for efficiency when you are just using unboxable 6 | -- types. 7 | 8 | -- These vectors are stored as a byte array underneath: 9 | -- 10 | -- Each element is not garbage collected (just the whole array), and 11 | -- thus are very efficient. Your vector will probably fit in your CPU 12 | -- cache, meaning you don't have to talk to mainline memory to do your 13 | -- work. 14 | -- 15 | -- There's a list of values that are unboxed here: 16 | -- 17 | -- 18 | -- 19 | -- See Int#, Char#, etc. 20 | -- 21 | -- 22 | -- 1) Use unsafeFreeze to avoid copying. See its haddocks. 23 | -- 24 | -- 2) Use unsafeRead/unsafeWrite. These are, clearly, unsafe 25 | -- operations. Use your discretion. And write tests! Or better yet, 26 | -- use Liquid Haskell so that you have a proof of bounds checks. 27 | -- 28 | module Main where 29 | import Control.Monad.ST 30 | import qualified Data.Vector.Unboxed as V 31 | import qualified Data.Vector.Unboxed.Mutable as MV 32 | main :: IO () 33 | main = do 34 | -- Using the IO monad: 35 | vec <- 36 | do v <- MV.new 1 37 | MV.write v 0 (1 :: Int) 38 | V.freeze v 39 | print vec 40 | -- Using the ST monad: 41 | print 42 | (runST 43 | (do v <- MV.new 1 44 | MV.write v 0 (1 :: Int) 45 | V.freeze v)) 46 | 47 | -- Output: 48 | {- 49 | > main 50 | [1] 51 | [1] 52 | -} 53 | -------------------------------------------------------------------------------- /use-of-ghc-api.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE CPP #-} 3 | import GHC 4 | import GHC.Paths 5 | import DynFlags 6 | import Language.Haskell.TH.LanguageExtensions 7 | 8 | targetFile :: [Char] 9 | targetFile = "B.hs" 10 | 11 | main :: IO () 12 | main = do 13 | defaultErrorHandler defaultFatalMessager defaultFlushOut $ do 14 | runGhc (Just libdir) $ do 15 | dflags <- getSessionDynFlags 16 | let dflags' = foldl xopt_set dflags [ImplicitPrelude] 17 | _ <- setSessionDynFlags dflags' 18 | target <- guessTarget targetFile Nothing 19 | setTargets [target] 20 | _ <- load LoadAllTargets 21 | modSum <- getModSummary $ mkModuleName "B" 22 | p <- parseModule modSum 23 | t <- typecheckModule p 24 | pure () 25 | -------------------------------------------------------------------------------- /use-of-the-reflection-package.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, TypeApplications, UndecidableInstances, ScopedTypeVariables #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | Displays a type error, using context information given by the reflection Reifies. 5 | 6 | import Data.Tagged 7 | import qualified Data.ByteString.Lazy as L 8 | import Data.String 9 | import Data.Proxy 10 | import qualified Data.Map.Strict as M 11 | import Data.Map.Strict (Map) 12 | import Data.ByteString.Builder 13 | import Data.List 14 | import Data.Monoid 15 | import Data.Reflection 16 | 17 | class Display a where display :: a -> Builder 18 | 19 | data Type = IntType | StringType 20 | 21 | instance Display Type where 22 | display IntType = "Int" 23 | display StringType = "String" 24 | 25 | data TypeError = TypeMismatch Type Type [TypeError] 26 | 27 | instance Reifies s (Map String Type) => Display (Tagged s TypeError) where 28 | display (Tagged (TypeMismatch t1 t2 otherErrors)) = 29 | "Couldn't match " <> display t1 <> " against " <> display t2 <> 30 | "\nContext:\n" <> 31 | mconcat 32 | (intersperse 33 | "\n" 34 | (map 35 | (\(k, v) -> fromString k <> " :: " <> display v) 36 | (M.toList (reflect (Proxy @s))))) <> 37 | "\nOther errors:\n" <> 38 | mconcat (intersperse "\n" (map (display . tagWith (Proxy @s)) otherErrors)) 39 | 40 | main :: IO () 41 | main = 42 | L.putStr 43 | (toLazyByteString 44 | (reify 45 | (M.fromList [("x", IntType)]) 46 | (\s -> 47 | display 48 | (tagWith 49 | s 50 | (TypeMismatch 51 | IntType 52 | StringType 53 | [TypeMismatch StringType IntType []]))))) 54 | -------------------------------------------------------------------------------- /warp.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack 2 | -- stack --resolver lts-12.12 script 3 | {-# LANGUAGE OverloadedStrings #-} 4 | import Network.Wai 5 | import Network.HTTP.Types 6 | import Network.Wai.Handler.Warp (run) 7 | 8 | app :: Application 9 | app _ respond = do 10 | putStrLn "I've done some IO here" 11 | respond $ responseLBS 12 | status200 13 | [("Content-Type", "text/plain")] 14 | "Hello, Web!" 15 | 16 | main :: IO () 17 | main = do 18 | putStrLn $ "http://localhost:8080/" 19 | run 8080 app 20 | -------------------------------------------------------------------------------- /zeckendorf.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | -- | Simple implementation of zeckendorf's fibonacci numbers. 4 | 5 | import Data.Bits 6 | import Data.List 7 | import Numeric.Natural 8 | 9 | fibs :: [Natural] 10 | fibs = scanl (+) 1 (1 : fibs) 11 | 12 | -- | Maps a natural number to non-consecutive fibonacci numbers. 13 | zeck :: Natural -> [Natural] 14 | zeck n | n <= 2 = [n] 15 | zeck n = go (reverse (takeWhile (<= n) fibs)) 0 [] 16 | where 17 | go [] total xs = xs 18 | go (inf:infs) !total !outfs = 19 | case compare (total + inf) n of 20 | EQ -> inf : outfs 21 | LT -> go (drop 1 infs) (total + inf) (inf : outfs) 22 | GT -> go infs total outfs 23 | --------------------------------------------------------------------------------