{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
module Coalpit.Parsing ( Parser
, CLArg(..)
, pS
, readArg
, pTime
) where
import Text.Megaparsec
import Data.Proxy (Proxy(..))
import Data.Time.Format (TimeLocale, ParseTime, readSTime)
import Data.Void (Void)
import qualified Data.List.NonEmpty as NE
import Data.List (foldl')
import Data.Semigroup ((<>))
newtype CLArg = CLArg { unArg :: String }
deriving (Ord, Eq)
advance :: Pos -> SourcePos -> t -> SourcePos
advance _ (SourcePos n l c) _ = SourcePos n l (c <> pos1)
instance Stream [CLArg] where
type Token [CLArg] = CLArg
type Tokens [CLArg] = [CLArg]
tokenToChunk Proxy = pure
tokensToChunk Proxy = id
chunkToTokens Proxy = id
chunkLength Proxy = length
chunkEmpty Proxy = null
advance1 Proxy = advance
advanceN Proxy w = foldl' (advance w)
take1_ [] = Nothing
take1_ (t:ts) = Just (t, ts)
takeN_ n s
| n <= 0 = Just ([], s)
| null s = Nothing
| otherwise = Just (splitAt n s)
takeWhile_ = span
instance ShowToken CLArg where
showTokens xs = concat $ NE.map unArg xs
type Parser = Parsec Void [CLArg]
pS :: Parsec Void String a -> Parsec Void [CLArg] a
pS p = try $ do
x <- token (Right . unArg) Nothing
case parse p "argument" x of
Left e -> fail $ show e
Right x' -> pure x'
readArg :: Read a => Parser a
readArg = do
x <- token (Right . unArg) Nothing
case reads x of
[(n, "")] -> pure n
_ -> fail $ "Failed to read: " ++ x
pTime :: ParseTime a
=> TimeLocale
-> String
-> Parser a
pTime tl tf = try $ do
x <- token (Right . unArg) Nothing
case readSTime False tl tf x of
[(t, "")] -> pure t
_ -> fail "Failed to parse time"