diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2009 Sean Leather +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of Universiteit Utrecht nor the names of its contributors + may be used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,55 @@ +#! /usr/bin/env runhaskell + +\begin{code} +{-# OPTIONS -Wall #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Setup +-- Copyright : (c) 2009 Sean Leather +-- License : BSD3 +-- +-- Maintainer : leather@cs.uu.nl +----------------------------------------------------------------------------- + +module Main (main) where + +import System.Cmd + ( system + ) + +import System.FilePath + ( () + ) + +import Distribution.Simple + ( defaultMainWithHooks + , simpleUserHooks + , UserHooks(runTests) + , Args + ) + +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo + ) + +import Distribution.PackageDescription + ( PackageDescription + ) + +main :: IO () +main = defaultMainWithHooks hooks + where + hooks = simpleUserHooks + { runTests = runTests' + } + +-- Run a 'test' binary that gets built when configured with '-ftest'. +runTests' :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO () +runTests' _ _ _ _ = system cmd >> return () + where testdir = "dist" "build" "test" + testcmd = "." "test" + cmd = "cd " ++ testdir ++ " && " ++ testcmd + +\end{code} + diff --git a/src/Text/XFormat/Read.hs b/src/Text/XFormat/Read.hs new file mode 100644 --- /dev/null +++ b/src/Text/XFormat/Read.hs @@ -0,0 +1,571 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Text.XFormat.Read +-- Copyright : (c) 2009 Sean Leather +-- License : BSD3 +-- +-- Maintainer : leather@cs.uu.nl +-- Stability : experimental +-- Portability : non-portable +-- +-- This module defines an extensible, type-indexed function for reading +-- well-typed values from a string with a format descriptor. This may be +-- considered a Haskell variant of the C @scanf@ function. +-- +-- If you are primarily interested in using this library, you will want to see +-- 'readsf' and 'readf', the more user-friendly functions. +-- +-- If you are also interested in extending this library with your own format +-- descriptors, you should read about the 'Format' class. +-------------------------------------------------------------------------------- + +module Text.XFormat.Read ( + + -- * The Class + + Format(..), + + -- * The Functions + + readsf, + readf, + + -- * Format Descriptors + + -- | These are used to indicate which values and types to read. + + -- ** Basic Format Descriptors + + CharF(..), + IntF(..), + IntegerF(..), + FloatF(..), + DoubleF(..), + StringF(..), + + -- ** Class-based Format Descriptors + + ReadF(..), + NumF(..), + + -- ** Recursive Format Descriptors + + (:%:)(..), + (%), + + WrapF(..), + MaybeF(..), + ChoiceF(..), + EitherF(..), + EitherLF(..), + + -- ** Other Format Descriptors + + SpaceF(..), + +) where + +-------------------------------------------------------------------------------- + +import Text.ParserCombinators.ReadP +import Data.Char (isSpace) + +-------------------------------------------------------------------------------- + +-- | This class provides the signature for an extensible, type-indexed function +-- that uses a format descriptor to parse a string input and return a well-typed +-- value. The type variable @d@ is the format descriptor, and the variable @a@ +-- is the type of the value to be read from the input. +-- +-- An instance of @Format@ adds a (type) case to the function. Before defining +-- an instance, you must first define a format descriptor for your specific type +-- and expected input. The descriptor is often very simple. See the descriptors +-- in this module for examples. +-- +-- Here is the instance for types that are instances of 'Prelude.Read'. +-- +-- @ +-- data 'ReadF' a = 'Read' -- Format descriptor +-- @ +-- +-- @ +-- instance ('Prelude.Read' a) => Format ('ReadF' a) a where +-- 'readpf' 'Read' = 'readS_to_P' 'reads' +-- @ +-- +-- Note that you will need some of the combinators (such as 'readS_to_P') in +-- "Text.ParserCombinators.ReadP". + +class Format d a | d -> a where + + -- | Given a format descriptor @d@, return a 'ReadP' parser for a type @a@. + -- This function may not be very useful outside of defining an instance for + -- 'Format'. Instead, consider using 'readsf' or 'readf'. + + readpf :: d -> ReadP a + +-------------------------------------------------------------------------------- + +-- | Given a format descriptor @d@ and a 'String', return a list of successes +-- for the type @a@, i.e. @[(a, 'String')]@. This function simply transforms the +-- 'ReadP' parser of 'readpf' to a 'ReadS' function. + +readsf :: (Format d a) => d -> ReadS a +readsf fmt = readP_to_S (readpf fmt) + +-- | Given a format descriptor @d@ and a 'String', return an optional result of +-- the type @a@. This function simply returns the head of the list from 'readsf' +-- if it was successful. + +readf :: (Format d a) => d -> String -> Maybe a +readf fmt s = headfirst (readsf fmt s) + where + headfirst [] = Nothing + headfirst ((a,_):_) = Just a + +-------------------------------------------------------------------------------- + +-- +-- Format constants +-- +-- These are not descriptors in the traditional sense. These are constants that +-- are compared with parsed input. +-- + +-- | Parse a 'String' and return it if it is equal to the enclosed value. + +instance Format String String where + readpf = string + +-- | Parse a 'Char' and return it if it is equal to the enclosed value. + +instance Format Char Char where + readpf = char + +-------------------------------------------------------------------------------- + +-- +-- Basic format descriptors +-- + +-- | Parse a character. + +data CharF = Char + +instance Format CharF Char where + readpf Char = get + +-- | Parse a string. Reads until the end of the input. + +data StringF = String + +instance Format StringF String where + readpf String = munch (const True) + +-- | Parse an 'Int'. + +data IntF = Int + +instance Format IntF Int where + readpf Int = readS_to_P reads + +-- | Parse an 'Integer'. + +data IntegerF = Integer + +instance Format IntegerF Integer where + readpf Integer = readS_to_P reads + +-- | Parse a 'Float'. + +data FloatF = Float + +instance Format FloatF Float where + readpf Float = readS_to_P reads + +-- | Parse a 'Double'. + +data DoubleF = Double + +instance Format DoubleF Double where + readpf Double = readS_to_P reads + +-------------------------------------------------------------------------------- + +-- +-- Class format descriptors +-- + +-- | Parse a value whose type is an instance of the class 'Prelude.Read'. + +data ReadF a = Read + +instance (Read a) => Format (ReadF a) a where + readpf Read = readS_to_P reads + +-- | Parse a value whose type is an instance of the class 'Prelude.Num'. + +data NumF a = Num + +instance (Read a, Num a) => Format (NumF a) a where + readpf Num = readS_to_P reads + +-------------------------------------------------------------------------------- + +-- +-- Other format descriptors +-- + +-- | Parse a @'ReadP' a@ value. + +instance Format (ReadP a) a where + readpf = id + +-- | Parse zero or more whitespace characters. Stop when a non-whitespace +-- character is reached. + +data SpaceF = Space + +instance Format SpaceF String where + readpf Space = munch isSpace + +-------------------------------------------------------------------------------- + +-- +-- Recursive format descriptors +-- + +-- | Right-associative pair. First parse a @a@-type format and then a @b@-type +-- format. + +data a :%: b = a :%: b + deriving (Eq, Show) + +infixr 8 :%: + +-- | Right-associative pair. This is a shorter, functional equivalent to the +-- type @(:%:)@. + +(%) :: a -> b -> a :%: b +(%) = (:%:) + +infixr 8 % + +instance (Format d1 a1, Format d2 a2) => Format (d1 :%: d2) (a1 :%: a2) where + readpf (d1 :%: d2) = do + a1 <- readpf d1 + a2 <- readpf d2 + return (a1 :%: a2) + +-- | Parse a format of one type wrapped by two other formats of a different +-- type. + +data WrapF inner outer = Wrap outer inner outer + +instance (Format din ain, Format dout aout) + => Format (WrapF din dout) (aout :%: ain :%: aout) where + readpf (Wrap doutl din doutr) = do + aoutl <- readpf doutl + ain <- readpf din + aoutr <- readpf doutr + return (aoutl :%: ain :%: aoutr) + +-- | Parse an optional value. + +data MaybeF a = Maybe a + +instance (Format d a) => Format (MaybeF d) (Maybe a) where + readpf (Maybe d) = (readpf d >>= return . Just) <++ return Nothing + +-- | Parse one of the optional formats in a list. + +data ChoiceF a = Choice [a] + +instance (Format d a) => Format (ChoiceF d) a where + readpf (Choice ds) = choice (fmap readpf ds) + +-- | Parse one of two formats in a fully symmetric choice. + +data EitherF a b = Either a b + +instance (Format d1 a1, Format d2 a2) => Format (EitherF d1 d2) (Either a1 a2) where + readpf (Either d1 d2) = + (readpf d1 >>= return . Left) +++ (readpf d2 >>= return . Right) + +-- | Parse one of two formats, trying the left one first. + +data EitherLF a b = EitherL a b + +instance (Format d1 a1, Format d2 a2) => Format (EitherLF d1 d2) (Either a1 a2) where + readpf (EitherL d1 d2) = + (readpf d1 >>= return . Left) <++ (readpf d2 >>= return . Right) + +-------------------------------------------------------------------------------- + +-- +-- Tuple format descriptors: These all follow the same pattern. +-- + +instance (Format d1 a1, Format d2 a2) => Format (d1, d2) (a1, a2) where + readpf (d1, d2) = do + a1 <- readpf d1 + a2 <- readpf d2 + return (a1, a2) + +instance + (Format d1 a1, Format d2 a2, Format d3 a3) + => Format + (d1, d2, d3) + (a1, a2, a3) + where + readpf (d1, d2, d3) = do + a1 <- readpf d1 + a2 <- readpf d2 + a3 <- readpf d3 + return (a1, a2, a3) + +instance + (Format d1 a1, Format d2 a2, Format d3 a3, Format d4 a4) + => Format + (d1, d2, d3, d4) + (a1, a2, a3, a4) + where + readpf (d1, d2, d3, d4) = do + a1 <- readpf d1 + a2 <- readpf d2 + a3 <- readpf d3 + a4 <- readpf d4 + return (a1, a2, a3, a4) + +instance + (Format d1 a1, Format d2 a2, Format d3 a3, Format d4 a4, Format d5 a5) + => Format + (d1, d2, d3, d4, d5) + (a1, a2, a3, a4, a5) + where + readpf (d1, d2, d3, d4, d5) = do + a1 <- readpf d1 + a2 <- readpf d2 + a3 <- readpf d3 + a4 <- readpf d4 + a5 <- readpf d5 + return (a1, a2, a3, a4, a5) + +instance + (Format d1 a1, Format d2 a2, Format d3 a3, Format d4 a4, Format d5 a5, + Format d6 a6) + => Format + (d1, d2, d3, d4, d5, d6) + (a1, a2, a3, a4, a5, a6) + where + readpf (d1, d2, d3, d4, d5, d6) = do + a1 <- readpf d1 + a2 <- readpf d2 + a3 <- readpf d3 + a4 <- readpf d4 + a5 <- readpf d5 + a6 <- readpf d6 + return (a1, a2, a3, a4, a5, a6) + +instance + (Format d1 a1, Format d2 a2, Format d3 a3, Format d4 a4, Format d5 a5, + Format d6 a6, Format d7 a7) + => Format + (d1, d2, d3, d4, d5, d6, d7) + (a1, a2, a3, a4, a5, a6, a7) + where + readpf (d1, d2, d3, d4, d5, d6, d7) = do + a1 <- readpf d1 + a2 <- readpf d2 + a3 <- readpf d3 + a4 <- readpf d4 + a5 <- readpf d5 + a6 <- readpf d6 + a7 <- readpf d7 + return (a1, a2, a3, a4, a5, a6, a7) + +instance + (Format d1 a1, Format d2 a2, Format d3 a3, Format d4 a4, Format d5 a5, + Format d6 a6, Format d7 a7, Format d8 a8) + => Format + (d1, d2, d3, d4, d5, d6, d7, d8) + (a1, a2, a3, a4, a5, a6, a7, a8) + where + readpf (d1, d2, d3, d4, d5, d6, d7, d8) = do + a1 <- readpf d1 + a2 <- readpf d2 + a3 <- readpf d3 + a4 <- readpf d4 + a5 <- readpf d5 + a6 <- readpf d6 + a7 <- readpf d7 + a8 <- readpf d8 + return (a1, a2, a3, a4, a5, a6, a7, a8) + +instance + (Format d1 a1, Format d2 a2, Format d3 a3, Format d4 a4, Format d5 a5, + Format d6 a6, Format d7 a7, Format d8 a8, Format d9 a9) + => Format + (d1, d2, d3, d4, d5, d6, d7, d8, d9) + (a1, a2, a3, a4, a5, a6, a7, a8, a9) + where + readpf (d1, d2, d3, d4, d5, d6, d7, d8, d9) = do + a1 <- readpf d1 + a2 <- readpf d2 + a3 <- readpf d3 + a4 <- readpf d4 + a5 <- readpf d5 + a6 <- readpf d6 + a7 <- readpf d7 + a8 <- readpf d8 + a9 <- readpf d9 + return (a1, a2, a3, a4, a5, a6, a7, a8, a9) + +instance + (Format d1 a1, Format d2 a2, Format d3 a3, Format d4 a4, Format d5 a5, + Format d6 a6, Format d7 a7, Format d8 a8, Format d9 a9, Format d10 a10) + => Format + (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10) + (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) + where + readpf (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10) = do + a1 <- readpf d1 + a2 <- readpf d2 + a3 <- readpf d3 + a4 <- readpf d4 + a5 <- readpf d5 + a6 <- readpf d6 + a7 <- readpf d7 + a8 <- readpf d8 + a9 <- readpf d9 + a10 <- readpf d10 + return (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) + +instance + (Format d1 a1, Format d2 a2, Format d3 a3, Format d4 a4, Format d5 a5, + Format d6 a6, Format d7 a7, Format d8 a8, Format d9 a9, Format d10 a10, + Format d11 a11) + => Format + (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11) + (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) + where + readpf (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11) = do + a1 <- readpf d1 + a2 <- readpf d2 + a3 <- readpf d3 + a4 <- readpf d4 + a5 <- readpf d5 + a6 <- readpf d6 + a7 <- readpf d7 + a8 <- readpf d8 + a9 <- readpf d9 + a10 <- readpf d10 + a11 <- readpf d11 + return (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) + +instance + (Format d1 a1, Format d2 a2, Format d3 a3, Format d4 a4, Format d5 a5, + Format d6 a6, Format d7 a7, Format d8 a8, Format d9 a9, Format d10 a10, + Format d11 a11, Format d12 a12) + => Format + (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12) + (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) + where + readpf (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12) = do + a1 <- readpf d1 + a2 <- readpf d2 + a3 <- readpf d3 + a4 <- readpf d4 + a5 <- readpf d5 + a6 <- readpf d6 + a7 <- readpf d7 + a8 <- readpf d8 + a9 <- readpf d9 + a10 <- readpf d10 + a11 <- readpf d11 + a12 <- readpf d12 + return (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) + +instance + (Format d1 a1, Format d2 a2, Format d3 a3, Format d4 a4, Format d5 a5, + Format d6 a6, Format d7 a7, Format d8 a8, Format d9 a9, Format d10 a10, + Format d11 a11, Format d12 a12, Format d13 a13) + => Format + (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13) + (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) + where + readpf (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13) = do + a1 <- readpf d1 + a2 <- readpf d2 + a3 <- readpf d3 + a4 <- readpf d4 + a5 <- readpf d5 + a6 <- readpf d6 + a7 <- readpf d7 + a8 <- readpf d8 + a9 <- readpf d9 + a10 <- readpf d10 + a11 <- readpf d11 + a12 <- readpf d12 + a13 <- readpf d13 + return (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13) + +instance + (Format d1 a1, Format d2 a2, Format d3 a3, Format d4 a4, Format d5 a5, + Format d6 a6, Format d7 a7, Format d8 a8, Format d9 a9, Format d10 a10, + Format d11 a11, Format d12 a12, Format d13 a13, Format d14 a14) + => Format + (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13, d14) + (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) + where + readpf (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13, d14) = do + a1 <- readpf d1 + a2 <- readpf d2 + a3 <- readpf d3 + a4 <- readpf d4 + a5 <- readpf d5 + a6 <- readpf d6 + a7 <- readpf d7 + a8 <- readpf d8 + a9 <- readpf d9 + a10 <- readpf d10 + a11 <- readpf d11 + a12 <- readpf d12 + a13 <- readpf d13 + a14 <- readpf d14 + return (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14) + +instance + (Format d1 a1, Format d2 a2, Format d3 a3, Format d4 a4, Format d5 a5, + Format d6 a6, Format d7 a7, Format d8 a8, Format d9 a9, Format d10 a10, + Format d11 a11, Format d12 a12, Format d13 a13, Format d14 a14, + Format d15 a15) + => Format + (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13, d14, d15) + (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) + where + readpf (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13, d14, d15) = do + a1 <- readpf d1 + a2 <- readpf d2 + a3 <- readpf d3 + a4 <- readpf d4 + a5 <- readpf d5 + a6 <- readpf d6 + a7 <- readpf d7 + a8 <- readpf d8 + a9 <- readpf d9 + a10 <- readpf d10 + a11 <- readpf d11 + a12 <- readpf d12 + a13 <- readpf d13 + a14 <- readpf d14 + a15 <- readpf d15 + return (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15) + diff --git a/src/Text/XFormat/Show.hs b/src/Text/XFormat/Show.hs new file mode 100644 --- /dev/null +++ b/src/Text/XFormat/Show.hs @@ -0,0 +1,512 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Text.XFormat.Show +-- Copyright : (c) 2009 Sean Leather +-- License : BSD3 +-- +-- Maintainer : leather@cs.uu.nl +-- Stability : experimental +-- Portability : non-portable +-- +-- This module defines an extensible, type-indexed function for showing +-- well-typed values with a format descriptor. This may be considered a Haskell +-- variant of the C @printf@ function. +-- +-- If you are primarily interested in using this library, you will want to see +-- 'showsf' and 'showf', the more user-friendly functions. +-- +-- If you are also interested in extending this library with your own format +-- descriptors, you should read about the 'Format' class. +-------------------------------------------------------------------------------- + +module Text.XFormat.Show ( + + -- * The Classes + + Format(..), + Apply(..), + + -- * The Functions + + showsf, + showf, + + -- * Format Descriptors + + -- | These are used to indicate which values and types to show. + + -- ** Basic Format Descriptors + + CharF(..), + IntF(..), + IntegerF(..), + FloatF(..), + DoubleF(..), + StringF(..), + + -- ** Class-based Format Descriptors + + ShowF(..), + NumF(..), + + -- ** Recursive Format Descriptors + + (:%:)(..), + (%), + + WrapF(..), + AlignF(..), + Dir(..), + + -- ** Other Format Descriptors + + SpacesF(..), + + -- * Utilities for Defining Instances + + Id(..), + Arr(..), + (:.:)(..), + (<>), + +) where + +-------------------------------------------------------------------------------- + + +-- | This class provides the signature for an extensible, type-indexed function +-- that uses a format descriptor to print a variable number of well-typed +-- arguments to a string. The type variable @d@ is the format descriptor, and +-- the 'Functor' variable @f@ determines the type of the value to be shown. +-- +-- An instance of @Format@ adds a (type) case to the function. Before defining +-- an instance, you must first define a format descriptor for your specific type +-- and expected input. The descriptor is often very simple. See the descriptors +-- in this module for examples. +-- +-- Here is the instance for types that are instances of 'Prelude.Show'. +-- +-- @ +-- data 'ShowF' a = 'Show' -- Format descriptor +-- @ +-- +-- @ +-- instance ('Prelude.Show' a) => Format ('ShowF' a) ('Arr' a) where +-- 'showsf'' 'Show' = 'Arr' 'shows' +-- @ +-- +-- The 'Arr' type is one of several 'Functor' wrappers necessary for defining +-- these instances. + +class (Functor f) => Format d f | d -> f where + + -- | Given a format descriptor @d@, return a 'Functor' wrapping a @'String' -> + -- 'String'@ type. This function may not be very useful outside of defining an + -- instance for 'Format'. Instead, consider using 'showsf' or 'showf'. + + showsf' :: d -> f ShowS + +-------------------------------------------------------------------------------- + +-- | Given a format descriptor @d@, a variable number of arguments represented +-- by @a@ (and determined by @d@), and a 'String', return a 'String' result. +-- This function removes the 'Functor' wrappers from the output of 'showsf'' to +-- get the variable number of arguments. + +showsf :: (Format d f, Apply f ShowS a) => d -> a +showsf d = apply (showsf' d) + +-- | Given a format descriptor @d@ and a variable number of arguments +-- represented by @a@ (and determined by @d@), return a 'String' result. This +-- function is the same as 'showsf' but has already been applied to a 'String' +-- input. + +showf :: (Format d f, Apply f String a) => d -> a +showf d = apply (fmap (\f -> f "") (showsf' d)) + +-------------------------------------------------------------------------------- + +-- +-- Functor wrappers +-- + +-- | Wrapper for a format constant that does not take any arguments. Used in +-- @instance 'Format' 'String' Id@ for example. + +newtype Id a = Id a + +instance Functor Id where + fmap f (Id x) = Id (f x) + +-- | Wrapper for a format descriptor that takes an argument. Used in @instance +-- ('Prelude.Show' a) => 'Format' ('ShowF' a) (Arr a)@ for example. + +newtype Arr a b = Arr (a -> b) + +instance Functor (Arr a) where + fmap f (Arr g) = Arr (f . g) + +-- | Wrapper for a format descriptor that composes two descriptors. Used in +-- @instance ('Format' d1 f1, 'Format' d2 f2) => 'Format' (d1 :%: d2) (f1 :.: +-- f2)@ for example. + +newtype (:.:) f g a = Comp (f (g a)) + +infixr 8 :.: + +instance (Functor f, Functor g) => Functor (f :.: g) where + fmap f (Comp fga) = Comp (fmap (fmap f) fga) + +-- | Helpful function for defining instances of composed format descriptors. + +(<>) :: (Functor f, Functor g) => f (b -> c) -> g (a -> b) -> (:.:) f g (a -> c) +f <> g = Comp (fmap (\s -> fmap (\t -> s . t) g) f) +infixr 8 <> + +-------------------------------------------------------------------------------- + +-- +-- Functor wrapper removal +-- + +class (Functor f) => Apply f a b | f a -> b where + apply :: f a -> b + +instance Apply Id a a where + apply (Id a) = a + +instance Apply (Arr a) b (a -> b) where + apply (Arr f) = f + +instance (Apply f b c, Apply g a b) => Apply (f :.: g) a c where + apply (Comp fga) = apply (fmap apply fga) + +-------------------------------------------------------------------------------- + +-- +-- Format constants +-- +-- These are not descriptors in the traditional sense. These are constants that +-- are shown directly without taking arguments. +-- + +-- | Print the enclosed 'String'. + +instance Format String Id where + showsf' s = Id (showString s) + +-- | Print the enclosed 'Char'. + +instance Format Char Id where + showsf' c = Id (showChar c) + +-------------------------------------------------------------------------------- + +-- +-- Basic format descriptors +-- + +-- | Print a character argument. + +data CharF = Char + +instance Format CharF (Arr Char) where + showsf' Char = Arr showChar + +-- | Print a string argument. + +data StringF = String + +instance Format StringF (Arr String) where + showsf' String = Arr showString + +-- | Print an 'Int' argument. + +data IntF = Int + +instance Format IntF (Arr Int) where + showsf' Int = Arr shows + +-- | Print an 'Integer' argument. + +data IntegerF = Integer + +instance Format IntegerF (Arr Integer) where + showsf' Integer = Arr shows + +-- | Print a 'Float' argument. + +data FloatF = Float + +instance Format FloatF (Arr Float) where + showsf' Float = Arr shows + +-- | Print a 'Double' argument. + +data DoubleF = Double + +instance Format DoubleF (Arr Double) where + showsf' Double = Arr shows + +-------------------------------------------------------------------------------- + +-- +-- Class format descriptors +-- + +-- | Print an argument whose type is an instance of the class 'Prelude.Show'. + +data ShowF a = Show + +instance (Show a) => Format (ShowF a) (Arr a) where + showsf' Show = Arr shows + +-- | Print an argument whose type is an instance of the class 'Prelude.Num'. + +data NumF a = Num + +instance (Num a) => Format (NumF a) (Arr a) where + showsf' Num = Arr shows + +-------------------------------------------------------------------------------- + +-- +-- Other format descriptors +-- + +-- | Print a specified number of spaces. + +data SpacesF = Spaces Int + +instance Format SpacesF Id where + showsf' (Spaces n) = Id (showString (replicate n ' ')) + +-------------------------------------------------------------------------------- + +-- +-- Recursive format descriptors +-- + +-- | Right-associative pair. First print a @a@-type format and then a @b@-type +-- format. + +data a :%: b = a :%: b + deriving (Eq, Show) + +infixr 8 :%: + +-- | Right-associative pair. This is a shorter, functional equivalent to the +-- type @(:%:)@. + +(%) :: a -> b -> a :%: b +(%) = (:%:) + +infixr 8 % + +instance (Format d1 f1, Format d2 f2) => Format (d1 :%: d2) (f1 :.: f2) where + showsf' (d1 :%: d2) = showsf' d1 <> showsf' d2 + +-- | Print a format of one type wrapped by two other formats of a different +-- type. + +data WrapF inner outer = Wrap outer inner outer + +instance (Format din fin, Format dout fout) + => Format (WrapF din dout) (fout :.: fin :.: fout) where + showsf' (Wrap doutl din doutr) = showsf' doutl <> showsf' din <> showsf' doutr + +-- | Print a format aligned left or right within a column of the given width. + +data AlignF a = Align Dir Int a + +-- | Direction (left or right) used for 'AlignF'. + +data Dir = L | R + +align :: Dir -> Int -> ShowS -> ShowS +align dir wid f = + case dir of + L -> f . g + R -> g . f + where + len = length (f "") + g = if len < wid then showString (replicate (wid - len) ' ') else id + +instance (Format d f) => Format (AlignF d) f where + showsf' (Align dir wid d) = fmap (align dir wid) (showsf' d) + +-------------------------------------------------------------------------------- + +-- +-- Tuple format descriptors: These all follow the same pattern. +-- + +instance + (Format d1 f1, Format d2 f2) + => Format + (d1, d2) + (f1 :.: f2) + where + showsf' (d1, d2) = + showsf' d1 <> showsf' d2 + +instance + (Format d1 f1, Format d2 f2, Format d3 f3) + => Format + (d1, d2, d3) + (f1 :.: f2 :.: f3) + where + showsf' (d1, d2, d3) = + showsf' d1 <> showsf' d2 <> showsf' d3 + +instance + (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4) + => Format + (d1, d2, d3, d4) + (f1 :.: f2 :.: f3 :.: f4) + where + showsf' (d1, d2, d3, d4) = + showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 + +instance + (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5) + => Format + (d1, d2, d3, d4, d5) + (f1 :.: f2 :.: f3 :.: f4 :.: f5) + where + showsf' (d1, d2, d3, d4, d5) = + showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5 + +instance + (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5, + Format d6 f6) + => Format + (d1, d2, d3, d4, d5, d6) + (f1 :.: f2 :.: f3 :.: f4 :.: f5 :.: f6) + where + showsf' (d1, d2, d3, d4, d5, d6) = + showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5 <> + showsf' d6 + +instance + (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5, + Format d6 f6, Format d7 f7) + => Format + (d1, d2, d3, d4, d5, d6, d7) + (f1 :.: f2 :.: f3 :.: f4 :.: f5 :.: f6 :.: f7) + where + showsf' (d1, d2, d3, d4, d5, d6, d7) = + showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5 <> + showsf' d6 <> showsf' d7 + +instance + (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5, + Format d6 f6, Format d7 f7, Format d8 f8) + => Format + (d1, d2, d3, d4, d5, d6, d7, d8) + (f1 :.: f2 :.: f3 :.: f4 :.: f5 :.: f6 :.: f7 :.: f8) + where + showsf' (d1, d2, d3, d4, d5, d6, d7, d8) = + showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5 <> + showsf' d6 <> showsf' d7 <> showsf' d8 + +instance + (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5, + Format d6 f6, Format d7 f7, Format d8 f8, Format d9 f9) + => Format + (d1, d2, d3, d4, d5, d6, d7, d8, d9) + (f1 :.: f2 :.: f3 :.: f4 :.: f5 :.: f6 :.: f7 :.: f8 :.: f9) + where + showsf' (d1, d2, d3, d4, d5, d6, d7, d8, d9) = + showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5 <> + showsf' d6 <> showsf' d7 <> showsf' d8 <> showsf' d9 + +instance + (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5, + Format d6 f6, Format d7 f7, Format d8 f8, Format d9 f9, Format d10 f10) + => Format + (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10) + (f1 :.: f2 :.: f3 :.: f4 :.: f5 :.: f6 :.: f7 :.: f8 :.: f9 :.: f10) + where + showsf' (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10) = + showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5 <> + showsf' d6 <> showsf' d7 <> showsf' d8 <> showsf' d9 <> showsf' d10 + +instance + (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5, + Format d6 f6, Format d7 f7, Format d8 f8, Format d9 f9, Format d10 f10, + Format d11 f11) + => Format + (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11) + (f1 :.: f2 :.: f3 :.: f4 :.: f5 :.: f6 :.: f7 :.: f8 :.: f9 :.: f10 :.: f11) + where + showsf' (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11) = + showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5 <> + showsf' d6 <> showsf' d7 <> showsf' d8 <> showsf' d9 <> showsf' d10 <> + showsf' d11 + +instance + (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5, + Format d6 f6, Format d7 f7, Format d8 f8, Format d9 f9, Format d10 f10, + Format d11 f11, Format d12 f12) + => Format + (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12) + (f1 :.: f2 :.: f3 :.: f4 :.: f5 :.: f6 :.: f7 :.: f8 :.: f9 :.: f10 :.: + f11 :.: f12) + where + showsf' (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12) = + showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5 <> + showsf' d6 <> showsf' d7 <> showsf' d8 <> showsf' d9 <> showsf' d10 <> + showsf' d11 <> showsf' d12 + +instance + (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5, + Format d6 f6, Format d7 f7, Format d8 f8, Format d9 f9, Format d10 f10, + Format d11 f11, Format d12 f12, Format d13 f13) + => Format + (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13) + (f1 :.: f2 :.: f3 :.: f4 :.: f5 :.: f6 :.: f7 :.: f8 :.: f9 :.: f10 :.: + f11 :.: f12 :.: f13) + where + showsf' (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13) = + showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5 <> + showsf' d6 <> showsf' d7 <> showsf' d8 <> showsf' d9 <> showsf' d10 <> + showsf' d11 <> showsf' d12 <> showsf' d13 + +instance + (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5, + Format d6 f6, Format d7 f7, Format d8 f8, Format d9 f9, Format d10 f10, + Format d11 f11, Format d12 f12, Format d13 f13, Format d14 f14) + => Format + (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13, d14) + (f1 :.: f2 :.: f3 :.: f4 :.: f5 :.: f6 :.: f7 :.: f8 :.: f9 :.: f10 :.: + f11 :.: f12 :.: f13 :.: f14) + where + showsf' (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13, d14) = + showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5 <> + showsf' d6 <> showsf' d7 <> showsf' d8 <> showsf' d9 <> showsf' d10 <> + showsf' d11 <> showsf' d12 <> showsf' d13 <> showsf' d14 + +instance + (Format d1 f1, Format d2 f2, Format d3 f3, Format d4 f4, Format d5 f5, + Format d6 f6, Format d7 f7, Format d8 f8, Format d9 f9, Format d10 f10, + Format d11 f11, Format d12 f12, Format d13 f13, Format d14 f14, + Format d15 f15) + => Format + (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13, d14, d15) + (f1 :.: f2 :.: f3 :.: f4 :.: f5 :.: f6 :.: f7 :.: f8 :.: f9 :.: f10 :.: + f11 :.: f12 :.: f13 :.: f14 :.: f15) + where + showsf' (d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13, d14, d15) = + showsf' d1 <> showsf' d2 <> showsf' d3 <> showsf' d4 <> showsf' d5 <> + showsf' d6 <> showsf' d7 <> showsf' d8 <> showsf' d9 <> showsf' d10 <> + showsf' d11 <> showsf' d12 <> showsf' d13 <> showsf' d14 <> showsf' d15 + diff --git a/xformat.cabal b/xformat.cabal new file mode 100644 --- /dev/null +++ b/xformat.cabal @@ -0,0 +1,54 @@ +name: xformat +version: 0.1 +synopsis: + + Extensible, type-safe formatting with scanf- and printf-like functions + +homepage: http://github.com/spl/xformat/tree/master +description: + + /Warning:/ This version of the package is very experimental and the interface + may change in later versions. I am seeking comments to improve it. + . + This package is composed of two functions for formatted conversion between + strings and typed values. Each is defined as a type-indexed function using a + type class with multiple parameters and functional dependencies along with + format descriptors. + . + "Text.XFormat.Read" allows one to parse values from a formatted string. Its + functionality is similar to the C @scanf@ function. Unlike @scanf@, however, + the format descriptor is well-typed, ensuring that the output type is + statically known. + . + "Text.XFormat.Show" allows one to print values to a formatted string. Its + functionality is similar to the C @printf@ function. Unlike @printf@, however, + the format descriptor is well-typed, ensuring that the variable number + arguments are statically known. + . + These functions can be easily extended to support new formats and new types. + Extension is simple: define a format descriptor and an instance of the + appropriate class. + +category: Text, Generics +copyright: (c) 2009 Sean Leather +license: BSD3 +license-file: LICENSE +author: Sean Leather, +maintainer: leather@cs.uu.nl +stability: experimental +build-type: Custom +cabal-version: >= 1.2.1 +tested-with: GHC == 6.8.3, GHC == 6.10.1 + +-------------------------------------------------------------------------------- + +Library + hs-source-dirs: src + + exposed-modules: Text.XFormat.Read + Text.XFormat.Show + + build-depends: base >= 3.0 && < 5.0 + + ghc-options: -Wall -O2 +