柴火流明

发表于 分类于 ，

HousePosition (houseBuilding form) (houseFloor form)如何使用monad简写

1
2
3
4
-- HousePosition :: Text -> Int -> HousePosition
-- houseBuilding :: Form -> Text
-- houseFloor :: Form -> Int
HousePosition <$> houseBuilding <*> houseFloor $ form

functor和Applicative

通过<$>和<*>进行简写，所以先了解函数的functor和applicative实现

functor于Applicative的签名如下

1
2
3
4
5
6
class Functor f where
    fmap :: (a -> b) -> f a -> f b

class Functor f => Applicative f where
    pure :: a -> f a
    (<*>) :: f (a -> b) -> f a -> f b

根据以上公式，函数的Functor和Applicative分别是

1
2
3
4
5
6
7
8
9
10
11
-- f1 <$> f2
-- f2结果作为f1的输入，得到f2的输入 -> f1 的结果
class Functor ((->) r) where
    fmap :: (a -> b) -> ((->) r) a -> ((->) r) b

-- f1 <*> f2
-- 不考虑f1的第一个参数
-- f2的结果作为f1的第二个参数，得到f2的输入 -> f1的结果
class Functor ((->) r) => Applicative ((->) r) where
    pure :: a -> f a
    (<*>) :: ((->) r) (a -> b) -> ((->) r) a -> ((->) r) b

推导

处理HousePosition houseBuilding的关系

  • HousePosition: Text -> (Text -> HousePosition )
  • houseBuilding: Form -> Text

houseBuilding的结果Text可以作为HousePosition的参数Text

所以，将HousePosition函数应用于houseBuilding的结果

得到HousePosition <$> houseBuilding

1
2
3
4
5
Text -> Text -> HousePosition 
<$>
Form -> Text
=
Form -> (Text -> HousePosition)

处理(HousePosition <$> houseBuilding)与houseFloor的关系

  • (HousePosition <$> houseBuilding): Form -> Int -> HousePosition
  • houseFloor: Form -> Int

houseFloor的结果可以作为(HousePosition <$> houseBuilding)的第二个参数

所以，将(HousePosition <$> houseBuilding)函数去掉第一个参数后应用于houseBuilding的结果

得到HousePosition <*> houseBuilding

1
2
3
4
5
6
7
-- 去掉第一个参数得到 Int -> HousePosition
Form -> Int -> HousePosition
<*>
-- 结果Int 将被函数Int -> HousePosition取代
Form -> Int
=
Form -> HousePosition

提升

其实就是一个提升操作，原先的构造函数是Text -> Int -> HousePosition，经过提升后变成Form -> HousePosition

发表于 分类于 ，

假设有个函数只能处理列表长度为10列表，通常都是在程序运行期间进行判断，
haskell能够实现固定长度的列表类型，使得长度在编译期间就能确定。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
{-# LANGUAGE GADTs, DataKinds #-}

module Lib
    ( someFunc
    ) where

-- 定义一个类型级别的自然数，用来表示栈的大小
data Nat = Z | S Nat  -- Z表示0，S表示后继

-- 定义固定长度的列表类型
data Vec a n where
  VNil  :: Vec a Z            -- 空列表，长度为 0
  VCons :: a -> Vec a n -> Vec a (S n)  -- 非空列表，长度为 n+1

-- 显示固定长度列表
instance Show a => Show (Vec a n) where
  show VNil = "[]"
  show (VCons x xs) = "[" ++ showElem x ++ showRest xs ++ "]"
    where
      showElem :: Show a => a -> String
      showElem = show
      
      showRest :: Show a => Vec a n -> String
      showRest VNil = ""
      showRest (VCons x xs) = ", " ++ showElem x ++ showRest xs

-- 测试用例
someFunc :: IO ()
someFunc = do
  let vec1 :: Vec Int (S (S Z))  -- 长度为2的列表
      vec1 = VCons 1 (VCons 2 VNil)
  print vec1
  
  let vec2 :: Vec Int (S (S (S Z)))  -- 长度为3的列表
      vec2 = VCons 3 (VCons 2 (VCons 1 VNil))
  print vec2

输出结果

1
2
[1, 2]
[3, 2, 1]

嵌套类型

Z和S都是Nat的构造子，S Nat表示一个嵌套结构，列表的长度将通过嵌套的层数表示。

编译器通过判断两个列表的Nat嵌套层数判断是否相同类型，从而实现列表的长度大小判断，而数字类型Int因为是相同类型所以只能是运行期间判断。

1
data Nat = Z | S Nat  -- Z表示0，S表示后继

定义列表

1
2
3
4
-- 定义固定长度的列表类型
data Vec a n where
  VNil  :: Vec a Z            -- 空列表，长度为 0
  VCons :: a -> Vec a n -> Vec a (S n)  -- 非空列表，长度为 n+1

Vec的参数

  • a：列表存储的类型
  • n：长度类型，因为两个构造子VNil和VCons都是返回的Nat类型，所以使用的时候只能构建出Vec a Nat的类型

Vec的两个构造子

  • VNil：生成一个空列表
  • VCons：将a放入Vec a n得到Vec a (S n)，结果的长度类型增加了一层嵌套

语言拓展

因为VNil和VCons都使用了Nat的构造子S和Z而不是Nat类型，所以需要开启DataKinds。

同时因为和VCons需要使用多个参数，需要开启GADT构造更灵活的构造子。

发表于 分类于 ，

Gloss 是一个用于创建图形和动画的 Haskell 库，特别适合用来制作 2D 图形和动画。它提供了简洁的 API 来进行图形渲染，并且能够轻松地在 Haskell 中进行动画和交互式程序开发。

wsl运行gloss

一开始我使用wsl的archlinux启动gloss项目，但是build失败，报错如下

1
2
3
4
5
Error: [S-7282]
       Stack failed to execute the build plan.
       While executing the build plan, Stack encountered the error:
       [S-7011]
       While building package GLURaw-2.0.0.5 (scroll up to its section to see the error) using:

GLURaw-2.0.0.5 构建失败，尝试了安装opengl，glut等依赖依旧没能解决，估计是因为wsl的图形驱动没能处理好。索性我在windows尝试了一番。

windows运行gloss

使用stack新建项目并添加gloss依赖，这时候stack build正常了，但是stack run会报错

1
2
F:\project-private\test\test-2d>stack run
test-2d-exe.EXE: user error (unknown GLUT entry glutInit)

这是因为缺少opengl的接口，程序需要通过opengl接口访问windows显卡的opengl。
现在需要安装freeglut，官网推荐windows使用msys2进行安装。

MSYS2（Minimal SYStem 2）是一个在 Windows 平台上提供类 Unix 环境的工具集。它为 Windows 用户提供了一些 Unix 风格的命令行工具、库和开发环境，主要用于软件开发，尤其是在与 Linux 或类 Unix 系统进行交互时，提供了一个类似的开发体验。

安装好msys2后，打开msys2开始安装

搜索freeglut相关的包

1
pacman -sS freeglut

找到w64版本安装

1
pacman -S mingw-w64-x86_64-freeglut

安装完成后还需要找到msys2安装软件的bin目录，添加到环境变量中，这样在windows的haskell程序才能找到。

以下是msys2安装软件的bin目录

1
D:\Applications\msys2\mingw64\bin

在该目录能发现msys2安装的windows可用的dll文件

1
D:\Applications\msys2\mingw64\bin\libfreeglut.dll

添加完环境变量记得重新开启终端，新的终端才能读取到新的环境变量。

发表于 分类于 ，

判断多个Maybe都不为Nothing

case of 嵌套

1
2
3
4
5
6
7
8
9
processValues :: Maybe String -> Maybe String -> Maybe String -> IO ()
processValues ma mb mc = do
    case ma of
        Nothing -> responseFail "ma 为空"
        Just a -> case mb of
            Nothing -> responseFail "mb 为空"
            Just b -> case mc of
                Nothing -> responseFail "mc 为空"
                Just c -> responseSuccess "成功"

模式匹配

将多个Maybe组成元组用于模式匹配

1
2
3
4
5
6
7
processValues :: Maybe String -> Maybe String -> Maybe String -> IO ()
processValues ma mb mc = 
	case (ma, mb, mc) of 
	(Nothing, _, _) -> responseFail "ma 为空" 
	(_, Nothing, _) -> responseFail "mb 为空" 
	(_, _, Nothing) -> responseFail "mc 为空" 
	(Just a, Just b, Just c) -> responseSuccess "成功"

traverse

1
2
3
4
5
6
7
processValues :: Maybe String -> Maybe String -> Maybe String -> IO ()
processValues ma mb mc = do
    let values = [ma, mb, mc]
    let result = traverse id values  -- 遍历每个 Maybe 值，保持原有的结构
    case result of
        Nothing -> responseFail "有空值"
        Just _ -> responseSuccess "成功"

MaybeT

1
2
3
4
5
6
7
8
processValues :: Maybe String -> Maybe String -> Maybe String -> IO ()
processValues ma mb mc = do
    runMaybeT $ do
        a <- MaybeT (maybe (responseFail "ma为空" >> return Nothing) (return . Just) ma)
        b <- MaybeT (maybe (responseFail "mb为空" >> return Nothing) (return . Just) mb)
        c <- MaybeT (maybe (responseFail "mc为空" >> return Nothing) (return . Just) mc)
        liftIO $ responseSuccess "成功"
    return ()

下面这句将Maybe String转为IO (Maybe String)，如果为Nothing将会打印提示

1
maybe (responseFail "ma为空" >> return Nothing) (return . Just) ma)

MaybeT包裹IO (Maybe String)使得遇到Nothing后短路

发表于 分类于 ，

在定义函数的时候尽量不要包含名词，让函数能够处理的数据范围更大。

使用现有的高阶函数处理数据，在对大量的高阶函数熟悉之后能够快速使用现有的函数实现功能。

发表于 分类于 ，

下方代码定义了一个ServiceContext，在多个Service中可以共享该ServiceContext的内容

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
type Service site = ReaderT ServiceContext (HandlerFor site)

someService1 :: Service App ()
someService1 = do
    ServiceContext now <- ask
    print now

someService2 :: Service App ()
someService2 = do
    ServiceContext now <- ask
    print now

someService :: Service App ()
someService = someService1 >> someService2

runService :: Service App a -> HandlerFor App a
runService service = do
    now <- localTime
    ctx <- ServiceContext now
    runReaderT service ctx

handlerUser :: HandlerFor App ()
handlerUser = do
    user <- runService someService

注意这里runService引入了副作用，每次调用runService的时间会重新生成。
在上面的例子中，runService只使用了一次，所以不会有问题。

什么时候会调用多次呢？
当在Service内使用了其他Monad，而其他Monad又要调用Service的情况

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
type Db site = ReaderT Connection (HandlerFor site)
runDB :: Db site a -> HandlerFor App a

insertDB :: Db App ()
insertDB = do
    user <- lift $ runService createUserService
    insert_ user

addUserService :: Service App ()
addUserService = 
    lift $ runDB insertDB

handlerUser :: HandlerFor App ()
handlerUser = do
    user <- runService addUserService

这时候HandlerFor和Db都调用了runService，两次生成的时间是不同的。
要避免这种情况有好几种方式

方式1：避免相互调用

Service处理完Db处理，不在Db中引入Service的逻辑

1
2
3
4
addUserService :: Service App ()
addUserService = 
    user <- createUserService
    lift $ runDB $ insert_ user

也可以传递ServiceContext到其他Monad内手动解包而不是通过runService解包

