Tangle で Do 記法レスプログラミング

example.hs

-- stack script --resolver ./snapshot.yaml -- example.hs

{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedLabels  #-}
{-# LANGUAGE PolyKinds         #-}
{-# LANGUAGE TypeOperators     #-}

module Main where

import           Control.Monad.Trans.Class (lift)
import           Data.Extensible
import           Data.Proxy
import           System.Random

main :: IO ()
main = print =<< makeRec

type Rec = Record Fields
type Fields =
    '[ "hoge1" >: String
     , "hoge2" >: Bool
     , "hoge3" >: Int
     ]

{-
  makeRec :: IO Rec
  makeRec = do
    hoge1 <- getLine
    hoge3 <- randomRIO (0, 2 * length hoge1)
    pure
       $ #hoge1 @= hoge1
      <: #hoge2 @= (length hoge1 <= hoge3)
      <: #hoge3 @= hoge3
      <: emptyRecord
-}

makeRec :: IO Rec
makeRec = runTangles tangles (wrench emptyRecord)

type FieldI = Field Identity

tangles :: Comp (TangleT FieldI Fields IO) FieldI :* Fields
tangles = htabulateFor (Proxy :: Proxy MakeRec) $
  \m -> Comp $ Field . pure <$> make m

class MakeRec kv where
  make :: proxy kv -> TangleT FieldI Fields IO (AssocValue kv)

instance MakeRec ("hoge1" >: String) where
  make _ = lift getLine

instance MakeRec ("hoge2" >: Bool) where
  make _ = (<=) <$> (length <$> lasso #hoge1) <*> lasso #hoge3

instance MakeRec ("hoge3" >: Int) where
  make _ = do
    ml <- length <$> lasso #hoge1
    lift $ randomRIO (0, 2 * ml)

fun-of-tangle.hs

-- stack script --resolver ./snapshot.yaml -- fun-of-tangle.hs sampleLog.csv

{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedLabels  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds         #-}
{-# LANGUAGE TypeOperators     #-}

module Main where

import           Control.Lens                    (view, (^.))
import           Control.Monad                   ((<=<))
import           Control.Monad.Except
import           Control.Monad.IO.Class
import           Data.Aeson                      (eitherDecode)
import qualified Data.ByteString.Lazy            as LB
import           Data.Csv                        (decodeByName)
import           Data.Extensible
import           Data.Extensible.Effect.Default  (EitherDef, runEitherDef)
import           Data.Extensible.Instances.Aeson ()
import           Data.Extensible.Instances.Csv   ()
import           Data.Proxy
import           Data.String                     (fromString)
import           Data.Text                       (Text)
import qualified Data.Vector                     as V
import           GHC.TypeLits                    (KnownSymbol (..), symbolVal)
import           System.Environment              (getArgs)

type Log = Record LogFields

type LogFields =
    '[ "path"    >: FilePath
     , "time"    >: Time
     , "code"    >: Int
     , "message" >: Text
     ]

type Time = Text

type LogCsv = Record CsvFields

type CsvFields =
    '[ "time"    >: Time
     , "info"    >: LB.ByteString
     ]

type Info = Record
    '[ "code"    >: Int
     , "message" >: Text
     ]

type EIO = Eff
    '[ EitherDef String
     , "IO" >: IO
     ]

runEIO :: EIO a -> IO (Either String a)
runEIO = retractEff . runEitherDef

{- |
  main :: IO ()
  main = either error print <=< runEIO $ do
    (path:_) <- liftIO getArgs
    csv <- mappend (header `mappend` "\n") <$> liftIO (LB.readFile path)
    log' <- V.head . snd <$> either throwError pure (decodeByName csv) :: EIO LogCsv
    info <- either throwError pure (eitherDecode $ log' ^. #info) :: EIO Info
    pure $ #path @= path <: #time @= (log' ^. #time) <: info
-}

main :: IO ()
main = either error print =<< runEIO makeLog

tangles
  :: Comp (TangleT (Field Identity) MidFields EIO) (Field Identity) :* MidFields
tangles =
  htabulateFor (Proxy :: Proxy MakeLog) $ \m -> Comp $ Field . pure <$> make m

makeLog :: EIO Log
makeLog = shrink <$> runTangles tangles (wrench emptyRecord)

type MidFields = "log" >: LogCsv ': "info" >: Info ': LogFields

class MakeLog kv where
  make :: proxy kv -> TangleT (Field Identity) MidFields EIO (AssocValue kv)

instance MakeLog ("path" >: FilePath) where
  make _ = lift $ liftIO getArgs >>= \case
    (path : _) -> pure path
    _          -> throwError "please path."

instance MakeLog ("log" >: LogCsv) where
  make _ = do
    file <- lift . liftIO . LB.readFile =<< lasso #path
    lift $ V.head . snd <$>
        either throwError pure (decodeByName $ mconcat [header, "\n", file])

instance MakeLog ("info" >: Info) where
  make _ =
    lift . either throwError pure . eitherDecode . view #info =<< lasso #log

instance MakeLog ("time" >: Time) where
  make _ = view #time <$> lasso #log

instance MakeLog ("code" >: Int) where
  make _ = view #code <$> lasso #info

instance MakeLog ("message" >: Text) where
  make _ = view #message <$> lasso #info

header :: LB.ByteString
header = LB.intercalate "," . fmap fromString $ henumerateFor
  (Proxy :: Proxy (KeyValue KnownSymbol Show))
  (Proxy :: Proxy CsvFields)
  ((:) . symbolVal . proxyAssocKey)
  []

sampleLog.csv

snapshot.yaml

resolver: lts-10.6
name: matsubara0507
packages:
- git: https://github.com/matsubara0507/extensible-instances.git
  commit: 8dabe7a3dd9cf162e2d81e4ca16dbe73b98a3809