Last active
February 22, 2018 13:27
-
-
Save matsubara0507/be20aa514016c991f19f2e604409cd96 to your computer and use it in GitHub Desktop.
Tangle で Do 記法レスプログラミング
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
-- 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) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
-- 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) | |
[] |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
2018-02-23T03:10:00 | {"code":123,"message":"hello"} |
---|
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
resolver: lts-10.6 | |
name: matsubara0507 | |
packages: | |
- git: https://github.com/matsubara0507/extensible-instances.git | |
commit: 8dabe7a3dd9cf162e2d81e4ca16dbe73b98a3809 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment