Myu

2025年8月25日月曜日

Haskell入門P368　ルーティング、本体

HaskellでSpockを使ったルーティングは、慣れるまで大変そうですが、無駄のない構成という感じがします。

-- src/Web/WeightRecorder.hsに追記。
authHook :: WRAction WRContext
authHook = do
  ctx <- getContext
  mUser <- fmap wrsesUser readSession
  case mUser of
    Nothing -> startView Nothing
    Just user ->
      return $
      ctx
      { wrconUser = Just user
      }

-- src/Web/WeightRecorder.hsに追記。
-- ルーティング定義。
spockApp :: WRApp () ()
spockApp =
  prehook (return emptyContext) $
  do prehook authHook $
       do get root $ mainView Nothing
          post "new_record" newRecordAction
     post "register" registerAction
     post "login" loginAction

-- src/Web/WeightRecorder.hsに追記。
weightRecorderMiddleware :: WRConfig -> IO WAI.Middleware
weightRecorderMiddleware cfg = do
  -- テンプレートの読み込み。
  starttpl <- loadStartTemplate cfg
  maintpl <- loadMainTemplate cfg
  -- 状態を作成。
  let state =
        WRState
        { wrstStartTemplate = starttpl
        , wrstMainTemplate = maintpl
        }
  pool <- sqlitePool $ wrcDBPath cfg
  -- セッションと状態を渡して設定を作成。
  spCfg <- defaultSpockCfg emptySession (PCPool pool) state
  spock spCfg spockApp -- 生成。

-- src/Web/WeightRecorder.hsに追記。
sqlitePool :: FilePath -> IO (Pool Connection)
sqlitePool dbpath = createPool (connectSqlite3 dbpath) disconnect 1 60 5

-- src/Web/WeightRecorder.hsに追記。
runWeightRecorder :: WRConfig -> IO ()
runWeightRecorder cfg = runSpock (wrcPort cfg) (weightRecorderMiddleware cfg)

authHook:ログイン認証

・ctx <- getContextについて：ユーザーからのリクエスト関連情報が、ある時点で箱にはいっていて、そこから、とりだしたのがctxへいく、というイメージ。

・mUser <- fmap wrsesUser readSessionについて：オブジェクトにフィールド名を関数として適用すると、該当フィールドの要素を返す仕組みになっている(P96).

