├── .github └── workflows │ └── haskell.yml ├── .gitignore ├── LICENSE ├── LtuPatternFactory.cabal ├── README.md ├── package.yaml ├── renovate.json ├── src ├── AbstractFactory.hs ├── Adapter.hs ├── AspectPascal.hs ├── Builder.hs ├── CMarkGFMRenderer.hs ├── Category.hs ├── CheapskateRenderer.hs ├── Coerce.hs ├── Command.hs ├── Composite.hs ├── CuttingStock.hs ├── DataTransferObject.hs ├── DependencyInjection.hs ├── FluentApi.hs ├── HigherOrder.hs ├── IdiomBrackets.hs ├── Infinity.hs ├── Interpreter.hs ├── Iterator.hs ├── JsonPersistence.hs ├── Main.hs ├── MapReduce.hs ├── MiniPascal.hs ├── NullObject.hs ├── Pipeline.hs ├── Proxy.hs ├── Reflection.hs ├── SimplePersistence.hs ├── Singleton.hs ├── Strategy.hs ├── TemplateMethod.hs └── Visitor.hs └── stack.yaml /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: 4 | push: 5 | branches: [ master ] 6 | pull_request: 7 | branches: [ master ] 8 | 9 | jobs: 10 | build: 11 | 12 | runs-on: ubuntu-latest 13 | 14 | steps: 15 | - uses: actions/checkout@v2 16 | - uses: actions/setup-haskell@v1 17 | with: 18 | ghc-version: '8.10' 19 | cabal-version: '3.2' 20 | 21 | - name: Cache 22 | uses: actions/cache@v1 23 | env: 24 | cache-name: cache-cabal 25 | with: 26 | path: ~/.cabal 27 | key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} 28 | restore-keys: | 29 | ${{ runner.os }}-build-${{ env.cache-name }}- 30 | ${{ runner.os }}-build- 31 | ${{ runner.os }}- 32 | - name: Install dependencies 33 | run: | 34 | cabal update 35 | cabal build --only-dependencies --enable-tests --enable-benchmarks 36 | - name: Build 37 | run: cabal build --enable-tests --enable-benchmarks all 38 | - name: Run tests 39 | run: cabal test all 40 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | cabal.project.local~ 21 | .HTF/ 22 | .ghc.environment.* 23 | .idea 24 | *.iml 25 | cabal.config 26 | out/ 27 | *.lock 28 | *.txt 29 | *.json -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "[]" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright [yyyy] [name of copyright owner] 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /LtuPatternFactory.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.4. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 49436843f74952bc53c2de84ac6188dcab587551114ca7267c5e4f9f3ad2f987 8 | 9 | name: LtuPatternFactory 10 | version: 0.1.0.0 11 | synopsis: Comparing OO Design Patterns with Functional Programming concepts 12 | description: Please see the README on GitHub at 13 | category: Programming 14 | homepage: https://github.com/thma/LtuPatternFactory#readme 15 | bug-reports: https://github.com/thma/LtuPatternFactory/issues 16 | author: Thomas Mahler 17 | maintainer: thma@apache.org 18 | copyright: 2018 - 2021 Thomas Mahler 19 | license: Apache-2.0 20 | license-file: LICENSE 21 | build-type: Simple 22 | extra-source-files: 23 | README.md 24 | 25 | source-repository head 26 | type: git 27 | location: https://github.com/thma/LtuPatternFactory 28 | 29 | executable LtuPatternFactory 30 | main-is: Main.hs 31 | other-modules: 32 | AbstractFactory 33 | Adapter 34 | AspectPascal 35 | Builder 36 | Category 37 | CheapskateRenderer 38 | CMarkGFMRenderer 39 | Coerce 40 | Command 41 | Composite 42 | CuttingStock 43 | DataTransferObject 44 | DependencyInjection 45 | FluentApi 46 | HigherOrder 47 | IdiomBrackets 48 | Infinity 49 | Interpreter 50 | Iterator 51 | JsonPersistence 52 | MapReduce 53 | MiniPascal 54 | NullObject 55 | Pipeline 56 | Proxy 57 | Reflection 58 | SimplePersistence 59 | Singleton 60 | Strategy 61 | TemplateMethod 62 | Visitor 63 | Paths_LtuPatternFactory 64 | hs-source-dirs: 65 | src 66 | build-depends: 67 | aeson 68 | , aeson-pretty 69 | , base >=4.7 && <5 70 | , blaze-html 71 | , bytestring 72 | , cheapskate 73 | , cmark-gfm 74 | , comonad 75 | , containers 76 | , directory 77 | , mtl 78 | , parallel 79 | , tagged 80 | , text 81 | , time 82 | , zlib 83 | default-language: Haskell2010 84 | 85 | test-suite LtuPatternFactory-test 86 | type: exitcode-stdio-1.0 87 | main-is: Main.hs 88 | other-modules: 89 | AbstractFactory 90 | Adapter 91 | AspectPascal 92 | Builder 93 | Category 94 | CheapskateRenderer 95 | CMarkGFMRenderer 96 | Coerce 97 | Command 98 | Composite 99 | CuttingStock 100 | DataTransferObject 101 | DependencyInjection 102 | FluentApi 103 | HigherOrder 104 | IdiomBrackets 105 | Infinity 106 | Interpreter 107 | Iterator 108 | JsonPersistence 109 | MapReduce 110 | MiniPascal 111 | NullObject 112 | Pipeline 113 | Proxy 114 | Reflection 115 | SimplePersistence 116 | Singleton 117 | Strategy 118 | TemplateMethod 119 | Visitor 120 | Paths_LtuPatternFactory 121 | hs-source-dirs: 122 | src 123 | build-depends: 124 | aeson 125 | , aeson-pretty 126 | , base >=4.7 && <5 127 | , blaze-html 128 | , bytestring 129 | , cheapskate 130 | , cmark-gfm 131 | , comonad 132 | , containers 133 | , directory 134 | , mtl 135 | , parallel 136 | , tagged 137 | , text 138 | , zlib 139 | default-language: Haskell2010 140 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: LtuPatternFactory 2 | version: 0.1.0.0 3 | synopsis: Comparing OO Design Patterns with Functional Programming concepts 4 | homepage: https://github.com/thma/LtuPatternFactory#readme 5 | github: "thma/LtuPatternFactory" 6 | license: Apache-2.0 7 | license-file: LICENSE 8 | author: Thomas Mahler 9 | maintainer: thma@apache.org 10 | copyright: 2018 - 2021 Thomas Mahler 11 | category: Programming 12 | #build-type: Simple 13 | #cabal-version: >=1.10 14 | extra-source-files: README.md 15 | description: Please see the README on GitHub at 16 | 17 | 18 | 19 | dependencies: 20 | - base >= 4.7 && < 5 21 | 22 | executables: 23 | LtuPatternFactory: 24 | main: Main.hs 25 | source-dirs: src 26 | # ghc-options: 27 | # - -threaded 28 | # - -rtsopts 29 | # - -with-rtsopts=-N 30 | dependencies: 31 | # - LtuPatternFactory 32 | - containers 33 | - mtl 34 | - aeson 35 | - aeson-pretty 36 | - text 37 | - directory 38 | - bytestring 39 | - tagged 40 | - cmark-gfm 41 | - cheapskate 42 | - blaze-html 43 | - parallel 44 | - comonad 45 | - time 46 | - zlib 47 | 48 | tests: 49 | LtuPatternFactory-test: 50 | main: Main.hs 51 | source-dirs: src 52 | # ghc-options: 53 | # - -threaded 54 | # - -rtsopts 55 | # - -with-rtsopts=-N 56 | dependencies: 57 | # - LtuPatternFactory 58 | - containers 59 | - mtl 60 | - aeson 61 | - aeson-pretty 62 | - text 63 | - directory 64 | - bytestring 65 | - tagged 66 | - cmark-gfm 67 | - cheapskate 68 | - blaze-html 69 | - parallel 70 | - comonad 71 | - zlib 72 | -------------------------------------------------------------------------------- /renovate.json: -------------------------------------------------------------------------------- 1 | { 2 | "extends": [ 3 | "config:base" 4 | ] 5 | } 6 | -------------------------------------------------------------------------------- /src/AbstractFactory.hs: -------------------------------------------------------------------------------- 1 | module AbstractFactory where 2 | import System.Info (os) 3 | 4 | -- | representation of a Button UI widget 5 | data Button = Button 6 | { label :: String -- the text label of the button 7 | , render :: Button -> IO () -- a platform specific rendering action 8 | } 9 | 10 | -- | rendering a Button for the WIN platform (we just simulate it by printing the label) 11 | winPaint :: Button -> IO () 12 | winPaint btn = putStrLn $ "winButton: " ++ label btn 13 | 14 | -- | rendering a Button for the OSX platform 15 | osxPaint :: Button -> IO () 16 | osxPaint btn = putStrLn $ "osxButton: " ++ label btn 17 | 18 | -- | paint a button by using the Buttons render function 19 | paint :: Button -> IO () 20 | paint btn@(Button _ render) = render btn 21 | 22 | -- | a representation of the operating system platform 23 | data Platform = OSX | WIN | NIX | Other 24 | 25 | -- | determine Platform by inspecting System.Info.os string 26 | platform :: Platform 27 | platform = case os of 28 | "darwin" -> OSX 29 | "mingw32" -> WIN 30 | "linux" -> NIX 31 | _ -> Other 32 | 33 | -- | create a button for os platform with label lbl 34 | createButton :: String -> Button 35 | createButton lbl = case platform of 36 | OSX -> Button lbl osxPaint 37 | WIN -> Button lbl winPaint 38 | NIX -> Button lbl (\btn -> putStrLn $ "nixButton: " ++ label btn) 39 | Other -> Button lbl (\btn -> putStrLn $ "otherButton: " ++ label btn) 40 | 41 | abstractFactoryDemo = do 42 | putStrLn "AbstractFactory -> functions as data type values" 43 | let exit = createButton "Exit" -- using the "abstract" API to create buttons 44 | let ok = createButton "OK" 45 | paint ok -- using the "abstract" API to paint buttons 46 | paint exit 47 | 48 | paint $ Button "Apple" osxPaint -- paint a platform specific button 49 | paint $ Button "Pi" -- paint a user-defined button 50 | (\btn -> putStrLn $ "raspberryButton: " ++ label btn) 51 | -------------------------------------------------------------------------------- /src/Adapter.hs: -------------------------------------------------------------------------------- 1 | module Adapter where 2 | 3 | backend :: c -> d 4 | backend = undefined 5 | 6 | marshal :: a -> c 7 | marshal = undefined 8 | 9 | unmarshal :: d -> b 10 | unmarshal = undefined 11 | 12 | adapter :: a -> b 13 | adapter = unmarshal . backend . marshal 14 | 15 | -- a 24:00 hour clock representation of time 16 | newtype WallTime = WallTime (Int, Int) deriving (Show) 17 | 18 | -- this is our backend. It can add minutes to a WallTime representation 19 | addMinutesToWallTime :: Int -> WallTime -> WallTime 20 | addMinutesToWallTime x (WallTime (h, m)) = 21 | let (hAdd, mAdd) = x `quotRem` 60 22 | hNew = h + hAdd 23 | mNew = m + mAdd 24 | in if mNew >= 60 25 | then 26 | let (dnew, hnew') = (hNew + 1) `quotRem` 24 27 | in WallTime (24*dnew + hnew', mNew-60) 28 | else WallTime (hNew, mNew) 29 | 30 | -- this is our time representation in Minutes that we want to use in the frontend 31 | newtype Minute = Minute Int deriving (Show) 32 | 33 | -- convert a Minute value into a WallTime representation 34 | marshalMW :: Minute -> WallTime 35 | marshalMW (Minute x) = 36 | let (h,m) = x `quotRem` 60 37 | in WallTime (h `rem` 24, m) 38 | 39 | -- convert a WallTime value back to Minutes 40 | unmarshalWM :: WallTime -> Minute 41 | unmarshalWM (WallTime (h,m)) = Minute $ 60 * h + m 42 | 43 | -- this is our frontend that add Minutes to a time of a day 44 | -- measured in minutes 45 | addMinutesAdapter :: Int -> Minute -> Minute 46 | addMinutesAdapter x = unmarshalWM . addMinutesToWallTime x . marshalMW 47 | 48 | adapterDemo = do 49 | putStrLn "Adapter -> function composition" 50 | print $ addMinutesAdapter 100 $ Minute 400 51 | putStrLn "" 52 | -------------------------------------------------------------------------------- /src/AspectPascal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module AspectPascal where 3 | import Control.Monad.Reader 4 | import Control.Monad.State 5 | import Control.Monad.Writer 6 | import Data.Map (Map) 7 | import qualified Data.Map as Map (lookup, insert, fromList) 8 | import MiniPascal (Id, IExp (..), BExp (..), Stmt (..), Store (..) 9 | , program, demo, getVar, setVar) 10 | 11 | data JoinPointDesc = Get Id | Set Id 12 | 13 | data PointCut = Setter 14 | | Getter 15 | | AtVar Id 16 | | NotAt PointCut 17 | | PointCut :||: PointCut 18 | | PointCut :&&: PointCut 19 | 20 | includes :: PointCut -> (JoinPointDesc -> Bool) 21 | includes Setter (Set i) = True 22 | includes Getter (Get i) = True 23 | includes (AtVar i) (Get j) = i == j 24 | includes (AtVar i) (Set j) = i == j 25 | includes (NotAt p) d = not (includes p d) 26 | includes (p :||: q) d = includes p d || includes q d 27 | includes (p :&&: q) d = includes p d && includes q d 28 | includes _ _ = False 29 | 30 | data Advice = Before PointCut Stmt 31 | | After PointCut Stmt 32 | 33 | -- the countSets Advice traces each setting of a variable and increments the counter "countSet" 34 | countSets = After (Setter :&&: NotAt (AtVar "countSet") :&&: NotAt (AtVar "countGet")) 35 | ("countSet" := (IVar "countSet" :+: Lit 1)) 36 | 37 | -- the countGets Advice traces each lookup of a variable and increments the counter "countGet" 38 | countGets = After (Getter :&&: NotAt (AtVar "countSet") :&&: NotAt (AtVar "countGet")) 39 | ("countGet" := (IVar "countGet" :+: Lit 1)) 40 | 41 | type Aspects = [Advice] 42 | 43 | iexp :: MonadState Store m => IExp -> ReaderT Aspects m Int 44 | iexp (Lit n) = return n 45 | iexp (e1 :+: e2) = liftM2 (+) (iexp e1) (iexp e2) 46 | iexp (e1 :*: e2) = liftM2 (*) (iexp e1) (iexp e2) 47 | iexp (e1 :-: e2) = liftM2 (-) (iexp e1) (iexp e2) 48 | iexp (e1 :/: e2) = liftM2 div (iexp e1) (iexp e2) 49 | iexp (IVar i) = withAdvice (Get i) (getVar i) 50 | 51 | bexp :: MonadState Store m => BExp -> ReaderT Aspects m Bool 52 | bexp T = return True 53 | bexp F = return False 54 | bexp (Not b) = fmap not (bexp b) 55 | bexp (b1 :&: b2) = liftM2 (&&) (bexp b1) (bexp b2) 56 | bexp (b1 :|: b2) = liftM2 (||) (bexp b1) (bexp b2) 57 | bexp (e1 :=: e2) = liftM2 (==) (iexp e1) (iexp e2) 58 | bexp (e1 :<: e2) = liftM2 (<) (iexp e1) (iexp e2) 59 | 60 | stmt :: MonadState Store m => Stmt -> ReaderT Aspects m () 61 | stmt Skip = return () 62 | stmt (i := e) = do x <- iexp e; withAdvice (Set i) (setVar i x) 63 | stmt (Begin ss) = mapM_ stmt ss 64 | stmt (If b t e) = do 65 | x <- bexp b 66 | if x then stmt t 67 | else stmt e 68 | stmt (While b t) = loop 69 | where loop = do 70 | x <- bexp b 71 | when x $ stmt t >> loop 72 | 73 | withAdvice :: MonadState Store m => JoinPointDesc -> ReaderT Aspects m a -> ReaderT Aspects m a 74 | withAdvice joinPoint action = do 75 | aspects <- ask 76 | mapM_ stmt (before joinPoint aspects) 77 | x <- action 78 | mapM_ stmt (after joinPoint aspects) 79 | return x 80 | 81 | before, after :: JoinPointDesc -> Aspects -> [Stmt] 82 | before joinPoint aspects = [s | Before pointCut s <- aspects, includes pointCut joinPoint] 83 | after joinPoint aspects = [s | After pointCut s <- aspects, includes pointCut joinPoint] 84 | 85 | run :: Aspects -> Stmt -> Store 86 | run a s = execState (runReaderT (stmt s) a) (Map.fromList []) 87 | 88 | aspectPascalDemo :: IO () 89 | aspectPascalDemo = do 90 | putStrLn "Aspect Weaving -> Monad Transformers" 91 | demo (run [countSets] program) 92 | demo (run [countGets] program) 93 | demo (run [countSets, countGets] program) 94 | putStrLn "" -------------------------------------------------------------------------------- /src/Builder.hs: -------------------------------------------------------------------------------- 1 | module Builder where 2 | 3 | -- accountNo, Name, branch, balance, interestRate 4 | data BankAccount = BankAccount { 5 | accountNo :: Int 6 | , name :: String 7 | , branch :: String 8 | , balance :: Double 9 | , interestRate :: Double 10 | } deriving (Show) 11 | 12 | buildAccount :: Int -> BankAccount 13 | buildAccount i = BankAccount i "Dummy Customer" "London" 0 0 14 | 15 | builderDemo = do 16 | putStrLn "Builder -> record syntax, smart constructor" 17 | let account = buildAccount 1234 18 | print account 19 | let account1 = account {name="Marjin Mejer", branch="Paris", balance=10000, interestRate=2} 20 | print account1 21 | 22 | let account2 = BankAccount { 23 | accountNo = 5678 24 | , name = "Marjin Mejer" 25 | , branch = "Reikjavik" 26 | , balance = 1000 27 | , interestRate = 2.5 28 | } 29 | print account2 30 | 31 | -------------------------------------------------------------------------------- /src/CMarkGFMRenderer.hs: -------------------------------------------------------------------------------- 1 | module CMarkGFMRenderer where 2 | import qualified CMarkGFM as CM 3 | import qualified Data.Text as T 4 | 5 | type MarkDown = T.Text 6 | type HTML = T.Text 7 | 8 | textToMarkDown :: T.Text -> MarkDown 9 | textToMarkDown = CM.commonmarkToHtml [] [] 10 | 11 | markDownToHtml :: MarkDown -> HTML 12 | markDownToHtml = id 13 | 14 | htmlToText :: HTML -> T.Text 15 | htmlToText = id 16 | -------------------------------------------------------------------------------- /src/Category.hs: -------------------------------------------------------------------------------- 1 | module Category where 2 | 3 | import qualified GHC.Base (id,(.)) 4 | import Control.Monad ((>=>)) 5 | 6 | class Category cat where 7 | -- | the identity morphism 8 | id :: cat a a 9 | 10 | -- | morphism composition 11 | (.) :: cat b c -> cat a b -> cat a c 12 | 13 | instance Category (->) where 14 | id = GHC.Base.id 15 | (.) = (GHC.Base..) 16 | 17 | -- | Kleisli monad. 18 | newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b } 19 | 20 | -- | Kleisli category 21 | instance Monad m => Category (Kleisli m) where 22 | id = Kleisli return 23 | (Kleisli f) . (Kleisli g) = Kleisli (g >=> f) 24 | -------------------------------------------------------------------------------- /src/CheapskateRenderer.hs: -------------------------------------------------------------------------------- 1 | module CheapskateRenderer 2 | ( MarkDown 3 | , HTML 4 | , textToMarkDown 5 | , markDownToHtml 6 | , htmlToText 7 | ) where 8 | 9 | import qualified Cheapskate as C 10 | import qualified Data.Text as T 11 | import qualified Text.Blaze.Html as H 12 | import qualified Text.Blaze.Html.Renderer.Pretty as R 13 | 14 | -- | a type synonym that hides the Cheapskate internal Doc type 15 | type MarkDown = C.Doc 16 | 17 | -- | a type synonym the hides the Blaze.Html internal Html type 18 | type HTML = H.Html 19 | 20 | -- | parse Markdown from a Text (with markdown markup). Using the Cheapskate library. 21 | textToMarkDown :: T.Text -> MarkDown 22 | textToMarkDown = C.markdown C.def 23 | 24 | -- | convert MarkDown to HTML by using the Blaze.Html library 25 | markDownToHtml :: MarkDown -> HTML 26 | markDownToHtml = H.toHtml 27 | 28 | -- | rendering a Text with html markup from HTML. Using Blaze again. 29 | htmlToText :: HTML -> T.Text 30 | htmlToText = T.pack . R.renderHtml 31 | -------------------------------------------------------------------------------- /src/Coerce.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | module Coerce where 8 | 9 | import Control.Applicative 10 | import Control.Monad.State.Lazy 11 | import Data.Functor.Compose 12 | import Data.Functor.Const 13 | import Data.Functor.Product 14 | import Data.Monoid (Sum (..), getSum) 15 | import Data.Typeable 16 | 17 | -- | This module provides explicit coercion. 18 | -- Instead of the "magic" Data.Coerce.coerce you could use wrap and unwrap to explicitly write the coercions. 19 | class Coerce a b | a -> b where 20 | unwrap :: a -> b 21 | wrap :: b -> a 22 | 23 | instance Coerce (Const a b) a where 24 | unwrap = getConst 25 | wrap = Const 26 | 27 | instance Coerce (Sum a) a where 28 | unwrap = getSum 29 | wrap = Sum 30 | 31 | instance (Coerce (m a) b, Coerce (n a) c) => 32 | Coerce ((Product m n) a) (b, c) where 33 | unwrap mnx = (unwrap (pfst mnx), unwrap (psnd mnx)) 34 | where 35 | pfst (Pair fst _) = fst 36 | psnd (Pair _ snd) = snd 37 | wrap (x, y) = Pair (wrap x) (wrap y) 38 | 39 | instance (Functor m, Functor n, Coerce (m b) c, Coerce (n a) b) => 40 | Coerce ((Compose m n) a) c where 41 | unwrap = unwrap . fmap unwrap . getCompose 42 | wrap = Compose . fmap wrap . wrap 43 | 44 | instance Coerce (m a) c => Coerce (WrappedMonad m a) c where 45 | unwrap = unwrap . unwrapMonad 46 | wrap = WrapMonad . wrap 47 | 48 | instance Coerce (State s a) (s -> (a, s)) where 49 | unwrap = runState 50 | wrap = state 51 | -------------------------------------------------------------------------------- /src/Command.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Command where 3 | import Control.Monad.Writer 4 | 5 | data Light = Light { 6 | turnOn :: IO String 7 | , turnOff :: IO String 8 | } 9 | 10 | simpleLamp = Light { 11 | turnOn = putStrLn "The Light is on" >> return "on" 12 | , turnOff = putStrLn "The Light is off" >> return "off" 13 | } 14 | 15 | flipUpCommand :: Light -> IO String 16 | flipUpCommand = turnOn 17 | 18 | flipDownCommand :: Light -> IO String 19 | flipDownCommand = turnOff 20 | 21 | storeAndExecute :: IO String -> WriterT[String] IO () 22 | storeAndExecute command = do 23 | logEntry <- liftIO command 24 | tell [logEntry] 25 | 26 | commandDemo :: IO () 27 | commandDemo = do 28 | putStrLn "Command -> higher order functions" 29 | let lamp = simpleLamp 30 | result <- execWriterT $ 31 | storeAndExecute (flipUpCommand lamp) >> 32 | storeAndExecute (flipDownCommand lamp) >> 33 | storeAndExecute (flipUpCommand lamp) 34 | putStrLn $ "switch history: " ++ show result 35 | -------------------------------------------------------------------------------- /src/Composite.hs: -------------------------------------------------------------------------------- 1 | module Composite where 2 | import Data.Semigroup (All (..)) 3 | 4 | -- the composite data structure: a Test can be Empty, a single TestCase 5 | -- or a TestSuite holding a list of Tests 6 | data Test = Empty 7 | | TestCase TestCase 8 | | TestSuite [Test] 9 | 10 | -- a test case produces a boolean when executed 11 | type TestCase = () -> Bool 12 | 13 | 14 | -- execution of a Test. 15 | run :: Test -> Bool 16 | run Empty = True 17 | run (TestCase t) = t () -- evaluating the TestCase by applying t to () 18 | --run (TestSuite l) = foldr ((&&) . run) True l 19 | run (TestSuite l) = all (True ==) (map run l) -- running all tests in l and return True if all tests pass 20 | 21 | 22 | -- addTesting Tests 23 | addTest :: Test -> Test -> Test 24 | addTest Empty t = t 25 | addTest t Empty = t 26 | addTest t1@(TestCase _) t2@(TestCase _) = TestSuite [t1,t2] 27 | addTest t1@(TestCase _) (TestSuite list) = TestSuite ([t1] ++ list) 28 | addTest (TestSuite list) t2@(TestCase _) = TestSuite (list ++ [t2]) 29 | addTest (TestSuite l1) (TestSuite l2) = TestSuite (l1 ++ l2) 30 | 31 | 32 | -- in order to make Test an instance of Monoid, we have to provide 33 | -- an operator <> which is required to be associative 34 | -- and a neutral element mempty 35 | instance Semigroup Test where 36 | (<>) = addTest 37 | instance Monoid Test where 38 | mempty = Empty 39 | 40 | -- a few most simple test cases 41 | t1 :: Test 42 | t1 = TestCase (\() -> True) 43 | t2 :: Test 44 | t2 = TestCase (\() -> True) 45 | t3 :: Test 46 | t3 = TestCase (\() -> False) 47 | -- collecting all test cases in a TestSuite 48 | ts = TestSuite [t1,t2,t3] 49 | 50 | 51 | type SmartTestCase = () -> All 52 | 53 | tc1 :: SmartTestCase 54 | tc1 () = All True 55 | tc2 :: SmartTestCase 56 | tc2 () = All True 57 | tc3 :: SmartTestCase 58 | tc3 () = All False 59 | 60 | run' :: SmartTestCase -> Bool 61 | run' tc = getAll $ tc () 62 | 63 | compositeDemo = do 64 | putStrLn "Composite -> SemiGroup -> Monoid" 65 | 66 | print $ run $ t1 <> t2 67 | print $ run $ t1 <> t2 <> t3 68 | 69 | print $ run $ mconcat [t1,t2] 70 | print $ run $ mconcat [t1,t2,t3] 71 | 72 | print $ run' tc1 73 | print $ run' $ mconcat [tc1,tc2] 74 | print $ run' $ mconcat [tc1,tc2,tc3] 75 | -------------------------------------------------------------------------------- /src/CuttingStock.hs: -------------------------------------------------------------------------------- 1 | module CuttingStock where 2 | 3 | import Data.Ord 4 | import Data.List 5 | -- https://en.wikipedia.org/wiki/Cutting_stock_problem 6 | 7 | type Rect = (Double, Double) 8 | 9 | len :: Rect -> Double 10 | len = fst 11 | 12 | width :: Rect -> Double 13 | width = snd 14 | 15 | size :: Rect -> Double 16 | size rect = width rect * len rect 17 | 18 | weightedLength :: Rect -> Double 19 | weightedLength (len, wid) = len^2 * wid 20 | 21 | weightedWidth :: Rect -> Double 22 | weightedWidth (len, wid) = len * wid^2 23 | 24 | arrange :: Double -> [Rect] -> [[Rect]] 25 | arrange _ [] = [[]] 26 | arrange maxWidth rects = let (rest, row) = fillRow maxWidth (rects, []) 27 | in if null rest 28 | then [row] 29 | else row : arrange maxWidth rest 30 | 31 | fillRow :: Double -> ([Rect], [Rect]) -> ([Rect], [Rect]) 32 | fillRow _ current@([], _) = current 33 | fillRow maxWidth current@(x:xs, row) = 34 | if (width x) + (totalWidth row) <= maxWidth 35 | then fillRow maxWidth (xs, row ++ [x]) 36 | else current 37 | 38 | totalWidth :: [Rect] -> Double 39 | totalWidth = foldr ((+) . width) 0 40 | 41 | totalLength :: [Rect] -> Double 42 | totalLength = foldr ((+) . len) 0 43 | 44 | maxLength :: [Rect] -> Double 45 | maxLength = maximum . map len 46 | 47 | rects :: [Rect] 48 | rects = [(100,60),(120,60),(80,40),(120,40)] 49 | 50 | type WeightFunction = Rect -> Double 51 | 52 | arrangeWith :: WeightFunction -> Double-> [Rect] -> [[Rect]] 53 | arrangeWith weightFun maxWidth rects = 54 | let preorderedRects = sortOn (Down . weightFun) rects 55 | in arrange maxWidth preorderedRects 56 | 57 | weightFunctions = [len,width,size,weightedLength,weightedWidth] 58 | 59 | arrangeWithAll :: [WeightFunction] -> Double -> [Rect] -> [[Rect]] 60 | arrangeWithAll allFuns maxWidth rects = 61 | let allTrials = map (\f -> arrangeWith f maxWidth rects) allFuns 62 | weightedTrials = map (\l -> (l, sum (map maxLength l))) allTrials 63 | sortedTrials = sortOn snd weightedTrials 64 | in fst $ head sortedTrials -------------------------------------------------------------------------------- /src/DataTransferObject.hs: -------------------------------------------------------------------------------- 1 | module DataTransferObject where 2 | 3 | import Codec.Compression.GZip 4 | import Data.ByteString.Lazy.Char8 hiding (map) 5 | import Control.Arrow ((>>>)) 6 | 7 | data Album = Album { 8 | title :: String 9 | , publishDate :: Int 10 | , labelName :: String 11 | , artist :: Artist 12 | } deriving (Show) 13 | 14 | data Artist = Artist { 15 | publicName :: String 16 | , realName :: Maybe String 17 | } deriving (Show) 18 | 19 | data AlbumDTO = AlbumDTO { 20 | albumTitle :: String 21 | , published :: Int 22 | , label :: String 23 | , artistName :: String 24 | } deriving (Show, Read) 25 | 26 | toAlbumDTO :: Album -> AlbumDTO 27 | toAlbumDTO Album {title = t, publishDate = d, labelName = l, artist = a} = 28 | AlbumDTO {albumTitle = t, published = d, label = l, artistName = (publicName a)} 29 | 30 | toAlbum :: AlbumDTO -> Album 31 | toAlbum AlbumDTO {albumTitle = t, published = d, label = l, artistName = n} = 32 | Album {title = t, publishDate = d, labelName = l, artist = Artist {publicName = n, realName = Nothing}} 33 | 34 | albums :: [Album] 35 | albums = 36 | [ 37 | Album {title = "Microgravity", 38 | publishDate = 1991, 39 | labelName = "Origo Sound", 40 | artist = Artist {publicName = "Biosphere", realName = Just "Geir Jenssen"}} 41 | , Album {title = "Apollo - Atmospheres & Soundtracks", 42 | publishDate = 1983, 43 | labelName = "Editions EG", 44 | artist = Artist {publicName = "Brian Eno", realName = Just "Brian Peter George St. John le Baptiste de la Salle Eno"}} 45 | ] 46 | 47 | album1 = albums !! 0 48 | album2 = albums !! 1 49 | 50 | dTODemo :: IO () 51 | dTODemo = do 52 | print "DataTransferObject -> Functor" 53 | print albums 54 | 55 | let albumDTOs = fmap toAlbumDTO albums 56 | print albumDTOs 57 | 58 | let albums = fmap toAlbum albumDTOs 59 | print albums 60 | 61 | let singlemarshalled = (show . toAlbumDTO) album1 62 | let gzipped = (compress . pack . show . toAlbumDTO) album1 63 | 64 | let marshalled = fmap (toAlbumDTO >>> show >>> pack >>> compress) albums 65 | let unmarshalled = fmap (decompress >>> unpack >>> read >>> toAlbum) marshalled 66 | 67 | print marshalled 68 | print unmarshalled 69 | 70 | -------------------------------------------------------------------------------- /src/DependencyInjection.hs: -------------------------------------------------------------------------------- 1 | module DependencyInjection where 2 | import CheapskateRenderer (HTML, MarkDown, htmlToText, markDownToHtml, textToMarkDown) 3 | --import CMarkGFMRenderer (HTML, MarkDown, textToMarkDown, markDownToHtml, htmlToText) 4 | import Control.Category ((>>>)) -- f >>> g = g . f 5 | import qualified Data.Text as T 6 | 7 | 8 | -- | a table of contents consists of a heading and a list of entries 9 | data TableOfContents = Section Heading [TocEntry] 10 | 11 | -- | a ToC entry can be a heading or a sub-table of contents 12 | data TocEntry = Head Heading | Sub TableOfContents 13 | 14 | -- | a heading can be just a title string or an url with a title and the actual link 15 | data Heading = Title String | Url String String 16 | 17 | -- | render a ToC entry as a Markdown String with the proper indentation 18 | teToMd :: Int -> TocEntry -> String 19 | teToMd depth (Head head) = headToMd depth head 20 | teToMd depth (Sub toc) = tocToMd depth toc 21 | 22 | -- | render a heading as a Markdown String with the proper indentation 23 | headToMd :: Int -> Heading -> String 24 | headToMd depth (Title str) = indent depth ++ "* " ++ str ++ "\n" 25 | headToMd depth (Url title url) = indent depth ++ "* [" ++ title ++ "](" ++ url ++ ")\n" 26 | 27 | -- | convert a ToC to Markdown String. The parameter depth is used for proper indentation. 28 | tocToMd :: Int -> TableOfContents -> String 29 | tocToMd depth (Section heading entries) = headToMd depth heading ++ concatMap (teToMd (depth+2)) entries 30 | 31 | -- | produce a String of length n, consisting only of blanks 32 | indent :: Int -> String 33 | indent n = replicate n ' ' 34 | 35 | -- | render a ToC as a Text (consisting of properly indented Markdown) 36 | tocToMDText :: TableOfContents -> T.Text 37 | tocToMDText = T.pack . tocToMd 0 38 | 39 | -- | render a ToC as a Text with html markup. 40 | -- we specify this function as a chain of parse and rendering functions that must be provided externally 41 | tocToHtmlText :: (TableOfContents -> T.Text) -- 1. a renderer function from ToC to Text with markdown markups 42 | -> (T.Text -> MarkDown) -- 2. a parser function from Text to a MarkDown document 43 | -> (MarkDown -> HTML) -- 3. a renderer function from MarkDown to an HTML document 44 | -> (HTML -> T.Text) -- 4. a renderer function from HTML to Text 45 | -> TableOfContents -- the actual ToC to be rendered 46 | -> T.Text -- the Text output (containing html markup) 47 | tocToHtmlText tocToMdText textToMd mdToHtml htmlToText = 48 | tocToMdText >>> -- 1. render a ToC as a Text (consisting of properly indented Markdown) 49 | textToMd >>> -- 2. parse text with Markdown to a MarkDown data structure 50 | mdToHtml >>> -- 3. convert the MarkDown data to an HTML data structure 51 | htmlToText -- 4. render the HTML data to a Text with hmtl markup 52 | 53 | 54 | -- | a default implementation of a ToC to html Text renderer. 55 | -- this function is constructed by partially applying `tocToHtmlText` 56 | -- to four functions matching the signature of `tocToHtmlText`. 57 | defaultTocToHtmlText :: TableOfContents -> T.Text 58 | defaultTocToHtmlText = 59 | tocToHtmlText 60 | tocToMDText -- the ToC to markdown Text renderer as defined above 61 | textToMarkDown -- a MarkDown parser, externally provided via import 62 | markDownToHtml -- a MarkDown to HTML renderer, externally provided via import 63 | htmlToText -- a HTML to Text with html markup, externally provided via import 64 | 65 | demoDI = do 66 | let toc = Section (Title "Chapter 1") 67 | [ Sub $ Section (Title "Section a") 68 | [Head $ Title "First Heading", 69 | Head $ Url "Second Heading" "http://the.url"] 70 | , Sub $ Section (Url "Section b" "http://the.section.b.url") 71 | [ Sub $ Section (Title "UnderSection b1") 72 | [Head $ Title "First", Head $ Title "Second"]]] 73 | 74 | putStrLn $ T.unpack $ tocToMDText toc 75 | 76 | putStrLn $ T.unpack $ defaultTocToHtmlText toc 77 | -------------------------------------------------------------------------------- /src/FluentApi.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, InstanceSigs #-} 2 | module FluentApi where 3 | import Control.Comonad 4 | import Control.Arrow 5 | 6 | {-- 7 | instance {-# OVERLAPPING #-} Comonad ((->) Options) where 8 | extract :: (Options -> config) -> config 9 | extract builder = builder mempty 10 | extend :: ((Options -> config) -> config') -> (Options -> config) -> (Options -> config') 11 | extend withFun builder opt2 = withFun (\opt1 -> builder (opt1 ++ opt2)) 12 | --} 13 | 14 | type Options = [String] 15 | 16 | newtype Config = Conf Options deriving (Show) 17 | 18 | type ConfigBuilder = Options -> Config 19 | 20 | configBuilder :: Options -> Config 21 | configBuilder = Conf 22 | 23 | withWarnings' :: ConfigBuilder -> Config 24 | withWarnings' builder = builder ["-Wall"] 25 | 26 | withProfiling' :: ConfigBuilder -> Config 27 | withProfiling' builder = builder ["-prof", "-auto-all"] 28 | 29 | withOptimization' :: ConfigBuilder -> Config 30 | withOptimization' builder = builder ["-O2"] 31 | 32 | withLogging' :: ConfigBuilder -> Config 33 | withLogging' builder = builder ["-logall"] 34 | 35 | -- ConfigBuilder -> ConfigBuilder versions 36 | withWarnings :: ConfigBuilder -> (Options -> Config) 37 | withWarnings builder opts = builder (opts ++ ["-Wall"]) 38 | 39 | withProfiling :: ConfigBuilder -> ConfigBuilder 40 | withProfiling builder opts = builder (opts ++ ["-prof", "-auto-all"]) 41 | 42 | withOptimization :: ConfigBuilder -> ConfigBuilder 43 | withOptimization builder opts = builder (opts ++ ["-O2"]) 44 | 45 | withLogging :: ConfigBuilder -> ConfigBuilder 46 | withLogging builder opts = builder (opts ++ ["-logall"]) 47 | 48 | -- factoring out the option concatenation 49 | withLogging'' :: ConfigBuilder -> ConfigBuilder 50 | withLogging'' builder = extend' builder ["-logall"] 51 | 52 | extend' :: ConfigBuilder -> Options -> ConfigBuilder 53 | --extend' builder opts2 = \opts1 -> builder (opts1 ++ opts2) 54 | extend' builder opts2 opts1 = builder (opts1 ++ opts2) 55 | 56 | extend'' :: (ConfigBuilder -> Config) -> ConfigBuilder -> ConfigBuilder 57 | extend'' withFun builder opt2 = withFun (\opt1 -> builder (opt1 ++ opt2)) 58 | 59 | 60 | build :: ConfigBuilder -> Config 61 | build builder = builder mempty 62 | 63 | 64 | (#) :: a -> (a -> b) -> b 65 | x # f = f x 66 | infixl 0 # 67 | 68 | (#>) :: Comonad w => w a -> (w a -> b) -> w b 69 | x #> f = extend f x 70 | infixl 0 #> 71 | 72 | (#>>) :: ConfigBuilder -> (ConfigBuilder -> Config) -> ConfigBuilder 73 | x #>> f = extend'' f x 74 | infixl 0 #>> 75 | 76 | data User = User { 77 | userId :: String 78 | , name :: String 79 | , email :: String 80 | } deriving Show 81 | 82 | emptyUser = User "" "" "" 83 | 84 | setId :: String -> User -> User 85 | setId id user = user {userId = id} 86 | 87 | setName :: String -> User -> User 88 | setName name user = user {name = name} 89 | 90 | setMail :: String -> User -> User 91 | setMail mail user = user {email = mail} 92 | 93 | fluentApiDemo :: IO () 94 | fluentApiDemo = do 95 | putStrLn "FluentApi -> Comonad" 96 | 97 | print $ build $ withOptimization $ withProfiling configBuilder 98 | 99 | configBuilder 100 | #>> withProfiling' 101 | #>> withOptimization' 102 | #>> withLogging' 103 | # build 104 | # print 105 | 106 | configBuilder 107 | #> withProfiling' 108 | #> withOptimization' 109 | #> withLogging' 110 | # extract 111 | # print 112 | 113 | configBuilder 114 | # withProfiling 115 | # withOptimization 116 | # withLogging 117 | # withWarnings 118 | # build 119 | # print 120 | 121 | emptyUser 122 | # setId "4610" 123 | # setName "tom" 124 | # setMail "tom@haskell.tv" 125 | # print 126 | -------------------------------------------------------------------------------- /src/HigherOrder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | module HigherOrder where 3 | 4 | import Prelude hiding (sum, product, map, filter) 5 | --import Data.List (unfoldr) 6 | 7 | type Lookup key value = key -> Maybe value 8 | 9 | nada :: Lookup k v 10 | nada _ = Nothing 11 | 12 | abc :: Num v => Lookup String v 13 | abc "a" = Just 1 14 | abc "b" = Just 2 15 | abc "c" = Just 3 16 | abc _ = Nothing 17 | 18 | 19 | put :: Eq k => k -> v -> Lookup k v -> Lookup k v 20 | put k v lookup = 21 | \key -> if key == k 22 | then Just v 23 | else lookup key 24 | 25 | -- 26 | sum :: Num a => [a] -> a 27 | sum [] = 0 28 | sum (x:xs) = x + sum xs 29 | 30 | product :: Num a => [a] -> a 31 | product [] = 1 32 | product (x:xs) = x * product xs 33 | 34 | map :: (a -> b) -> [a] -> [b] 35 | map _ [] = [] 36 | map f (x:xs) = f x : map f xs 37 | 38 | filter :: (a -> Bool) -> [a] -> [a] 39 | filter _ [] = [] 40 | filter p (x:xs) = if p x then x : filter p xs else filter p xs 41 | 42 | foldr :: (a -> b -> b) -> b -> [a] -> b 43 | foldr fn z [] = z 44 | foldr fn z (x:xs) = fn x y 45 | where y = HigherOrder.foldr fn z xs 46 | 47 | sum' :: Num a => [a] -> a 48 | sum' = HigherOrder.foldr (+) 0 49 | 50 | product' :: Num a => [a] -> a 51 | product' = HigherOrder.foldr (*) 1 52 | 53 | map' :: (a -> b) -> [a] -> [b] 54 | map' f = HigherOrder.foldr ((:) . f) [] 55 | 56 | filter' :: (a -> Bool) -> [a] -> [a] 57 | filter' p = HigherOrder.foldr (\x xs -> if p x then x : xs else xs) [] 58 | 59 | data Tree a = Leaf 60 | | Node a (Tree a) (Tree a) deriving (Foldable) 61 | 62 | sumTree :: Num a => Tree a -> a 63 | sumTree Leaf = 0 64 | sumTree (Node x l r) = x + sumTree l + sumTree r 65 | 66 | productTree :: Num a => Tree a -> a 67 | productTree Leaf = 1 68 | productTree (Node x l r) = x * sumTree l * sumTree r 69 | 70 | foldTree :: (a -> b -> b) -> b -> Tree a -> b 71 | foldTree f z Leaf = z 72 | foldTree f z (Node a left right) = foldTree f z' left where 73 | z' = f a z'' 74 | z'' = foldTree f z right 75 | 76 | sumTree' = foldTree (+) 0 77 | productTree' = foldTree (*) 1 78 | 79 | 80 | unfoldr :: (b -> Maybe (a, b)) -> b -> [a] 81 | unfoldr f u = case f u of 82 | Nothing -> [] 83 | Just (x, v) -> x:(unfoldr f v) 84 | 85 | 86 | fact = Prelude.foldr (*) 1 . unfoldr (\n -> if n ==0 then Nothing else Just (n, n-1)) 87 | 88 | fibs = unfoldr (\(a, b) -> Just (a, (b, a + b))) (0, 1) 89 | 90 | bubble :: Ord a => [a] -> Maybe (a, [a]) 91 | bubble = Prelude.foldr step Nothing where 92 | step x Nothing = Just (x, []) 93 | step x (Just (y, ys)) 94 | | x < y = Just (x, y:ys) 95 | | otherwise = Just (y, x:ys) 96 | 97 | bubbleSort :: Ord a => [a] -> [a] 98 | bubbleSort = unfoldr bubble 99 | 100 | 101 | higherOrderDemo :: IO () 102 | higherOrderDemo = do 103 | putStrLn "higher order functions" 104 | let get = put "a" 1 (const Nothing) 105 | get' = put "b" 2 get 106 | get'' = put "c" 3 get' 107 | print $ get'' "a" 108 | print $ get'' "b" 109 | print $ get'' "c" 110 | print $ get'' "d" 111 | 112 | print $ sum' [1..10] 113 | print $ product' [1..10] 114 | print $ map' (*2) [1..10] 115 | print $ filter' even [1..10] 116 | 117 | let tree = Node 2 (Node 3 Leaf Leaf) (Node 4 Leaf Leaf) 118 | print $ sumTree tree 119 | print $ sumTree' tree 120 | print $ Prelude.foldr (+) 0 tree 121 | 122 | print $ productTree tree 123 | print $ productTree' tree 124 | print $ Prelude.foldr (*) 1 tree 125 | 126 | 127 | print $ unfoldr (\n -> if n==0 then Nothing else Just (n, n-1)) 10 128 | print $ fact 10 129 | print $ take 20 fibs 130 | print $ bubbleSort [34,13,0,144,1,4181,2,2584,1,377,55,233,3,987,89,610,1597,21,5,8] 131 | 132 | 133 | 134 | 135 | -------------------------------------------------------------------------------- /src/IdiomBrackets.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | module IdiomBrackets where 6 | 7 | -- This module provides the Idiom Bracket syntax suggested by Conor McBride 8 | -- 'iI f a b ... Ii' stands for '[[f a b ...]]' which denotes 'pure f <*> a <*> b <*> ...' 9 | -- See also https://wiki.haskell.org/Idiom_brackets 10 | 11 | class Applicative i => Idiomatic i f g | g -> f i where 12 | idiomatic :: i f -> g 13 | 14 | iI :: Idiomatic i f g => f -> g 15 | iI = idiomatic . pure 16 | 17 | data Ii = Ii 18 | 19 | instance Applicative i => Idiomatic i x (Ii -> i x) where 20 | idiomatic xi Ii = xi 21 | 22 | instance Idiomatic i f g => Idiomatic i (s -> f) (i s -> g) where 23 | idiomatic sfi si = idiomatic (sfi <*> si) 24 | -------------------------------------------------------------------------------- /src/Infinity.hs: -------------------------------------------------------------------------------- 1 | module Infinity where 2 | 3 | odds :: [Int] 4 | odds = [n | n <- [1 ..], n `mod` 2 /= 0] 5 | 6 | -- | a list of all integer pythagorean triples with a² + b² = c² 7 | pythagoreanTriples :: [(Int, Int, Int)] 8 | pythagoreanTriples = [ (a, b, c) 9 | | c <- [1 ..] 10 | , b <- [1 .. c - 1] 11 | , a <- [1 .. b - 1] 12 | , a ^ 2 + b ^ 2 == c ^ 2 13 | ] 14 | 15 | primes :: [Integer] 16 | primes = 2 : [i | i <- [3,5..], 17 | and [rem i p > 0 | p <- takeWhile (\p -> p^2 <= i) primes]] 18 | 19 | -- | bottom, a computation which never completes successfully, aka as _|_ 20 | bottom :: a 21 | bottom = bottom 22 | 23 | -- | a CAF representing all integer numbers (https://wiki.haskell.org/Constant_applicative_form) 24 | ints :: Num a => [a] 25 | ints = from 1 26 | where 27 | from n = n : from (n + 1) 28 | 29 | -- | the K combinator which drop its second argument 30 | k :: a -> b -> a 31 | k x _ = x 32 | 33 | -- a_i+1 = (a_i + n/a_i)/2 34 | next :: Fractional a => a -> a -> a 35 | next n a_i = (a_i + n/a_i)/2 36 | 37 | within :: (Ord a, Fractional a) => a -> [a] -> a 38 | within eps (a:b:rest) = 39 | if abs(a/b - 1) <= eps 40 | then b 41 | else within eps (b:rest) 42 | 43 | root :: (Ord a, Fractional a) => a -> a -> a 44 | root n eps = within eps (iterate (next n) 1) 45 | 46 | infinityDemo :: IO () 47 | infinityDemo = do 48 | putStrLn 49 | "Infinite data structures and nonterminating computations -> laziness & list comprehension\n" 50 | print $ take 100 ints 51 | print $ take 10 [2,4 ..] 52 | print $ take 10 pythagoreanTriples 53 | print $ k "21 is just half the truth" undefined 54 | print $ k 42 bottom 55 | print ("square root of 2: " ++ show (root 2 0.000001)) 56 | putStrLn "" 57 | -------------------------------------------------------------------------------- /src/Interpreter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Interpreter where 3 | import Control.Monad.Reader 4 | import Control.Monad.State 5 | 6 | data Exp a = 7 | Var String 8 | | BinOp (BinOperator a) (Exp a) (Exp a) 9 | | Let String (Exp a) (Exp a) 10 | | Val a 11 | 12 | type BinOperator a = a -> a -> a 13 | 14 | type Env a = [(String, a)] 15 | 16 | -- environment lookup 17 | fetch :: String -> Env a -> a 18 | fetch x [] = error $ "variable " ++ x ++ " is not defined" 19 | fetch x ((y,v):ys) 20 | | x == y = v 21 | | otherwise = fetch x ys 22 | 23 | -- using a Reader Monad to thread the environment. The Environment can be accessed by ask and asks. 24 | --eval :: Exp a -> Env a -> a 25 | --eval :: Exp a -> ((->) (Env a)) a 26 | eval :: MonadReader (Env a) m => Exp a -> m a 27 | eval (Var x) = asks (fetch x) 28 | eval (Val i) = return i 29 | eval (BinOp op e1 e2) = liftM2 op (eval e1) (eval e2) 30 | eval (Let x e1 e2) = eval e1 >>= \v -> local ((x,v):) (eval e2) 31 | 32 | eval' :: Exp a -> Reader (Env a) a 33 | eval' (Var x) = asks (fetch x) 34 | eval' (Val i) = return i 35 | eval' (BinOp op e1 e2) = liftM2 op (eval' e1) (eval' e2) 36 | eval' (Let x e1 e2) = eval' e1 >>= \v -> local ((x,v):) (eval' e2) 37 | 38 | -- using a State Monad to thread the environment. The Environment can be accessed by get, gets, modify. 39 | eval1 :: (MonadState (Env a) m) => Exp a -> m a 40 | eval1 (Val i) = return i 41 | eval1 (Var x) = gets (fetch x) 42 | eval1 (BinOp op e1 e2) = liftM2 op (eval1 e1) (eval1 e2) 43 | eval1 (Let x e1 e2) = eval1 e1 >>= \v -> modify ((x,v):) >> eval1 e2 44 | 45 | letExp = Let "x" 46 | (Let "y" 47 | (BinOp (+) (Val 5) (Val 7)) 48 | (BinOp (/) (Var "y") (Val 6))) 49 | (BinOp (*) (Var "pi") (Var "x")) 50 | 51 | interpreterDemo :: IO () 52 | interpreterDemo = do 53 | putStrLn "Interpreter -> Reader Monad + ADTs + pattern matching" 54 | let env = [("pi", pi)] 55 | print $ eval letExp env 56 | print $ runReader (eval letExp) env 57 | 58 | print $ runState (eval1 letExp) env 59 | 60 | let exp1 = Let "x" (BinOp (+) (Val 4) (Val 5)) (BinOp (*) (Val 2) (Var "x")) 61 | print $ eval exp1 [] 62 | 63 | putStrLn "" 64 | -------------------------------------------------------------------------------- /src/Iterator.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Iterator where 3 | import Singleton (Exp (..)) 4 | import Visitor 5 | 6 | import Control.Applicative 7 | import Control.Monad.State.Lazy 8 | import Data.Coerce (coerce) 9 | import Data.Functor.Compose 10 | import Data.Functor.Const 11 | import Data.Functor.Identity 12 | import Data.Functor.Product 13 | import Data.Monoid (Sum (..), getSum) 14 | 15 | instance Functor Exp where 16 | fmap f (Var x) = Var x 17 | fmap f (Val a) = Val $ f a 18 | fmap f (Add x y) = Add (fmap f x) (fmap f y) 19 | fmap f (Mul x y) = Mul (fmap f x) (fmap f y) 20 | 21 | instance Traversable Exp where 22 | traverse g (Var x) = pure $ Var x 23 | traverse g (Val x) = Val <$> g x 24 | traverse g (Add x y) = Add <$> traverse g x <*> traverse g y 25 | traverse g (Mul x y) = Mul <$> traverse g x <*> traverse g y 26 | 27 | -- getConst . traverse (Const . f) = foldMap f 28 | 29 | -- Functor Product 30 | (<#>) :: (Functor m, Functor n) => (a -> m b) -> (a -> n b) -> (a -> Product m n b) 31 | (f <#> g) y = Pair (f y) (g y) 32 | 33 | -- Functor composition 34 | (<.>) :: (Functor m, Functor n) => (b -> n c) -> (a -> m b) -> (a -> (Compose m n) c) 35 | f <.> g = Compose . fmap f . g 36 | 37 | cciBody :: Char -> Sum Integer 38 | cciBody _ = 1 39 | 40 | cci :: String -> (Const (Sum Integer)) [a] 41 | cci = traverse (Const . cciBody) 42 | 43 | lciBody :: Char -> Sum Integer 44 | lciBody c = if (c == '\n') then 1 else 0 45 | 46 | lci :: String -> (Const (Sum Integer)) [a] 47 | lci = traverse (Const . lciBody) 48 | 49 | clci :: String -> Product (Const (Sum Integer)) (Const (Sum Integer)) [a] 50 | clci = traverse ((Const . cciBody) <#> (Const . lciBody)) 51 | 52 | -- wciBody and wci based on suggestion by NoughtMare 53 | wciBody :: Char -> Maybe SepCount 54 | wciBody = Just . mkSepCount isSpace where 55 | isSpace :: Char -> Bool 56 | isSpace c = c == ' ' || c == '\n' || c == '\t' 57 | 58 | -- using traverse to count words in a String 59 | wci :: String -> Const (Maybe SepCount) [Integer] 60 | wci = traverse (Const . wciBody) 61 | 62 | -- Forming the Product of character counting, line counting and word counting 63 | -- and performing a one go traversal using this Functor product 64 | clwci :: String -> (Product (Product (Const (Sum Integer)) (Const (Sum Integer))) (Const (Maybe SepCount))) [Integer] 65 | clwci = traverse ((Const . cciBody) <#> (Const . lciBody) <#> (Const . wciBody)) 66 | 67 | -- or much simpler, just use a foldMap 68 | clwci'' :: Foldable t => t Char -> (Sum Integer, Sum Integer, Maybe SepCount) 69 | clwci'' = foldMap (\x -> (cciBody x, lciBody x, wciBody x)) 70 | 71 | 72 | -- original solution from 'The Essence of the Iterator Patern' paper 73 | wciBody' :: Char -> Compose (WrappedMonad (State Bool)) (Const (Sum Integer)) a 74 | wciBody' c = coerce (updateState c) where 75 | updateState :: Char -> Bool -> (Sum Integer, Bool) 76 | updateState c w = let s = not(isSpace c) in (test (not w && s), s) 77 | isSpace :: Char -> Bool 78 | isSpace c = c == ' ' || c == '\n' || c == '\t' 79 | test :: Bool -> Sum Integer 80 | test b = Sum $ if b then 1 else 0 81 | 82 | wci' :: String -> Compose (WrappedMonad (State Bool)) (Const (Sum Integer)) [a] 83 | wci' = traverse wciBody' 84 | 85 | clwci' :: String -> (Product (Product (Const (Sum Integer)) (Const (Sum Integer))) (Compose (WrappedMonad (State Bool)) (Const (Sum Integer)))) [a] 86 | clwci' = traverse ((Const . cciBody) <#> (Const . lciBody) <#> wciBody') 87 | 88 | data SepCount = SC Bool Bool Integer 89 | deriving Show 90 | 91 | mkSepCount :: (a -> Bool) -> a -> SepCount 92 | mkSepCount pred x = SC p p (if p then 0 else 1) 93 | where 94 | p = pred x 95 | 96 | getSepCount :: SepCount -> Integer 97 | getSepCount (SC _ _ n) = n 98 | 99 | instance Semigroup SepCount where 100 | (SC l0 r0 n) <> (SC l1 r1 m) = SC l0 r1 x where 101 | x | not r0 && not l1 = n + m - 1 102 | | otherwise = n + m 103 | 104 | extractCount :: Const (Maybe SepCount) a -> Integer 105 | extractCount (Const (Just sepCount)) = getSepCount sepCount 106 | 107 | -- | the actual wordcount implementation. 108 | -- for any String a triple of linecount, wordcount, charactercount is returned 109 | wc :: String -> (Integer, Integer, Integer) 110 | wc str = 111 | let raw = clwci str 112 | cc = coerce $ pfst (pfst raw) 113 | lc = coerce $ psnd (pfst raw) 114 | wc = extractCount (psnd raw) 115 | in (lc,wc,cc) 116 | 117 | wc'' :: String -> (Integer, Integer, Integer) 118 | wc'' str = 119 | let (rawCC, rawLC, rawWC) = clwci'' str 120 | cc = coerce rawCC 121 | lc = coerce rawLC 122 | wc = extractCount $ Const rawWC 123 | in (lc,wc,cc) 124 | 125 | str :: String 126 | str = "hello \n world" 127 | 128 | pfst :: Product f g a -> f a 129 | pfst (Pair fst _) = fst 130 | psnd :: Product f g a -> g a 131 | psnd (Pair _ snd) = snd 132 | 133 | iteratorDemo = do 134 | putStrLn "Iterator -> Traversable" 135 | let exp = Mul (Add (Val 3) (Val 1)) 136 | (Mul (Val 2) (Var "pi")) 137 | env = [("pi", pi)] 138 | print $ traverse (\x c -> if even x then [x] else [2*x]) exp 0 139 | 140 | print $ wc "hello \n world" 141 | 142 | 143 | -------------------------------------------------------------------------------- /src/JsonPersistence.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module JsonPersistence 3 | ( Id 4 | , Entity 5 | , getId 6 | , persist 7 | , retrieve 8 | ) where 9 | import Data.Aeson (FromJSON, ToJSON, eitherDecodeFileStrict, encodeFile, toJSON) 10 | import Data.Typeable 11 | 12 | -- | Identifier for an Entity 13 | type Id = String 14 | 15 | -- | The Entity type class provides generic persistence to JSON files 16 | class (ToJSON a, FromJSON a, Typeable a) => Entity a where 17 | 18 | -- | return the unique Id of the entity. This function must be implemented by type class instances. 19 | getId :: a -> Id 20 | 21 | -- | persist an entity of type a and identified by an Id to a json file 22 | persist :: a -> IO () 23 | persist entity = do 24 | -- compute file path based on runtime type and entity id 25 | let jsonFileName = getPath (typeRep ([] :: [a])) (getId entity) 26 | -- serialize entity as JSON and write to file 27 | encodeFile jsonFileName entity 28 | 29 | -- | load persistent entity of type a and identified by an Id 30 | retrieve :: Id -> IO a 31 | retrieve id = do 32 | -- compute file path based on entity type and entity id 33 | let jsonFileName = getPath (typeRep ([] :: [a])) id 34 | -- parse entity from JSON file 35 | eitherEntity <- eitherDecodeFileStrict jsonFileName 36 | case eitherEntity of 37 | Left msg -> fail msg 38 | Right e -> return e 39 | 40 | -- | compute path of data file 41 | getPath :: TypeRep -> String -> String 42 | getPath tr id = show tr ++ "." ++ id ++ ".json" -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import AbstractFactory 4 | import Adapter 5 | import Builder 6 | import Coerce 7 | import Composite 8 | import DependencyInjection 9 | import HigherOrder 10 | import Infinity 11 | import Interpreter 12 | import Iterator 13 | import JsonPersistence 14 | import NullObject 15 | import Pipeline 16 | import Singleton 17 | import DataTransferObject 18 | import TemplateMethod 19 | import Visitor 20 | import MapReduce 21 | import MiniPascal 22 | import AspectPascal 23 | import Reflection 24 | import FluentApi 25 | 26 | main :: IO () 27 | main = do 28 | putStrLn "have fun with Lambda the ultimate Pattern Factory\n" 29 | dTODemo 30 | singletonDemo 31 | pipelineDemo 32 | compositeDemo 33 | visitorDemo 34 | adapterDemo 35 | builderDemo 36 | templateMethodDemo 37 | nullObjectDemo 38 | iteratorDemo 39 | abstractFactoryDemo 40 | reflectionDemo 41 | demoDI 42 | interpreterDemo 43 | infinityDemo 44 | mapReduceDemo 45 | miniPascalDemo 46 | aspectPascalDemo 47 | higherOrderDemo 48 | fluentApiDemo -------------------------------------------------------------------------------- /src/MapReduce.hs: -------------------------------------------------------------------------------- 1 | module MapReduce where 2 | 3 | import Control.Arrow ((&&&)) 4 | import Control.Category ((>>>)) 5 | import Data.Char (toLower) 6 | import Data.List (group, sort) 7 | import Data.Map as Map hiding (filter, map, foldr) 8 | import Data.Map (Map) 9 | import Control.Parallel (pseq) 10 | import Control.Parallel.Strategies (rseq, using, parMap) 11 | import Data.Coerce 12 | 13 | newtype WordCountMap = WordCountMap (Map String Int) deriving (Show) 14 | 15 | instance Semigroup WordCountMap where 16 | WordCountMap a <> WordCountMap b = WordCountMap $ Map.unionWith (+) a b 17 | instance Monoid WordCountMap where 18 | mempty = WordCountMap Map.empty 19 | 20 | 21 | stringToWordCountMap :: String -> WordCountMap 22 | stringToWordCountMap = 23 | map toLower >>> words >>> -- convert to lowercase and split into a list of words 24 | sort >>> group >>> -- sort the words and group all equal words to sub-lists 25 | map (head &&& length) >>> -- for each of those list of grouped words: form a pair (word, frequency) 26 | Map.fromList >>> -- create a Map from the list of (word, frequency) pairs 27 | WordCountMap -- wrap as WordCountMap 28 | 29 | reduceWordCountMaps :: [WordCountMap] -> WordCountMap 30 | reduceWordCountMaps = WordCountMap . foldr (Map.unionWith (+) . coerce) empty 31 | 32 | simpleMapReduce :: 33 | (a -> b) -- map function 34 | -> ([b] -> c) -- reduce function 35 | -> [a] -- list to map over 36 | -> c -- result 37 | simpleMapReduce mapFunc reduceFunc = reduceFunc . map mapFunc 38 | 39 | parMapReduce :: (a -> b) -> ([b] -> c) -> [a] -> c 40 | parMapReduce mapFunc reduceFunc input = 41 | mapResult `pseq` reduceResult 42 | where mapResult = parMap rseq mapFunc input 43 | reduceResult = reduceFunc mapResult `using` rseq 44 | 45 | alphabetic :: Char -> Bool 46 | alphabetic char = char `elem` (" \t\n\r" ++ ['a'..'z'] ++ ['A'..'Z']) 47 | 48 | mapReduceDemo = do 49 | contents <- readFile "LICENSE" 50 | let linesInFile = lines $ filter alphabetic contents 51 | 52 | -- simple map reduce, no parallelism 53 | print $ simpleMapReduce stringToWordCountMap reduceWordCountMaps linesInFile 54 | -- parallelized map reduce 55 | print $ parMapReduce stringToWordCountMap reduceWordCountMaps linesInFile 56 | 57 | -- the essence of map reduce: foldMap: 58 | print $ foldMap stringToWordCountMap linesInFile 59 | 60 | -------------------------------------------------------------------------------- /src/MiniPascal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module MiniPascal where 3 | import Control.Monad.Reader 4 | import Control.Monad.State 5 | import Control.Monad.Writer 6 | import Data.Map (Map) 7 | import qualified Data.Map as Map (lookup, insert, fromList, assocs) 8 | import Interpreter (Exp (..), Env (..), letExp, fetch) 9 | 10 | -- adding a logging capability to the expression evaluator 11 | eval :: Show a => Exp a -> WriterT [String] (Reader (Env a)) a 12 | eval (Var x) = tell ["lookup " ++ x] >> asks (fetch x) 13 | eval (Val i) = tell [show i] >> return i 14 | eval (BinOp op e1 e2) = tell ["Op"] >> liftM2 op (eval e1) (eval e2) 15 | eval (Let x e1 e2) = do 16 | tell ["let " ++ x] 17 | v <- eval e1 18 | tell ["in"] 19 | local ((x,v):) (eval e2) 20 | 21 | -- Mini Pascal -- 22 | type Id = String 23 | 24 | data IExp = Lit Int 25 | | IExp :+: IExp 26 | | IExp :*: IExp 27 | | IExp :-: IExp 28 | | IExp :/: IExp 29 | | IVar Id deriving (Show) 30 | 31 | data BExp = T 32 | | F 33 | | Not BExp 34 | | BExp :&: BExp 35 | | BExp :|: BExp 36 | | IExp :=: IExp 37 | | IExp :<: IExp deriving (Show) 38 | 39 | data Stmt = Skip 40 | | Id := IExp 41 | | Begin [Stmt] 42 | | If BExp Stmt Stmt 43 | | While BExp Stmt deriving (Show) 44 | 45 | -- an example program: the MiniPascal equivalent of `sum [1..10]` 46 | program :: Stmt 47 | program = 48 | Begin [ 49 | "total" := Lit 0, 50 | "count" := Lit 0, 51 | While (IVar "count" :<: Lit 10) 52 | (Begin [ 53 | "count" := (IVar "count" :+: Lit 1), 54 | "total" := (IVar "total" :+: IVar "count") 55 | ]) 56 | ] 57 | 58 | type Store = Map Id Int 59 | 60 | iexp :: MonadState Store m => IExp -> m Int 61 | iexp (Lit n) = return n 62 | iexp (e1 :+: e2) = liftM2 (+) (iexp e1) (iexp e2) 63 | iexp (e1 :*: e2) = liftM2 (*) (iexp e1) (iexp e2) 64 | iexp (e1 :-: e2) = liftM2 (-) (iexp e1) (iexp e2) 65 | iexp (e1 :/: e2) = liftM2 div (iexp e1) (iexp e2) 66 | iexp (IVar i) = getVar i 67 | 68 | bexp :: MonadState Store m => BExp -> m Bool 69 | bexp T = return True 70 | bexp F = return False 71 | bexp (Not b) = fmap not (bexp b) 72 | bexp (b1 :&: b2) = liftM2 (&&) (bexp b1) (bexp b2) 73 | bexp (b1 :|: b2) = liftM2 (||) (bexp b1) (bexp b2) 74 | bexp (e1 :=: e2) = liftM2 (==) (iexp e1) (iexp e2) 75 | bexp (e1 :<: e2) = liftM2 (<) (iexp e1) (iexp e2) 76 | 77 | stmt :: MonadState Store m => Stmt -> m () 78 | stmt Skip = return () 79 | stmt (i := e) = do x <- iexp e; setVar i x 80 | stmt (Begin ss) = mapM_ stmt ss 81 | stmt (If b t e) = do 82 | x <- bexp b 83 | if x then stmt t 84 | else stmt e 85 | stmt (While b t) = loop 86 | where loop = do 87 | x <- bexp b 88 | when x $ stmt t >> loop 89 | 90 | setVar :: (MonadState (Map k a) m, Ord k) => k -> a -> m () 91 | setVar i x = do 92 | store <- get 93 | put (Map.insert i x store) 94 | 95 | getVar :: MonadState Store m => Id -> m Int 96 | getVar i = do 97 | s <- get 98 | case Map.lookup i s of 99 | Nothing -> return 0 100 | (Just v) -> return v 101 | 102 | 103 | run :: Stmt -> Store 104 | run s = execState (stmt s) (Map.fromList []) 105 | 106 | demo :: Store -> IO () 107 | demo store = print (Map.assocs store) 108 | 109 | miniPascalDemo :: IO () 110 | miniPascalDemo = do 111 | putStrLn "Aspect Weaving -> Monad Transformers" 112 | let env = [("pi", pi)] 113 | print $ runReader (runWriterT (eval letExp)) env 114 | 115 | demo (run program) 116 | 117 | putStrLn "" -------------------------------------------------------------------------------- /src/NullObject.hs: -------------------------------------------------------------------------------- 1 | module NullObject where 2 | import Control.Monad ((>=>)) 3 | import Data.Map (Map, fromList) 4 | import qualified Data.Map as Map (lookup) 5 | 6 | type Song = String 7 | type Album = String 8 | type Artist = String 9 | type URL = String 10 | 11 | songMap :: Map Song Album 12 | songMap = fromList 13 | [("Baby Satellite","Microgravity") 14 | ,("An Ending", "Apollo: Atmospheres and Soundtracks")] 15 | 16 | albumMap :: Map Album Artist 17 | albumMap = fromList 18 | [("Microgravity","Biosphere") 19 | ,("Apollo: Atmospheres and Soundtracks", "Brian Eno")] 20 | 21 | artistMap :: Map Artist URL 22 | artistMap = fromList 23 | [("Biosphere","http://www.biosphere.no//") 24 | ,("Brian Eno", "http://www.brian-eno.net")] 25 | 26 | loookup' :: Ord a => Map a b -> a -> Maybe b 27 | loookup' = flip Map.lookup 28 | 29 | findAlbum :: Song -> Maybe Album 30 | findAlbum = loookup' songMap 31 | 32 | findArtist :: Album -> Maybe Artist 33 | findArtist = loookup' albumMap 34 | 35 | findWebSite :: Artist -> Maybe URL 36 | findWebSite = loookup' artistMap 37 | 38 | findUrlFromSong :: Song -> Maybe URL 39 | findUrlFromSong song = 40 | case findAlbum song of 41 | Nothing -> Nothing 42 | Just album -> 43 | case findArtist album of 44 | Nothing -> Nothing 45 | Just artist -> 46 | case findWebSite artist of 47 | Nothing -> Nothing 48 | Just url -> Just url 49 | 50 | findUrlFromSongDo :: Song -> Maybe URL 51 | findUrlFromSongDo song = do 52 | album <- findAlbum song 53 | artist <- findArtist album 54 | findWebSite artist 55 | 56 | findUrlFromSong' :: Song -> Maybe URL 57 | findUrlFromSong' song = 58 | findAlbum song >>= \album -> 59 | findArtist album >>= \artist -> 60 | findWebSite artist 61 | 62 | findUrlFromSong'' :: Song -> Maybe URL 63 | findUrlFromSong'' song = 64 | findAlbum song >>= findArtist >>= findWebSite 65 | 66 | findUrlFromSong''' :: Song -> Maybe URL 67 | findUrlFromSong''' = 68 | findAlbum >=> findArtist >=> findWebSite 69 | 70 | nullObjectDemo = do 71 | putStrLn "NullObject -> Maybe" 72 | 73 | print $ Map.lookup "Baby Satellite" songMap 74 | print $ Map.lookup "The Fairy Tale" songMap 75 | 76 | case Map.lookup "Ancient Campfire" songMap of 77 | Nothing -> print "sorry, could not find your song" 78 | Just s -> print s 79 | 80 | print $ findUrlFromSong' "An Ending" 81 | print $ findUrlFromSong'' "Baby Satellite" 82 | print $ findUrlFromSong''' "A Never Ending Story" 83 | 84 | print $ safeRootReciprocal 0 85 | print $ safeRootReciprocal (-10) 86 | print $ safeRootReciprocal 0.01 87 | 88 | {-- --This is how >=> could be implemented for Maybe: 89 | (>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> (a -> Maybe c) 90 | m1 >=> m2 = \x -> 91 | case m1 x of 92 | Nothing -> Nothing 93 | Just y -> case m2 y of 94 | Nothing -> Nothing 95 | result@(Just z) -> result 96 | --} 97 | 98 | safeRoot :: Double -> Maybe Double 99 | safeRoot x 100 | | x >= 0 = Just (sqrt x) 101 | | otherwise = Nothing 102 | 103 | safeReciprocal :: Double -> Maybe Double 104 | safeReciprocal x 105 | | x /= 0 = Just (1/x) 106 | | otherwise = Nothing 107 | 108 | safeRootReciprocal :: Double -> Maybe Double 109 | safeRootReciprocal = safeReciprocal >=> safeRoot 110 | 111 | safeRootReciprocal' :: Double -> Maybe Double 112 | safeRootReciprocal' x = return x >>= safeReciprocal >>= safeRoot 113 | -------------------------------------------------------------------------------- /src/Pipeline.hs: -------------------------------------------------------------------------------- 1 | -- The DeriveFunctor Language Pragma provides automatic derivation of Functor instances 2 | {-# LANGUAGE DeriveFunctor #-} 3 | module Pipeline where 4 | 5 | -- The Stream type is a wrapper around an arbitrary payload type 'a' 6 | newtype Stream a = Stream a deriving (Show) 7 | 8 | -- echo injects an item of type 'a' into the Stream context 9 | echo :: a -> Stream a 10 | echo = Stream 11 | 12 | -- the 'andThen' operator used for chaining commands 13 | infixl 7 |> 14 | (|>) :: Stream a -> (a -> Stream b) -> Stream b 15 | Stream x |> f = f x 16 | 17 | 18 | -- echo and |> are used to create the actual pipeline 19 | pipeline :: String -> Stream Int 20 | pipeline str = 21 | echo str |> echo . length . words |> echo . (3 *) 22 | 23 | -- a log is just a list of Strings 24 | type Log = [String] 25 | 26 | -- the Stream type is extended by a Log, that keeps track of any logged messages 27 | newtype LoggerStream a = LoggerStream (a, Log) deriving (Show, Functor) 28 | 29 | instance Applicative LoggerStream where 30 | pure = return 31 | LoggerStream (f, _) <*> r = fmap f r 32 | 33 | -- our definition of the Logging Stream Monad 34 | instance Monad LoggerStream where 35 | -- returns a Stream wrapping a tuple of the actual payload and an empty Log 36 | return a = LoggerStream (a, []) 37 | -- we define (>>=) to return a tuple (composed functions, concatenated logs) 38 | m1 >>= m2 = let LoggerStream(f1, l1) = m1 39 | LoggerStream(f2, l2) = m2 f1 40 | in LoggerStream(f2, l1 ++ l2) 41 | 42 | -- compute length of a String and provide a log message 43 | logLength :: String -> LoggerStream Int 44 | logLength str = let l = length(words str) 45 | in LoggerStream (l, ["length(" ++ str ++ ") = " ++ show l]) 46 | 47 | logMultiply :: Int -> LoggerStream Int 48 | logMultiply x = let z = x * 3 49 | in LoggerStream (z, ["multiply(" ++ show x ++ ", 3" ++") = " ++ show z]) 50 | 51 | logPipeline :: String -> LoggerStream Int 52 | logPipeline str = 53 | return str >>= logLength >>= logMultiply 54 | 55 | pipelineDemo = do 56 | putStrLn "Pipeline -> Monad" 57 | print $ pipeline "hello world" 58 | print $ logPipeline "hello logging world" 59 | putStrLn "" 60 | -------------------------------------------------------------------------------- /src/Proxy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | module Proxy where 5 | 6 | import Data.Char as C 7 | 8 | type RealSubject = String 9 | 10 | newtype Proxy a = Proxy a deriving (Show, Read, Functor) 11 | 12 | instance (Num a) => Num (Proxy a) where 13 | (Proxy x) + (Proxy y) = Proxy (x + y) 14 | (Proxy x) * (Proxy y) = Proxy (x * y) 15 | abs (Proxy x) = Proxy (abs x) 16 | signum (Proxy x) = Proxy (signum x) 17 | fromInteger = Proxy . fromInteger 18 | negate (Proxy x) = Proxy (negate x) 19 | 20 | upper :: RealSubject -> RealSubject 21 | upper = map C.toUpper 22 | 23 | demoProxy = do 24 | putStrLn "Proxy -> Functor" 25 | 26 | let realX = 7 27 | realY = 19 28 | proxyX = Proxy realX 29 | proxyY = Proxy realY 30 | print (proxyX + proxyY) 31 | --print $ fmap (upper . reverse) proxy 32 | 33 | 34 | -------------------------------------------------------------------------------- /src/Reflection.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | module Reflection where 4 | import Data.Aeson (FromJSON, ToJSON) 5 | import GHC.Generics 6 | --import JsonPersistence -- use this to use JSON serialization/deserialization 7 | import SimplePersistence (Id, Entity, getId, persist, retrieve) 8 | 9 | data User = User { 10 | userId :: Id 11 | , name :: String 12 | , email :: String 13 | } deriving (Show, Read, Generic, ToJSON, FromJSON) 14 | 15 | instance Entity User where 16 | getId = userId 17 | 18 | data Post = Post { 19 | postId :: Id 20 | , userRef :: Id 21 | , text :: String 22 | } deriving (Show, Read, Generic, ToJSON, FromJSON) 23 | 24 | instance Entity Post where 25 | getId = postId 26 | 27 | retrieveUser :: Id -> IO User 28 | retrieveUser = retrieve 29 | 30 | retrievePost :: Id -> IO Post 31 | retrievePost = retrieve 32 | 33 | reflectionDemo = do 34 | putStrLn "Reflection" 35 | let user = User "1" "Heinz Meier" "hm@meier.com" 36 | let post = Post "4711" "1" "My name is Heinz, this is my first post" 37 | 38 | persist user 39 | persist post 40 | 41 | user' <- retrieve "1" :: IO User 42 | user' <- retrieveUser "1" 43 | print user' 44 | 45 | retrievePost "4711" >>= print 46 | -------------------------------------------------------------------------------- /src/SimplePersistence.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module SimplePersistence 3 | ( Id 4 | , Entity 5 | , getId 6 | , persist 7 | , retrieve 8 | ) where 9 | import Data.Typeable 10 | 11 | -- | Identifier for an Entity 12 | type Id = String 13 | 14 | -- | The Entity type class provides generic persistence to txt files 15 | class (Show a, Read a, Typeable a) => Entity a where 16 | 17 | -- | return the unique Id of the entity. This function must be implemented by type class instances. 18 | getId :: a -> Id 19 | 20 | -- | persist an entity of type a and identified by an Id to a file 21 | persist :: a -> IO () 22 | persist entity = do 23 | -- compute file path based on entity type and id 24 | let fileName = getPath (typeOf entity) (getId entity) 25 | -- serialize entity as JSON and write to file 26 | writeFile fileName (show entity) 27 | 28 | -- | load persistent entity of type a and identified by an Id 29 | retrieve :: Id -> IO a 30 | retrieve id = do 31 | -- compute file path based on entity type and id 32 | let fileName = getPath (typeOf (undefined :: a)) id 33 | -- read file content into string 34 | contentString <- readFile fileName 35 | -- parse entity from string 36 | return (read contentString) 37 | 38 | 39 | -- | compute path of data file 40 | getPath :: TypeRep -> String -> FilePath 41 | getPath tr id = show tr ++ "." ++ id ++ ".txt" -------------------------------------------------------------------------------- /src/Singleton.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Singleton where 3 | import IdiomBrackets 4 | 5 | data Exp a = 6 | Var String 7 | | Val a 8 | | Add (Exp a) (Exp a) 9 | | Mul (Exp a) (Exp a) deriving (Show) 10 | 11 | type Env a = [(String, a)] 12 | 13 | -- the naive implementation of eval: 14 | -- the environment is threaded into each recursive call of eval 15 | -- as an explicit parameter e 16 | eval :: (Num a) => Exp a -> Env a -> a 17 | eval (Var x) e = fetch x e 18 | eval (Val i) e = i 19 | eval (Add p q) e = eval p e + eval q e 20 | eval (Mul p q) e = eval p e * eval q e 21 | 22 | -- the K combinator 23 | k :: a -> env -> a 24 | k x e = x 25 | -- the S combinator 26 | s :: (env -> a -> b) -> (env -> a) -> env -> b 27 | s ef es e = ef e (es e) 28 | 29 | -- the SK combinator based implementation 30 | -- the threading of the env into recursive calls is done by the S combinator 31 | -- currying allows to omit the explicit parameter e 32 | eval1 :: (Num a) => Exp a -> Env a -> a 33 | eval1 (Var x) = fetch x 34 | eval1 (Val i) = k i 35 | eval1 (Add p q) = k (+) `s` eval1 p `s` eval1 q 36 | eval1 (Mul p q) = k (*) `s` eval1 p `s` eval1 q 37 | 38 | -- instance Applicative ((->) r) where 39 | -- pure x _ = x 40 | -- f <*> g = \x -> f x (g x) 41 | 42 | -- applicative functor based implementation 43 | -- the K and S magic is now done by pure and <*> 44 | eval2 :: (Num a) => Exp a -> Env a -> a 45 | eval2 (Var x) = fetch x 46 | eval2 (Val i) = pure i 47 | eval2 (Add p q) = pure (+) <*> eval2 p <*> eval2 q 48 | eval2 (Mul p q) = pure (*) <*> eval2 p <*> eval2 q 49 | 50 | -- using the Idiom Bracket syntax suggested by Conor McBride 51 | -- 'iI f a b ... Ii' stands for '[[f a b ...]]' which denotes 'pure f <*> a <*> b <*> ...' 52 | eval3 :: (Num a) => Exp a -> Env a -> a 53 | eval3 (Var x) = fetch x 54 | eval3 (Val i) = iI i Ii 55 | eval3 (Add p q) = iI (+) (eval3 p) (eval3 q) Ii 56 | eval3 (Mul p q) = iI (*) (eval3 p) (eval3 q) Ii 57 | 58 | -- simple environment lookup 59 | fetch :: String -> Env a -> a 60 | fetch x [] = error $ "variable " ++ x ++ " is not defined" 61 | fetch x ((y,v):ys) 62 | | x == y = v 63 | | otherwise = fetch x ys 64 | 65 | singletonDemo :: IO () 66 | singletonDemo = do 67 | putStrLn "Singleton -> Applicative Functor (and let in general)" 68 | let exp = Mul (Add (Val 3) (Val 1)) 69 | (Mul (Val 2) (Var "pi")) 70 | env = [("pi", pi)] 71 | print $ eval exp env 72 | print $ eval1 exp env 73 | print $ eval2 exp env 74 | print $ eval3 exp env 75 | 76 | putStrLn "" 77 | -------------------------------------------------------------------------------- /src/Strategy.hs: -------------------------------------------------------------------------------- 1 | module Strategy where 2 | 3 | data CustomerType = EndCustomer | Retailer | NGO 4 | 5 | type Price = Double 6 | type Quantity = Double 7 | 8 | consumerPrice :: Quantity -> Price -> Price 9 | consumerPrice quantity price = 10 | if quantity <= 3 11 | then price 12 | else price * 0.9 13 | 14 | retailPrice :: Quantity -> Price -> Price 15 | retailPrice quantity price 16 | | quantity * price < 100 = price * 0.8 17 | | quantity * price < 250 = price * 0.7 18 | | otherwise = price * 0.5 19 | 20 | discountPrice :: CustomerType -> (Quantity -> Price -> Price) 21 | discountPrice EndCustomer = consumerPrice 22 | discountPrice Retailer = retailPrice 23 | discountPrice NGO = retailPrice 24 | 25 | class CustomerClass a where 26 | discount :: a -> (Quantity -> Price -> Price) 27 | 28 | data EndCustomerType = EcType 29 | data RetailerType = RtType 30 | data NgoType = NgType 31 | 32 | instance CustomerClass EndCustomerType where 33 | discount _ = consumerPrice 34 | 35 | instance CustomerClass RetailerType where 36 | discount _ = retailPrice 37 | 38 | instance CustomerClass NgoType where 39 | discount _ = retailPrice 40 | 41 | 42 | strategyDemo = do 43 | putStrLn "Strategy Pattern -> Higher Order Functions" 44 | 45 | print $ discountPrice EndCustomer 2 10 46 | print $ discountPrice EndCustomer 9 10 47 | 48 | print $ discountPrice Retailer 9 10 49 | print $ discountPrice Retailer 20 10 50 | print $ discountPrice Retailer 60 10 51 | 52 | print $ discount EcType 2 10 53 | print $ discount EcType 9 10 54 | print $ discount RtType 20 10 55 | print $ discount NgType 60 10 56 | 57 | putStrLn "" 58 | -------------------------------------------------------------------------------- /src/TemplateMethod.hs: -------------------------------------------------------------------------------- 1 | module TemplateMethod where 2 | 3 | import Adapter (Minute (..), WallTime (..), addMinutesToWallTime, marshalMW, unmarshalWM) 4 | 5 | addMinutesTemplate :: (Int -> WallTime -> WallTime) -> Int -> Minute -> Minute 6 | addMinutesTemplate f x = 7 | unmarshalWM . 8 | f x . 9 | marshalMW 10 | 11 | -- implements linear addition even for values > 1440 12 | linearTimeAdd :: Int -> Minute -> Minute 13 | linearTimeAdd = addMinutesTemplate addMinutesToWallTime 14 | 15 | -- implements cyclic addition, respecting a 24 hour (1440 Min) cycle 16 | cyclicTimeAdd :: Int -> Minute -> Minute 17 | cyclicTimeAdd = addMinutesTemplate addMinutesToWallTime' 18 | 19 | -- a 24 hour (1440 min) cyclic version of addition: 1400 + 100 = 60 20 | addMinutesToWallTime' :: Int -> WallTime -> WallTime 21 | addMinutesToWallTime' x (WallTime (h, m)) = 22 | let (hAdd, mAdd) = x `quotRem` 60 23 | hNew = h + hAdd 24 | mNew = m + mAdd 25 | in if mNew >= 60 26 | then WallTime ((hNew + 1) `rem` 24, mNew-60) 27 | else WallTime (hNew, mNew) 28 | 29 | addWallTimes :: WallTime -> WallTime -> WallTime 30 | addWallTimes a@(WallTime (h,m)) b = 31 | let aMin = h*60 + m 32 | in addMinutesToWallTime aMin b 33 | 34 | instance Semigroup WallTime where 35 | (<>) = addWallTimes 36 | instance Monoid WallTime where 37 | mempty = WallTime (0,0) 38 | 39 | templateMethodDemo = do 40 | putStrLn "TemplateMethod -> higher order function -> typeclass default implementations" 41 | putStrLn $ "linear time: " ++ (show $ linearTimeAdd 100 (Minute 1400)) 42 | putStrLn $ "cyclic time: " ++ (show $ cyclicTimeAdd 100 (Minute 1400)) 43 | putStrLn "" 44 | let a = WallTime (3,20) 45 | print $ mappend a a 46 | print $ mconcat [a,a,a,a,a,a,a,a,a] 47 | putStrLn "" 48 | -------------------------------------------------------------------------------- /src/Visitor.hs: -------------------------------------------------------------------------------- 1 | module Visitor where 2 | import Singleton (Exp (..)) 3 | 4 | -- we are re-using the Exp data type from the Singleton example 5 | -- and transform it into a Foldable type: 6 | instance Foldable Exp where 7 | foldMap f (Val x) = f x 8 | foldMap f (Add x y) = foldMap f x `mappend` foldMap f y 9 | foldMap f (Mul x y) = foldMap f x `mappend` foldMap f y 10 | 11 | filterF :: Foldable f => (a -> Bool) -> f a -> [a] 12 | filterF p = foldMap (\a -> if p a then [a] else []) 13 | 14 | visitorDemo = do 15 | putStrLn "Visitor -> Foldable -> Traversable" 16 | let exp = Mul (Add (Val 3) (Val 2)) 17 | (Mul (Val 4) (Val 6)) 18 | print exp 19 | putStr "size of exp: " 20 | print $ length exp 21 | putStrLn "filter even numbers from tree" 22 | print $ filterF even exp 23 | 24 | 25 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-13.30 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # - location: 29 | # git: https://github.com/commercialhaskell/stack.git 30 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 31 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # subdirs: 33 | # - auto-update 34 | # - wai 35 | packages: 36 | - . 37 | # Dependency packages to be pulled from upstream that are not in the resolver 38 | # using the same syntax as the packages field. 39 | # (e.g., acme-missiles-0.3) 40 | # extra-deps: [] 41 | 42 | # Override default flag values for local packages and extra-deps 43 | # flags: {} 44 | 45 | # Extra package databases containing global packages 46 | # extra-package-dbs: [] 47 | 48 | # Control whether we use the GHC we find on the path 49 | # system-ghc: true 50 | # 51 | # Require a specific version of stack, using version ranges 52 | # require-stack-version: -any # Default 53 | # require-stack-version: ">=1.9" 54 | # 55 | # Override the architecture used by stack, especially useful on Windows 56 | # arch: i386 57 | # arch: x86_64 58 | # 59 | # Extra directories used by stack for building 60 | # extra-include-dirs: [/path/to/dir] 61 | # extra-lib-dirs: [/path/to/dir] 62 | # 63 | # Allow a newer minor version of GHC than the snapshot specifies 64 | # compiler-check: newer-minor 65 | --------------------------------------------------------------------------------