{-# OPTIONS -Wall #-}
{-# OPTIONS -Wno-compat #-}
{-# OPTIONS -Wincomplete-record-updates #-}
{-# OPTIONS -Wincomplete-uni-patterns #-}
{-# OPTIONS -Wredundant-constraints #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE NoOverloadedLists #-}
{-# LANGUAGE NoStarIsType #-}
module Predicate.Data.IO (
ReadFile
, FileExists
, ReadDir
, DirExists
, ReadEnv
, ReadEnvAll
, TimeUtc
, TimeZt
, AppendFile
, WriteFile
, WriteFile'
, Stdout
, Stderr
, Stdin
, ReadIO
, ReadIO'
) where
import Predicate.Core
import Predicate.Util
import Predicate.Data.Maybe (IsJust)
import Predicate.Data.Monoid (type (<>))
import Predicate.Data.ReadShow (ReadP)
import GHC.TypeLits (Symbol,KnownSymbol)
import Data.Proxy
import qualified Control.Exception as E
import Data.Kind (Type)
import Control.Arrow
import Data.Time
import System.Directory
import System.IO
import System.Environment
data ReadFile p
data FileExists p
type FileExistsT p = IsJust (ReadFile p)
instance P (FileExistsT p) x => P (FileExists p) x where
type PP (FileExists p) x = PP (FileExistsT p) x
eval _ = evalBool (Proxy @(FileExistsT p))
instance ( PP p x ~ String
, P p x
) => P (ReadFile p) x where
type PP (ReadFile p) x = Maybe String
eval _ opts x = do
let msg0 = "ReadFile"
pp <- eval (Proxy @p) opts x
case getValueLR opts msg0 pp [] of
Left e -> pure e
Right p -> do
let msg1 = msg0 <> "[" <> p <> "]"
mb <- runIO $ do
b <- doesFileExist p
if b then Just <$> readFile p
else pure Nothing
pure $ case mb of
Nothing -> mkNode opts (FailT msg1) "" [hh pp]
Just Nothing -> mkNode opts (PresentT Nothing) (msg1 <> " does not exist") [hh pp]
Just (Just b) -> mkNode opts (PresentT (Just b)) (msg1 <> " len=" <> show (length b) <> " Just " <> litL opts b) [hh pp]
data DirExists p
type DirExistsT p = IsJust (ReadDir p)
instance P (DirExistsT p) x => P (DirExists p) x where
type PP (DirExists p) x = PP (DirExistsT p) x
eval _ = evalBool (Proxy @(DirExistsT p))
data ReadDir p
instance ( PP p x ~ String
, P p x
) => P (ReadDir p) x where
type PP (ReadDir p) x = Maybe [FilePath]
eval _ opts x = do
let msg0 = "ReadDir"
pp <- eval (Proxy @p) opts x
case getValueLR opts msg0 pp [] of
Left e -> pure e
Right p -> do
let msg1 = msg0 <> "[" <> p <> "]"
mb <- runIO $ do
b <- doesDirectoryExist p
if b then Just <$> listDirectory p
else pure Nothing
pure $ case mb of
Nothing -> mkNode opts (FailT msg1) "" [hh pp]
Just Nothing -> mkNode opts (PresentT Nothing) (msg1 <> " does not exist") [hh pp]
Just (Just b) -> mkNode opts (PresentT (Just b)) (msg1 <> " len=" <> show (length b) <> " Just " <> showL opts b) [hh pp]
data ReadEnv p
instance ( PP p x ~ String
, P p x
) => P (ReadEnv p) x where
type PP (ReadEnv p) x = Maybe String
eval _ opts x = do
let msg0 = "ReadEnv"
pp <- eval (Proxy @p) opts x
case getValueLR opts msg0 pp [] of
Left e -> pure e
Right p -> do
let msg1 = msg0 <> "[" <> p <> "]"
mb <- runIO $ lookupEnv p
pure $ case mb of
Nothing -> mkNode opts (FailT msg1) "" [hh pp]
Just Nothing -> mkNode opts (PresentT Nothing) (msg1 <> " does not exist") [hh pp]
Just (Just v) -> mkNode opts (PresentT (Just v)) (msg1 <> " " <> litL opts v) [hh pp]
data ReadEnvAll
instance P ReadEnvAll a where
type PP ReadEnvAll a = [(String,String)]
eval _ opts _ = do
let msg0 = "ReadEnvAll"
mb <- runIO getEnvironment
pure $ case mb of
Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) "" []
Just v -> mkNode opts (PresentT v) (msg0 <> " count=" <> show (length v)) []
data TimeUtc
instance P TimeUtc a where
type PP TimeUtc a = UTCTime
eval _ opts _a = do
let msg0 = "TimeUtc"
mb <- runIO getCurrentTime
pure $ case mb of
Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) "" []
Just v -> mkNode opts (PresentT v) (msg0 <> " " <> showL opts v) []
data TimeZt
instance P TimeZt a where
type PP TimeZt a = ZonedTime
eval _ opts _a = do
let msg0 = "TimeZt"
mb <- runIO getZonedTime
pure $ case mb of
Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) "" []
Just v -> mkNode opts (PresentT v) (msg0 <> " " <> showL opts v) []
data FHandle s = FStdout | FStderr | FOther !s !WFMode deriving Show
class GetFHandle (x :: FHandle Symbol) where getFHandle :: FHandle String
instance GetFHandle 'FStdout where getFHandle = FStdout
instance GetFHandle 'FStderr where getFHandle = FStderr
instance (GetMode w, KnownSymbol s) => GetFHandle ('FOther s w) where getFHandle = FOther (symb @s) (getMode @w)
data WFMode = WFAppend | WFWrite | WFWriteForce deriving (Show,Eq)
class GetMode (x :: WFMode) where getMode :: WFMode
instance GetMode 'WFAppend where getMode = WFAppend
instance GetMode 'WFWriteForce where getMode = WFWriteForce
instance GetMode 'WFWrite where getMode = WFWrite
data WriteFileImpl (hh :: FHandle Symbol) p
data AppendFile (s :: Symbol) p
type AppendFileT (s :: Symbol) p = WriteFileImpl ('FOther s 'WFAppend) p
instance P (AppendFileT s p) x => P (AppendFile s p) x where
type PP (AppendFile s p) x = PP (AppendFileT s p) x
eval _ = eval (Proxy @(AppendFileT s p))
data WriteFile' (s :: Symbol) p
type WriteFileT' (s :: Symbol) p = WriteFileImpl ('FOther s 'WFWriteForce) p
instance P (WriteFileT' s p) x => P (WriteFile' s p) x where
type PP (WriteFile' s p) x = PP (WriteFileT' s p) x
eval _ = eval (Proxy @(WriteFileT' s p))
data WriteFile (s :: Symbol) p
type WriteFileT (s :: Symbol) p = WriteFileImpl ('FOther s 'WFWrite) p
instance P (WriteFileT s p) x => P (WriteFile s p) x where
type PP (WriteFile s p) x = PP (WriteFileT s p) x
eval _ = eval (Proxy @(WriteFileT s p))
data Stdout p
type StdoutT p = WriteFileImpl 'FStdout p
instance P (StdoutT p) x => P (Stdout p) x where
type PP (Stdout p) x = PP (StdoutT p) x
eval _ = eval (Proxy @(StdoutT p))
data Stderr p
type StderrT p = WriteFileImpl 'FStderr p
instance P (StderrT p) x => P (Stderr p) x where
type PP (Stderr p) x = PP (StderrT p) x
eval _ = eval (Proxy @(StderrT p))
instance (GetFHandle fh
, P p a
, PP p a ~ String
) => P (WriteFileImpl fh p) a where
type PP (WriteFileImpl fh p) a = ()
eval _ opts a = do
let fh = getFHandle @fh
msg0 = case fh of
FStdout -> "Stdout"
FStderr -> "Stderr"
FOther s w -> (<>("[" <> s <> "]")) $ case w of
WFAppend -> "AppendFile"
WFWrite -> "WriteFile"
WFWriteForce -> "WriteFile'"
pp <- eval (Proxy @p) opts a
case getValueLR opts msg0 pp [] of
Left e -> pure e
Right ss -> do
mb <- runIO $ case fh of
FStdout -> fmap (left show) $ E.try @E.SomeException $ putStr ss
FStderr -> fmap (left show) $ E.try @E.SomeException $ putStr ss
FOther s w -> do
b <- doesFileExist s
if b && w == WFWrite then pure $ Left $ "file [" <> s <> "] already exists"
else do
let md = case w of
WFAppend -> AppendMode
_ -> WriteMode
fmap (left show) $ E.try @E.SomeException $ withFile s md (`hPutStr` ss)
pure $ case mb of
Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) "" [hh pp]
Just (Left e) -> mkNode opts (FailT e) (msg0 <> " " <> e) [hh pp]
Just (Right ()) -> mkNode opts (PresentT ()) msg0 [hh pp]
type ReadIO (t :: Type) = ReadIO' t "Enter value"
type ReadIO' (t :: Type) s = Stdout (s <> ":") >> Stdin >> ReadP t Id
data Stdin
instance P Stdin x where
type PP Stdin x = String
eval _ opts _x = do
let msg0 = "Stdin"
mb <- runIO $ do
lr <- E.try getLine
pure $ case lr of
Left (e :: E.SomeException) -> Left $ show e
Right ss -> Right ss
pure $ case mb of
Nothing -> mkNode opts (FailT (msg0 <> " must run in IO")) "" []
Just (Left e) -> mkNode opts (FailT e) (msg0 <> " " <> e) []
Just (Right ss) -> mkNode opts (PresentT ss) (msg0 <> "[" <> litVerbose opts "" ss <> "]") []