wrath/shaniqua-plugins
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

HEADS UP: Move modules under the System.* and Language.* namespace

Browse Source 
* The Plugins.* modules now live under System.Plugins.*
* The Eval.* modules live under System.Eval.*, and they are part of the
  plugins package (no more separate eval package).
* The printf package has been removed
* The Hi.* modules are now available as Language.Hi.Parser
This commit is contained in:
Don Stewart 2005-05-15 04:55:38 +00:00
parent cee65e133a
commit 7b24c7fd3d
43 changed files with 112 additions and 2189 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
configure.ac
View File

@ -4,7 +4,7 @@
#
# sanity test
AC_INIT(src/plugins/Plugins.hs)
AC_INIT(src/plugins/System/Plugins.hs)
# untested on earlier than 2.52, but it won't work anyway
AC_PREREQ(2.53)

16
src/Makefile
View File

@ -2,10 +2,10 @@
# Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons
# GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)
.PHONY: all build altdata hi plugins eval printf
.PHONY: install i_altdata i_hi i_plugins i_eval i_printf
.PHONY: all build altdata hi plugins
.PHONY: install i_altdata i_hi i_plugins
build: altdata hi plugins eval printf
build: altdata hi plugins
altdata:
@cd altdata && $(MAKE)
@ -13,12 +13,8 @@ hi:
@cd hi && $(MAKE)
plugins: altdata hi
@cd plugins && $(MAKE)
eval: plugins
@cd eval && $(MAKE)
printf: plugins
@cd printf && $(MAKE)
install: i_altdata i_hi i_plugins i_eval i_printf
install: i_altdata i_hi i_plugins
@true
i_altdata:
@ -27,10 +23,6 @@ i_hi:
@cd hi && $(MAKE) install
i_plugins:
@cd plugins && $(MAKE) install
i_eval:
@cd eval && $(MAKE) install
i_printf:
@cd printf && $(MAKE) install
all: build

96
src/eval/Eval/Meta.hs
View File