readSession :: WRAction (SessionVal UserSession):現在のリクエストに紐づくセッション情報を取得する関数 data UserSession = UserSession { wrsesUser :: Maybe User....から、取り出しmUserに

spockApp:ルーティング

・外側のprehookは認証なし、内側はauthHookで認証　うまく階層的に配置してわかりやすい構造

・get,postの別やURLと対応するActionが並べられている。

prehook (return emptyContext) $

├─ prehook authHook $ do

│ ├─ get root

│ └─ post "new_record"

├─ post "register" ← authHook は適用されない

└─ post "login" ← authHook は適用されない

weightRecorderMiddleware:WAI ミドルウェアとして起動するための処理

・runWeightRecorder cfgで定義されているように、runSpockで呼ばれる。

　　ここで、spock spCfg spockApp にreturnがないが、do内のモナド計算なので不要

2025年8月24日日曜日

Haskell入門 P364 グラフ表示部の実装

ここも、分かりにくいところがあり、ChatGPTの助けを借りるが、ほぼ完ぺきにわかりやすく説明してくれるので、非常に助かる。

・weightGraphValueはMustacheへ渡すValueを返すのが役目。

・liftIO $ mapM flat wrsについて：flatでweightはそのまま使い、日付のみ"%m/%d"形式に変換し、 flat::WeightRecord-> IO (String,Double)　よりmapM flat wrsはIO[(String,Double)]を返す。このへんは、mapMの働きを覚えてないと使えない、正直言って、前に学習(P174)したことを忘れており、復習して気づいた感じ。IOを含んでいるのでliftIOでWRActionモナドに持ち上げている。

・let wrss = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ flatWrsについて:

sortBy (compare `on` fst) は、fstの日付でソートしている。groupBy ((==) `on` fst) は同じ日付のものをまとめるらしい。つまり[ [("08/20",60.5), ("08/20",61.0)], [("08/21",60.8)]となる。wrssはリストのリストになります。(==)にそういう機能があることなど、非常に細かいところだけどChatGPTがしっかり解説してくれたのには、驚いた。

　本によれば、onは第二引数の関数を適用してから、第一引数の２項演算子を適用するという働きらしい。これと、上記の説明をみて、ようやく意味が理解できた。

・groupToValueについて：　　:: [(String, Double)] -> Valueである。

　　dt = head $ map fst gr→ グループの日付を取り出す（全部同じなので先頭でOK）。

　　 wt = avg $ map snd gr→ 複数記録がある場合は平均を取る。

　なるほど、うまくでてきています。これを使えばgroupToValue [("08/20",60.5),("08/20",61.0)]→ object ["day" ~> "08/20", "weight" ~> 60.75]となります。

2025年8月22日金曜日

Haskell入門 P354 各種操作の実装

whenはtrueならアクションを実行、startViewは実行したら次の行にはいかない。

runSqlite で　(Connection -> IO m)を引数にとるため、insertUserの部分適用をうまく使っている。　(insertUser :: IConnection c => NewUser -> c -> IO Integerなので)

このへんがHaskellの簡潔さにつながっているのだと思う。

Haskell入門 P352　コントローラの開発

P352「type WRApp ctx= SpockCtxN ctx WRConnection WRSession WRState

type WRAciton = SpockActionCtx WRCibtext WRConnection WRSession WRState

WRAppとWRActionはWeightRecoder アプリケーションで利用するモナドです。
先ほどコンテキストにはWRContextを使うものとしてsrc/Web/Core.hsに定義しました。
　しかし、/のコンテキストは必ず()になるため、WRContextは適しません。そのため、ルーティングに用いるWRAppでは()にも対応できるよう、ctxを指定できるよう定義しています。一方で、ロジックを実際に記述するWRActionのコンテキストは、()を受け取らないようにできるため、型変数ではなくWRContext固定としています。このため、ルーティングの根本でコンテキストをWRContextに設定する必要があります。」

　この部分がよくわからなかった。どうやら、型変数ctxの例がWRContextという型などであるようだ。WRappとWRActionは厳密に関連しているのかと思ったけれど、必ずしもそういうことではなかったよう。WRAction が型変数をとらない理由は、型を固定して型安全にしたいからのよう。WRApp はルートや URL ごとに ctx が異なる可能性があるので型変数で柔軟にしている。そういうことらしい。WRappは設定データだから、いろんなデータを設定できる方がいい、でもWRActionは、安全性が求められるのである程度使える設定データは制限したい、そんな感じだろうか。

2025年8月21日木曜日

Haskell入門　P347　ユーザー登録のためのINSERT

仕組みがわかりにくかった。

module Model.User
     ( NewUser(NewUser, nuName, nuPassword)
     , nuName'
     , nuPassword'
     , insertUser
     , selectUser
     )
  where

-- import 省略

data NewUser = NewUser
  { nuName     :: !String
  , nuPassword :: !String
  }

makeRecordPersistableDefault ''NewUser

-- 射影を定義。
piNewUser :: HRR.Pi User.User NewUser
piNewUser = NewUser HRR.|$| User.name' HRR.|*| User.password'

-- src/Model/User.hsに追記。
-- 第一引数で新ユーザ、第二引数で接続を指定。
insertUser
  :: IConnection c
  => NewUser -> c -> IO Integer
insertUser u conn = do
  mHashed <-
    -- ハッシュ生成。第一引数はハッシュ化ポリシー設定。
    hashPasswordUsingPolicy slowerBcryptHashingPolicy $
    enc . nuPassword $ u
  case mHashed of
    -- ハッシュ生成失敗の場合。
    Nothing -> do hPutStrLn stderr "Failed to hash password"
                  return 0
    -- ハッシュ生成成功の場合。
    Just hashed -> do
      let ins = HRR.typedInsert User.tableOfUser piNewUser
          u' =
            u
            { nuPassword = dec hashed
            }
      -- トランザクション維持。
      withTransaction conn $
        \conn' ->
           -- ここでINSERT文実行。
           DHR.runInsert conn' ins u' `catch`
           \e ->
              do hPrint stderr (e :: SqlError)
                 return 0

-- ハッシュ化した情報を取り扱うエンコーダとデコーダ。
enc :: String -> BS.ByteString
enc = encodeUtf8 . pack

dec :: BS.ByteString -> String
dec = unpack . decodeUtf8

-- src/Model/User.hsに追記。
-- 第一引数にユーザ名、第二引数にパスワード、第三引数に接続を指定。
selectUser
  :: IConnection c
  => String -> String -> c -> IO (Maybe User.User)
selectUser name pass conn = do
    -- runQueryでクエリ実行で情報取り出し、listToUniqueでリストを一意に。
    user <- DHR.runQuery conn q name >>= DHR.listToUnique
    return $ user >>= checkHash
  where
    -- 関数の性格上、where以下に定義する。
    -- クエリの定義
    q :: HRR.Query String User.User
    q =
      HRR.relationalQuery . HRR.relation' . HRR.placeholder $
      \ph ->
         do a <- HRR.query User.user
            HRR.wheres $ a HRR.! User.name' HRR..=. ph
            return a
    -- ハッシュをチェックする。
    checkHash :: User.User -> Maybe User.User
    checkHash user
        | validated = Just user
        | otherwise = Nothing
      where
        hashed = User.password user
        -- ハッシュ化したパスワードとの照合。
        validated = validatePassword (enc hashed) (enc pass)

そこで、次のような質問をChatGPTにしてみた。

Q1：piNewUserは、どういうふうに使い方をするのですか？

Ans: let ins = HRR.typedInsert User.tableOfUser piNewUser がポイント

typedInsert :: Table User -> Pi User NewUser -> Insert NewUser

第1引数 User.tableOfUser → 「Userテーブルそのもの」

第2引数 piNewUser → 「NewUser から User のカラムに対応付ける射影」

let ins = HRR.typedInsert User.tableOfUser piNewUser

u' = u { nuPassword = dec hashed } ins は INSERT 文のひな型

DHR.runInsert conn' ins u' と実行すると、

u' :: NewUser の値（ユーザー名とハッシュ済パスワード）を

piNewUser に従って User テーブルの name, password カラムに対応付け

実際に DB へ INSERT

Q2: 要するに、手順を最初にくみたてて、最後に、runInsertで実行するのですね。

Ans: はい、その理解でバッチリです！

まとめると：

piNewUser で「どう射影するか」を定義（テーブルと型の橋渡し）。

typedInsert で「INSERT文のひな型」を作成。

runInsert で「実際の値」を流し込んでDBに送信。

※　Haskellは、手続き型のように「値を受け取りながら逐次SQL発行」というやり方はあまりせず、まず「設計図を型安全に作る → 値を流し込む」という宣言的な流れ

　型安全性が高い：SQL文やカラム名の間違いをコンパイル時に検出できる

　SQLインジェクション対策が組み込みである：値を直接文字列連結しないので安全

　トランザクション管理が明確：withTransaction の中で設計図に値を流し込むので、途中でエラーがあればロールバック可能

　コードの再利用性が高い：射影（piNewUser のような定義）を作っておくと、INSERTや　　SELECTで同じマッピングを使い回せる

　などの利点があるらしい

Q3:makeRecordPersistableDefault ''NewUser　はどういう意味？

Ans:NewUser を Relational-Record の「DBに入出力できる型」として登録する宣言、Template Haskell によって必要な型クラスインスタンスを自動生成している

「この型をSQLに流せるようにしますよ！」と最初に宣言しておく儀式みたいなもの

Q4:Template Haskellとは？（P340にも説明はありますが）

Ans:「Haskellプログラム自身を生成する Haskellプログラム」を書ける

Q5:自動生成ですね。DjangoやRuby on Railsなどでも、DB初期化で似たような処理あったような気がしますね.

Ans:まさに Django や Ruby on Rails と同じ発想です。

Rails/Django = 実行時に自動生成・マッピング

Haskell(TH) = コンパイル時に自動生成・型安全にマッピング

Q6:user <- DHR.runQuery conn q name >>= DHR.listToUniqueのDHR.listToUniqueの働きは？

Ans:[] の場合 → Nothing を返す、[x] の場合 → Just x を返す、[x, y, ...] の場合 → エラーか Nothing を返す。「DB側にユニーク制約があるとは限らない」設計を想定。

Q7:checkHash user | validated = Just user | otherwise = Nothingの意味は？

Ans: if ... else if ... else if ... elseのイメージで、最初にtrueになったところが　checkHash userの値。ガードの機能(p62で既習)

2025年8月18日月曜日

Haskell入門 P326　処理のまとめ

stack install で実行ファイルを作り、動作確認してみた。これも、一筋縄ではいかず、Windowsだと、文字エンコードなど配慮しないとうまくいかなかった。エラーメッセージ見たり、ChatGPTに聞いたりしながら、なんとか解決。

echo [{"age":"aa","name":"名前","telnumber":"abcdef"},"age":"bb","name":"abcd","telnumber":"jkl"}] > test.json

としてファイルをつくってから

hjq-exe "{\"name\":.[1].name,\"telnumber\":.[1].telnumber}" test.json

としたらうまくいった。ハイフンがあるとうまくいかず、カットする必要あった。なかなか、大変だった。

package.yamlのdependenciesは最終的にこのようになった
 dependencies:
  - base >= 4.7 && < 5
  - text
  - megaparsec
  - aeson
  - lens
  - lens-aeson
  - vector
  - unordered-containers
  - errors
  - bytestring
  - aeson-pretty
                         
Hjq.hsは
{-# LANGUAGE OverloadedStrings #-}
module Data.Hjq ( hjq ) where
import Control.Error.Util
import Data.Aeson
import Data.Text as T
import Data.ByteString.Lazy as B
import Data.Hjq.Parser
import Data.Hjq.Query
import Data.Aeson.Encode.Pretty
import Data.Bifunctor (first)

hjq :: B.ByteString -> T.Text -> Either T.Text B.ByteString
hjq jsonString queryText = do
  value <- note "Invalid json format." $ decode jsonString
  query <- first T.pack $ parseJqQuery queryText   -- String -> Either Text _
  result <- executeQuery query value               -- Either Text Value
  return $ encodePretty result
                          
Main.hsは
module Main where
import System.Environment
import System.Exit
import Data.Hjq
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import System.Exit (ExitCode(..))

main :: IO ()
main = do
  args <- getArgs
  case args of
    (q : file : []) -> do
      jsonLazy <- BL.readFile file
      printResult $ hjq jsonLazy (T.pack q)  -- ここでは q が正しい
    (q : []) -> do
      jsonLazy <- BL.getContents
      printResult $ hjq jsonLazy (T.pack q)  -- ここも q
    _ -> putStrLn "Invalid arguments" >> exitWith (ExitFailure 1)

printResult :: Either T.Text BL.ByteString -> IO ()
printResult (Right s) = do
    BL.putStr s
    putStrLn ""  -- 改行を追加
printResult (Left s)  = do
    T.putStrLn s
    exitWith $ ExitFailure 1

Hjq.hs

・note:MaybeをEitherに変換　　　　decode:ByteStringをValueに変換

　first:Rightはそのまま、Leftに関数を適用

Haskell入門　P323　テストようやく終了

本のままでは、動かず新しいバージョンに合わせた修正が必要だった。

-- Spec.hs *********************
  {-# LANGUAGE OverloadedStrings #-}

import Test.HUnit
import qualified Data.Text()
import Data.Text (Text,unpack)   
import Data.Hjq.Parser
import Data.Hjq.Query(applyFilter,executeQuery)
-- import qualified Data.HashMap.Strict as H
import qualified Data.Vector as V
import Data.Aeson
import qualified Data.Aeson.KeyMap as KM
import Control.Lens
import Data.Aeson
import Data.Aeson.Lens

jqFilterParserTest :: Test
jqFilterParserTest = TestList
  [ "jqFilterParser test 1" ~: parseJqFilter "." ~?= Right JqNil
  , "jqFilterParser test 2" ~: parseJqFilter ".[0]" ~?= Right (JqIndex 0 JqNil)
  , "jqFilterParser test 3" ~: parseJqFilter ".fieldName" ~?= Right (JqField "fieldName" JqNil)
  , "jqFilterParser test 4" ~: parseJqFilter ".[0].fieldName" ~?= Right (JqIndex 0 (JqField "fieldName" JqNil))
  , "jqFilterParser test 5" ~: parseJqFilter ".fieldName[0]" ~?= Right (JqField "fieldName" (JqIndex 0 JqNil))
  ]

jqFilterParserSpacesTest :: Test
jqFilterParserSpacesTest = TestList
  [ "jqFilterParser spaces test 1" ~:
      parseJqFilter " . " ~?= Right JqNil
  , "jqFilterParser spaces test 2" ~:
      parseJqFilter " . [ 0 ] " ~?= Right (JqIndex 0 JqNil)
  , "jqFilterParser spaces test 3" ~:
      parseJqFilter " . fieldName " ~?= Right (JqField "fieldName" JqNil)
  , "jqFilterParser spaces test 4" ~:
      parseJqFilter " . [ 0 ] . fieldName " ~?= Right (JqIndex 0 (JqField "fieldName" JqNil))
  , "jqFilterParser spaces test 5" ~:
      parseJqFilter " . fieldName [ 0 ] " ~?= Right (JqField "fieldName" (JqIndex 0 JqNil))
  ]
--  ************************:
jqQueryParserTest :: Test
jqQueryParserTest = TestList
  [ "jqQueryParser test 1" ~:
      parseJqQuery "[]" ~?= Right (JqQueryArray [])
  , "jqQueryParser test 2" ~:
      parseJqQuery "[.hoge,.piyo]" ~?=
        Right (JqQueryArray [JqQueryFilter (JqField "hoge" JqNil), JqQueryFilter (JqField "piyo" JqNil)])
  , "jqQueryParser test 3" ~:
      parseJqQuery "{\"hoge\":[],\"piyo\":[]}" ~?=
        Right (JqQueryObject [("hoge", JqQueryArray []), ("piyo", JqQueryArray [])])
  ]
jqQueryParserSpacesTest :: Test
jqQueryParserSpacesTest = TestList
  [ "jqQueryParser spaces test 1" ~:
      parseJqQuery " [ ] " ~?= Right (JqQueryArray [])
  , "jqQueryParser spaces test 2" ~:
      parseJqQuery " [ . hoge , . piyo ] " ~?=
        Right (JqQueryArray [JqQueryFilter (JqField "hoge" JqNil), JqQueryFilter (JqField "piyo" JqNil)])
  , "jqQueryParser spaces test 3" ~:
      parseJqQuery "{ \"hoge\" : [ ] , \"piyo\" :  [ ] } " ~?=
        Right (JqQueryObject [("hoge", JqQueryArray []), ("piyo", JqQueryArray [])])
  ]
-- *****************
applyFilterTest :: Test
applyFilterTest = TestList
  [ "applyFilter test 1" ~: applyFilter (unsafeParseFilter ".") testData ~?= Right testData   
  , "applyFilter test 2" ~:
      (Just $ applyFilter (unsafeParseFilter ".string-field") testData)
      ~?= fmap Right (testData^?key "string-field")
  , "applyFilter test 3" ~:
      (Just $ applyFilter (unsafeParseFilter ".nested-field.inner-string") testData)
      ~?= fmap Right (testData ^? key "nested-field" . key "inner-string")
  , "applyFilter test 4" ~:
      (Just $ applyFilter (unsafeParseFilter ".nested-field.inner-number") testData)
      ~?= fmap Right (testData ^? key "nested-field" . key "inner-number")
  , "applyFilter test 5" ~:
      (Just $ applyFilter (unsafeParseFilter ".array-field[0]") testData)
      ~?= fmap Right (testData ^? key "array-field" . nth 0)
  , "applyFilter test 6" ~:
      (Just $ applyFilter (unsafeParseFilter ".array-field[1]") testData)
      ~?= fmap Right (testData ^? key "array-field" . nth 1)
  , "applyFilter test 7" ~:
      (Just $ applyFilter (unsafeParseFilter ".array-field[2].object-in-array") testData)
      ~?= fmap Right (testData ^? key "array-field" . nth 2 . key "object-in-array")
  ]
executeQueryTest :: Test
executeQueryTest = TestList
 -- [ "executeQuery test 1" ~: executeQuery (unsafeParseQuery "{}") testData ~?= Right (Object $ H.fromList [])
  [ "executeQuery test 1" ~: executeQuery (unsafeParseQuery "{}") testData ~?= Right (Object $ KM.fromList [])
  , "executeQuery test 2" ~:
      executeQuery (unsafeParseQuery "{ \"fielda\": . , \"fieldb\": .string-field }") testData ~?=
 --  Right (Object $ H.fromList [("fielda", testData), ("fieldb", String "string value")])
     Right (Object $ KM.fromList [("fielda", testData), ("fieldb", String "string value")])
  , "executeQuery test 3" ~:
      executeQuery (unsafeParseQuery "[ .string-field, .nested-field.inner-string ]") testData ~?=
      Right (Array $ V.fromList [String "string value", String "inner value"])
  ]
-----
testData :: Value
-- testData = Object $ H.fromList
testData = Object $ KM.fromList
  [ ("string-field", String "string value")
--  , ("nested-field", Object $ H.fromList
    , ("nested-field", Object $ KM.fromList
      [ ("inner-string", String "inner value")
      , ("inner-number", Number 100)
      ]
    )
  , ("array-field", Array $ V.fromList
      [ String "first field"
      , String "next field"
   -- , Object (H.fromList
      , Object (KM.fromList
        [ ("object-in-array", String "string value in object-in-array")
        ] )
      ]
    )
  ]
unsafeParseFilter :: Text -> JqFilter
unsafeParseFilter t = case parseJqFilter t of
  Right f -> f
  -- Left s -> error $ "PARSE FAILURE IN A TEST : " ++ unpack s
  Left s -> error $ "PARSE FAILURE IN A TEST : " ++ s
unsafeParseQuery :: Text -> JqQuery
unsafeParseQuery t = case parseJqQuery t of
  Right q -> q
  -- Left s -> error $ "PARSE FAILURE IN A TEST : " ++ unpack s
  Left s -> error $ "PARSE FAILURE IN A TEST : " ++ s
main :: IO ()
main = do
  result <- runTestTT $ (TestList [
     jqFilterParserTest
   , jqFilterParserSpacesTest
   , jqQueryParserTest
   , jqQueryParserSpacesTest
   , applyFilterTest
   , executeQueryTest
   ])
  print result
-- Parser.hs ******************************************
        {-# LANGUAGE OverloadedStrings #-}
module Data.Hjq.Parser
  ( JqFilter(..)
  , parseJqFilter
  , JqQuery(..)
  , parseJqQuery
  ) where

import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import Data.Void (Void)
import qualified Data.Text as T
import Data.Char ()

------------------------------------------------------------
-- JqFilter 定義
------------------------------------------------------------
data JqFilter
  = JqNil
  | JqField String JqFilter
  | JqIndex Int JqFilter
  deriving (Show, Read, Eq)

type Parser = Parsec Void String

------------------------------------------------------------
-- JqFilter パーサ
------------------------------------------------------------
parseJqFilter :: T.Text -> Either String JqFilter
parseJqFilter s =
  case parse (sc *> topFilter <* eof) "" (T.unpack s) of
    Left err -> Left (errorBundlePretty err)
    Right v  -> Right v

topFilter :: Parser JqFilter
topFilter = schar '.' *> filterRest

filterRest :: Parser JqFilter
filterRest = try parseIndex <|> try parseField <|> pure JqNil

parseField :: Parser JqFilter
parseField = do
  name <- lexeme (some (letterChar <|> schar '-' ) )
  rest <- option JqNil (schar '.' *> filterRest <|> parseIndex)
  return $ JqField name rest

parseIndex :: Parser JqFilter
parseIndex = do
  idx <- schar '[' *> lexeme L.decimal <* schar ']'
  rest <- option JqNil (schar '.' *> filterRest <|> parseField)
  return $ JqIndex idx rest

------------------------------------------------------------
-- JqQuery 定義 & パーサ
------------------------------------------------------------
data JqQuery
  = JqQueryObject [(T.Text, JqQuery)]
  | JqQueryArray [JqQuery]
  | JqQueryFilter JqFilter
  deriving (Show, Read, Eq)

parseJqQuery :: T.Text -> Either String JqQuery
parseJqQuery s =
  case parse (sc *> jqQueryParser <* eof) "" (T.unpack s) of
    Left err -> Left (errorBundlePretty err)
    Right v  -> Right v

jqQueryParser :: Parser JqQuery
jqQueryParser = queryArray <|> queryObject <|> queryFilter

queryArray :: Parser JqQuery
queryArray = do
  _ <- schar '['
  elems <- jqQueryParser `sepBy` schar ','
  _ <- schar ']'
  return $ JqQueryArray elems

queryObject :: Parser JqQuery
queryObject = do
  _ <- schar '{'
  kvs <- qObj `sepBy` schar ','
  _ <- schar '}'
  return $ JqQueryObject kvs
  where
    qObj = do
      key <- schar '"' *> (T.pack <$> some letterChar) <* schar '"'
      _ <- schar ':'
      val <- jqQueryParser
      return (key, val)

queryFilter :: Parser JqQuery
queryFilter = JqQueryFilter <$> topFilter

------------------------------------------------------------
-- 共通補助
------------------------------------------------------------
sc :: Parser ()
sc = L.space space1 empty empty

lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc

schar :: Char -> Parser Char
schar c = lexeme (char c)
-- Query.hs *********************************************
  {-# LANGUAGE OverloadedStrings #-}
module Data.Hjq.Query  where
import Control.Lens
import Control.Monad
import Data.Monoid
import Data.Hjq.Parser
import Data.Aeson
import Data.Aeson.Lens
-- import Data.Text as T
import qualified Data.Vector as V
-- import qualified Data.HashMap.Strict as H
import qualified Data.Text as T
import Data.Aeson.Key (fromText)
import qualified Data.Aeson.KeyMap as KM
import qualified Data.Aeson.Key as Key

applyFilter :: JqFilter -> Value -> Either T.Text Value
applyFilter (JqField fieldName n) obj@(Object _)
  = join $ noteNotFoundError (T.pack fieldName) (fmap (applyFilter n) (obj ^? key (fromText(T.pack fieldName))))
applyFilter (JqIndex index n) array@(Array _)
  = join $ noteOutOfRangeError index (fmap (applyFilter n) (array ^? nth index))
applyFilter JqNil v = Right v
applyFilter f o = Left $ "unexpected pattern : " <> tshow f <> " : " <> tshow o

executeQuery :: JqQuery -> Value -> Either T.Text Value
executeQuery (JqQueryObject o) v
-- = fmap (Object . H.fromList) . sequence . fmap sequence $ fmap (fmap $ flip executeQuery v) o
   = fmap (Object . KM.fromList . fmap (\(k,v) -> (Key.fromText k, v)))
    . sequence
    . fmap sequence
    $ fmap (fmap $ flip executeQuery v) o
executeQuery (JqQueryArray l) v
  = fmap (Array . V.fromList) . sequence $ fmap (flip executeQuery v) l
executeQuery (JqQueryFilter f) v = applyFilter f v

noteNotFoundError :: T.Text -> Maybe a -> Either T.Text a
noteNotFoundError _ (Just x) = Right x
noteNotFoundError s Nothing = Left $ "field name not found" <> s

noteOutOfRangeError :: Int -> Maybe a -> Either T.Text a
noteOutOfRangeError _ (Just x) = Right x
noteOutOfRangeError s Nothing = Left $ "out of range : " <> tshow s

tshow :: Show a => a -> T.Text
tshow = T.pack . Prelude.show

よくわからないところを確認してみた。

Spec.hs

・applyFilterTestについて

^? 指定データを１部取り出したいとき使用(lens)

　nth 2 リストの３番目要素取り出し

fmap Right (testData^?key "string-field") だと fmap::(a->b)->f a->f bでみると

　(a->b)がRight　　f aがMaybe Value f bがJustつまりMaybe(Either e Value)

　これにRightが適用なるようだ

Parser.hs

・queryArrayの　jqQueryParser `sepBy` schar ','　について

　　sepByは中値だが、２引数関数で　schar ','を区切りとして　jqQueryParserでパース

Query.hs

・applyFilter (JqField fieldName n) obj@(Object _)

= join $ noteNotFoundError (T.pack fieldName) (fmap (applyFilter n) (obj ^? key (fromText(T.pack fieldName)))) について

obj@(Object _)はObjectとか確認し、その値をobjとして利用可能

　joinはMaybeをはずすため

・executeQuery (JqQueryObject o) v

= fmap (Object . KM.fromList . fmap (\(k,v) -> (Key.fromText k, v)))

. sequence　②

. fmap sequence　①

$ fmap (fmap $ flip executeQuery v) o　　について

左辺の(JqQueryObject o) vは{"name":.name,"age":.age}::[(Text,JqQuery)]
右辺の fmap $ flip executeQuery v のflipは引数を逆順にして、部分適用を意図した通りにするために使う。(flip executeQuery v) q == executeQuery q v　
　 fmap (fmap $ flip executeQuery v) は、内側のfmapで( , )への処理を、外側のfmapで上の関数使って[ , , ]への処理を行う。
　　sequenceは①で　Eitherを外に出していく　[(either Text (Text,Value))]
②で　Ehter Text　[(Text,Value)]にする

　　　パーシングは、なかなか複雑

登録: 投稿 (Atom)