1
2
3
4
5
6
addUserService :: Service App ()
addUserService = 
    context <- ask
    lift $ runDB do
        user <- runReaderT createUserService context
        insert_ user

方式2：堆叠Monad

何不构建一个既可以执行Service又能执行Db的Monad呢

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
type Db site = ReaderT Connection (HandlerFor site)
type Service site = ReaderT ServiceContext (HandlerFor site)
-- 嵌套
type DbService site = ReaderT Connection (Service site)

runDB :: Db site a -> HandlerFor App a
runDB = ...

runDBService :: DbService site a -> Service site a
runDBService dbService = do
    -- 解包最外层，得到Service
    lift $ runDB $ runInnerService dbService
    where
        -- 转换ReaderT的Monad参数，等同下方
    -- runInnerService :: ReaderT Connection (Service site) a -> ReaderT Connection (HandlerFor site) a
        runInnerService :: DbService site a -> Db site a
        runInnerService dbService = hoistReaderT runService dbService

-- 因为 ReaderT r m a = ReaderT { runReaderT :: r -> m a }
-- 所以 f :: r -> ma
hoistReaderT :: (m a -> n a) -> ReaderT r m a -> ReaderT r n a
hoistReaderT nat (ReaderT f) = ReaderT (nat . f)

一开始错误的使用runService <$> dbService进行转换。

其本质依旧是一个函数

1
2
3
Handler: HandlerData -> IO a
Service: ServiceContext -> (HandlerData -> IO a)
DbService: Connection -> (ServiceContext -> (HandlerData -> IO a))

发表于 分类于 ，

在搭建业务系统的时候有些通用的逻辑经常反复使用，如下

  • 获取一个统一的当前时间
  • 获取用户信息
  • 若实体存在再执行某个方法
  • 若实体是唯一的再执行某个方法

为此，对Yesod框架的Handler进行拓展

提供ServiceContext

1
2
3
4
data ServiceContext site = ServiceContext
        { serviceCtxUserId :: RawUserId site
        , serviceCtxTime :: LocalTime
    }

如何将ServiceContext传递给Service呢，这时候有两种方式可以解决

方式1：定义一个获取Context的方法

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
getContext :: ServiceContext site
getContext = ....

doSomething1 :: Handler a
doSomething1 = do
    sc <- getContext
    ....

doSomething2 :: Handler a
doSomething2 = do
    sc <- getContext
    ....

myhandler :: Handler a
myhandler = do
    doSomething1
    doSomething2

这种方式存在一个问题，就是每次调用的时候都会执行函数，多次执行获取的时间并不相同。

方式2：使用ReaderT

定义一个ReaderT将计算好的数据传递给HandlerFor

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
type ServeFor site a = (RawUserIdGetter site) => 
    ReaderT (ServiceContext site) (HandlerFor site) a

runServeFor :: ServeFor site a -> (HandlerFor site) a
runServeFor service = do
    let sc = ServiceContext ...
    runReaderT service sc

serveFor1 :: ServeFor site a
serveFor1 = do
    sc <- ask
    ....

serveFor2 :: ServeFor site a
serveFor1 = do
    sc <- ask
    ....

myhandler :: Handler a
myhandler = do
    runServeFor serveFor1
    runServeFor serveFor2

提供参数

每个Service都有独立的参数类型，提供的方式又有很多种

方式1：放在ServiceContext

为ServiceContext添加一个参数类型

1
2
3
4
5
data ServiceContext site a = ServiceContext
        { serviceCtxUserId :: RawUserId site
        , serviceCtxTime   :: LocalTime
        , serviceData      :: a -- 新增参数
    }

runServeFor需要添加一个参数

1
2
3
4
5
6
7
8
runServeFor :: form -> ServeFor site a -> (HandlerFor site) a
runServeFor form service = do
    -- 需要提供表单给ServiceContext
    let sc = ServiceContext {
        ...
        serviceData = form
    }
    runReaderT service sc

该方式处理起来更加简洁，不同嵌套太多，否者还得单独处理参数

方式2：新增函数