@ -1,96 +0,0 @@
{-# OPTIONS -cpp -fth #-}
--
-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
-- USA
--
--
-- an implementation of the staged compilation primitives from
-- "Dynamic Typing as Staged Type Inference"
-- Shields, Sheard and Jones, 1998
-- http://doi.acm.org/10.1145/268946.268970
--
module Eval.Meta (
run,
defer,
splice,
) where
import Eval.Haskell ( eval )
import AltData.Typeable ( Typeable )
#if __GLASGOW_HASKELL__ > 602
import Language.Haskell.TH ( ExpQ, pprint, runQ )
#else
import Language.Haskell.THSyntax ( ExpQ, pprExp, runQ )
import Text.PrettyPrint ( render )
#endif
import System.IO.Unsafe ( unsafePerformIO )
type ExpR = String -- hack for splicing
--
-- defer the evaluation of an expression by one stage.
-- uses [| |] just for the nice syntax.
--
-- defer [| 1 + 1 |] --> (1 + 1)
--
defer :: ExpQ -> ExpR
#if __GLASGOW_HASKELL__ > 602
defer e = pprint (unsafePerformIO (runQ e))
#else
defer e = render $ pprExp (unsafePerformIO (runQ e))
#endif
--
-- evaluate 'e' to a deferred expression, and evaluate the result.
--
-- run( defer [|1+1|] ) --> 2
--
run :: (Show t, Typeable t) => ExpR -> t
run e = case unsafePerformIO (eval e imports) of
Nothing -> error "source failed to compile"
Just a -> a
--
-- evaluate 'e' to a deferred expression. then splice the result back in
-- to the surrounding deferred expression. splice() is only legal within
-- deferred expressions.
--
-- let code = defer [| 1 + 1 |] in defer [| splice(code) + 2 |]
-- -->
-- defer [| 1 + 1 + 2 |]
--
-- defer( "\x -> " ++ splice (v) )
--
splice :: Show t => t -> ExpR
splice e = show e
--
-- libraries needed
--
imports =
[
"GHC.Base",
"GHC.Num",
"GHC.List"
]

18
src/eval/Makefile
View File

@ -1,18 +0,0 @@
PKG = eval
UPKG = Eval
ALL_SRCS=$(wildcard $(patsubst ./%, %, $(patsubst %, %/*.hs, . $(UPKG))))
STUBOBJS =Eval/Haskell_stub.$(way_)o
TOP=../..
include ../build.mk
HC_OPTS += -package-conf $(TOP)/plugins.conf.inplace
HC_OPTS += -package plugins
GHC6_3_HC_OPTS += -package template-haskell
install: install-me
-include depend

60
src/eval/eval.conf.in.cpp
View File

@ -1,60 +0,0 @@
#if CABAL == 0 && GLASGOW_HASKELL < 604
Package {
name = "eval",
auto = False,
hs_libraries = [ "HSeval" ],
#ifdef INSTALLING
import_dirs = [ "${LIBDIR}/imports" ],
library_dirs = [ "${LIBDIR}/" ],
#else
import_dirs = [ "${TOP}/src/eval" ],
library_dirs = [ "${TOP}/src/eval" ],
#endif
include_dirs = [],
c_includes = [],
source_dirs = [],
extra_libraries = [],
package_deps = [ "plugins"
#if GLASGOW_HASKELL >= 603
, "template-haskell"
#endif
],
extra_ghc_opts = [],
extra_cc_opts = [],
extra_ld_opts = []
}
#else
name: eval
version: 0.9.8
license: LGPL
maintainer: dons@cse.unsw.edu.au
exposed: True
exposed-modules:
Eval.Haskell,
Eval.Meta,
Eval.Utils,
Eval
hidden-modules:
#ifdef INSTALLING
import-dirs: LIBDIR/imports
library-dirs: LIBDIR
#else
import-dirs: TOP/src/eval
library-dirs: TOP/src/eval
#endif
hs-libraries: HSeval
extra-libraries:
include-dirs:
includes:
depends: plugins, template-haskell
hugs-options:
cc-options:
ld-options:
framework-dirs:
frameworks:
haddock-interfaces:
haddock-html:
#endif

25
src/hi/Hi.hs
View File

@ -1,25 +0,0 @@
--
-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
-- USA
--
module Hi (
module Hi.Parser
) where
import Hi.Parser {-all-}

10
src/hi/Hi/Binary.hs → src/hi/Language/Hi/Binary.hs
View File

@ -33,7 +33,7 @@
-- We never have to write stuff, so I've scrubbed all the put* code.
--
module Hi.Binary (
module Language.Hi.Binary (
{-type-} Bin,
{-class-} Binary(..),
{-type-} BinHandle,
@ -69,8 +69,8 @@ module Hi.Binary (
-- import Hi.Utils -- ?
import Hi.FastMutInt
import Hi.FastString
import Language.Hi.FastMutInt
import Language.Hi.FastString
#if __GLASGOW_HASKELL__ < 604
import Data.FiniteMap
@ -465,7 +465,7 @@ binaryInterfaceMagic = 0x1face :: Word32
getBinFileWithDict :: Binary a => FilePath -> IO a
getBinFileWithDict file_path = do
bh <- Hi.Binary.readBinMem file_path
bh <- Language.Hi.Binary.readBinMem file_path
-- Read the magic number to check that this really is a GHC .hi file
-- (This magic number does not change when we change
@ -478,7 +478,7 @@ getBinFileWithDict file_path = do
-- Read the dictionary
-- The next word in the file is a pointer to where the dictionary is
-- (probably at the end of the file)
dict_p <- Hi.Binary.get bh -- Get the dictionary ptr
dict_p <- Language.Hi.Binary.get bh -- Get the dictionary ptr
data_p <- tellBin bh -- Remember where we are now
seekBin bh dict_p
dict <- getDictionary bh

2
src/hi/Hi/FastMutInt.hs → src/hi/Language/Hi/FastMutInt.hs
View File

@ -26,7 +26,7 @@
-- Unboxed mutable Ints
--
module Hi.FastMutInt (
module Language.Hi.FastMutInt (
FastMutInt,
newFastMutInt,
readFastMutInt,

4
src/hi/Hi/FastString.hs → src/hi/Language/Hi/FastString.hs
View File

@ -31,7 +31,7 @@
-- unique identifiers (hash-cons'ish).
--
module Hi.FastString
module Language.Hi.FastString
(
FastString(..), -- not abstract, for now.
@ -65,7 +65,7 @@ module Hi.FastString
mkLitString# -- :: Addr# -> LitString
) where
import Hi.PrimPacked
import Language.Hi.PrimPacked
import IO
import Char ( chr, ord )

10
src/hi/Hi/Parser.hs → src/hi/Language/Hi/Parser.hs
View File

@ -42,15 +42,15 @@
module Hi.Parser ( readIface, module Hi.Syntax ) where
module Language.Hi.Parser ( readIface, module Language.Hi.Syntax ) where
import Hi.Syntax
import Hi.Binary
import Hi.FastString
import Language.Hi.Syntax
import Language.Hi.Binary
import Language.Hi.FastString
import GHC.Word
#include "../../../config.h"
#include "../../../../config.h"
-- ---------------------------------------------------------------------------
-- how to get there from here

2
src/hi/Hi/PrimPacked.hs → src/hi/Language/Hi/PrimPacked.hs
View File

@ -34,7 +34,7 @@
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
module Hi.PrimPacked (
module Language.Hi.PrimPacked (
Ptr(..), nullPtr, plusAddr#,
BA(..),
packString, -- :: String -> (Int, BA)

4
src/hi/Hi/Syntax.hs → src/hi/Language/Hi/Syntax.hs
View File

@ -20,9 +20,9 @@
-- (c) The University of Glasgow 2002
--
module Hi.Syntax where
module Language.Hi.Syntax where
import Hi.FastString
import Language.Hi.FastString
import Data.List ( intersperse )

0
src/hi/Hi/hschooks.c → src/hi/Language/Hi/hschooks.c
View File

0
src/hi/Hi/hschooks.h → src/hi/Language/Hi/hschooks.h
View File

8
src/hi/Makefile
View File

@ -1,15 +1,15 @@
PKG = hi
UPKG = Hi
CSRC = $(UPKG)/hschooks.c
COBJ = $(UPKG)/hschooks.o
CSRC = Language/$(UPKG)/hschooks.c
COBJ = Language/$(UPKG)/hschooks.o
ALL_SRCS=$(wildcard $(patsubst ./%, %, $(patsubst %, %/*.hs, . $(UPKG))))
ALL_SRCS=$(wildcard $(patsubst ./%, %, $(patsubst %, %/*.hs, Language Language/$(UPKG))))
TOP=../..
include ../build.mk
HC_OPTS += -I$(UPKG)
HC_OPTS += -ILanguage/$(UPKG)
install: install-me

14
src/hi/hi.conf.in.cpp
View File

@ -26,15 +26,15 @@ license: BSD3
maintainer: libraries@haskell.org
exposed: True
exposed-modules:
Hi.Binary,
Hi.FastMutInt,
Hi.FastString,
Hi.Parser,
Hi.PrimPacked,
Hi.Syntax,
Hi
Language.Hi.Parser
hidden-modules:
Language.Hi.Binary,
Language.Hi.FastString,
Language.Hi.Syntax,
Language.Hi.FastMutInt,
Language.Hi.PrimPacked
#ifdef INSTALLING
import-dirs: LIBDIR/imports
library-dirs: LIBDIR

16
src/plugins/Makefile
View File

@ -5,18 +5,20 @@ TOP=../..
include $(TOP)/config.mk
ifeq ($(CABAL),1)
YOBJ = $(UPKG)/ParsePkgConfCabal.hs
YSRC = $(UPKG)/ParsePkgConfCabal.y
OTHER = $(UPKG)/ParsePkgConfLite.hs
YOBJ = System/$(UPKG)/ParsePkgConfCabal.hs
YSRC = System/$(UPKG)/ParsePkgConfCabal.y
OTHER = System/$(UPKG)/ParsePkgConfLite.hs
else
YOBJ = $(UPKG)/ParsePkgConfLite.hs
YSRC = $(UPKG)/ParsePkgConfLite.y
OTHER = $(UPKG)/ParsePkgConfCabal.hs
YOBJ = System/$(UPKG)/ParsePkgConfLite.hs
YSRC = System/$(UPKG)/ParsePkgConfLite.y
OTHER = System/$(UPKG)/ParsePkgConfCabal.hs
endif
STUBOBJS =System/Eval/Haskell_stub.$(way_)o
ALL_SRCS= $(filter-out $(OTHER), \
$(wildcard $(patsubst ./%, %, \
$(patsubst %, %/*.hs, . $(UPKG)))))
$(patsubst %, %/*.hs, System System/$(UPKG)))))
include ../build.mk

8
src/eval/Eval.hs → src/plugins/System/Eval.hs
View File

@ -17,11 +17,9 @@
-- USA
--
module Eval (
module Eval.Haskell,
module Eval.Meta,
module System.Eval (
module System.Eval.Haskell,
) where
import Eval.Haskell {-all-}
import Eval.Meta {-all-}
import System.Eval.Haskell {-all-}

11
src/eval/Eval/Haskell.hs → src/plugins/System/Eval/Haskell.hs
View File

@ -22,7 +22,7 @@
-- compile and run haskell strings at runtime.
--
module Eval.Haskell (
module System.Eval.Haskell (
eval,
eval_,
unsafeEval,
@ -34,14 +34,13 @@ module Eval.Haskell (
hs_eval_i, -- return a CInt
hs_eval_s, -- return a CString
module Eval.Utils,
module System.Eval.Utils,
) where
import Eval.Utils
import Plugins.Make
import Plugins.Load
import System.Eval.Utils
import System.Plugins.Make
import System.Plugins.Load
import AltData.Dynamic
import AltData.Typeable ( Typeable )

8
src/eval/Eval/Utils.hs → src/plugins/System/Eval/Utils.hs
View File

@ -22,7 +22,7 @@
-- compile and run haskell strings at runtime.
--
module Eval.Utils (
module System.Eval.Utils (
Import,
symbol,
@ -38,9 +38,9 @@ module Eval.Utils (
) where
import Plugins.Load ( Symbol )
import Plugins.Utils
import Plugins.Consts ( top {- :{ -} )
import System.Plugins.Load ( Symbol )
import System.Plugins.Utils
import System.Plugins.Consts ( top {- :{ -} )
import System.IO
import System.Directory

2
src/plugins/Plugins/MkTemp.hs → src/plugins/System/MkTemp.hs
View File

@ -27,7 +27,7 @@
-- which are available under the BSD license.
--
module Plugins.MkTemp (
module System.MkTemp (
mktemp, -- :: FilePath -> IO Maybe FilePath
mkstemp, -- :: FilePath -> IO Maybe (FilePath, Handle)

10
src/plugins/Plugins.hs → src/plugins/System/Plugins.hs
View File

@ -17,17 +17,17 @@
-- USA
--
module Plugins (
module System.Plugins (
-- $Description
module Plugins.Make,
module Plugins.Load,
module System.Plugins.Make,
module System.Plugins.Load,
) where
import Plugins.Make {-all-}
import Plugins.Load {-all-}
import System.Plugins.Make {-all-}
import System.Plugins.Load {-all-}
--
-- $Description

4
src/plugins/Plugins/Consts.hs → src/plugins/System/Plugins/Consts.hs
View File

@ -18,9 +18,9 @@
-- USA
--
module Plugins.Consts where
module System.Plugins.Consts where
#include "../../../config.h"
#include "../../../../config.h"
#if __GLASGOW_HASKELL__ >= 604

12
src/plugins/Plugins/Env.hs → src/plugins/System/Plugins/Env.hs
View File

@ -18,7 +18,7 @@
-- USA
--
module Plugins.Env (
module System.Plugins.Env (
withModEnv,
withPkgEnvs,
withMerged,
@ -41,15 +41,15 @@ module Plugins.Env (
) where
#include "../../../config.h"
#include "../../../../config.h"
import Plugins.PackageAPI {- everything -}
import System.Plugins.PackageAPI {- everything -}
#if CABAL == 1 || __GLASGOW_HASKELL__ >= 604
import Plugins.ParsePkgConfCabal( parsePkgConf )
import System.Plugins.ParsePkgConfCabal( parsePkgConf )
#else
import Plugins.ParsePkgConfLite ( parsePkgConf )
import System.Plugins.ParsePkgConfLite ( parsePkgConf )
#endif
import Plugins.Consts ( ghcLibraryPath, sysPkgConf, sysPkgSuffix, dllSuf )
import System.Plugins.Consts ( ghcLibraryPath, sysPkgConf, sysPkgSuffix, dllSuf )
import Data.IORef ( writeIORef, readIORef, newIORef, IORef() )
import Data.Maybe ( isJust )

12
src/plugins/Plugins/Load.hs → src/plugins/System/Plugins/Load.hs
View File

@ -19,7 +19,7 @@
-- USA
--
module Plugins.Load (
module System.Plugins.Load (
-- high level interface
load , load_
@ -47,12 +47,12 @@ module Plugins.Load (
) where
import Plugins.Make ( build )
import Plugins.Env
import Plugins.Utils
import Plugins.Consts ( sysPkgSuffix, hiSuf, prefixUnderscore )
import System.Plugins.Make ( build )
import System.Plugins.Env
import System.Plugins.Utils
import System.Plugins.Consts ( sysPkgSuffix, hiSuf, prefixUnderscore )
import Hi.Parser
import Language.Hi.Parser
import AltData.Dynamic ( fromDyn, Dynamic )
import AltData.Typeable ( Typeable )

10
src/plugins/Plugins/Make.hs → src/plugins/System/Plugins/Make.hs
View File

@ -18,7 +18,7 @@
-- USA
--
module Plugins.Make (
module System.Plugins.Make (
make,
makeAll,
@ -39,10 +39,10 @@ module Plugins.Make (
) where
import Plugins.Utils
import Plugins.Parser
import Plugins.Consts ( ghc, hiSuf, objSuf, hsSuf )
import Plugins.Env ( lookupMerged, addMerge )
import System.Plugins.Utils
import System.Plugins.Parser
import System.Plugins.Consts ( ghc, hiSuf, objSuf, hsSuf )
import System.Plugins.Env ( lookupMerged, addMerge )
import System.IO
import System.Directory ( doesFileExist, removeFile )

2
src/plugins/Plugins/Package.hs → src/plugins/System/Plugins/Package.hs
View File

@ -20,7 +20,7 @@
-- Read information from a package.conf
--
module Plugins.Package {-everything-} where
module System.Plugins.Package {-everything-} where
type PackageName = String

6
src/plugins/Plugins/PackageAPI.hs → src/plugins/System/Plugins/PackageAPI.hs
View File

@ -22,7 +22,7 @@
-- to handle either traditional or Cabal style package conf`s.
--
module Plugins.PackageAPI (
module System.Plugins.PackageAPI (
PackageName
, PackageConfig
, packageName
@ -36,13 +36,13 @@ module Plugins.PackageAPI (
, updLibraryDirs
) where
#include "../../../config.h"
#include "../../../../config.h"
#if CABAL == 1 || __GLASGOW_HASKELL__ >= 604
import Distribution.InstalledPackageInfo
import Distribution.Package
#else
import Plugins.Package
import System.Plugins.Package
#endif
packageName :: PackageConfig -> PackageName

4
src/plugins/Plugins/ParsePkgConfCabal.hs → src/plugins/System/Plugins/ParsePkgConfCabal.hs
View File

@ -3,7 +3,7 @@
module Plugins.ParsePkgConfCabal (
module System.Plugins.ParsePkgConfCabal (
parsePkgConf, parseOnePkgConf
) where
@ -515,7 +515,7 @@ parseOnePkgConf = parseOne . lexer
{-# LINE 1 "<built-in>" #-}
{-# LINE 1 "<command line>" #-}
{-# LINE 1 "GenericTemplate.hs" #-}
-- $Id: ParsePkgConfCabal.hs,v 1.1 2005/04/22 08:58:28 dons Exp $
-- $Id$
{-# LINE 28 "GenericTemplate.hs" #-}

2
src/plugins/Plugins/ParsePkgConfCabal.y → src/plugins/System/Plugins/ParsePkgConfCabal.y
View File

@ -31,7 +31,7 @@
{
{-# OPTIONS -w #-}
module Plugins.ParsePkgConfCabal (
module System.Plugins.ParsePkgConfCabal (
parsePkgConf, parseOnePkgConf
) where

4
src/plugins/Plugins/ParsePkgConfLite.hs → src/plugins/System/Plugins/ParsePkgConfLite.hs
View File

@ -3,11 +3,11 @@
module Plugins.ParsePkgConfLite (
module System.Plugins.ParsePkgConfLite (
parsePkgConf, parseOnePkgConf
) where
import Plugins.Package ( PackageConfig(..), defaultPackageConfig )
import System.Plugins.Package ( PackageConfig(..), defaultPackageConfig )
import Char ( isSpace, isAlpha, isAlphaNum, isUpper )
import List ( break )

4
src/plugins/Plugins/ParsePkgConfLite.y → src/plugins/System/Plugins/ParsePkgConfLite.y
View File

@ -28,11 +28,11 @@
{-# OPTIONS -w #-}
module Plugins.ParsePkgConfLite (
module System.Plugins.ParsePkgConfLite (
parsePkgConf, parseOnePkgConf
) where
import Plugins.Package ( PackageConfig(..), defaultPackageConfig )
import System.Plugins.Package ( PackageConfig(..), defaultPackageConfig )
import Char ( isSpace, isAlpha, isAlphaNum, isUpper )
import List ( break )

2
src/plugins/Plugins/Parser.hs → src/plugins/System/Plugins/Parser.hs
View File

@ -18,7 +18,7 @@
-- 02111-1307, USA.
--
module Plugins.Parser (
module System.Plugins.Parser (
parse, mergeModules, pretty, parsePragmas,
HsModule(..) ,
replaceModName

12
src/plugins/Plugins/Utils.hs → src/plugins/System/Plugins/Utils.hs
View File

@ -18,9 +18,9 @@
-- USA
--
#include "../../../config.h"
#include "../../../../config.h"
module Plugins.Utils (
module System.Plugins.Utils (
Arg,
hWrite,
@ -55,9 +55,9 @@ module Plugins.Utils (
) where
import Plugins.Env ( isLoaded )
import Plugins.Consts ( objSuf, hiSuf, tmpDir )
import qualified Plugins.MkTemp ( mkstemps )
import System.Plugins.Env ( isLoaded )
import System.Plugins.Consts ( objSuf, hiSuf, tmpDir )
import qualified System.MkTemp ( mkstemps )
import Data.Char
import Data.List
@ -104,7 +104,7 @@ hWrite hdl src = hPutStr hdl src >> hClose hdl >> return ()
mkstemps :: String -> Int -> IO (String,Handle)
mkstemps path slen = do
m_v <- Plugins.MkTemp.mkstemps path slen
m_v <- System.MkTemp.mkstemps path slen
case m_v of Nothing -> error "mkstemps : couldn't create temp file"
Just v' -> return v'

26
src/plugins/plugins.conf.in.cpp
View File

@ -28,18 +28,24 @@ license: LGPL
maintainer: dons@cse.unsw.edu.au
exposed: True
exposed-modules:
Plugins.Consts,
Plugins.Env,
Plugins.Load,
Plugins.Make,
Plugins.MkTemp,
Plugins.PackageAPI,
Plugins.ParsePkgConfCabal,
Plugins.Parser,
Plugins.Utils,
Plugins
System.Plugins.Load,
System.Plugins.Make,
System.Plugins,
System.MkTemp,
System.Eval.Haskell,
System.Eval
hidden-modules:
System.Plugins.Consts,
System.Plugins.Env,
System.Plugins.Package,
System.Plugins.PackageAPI,
System.Plugins.ParsePkgConfCabal,
System.Plugins.ParsePkgConfLite,
System.Plugins.Parser,
System.Plugins.Utils,
System.Eval.Utils
#ifdef INSTALLING
import-dirs: LIBDIR/imports
library-dirs: LIBDIR

20
src/printf/Makefile
View File

@ -1,20 +0,0 @@
PKG = printf
UPKG = Printf
YOBJ = $(UPKG)/Parser.hs
YSRC = $(UPKG)/Parser.y
XOBJ = $(UPKG)/Lexer.hs
XSRC = $(UPKG)/Lexer.x
ALL_SRCS=$(wildcard $(patsubst ./%, %, $(patsubst %, %/*.hs, . $(UPKG))))
TOP=../..
include ../build.mk
HC_OPTS += -package-conf $(TOP)/plugins.conf.inplace
HC_OPTS += -package eval
install: install-me
-include depend

25
src/printf/Printf.hs
View File

@ -1,25 +0,0 @@
--
-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
-- USA
--
module Printf (
module Printf.Compile
) where
import Printf.Compile {-all-}

390
src/printf/Printf/Compile.hs
View File

@ -1,390 +0,0 @@
{-# OPTIONS -fglasgow-exts #-}
--
-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
-- USA
--
--
-- compile and run haskell strings at runtime.
--
-- Some of the backend code is based on Ian Lynagh's TH version of
-- Printf.
--
-- The specification of this implementation is taken from
-- the OpenBSD 3.5 man page for printf(3)
--
module Printf.Compile (
printf,
(!),
($>), ($<),
) where
import Printf.Lexer
import Printf.Parser
import Eval.Haskell ( eval )
import Eval.Utils ( escape )
import Plugins.Utils ( (<>), (<+>) )
import AltData.Dynamic
import AltData.Typeable hiding ( typeOf )
import Data.List
import Data.Maybe ( isNothing, isJust )
import System.IO.Unsafe ( unsafePerformIO )
type Type = String
type Code = String
-- ---------------------------------------------------------------------
--
-- Generate a new Haskell function, as compiled native-code, from a
-- printf format string. It isn't applied to its arguments yet.
-- The function will return a String, but we won't typecheck this till
-- application.
--
printf :: String -> Dynamic -- ([Dynamic] -> String)
printf fmt = run src ["Data.Char","Numeric"]
where
src = compile . parse . scan' . escape $ fmt
scan' s = either (error "lexer failed") (id) (scan s)
run e i = case unsafePerformIO (eval e i) of
Nothing -> error "source failed to compile"
Just a -> a
--
-- application shortcuts. these expect all arguments to be supplied, and
-- if this is so, we can then give the result a type.
-- partial application means type annotations, or retaining everything
-- as a Dynamic
--
--
-- sprintf
-- Apply a new fn to a arg list, returning a String
--
infixr 0 $<
($<) :: Dynamic -> [Dynamic] -> String
f $< as = fromDynamic $! f `dynAppHList` as
--
-- printf
-- Apply a new fn to a arg list, printing out the result
--
infixr 0 $>
($>) :: Dynamic -> [Dynamic] -> IO ()
f $> as = putStr (fromDynamic $! f `dynAppHList` as)
-- ---------------------------------------------------------------------
-- a printf code generator
--
-- ToDo handle all the different specifiers
--
-- Compile a printf format syntax tree into a Haskell string
-- representing a Haskell function to implement this printf.
--
compile :: [Format] -> String
compile fmt =
let (tys,src) = compile' fmt 0
in "toDyn $ \\" <>
spacify (map (\(ty,i) -> parens('x':show i <+> "::" <+> ty))
(zip tys [0..length src])) <+> "->" <+> consify src
where spacify s = concat (intersperse " " s)
consify s = concat (intersperse "++" s)
-- ---------------------------------------------------------------------
--
-- Compile an individual format or string literal
compile' :: [Format] -> Int -> ([String],[String])
compile' [] _ = ([],[])
compile' ((StrLit s):xs) i = ( ts, ( '"':s++"\"" ):ss )
where (ts,ss) = compile' xs i
compile' ((ConvSp _ _ _ _ Percent):xs) i = (ts, "\"%\"":ss)
where (ts,ss) = compile' xs $! i+1
compile' (c@(ConvSp _ _ _ _ t):xs) i =
(typeOf t:ts, parens(
(snd.plus.pad.alt.trunc.codeOf) c -- apply transformations
<+> ident i) : ss)
where (ts, ss) = compile' xs $! i+1
-- ---------------------------------------------------------------------
--
-- What argument type does a conversion specifier generate?
-- should be a FM
--
typeOf :: Conv -> Type
typeOf x = case x of
D -> "Int"
O -> "Int"
Xx -> "Int"
XX -> "Int"
U -> "Int"
C -> "Char"
S -> "String"
F -> "Double"
Ee -> "Double"
EE -> "Double"
Gg -> "Double"
GG -> "Double"
Percent -> error "typeOf %: conversion specifier has no argument type"
-- ---------------------------------------------------------------------
--
-- Generate Haskell code for each particular format
--
codeOf :: Format -> (Format,Code)
codeOf c@(ConvSp _ _ p _ f) = case f of
-- diouxX The int (or appropriate variant) argument is converted to signed
-- decimal (d and i), unsigned octal (o), unsigned decimal (u), or
-- unsigned hexadecimal (x and X) notation. The letters abcdef are
-- used for x conversions; the letters ABCDEF are used for X conver-
-- sions. The precision, if any, gives the minimum number of digits
-- that must appear; if the converted value requires fewer digits,
-- it is padded on the left with zeros.
D -> (c,"(show)")
U -> (c,"(show)")
O -> (c,"(\\v -> showOct v [])")
Xx -> (c,"(\\v -> showHex v [])")
XX -> (c,"(\\v -> map toUpper (showHex v []))")
-- eE The double argument is rounded and converted in the style
-- [-]d.ddde+-dd where there is one digit before the decimal-point
-- character and the number of digits after it is equal to the pre-
-- cision; if the precision is missing, it is taken as 6; if the
-- precision is zero, no decimal-point character appears. An E con-
-- version uses the letter E (rather than e) to introduce the expo-
-- nent. The exponent always contains at least two digits; if the
-- value is zero, the exponent is 00.
-- TODO prints exponent differently to printf(3)
Ee -> let prec = if isNothing p then "Just 6" else show p
in (c,"(\\v->(showEFloat("++prec++")v)[])")
EE -> let prec = if isNothing p then "Just 6" else show p
in (c,"(\\v->map toUpper((showEFloat ("++prec++")v)[]))")
-- gG The double argument is converted in style f or e (or E for G con-
-- versions). The precision specifies the number of significant
-- digits. If the precision is missing, 6 digits are given; if the
-- precision is zero, it is treated as 1. Style e is used if the
-- exponent from its conversion is less than -4 or greater than or
-- equal to the precision. Trailing zeros are removed from the
-- fractional part of the result; a decimal point appears only if it
-- is followed by at least one digit.
-- TODO unimplemented
Gg -> let prec = if isNothing p then "Just 6" else show p
in (c,"(\\v->(showGFloat("++prec++")v)[])")
GG -> let prec = if isNothing p then "Just 6" else show p
in (c,"(\\v->map toUpper((showGFloat ("++prec++")v)[]))")
-- f The double argument is rounded and converted to decimal notation
-- in the style [-]ddd.ddd, where the number of digits after the
-- decimal-point character is equal to the precision specification.
-- If the precision is missing, it is taken as 6; if the precision
-- is explicitly zero, no decimal-point character appears. If a
-- decimal point appears, at least one digit appears before it.
F -> let prec = if isNothing p then "Just 6" else show p
in (c, "(\\v -> (showFFloat ("++prec++") v) [])")
-- c The int argument is converted to an unsigned char, and the re-
-- sulting character is written.
C -> (c,"(\\c -> (showLitChar c) [])")
-- s The char * argument is expected to be a pointer to an array of
-- character type (pointer to a string). Characters from the array
-- are written up to (but not including) a terminating NUL charac-
-- ter; if a precision is specified, no more than the number speci-
-- fied are written. If a precision is given, no null character
-- need be present; if the precision is not specified, or is greater
-- than the size of the array, the array must contain a terminating
-- NUL character.
S -> (c,"(id)")
-- % A `%' is written. No argument is converted. The complete con-
-- version specification is `%%'.
Percent -> (c,"%")
codeOf _ = error "codeOf: unknown conversion specifier"
-- ---------------------------------------------------------------------
--
-- Do we need a leading + ?
--
-- A `+' character specifying that a sign always be placed before a
-- number produced by a signed conversion. A `+' overrides a space
-- if both are used.
--
plus :: (Format, Code) -> (Format, Code)
plus p@(StrLit _,_) = p
plus a@(c@(ConvSp fs _w _ _ x), code) = case x of
D -> prefix
Ee-> prefix
EE-> prefix
Gg-> prefix
GG-> prefix
F -> prefix
_ -> a
where prefix = let pref | Signed `elem` fs = "\"+\""
| Space `elem` fs = "\" \""
| otherwise = "[]"
in (c,parens("\\v ->"<+>pref<+>"++ v") <$> code)
{- munge = case w of
Just w' | w' > 0 -> "tail"
_ -> "" -}
-- ---------------------------------------------------------------------
-- Work out padding.
--
-- A negative field width flag `-' indicates the converted value is
-- to be left adjusted on the field boundary. Except for n conver-
-- sions, the converted value is padded on the right with blanks,
-- rather than on the left with blanks or zeros. A `-' overrides a
-- `0' if both are given.
--
-- A zero `0' character specifying zero padding. For all conver-
-- sions except n, the converted value is padded on the left with
-- zeros rather than blanks. If a precision is given with a numeric
-- conversion (d, i, o, u, x, and X), the `0' flag is ignored.
--
pad :: (Format,Code) -> (Format,Code)
pad (c@(ConvSp fs (Just w) p _ x),code)
| LeftAdjust `elem` fs
= (c, parens(parens("\\i c s -> if length s < i"<+>
"then s ++ take (i-length s) (repeat c) else s")
<+>show w<+>"' '")<$>code )
| otherwise
= (c, parens(parens("\\i c s -> if length s < i"<+>
"then take (i-length s) (repeat c) ++ s else s")
<+>show w<+>pad_chr)<$>code)
where pad_chr | isNumeric x && isJust p = "' '"
| LeadZero `elem` fs = "'0'"
| otherwise = "' '"
pad (c@(ConvSp _ Nothing _ _ _),code) = (c,code)
pad ((StrLit _),_) = error "pad: can't pad str lit"
isNumeric :: Conv -> Bool
isNumeric x = case x of
D -> True
O -> True
U -> True
Xx -> True
XX -> True
_ -> False
-- ---------------------------------------------------------------------
--
-- Check the 'alternate' modifier
--
-- A hash `#' character specifying that the value should be convert-
-- ed to an ``alternate form''. For c, d, i, n, p, s, and u conver-
-- sions, this option has no effect. For o conversions, the preci-
-- sion of the number is increased to force the first character of
-- the output string to a zero (except if a zero value is printed
-- with an explicit precision of zero). For x and X conversions, a
-- non-zero result has the string `0x' (or `0X' for X conversions)
-- prepended to it. For e, E, f, g, and G conversions, the result
-- will always contain a decimal point, even if no digits follow it
-- (normally, a decimal point appears in the results of those con-
-- versions only if a digit follows). For g and G conversions,
-- trailing zeros are not removed from the result as they would oth-
-- erwise be.
--
alt :: (Format,Code) -> (Format,Code)
alt a@(c@(ConvSp fs _ _ _ x), code) | Alt `elem` fs = case x of
Xx -> (c,parens("\\v->if fst (head (readHex v)) /= 0"<+>
"then \"0x\"++v else v")<$>code)
XX -> (c,parens("\\v->if fst (head (readHex v)) /= 0"<+>
"then \"0X\"++v else v")<$>code)
O -> (c,parens("\\v->if fst(head(readOct v)) /= 0"<+>
"then \"0\"++v else v")<$>code)
_ -> a
alt a = a
-- ---------------------------------------------------------------------
--
-- Handle precision. Involves truncating strings and decimal points
--
-- An optional precision, in the form of a period `.' followed by an op-
-- tional digit string. If the digit string is omitted, the precision
-- is taken as zero. This gives the minimum number of digits to appear
-- for d, i, o, u, x, and X conversions, the number of digits to appear
-- after the decimal-point for e, E, and f conversions, the maximum num-
-- ber of significant digits for g and G conversions, or the maximum
-- number of characters to be printed from a string for s conversions.
--
trunc :: (Format,Code) -> (Format,Code)
trunc (c@(ConvSp _ _ (Just i) _ x), code) = case x of
S -> (c, parens("(\\i s -> if length s > i"<+>
"then take i s else s)"<+>show i)<$>code)
_ | isNumeric x -> {-TODO-} (c, code)
| otherwise -> (c, code)
trunc c = c
-- ---------------------------------------------------------------------
-- make a new variable
ident i = 'x':show i
-- wrap in parens
parens p = "("++p++")"
-- lazy operator
infixr 6 <$>
(<$>) :: String -> String -> String
[] <$> a = a
a <$> b = a ++ " $ " ++ b
-- ---------------------------------------------------------------------
--
-- This bit of syntax constructs a [Dynamic].
--
infixr 6 !
(!) :: Typeable a => a -> [Dynamic] -> [Dynamic]
a ! xs = toDyn a : xs

407
src/printf/Printf/Lexer.hs
View File

@ -1,407 +0,0 @@
{-# OPTIONS -fglasgow-exts -cpp #-}
{-# LINE 25 "Printf/Lexer.x" #-}
{-# OPTIONS -w #-}
-- ^ don't want to see all the warns alex templates produce
module Printf.Lexer ( scan, Token(..) ) where
#if __GLASGOW_HASKELL__ >= 503
import Data.Array
import Data.Char (ord)
import Data.Array.Base (unsafeAt)
#else
import Array
import Char (ord)
#endif
#if __GLASGOW_HASKELL__ >= 503
import GHC.Exts
#else
import GlaExts
#endif
alex_base :: AlexAddr
alex_base = AlexA# "\xf7\xff\xe2\xff\xef\xff\xf9\xff\x04\x00\x00\x00\xe6\xff\xfa\xff\x00\x00\x00\x00\x00\x00"#
alex_table :: AlexAddr
alex_table = AlexA# "\x00\x00\xff\xff\x06\x00\xff\xff\x00\x00\x06\x00\x06\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x06\x00\xff\xff\x06\x00\x00\x00\x06\x00\x06\x00\x06\x00\x0a\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x08\x00\xff\xff\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\xff\xff\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x0a\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x09\x00\x0a\x00\x00\x00\x00\x00\x09\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#
alex_check :: AlexAddr
alex_check = AlexA# "\xff\xff\x0a\x00\x20\x00\x0a\x00\xff\xff\x23\x00\x20\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x2b\x00\x0a\x00\x2d\x00\xff\xff\x2b\x00\x30\x00\x2d\x00\x25\x00\xff\xff\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\x2e\x00\x25\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x25\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\xff\xff\xff\xff\x6c\x00\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\xff\xff\x75\x00\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
alex_deflt :: AlexAddr
alex_deflt = AlexA# "\x04\x00\xff\xff\xff\xff\x04\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
alex_accept = listArray (0::Int,10) [[],[(AlexAcc (alex_action_2))],[],[],[(AlexAcc (alex_action_0))],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_6))]]
{-# LINE 54 "Printf/Lexer.x" #-}
mkflags, mkconv, mklength, mkint, mkstr, mkdot :: AlexInput -> Int -> Alex Token
mkflags (_,_,input) len = return (FlagT (take len input))
mkconv (_,_,(c:_)) _ = return (ConvT c)
mklength (_,_,(c:_)) _ = return (LengthT c)
mkint (_,_,input) len = return (IntT (read (take len input)))
mkstr (_,_,input) len = return (StrT (take len input))
mkdot _ _ = return DotT
alexEOF = return EOFT
data Token
= FlagT [Char]
| ConvT Char
| LengthT Char
| IntT Int
| StrT String
| DotT
| EOFT
deriving (Eq, Show)
scan :: String -> Either String [Token]
scan str = runAlex str $ do
let loop tks = do
tok <- alexMonadScan;
if tok == EOFT then do return $! reverse tks
else loop $! (tok:tks)
loop []
flag,fmt :: Int
flag = 1
fmt = 2
alex_action_0 = mkstr
alex_action_1 = begin flag
alex_action_2 = mkflags `andBegin` fmt
alex_action_3 = mkint
alex_action_4 = mkdot
alex_action_5 = mklength
alex_action_6 = mkconv `andBegin` 0
{-# LINE 1 "GenericTemplate.hs" #-}
-- -----------------------------------------------------------------------------
-- ALEX TEMPLATE
--
-- This code is in the PUBLIC DOMAIN; you may copy it freely and use
-- it for any purpose whatsoever.
-- -----------------------------------------------------------------------------
-- INTERNALS and main scanner engine
{-# LINE 34 "GenericTemplate.hs" #-}
data AlexAddr = AlexA# Addr#
{-# INLINE alexIndexShortOffAddr #-}
alexIndexShortOffAddr (AlexA# arr) off =
#if __GLASGOW_HASKELL__ > 500
narrow16Int# i
#elif __GLASGOW_HASKELL__ == 500
intToInt16# i
#else
(i `iShiftL#` 16#) `iShiftRA#` 16#
#endif
where
#if __GLASGOW_HASKELL__ >= 503
i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)
#else
i = word2Int# ((high `shiftL#` 8#) `or#` low)
#endif
high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
low = int2Word# (ord# (indexCharOffAddr# arr off'))
off' = off *# 2#
-- -----------------------------------------------------------------------------
-- Main lexing routines
data AlexReturn a
= AlexEOF
| AlexError !AlexInput
| AlexSkip !AlexInput !Int
| AlexToken !AlexInput !Int a
-- alexScan :: AlexInput -> StartCode -> Maybe (AlexInput,Int,act)
alexScan input (I# (sc))
= alexScanUser undefined input (I# (sc))
alexScanUser user input (I# (sc))
= case alex_scan_tkn user input 0# input sc AlexNone of
(AlexNone, input') ->
case alexGetChar input of
Nothing ->
AlexEOF
Just _ ->
AlexError input
(AlexLastSkip input len, _) ->
AlexSkip input len
(AlexLastAcc k input len, _) ->
AlexToken input len k
-- Push the input through the DFA, remembering the most recent accepting
-- state it encountered.
alex_scan_tkn user orig_input len input s last_acc =
input `seq` -- strict in the input
case s of
-1# -> (last_acc, input)
_ -> alex_scan_tkn' user orig_input len input s last_acc
alex_scan_tkn' user orig_input len input s last_acc =
let
new_acc = check_accs (alex_accept `unsafeAt` (I# (s)))
in
new_acc `seq`
case alexGetChar input of
Nothing -> (new_acc, input)
Just (c, new_input) ->
let
base = alexIndexShortOffAddr alex_base s
(I# (ord_c)) = ord c
offset = (base +# ord_c)
check = alexIndexShortOffAddr alex_check offset
new_s = if (offset >=# 0#) && (check ==# ord_c)
then alexIndexShortOffAddr alex_table offset
else alexIndexShortOffAddr alex_deflt s
in
alex_scan_tkn user orig_input (len +# 1#) new_input new_s new_acc
where
check_accs [] = last_acc
check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len))
check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len))
check_accs (AlexAccPred a pred : rest)
| pred user orig_input (I# (len)) input
= AlexLastAcc a input (I# (len))
check_accs (AlexAccSkipPred pred : rest)
| pred user orig_input (I# (len)) input
= AlexLastSkip input (I# (len))
check_accs (_ : rest) = check_accs rest
data AlexLastAcc a
= AlexNone
| AlexLastAcc a !AlexInput !Int
| AlexLastSkip !AlexInput !Int
data AlexAcc a user
= AlexAcc a
| AlexAccSkip
| AlexAccPred a (AlexAccPred user)
| AlexAccSkipPred (AlexAccPred user)
type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool
-- -----------------------------------------------------------------------------
-- Predicates on a rule
alexAndPred p1 p2 user in1 len in2
= p1 user in1 len in2 && p2 user in1 len in2
--alexPrevCharIsPred :: Char -> AlexAccPred _
alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input
--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _
alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input
--alexRightContext :: Int -> AlexAccPred _
alexRightContext (I# (sc)) user _ _ input =
case alex_scan_tkn user input 0# input sc AlexNone of
(AlexNone, _) -> False
_ -> True
-- TODO: there's no need to find the longest
-- match when checking the right context, just
-- the first match will do.
-- used by wrappers
iUnbox (I# (i)) = i
{-# LINE 1 "wrappers.hs" #-}
-- -----------------------------------------------------------------------------
-- Alex wrapper code.
--
-- This code is in the PUBLIC DOMAIN; you may copy it freely and use
-- it for any purpose whatsoever.
-- -----------------------------------------------------------------------------
-- The input type
type AlexInput = (AlexPosn, -- current position,
Char, -- previous char
String) -- current input string
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (p,c,s) = c
alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
alexGetChar (p,c,[]) = Nothing
alexGetChar (p,_,(c:s)) = let p' = alexMove p c in p' `seq`
Just (c, (p', c, s))
-- -----------------------------------------------------------------------------
-- Token positions
-- `Posn' records the location of a token in the input text. It has three
-- fields: the address (number of chacaters preceding the token), line number
-- and column of a token within the file. `start_pos' gives the position of the
-- start of the file and `eof_pos' a standard encoding for the end of file.
-- `move_pos' calculates the new position after traversing a given character,
-- assuming the usual eight character tab stops.
data AlexPosn = AlexPn !Int !Int !Int
deriving (Eq,Show)
alexStartPos :: AlexPosn
alexStartPos = AlexPn 0 1 1
alexMove :: AlexPosn -> Char -> AlexPosn
alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+7) `div` 8)*8+1)
alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1) 1
alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1)
-- -----------------------------------------------------------------------------
-- Default monad
data AlexState = AlexState {
alex_pos :: !AlexPosn, -- position at current input location
alex_inp :: String, -- the current input
alex_chr :: !Char, -- the character before the input
alex_scd :: !Int -- the current startcode
}
-- Compile with -funbox-strict-fields for best results!
runAlex :: String -> Alex a -> Either String a
runAlex input (Alex f)
= case f (AlexState {alex_pos = alexStartPos,
alex_inp = input,
alex_chr = '\n',
alex_scd = 0}) of Left msg -> Left msg
Right ( _, a ) -> Right a
newtype Alex a = Alex { unAlex :: AlexState -> Either String (AlexState, a) }
instance Monad Alex where
m >>= k = Alex $ \s -> case unAlex m s of
Left msg -> Left msg
Right (s',a) -> unAlex (k a) s'
return a = Alex $ \s -> Right (s,a)
alexGetInput :: Alex AlexInput
alexGetInput
= Alex $ \s@AlexState{alex_pos=pos,alex_chr=c,alex_inp=inp} ->
Right (s, (pos,c,inp))
alexSetInput :: AlexInput -> Alex ()
alexSetInput (pos,c,inp)
= Alex $ \s -> case s{alex_pos=pos,alex_chr=c,alex_inp=inp} of
s@(AlexState{}) -> Right (s, ())
alexError :: String -> Alex a
alexError message = Alex $ \s -> Left message
alexGetStartCode :: Alex Int
alexGetStartCode = Alex $ \s@AlexState{alex_scd=sc} -> Right (s, sc)
alexSetStartCode :: Int -> Alex ()
alexSetStartCode sc = Alex $ \s -> Right (s{alex_scd=sc}, ())
alexMonadScan = do
inp <- alexGetInput
sc <- alexGetStartCode
case alexScan inp sc of
AlexEOF -> alexEOF
AlexError inp' -> alexError "lexical error"
AlexSkip inp' len -> do
alexSetInput inp'
alexMonadScan
AlexToken inp' len action -> do
alexSetInput inp'
action inp len
-- -----------------------------------------------------------------------------
-- Useful token actions
type AlexAction result = AlexInput -> Int -> result
-- just ignore this token and scan another one
-- skip :: AlexAction result
skip input len = alexMonadScan
-- ignore this token, but set the start code to a new value
-- begin :: Int -> AlexAction result
begin code input len = do alexSetStartCode code; alexMonadScan
-- perform an action for this token, and set the start code to a new value
-- andBegin :: AlexAction result -> Int -> AlexAction result
(action `andBegin` code) input len = do alexSetStartCode code; action input len
-- token :: (String -> Int -> token) -> AlexAction token
token t input len = return (t input len)
-- -----------------------------------------------------------------------------
-- Basic wrapper
{-# LINE 146 "wrappers.hs" #-}
-- -----------------------------------------------------------------------------
-- Posn wrapper
-- Adds text positions to the basic model.
{-# LINE 162 "wrappers.hs" #-}
-- -----------------------------------------------------------------------------
-- GScan wrapper
-- For compatibility with previous versions of Alex, and because we can.
{-# LINE 180 "wrappers.hs" #-}

86
src/printf/Printf/Lexer.x
View File

@ -1,86 +0,0 @@
--
-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons
--
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
-- published by the Free Software Foundation; either version 2 of
-- the License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
--
--
-- Lexer for printf format strings
-- Based on B1.2 Formatted Output, from Kernighan and Ritchie.
--
{
{-# OPTIONS -w #-}
-- ^ don't want to see all the warns alex templates produce
module Printf.Lexer ( scan, Token(..) ) where
}
%wrapper "monad"
$digit = 0-9
$conv = [dioxXucsfeEgGpn\%]
$len = [hlL]
$flag = [\-\+\ 0\#]
$str = [. # \%]
printf :-
<0> $str+ { mkstr }
<0> \% { begin flag }
<flag> $flag* { mkflags `andBegin` fmt }
<fmt> $digit+ { mkint }
<fmt> \. { mkdot }
<fmt> $len { mklength }
<fmt> $conv { mkconv `andBegin` 0 }
{
mkflags, mkconv, mklength, mkint, mkstr, mkdot :: AlexInput -> Int -> Alex Token
mkflags (_,_,input) len = return (FlagT (take len input))
mkconv (_,_,(c:_)) _ = return (ConvT c)
mklength (_,_,(c:_)) _ = return (LengthT c)
mkint (_,_,input) len = return (IntT (read (take len input)))
mkstr (_,_,input) len = return (StrT (take len input))
mkdot _ _ = return DotT
alexEOF = return EOFT
data Token
= FlagT [Char]
| ConvT Char
| LengthT Char
| IntT Int
| StrT String
| DotT
| EOFT
deriving (Eq, Show)
scan :: String -> Either String [Token]
scan str = runAlex str $ do
let loop tks = do
tok <- alexMonadScan;
if tok == EOFT then do return $! reverse tks
else loop $! (tok:tks)
loop []
}

719
src/printf/Printf/Parser.hs
View File

@ -1,719 +0,0 @@
{-# OPTIONS -fglasgow-exts -cpp -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-incomplete-patterns #-}
-- parser produced by Happy Version 1.14
-- ^ grr. happy needs them all on one line
module Printf.Parser where
import Printf.Lexer
import Array
#if __GLASGOW_HASKELL__ >= 503
import GHC.Exts
#else
import GlaExts
#endif
newtype HappyAbsSyn = HappyAbsSyn (() -> ())
happyIn4 :: ([Format]) -> (HappyAbsSyn )
happyIn4 x = unsafeCoerce# x
{-# INLINE happyIn4 #-}
happyOut4 :: (HappyAbsSyn ) -> ([Format])
happyOut4 x = unsafeCoerce# x
{-# INLINE happyOut4 #-}
happyIn5 :: (Format) -> (HappyAbsSyn )
happyIn5 x = unsafeCoerce# x
{-# INLINE happyIn5 #-}
happyOut5 :: (HappyAbsSyn ) -> (Format)
happyOut5 x = unsafeCoerce# x
{-# INLINE happyOut5 #-}
happyIn6 :: (Format) -> (HappyAbsSyn )
happyIn6 x = unsafeCoerce# x
{-# INLINE happyIn6 #-}
happyOut6 :: (HappyAbsSyn ) -> (Format)
happyOut6 x = unsafeCoerce# x
{-# INLINE happyOut6 #-}
happyIn7 :: (Format) -> (HappyAbsSyn )
happyIn7 x = unsafeCoerce# x
{-# INLINE happyIn7 #-}
happyOut7 :: (HappyAbsSyn ) -> (Format)
happyOut7 x = unsafeCoerce# x
{-# INLINE happyOut7 #-}
happyIn8 :: ([Flag]) -> (HappyAbsSyn )
happyIn8 x = unsafeCoerce# x
{-# INLINE happyIn8 #-}
happyOut8 :: (HappyAbsSyn ) -> ([Flag])
happyOut8 x = unsafeCoerce# x
{-# INLINE happyOut8 #-}
happyIn9 :: (Maybe Prec) -> (HappyAbsSyn )
happyIn9 x = unsafeCoerce# x
{-# INLINE happyIn9 #-}
happyOut9 :: (HappyAbsSyn ) -> (Maybe Prec)
happyOut9 x = unsafeCoerce# x
{-# INLINE happyOut9 #-}
happyIn10 :: (Maybe Width) -> (HappyAbsSyn )
happyIn10 x = unsafeCoerce# x
{-# INLINE happyIn10 #-}
happyOut10 :: (HappyAbsSyn ) -> (Maybe Width)
happyOut10 x = unsafeCoerce# x
{-# INLINE happyOut10 #-}
happyIn11 :: (Length) -> (HappyAbsSyn )
happyIn11 x = unsafeCoerce# x
{-# INLINE happyIn11 #-}
happyOut11 :: (HappyAbsSyn ) -> (Length)
happyOut11 x = unsafeCoerce# x
{-# INLINE happyOut11 #-}
happyIn12 :: (Conv) -> (HappyAbsSyn )
happyIn12 x = unsafeCoerce# x
{-# INLINE happyIn12 #-}
happyOut12 :: (HappyAbsSyn ) -> (Conv)
happyOut12 x = unsafeCoerce# x
{-# INLINE happyOut12 #-}
happyInTok :: Token -> (HappyAbsSyn )
happyInTok x = unsafeCoerce# x
{-# INLINE happyInTok #-}
happyOutTok :: (HappyAbsSyn ) -> Token
happyOutTok x = unsafeCoerce# x
{-# INLINE happyOutTok #-}
happyActOffsets :: HappyAddr
happyActOffsets = HappyA# "\x0f\x00\x00\x00\x14\x00\x0f\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x15\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00"#
happyGotoOffsets :: HappyAddr
happyGotoOffsets = HappyA# "\x0a\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xff\x00\x00\x00\x00"#
happyDefActions :: HappyAddr
happyDefActions = HappyA# "\xfe\xff\x00\x00\x00\x00\xfe\xff\xfc\xff\xfb\xff\xf3\xff\xfa\xff\xf7\xff\xef\xff\xf4\xff\xfd\xff\x00\x00\xf2\xff\xf1\xff\xf0\xff\xf5\xff\xef\xff\xf6\xff\xf8\xff\xee\xff\xed\xff\xec\xff\xeb\xff\xea\xff\xe9\xff\xe8\xff\xe7\xff\xe6\xff\xe5\xff\xe4\xff\xe3\xff\xe2\xff\xe1\xff\x00\x00\xf9\xff"#
happyCheck :: HappyAddr
happyCheck = HappyA# "\xff\xff\x08\x00\x01\x00\x02\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x01\x00\x02\x00\x03\x00\x07\x00\x12\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x05\x00\x14\x00\x15\x00\x06\x00\x08\x00\x07\x00\x13\x00\x13\x00\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
happyTable :: HappyAddr
happyTable = HappyA# "\x00\x00\x23\x00\x0e\x00\x0f\x00\x10\x00\x0b\x00\x03\x00\x04\x00\x05\x00\x06\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x0e\x00\x0f\x00\x10\x00\x22\x00\x11\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x11\x00\x08\x00\x09\x00\x09\x00\x13\x00\x0c\x00\x13\x00\x0b\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#
happyReduceArr = array (1, 30) [
(1 , happyReduce_1),
(2 , happyReduce_2),
(3 , happyReduce_3),
(4 , happyReduce_4),
(5 , happyReduce_5),
(6 , happyReduce_6),
(7 , happyReduce_7),
(8 , happyReduce_8),
(9 , happyReduce_9),
(10 , happyReduce_10),
(11 , happyReduce_11),
(12 , happyReduce_12),
(13 , happyReduce_13),
(14 , happyReduce_14),
(15 , happyReduce_15),
(16 , happyReduce_16),
(17 , happyReduce_17),
(18 , happyReduce_18),
(19 , happyReduce_19),
(20 , happyReduce_20),
(21 , happyReduce_21),
(22 , happyReduce_22),
(23 , happyReduce_23),
(24 , happyReduce_24),
(25 , happyReduce_25),
(26 , happyReduce_26),
(27 , happyReduce_27),
(28 , happyReduce_28),
(29 , happyReduce_29),
(30 , happyReduce_30)
]
happy_n_terms = 23 :: Int
happy_n_nonterms = 9 :: Int
happyReduce_1 = happySpecReduce_0 0# happyReduction_1
happyReduction_1 = happyIn4
([]
)
happyReduce_2 = happySpecReduce_2 0# happyReduction_2
happyReduction_2 happy_x_2
happy_x_1
= case happyOut5 happy_x_1 of { happy_var_1 ->
case happyOut4 happy_x_2 of { happy_var_2 ->
happyIn4
(happy_var_1 : happy_var_2
)}}
happyReduce_3 = happySpecReduce_1 1# happyReduction_3
happyReduction_3 happy_x_1
= case happyOut6 happy_x_1 of { happy_var_1 ->
happyIn5
(happy_var_1
)}
happyReduce_4 = happySpecReduce_1 1# happyReduction_4
happyReduction_4 happy_x_1
= case happyOut7 happy_x_1 of { happy_var_1 ->
happyIn5
(happy_var_1
)}
happyReduce_5 = happySpecReduce_1 2# happyReduction_5
happyReduction_5 happy_x_1
= case happyOutTok happy_x_1 of { (StrT happy_var_1) ->
happyIn6
(StrLit happy_var_1
)}
happyReduce_6 = happyReduce 6# 3# happyReduction_6
happyReduction_6 (happy_x_6 `HappyStk`
happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
happyRest)
= case happyOut8 happy_x_1 of { happy_var_1 ->
case happyOut10 happy_x_2 of { happy_var_2 ->
case happyOut9 happy_x_4 of { happy_var_4 ->
case happyOut11 happy_x_5 of { happy_var_5 ->
case happyOut12 happy_x_6 of { happy_var_6 ->
happyIn7
(ConvSp happy_var_1 happy_var_2 happy_var_4 happy_var_5 happy_var_6
) `HappyStk` happyRest}}}}}
happyReduce_7 = happyReduce 4# 3# happyReduction_7
happyReduction_7 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
happyRest)
= case happyOut8 happy_x_1 of { happy_var_1 ->
case happyOut10 happy_x_2 of { happy_var_2 ->
case happyOut11 happy_x_3 of { happy_var_3 ->
case happyOut12 happy_x_4 of { happy_var_4 ->
happyIn7
(ConvSp happy_var_1 happy_var_2 Nothing happy_var_3 happy_var_4
) `HappyStk` happyRest}}}}
happyReduce_8 = happySpecReduce_1 4# happyReduction_8
happyReduction_8 happy_x_1
= case happyOutTok happy_x_1 of { (FlagT happy_var_1) ->
happyIn8
(mkFlags happy_var_1
)}
happyReduce_9 = happySpecReduce_1 5# happyReduction_9
happyReduction_9 happy_x_1
= case happyOutTok happy_x_1 of { (IntT happy_var_1) ->
happyIn9
(Just happy_var_1
)}
happyReduce_10 = happySpecReduce_0 5# happyReduction_10
happyReduction_10 = happyIn9
(Nothing
)
happyReduce_11 = happySpecReduce_1 6# happyReduction_11
happyReduction_11 happy_x_1
= case happyOutTok happy_x_1 of { (IntT happy_var_1) ->
happyIn10
(Just happy_var_1
)}
happyReduce_12 = happySpecReduce_0 6# happyReduction_12
happyReduction_12 = happyIn10
(Nothing
)
happyReduce_13 = happySpecReduce_1 7# happyReduction_13
happyReduction_13 happy_x_1
= happyIn11
(Short
)
happyReduce_14 = happySpecReduce_1 7# happyReduction_14
happyReduction_14 happy_x_1
= happyIn11
(Long
)
happyReduce_15 = happySpecReduce_1 7# happyReduction_15
happyReduction_15 happy_x_1
= happyIn11
(Double
)
happyReduce_16 = happySpecReduce_0 7# happyReduction_16
happyReduction_16 = happyIn11
(Default
)
happyReduce_17 = happySpecReduce_1 8# happyReduction_17
happyReduction_17 happy_x_1
= happyIn12
(D
)
happyReduce_18 = happySpecReduce_1 8# happyReduction_18
happyReduction_18 happy_x_1
= happyIn12
(D
)
happyReduce_19 = happySpecReduce_1 8# happyReduction_19
happyReduction_19 happy_x_1
= happyIn12
(O
)
happyReduce_20 = happySpecReduce_1 8# happyReduction_20
happyReduction_20 happy_x_1
= happyIn12
(Xx
)
happyReduce_21 = happySpecReduce_1 8# happyReduction_21
happyReduction_21 happy_x_1
= happyIn12
(XX
)
happyReduce_22 = happySpecReduce_1 8# happyReduction_22
happyReduction_22 happy_x_1
= happyIn12
(U
)
happyReduce_23 = happySpecReduce_1 8# happyReduction_23
happyReduction_23 happy_x_1
= happyIn12
(C
)
happyReduce_24 = happySpecReduce_1 8# happyReduction_24
happyReduction_24 happy_x_1
= happyIn12
(S
)
happyReduce_25 = happySpecReduce_1 8# happyReduction_25
happyReduction_25 happy_x_1
= happyIn12
(F
)
happyReduce_26 = happySpecReduce_1 8# happyReduction_26
happyReduction_26 happy_x_1
= happyIn12
(Ee
)
happyReduce_27 = happySpecReduce_1 8# happyReduction_27
happyReduction_27 happy_x_1
= happyIn12
(EE
)
happyReduce_28 = happySpecReduce_1 8# happyReduction_28
happyReduction_28 happy_x_1
= happyIn12
(Gg
)
happyReduce_29 = happySpecReduce_1 8# happyReduction_29
happyReduction_29 happy_x_1
= happyIn12
(GG
)
happyReduce_30 = happySpecReduce_1 8# happyReduction_30
happyReduction_30 happy_x_1
= happyIn12
(Percent
)
happyNewToken action sts stk [] =
happyDoAction 22# (error "reading EOF!") action sts stk []
happyNewToken action sts stk (tk:tks) =
let cont i = happyDoAction i tk action sts stk tks in
case tk of {
LengthT 'h' -> cont 1#;
LengthT 'l' -> cont 2#;
LengthT 'L' -> cont 3#;
ConvT 'd' -> cont 4#;
ConvT 'i' -> cont 5#;
ConvT 'o' -> cont 6#;
ConvT 'x' -> cont 7#;
ConvT 'X' -> cont 8#;
ConvT 'u' -> cont 9#;
ConvT 'c' -> cont 10#;
ConvT 's' -> cont 11#;
ConvT 'f' -> cont 12#;
ConvT 'e' -> cont 13#;
ConvT 'E' -> cont 14#;
ConvT 'g' -> cont 15#;
ConvT 'G' -> cont 16#;
ConvT '%' -> cont 17#;
DotT -> cont 18#;
IntT happy_dollar_dollar -> cont 19#;
StrT happy_dollar_dollar -> cont 20#;
FlagT happy_dollar_dollar -> cont 21#;
_ -> happyError tks
}
happyThen = \m k -> k m
happyReturn = \a -> a
happyThen1 = happyThen
happyReturn1 = \a tks -> a
parse tks = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x))
happySeq = happyDontSeq
------------------------------------------------------------------------
--
-- abstract syntax for printf format strings
--
data Format
= StrLit String
| ConvSp { flags :: [Flag],
width :: (Maybe Width),
precision :: (Maybe Prec ),
lenght :: Length,
conv :: Conv }
deriving (Show, Eq)
type Width = Int
type Prec = Int
data Flag
= LeftAdjust -- -
| Signed -- +
| Space -- ' '
| LeadZero -- 0
| Alt -- #
deriving (Show, Eq)
data Length
= Short -- h
| Long -- l
| Double -- L
| Default
deriving (Show, Eq)
data Conv
= D
| O
| Xx | XX
| U
| C
| S
| F
| Ee | EE
| Gg | GG
| Percent
deriving (Show, Eq)
mkFlags :: [Char] -> [Flag]
mkFlags [] = []
mkFlags (c:cs) = (case c of
'-' -> LeftAdjust
'+' -> Signed
' ' -> Space
'0' -> LeadZero
'#' -> Alt) : mkFlags cs
happyError :: [Token] -> a
happyError [] = error "Parser" "parse error"
happyError tks = error $ "Parser: " ++ show tks
{-# LINE 1 "GenericTemplate.hs" #-}
-- $Id: Parser.hs,v 1.1 2004/06/28 03:56:01 dons Exp $
{-# LINE 27 "GenericTemplate.hs" #-}
data Happy_IntList = HappyCons Int# Happy_IntList
infixr 9 `HappyStk`
data HappyStk a = HappyStk a (HappyStk a)
-----------------------------------------------------------------------------
-- starting the parse
happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll
-----------------------------------------------------------------------------
-- Accepting the parse
happyAccept j tk st sts (HappyStk ans _) = (happyTcHack j
(happyTcHack st))
(happyReturn1 ans)
-----------------------------------------------------------------------------
-- Arrays only: do the next action
happyDoAction i tk st
= {- nothing -}
case action of
0# -> {- nothing -}
happyFail i tk st
-1# -> {- nothing -}
happyAccept i tk st
n | (n <# (0# :: Int#)) -> {- nothing -}
(happyReduceArr ! rule) i tk st
where rule = (I# ((negateInt# ((n +# (1# :: Int#))))))
n -> {- nothing -}
happyShift new_state i tk st
where new_state = (n -# (1# :: Int#))
where off = indexShortOffAddr happyActOffsets st
off_i = (off +# i)
check = if (off_i >=# (0# :: Int#))
then (indexShortOffAddr happyCheck off_i ==# i)
else False
action | check = indexShortOffAddr happyTable off_i
| otherwise = indexShortOffAddr happyDefActions st
indexShortOffAddr (HappyA# arr) off =
#if __GLASGOW_HASKELL__ > 500
narrow16Int# i
#elif __GLASGOW_HASKELL__ == 500
intToInt16# i
#else
(i `iShiftL#` 16#) `iShiftRA#` 16#
#endif
where
#if __GLASGOW_HASKELL__ >= 503
i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)
#else
i = word2Int# ((high `shiftL#` 8#) `or#` low)
#endif
high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
low = int2Word# (ord# (indexCharOffAddr# arr off'))
off' = off *# 2#
data HappyAddr = HappyA# Addr#
-----------------------------------------------------------------------------
-- HappyState data type (not arrays)
{-# LINE 165 "GenericTemplate.hs" #-}
-----------------------------------------------------------------------------
-- Shifting a token
happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =
let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in
-- trace "shifting the error token" $
happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)
happyShift new_state i tk st sts stk =
happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)
-- happyReduce is specialised for the common cases.
happySpecReduce_0 i fn 0# tk st sts stk
= happyFail 0# tk st sts stk
happySpecReduce_0 nt fn j tk st@((action)) sts stk
= happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)
happySpecReduce_1 i fn 0# tk st sts stk
= happyFail 0# tk st sts stk
happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')
= let r = fn v1 in
happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
happySpecReduce_2 i fn 0# tk st sts stk
= happyFail 0# tk st sts stk
happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')
= let r = fn v1 v2 in
happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
happySpecReduce_3 i fn 0# tk st sts stk
= happyFail 0# tk st sts stk
happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')
= let r = fn v1 v2 v3 in
happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
happyReduce k i fn 0# tk st sts stk
= happyFail 0# tk st sts stk
happyReduce k nt fn j tk st sts stk
= case happyDrop (k -# (1# :: Int#)) sts of
sts1@((HappyCons (st1@(action)) (_))) ->
let r = fn stk in -- it doesn't hurt to always seq here...
happyDoSeq r (happyGoto nt j tk st1 sts1 r)
happyMonadReduce k nt fn 0# tk st sts stk
= happyFail 0# tk st sts stk
happyMonadReduce k nt fn j tk st sts stk =
happyThen1 (fn stk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))
where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))
drop_stk = happyDropStk k stk
happyDrop 0# l = l
happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t
happyDropStk 0# l = l
happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs
-----------------------------------------------------------------------------
-- Moving to a new state after a reduction
happyGoto nt j tk st =
{- nothing -}
happyDoAction j tk new_state
where off = indexShortOffAddr happyGotoOffsets st
off_i = (off +# nt)
new_state = indexShortOffAddr happyTable off_i
-----------------------------------------------------------------------------
-- Error recovery (0# is the error token)
-- parse error if we are in recovery and we fail again
happyFail 0# tk old_st _ stk =
-- trace "failing" $
happyError
{- We don't need state discarding for our restricted implementation of
"error". In fact, it can cause some bogus parses, so I've disabled it
for now --SDM
-- discard a state
happyFail 0# tk old_st (HappyCons ((action)) (sts))
(saved_tok `HappyStk` _ `HappyStk` stk) =
-- trace ("discarding state, depth " ++ show (length stk)) $
happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))
-}
-- Enter error recovery: generate an error token,
-- save the old token and carry on.
happyFail i tk (action) sts stk =
-- trace "entering error recovery" $
happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk)
-- Internal happy errors:
notHappyAtAll = error "Internal Happy error\n"
-----------------------------------------------------------------------------
-- Hack to get the typechecker to accept our action functions
happyTcHack :: Int# -> a -> a
happyTcHack x y = y
{-# INLINE happyTcHack #-}
-----------------------------------------------------------------------------
-- Seq-ing. If the --strict flag is given, then Happy emits
-- happySeq = happyDoSeq
-- otherwise it emits
-- happySeq = happyDontSeq
happyDoSeq, happyDontSeq :: a -> b -> b
happyDoSeq a b = a `seq` b
happyDontSeq a b = b
-----------------------------------------------------------------------------
-- Don't inline any functions from the template. GHC has a nasty habit
-- of deciding to inline happyGoto everywhere, which increases the size of
-- the generated parser quite a bit.
{-# NOINLINE happyDoAction #-}
{-# NOINLINE happyTable #-}
{-# NOINLINE happyCheck #-}
{-# NOINLINE happyActOffsets #-}
{-# NOINLINE happyGotoOffsets #-}
{-# NOINLINE happyDefActions #-}
{-# NOINLINE happyShift #-}
{-# NOINLINE happySpecReduce_0 #-}
{-# NOINLINE happySpecReduce_1 #-}
{-# NOINLINE happySpecReduce_2 #-}
{-# NOINLINE happySpecReduce_3 #-}
{-# NOINLINE happyReduce #-}
{-# NOINLINE happyMonadReduce #-}
{-# NOINLINE happyGoto #-}
{-# NOINLINE happyFail #-}
-- end of Happy Template.

174
src/printf/Printf/Parser.y
View File

@ -1,174 +0,0 @@
--
-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons
--
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
-- published by the Free Software Foundation; either version 2 of
-- the License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
--
--
-- Parser for printf format strings
-- Based on B1.2 Formatted Output, from Kernighan and Ritchie.
--
{
{-# OPTIONS -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-incomplete-patterns #-}
-- ^ grr. happy needs them all on one line
module Printf.Parser where
import Printf.Lexer
}
%name parse
%tokentype { Token }
%token
'h' { LengthT 'h' }
'l' { LengthT 'l' }
'L' { LengthT 'L' }
'd' { ConvT 'd' }
'i' { ConvT 'i' }
'o' { ConvT 'o' }
'x' { ConvT 'x' }
'X' { ConvT 'X' }
'u' { ConvT 'u' }
'c' { ConvT 'c' }
's' { ConvT 's' }
'f' { ConvT 'f' }
'e' { ConvT 'e' }
'E' { ConvT 'E' }
'g' { ConvT 'g' }
'G' { ConvT 'G' }
'%' { ConvT '%' }
'.' { DotT }
INT { IntT $$ }
STRING { StrT $$ }
FLAGS { FlagT $$ }
%%
printf :: { [Format] }
: {- epsilon -} { [] }
| format0 printf { $1 : $2 }
format0 :: { Format }
: string { $1 }
| format { $1 }
string :: { Format }
: STRING { StrLit $1 }
format :: { Format }
: flags width '.' precision length conv { ConvSp $1 $2 $4 $5 $6 }
| flags width length conv { ConvSp $1 $2 Nothing $3 $4 }
flags :: { [Flag] }
: FLAGS { mkFlags $1 }
precision :: { Maybe Prec }
: INT { Just $1 }
| {- epsilon -} { Nothing }
width :: { Maybe Width }
: INT { Just $1 }
| {- epsilon -} { Nothing }
length :: { Length }
: 'h' { Short }
| 'l' { Long }
| 'L' { Double }
| {- epsilon -} { Default}
conv :: { Conv }
: 'd' { D }
| 'i' { D } -- n.b
| 'o' { O }
| 'x' { Xx }
| 'X' { XX }
| 'u' { U }
| 'c' { C }
| 's' { S }
| 'f' { F }
| 'e' { Ee }
| 'E' { EE }
| 'g' { Gg }
| 'G' { GG }
| '%' { Percent }
{
------------------------------------------------------------------------
--
-- abstract syntax for printf format strings
--
data Format
= StrLit String
| ConvSp { flags :: [Flag],
width :: (Maybe Width),
precision :: (Maybe Prec ),
lenght :: Length,
conv :: Conv }
deriving (Show, Eq)
type Width = Int
type Prec = Int
data Flag
= LeftAdjust -- -
| Signed -- +
| Space -- ' '
| LeadZero -- 0
| Alt -- #
deriving (Show, Eq)
data Length
= Short -- h
| Long -- l
| Double -- L
| Default
deriving (Show, Eq)
data Conv
= D
| O
| Xx | XX
| U
| C
| S
| F
| Ee | EE
| Gg | GG
| Percent
deriving (Show, Eq)
mkFlags :: [Char] -> [Flag]
mkFlags [] = []
mkFlags (c:cs) = (case c of
'-' -> LeftAdjust
'+' -> Signed
' ' -> Space
'0' -> LeadZero
'#' -> Alt) : mkFlags cs
happyError :: [Token] -> a
happyError [] = error "Parser" "parse error"
happyError tks = error $ "Parser: " ++ show tks
}

54
src/printf/printf.conf.in.cpp
View File

@ -1,54 +0,0 @@
#if CABAL == 0 && GLASGOW_HASKELL < 604
Package {
name = "printf",
auto = False,
hs_libraries = [ "HSprintf" ],
#ifdef INSTALLING
import_dirs = [ "${LIBDIR}/imports" ],
library_dirs = [ "${LIBDIR}/" ],
#else
import_dirs = [ "${TOP}/src/printf" ],
library_dirs = [ "${TOP}/src/printf" ],
#endif
include_dirs = [],
c_includes = [],
source_dirs = [],
extra_libraries = [],
package_deps = [ "eval" ],
extra_ghc_opts = [],
extra_cc_opts = [],
extra_ld_opts = []
}
#else
name: printf
version: 0.9.8
license: LGPL
maintainer: dons@cse.unsw.edu.au
exposed: False
exposed-modules:
Printf.Compile,
Printf.Lexer,
Printf.Parser,
Printf
hidden-modules:
#ifdef INSTALLING
import-dirs: LIBDIR/imports
library-dirs: LIBDIR
#else
import-dirs: TOP/src/printf
library-dirs: TOP/src/printf
#endif
hs-libraries: HSprintf
extra-libraries:
include-dirs:
includes:
depends: eval
hugs-options:
cc-options:
ld-options:
framework-dirs:
frameworks:
haddock-interfaces:
haddock-html:
#endif