因为ServeFor缺少参数，可以定义一个有参数的函数

1
param -> ServeFor site result

这时候有两种选择

使用class

参数和返回值由具体的实现提供。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
class Service param site where
    type Output param
    action :: param -> ServeFor site (Output param)

newtype AddUserService = AddUserService UserForm
newtype AddUserService = AddGroupService GroupForm

instance Service AddUserService App where
    action :: AddUserService -> ServeFor site ()

instance Service AddGroupService App where
    action :: AddGroupService -> ServeFor site ()

class ServiceRunner site where

    runService :: (ServiceRunner site) => Service site -> HandlerFor site result

instance ServiceRunner App where
    runService service =
        ServiceContext <$> getRawUserId <*> nowDateTime >>=
        runReaderT (action service)

使用newtype

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
newtype Service site param result = Service {
    action :: param -> ServeFor site result
}

addUserService :: Service App UserForm ()

addGroupService :: Service App GroupForm ()

class ServiceRunner site where

    runService :: (Service param result site) => param -> HandlerFor site result

instance ServiceRunner App where
    runService service =
        ServiceContext <$> getRawUserId <*> nowDateTime >>=
        runReaderT (action service)

newtype和class都能实现，这取决于runService是接收一个数据还是接收一个函数，简单的例子如下

1
2
3
4
5
-- 通过class多态实现，参数需要实现ToJson，
responseJsonStr :: ToJson a => a -> String

-- 直接传递生成json的函数
responseJsonStr :: (a -> JsonValue) -> String

传递函数这种风格看起来更加符合函数式编程且更简洁。

提升Monad

下方是我的Service定义，使用newtype封装ReaderT

1
2
newtype ServeFor site param a = ServeFor (ReaderT (ServiceContext site param) (HandlerFor site) a)
    deriving (Functor, Applicative, Monad, MonadIO, MonadResource, MonadLogger)

因为使用的是newtype，所以在这个新类型下无法调用其他Monad，所以需要定义提升操作，这样才能和其他Monad交互。

提升包含两部分，

  • 其他类型提升为当前类型，m a -> ServeFor site parma a
  • 提升当前类型为其他类型，ServeFor site parma a -> m a

HandlerFor 与 ServeFor的关系

根据ServeFor的签名可以知道，ServeFor是包含了ServiceContext的HandleFor。所以ServeFor可以解包成HandleFor，HandleFor可以提升为ServeFor。

在HandlerFor中使用Service需要通过runServeFor并传递ServiceContext将ServeFor解包。

1
2
runServeFor :: ServeFor site param a -> ServiceContext site param -> HandlerFor site a
runServeFor (ServeFor service) context = runReaderT service context

在ServeFor中使用HandlerFor需要对HandlerFor提升

1
2
3
instance MonadHandler (ServeFor site param) where
    type HandlerSite (ServeFor site param) = site
    liftHandler handler = ServeFor $ lift handler

发表于 分类于 ，

stack new 项目名

创建一个项目

stack init

生成stack.yml文件

stack setup

这个命令会检查你的项目所需的 GHC（Glasgow Haskell Compiler）版本是否已安装。如果没有，它会自动下载并安装所需版本。这个命令通常在第一次设置项目时使用。

以下命令查询当前项目的ghc版本，而不是系统的ghc版本

1
stack exec -- ghc -v

查看系统ghc版本

1
ghc -v

显示为项目下载ghc，不加参数在系统存在ghc的情况下不会下载

1
stack setup --install-ghc

stack build

这个命令会根据 stack.yaml 文件中指定的依赖项构建项目。它会编译项目的源代码，并确保所有依赖都正确安装和编译。这个命令是实际构建项目的核心命令。

stack install

这个命令会将构建好的可执行文件安装到你的系统中，通常是放在 ~/.local/bin 目录下。它可以让你在命令行中直接调用项目生成的可执行文件，而不需要指定完整路径。

stack update

此命令会更新 Stack 的包索引，以确保你获取到最新的可用库和依赖项。这是获取新版本库和更新信息的好方法。

stack可执行文件的路径

stack build之后的可执行文件路径通常是.stack-work\install\x86_64-linux-tinfo6\8a029dbf41a1c3fcb35019c33e03ac25af5edc3e649d290045c7d445666bbf8b\9.6.5\bin，包含了一个随机字符串，而在配置Dockerfile的时候需要固定的路径，这时候可以通过以下方式解决

stack path –local-install-root

1
2
RUN EXEC_PATH=$(stack path --local-install-root)/bin && \
    cp "$EXEC_PATH/recite" /tmp/recite  # 假设可执行文件名为 recite

通过stack path --local-install-root找到目录并复制到/tmp下

stack build –copy-compiler-tool

该命令会将可执行文件复制一份到.stack/compiler-tools/x86_64-linux-tinfo6/ghc-9.6.5/bin/下

stack run

根据 package.yaml 中的配置来运行项目的主模块，通常是定义在 executable 部分的模块。

发表于 分类于 ，

导入hspec依赖

配置package.yml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
name: projectname

dependencies:
- hspec

tests:
  projectname-test:
    main:                Spec.hs
    source-dirs:         test
    ghc-options:
    - -threaded
    - -rtsopts
    - -with-rtsopts=-N
    dependencies:
    - projectname

在package.yml定义的main文件添加ghc参数

  • -F：告诉 GHC 使用自定义的预处理器。
  • -pgmF hspec-discover：指定 hspec-discover 作为预处理器。

在Spec.hs添加ghc参数

1
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

编写测试

文档

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
{-# LANGUAGE OverloadedStrings #-}

module ParserSpec (spec) where

import Test.Hspec
import Parser (parseLocalDate)
import Data.Time.Calendar (fromGregorian)
import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..))

spec :: Spec
spec = do
  parseLocalDateSpec

parseLocalDateSpec :: Spec
parseLocalDateSpec = describe "parseLocalDate" $ do
    it "parses a valid date string" $ do
      let dateStr = "2024-10-25 225530"
      let expectedDate = LocalTime (fromGregorian 2024 10 25) (TimeOfDay 22 55 30)
      parseLocalDate dateStr `shouldBe` expectedDate

    it "returns Nothing for an invalid date string" $ do
      let invalidDateStr = "invalid-date"
      evaluate (parseLocalDate invalidDateStr) `shouldThrow` anyErrorCall
  • describe：用于分组相关的测试案例。一般用于描述被测试的函数或模块，通常是一级分组。
  • it：表示一个具体的测试案例，用于描述单个测试的行为或期望的结果。it 后面通常跟一个字符串描述该测试的目的。
  • shouldBe：断言运算符，用于验证测试的结果是否符合期望值。当表达式的结果与预期不符时，测试将失败。
  • evaluate：用于强制求值一个表达式，以便在需要测试的地方触发异常。通常与 shouldThrow 搭配使用。
  • shouldThrow：用于断言一个表达式是否抛出异常。与 evaluate 一起使用，检查表达式是否会因无效输入等原因引发错误。
  • anyErrorCall：一个通用匹配器，适用于 shouldThrow。当不关心异常的具体类型时可以使用 anyErrorCall 来匹配任何错误调用。

值得注意的是evaluate关键字在这里的应用，因为haskell的惰性求值的语言，也就是说下面这段代码将不会执行parseLocalDate invalidDateStr

1
parseLocalDate invalidDateStr `shouldThrow` anyErrorCall

因为parseLocalDate的结果并没有被其他方法使用，通过evaluate包裹才能强制执行该方法。

发表于 分类于 ，

Yesod框架在响应json异常的时候可以调用sendStatusJSON

其签名如下

1
sendStatusJSON :: (MonadHandler m, ToJSON c) => Status -> c -> m a

之所以返回值是a，也就是任意类型是因为其实现是throwIO并不关心返回值。

0%