├── LICENSE ├── testsuite ├── tests │ └── liskell │ │ ├── toplevel │ │ ├── Class.stdout │ │ ├── Data.stdout │ │ ├── NewType.stdout │ │ ├── Test01.lsk │ │ ├── Test01.stderr │ │ ├── Test02Dep.lsk │ │ ├── Test02.lsk │ │ ├── test02.comp.stderr │ │ ├── Test02.stderr │ │ ├── Test02.stderr.normalised │ │ ├── Data.lsk │ │ ├── Class.hs │ │ ├── NewType.lsk │ │ ├── Class.lsk │ │ └── TopLevel.T │ │ ├── parser │ │ └── ParseError.lsk │ │ ├── testprogs │ │ ├── Bezier.stdout │ │ ├── Factorial.stdout │ │ ├── Star.stdout │ │ ├── Factorial.lsk │ │ ├── TestProgs.T │ │ ├── Star.lsk │ │ ├── Bezier.lsk │ │ └── TicTacToe.lsk │ │ ├── metaprogramming │ │ ├── Data.comp.stderr │ │ ├── AvgTest.comp.stderr │ │ ├── OrigName.comp.stderr │ │ ├── Metaprogramming.T │ │ ├── Defmacro.comp.stderr │ │ ├── NopDispatcher.comp.stderr │ │ ├── AvgmTest.lsk │ │ ├── Defdispatcher.comp.stderr │ │ ├── stage-free.lsk │ │ ├── basic.lsk │ │ ├── DefmacroTest.lsk │ │ ├── NopDispatcher.lsk │ │ ├── Avgm.lsk │ │ ├── Avgm.stderr │ │ ├── AvgmTest.stderr │ │ ├── Backquote.stderr │ │ ├── Defmacro.stderr │ │ ├── Defdispatcher.stderr │ │ ├── DefmacroTest.comp.stderr │ │ ├── Bang.stderr │ │ ├── Bang.stderr.normalised │ │ ├── Avgm.comp.stderr │ │ ├── BqTest.lsk │ │ ├── Defptfun.lsk │ │ ├── AvgmTest.comp.stderr │ │ ├── Cond.lsk │ │ ├── Backquote.comp.stderr │ │ ├── Defdispatcher.lsk │ │ ├── Defmacro.lsk │ │ ├── Bang.lsk │ │ └── Backquote.lsk │ │ ├── Makefile │ │ ├── exprs │ │ ├── exprforms.stderr │ │ ├── Exprs.T │ │ └── exprforms.lsk │ │ ├── patterns │ │ ├── patternforms.stderr │ │ ├── Patterns.T │ │ └── patternforms.lsk │ │ └── types │ │ ├── Types.T │ │ ├── TypeForms.stderr │ │ └── TypeForms.lsk ├── mk │ ├── target.mk │ ├── wordsize.mk.in │ ├── boilerplate.mk │ ├── wordsize.mk │ └── test.mk ├── timeout │ ├── TimeMe.hs │ ├── calibrate │ ├── Makefile │ ├── timeout.py │ └── timeout.hs ├── Makefile ├── config │ ├── hugs │ └── ghc ├── driver │ ├── testutil.py │ ├── runtests.py │ └── testglobals.py ├── .darcs-boring └── README ├── Setup.lhs ├── LskTransformationMonad.hs-boot ├── Liskell.hs ├── GHCSalat ├── HsVersions4Lsk.h ├── GHC4Lsk.hs-boot ├── TcRnDriver4Lsk.hs ├── GhciMonad.hs └── HscMain4Lsk.hs ├── LskPrelude ├── package.conf.in ├── Makefile └── LskPrelude.lsk ├── GHCAPICompat.hs ├── LskNames.hs ├── ghc_boot_platform.h ├── ReadRationalS.hs ├── liskell.cabal ├── ParseLiskell.y ├── LskFileHandler.hs ├── HsVersions.h ├── LexLiskell.x ├── LskInteractiveEval.hs ├── LskTransformationMonad.hs ├── LskParseTree.hs ├── LskMain.hs └── Main.hs /LICENSE: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/toplevel/Class.stdout: -------------------------------------------------------------------------------- 1 | "0" 2 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/toplevel/Data.stdout: -------------------------------------------------------------------------------- 1 | 12 2 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/toplevel/NewType.stdout: -------------------------------------------------------------------------------- 1 | 4711 2 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/parser/ParseError.lsk: -------------------------------------------------------------------------------- 1 | (defmodule)) 2 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/testprogs/Bezier.stdout: -------------------------------------------------------------------------------- 1 | "602798.3" 2 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/testprogs/Factorial.stdout: -------------------------------------------------------------------------------- 1 | 479001600 2 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/testprogs/Star.stdout: -------------------------------------------------------------------------------- 1 | "[True,False]" 2 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/Data.comp.stderr: -------------------------------------------------------------------------------- 1 | ghc-6.7: does not exist: Data.lsk 2 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env runhaskell 2 | 3 | > import Distribution.Simple 4 | > main = defaultMain 5 | -------------------------------------------------------------------------------- /testsuite/mk/target.mk: -------------------------------------------------------------------------------- 1 | #TOP:=$(TOP)/.. 2 | #include $(TOP)/mk/target.mk 3 | #TOP:=$(TESTSUITE_TOP) 4 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/AvgTest.comp.stderr: -------------------------------------------------------------------------------- 1 | ghc-6.7: does not exist: AvgTest.lsk 2 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/OrigName.comp.stderr: -------------------------------------------------------------------------------- 1 | ghc-6.7: does not exist: OrigName.lsk 2 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/Makefile: -------------------------------------------------------------------------------- 1 | TOP=../.. 2 | include $(TOP)/mk/boilerplate.mk 3 | include $(TOP)/mk/test.mk 4 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/toplevel/Test01.lsk: -------------------------------------------------------------------------------- 1 | (defmodule Main _ (Prelude)) 2 | 3 | (define main undefined) 4 | -------------------------------------------------------------------------------- /testsuite/mk/wordsize.mk.in: -------------------------------------------------------------------------------- 1 | 2 | #include "../../includes/MachDeps.h" 3 | 4 | WORDSIZE = WORD_SIZE_IN_BITS 5 | 6 | -------------------------------------------------------------------------------- /testsuite/timeout/TimeMe.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main (main) where 3 | 4 | import System.IO 5 | 6 | main = hPutStr stderr "" 7 | 8 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/toplevel/Test01.stderr: -------------------------------------------------------------------------------- 1 | [1 of 1] Compiling Main ( Test01.lsk, Test01.o ) 2 | Linking Test01 ... 3 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/exprs/exprforms.stderr: -------------------------------------------------------------------------------- 1 | [1 of 1] Compiling Main ( exprforms.lsk, exprforms.o ) 2 | Linking exprforms ... 3 | -------------------------------------------------------------------------------- /testsuite/mk/boilerplate.mk: -------------------------------------------------------------------------------- 1 | TESTSUITE_TOP := $(TOP) 2 | TOP:=$(TOP)/.. 3 | 4 | #include $(TOP)/mk/boilerplate.mk 5 | 6 | TOP:=$(TESTSUITE_TOP) 7 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/patterns/patternforms.stderr: -------------------------------------------------------------------------------- 1 | [1 of 1] Compiling Main ( patternforms.lsk, patternforms.o ) 2 | Linking patternforms ... 3 | -------------------------------------------------------------------------------- /LskTransformationMonad.hs-boot: -------------------------------------------------------------------------------- 1 | module LskTransformationMonad where 2 | 3 | data LskEnvironment 4 | data TransformationError 5 | data TransformationMonad a 6 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/toplevel/Test02Dep.lsk: -------------------------------------------------------------------------------- 1 | ; Dependency target for Test02 2 | 3 | (defmodule Test02Dep _ (Prelude)) 4 | 5 | (define foobar undefined) 6 | 7 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/exprs/Exprs.T: -------------------------------------------------------------------------------- 1 | def f(opts): 2 | opts.liskell = 1 3 | 4 | setTestOpts(f) 5 | 6 | test('exprforms', normal, multimod_compile, ['exprforms','']) 7 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/toplevel/Test02.lsk: -------------------------------------------------------------------------------- 1 | ;; Dependency tracking test for GHC 2 | 3 | (defmodule Test02 _ (Prelude Test02Dep)) 4 | 5 | (define main undefined) 6 | 7 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/types/Types.T: -------------------------------------------------------------------------------- 1 | def f(opts): 2 | opts.liskell = 1 3 | 4 | setTestOpts(f) 5 | 6 | test('TypeForms', normal, multimod_compile, ['TypeForms','']) 7 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/toplevel/test02.comp.stderr: -------------------------------------------------------------------------------- 1 | 2 | : 3 | Could not find module `test02': 4 | Use -v to see a list of the files searched for. 5 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/Metaprogramming.T: -------------------------------------------------------------------------------- 1 | def f(opts): 2 | opts.liskell = 1 3 | 4 | setTestOpts(f) 5 | 6 | test('Bang', normal, multimod_compile, ['Bang','']) 7 | 8 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/Defmacro.comp.stderr: -------------------------------------------------------------------------------- 1 | 2 | Defmacro.lsk:1:43: 3 | Failed to load interface for `Quote': 4 | Use -v to see a list of the files searched for. 5 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/NopDispatcher.comp.stderr: -------------------------------------------------------------------------------- 1 | 2 | NopDispatcher.lsk:1:79: 3 | Failed to load interface for `Quote': 4 | Use -v to see a list of the files searched for. 5 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/toplevel/Test02.stderr: -------------------------------------------------------------------------------- 1 | [1 of 2] Compiling Test02Dep ( Test02Dep.lsk, Test02Dep.o ) 2 | [2 of 2] Compiling Test02 ( Test02.lsk, Test02.o ) 3 | Linking Test02 ... 4 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/patterns/Patterns.T: -------------------------------------------------------------------------------- 1 | def f(opts): 2 | opts.liskell = 1 3 | 4 | setTestOpts(f) 5 | 6 | test('patternforms', normal, multimod_compile, ['patternforms','']) 7 | 8 | 9 | 10 | 11 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/toplevel/Test02.stderr.normalised: -------------------------------------------------------------------------------- 1 | [1 of 2] Compiling Test02Dep ( Test02Dep.lsk, Test02Dep.o ) 2 | [2 of 2] Compiling Test02 ( Test02.lsk, Test02.o ) 3 | Linking Test02 ... 4 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/types/TypeForms.stderr: -------------------------------------------------------------------------------- 1 | [1 of 1] Compiling TypeForms ( TypeForms.lsk, TypeForms.o ) 2 | Warning: output was redirected with -o, but no output will be generated 3 | because there is no Main module. 4 | -------------------------------------------------------------------------------- /testsuite/Makefile: -------------------------------------------------------------------------------- 1 | TOP = . 2 | include $(TOP)/mk/boilerplate.mk 3 | 4 | SUBDIRS = timeout 5 | 6 | CLEAN_FILES += mk/wordsize.mk 7 | 8 | all :: 9 | cd tests/liskell && $(MAKE) $(MFLAGS) 10 | 11 | include $(TOP)/mk/target.mk 12 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/AvgmTest.lsk: -------------------------------------------------------------------------------- 1 | (defmodule AvgmTest _ (Liskell Avgm)) 2 | 3 | (defenv (lambda ((LskEnv e p t d)) (return (LskEnv (avgm-dspr trf_expr e) p t d)))) 4 | 5 | (define main 6 | (print (avgm 1 3 4 5 8))) 7 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/Defdispatcher.comp.stderr: -------------------------------------------------------------------------------- 1 | 2 | Defdispatcher.lsk:2:27: Module `LskToHs' does not export `main' 3 | 4 | Defdispatcher.lsk:7:3: 5 | Failed to load interface for `Quote': 6 | Use -v to see a list of the files searched for. 7 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/toplevel/Data.lsk: -------------------------------------------------------------------------------- 1 | (defmodule Data _ ()) 2 | 3 | (defdata (MEither a b) 4 | (MLeft a) 5 | (MRight b)) 6 | 7 | (define (mkLeft a) 8 | (MLeft a)) 9 | 10 | (define main 11 | (let (((MLeft a) (mkLeft 12))) 12 | (print a))) 13 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/toplevel/Class.hs: -------------------------------------------------------------------------------- 1 | module Class where 2 | 3 | class Bar a where 4 | kuh :: a -> Int 5 | 6 | data Tree a = Leaf a 7 | | Branch (Tree a) (Tree a) 8 | 9 | type Lala = Char 10 | 11 | instance Bar Lala where 12 | kuh a = 1 13 | 14 | main = print (kuh "a") -------------------------------------------------------------------------------- /Liskell.hs: -------------------------------------------------------------------------------- 1 | module Liskell ( 2 | module LskTransformationMonad, 3 | module LexLiskell, 4 | module LskParseTree, 5 | module ParseLiskell, 6 | noSrcSpan 7 | ) where 8 | 9 | import LskTransformationMonad 10 | import LskParseTree 11 | import LexLiskell 12 | import ParseLiskell 13 | import SrcLoc 14 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/stage-free.lsk: -------------------------------------------------------------------------------- 1 | (defmodule NopDispatcher _ (LskToHs SrcLoc LskParseTree LskTransformationMonad Quote)) 2 | 3 | (define (nop-dispatcher k pt) 4 | (k pt)) 5 | 6 | (defenv (lambda ((LskEnv e p t d)) (return (LskEnv (nop-dispatcher e) p t d)))) 7 | 8 | (define k 12) 9 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/basic.lsk: -------------------------------------------------------------------------------- 1 | (defmodule Meta1 _ (SrcLoc LskParseTree LskTransformationMonad HsSyn RdrName 2 | Cond)) 3 | 4 | (macrolet (lambda ((LskEnv e p t d)) (LskEnv (backquote-dispatcher e) p t d)) 5 | (define main 6 | (print (let ((char #\a)) 7 | (show (bq ,char)))))) -------------------------------------------------------------------------------- /testsuite/tests/liskell/testprogs/Factorial.lsk: -------------------------------------------------------------------------------- 1 | ;;;; This is the first Liskell program ever. 2 | 3 | (defmodule Main 4 | (main) ()) 5 | 6 | (define (fact n) 7 | (case (== n 0) 8 | ((True) 1) 9 | (False (* n (Main.fact (- n 1)))))) 10 | 11 | (define (main) 12 | (print (fact 12))) 13 | 14 | 15 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/toplevel/NewType.lsk: -------------------------------------------------------------------------------- 1 | (defmodule NewType _ ()) 2 | 3 | (defnewtype Natural (MakeNatural Int)) 4 | 5 | (define (toNatural x) 6 | (if (< x 0) 7 | (error "Can't create negative naturals!") 8 | (MakeNatural x))) 9 | 10 | 11 | (define (fromNatural (MakeNatural i)) 12 | i) 13 | 14 | (define main 15 | (print (fromNatural (toNatural 4711)))) 16 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/DefmacroTest.lsk: -------------------------------------------------------------------------------- 1 | (defmodule DefmacroTest _ (LskParseTree SrcLoc Quote Backquote Defdispatcher LskTransformationMonad Defmacro Defdispatcher)) 2 | 3 | (defenv (lambda ((LskEnv e p t d)) (LskEnv (backquote-dispatcher (quote-dispatcher e)) p t (defmacro-dispatcher (defhead-dispatcher-dispatcher d))))) 4 | 5 | (defmacro (avgm pts) 6 | (let ((wrapped `([] ,pts))) 7 | `(/ (sum ,wrapped) 8 | ,(length pts)))) 9 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/NopDispatcher.lsk: -------------------------------------------------------------------------------- 1 | (defmodule NopDispatcher _ (LskToHs SrcLoc LskParseTree LskTransformationMonad Quote)) 2 | 3 | (define (nop-dispatcher k pt) 4 | (if (== pt (PSym noSrcSpan "x" "")) 5 | (k (PSym noSrcSpan "y" "")) 6 | (k pt))) 7 | 8 | (defenv (lambda ((LskEnv e p t d)) (return (LskEnv (nop-dispatcher e) p t d)))) 9 | 10 | (define y 12) 11 | (define foo x) 12 | (define main 13 | (print foo)) 14 | -------------------------------------------------------------------------------- /GHCSalat/HsVersions4Lsk.h: -------------------------------------------------------------------------------- 1 | #define ASSERT(e) if (not (e)) then (assertPanic __FILE__ __LINE__) else 2 | #define ASSERT2(e,msg) if False && (const False (e,msg)) then pprPanic "ASSERT2" (msg) else 3 | #if !defined(GHCI) 4 | #define GHCI 5 | #endif 6 | 7 | #define GLOBAL_VAR(name,value,ty) \ 8 | {-# NOINLINE name #-}; \ 9 | name :: IORef (ty); \ 10 | name = Util.global (value); 11 | 12 | 13 | #include 14 | 15 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/Avgm.lsk: -------------------------------------------------------------------------------- 1 | (defmodule Avgm _ (Liskell LskPrelude)) 2 | 3 | (defenv (lambda ((LskEnv e p t d)) 4 | (return (LskEnv (backquote-dspr trf_expr e) p t (defmacro-dspr trf_decl (def-hdspr-dsprs trf_decl d)))))) 5 | 6 | ;; Naive average 7 | ;; (define (avg lst) 8 | ;; (/ (sum lst) (length lst))) 9 | ;; Improved avg macro, compile-time list traversal 10 | 11 | (defmacro (avgm pts) 12 | `(/ (sum ([] ,@pts)) 13 | ,(length pts))) 14 | -------------------------------------------------------------------------------- /testsuite/timeout/calibrate: -------------------------------------------------------------------------------- 1 | #!/usr/bin/python 2 | 3 | import math 4 | import os 5 | from os import * 6 | from sys import * 7 | from resource import * 8 | 9 | compiler = argv[1] 10 | compiler_name = os.path.basename(compiler) 11 | 12 | spawnl(os.P_WAIT, compiler, 13 | compiler_name, 'TimeMe.hs', '-o', 'TimeMe', '-O2') 14 | spawnl(os.P_WAIT, './TimeMe', 'TimeMe') 15 | 16 | xs = getrusage(RUSAGE_CHILDREN); 17 | print (300*int(math.ceil(xs[0] + xs[1]))) 18 | 19 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/toplevel/Class.lsk: -------------------------------------------------------------------------------- 1 | (defmodule Class _ ()) 2 | 3 | (defclass (Bar a) 4 | (kuh (-> a Int))) 5 | (defdata (Tree a) (Leaf a) (Branch (Tree a) (Tree a))) 6 | 7 | (definstance (=> (Eq a) (Eq (Tree a))) 8 | ((== (Leaf a) (Leaf b)) 9 | (== a b))) 10 | 11 | (defnewtype CharTree (CharTree (Tree Char))) 12 | 13 | (definstance (Bar CharTree) 14 | ((kuh (CharTree _)) 15 | 0)) 16 | 17 | (define main 18 | (print (show (kuh (CharTree (Leaf #\a)))))) 19 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/toplevel/TopLevel.T: -------------------------------------------------------------------------------- 1 | def f(opts): 2 | opts.liskell = 1 3 | 4 | setTestOpts(f) 5 | 6 | test('Test01', normal, multimod_compile, ['Test01','']) 7 | test('Test02', normal, multimod_compile, ['Test02','-main-is Test02']) 8 | 9 | 10 | test('NewType', normal, multimod_compile_and_run, ['NewType','-main-is NewType']) 11 | test('Data', normal, multimod_compile_and_run, ['Data','-main-is Data']) 12 | test('Class', normal, multimod_compile_and_run, ['Class','-main-is Class']) 13 | 14 | 15 | 16 | -------------------------------------------------------------------------------- /testsuite/config/hugs: -------------------------------------------------------------------------------- 1 | # Testsuite configuration setup for Hugs 2 | # 3 | # This file is Python source 4 | # 5 | config.compiler_type = 'hugs' 6 | config.compiler = 'hugs-hc' 7 | config.compiler_always_flags = [] 8 | 9 | # We test the 'normal' way only 10 | config.compile_ways = ['normal'] 11 | config.run_ways = ['normal'] 12 | 13 | # No other ways for Hugs 14 | config.other_ways = [] 15 | 16 | config.way_flags = { 'normal' : [] } 17 | config.way_rts_flags = { 'normal' : [] } 18 | -------------------------------------------------------------------------------- /LskPrelude/package.conf.in: -------------------------------------------------------------------------------- 1 | name: PACKAGE 2 | version: VERSION 3 | license: BSD3 4 | maintainer: clemens@endorphin.org 5 | exposed: True 6 | 7 | exposed-modules: 8 | LskPrelude 9 | 10 | hidden-modules: 11 | 12 | import-dirs: IMPORT_DIR 13 | library-dirs: LIB_DIR 14 | hs-libraries: "HSLskPrelude" 15 | extra-libraries: 16 | include-dirs: 17 | includes: 18 | depends: DEPENDS 19 | hugs-options: 20 | cc-options: 21 | ld-options: 22 | framework-dirs: 23 | frameworks: 24 | haddock-interfaces: HADDOCK_IFACE 25 | haddock-html: HTML_DIR 26 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/Avgm.stderr: -------------------------------------------------------------------------------- 1 | Loading package base ... linking ... done. 2 | Loading package template-haskell ... linking ... done. 3 | Loading package readline-1.0 ... linking ... done. 4 | Loading package unix-1.0 ... linking ... done. 5 | Loading package Cabal-1.1.7 ... linking ... done. 6 | Loading package regex-base-0.71 ... linking ... done. 7 | Loading package regex-posix-0.71 ... linking ... done. 8 | Loading package regex-compat-0.71 ... linking ... done. 9 | Loading package haskell98 ... linking ... done. 10 | Loading package ghc-6.7 ... linking ... done. 11 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/AvgmTest.stderr: -------------------------------------------------------------------------------- 1 | Loading package base ... linking ... done. 2 | Loading package template-haskell ... linking ... done. 3 | Loading package readline-1.0 ... linking ... done. 4 | Loading package unix-1.0 ... linking ... done. 5 | Loading package Cabal-1.1.7 ... linking ... done. 6 | Loading package regex-base-0.71 ... linking ... done. 7 | Loading package regex-posix-0.71 ... linking ... done. 8 | Loading package regex-compat-0.71 ... linking ... done. 9 | Loading package haskell98 ... linking ... done. 10 | Loading package ghc-6.7 ... linking ... done. 11 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/Backquote.stderr: -------------------------------------------------------------------------------- 1 | Loading package base ... linking ... done. 2 | Loading package template-haskell ... linking ... done. 3 | Loading package readline-1.0 ... linking ... done. 4 | Loading package unix-1.0 ... linking ... done. 5 | Loading package Cabal-1.1.7 ... linking ... done. 6 | Loading package regex-base-0.71 ... linking ... done. 7 | Loading package regex-posix-0.71 ... linking ... done. 8 | Loading package regex-compat-0.71 ... linking ... done. 9 | Loading package haskell98 ... linking ... done. 10 | Loading package ghc-6.7 ... linking ... done. 11 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/Defmacro.stderr: -------------------------------------------------------------------------------- 1 | Loading package base ... linking ... done. 2 | Loading package template-haskell ... linking ... done. 3 | Loading package readline-1.0 ... linking ... done. 4 | Loading package unix-1.0 ... linking ... done. 5 | Loading package Cabal-1.1.7 ... linking ... done. 6 | Loading package regex-base-0.71 ... linking ... done. 7 | Loading package regex-posix-0.71 ... linking ... done. 8 | Loading package regex-compat-0.71 ... linking ... done. 9 | Loading package haskell98 ... linking ... done. 10 | Loading package ghc-6.7 ... linking ... done. 11 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/Defdispatcher.stderr: -------------------------------------------------------------------------------- 1 | Loading package base ... linking ... done. 2 | Loading package template-haskell ... linking ... done. 3 | Loading package readline-1.0 ... linking ... done. 4 | Loading package unix-1.0 ... linking ... done. 5 | Loading package Cabal-1.1.7 ... linking ... done. 6 | Loading package regex-base-0.71 ... linking ... done. 7 | Loading package regex-posix-0.71 ... linking ... done. 8 | Loading package regex-compat-0.71 ... linking ... done. 9 | Loading package haskell98 ... linking ... done. 10 | Loading package ghc-6.7 ... linking ... done. 11 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/DefmacroTest.comp.stderr: -------------------------------------------------------------------------------- 1 | Loading package base ... linking ... done. 2 | Loading package template-haskell ... linking ... done. 3 | Loading package readline-1.0 ... linking ... done. 4 | Loading package unix-1.0 ... linking ... done. 5 | Loading package Cabal-1.1.7 ... linking ... done. 6 | Loading package regex-base-0.71 ... linking ... done. 7 | Loading package regex-posix-0.71 ... linking ... done. 8 | Loading package regex-compat-0.71 ... linking ... done. 9 | Loading package haskell98 ... linking ... done. 10 | Loading package ghc-6.7 ... linking ... done. 11 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/testprogs/TestProgs.T: -------------------------------------------------------------------------------- 1 | def f(opts): 2 | opts.liskell = 1 3 | 4 | setTestOpts(f) 5 | 6 | test('Factorial', normal, multimod_compile_and_run, ['Factorial','']) 7 | test('TicTacToe', normal, multimod_compile_and_run, ['TicTacToe','-main-is TicTacToe']) 8 | test('Star', normal, multimod_compile_and_run, ['Star','-main-is Star -package LskPrelude']) 9 | test('Bezier', extra_run_opts('macro'), multimod_compile_and_run, ['Bezier','-main-is Bezier -package LskPrelude']) 10 | test('Bezier', extra_run_opts('fun'), multimod_compile_and_run, ['Bezier','-main-is Bezier -package LskPrelude']) 11 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/Bang.stderr: -------------------------------------------------------------------------------- 1 | Loading package base ... linking ... done. 2 | Loading package haskell98 ... linking ... done. 3 | Loading package template-haskell ... linking ... done. 4 | Loading package Cabal-1.1.6.1 ... linking ... done. 5 | Loading package readline-1.0 ... linking ... done. 6 | Loading package unix-1.0 ... linking ... done. 7 | Loading package regex-base-0.71 ... linking ... done. 8 | Loading package regex-posix-0.71 ... linking ... done. 9 | Loading package regex-compat-0.71 ... linking ... done. 10 | Loading package ghc ... linking ... done. 11 | Loading package LskPrelude ... linking ... done. 12 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/Bang.stderr.normalised: -------------------------------------------------------------------------------- 1 | Loading package base ... linking ... done. 2 | Loading package haskell98 ... linking ... done. 3 | Loading package template-haskell ... linking ... done. 4 | Loading package Cabal-1.1.6.1 ... linking ... done. 5 | Loading package readline-1.0 ... linking ... done. 6 | Loading package unix-1.0 ... linking ... done. 7 | Loading package regex-base-0.71 ... linking ... done. 8 | Loading package regex-posix-0.71 ... linking ... done. 9 | Loading package regex-compat-0.71 ... linking ... done. 10 | Loading package ghc ... linking ... done. 11 | Loading package LskPrelude ... linking ... done. 12 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/patterns/patternforms.lsk: -------------------------------------------------------------------------------- 1 | (defmodule Main _ ()) 2 | 3 | (define main undefined) 4 | 5 | (define (primitivevars a b) undefined) 6 | ; 7 | (define (wildcard _) undefined) 8 | 9 | (define (singleConstructor True) undefined) 10 | 11 | (define (charLit #\a) undefined) 12 | 13 | (define (intLit 3) undefined) 14 | 15 | (define (ratLit 3.3) undefined) 16 | 17 | (define (stringLit "bar") 18 | (case (, "kuh" "bar") 19 | ((, "" "") undefined))) 20 | 21 | (define (moreConstructors (Just a) (Just b)) undefined) 22 | 23 | (define (asPat (@ asName (Just a))) undefined) 24 | 25 | (define (lazyPat (~ (: x xs))) undefined) 26 | -------------------------------------------------------------------------------- /testsuite/timeout/Makefile: -------------------------------------------------------------------------------- 1 | TOP = .. 2 | include $(TOP)/mk/boilerplate.mk 3 | 4 | HC = $(GHC_INPLACE) 5 | MKDEPENDHS = $(GHC_INPLACE) 6 | SRC_HC_OPTS += -threaded 7 | EXCLUDED_SRCS += TimeMe.hs 8 | 9 | ifeq "$(Windows)" "NO" 10 | SRC_HC_OPTS += -package unix 11 | endif 12 | 13 | HS_PROG = timeout 14 | 15 | boot :: calibrate.out 16 | 17 | ifeq "$(findstring thr,$(GhcRTSWays))" "thr" 18 | boot :: $(HS_PROG) 19 | else 20 | boot :: python-timeout 21 | endif 22 | 23 | calibrate.out: 24 | rm -f TimeMe.o TimeMe.hi TimeMe 25 | $(PYTHON) calibrate "$(HC)" > $@ 26 | 27 | python-timeout: 28 | cp timeout.py timeout 29 | chmod +x timeout 30 | 31 | include $(TOP)/mk/target.mk 32 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/Avgm.comp.stderr: -------------------------------------------------------------------------------- 1 | 2 | Avgm.lsk:4:20: Not in scope: `backquote-dspr' 3 | 4 | Avgm.lsk:4:76: Not in scope: `def-hdspr-dsprs' 5 | Loading package base ... linking ... done. 6 | Loading package template-haskell ... linking ... done. 7 | Loading package readline-1.0 ... linking ... done. 8 | Loading package unix-1.0 ... linking ... done. 9 | Loading package Cabal-1.1.7 ... linking ... done. 10 | Loading package regex-base-0.71 ... linking ... done. 11 | Loading package regex-posix-0.71 ... linking ... done. 12 | Loading package regex-compat-0.71 ... linking ... done. 13 | Loading package haskell98 ... linking ... done. 14 | Loading package ghc-6.7 ... linking ... done. 15 | -------------------------------------------------------------------------------- /testsuite/driver/testutil.py: -------------------------------------------------------------------------------- 1 | # ----------------------------------------------------------------------------- 2 | # Utils 3 | 4 | def eq(x): 5 | return lambda y,z=x: y == z 6 | 7 | def neq(x): 8 | return lambda y,z=x: y != z 9 | 10 | def append(x,y): 11 | return x + y 12 | 13 | def concat(xs): 14 | return reduce(append,xs,[]) 15 | 16 | def chop(s): 17 | if s[len(s)-1:] == '\n': 18 | return s[:len(s)-1] 19 | else: 20 | return s 21 | 22 | def all(p,xs): 23 | for x in xs: 24 | if not p(x): 25 | return False 26 | return True 27 | 28 | def elem(xs): 29 | return lambda x: x in xs 30 | 31 | def notElem(xs): 32 | return lambda x: x not in xs 33 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/testprogs/Star.lsk: -------------------------------------------------------------------------------- 1 | (defmodule Star _ (LskPrelude Liskell)) 2 | 3 | (defenv (lambda ((LskEnv e p t d)) 4 | (return (LskEnv (dspr-namespace-dspr e) p t (define-dspr-dspr d))))) 5 | (defenv (lambda ((LskEnv e p t d)) 6 | (return (LskEnv e p t (d(add-dspr) d))))) 7 | 8 | (add-dspr (declaration defmacros) 9 | (declaration def-hdsprs) 10 | (expression backquote)) 11 | 12 | (defmacro (~= pts) 13 | `(let (((comp ,pts) True) 14 | ((comp _) False)) 15 | comp)) 16 | 17 | (add-dspr (expression ~=)) 18 | 19 | (defdata Star 20 | (Atom) 21 | (Star String)) 22 | 23 | (define main 24 | (print (show ([] (all (~= Star _) ([] (Star "x") (Star "foobar"))) 25 | (all (~= Star _) ([] (Atom) (Star "x"))))))) -------------------------------------------------------------------------------- /testsuite/tests/liskell/types/TypeForms.lsk: -------------------------------------------------------------------------------- 1 | (defmodule TypeForms _ ()) 2 | 3 | (define main undefined) 4 | 5 | (define regularTyApp undefined (Either Int Char)) 6 | 7 | (define funType undefined 8 | (-> Int Bool Char)) 9 | 10 | (define contextedType undefined 11 | (=> ((Show a) (Num a)) 12 | (-> a String))) 13 | 14 | (define contextedTypeAutoWrapped undefined 15 | (=> (Show a) 16 | (-> a String))) 17 | 18 | (define listType undefined 19 | ([] Int)) 20 | 21 | (define nullarytupType undefined 22 | (,)) 23 | 24 | (define twotup undefined 25 | (, Int Bool)) 26 | 27 | (define nonstandardapp undefined 28 | (app Either Int Bool)) 29 | 30 | (defwithsig 31 | (myid a) 32 | (-> a a) 33 | a) 34 | 35 | ;(defdata Foo ()) - Bang Type missing -------------------------------------------------------------------------------- /GHCAPICompat.hs: -------------------------------------------------------------------------------- 1 | -- -*-haskell-*- 2 | -- --------------------------------------------------------------------------- 3 | -- Liskell 4 | -- 5 | -- Author(s): 6 | -- --------------------------------------------------------------------------- 7 | 8 | module GHCAPICompat where 9 | 10 | import HsSyn 11 | import RdrHsSyn 12 | cHsModule a b c d e = HsModule a b c d e emptyHaddockModInfo Nothing 13 | cmkClassDecl a b c d = mkClassDecl a b c d [] [] 14 | ccvBindsAndSigs x = let (binds, sigs, _, _ ) = cvBindsAndSigs x 15 | in (binds, sigs) 16 | 17 | cConDecl a b c d e f = ConDecl a b c d e f Nothing 18 | cTySynonym a b c = TySynonym a b Nothing c 19 | cmkTyData a (b, c, d) e f g = mkTyData a (b, c, d, Nothing) e f g 20 | cInstDecl a b c = InstDecl a b c 21 | -------------------------------------------------------------------------------- /testsuite/.darcs-boring: -------------------------------------------------------------------------------- 1 | # Boring file regexps: 2 | \.hi$ 3 | \.o$ 4 | \.p_hi$ 5 | \.p_o$ 6 | \.a$ 7 | \.o\.cmd$ 8 | \.ko$ 9 | \.ko\.cmd$ 10 | \.mod\.c$ 11 | (^|/)\.tmp_versions($|/) 12 | (^|/)CVS($|/) 13 | (^|/)RCS($|/) 14 | ~$ 15 | #(^|/)\.[^/] 16 | (^|/)_darcs($|/) 17 | \.bak$ 18 | \.BAK$ 19 | \.orig$ 20 | (^|/)vssver\.scc$ 21 | \.swp$ 22 | (^|/)MT($|/) 23 | (^|/)\{arch\}($|/) 24 | (^|/).arch-ids($|/) 25 | (^|/), 26 | \.class$ 27 | \.prof$ 28 | (^|/)\.DS_Store$ 29 | (^|/)BitKeeper($|/) 30 | (^|/)ChangeSet($|/) 31 | (^|/)\.svn($|/) 32 | \.py[co]$ 33 | \# 34 | \.cvsignore$ 35 | (^|/)Thumbs\.db$ 36 | \.comp\.stderr$ 37 | \.interp\.stdout$ 38 | \.interp\.stderr$ 39 | \.run\.stdout$ 40 | \.run\.stderr$ 41 | \.out$ 42 | \.out[12]$ 43 | \.inout$ 44 | \.hc$ 45 | [0-9][0-9][0-9]$ 46 | _stub.[hc]$ 47 | -------------------------------------------------------------------------------- /testsuite/timeout/timeout.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/python 2 | 3 | import os 4 | import signal 5 | import sys 6 | 7 | secs = int(sys.argv[1]) 8 | cmd = sys.argv[2] 9 | 10 | pid = os.fork() 11 | # XXX error checking 12 | if pid == 0: 13 | # child 14 | os.setpgrp() 15 | os.execvp('/bin/sh', ['/bin/sh', '-c', cmd]) 16 | else: 17 | # parent 18 | def handler(signum, frame): 19 | sys.stderr.write('Timeout happened...killing process...\n') 20 | os.killpg(pid, signal.SIGKILL) # XXX Kill better like .hs 21 | sys.exit(99) 22 | old = signal.signal(signal.SIGALRM, handler) 23 | signal.alarm(secs) 24 | (pid2, res) = os.waitpid(pid, 0) 25 | if (os.WIFEXITED(res)): 26 | sys.exit(os.WEXITSTATUS(res)) 27 | else: 28 | sys.exit(res) 29 | 30 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/BqTest.lsk: -------------------------------------------------------------------------------- 1 | (defmodule BqTest _ (Liskell LskPrelude Debug.Trace)) 2 | 3 | (defenv (lambda ((LskEnv e p t d)) 4 | (return (LskEnv (backquote-dspr 5 | (sParseTree-e-dspr (cond-dspr (simple-list-dspr e)))) 6 | (sParseTree-p-dspr (simple-list-dspr p)) 7 | t 8 | (def-hdspr-dsprs 9 | (defmacro-dspr (infix-to-multi-prefix-dspr d))))))) 10 | (defenv (lambda ((LskEnv e p t d)) 11 | (return (LskEnv 12 | e p 13 | t (infix-to-multi-prefix-dspr d))))) 14 | 15 | (define x `(1 2 3 4)) 16 | (define foo `(a ,@(let ((a `(1 2 3 4))) 17 | a) c)) 18 | 19 | (infix-to-multi-prefix + left) 20 | 21 | (defenv (lambda ((LskEnv e p t d)) 22 | (return (LskEnv (+-dspr e) 23 | p t d)))) 24 | 25 | (define main (putStrLn (show (+* 1 2 3 4 5 6)))) 26 | -------------------------------------------------------------------------------- /LskNames.hs: -------------------------------------------------------------------------------- 1 | module LskNames where 2 | 3 | #include "HsVersions.h" 4 | 5 | import PackageConfig 6 | import Unique ( Unique, Uniquable(..), 7 | mkPreludeTyConUnique ) 8 | import Module ( Module, ModuleName, mkModule, mkModuleNameFS ) 9 | import OccName ( dataName, tcName, clsName, varName, mkOccNameFS, 10 | mkVarOccFS ) 11 | import SrcLoc ( noSrcLoc ) 12 | import Name ( mkExternalName ) 13 | 14 | liskellNames = [ lskEnvironmentTransformerTyCon ] 15 | 16 | lSK_TRANSFORMATIONMONAD = mkModule ghcPackageId (mkModuleNameFS FSLIT("LskTransformationMonad")) 17 | lskEnvironmentTransformerKey = mkPreludeTyConUnique 127 -- FIXME 18 | lskEnvironmentTransformerTyCon = mkExternalName lskEnvironmentTransformerKey lSK_TRANSFORMATIONMONAD 19 | (mkOccNameFS tcName FSLIT("LskEnvironmentTransformer")) 20 | Nothing noSrcLoc 21 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/Defptfun.lsk: -------------------------------------------------------------------------------- 1 | (defmodule Defmacro _ (Defdispatcher)) 2 | 3 | (defenv (lambda ((LskEnv e p t d)) (LskEnv e p t (defhead-dispatcher-dispatcher d)))) 4 | 5 | ;(define (defpfun-fun pt) 6 | ; (case pt 7 | ; (([] (: funname args) expr) ; this should be called in the form (defpfun (name args..) expr). (name args..) expr is given as pt. 8 | ; (let ((selectors (map (bq )))) 9 | ; ([] (` define (,funname pt) 10 | ; ((lambda ,args 11 | ; ,expr) 12 | ; ,@selectors)))))) ; return two function declarations. first 13 | ; ))) 14 | 15 | (define (defmacro-fun ([] funhead 16 | expr)) 17 | (let ((dispatcher-name 'kar) 18 | (dispatch-on (head funhead))) 19 | ([] `(define ,funhead ,expr) 20 | `(defhead-dispatch ,dispatcher-name 21 | ,dispatch-on 22 | ,dispatch-on))))) 23 | 24 | (defheadm-dispatch 25 | 'defmacro 26 | 'defmacro-fun 27 | 'defmacro-dispatcher) -------------------------------------------------------------------------------- /ghc_boot_platform.h: -------------------------------------------------------------------------------- 1 | #ifndef __PLATFORM_H__ 2 | #define __PLATFORM_H__ 3 | 4 | #define BuildPlatform_NAME "x86_64-unknown-linux" 5 | #define HostPlatform_NAME "x86_64-unknown-linux" 6 | #define TargetPlatform_NAME "x86_64-unknown-linux" 7 | 8 | #define x86_64_unknown_linux_BUILD 1 9 | #define x86_64_unknown_linux_HOST 1 10 | #define x86_64_unknown_linux_TARGET 1 11 | 12 | #define x86_64_BUILD_ARCH 1 13 | #define x86_64_HOST_ARCH 1 14 | #define x86_64_TARGET_ARCH 1 15 | #define BUILD_ARCH "x86_64" 16 | #define HOST_ARCH "x86_64" 17 | #define TARGET_ARCH "x86_64" 18 | 19 | #define linux_BUILD_OS 1 20 | #define linux_HOST_OS 1 21 | #define linux_TARGET_OS 1 22 | #define BUILD_OS "linux" 23 | #define HOST_OS "linux" 24 | #define TARGET_OS "linux" 25 | 26 | #define unknown_BUILD_VENDOR 1 27 | #define unknown_HOST_VENDOR 1 28 | #define unknown_TARGET_VENDOR 1 29 | #define BUILD_VENDOR "unknown" 30 | #define HOST_VENDOR "unknown" 31 | #define TARGET_VENDOR "unknown" 32 | 33 | #endif /* __PLATFORM_H__ */ 34 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/AvgmTest.comp.stderr: -------------------------------------------------------------------------------- 1 | 2 | AvgmTest.lsk:3:71: 3 | Couldn't match expected type `TransformationMonad (HsExpr.LHsExpr RdrName.RdrName)' 4 | against inferred type `(ParseTree -> a) -> (ParseTree -> a) -> a' 5 | In the second argument of `avgm-dspr', namely `e' 6 | In the first argument of `LskEnv', namely `avgm-dspr trf_expr e' 7 | In the first argument of `return', namely 8 | `LskEnv (avgm-dspr trf_expr e) p t d' 9 | Loading package base ... linking ... done. 10 | Loading package template-haskell ... linking ... done. 11 | Loading package readline-1.0 ... linking ... done. 12 | Loading package unix-1.0 ... linking ... done. 13 | Loading package Cabal-1.1.7 ... linking ... done. 14 | Loading package regex-base-0.71 ... linking ... done. 15 | Loading package regex-posix-0.71 ... linking ... done. 16 | Loading package regex-compat-0.71 ... linking ... done. 17 | Loading package haskell98 ... linking ... done. 18 | Loading package ghc-6.7 ... linking ... done. 19 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/Cond.lsk: -------------------------------------------------------------------------------- 1 | (defmodule Cond _ (LskToHs SrcLoc LskParseTree LskTransformationMonad HsSyn RdrName)) 2 | 3 | (define (trf_cond capairs) 4 | (case capairs 5 | (([]) (PSym noSrcSpan "undefined" "")) ; no actions. return undefined. 6 | ((: (PList _ ([] cond action) (, "" "")) 7 | rest) 8 | (PList noSrcSpan ([] (PSym noSrcSpan "if" "") 9 | cond 10 | action 11 | (trf_cond rest)) 12 | (, "" ""))) 13 | (_ (error (show capairs))))) 14 | 15 | (defwithsig (cond-dspr kn pt ks kf) 16 | (-> (-> ParseTree 17 | (-> ParseTree a) 18 | (-> ParseTree a) 19 | a) 20 | ParseTree 21 | (-> ParseTree a) 22 | (-> ParseTree a) 23 | a) 24 | (case pt 25 | ((PList _ (: (PSym _ "cond" "") rest) (, "" "")) 26 | (ks (trf_cond rest))) 27 | (_ (kn pt ks kf)))) 28 | 29 | 30 | (defenv (lambda ((LskEnv e p t d)) 31 | (return (LskEnv (cond-dspr e) p t d)))) 32 | 33 | (define main 34 | (putStrLn (cond ((< 1 0) 35 | "1") 36 | (True 37 | "0")))) -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/Backquote.comp.stderr: -------------------------------------------------------------------------------- 1 | 2 | Backquote.lsk:17:58: 3 | Couldn't match expected type `TransformationMonad (HsExpr.LHsExpr RdrName.RdrName)' 4 | against inferred type `(ParseTree -> a) -> (ParseTree -> a) -> a' 5 | In the second argument of `backquote-dispatcher-on-syms', namely 6 | `e' 7 | In the first argument of `LskEnv', namely 8 | `backquote-dispatcher-on-syms trf_expr e' 9 | In the first argument of `return', namely 10 | `LskEnv (backquote-dispatcher-on-syms trf_expr e) p t d' 11 | Loading package base ... linking ... done. 12 | Loading package template-haskell ... linking ... done. 13 | Loading package readline-1.0 ... linking ... done. 14 | Loading package unix-1.0 ... linking ... done. 15 | Loading package Cabal-1.1.7 ... linking ... done. 16 | Loading package regex-base-0.71 ... linking ... done. 17 | Loading package regex-posix-0.71 ... linking ... done. 18 | Loading package regex-compat-0.71 ... linking ... done. 19 | Loading package haskell98 ... linking ... done. 20 | Loading package ghc-6.7 ... linking ... done. 21 | -------------------------------------------------------------------------------- /ReadRationalS.hs: -------------------------------------------------------------------------------- 1 | module ReadRationalS where 2 | import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit ) 3 | import Data.Ratio ( (%) ) 4 | 5 | readRationalS :: ReadS Rational -- NB: doesn't handle leading "-" 6 | readRationalS r = do 7 | (n,d,s) <- readFix r 8 | (k,t) <- readExp s 9 | return ((n%1)*10^^(k-d), t) 10 | where 11 | readFix r = do 12 | (ds,s) <- lexDecDigits r 13 | (ds',t) <- lexDotDigits s 14 | return (read (ds++ds'), length ds', t) 15 | 16 | readExp (e:s) | e `elem` "eE" = readExp' s 17 | readExp s = return (0,s) 18 | 19 | readExp' ('+':s) = readDec s 20 | readExp' ('-':s) = do (k,t) <- readDec s 21 | return (-k,t) 22 | readExp' s = readDec s 23 | 24 | readDec s = do 25 | (ds,r) <- nonnull isDigit s 26 | return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ], 27 | r) 28 | 29 | lexDecDigits = nonnull isDigit 30 | 31 | lexDotDigits ('.':s) = return (span isDigit s) 32 | lexDotDigits s = return ("",s) 33 | 34 | nonnull p s = do (cs@(_:_),t) <- return (span p s) 35 | return (cs,t) 36 | -------------------------------------------------------------------------------- /liskell.cabal: -------------------------------------------------------------------------------- 1 | Name: liskell 2 | Version: 0.1 3 | Copyright: Clemens Fruhwirth 4 | License: BSD3 5 | -- License-File: XXX 6 | Author: XXX 7 | Maintainer: clemens@endorphin.org 8 | Homepage: http://liskell.com 9 | Description: 10 | XXX 11 | Category: XXX 12 | Build-Type: Simple 13 | Cabal-Version: >= 1.2 14 | 15 | Flag base3 16 | Description: Choose the new smaller, split-up base package. 17 | 18 | Flag ghci 19 | Description: Build GHCi support. 20 | 21 | Executable liskell 22 | Main-Is: Main.hs 23 | other-modules: LexLiskell, ParseLiskell 24 | Build-Depends: base >= 3 && < 5, 25 | directory >= 1 && < 1.1 26 | Build-Depends: base, ghc, array, old-time, ghc-paths, process, bytestring, mtl, haskeline, unix 27 | Build-Depends: filepath >= 1 && < 1.2 28 | 29 | if flag(ghci) 30 | CPP-Options: -DGHCI 31 | Extensions: CPP, PatternGuards, RankNTypes, ScopedTypeVariables 32 | ghc-options: -w -fglasgow-exts 33 | 34 | library 35 | exposed-modules: Liskell, LexLiskell, LskParseTree, LskTransformationMonad, ParseLiskell, ReadRationalS 36 | Extensions: CPP, PatternGuards, RankNTypes, ScopedTypeVariables 37 | ghc-options: -w -fglasgow-exts 38 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/exprs/exprforms.lsk: -------------------------------------------------------------------------------- 1 | (defmodule Main _ ((LskPrelude))) 2 | 3 | (define main undefined) 4 | 5 | ; test all literals 6 | (define myint 30) 7 | (define myhexint 0x30) 8 | (define myoctnt 0o1237) 9 | 10 | (define mychar #\1) 11 | (define mydoublequote #\") 12 | (define mystring "adsada") 13 | (define myrational 4.2) 14 | 15 | ; test all atom symbol forms 16 | (define myvarref myint) 17 | (define mytrue True) 18 | 19 | ; nil checks 20 | (define nil ([])) 21 | (define [] ([])) 22 | (define mycons (: 1 nil)) 23 | (define mycons2 (: True nil)) 24 | (define mycons3 (: True [])) 25 | (define prelude-just Prelude.Just) 26 | 27 | (define regularapp (+ myint myint)) 28 | (define myid (lambda (x) x)) 29 | (define myadd (lambda (x y) 30 | (+ x y))) 31 | 32 | (define mycondition (if True 0 1)) 33 | (define mylist ([] 1 2 3)) 34 | 35 | (define mylet (let ((x mylist) 36 | ((somefun foo) (head foo))) 37 | (somefun x))) 38 | 39 | (define mycase (case (+ 2 3) 40 | (5 True) 41 | (_ False))) 42 | 43 | (define mycoerce (:: 4 Int)) 44 | 45 | (define nullarytup (,)) 46 | (define twotup (, 1 2)) 47 | 48 | (define enumTest (:: (enumFromThenTo 0 49 | (/ 1 (fromInteger (+ 1 10))) 50 | 1) 51 | ([] Float))) 52 | 53 | (define apptest (let (((lambda x) x)) 54 | (app lambda 12))) 55 | -------------------------------------------------------------------------------- /LskPrelude/Makefile: -------------------------------------------------------------------------------- 1 | PACKAGE=LskPrelude 2 | VERSION=0.1 3 | 4 | LskPrelude.o: 5 | liskell -package-name LskPrelude -package ghc -package liskell --make LskPrelude 6 | libHSLskPrelude.a: 7 | ar r libHSLskPrelude.a LskPrelude.o 8 | 9 | HSLskPrelude.o: 10 | ld -r -o HSLskPrelude.o LskPrelude.o 11 | 12 | .PHONY: install 13 | 14 | install-inplace: package.conf.inplace libHSLskPrelude.a HSLskPrelude.o 15 | ghc-pkg update package.conf.inplace 16 | 17 | PACKAGE_CPP_OPTS += -DPACKAGE=${PACKAGE} 18 | PACKAGE_CPP_OPTS += -DVERSION=${VERSION} 19 | 20 | IMPORT_DIR_INPLACE=${PWD} 21 | LIB_DIR_INPLACE=${PWD} 22 | 23 | DEPENDS += $(shell ghc-pkg latest ghc) 24 | DEPENDS += $(shell ghc-pkg latest base) 25 | 26 | package.conf.inplace : package.conf.in 27 | $(CPP) $(RAWCPP_FLAGS) -P \ 28 | -DIMPORT_DIR='"$(IMPORT_DIR_INPLACE)"' \ 29 | -DLIB_DIR='"$(LIB_DIR_INPLACE)"' \ 30 | -DINCLUDE_DIR='"$(INCLUDE_DIR_INPLACE)"' \ 31 | -DDATA_DIR='"$(DATA_DIR_INPLACE)"' \ 32 | -DHTML_DIR='"$(HTML_DIR_INPLACE)"' \ 33 | -DDEPENDS='$(DEPENDS)' \ 34 | -DHADDOCK_IFACE='"$(HADDOCK_IFACE_INPLACE)"' \ 35 | -DFPTOOLS_TOP_ABS='"${FPTOOLS_TOP_ABS}"' \ 36 | -x c $(PACKAGE_CPP_OPTS) $< | \ 37 | grep -v '^#pragma GCC' | \ 38 | sed -e 's/""//g' -e 's/:[ ]*,/: /g' >$@ 39 | 40 | clean: 41 | rm LskPrelude.hi LskPrelude.o libHSLskPrelude.a HSLskPrelude.o package.conf.inplace 42 | 43 | -------------------------------------------------------------------------------- /ParseLiskell.y: -------------------------------------------------------------------------------- 1 | { 2 | module ParseLiskell(parseLiskell,LiskellParserMonad(..)) where 3 | import LexLiskell 4 | import SrcLoc 5 | import FastString 6 | import StringBuffer 7 | import LskParseTree 8 | import ErrUtils ( Message ) 9 | import Outputable 10 | } 11 | 12 | %name parseLiskell Exps 13 | %tokentype { Token } 14 | %monad { LiskellParserMonad } { thenLPM } { returnLPM } 15 | %token 16 | '(' { TOParent _ _} 17 | ')' { TCParent _ _} 18 | sym { TSym _ _ } 19 | 20 | %% 21 | 22 | Exps : Exps1 { reverse $1 } 23 | 24 | Exps1 : {- empty -} { [] } 25 | | Exps1 Exp { $2:$1 } 26 | 27 | Exp : Atom { $1 } 28 | | List { $1 } 29 | 30 | Atom : sym { PSym (locSS $1) (idT $1) } 31 | 32 | List : '(' Exps ')' { PList (mkSrcSpan (loc $1) (loc $3)) 33 | $2 34 | (preSym $1, postSym $3) } 35 | 36 | { 37 | 38 | data LiskellParserMonad a = LPMOk a | LPMFailed SrcSpan Message 39 | 40 | thenLPM :: LiskellParserMonad a -> (a -> LiskellParserMonad b) -> LiskellParserMonad b 41 | m `thenLPM` k = 42 | case m of 43 | LPMOk a -> k a 44 | LPMFailed s m -> LPMFailed s m 45 | 46 | returnLPM :: a -> LiskellParserMonad a 47 | returnLPM a = LPMOk a 48 | 49 | failLPM :: String -> LiskellParserMonad a 50 | failLPM s = LPMFailed noSrcSpan (text s) 51 | 52 | catchLPM :: LiskellParserMonad a -> (SrcSpan -> Message -> LiskellParserMonad a) -> LiskellParserMonad a 53 | catchLPM m k = 54 | case m of 55 | LPMOk a -> LPMOk a 56 | LPMFailed s m -> k s m 57 | 58 | locSS token = mkSrcSpan point point 59 | where point = loc token 60 | 61 | happyError tokens = LPMFailed (mkSrcSpan (loc (head tokens)) (loc (head tokens))) (text ("Parse Error: " ++ (show (printLiskellToken (head tokens))))) 62 | } 63 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/Defdispatcher.lsk: -------------------------------------------------------------------------------- 1 | (defmodule Defdispatcher _ 2 | ((LskToHs (flags hiding) main) 3 | SrcLoc 4 | LskParseTree 5 | LskTransformationMonad 6 | Backquote 7 | Quote)) 8 | 9 | (defenv (lambda ((LskEnv e p t d)) (return (LskEnv (backquote-dispatcher (quote-dispatcher trf_expr e)) p t d)))) 10 | 11 | ;; defhead is only able to define a dispatch function for a 12 | ;; transformation of the head of the declaration list 13 | 14 | (define (defhead-dispatcher-fun ([] dispatcher-name dispatch-on dispatcher-fun)) 15 | `(define (,dispatcher-name k (: p ps)) 16 | (case p 17 | ((PList loc (: h t) (, "" "")) 18 | (if (== h ,dispatch-on) 19 | (k (: (,dispatcher-fun t) 20 | ps)) 21 | (k (: p ps)))) 22 | (_ (k (: p ps)))))) 23 | 24 | ;; defheadm is able to define dispatcher that emit a series of declarations 25 | 26 | (define (defheadm-dispatcher-fun ([] dispatcher-name dispatch-on dispatcher-fun)) 27 | `(define (,dispatcher-name k (: p ps)) 28 | (case p 29 | ((PList loc (: h t) (, "" "")) 30 | (if (== h ,dispatch-on) 31 | (k (++ (,dispatcher-fun t) 32 | ps)) 33 | (k (: p ps)))) 34 | (_ (k (: p ps)))))) 35 | 36 | (define (defheade-dispatcher-fun ([] dispatcher-name dispatch-on dispatcher-fun)) 37 | `(define (,dispatcher-name k p) 38 | (case p 39 | ((PList loc (: h t) (, "" "")) 40 | (if (== h ,dispatch-on) 41 | (k (,dispatcher-fun t)) 42 | (k p))) 43 | (_ (k p))))) 44 | 45 | (define (defhead-dispatcher-dispatcher-generic dispatch-on dispatch-fun k (: p ps)) 46 | (case p 47 | ((PList loc (: h t) (, "" "")) 48 | (if (== h dispatch-on) 49 | (k (: (dispatch-fun t) 50 | ps)) 51 | (k (: p ps)))) 52 | (_ (k (: p ps))))) 53 | 54 | (define defheadm-dispatcher-dispatcher 55 | (defhead-dispatcher-dispatcher-generic 'defheadm-dispatcher defheadm-dispatcher-fun)) 56 | 57 | (define defhead-dispatcher-dispatcher 58 | (defhead-dispatcher-dispatcher-generic 'defhead-dispatcher defhead-dispatcher-fun)) 59 | 60 | (define defheade-dispatcher-dispatcher 61 | (defhead-dispatcher-dispatcher-generic 'defheade-dispatcher defheade-dispatcher-fun)) 62 | -------------------------------------------------------------------------------- /LskFileHandler.hs: -------------------------------------------------------------------------------- 1 | module LskFileHandler where 2 | 3 | import DynFlags 4 | import LskToHs 5 | import HeaderInfo 6 | import HsSyn 7 | import LskTransformationMonad 8 | import SrcLoc 9 | import FastString 10 | import Util 11 | import Module 12 | import Data.List 13 | import StringBuffer 14 | import HscTypes 15 | import ErrUtils 16 | import System.FilePath 17 | import PrelNames (gHC_PRIM) 18 | 19 | getImportsLsk :: DynFlags -> StringBuffer -> FilePath -> FilePath 20 | -> IO ([Located ModuleName], [Located ModuleName], Located ModuleName) 21 | 22 | getImportsLsk dflags buf filename source_filename = 23 | if isLiskellSrcFilename filename then 24 | getImportsLsk' dflags buf filename source_filename 25 | else 26 | getImports dflags buf filename source_filename 27 | 28 | getImportsLsk' dflags buf filename source_filename = 29 | do 30 | env <- seedLskTrfEnv 31 | module_t <- runTM (liskell_transform_header_only buf (mkSrcLoc (mkFastString filename) 1 0)) 32 | (TransformationState env (error "Importing should not touch hsc_env") (newFreshVarStream "parse") ([],[])) 33 | case module_t of 34 | Left (TrErr s m) -> parseError s m 35 | Right (_, rdr_module) -> case rdr_module of 36 | L loc (HsModule mb_mod _ imps _ _ _ _) -> let 37 | (Just mod) = mb_mod 38 | (src_idecls, ord_idecls) = partition isSourceIdecl (map unLoc imps) 39 | source_imps = map getImpMod src_idecls 40 | ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc) 41 | (map getImpMod ord_idecls) 42 | -- GHC.Prim doesn't exist physically, so don't go looking for it. 43 | in 44 | return (source_imps, ordinary_imps, mod) 45 | 46 | 47 | isLiskellSrcSuffix s = s `elem` liskellish_user_src_suffixes 48 | liskellish_user_src_suffixes = [ "lsk" ] 49 | 50 | parseError :: SrcSpan -> Message -> IO a 51 | parseError span err = throwOneError $ mkPlainErrMsg span err 52 | 53 | isSourceIdecl :: ImportDecl name -> Bool 54 | isSourceIdecl (ImportDecl _ _ s _ _ _) = s 55 | 56 | getImpMod :: ImportDecl name -> Located ModuleName 57 | getImpMod (ImportDecl located_mod _ _ _ _ _) = located_mod 58 | 59 | isLiskellSrcFilename f = isLiskellSrcSuffix (drop 1 $ takeExtension f) 60 | -------------------------------------------------------------------------------- /testsuite/config/ghc: -------------------------------------------------------------------------------- 1 | # Testsuite configuration setup for GHC 2 | # 3 | # This file is Python source 4 | # 5 | config.compiler_type = 'ghc' 6 | config.compiler = 'ghc' 7 | config.compiler_always_flags = ['-fforce-recomp', '-dcore-lint', '-dcmm-lint'] 8 | 9 | # By default, we test the 'normal' and 'opt' ways. 10 | # 'optasm' is added by mk/test.mk if the compiler has a native code gen, 11 | # 'prof' is added by mk/test.mk if the profiling way is enabled. 12 | config.compile_ways = ['normal'] 13 | config.run_ways = ['normal'] 14 | 15 | # ways that are not enabled by default, but can always be invoked explicitly 16 | config.other_ways = ['extcore','optextcore'] 17 | 18 | if (ghc_with_native_codegen == 1): 19 | config.compile_ways.append('optasm') 20 | config.run_ways.append('optasm') 21 | 22 | if (ghc_with_profiling == 1): 23 | config.have_profiling = True 24 | config.compile_ways.append('prof') 25 | config.run_ways.append('prof') 26 | if (ghc_with_native_codegen == 1): 27 | config.compile_ways.append('profasm') 28 | config.run_ways.append('profasm') 29 | 30 | if (ghc_with_unreg == 1): 31 | config.compile_ways.append('unreg') 32 | config.run_ways.append('unreg') 33 | 34 | if (ghc_with_interpreter == 1): 35 | config.run_ways.append('ghci') 36 | 37 | if (ghc_with_threaded_rts == 1): 38 | config.run_ways.append('threaded1') 39 | if (ghc_with_smp == 1): 40 | config.run_ways.append('threaded2') 41 | 42 | config.way_flags = { 43 | 'normal' : [], 44 | 'opt' : ['-O'], 45 | 'optasm' : ['-O -fasm'], 46 | 'prof' : ['-O -prof -auto-all'], 47 | 'profasm' : ['-O -prof -auto-all -fasm'], 48 | 'unreg' : ['-unreg'], 49 | 'ghci' : ['--interactive', '-v0'], 50 | 'extcore' : ['-fext-core'], 51 | 'optextcore' : ['-O -fext-core'], 52 | 'threaded1' : ['-threaded', '-debug'], 53 | 'threaded2' : ['-O', '-threaded'] 54 | } 55 | 56 | config.way_rts_flags = { 57 | 'normal' : [], 58 | 'opt' : [], 59 | 'optasm' : [], 60 | 'prof' : ['-p'], 61 | 'profasm' : ['-hc'], # test heap profiling too 62 | 'unreg' : [], 63 | 'ghci' : [], 64 | 'extcore' : [], 65 | 'optextcore' : [], 66 | 'threaded1' : [], 67 | 'threaded2' : ['-N2'] 68 | } 69 | 70 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/Defmacro.lsk: -------------------------------------------------------------------------------- 1 | (defmodule Defmacro _ (LskParseTree SrcLoc Quote Backquote Defdispatcher LskTransformationMonad LskToHs)) 2 | 3 | (defenv (lambda ((LskEnv e p t d)) 4 | (return (LskEnv (backquote-dispatcher (quote-dispatcher trf_expr e)) p t (defheadm-dispatcher-dispatcher d))))) 5 | 6 | ;(define (defpfun-fun pt) 7 | ; (case pt 8 | ; (([] (: funname args) expr) ; this should be called in the form (defpfun (name args..) expr). (name args..) expr is given as pt. 9 | ; (let ((selectors (map (bq )))) 10 | ; ([] (` define (,funname pt) 11 | ; ((lambda ,args 12 | ; ,expr) 13 | ; ,@selectors)))))) ; return two function declarations. first 14 | ; ))) 15 | 16 | (define (getLstfromPlist pl) 17 | (let (((PList _ lst _) pl)) 18 | lst)) 19 | 20 | (define (getStrfromPSym pl) 21 | (let (((PSym _ str _) pl)) 22 | str)) 23 | 24 | (define (getQualfromPSym pl) 25 | (let (((PSym _ _ qual) pl)) 26 | qual)) 27 | 28 | (define (trfPSymSym p f) 29 | (let (((PSym loc str qual) p)) 30 | (PSym loc (f str) qual))) 31 | 32 | (defwithsig (defmacro-fun ([] funhead 33 | expr)) 34 | (-> ([] ParseTree) ([] ParseTree)) 35 | (let ((dispatch-fun (head (getLstfromPlist funhead))) 36 | (dispatcher-name (trfPSymSym dispatch-fun (lambda (s) (++ s "-dispatch"))))) 37 | ([] `(define ,funhead ,expr) 38 | `(defhead-dispatcher 39 | ,dispatcher-name 40 | ',dispatch-fun 41 | ,dispatch-fun)))) 42 | 43 | (defwithsig (defmacroe-fun ([] funhead 44 | expr)) 45 | (-> ([] ParseTree) ([] ParseTree)) 46 | (let ((dispatch-fun (head (getLstfromPlist funhead))) 47 | (dispatcher-name (trfPSymSym dispatch-fun (lambda (s) (++ s "-dispatch")))) 48 | (dispatch-on (PList noSrcSpan ([] (PSym noSrcSpan "PSym" "") 49 | (PSym noSrcSpan "noSrcSpan" "") 50 | (PString noSrcSpan (getStrfromPSym dispatch-fun)) 51 | (PString noSrcSpan (getQualfromPSym dispatch-fun))) 52 | noPP))) 53 | ([] `(define ,funhead ,expr) 54 | `(defheade-dispatcher 55 | ,dispatcher-name 56 | ,dispatch-on 57 | ,dispatch-fun)))) 58 | 59 | (defheadm-dispatcher 60 | defmacroe-dispatcher 61 | 'defmacroe 62 | defmacroe-fun) 63 | 64 | (defheadm-dispatcher 65 | defmacro-dispatcher 66 | 'defmacro 67 | defmacro-fun) 68 | 69 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/Bang.lsk: -------------------------------------------------------------------------------- 1 | (defmodule Bang _ (LskPrelude Liskell)) 2 | 3 | (defenv (lambda ((LskEnv e p t d)) 4 | (return (LskEnv (dspr-namespace-dspr e) p t (define-dspr-dspr d))))) 5 | (defenv (lambda ((LskEnv e p t d)) 6 | (return (LskEnv e p t (d(add-dspr) d))))) 7 | 8 | (add-dspr (expression simple-list) 9 | (expression sParseTree-e) 10 | (expression ++*) 11 | (pattern simple-list) 12 | (pattern sParseTree-p) 13 | (expression backquote) 14 | (declaration def-hdsprs) 15 | (declaration defmacros)) 16 | 17 | (defdata (PatWriter a) 18 | (PatWriter (, a (Maybe ([] ParseTree))))) 19 | 20 | (define (runPatWriter (PatWriter a)) 21 | a) 22 | 23 | (define (combine-output a b) 24 | (let (((x (Just a) (Just b)) 25 | (Just (++ a b))) 26 | ((x (Just _) Nothing) 27 | a) 28 | ((x Nothing (Just _)) 29 | b) 30 | ((x Nothing Nothing) 31 | Nothing)) 32 | (x a b))) 33 | 34 | (definstance (Monad PatWriter) 35 | ((return a) (PatWriter (, a Nothing))) 36 | ((>>= (PatWriter (, a o)) 37 | f) 38 | (let (((PatWriter (, r o')) 39 | (f a))) 40 | (PatWriter (, r (combine-output o o')))))) 41 | 42 | (define (pw-output pt) 43 | (PatWriter (, (,) (Just pt)))) 44 | 45 | (define (walk-pats pt) 46 | (case pt 47 | ((SList %((SSym "!") 48 | maybe-bang)) 49 | (case maybe-bang 50 | ((SSym _) 51 | (>> (pw-output ([] maybe-bang)) 52 | (return maybe-bang))) 53 | ((SList _) ; constructor, we don't bang constructors 54 | (>> (pw-output ([])) 55 | (walk-pats maybe-bang))))) 56 | ((SList (: constructor 57 | sub-pats)) 58 | (>>= (mapM walk-pats sub-pats) 59 | (lambda (clean-subpats) 60 | (return (SList (: constructor 61 | clean-subpats)))))) 62 | ((SSym _) 63 | (return pt)))) 64 | 65 | (define-dspr (bang-ptt kn pt ks kf) 66 | (case pt 67 | ((SList %((SSym "lambda") 68 | (SList pats) 69 | expr)) 70 | (let (((PatWriter (, clean-pats maybe-banged-pats)) 71 | (mapM walk-pats pats))) 72 | (case maybe-banged-pats 73 | (Nothing (kn pt ks kf)) 74 | ((Just banged-pats) 75 | (ks (SList %((SSym "lambda") 76 | (SList clean-pats) 77 | (foldr (lambda (pt pts) 78 | `(seq ,pt ,pts)) 79 | expr 80 | banged-pats)))))))) 81 | (_ (kn pt ks kf)))) 82 | 83 | (define pt1 `(lambda ((! x)) x)) 84 | (define pt2 `(lambda ((! (Just (! x))) (Just (! y))) x)) 85 | -------------------------------------------------------------------------------- /GHCSalat/GHC4Lsk.hs-boot: -------------------------------------------------------------------------------- 1 | module GHCSalat.GHC4Lsk (ParsedMod,loadModule,typecheckModule,runGhc,setSessionDynFlags,getSessionDynFlags,findModule,ParsedModule(..),compileHsExpr,setTargets,LoadHowMuch(..),load,unload) where 2 | import GHCSalat.GhciMonad 3 | import HscTypes 4 | import Module 5 | import FastString 6 | import DynFlags 7 | import SrcLoc 8 | import HsSyn 9 | import RdrName 10 | import TcRnTypes hiding (LIE) 11 | import Name 12 | import Var 13 | import ByteCodeLink 14 | import BasicTypes 15 | import TypeRep 16 | 17 | findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module 18 | 19 | getSessionDynFlags :: GhcMonad m => m DynFlags 20 | 21 | setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId] 22 | 23 | runGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'. 24 | -> Ghc a -- ^ The action to perform. 25 | -> IO a 26 | 27 | loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod 28 | 29 | typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule 30 | 31 | class ParsedMod m => TypecheckedMod m where 32 | renamedSource :: m -> Maybe RenamedSource 33 | typecheckedSource :: m -> TypecheckedSource 34 | moduleInfo :: m -> ModuleInfo 35 | tm_internals :: m -> (TcGblEnv, ModDetails) 36 | -- ToDo: improvements that could be made here: 37 | -- if the module succeeded renaming but not typechecking, 38 | -- we can still get back the GlobalRdrEnv and exports, so 39 | -- perhaps the ModuleInfo should be split up into separate 40 | -- fields. 41 | 42 | class ParsedMod m where 43 | 44 | data TypecheckedModule 45 | type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], 46 | Maybe (HsDoc Name), HaddockModInfo Name) 47 | type TypecheckedSource = LHsBinds Id 48 | 49 | data ParsedModule = 50 | ParsedModule { pm_mod_summary :: ModSummary 51 | , pm_parsed_source :: ParsedSource } 52 | type ParsedSource = Located (HsModule RdrName) 53 | 54 | 55 | instance TypecheckedMod TypecheckedModule where 56 | 57 | data ModuleInfo 58 | 59 | compileHsExpr -- Compile a stmt all the way to an HValue, but don't run it 60 | :: GhcMonad m => 61 | HscEnv 62 | -> LHsExpr RdrName -- The statement 63 | -> TcM Type 64 | -> m (Maybe HValue) 65 | 66 | setTargets :: GhcMonad m => [Target] -> m () 67 | 68 | data LoadHowMuch 69 | = LoadAllTargets 70 | | LoadUpTo ModuleName 71 | | LoadDependenciesOf ModuleName 72 | 73 | load :: GhcMonad m => LoadHowMuch -> m SuccessFlag 74 | 75 | unload :: HscEnv -> [Linkable] -> IO () 76 | -------------------------------------------------------------------------------- /HsVersions.h: -------------------------------------------------------------------------------- 1 | #ifndef HSVERSIONS_H 2 | #define HSVERSIONS_H 3 | 4 | #if 0 5 | 6 | IMPORTANT! If you put extra tabs/spaces in these macro definitions, 7 | you will screw up the layout where they are used in case expressions! 8 | 9 | (This is cpp-dependent, of course) 10 | 11 | #endif 12 | 13 | /* Useful in the headers that we share with the RTS */ 14 | #define COMPILING_GHC 1 15 | 16 | /* Pull in all the platform defines for this build (foo_TARGET_ARCH etc.) */ 17 | #include "ghc_boot_platform.h" 18 | 19 | /* Pull in the autoconf defines (HAVE_FOO), but don't include 20 | * ghcconfig.h, because that will include ghcplatform.h which has the 21 | * wrong platform settings for the compiler (it has the platform 22 | * settings for the target plat instead). */ 23 | #include "../includes/ghcautoconf.h" 24 | 25 | #if __GLASGOW_HASKELL__ >= 602 26 | #define SYSTEM_IO_ERROR System.IO.Error 27 | #else 28 | #define SYSTEM_IO_ERROR System.IO 29 | #endif 30 | 31 | #ifdef __GLASGOW_HASKELL__ 32 | #define GLOBAL_VAR(name,value,ty) \ 33 | name = Util.global (value) :: IORef (ty); \ 34 | {-# NOINLINE name #-} 35 | #endif 36 | 37 | #define COMMA , 38 | 39 | #ifdef DEBUG 40 | #define debugIsOn True 41 | #define ASSERT(e) if (not (e)) then (assertPanic __FILE__ __LINE__) else 42 | #define ASSERT2(e,msg) if (not (e)) then (assertPprPanic __FILE__ __LINE__ (msg)) else 43 | #define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) 44 | #define ASSERTM(mbool) do { bool <- mbool; ASSERT(bool) return () } 45 | #define ASSERTM2(mbool,msg) do { bool <- mbool; ASSERT2(bool,msg) return () } 46 | #else 47 | #define debugIsOn False 48 | -- We have to actually use all the variables we are given or we may get 49 | -- unused variable warnings when DEBUG is off. 50 | #define ASSERT(e) if False && (not (e)) then panic "ASSERT" else 51 | #define ASSERT2(e,msg) if False && (not (e)) then pprPanic "ASSERT2" (msg) else 52 | #define ASSERTM(e) do { let { _mbool = (e) } } 53 | -- Here we deliberately don't use when as Control.Monad might not be imported 54 | #define ASSERTM2(e,msg) do { let { _mbool = (e) }; if False then panic "ASSERTM2" else return () } 55 | #define WARN(e,msg) if False && (e) then pprPanic "WARN" (msg) else 56 | #endif 57 | 58 | -- This #ifndef lets us switch off the "import FastString" 59 | -- when compiling FastString itself 60 | #ifndef COMPILING_FAST_STRING 61 | -- 62 | import qualified FastString as FS 63 | #endif 64 | 65 | #define SLIT(x) (FS.mkLitString# (x#)) 66 | #define FSLIT(x) (FS.mkFastString# (x#)) 67 | 68 | -- Useful for declaring arguments to be strict 69 | #define STRICT1(f) f a | a `seq` False = undefined 70 | #define STRICT2(f) f a b | a `seq` b `seq` False = undefined 71 | #define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined 72 | #define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined 73 | #define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined 74 | #define STRICT6(f) f a b c d e f | a `seq` b `seq` c `seq` d `seq` e `seq` f `seq` False = undefined 75 | 76 | #endif /* HsVersions.h */ 77 | 78 | -------------------------------------------------------------------------------- /LexLiskell.x: -------------------------------------------------------------------------------- 1 | { 2 | -- -*-haskell-*- 3 | -- --------------------------------------------------------------------------- 4 | -- Liskell 5 | -- Lexer for Liskell 6 | -- 7 | -- Author(s): Clemens Fruhwirth 8 | -- --------------------------------------------------------------------------- 9 | 10 | module LexLiskell(lexLiskell, Token(..),printLiskellToken) where 11 | import SrcLoc 12 | import StringBuffer 13 | import FastString 14 | import Numeric 15 | import Util 16 | } 17 | 18 | 19 | $digit = 0-9 -- digits 20 | $hex = [0-9 a-f A-F] -- hex 21 | $octal = 0-7 -- octal 22 | $lowerchars = [a-z] -- lowerchars 23 | $upperchars = [A-Z] -- upperchars 24 | $liskellsymbols = [\:\,\_\`\'] -- additional symbols allowed by Liskell 25 | $haskellsymbols = [\!\#\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\[\]\_\,\:] -- as in Page 8 Haskell 98 Report 26 | $symbols = [$liskellsymbols $haskellsymbols] 27 | $alpha = [[A-Z][a-z]] 28 | $idchars = [$alpha $symbols $digit] 29 | @id = $idchars+ 30 | @upid = $upperchars $idchars* 31 | @qualid = (@upid [\.])+ @id 32 | 33 | tokens :- 34 | 35 | $white+ ; 36 | ";".* ; 37 | $idchars* "(" { \p s -> TOParent p (init s) } 38 | ")" $idchars* { \p s -> TCParent p (tail s) } 39 | 40 | -- Strings 41 | \"[^\"]*\" { TSym } -- FIXME. what about control chars? 42 | 43 | -- Everything else is symbol not including symbol separators (whitespace, parenthesis and comments) 44 | [^\ \(\)\;]+ { TSym } 45 | { 46 | 47 | -- The token type: 48 | data Token = TOParent { loc :: SrcLoc, preSym :: String } 49 | | TCParent { loc :: SrcLoc, postSym :: String } 50 | | TSym { loc :: SrcLoc, idT :: String } 51 | | TString { loc :: SrcLoc, stringT :: String } 52 | deriving (Eq,Show) 53 | 54 | printLiskellToken (TOParent _ pre) = pre ++ "(" 55 | printLiskellToken (TCParent _ post) = ")" ++ post 56 | printLiskellToken (TSym _ id) = id 57 | printLiskellToken (TString _ str) = show str 58 | 59 | -------------------------------------------------------------------------------- 60 | -- The input type 61 | -------------------------------------------------------------------------------- 62 | type AlexInput = (SrcLoc, -- current position, 63 | StringBuffer) -- current input string 64 | 65 | alexInputPrevChar :: AlexInput -> Char 66 | alexInputPrevChar (p,buf) = prevChar buf '\n' 67 | 68 | alexGetChar :: AlexInput -> Maybe (Char,AlexInput) 69 | alexGetChar (loc,s) 70 | | atEnd s = Nothing 71 | | otherwise = c `seq` loc' `seq` s' `seq` 72 | --trace (show (ord c)) $ 73 | Just (c, (loc', s')) 74 | where (c,s') = nextChar s 75 | loc' = advanceSrcLoc loc c 76 | 77 | alexStartPos = mkSrcLoc (mkFastString "foo") 1 0 78 | 79 | alexScanTokens startpos str = go (startpos,str) 80 | where go inp@(pos,strbuf) = 81 | case alexScan inp 0 of 82 | AlexEOF -> [] 83 | AlexError _ -> error "lexical error" 84 | AlexSkip inp' len -> go inp' 85 | AlexToken inp' len act -> act pos (lexemeToString strbuf len) : go inp' 86 | 87 | instance Show SrcLoc where 88 | show s = "" 89 | 90 | lexLiskell s l = alexScanTokens l s 91 | 92 | main = do 93 | s <- getContents 94 | sb <- stringToStringBuffer s 95 | print (alexScanTokens alexStartPos sb) 96 | } -------------------------------------------------------------------------------- /testsuite/tests/liskell/metaprogramming/Backquote.lsk: -------------------------------------------------------------------------------- 1 | (defmodule Backquote _ (Liskell SrcLoc LskParseTree SimpleList)) 2 | 3 | (define (backquote-dispatcher-on-syms ks kf pt) 4 | (case pt 5 | ((PSym loc sym qual) 6 | (if (== (head sym) #\`) 7 | (ks (PList loc ([] (PSym noSrcSpan "PSym" "") 8 | (PSym noSrcSpan "noSrcSpan" "") 9 | (PString noSrcSpan (tail sym)) 10 | (PString noSrcSpan qual)) 11 | noPP)) 12 | (kf pt))) 13 | (_ (kf pt)))) 14 | 15 | 16 | (defenv (lambda ((LskEnv e p t d)) 17 | (return (LskEnv (backquote-dispatcher-on-syms trf_expr e) p t d)))) 18 | 19 | (defenv (lambda ((LskEnv e p t d)) 20 | (return (LskEnv (simple-list-dispatcher trf_expr e) p t d)))) 21 | 22 | (define (sPList lst) 23 | (PList noSrcSpan lst noPP)) 24 | 25 | (define (bq-transform-lst pts curlst) 26 | (case pts 27 | (([]) (sPList (: `[] (reverse curlst)))) 28 | ((: x xs) 29 | (case x 30 | ;; Escaped symbol of the forms ,foo ,@foo 31 | ((@ sym (PSym loc string qual)) 32 | (if (&& (== (head string) #\,) 33 | (< 1 (length string))) ;; otherwise it might be tuple (, foo) 34 | (if (== (!! string 1) #\@) 35 | ;; Is a spliced list 36 | (sPList '(`++ 37 | (bq-transform-lst ([]) curlst) 38 | (sPList '(`++ 39 | (PSym loc (tail (tail string)) qual) 40 | (bq-transform-lst xs ([])))))) 41 | ;; Eval symbol 42 | (bq-transform-lst xs 43 | (: (PList loc '(`toParseTree 44 | (PSym loc (tail string) qual)) 45 | noPP) 46 | curlst))) 47 | ;; Normal symbol. Quote it! 48 | (bq-transform-lst xs 49 | (: (PList loc ([] `PSym 50 | `noSrcSpan 51 | (PString loc string) 52 | (PString loc qual)) 53 | noPP) 54 | curlst)))) 55 | ;; Escaped lists of the form ,(foobar a b) 56 | ((PList loc lst (, pre post)) 57 | (if (&& (< 0 (length pre)) 58 | (== (head pre) #\,)) 59 | (bq-transform-lst xs 60 | (: (PList loc ([] `toParseTree 61 | (PList loc lst noPP)) 62 | noPP) 63 | curlst)) 64 | (bq-transform-lst xs 65 | (: (sPList '(`PList 66 | `noSrcSpan 67 | (bq-transform-lst lst ([])) 68 | `noPP)) 69 | curlst)))) 70 | ;; Autoquoting of strings 71 | ;; The problem with strings are that they are actually a type synonym for [Char] 72 | ;; As type synonyms can be part of instance declaration but toParseTree 73 | ;; relays on instance decls., we have to manually convert strings here 74 | ((@ s (PString loc str)) 75 | (bq-transform-lst xs 76 | (: (PList loc 77 | '(`PString 78 | `noSrcSpan 79 | (PString noSrcSpan str)) 80 | noPP) 81 | curlst))) 82 | (other (bq-transform-lst xs 83 | (: (PList (ploc other) '(`toParseTree 84 | other) 85 | noPP) 86 | curlst))))))) 87 | 88 | (define (backquote-dispatcher-on-lists ks kf pt) 89 | (case pt 90 | ((PList loc lst (, "`" "")) 91 | (ks (sPList '(`PList 92 | `noSrcSpan 93 | (bq-transform-lst lst ([])) 94 | `noPP)))) 95 | (_ (kf pt)))) 96 | 97 | (define (backquote-dispatcher ks kf) 98 | (backquote-dispatcher-on-syms ks (backquote-dispatcher-on-lists ks kf))) 99 | 100 | -------------------------------------------------------------------------------- /testsuite/mk/wordsize.mk: -------------------------------------------------------------------------------- 1 | # 1 "../../mk/wordsize.mk.in" 2 | # 1 "" 3 | # 1 "" 4 | # 1 "../../mk/wordsize.mk.in" 5 | 6 | 7 | # 1 "../../mk/../../includes/MachDeps.h" 1 8 | 9 | # 11 "../../mk/../../includes/MachDeps.h" 10 | 11 | 12 | 13 | 14 | 15 | 16 | # 1 "../../mk/../../includes/ghcautoconf.h" 1 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | 146 | 147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | 171 | 172 | 173 | 174 | 175 | 176 | 177 | 178 | 179 | 180 | 181 | 182 | 183 | 184 | 185 | 186 | 187 | 188 | 189 | 190 | 191 | 192 | 193 | 194 | 195 | 196 | 197 | 198 | 199 | 200 | 201 | 202 | 203 | 204 | 205 | 206 | 207 | 208 | 209 | 210 | 211 | 212 | 213 | 214 | 215 | 216 | 217 | 218 | 219 | 220 | 221 | 222 | 223 | 224 | 225 | 226 | 227 | 228 | 229 | 230 | 231 | 232 | 233 | 234 | 235 | 236 | 237 | 238 | 239 | 240 | 241 | 242 | 243 | 244 | 245 | 246 | 247 | 248 | 249 | 250 | 251 | 252 | 253 | 254 | 255 | 256 | 257 | 258 | 259 | 260 | 261 | 262 | 263 | 264 | 265 | 266 | 267 | 268 | 269 | 270 | 271 | 272 | 273 | 274 | 275 | 276 | 277 | 278 | 279 | 280 | 281 | 282 | 283 | 284 | 285 | 286 | 287 | 288 | 289 | 290 | 291 | 292 | 293 | 294 | 295 | 296 | 297 | 298 | 299 | 300 | 301 | 302 | 303 | 304 | 305 | 306 | 307 | 308 | 309 | 310 | 311 | 312 | 313 | 314 | 315 | 316 | 317 | 318 | 319 | 320 | 321 | 322 | 323 | 324 | 325 | 326 | 327 | 328 | 329 | 330 | 331 | 332 | 333 | 334 | 335 | 336 | 337 | 338 | 339 | 340 | 341 | 342 | 343 | 344 | 345 | 346 | 347 | 348 | 349 | 350 | 351 | 352 | 353 | 354 | 355 | 356 | 357 | 358 | 359 | 360 | 361 | 362 | 363 | 364 | 365 | 366 | 367 | 368 | 369 | 370 | 371 | 372 | 373 | 374 | 375 | 376 | 377 | 378 | 379 | 380 | 381 | # 17 "../../mk/../../includes/MachDeps.h" 2 382 | 383 | 384 | 385 | 386 | 387 | 388 | 389 | 390 | 391 | 392 | 393 | 394 | 395 | 396 | 397 | 398 | 399 | 400 | 401 | 402 | 403 | 404 | 405 | 406 | 407 | 408 | 409 | 410 | 411 | 412 | 413 | 414 | 415 | 416 | 417 | 418 | 419 | 420 | 421 | 422 | 423 | 424 | 425 | 426 | 427 | 428 | 429 | 430 | 431 | 432 | 433 | 434 | 435 | 436 | 437 | 438 | 439 | 440 | 441 | 442 | 443 | 444 | 445 | 446 | 447 | 448 | 449 | 450 | # 99 "../../mk/../../includes/MachDeps.h" 451 | 452 | 453 | 454 | 455 | 456 | 457 | 458 | 459 | 460 | # 3 "../../mk/wordsize.mk.in" 2 461 | 462 | WORDSIZE = 64 463 | 464 | -------------------------------------------------------------------------------- /LskInteractiveEval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module LskInteractiveEval where 3 | 4 | import LskTransformationMonad 5 | import HsSyn 6 | import {-# SOURCE #-} GHCSalat.GHC4Lsk as GHC4Lsk 7 | import SrcLoc 8 | import MonadUtils 9 | import InteractiveEval 10 | import HscTypes 11 | import LskParseTree 12 | import Module 13 | import Outputable 14 | import TcEnv 15 | import TcExpr 16 | import RnEnv 17 | import RdrName 18 | import OccName 19 | import GHC.Exts ( unsafeCoerce# ) 20 | import GHC.Paths (libdir) 21 | 22 | emptyModSummary = ModSummary { 23 | -- ms_mod = mkModule mainPackageId interactiveMod, -- (error "pkgid") (error "modname"), -- ^ Identity of the module 24 | ms_hsc_src = HsSrcFile, 25 | ms_location = error "ms_location accessed", 26 | ms_hs_date = error "ms_hs_date accessed", 27 | ms_obj_date = error "ms_obj_date accessed", 28 | ms_srcimps = error "ms_srcimps accessed", 29 | ms_imps = error "ms_imps accessed", 30 | ms_hspp_file = error "ms_hspp_file accessed", 31 | ms_hspp_opts = error "ms_hspp_opts accessed", -- ^ Cached flags from @OPTIONS@, @INCLUDE@ 32 | -- and @LANGUAGE@ pragmas in the modules source code 33 | ms_hspp_buf = Nothing -- error "ms_hspp_buf accessed" -- ^ The actual preprocessed source, if we have it 34 | }; 35 | 36 | 37 | 38 | eval expr (imports, decls) hsc_env = do 39 | (PSym _ (_:newname)) <- genSym 40 | liftIO $ runGhc (Just libdir) $ do 41 | setSession hsc_env 42 | dflags <- getSessionDynFlags 43 | let prelude_mod = mkModuleName "Prelude" 44 | #warning Recognize explicit Prelude imports 45 | mods <- mapM (`GHC4Lsk.findModule` Nothing) (prelude_mod:(map (unLoc . ideclName . unLoc) imports)) 46 | liftIO $ log ("imports:" ++ (show $ length mods) ++ ", decls:" ++ (show $ length decls)) 47 | -- prel_mod <- GHC4Lsk.getPrelude 48 | InteractiveEval.setContext [] (mods) 49 | -- parsed <- parseLSKModule myModSum 50 | -- let interactiveMod = (mkModuleName "InteractiveContextModule") 51 | let interactiveMod = (mkModuleName $ "Adhoc" ++ newname) 52 | let interactiveModule = HsModule { hsmodName = Just (L noSrcSpan interactiveMod) , hsmodExports = Nothing, hsmodImports = imports, hsmodDecls = reverse decls, hsmodDeprecMessage = Nothing, hsmodHaddockModInfo = emptyHaddockModInfo, hsmodHaddockModDescr = Nothing } 53 | liftIO $ log "pretypecheck" 54 | typechecked <- typecheckModule (ParsedModule (emptyModSummary { ms_mod = mkModule mainPackageId interactiveMod, ms_hspp_opts = dflags } ) (L noSrcSpan interactiveModule)) 55 | liftIO $ log "preload" 56 | loaded <- GHC4Lsk.loadModule typechecked 57 | liftIO $ log "postload" 58 | current_mod <- GHC4Lsk.findModule interactiveMod Nothing 59 | liftIO $ log "preset" 60 | InteractiveEval.setContext [current_mod] (mods) 61 | liftIO $ log "compiling..." 62 | lskTransformationMonadModule <- findModule (mkModuleName "LskTransformationMonad") Nothing 63 | let lskType = do 64 | lskEnvName <- lookupGlobalOccRn (mkOrig lskTransformationMonadModule 65 | (mkTcOcc "LskEnvironmentTransformer")); 66 | lskEnvType <- tcMetaTy lskEnvName 67 | return lskEnvType 68 | (Just hval) <- withSession (\e -> compileHsExpr e expr lskType) 69 | -- We don't need to unlink that MUCH 70 | liftIO $ GHC4Lsk.unload hsc_env [] 71 | return ((unsafeCoerce# hval) :: LskEnvironment -> IO LskEnvironment ) 72 | where 73 | #ifdef VERBOSE 74 | log = putStrLn 75 | #else 76 | log x = return () 77 | #endif 78 | -------------------------------------------------------------------------------- /LskTransformationMonad.hs: -------------------------------------------------------------------------------- 1 | module LskTransformationMonad where 2 | import LskParseTree 3 | import HsSyn 4 | import RdrName 5 | import SrcLoc 6 | import Outputable 7 | import ErrUtils ( Message ) 8 | import MonadUtils 9 | import HscTypes 10 | 11 | ------------------------------------------------------------------------------------- 12 | --- TransformationMonad 13 | ------------------------------------------------------------------------------------- 14 | 15 | --- The Transformation Monad is basically a combination of the 16 | --- Error+Reader Monad with an IO Monad 17 | 18 | data LskEnvironment = LskEnv 19 | -- SUCCESS CONT. FAILURE CONT. 20 | (forall a.(ParseTree -> (ParseTree -> a) -> (ParseTree -> a) -> a)) -- ExprTable 21 | (forall a.(ParseTree -> (ParseTree -> a) -> (ParseTree -> a) -> a)) -- PatTable 22 | (forall a.(ParseTree -> (ParseTree -> a) -> (ParseTree -> a) -> a)) -- TypeTable 23 | (forall a.(ParseTree -> (ParseTree -> a) -> (ParseTree -> a) -> a)) -- DeclTable 24 | 25 | -- Transformation Environment 26 | 27 | type LskEnvironmentTransformer = LskEnvironment -> IO LskEnvironment 28 | 29 | envExprTable (LskEnv e _ _ _) = e 30 | envPatTable (LskEnv _ p _ _) = p 31 | envTypeTable (LskEnv _ _ t _) = t 32 | envDeclTable (LskEnv _ _ _ d) = d 33 | 34 | -- The Monad itself 35 | 36 | type Variables = String 37 | 38 | data TransformationState = TransformationState { 39 | ts_lskenv :: LskEnvironment, 40 | ts_hsc_env :: HscEnv, 41 | ts_freshvars :: [Variables], 42 | ts_evalctx :: ([LImportDecl RdrName], [LHsDecl RdrName]) 43 | } 44 | 45 | data TransformationError = TrErr SrcSpan Message 46 | 47 | data TransformationMonad a = TM { runTM :: TransformationState -> (IO (Either TransformationError (TransformationState,a))) } 48 | 49 | instance Monad TransformationMonad where 50 | m >>= k = TM $ \s -> do 51 | a <- runTM m s 52 | case a of 53 | Left l -> return (Left l) 54 | Right (s',r) -> runTM (k r) s' 55 | return a = TM $ \s -> return (Right (s,a)) 56 | 57 | instance MonadIO TransformationMonad where 58 | liftIO m = TM $ \s -> do 59 | a <- m 60 | return (Right (s,a)) 61 | 62 | 63 | throwError m = TM $ \_ -> return (Left (TrErr noSrcSpan m)) 64 | throwErrorAt s m = TM $ \_ -> return (Left (TrErr s m)) 65 | 66 | m `catchError` h = TM $ \s -> do 67 | a <- runTM m s 68 | case a of 69 | Left l -> runTM (h l) s 70 | Right (s,r) -> return (Right (s,r)) 71 | 72 | askVars = TM $ \s -> return (Right (s, ts_freshvars s)) 73 | askEnv = TM $ \s -> return (Right (s, ts_lskenv s)) 74 | askHscEnv = TM $ \s -> return (Right (s, ts_hsc_env s)) 75 | askEvalCtx = TM $ \s -> return (Right (s, ts_evalctx s)) 76 | 77 | 78 | getsTM = TM $ \s -> return (Right (s, s)) 79 | setsTM s = TM $ \_ -> return (Right (s, ())) 80 | 81 | setEvalCtxImports i = TM $ \s -> 82 | return $ Right (s { ts_evalctx = (i, (snd $ ts_evalctx s)) }, ()) 83 | 84 | addEvalCtxDecl d = TM $ \s -> do 85 | let oldeval = ts_evalctx s 86 | return $ Right (s { ts_evalctx = (fst oldeval, d:(snd oldeval)) }, ()) 87 | 88 | genSym :: TransformationMonad ParseTree 89 | genSym = do 90 | TM $ \ts -> 91 | let vars = ts_freshvars ts 92 | in return $ Right (ts { ts_freshvars = (tail vars) }, 93 | PSym noSrcSpan (head vars)) 94 | 95 | newFreshVarStream prefix = map (((toEnum 0:prefix) ++) . show) [1..] 96 | 97 | withTrfState s' m = TM $ \s -> (runTM m) s' 98 | askTrfState = TM $ \s -> return (Right (s, s)) 99 | withEnvTrf f m = TM $ \s -> (runTM m) (s { ts_lskenv = f (ts_lskenv s) }) 100 | 101 | lift m = TM $ \s -> do 102 | a <- m 103 | return (Right (s,a)) 104 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/testprogs/Bezier.lsk: -------------------------------------------------------------------------------- 1 | (defmodule Bezier _ (Liskell LskPrelude System)) 2 | 3 | ;; Bezier Curve compile-time computation performance test 4 | 5 | (defenv (lambda ((LskEnv e p t d)) 6 | (return (LskEnv (dspr-namespace-dspr e) p t (define-dspr-dspr d))))) 7 | (defenv (lambda ((LskEnv e p t d)) 8 | (return (LskEnv e p t (d(add-dspr) d))))) 9 | 10 | (add-dspr (declaration defmacros) 11 | (declaration def-hdsprs) 12 | (expression backquote) 13 | (expression simple-list) 14 | (pattern simple-list) 15 | (declaration def-binary-fun-as-prefix) 16 | (expression sParseTree-e) 17 | (pattern sParseTree-p)) 18 | 19 | (def-binary-fun-as-prefix + right) 20 | (def-binary-fun-as-prefix - left) 21 | (def-binary-fun-as-prefix * right) 22 | 23 | (add-dspr (expression +*) 24 | (expression -*) 25 | (expression **) 26 | (expression ++*)) 27 | 28 | 29 | (defdata Point (Point Float Float)) 30 | 31 | (definstance (Show Point) 32 | ((show (Point a b)) (++* "Point " (show a) " " (show b)))) 33 | (define (px (Point x _)) x) 34 | (define (py (Point y _)) y) 35 | 36 | ;; In tribute to Paul Graham's On Lisp: "Computation At Compile-Time" 37 | 38 | (defmacro (bezier %((SSym snumber))) 39 | (let (((Just number) (:: (convertNumber snumber) (Maybe Integer)))) 40 | `(lambda (s c1 c2 e) 41 | (let ((cx (* (- (px s) 42 | (px c1)) 43 | 3)) 44 | (cy (* (- (py s) 45 | (py c1)) 46 | 3)) 47 | (sx (* (- (px c2) 48 | (px c1)) 49 | 3)) 50 | (sy (* (- (py c2) 51 | (py c1)) 52 | 3)) 53 | (bx (- sx cx)) 54 | (by (- sy cy)) 55 | (ax (-* (px e) 56 | sx 57 | (px s))) 58 | (ay (-* (py e) 59 | sy 60 | (py s)))) 61 | ([] s ,@(map (lambda (u) 62 | `(Point (+* (* ax ,(SSym (show (* u (* u u))))) 63 | (* bx ,(SSym (show (* u u)))) 64 | (* cx ,(SSym (show u))) 65 | (px s)) 66 | (+* (* ay ,(SSym (show (* u (* u u))))) 67 | (* by ,(SSym (show (* u u)))) 68 | (* cy ,(SSym (show u))) 69 | (py s)))) 70 | (:: (take (fromInteger number) 71 | (tail (enumFromThenTo 0 72 | (/ 1 (fromInteger (+ 1 number))) 73 | 1))) 74 | ([] Float))) 75 | e))))) 76 | 77 | (define (bezier-fun number s c1 c2 e) 78 | (let ((cx (* (- (px s) 79 | (px c1)) 80 | 3)) 81 | (cy (* (- (py s) 82 | (py c1)) 83 | 3)) 84 | (sx (* (- (px c2) 85 | (px c1)) 86 | 3)) 87 | (sy (* (- (py c2) 88 | (py c1)) 89 | 3)) 90 | (bx (- sx cx)) 91 | (by (- sy cy)) 92 | (ax (-* (px e) 93 | sx 94 | (px s))) 95 | (ay (-* (py e) 96 | sy 97 | (py s)))) 98 | (++ (: s 99 | (map (lambda (u) 100 | (let ((u2 (* u u)) 101 | (u3 (* u u2))) 102 | (Point (+* (* ax u3) 103 | (* bx u2) 104 | (* cx u) 105 | (px s)) 106 | (+* (* ay u3) 107 | (* by u2) 108 | (* cy u) 109 | (py s))))) 110 | (take (fromInteger number) 111 | (tail (enumFromThenTo 0 112 | (/ 1 (fromInteger (+ 1 number))) 113 | 1))))) 114 | ([] e)))) 115 | 116 | (add-dspr (expression bezier)) 117 | 118 | (define main 119 | (>>= System.getArgs 120 | (lambda (([] which)) 121 | (let ((fun-to-call (case which 122 | ("macro" (bezier 20)) 123 | ("fun" (bezier-fun 20))))) 124 | (print (show 125 | (foldr (lambda (list res) 126 | (+ (foldr (lambda ((Point x y) res) 127 | (+ res x)) 128 | 0 129 | list) 130 | res)) 131 | 0 132 | (map (lambda (x) 133 | (fun-to-call (Point 0 0) (Point 1 1) (Point 2 2) (Point 3 x))) 134 | (enumFromTo 0 50000))))))))) 135 | -------------------------------------------------------------------------------- /LskParseTree.hs: -------------------------------------------------------------------------------- 1 | module LskParseTree where 2 | import SrcLoc 3 | import FastString 4 | import Data.List 5 | import qualified Numeric 6 | import ReadRationalS 7 | 8 | data ParseTree = PSym { pt_loc :: SrcSpan, pt_sym :: String } 9 | | PList { pt_loc :: SrcSpan, pt_list :: [ParseTree], pt_pp :: (String, String) } 10 | 11 | instance Show ParseTree where 12 | show (PSym _ s) = s 13 | show (PList _ l (pe, ps)) = pe ++ "(" ++ (tail (concat (map (\pt -> " " ++ show pt) 14 | l))) ++ ")" ++ ps 15 | 16 | ploc = pt_loc 17 | 18 | instance Eq ParseTree where 19 | (==) (PSym _ s1) (PSym _ s2) = s1 == s2 20 | (==) (PList _ l1 pp1) (PList _ l2 pp2) = l1 == l2 && pp1==pp2 21 | (==) a b = False 22 | 23 | noPP = ("", "") -- No pre- or postfix 24 | 25 | instance Show SrcSpan where 26 | show a = "" -- we might want to improvide this 27 | 28 | class Parseable a where 29 | toParseTree :: a -> ParseTree 30 | 31 | instance Parseable ParseTree where 32 | toParseTree = id 33 | 34 | instance Parseable Integer where 35 | toParseTree int = (PSym noSrcSpan (show int)) 36 | 37 | instance Parseable Int where 38 | toParseTree int = (PSym noSrcSpan (show int)) 39 | 40 | instance Parseable Char where 41 | toParseTree char = (PSym noSrcSpan ("#\\" ++ [char])) 42 | 43 | --instance Parseable String where 44 | -- toParseTree str = (PString noSrcSpan str) 45 | 46 | instance Parseable a => Parseable [a] where 47 | toParseTree ps = (PList noSrcSpan (map toParseTree ps) noPP) 48 | 49 | macroSrcSpan = mkGeneralSrcSpan (mkFastString ("")) 50 | 51 | -- Trivial helpers that might be useful to external macros 52 | 53 | parseQual str = 54 | let rstr = reverse str 55 | in case (dropWhile (/= '.') rstr, takeWhile (/= '.') rstr) of 56 | ("", _) -> ("", str) -- str doesn't contain a dot 57 | (_, "") -> ("", str) -- str ends with a dot such as "abc.kuh." or simply "." 58 | (qual, sym) -> (reverse (tail qual), reverse sym) -- found qualified name 59 | 60 | parseOrig str = 61 | case (takeWhile (/= ':') str, dropWhile (/= ':') str) of 62 | ("", _) -> wrappedParseQual "" str -- str starts with ":" 63 | (_, "") -> wrappedParseQual "" str -- str doesn't contain ":" 64 | (qual, str') -> case parseQual (tail str') of -- str contains ":" 65 | ("", sym) -> ("","", str) -- but no module name found, hence no orig. such as "a:a" 66 | (mod, sym) -> (qual, mod, sym) -- found original, qualified module name, and symbol 67 | where wrappedParseQual qual str = 68 | let (modname, sym) = parseQual str 69 | in (qual, modname, sym) 70 | 71 | convertDec str = 72 | case Numeric.readDec str of 73 | [(int, "")] -> Just int 74 | _ -> Nothing 75 | 76 | convertHex str 77 | | (isPrefixOf "0x" str || isPrefixOf "0X" str) 78 | = case Numeric.readHex (drop 2 str) of 79 | [(int, "")] -> Just int 80 | _ -> (error "Invalid hex number") 81 | | otherwise = Nothing 82 | 83 | convertOct str 84 | | isPrefixOf "0o" str || isPrefixOf "0o" str 85 | = case Numeric.readOct (drop 2 str) of 86 | [(int, "")] -> Just int 87 | _ -> (error "Invalid octal number") 88 | | otherwise = Nothing 89 | 90 | convertNumber str = (convertOct str) `orElse'` (convertHex str) `orElse'` (convertDec str) 91 | 92 | convertChar str 93 | | isPrefixOf "#\\" str && length str == 3 = Just (str !! 2) 94 | | otherwise = Nothing 95 | 96 | convertRational str = 97 | case readRationalS str of 98 | [(rat, "")] -> Just rat 99 | _ -> Nothing 100 | 101 | convertString str 102 | | isPrefixOf "\"" str && isSuffixOf "\"" str = Just (tail (take ((length str) - 1) str)) -- FIXMELSK this looks a bit ugly 103 | | otherwise = Nothing 104 | 105 | 106 | orElse' :: Maybe a -> Maybe a -> Maybe a 107 | orElse' a b = 108 | case a of 109 | (Just _) -> a 110 | Nothing -> b 111 | -------------------------------------------------------------------------------- /testsuite/timeout/timeout.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -cpp #-} 2 | 3 | import Control.Concurrent (forkIO, threadDelay) 4 | import Control.Concurrent.MVar (putMVar, takeMVar, newEmptyMVar) 5 | import Control.Exception (try) 6 | import Data.Maybe (isNothing) 7 | import System.Cmd (system) 8 | import System.Environment (getArgs) 9 | import System.Exit (exitWith, ExitCode(ExitFailure)) 10 | import System.IO (hPutStrLn, stderr) 11 | import System.Process 12 | import Control.Monad (when) 13 | #if !defined(mingw32_HOST_OS) 14 | import System.Process.Internals (mkProcessHandle) 15 | import System.Posix.Process (forkProcess, createSession, executeFile) 16 | import System.Posix.Signals (installHandler, Handler(Catch), 17 | signalProcessGroup, sigINT, sigTERM, sigKILL ) 18 | #endif 19 | 20 | 21 | 22 | #if !defined(mingw32_HOST_OS) 23 | main = do 24 | args <- getArgs 25 | case args of 26 | [secs,cmd] -> do 27 | m <- newEmptyMVar 28 | mp <- newEmptyMVar 29 | installHandler sigINT (Catch (putMVar m Nothing)) Nothing 30 | forkIO (do threadDelay (read secs * 1000000) 31 | putMVar m Nothing 32 | ) 33 | forkIO (do try (do pid <- systemSession cmd 34 | ph <- mkProcessHandle pid 35 | putMVar mp (pid,ph) 36 | r <- waitForProcess ph 37 | putMVar m (Just r)) 38 | return ()) 39 | 40 | (pid,ph) <- takeMVar mp 41 | r <- takeMVar m 42 | case r of 43 | Nothing -> do 44 | hPutStrLn stderr "Timeout happened...killing process..." 45 | killProcess pid ph 46 | exitWith (ExitFailure 99) 47 | Just r -> do 48 | exitWith r 49 | _other -> do hPutStrLn stderr "timeout: bad arguments" 50 | exitWith (ExitFailure 1) 51 | 52 | systemSession cmd = 53 | forkProcess $ do 54 | createSession 55 | executeFile "/bin/sh" False ["-c", cmd] Nothing 56 | -- need to use exec() directly here, rather than something like 57 | -- System.Process.system, because we are in a forked child and some 58 | -- pthread libraries get all upset if you start doing certain 59 | -- things in a forked child of a pthread process, such as forking 60 | -- more threads. 61 | 62 | killProcess pid ph = do 63 | try (signalProcessGroup sigTERM pid) 64 | checkReallyDead 10 65 | where 66 | checkReallyDead 0 = hPutStrLn stderr "checkReallyDead: Giving up" 67 | checkReallyDead (n+1) = 68 | do threadDelay (3*100000) -- 3/10 sec 69 | m <- getProcessExitCode ph 70 | when (isNothing m) $ do 71 | try (signalProcessGroup sigKILL pid) 72 | checkReallyDead n 73 | 74 | #else 75 | 76 | main = do 77 | args <- getArgs 78 | case args of 79 | [secs,cmd] -> do 80 | m <- newEmptyMVar 81 | mp <- newEmptyMVar 82 | forkIO (do threadDelay (read secs * 1000000) 83 | putMVar m Nothing 84 | ) 85 | -- Assume sh.exe is in the path 86 | forkIO (do p <- runProcess 87 | "sh" ["-c",cmd] 88 | Nothing Nothing Nothing Nothing Nothing 89 | putMVar mp p 90 | r <- waitForProcess p 91 | putMVar m (Just r)) 92 | p <- takeMVar mp 93 | r <- takeMVar m 94 | case r of 95 | Nothing -> do 96 | hPutStrLn stderr "Timeout happened...killing process..." 97 | killProcess p 98 | exitWith (ExitFailure 99) 99 | Just r -> do 100 | exitWith r 101 | _other -> do hPutStrLn stderr $ "timeout: bad arguments " ++ show args 102 | exitWith (ExitFailure 1) 103 | 104 | killProcess p = do 105 | terminateProcess p 106 | -- ToDo: we should kill the process and its descendents on Win32 107 | threadDelay (3*100000) -- 3/10 sec 108 | m <- getProcessExitCode p 109 | when (isNothing m) $ killProcess p 110 | 111 | #endif 112 | -------------------------------------------------------------------------------- /testsuite/driver/runtests.py: -------------------------------------------------------------------------------- 1 | # 2 | # (c) Simon Marlow 2002 3 | # 4 | 5 | # ToDo: 6 | # GHCi tests 7 | # expect failure for some ways only 8 | 9 | import sys 10 | import os 11 | import string 12 | import getopt 13 | import time 14 | 15 | from testutil import * 16 | from testglobals import * 17 | 18 | global config 19 | config = getConfig() # get it from testglobals 20 | 21 | # ----------------------------------------------------------------------------- 22 | # cmd-line options 23 | 24 | long_options = [ 25 | "config=", # config file 26 | "rootdir=", # root of tree containing tests (default: .) 27 | "output-summary=", # file in which to save the (human-readable) summary 28 | "only=", # just this test (can be give multiple --only= flags) 29 | "way=", # just this way 30 | "skipway=", # skip this way 31 | "threads=", # threads to run simultaneously 32 | ] 33 | 34 | opts, args = getopt.getopt(sys.argv[1:], "e:", long_options) 35 | 36 | for opt,arg in opts: 37 | if opt == '--config': 38 | execfile(arg) 39 | 40 | # -e is a string to execute from the command line. For example: 41 | # testframe -e 'config.compiler=ghc-5.04' 42 | if opt == '-e': 43 | exec arg 44 | 45 | if opt == '--rootdir': 46 | config.rootdir = arg 47 | 48 | if opt == '--output-summary': 49 | config.output_summary = arg 50 | 51 | if opt == '--times-file': 52 | config.times_file = arg 53 | 54 | if opt == '--only': 55 | config.only.append(arg) 56 | 57 | if opt == '--way': 58 | if (arg not in config.run_ways and arg not in config.compile_ways and arg not in config.other_ways): 59 | sys.stderr.write("ERROR: requested way \'" + 60 | arg + "\' does not exist\n") 61 | sys.exit(1) 62 | config.run_ways = filter(eq(arg), config.run_ways + config.other_ways) 63 | config.compile_ways = filter(eq(arg), config.compile_ways + config.other_ways) 64 | 65 | if opt == '--skipway': 66 | if (arg not in config.run_ways and arg not in config.compile_ways and arg not in config.other_ways): 67 | sys.stderr.write("ERROR: requested way \'" + 68 | arg + "\' does not exist\n") 69 | sys.exit(1) 70 | config.other_ways = filter(neq(arg), config.other_ways) 71 | config.run_ways = filter(neq(arg), config.run_ways) 72 | config.compile_ways = filter(neq(arg), config.compile_ways) 73 | 74 | if opt == '--threads': 75 | config.threads = int(arg) 76 | 77 | # Can't import this earlier as we need to know if threading will be 78 | # enabled or not 79 | from testlib import * 80 | 81 | global testopts_local 82 | testopts_local.x = TestOptions() 83 | 84 | global thisdir_testopts 85 | thisdir_testopts = getThisDirTestOpts() 86 | 87 | if config.use_threads: 88 | t.lock = threading.Lock() 89 | t.thread_pool = threading.Condition(t.lock) 90 | t.running_threads = 0 91 | 92 | # if timeout == -1 then we try to calculate a sensible value 93 | if config.timeout == -1: 94 | config.timeout = int(read_no_crs(config.top + '/timeout/calibrate.out')) 95 | 96 | print 'Timeout is ' + str(config.timeout) 97 | 98 | # ----------------------------------------------------------------------------- 99 | # The main dude 100 | 101 | t_files = findTFiles(config.rootdir) 102 | 103 | print 'Found', len(t_files), '.T files...' 104 | 105 | t = getTestRun() 106 | 107 | t.start_time = chop(os.popen('date').read()) 108 | print 'Beginning test run at', t.start_time 109 | 110 | # set stdout to unbuffered (is this the best way to do it?) 111 | sys.stdout.flush() 112 | sys.stdout = os.fdopen(sys.__stdout__.fileno(), "w", 0) 113 | 114 | times = {} 115 | 116 | for file in t_files: 117 | print '====> Running', file 118 | newTestDir(os.path.dirname(file)) 119 | try: 120 | if config.use_threads: 121 | t.running_threads=0 122 | start = time.time() 123 | execfile(file) 124 | end = time.time() 125 | times[file] = end - start 126 | if config.use_threads: 127 | t.thread_pool.acquire() 128 | while t.running_threads>0: 129 | t.thread_pool.wait() 130 | t.thread_pool.release() 131 | except: 132 | print '*** found an error while executing ', file, ':' 133 | traceback.print_exc() 134 | 135 | summary(t, sys.stdout) 136 | 137 | if config.output_summary != '': 138 | summary(t, open(config.output_summary, 'w')) 139 | 140 | if config.times_file != '': 141 | h = open(config.times_file, 'w') 142 | for (k, v) in times.items(): 143 | h.write(k + ',' + str(v) + '\n') 144 | h.close() 145 | 146 | sys.exit(0) 147 | 148 | -------------------------------------------------------------------------------- /testsuite/tests/liskell/testprogs/TicTacToe.lsk: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Tic Tac Toe implemented in pure Liskell 3 | ;;; 4 | ;;; Clemens Fruhwirth 5 | ;;; Data structures: move = Set Int 6 | ;;; state = a tuple of moves 7 | ;;; player = character 8 | 9 | (defmodule TicTacToe (main) 10 | ((Data.List (flags qualified (as List)) sortBy map) 11 | Data.Set 12 | System)) 13 | 14 | (define board-construct (, empty empty)) 15 | 16 | (define empty-board (fromList ([] 1 2 3 4 5 6 7 8 9))) 17 | (define (board-valid-moves (, stateA stateB)) 18 | (\\ empty-board 19 | (union stateA stateB))) 20 | 21 | (define (board-is-valid-move? state move) 22 | (member move (board-valid-moves state))) 23 | 24 | (define (board-add-move (, stateA stateB) move player) 25 | (case player 26 | (#\a (, (insert move stateA) 27 | stateB)) 28 | (#\b (, stateA 29 | (insert move stateB))))) 30 | 31 | (define (board-get-move (, stateA stateB) move) 32 | (if (member move stateA) 33 | #\a 34 | (if (member move stateB) 35 | #\b 36 | #\x))) 37 | 38 | (define (move->print-char state move) 39 | (case (board-get-move state move) 40 | (#\a "X") 41 | (#\b "O") 42 | (#\x " "))) 43 | 44 | (define (print-board state) 45 | (let (((print-states x y z headstr tailstr) 46 | (print (++ headstr 47 | (++ (move->print-char state x) 48 | (++ " | " 49 | (++ (move->print-char state y) 50 | (++ " | " 51 | (++ (move->print-char state z) 52 | tailstr))))))))) 53 | (>> (print "7---+-8-+---9") 54 | (>> (print-states 7 8 9 "| " " |") 55 | (>> (print "+---+-5-+---+") 56 | (>> (print-states 4 5 6 "4 " " 6") 57 | (>> (print "+---+---+---+") 58 | (>> (print-states 1 2 3 "| " " |") 59 | (print "1---+-2-+---3"))))))))) 60 | 61 | 62 | (define (prompt-move state) 63 | (>> (print (++ "Please enter a move(" 64 | (++ (show (board-valid-moves state)) 65 | ") :"))) 66 | (>>= (:: readLn (IO Int)) 67 | (lambda (move) 68 | (if (board-is-valid-move? state move) 69 | (return move) 70 | (prompt-move state)))))) 71 | 72 | (define win-combs (Prelude.map fromList 73 | ([] ([] 1 2 3) ([] 4 5 6) ([] 7 8 9) 74 | ([] 1 4 7) ([] 2 5 8) ([] 3 6 9) 75 | ([] 1 5 9) ([] 3 5 7)))) 76 | (define (xs-in-y xs y) 77 | (case xs 78 | (([]) False) 79 | ((: x xs) (|| (isSubsetOf x y) 80 | (xs-in-y xs y))))) 81 | (define (player state _) 82 | (>> (print-board state) 83 | (prompt-move state))) 84 | 85 | (define (game-over? (, stateA stateB)) 86 | (if (xs-in-y win-combs stateA) 87 | (Just #\a) 88 | (if (xs-in-y win-combs stateB) 89 | (Just #\b) 90 | (if (Data.Set.null (board-valid-moves (, stateA stateB))) 91 | (Just #\d) 92 | Nothing)))) 93 | 94 | (define (game-loop player opponent player-fn opponent-fn state) 95 | (case (game-over? state) 96 | ((Just result) (>> (print-board state) 97 | (>> (print (show result)) 98 | (return result)))) 99 | (Nothing (>>= (player-fn state player) 100 | (lambda (move) 101 | (let ((new-board (board-add-move state move player))) 102 | (game-loop opponent player opponent-fn player-fn new-board))))))) 103 | 104 | (define (rate-outcome-a (, _ result)) 105 | (case result 106 | (#\a 1) 107 | (#\d 0) 108 | (#\b (- 0 1)))) 109 | 110 | (define (rate-outcome-b result-cons) 111 | (- 0 (rate-outcome-a result-cons))) 112 | 113 | (define (opponent ego) 114 | (case ego 115 | (#\a #\b) 116 | (#\b #\a))) 117 | 118 | 119 | (define (computer-player state ego) 120 | (case (game-over? state) 121 | ((Just a) (, undefined a)) 122 | (Nothing 123 | (let ((results 124 | (List.map 125 | (lambda (move) 126 | (let ((new-state (board-add-move state move ego)) 127 | ((, _ opresult) 128 | (computer-player new-state (opponent ego)))) 129 | (, move opresult))) 130 | (Data.Set.toList (board-valid-moves state)))) 131 | (rate-with (case ego 132 | (#\a rate-outcome-a) 133 | (#\b rate-outcome-b))) 134 | (sorted-results 135 | (List.sortBy (lambda (result1 result2) 136 | (compare (rate-with result2) 137 | (rate-with result1))) 138 | results))) 139 | ;; return the best move 140 | (head sorted-results))))) 141 | 142 | (define (computer state player) 143 | (return (fst (computer-player state player)))) 144 | 145 | (define main 146 | (>>= System.getArgs 147 | (mapM (lambda (str) 148 | (case str 149 | ("hh" (game-loop #\a #\b player player (board-construct))) 150 | ("ch" (game-loop #\a #\b computer player (board-construct))) 151 | ("hc" (game-loop #\a #\b player computer (board-construct))) 152 | ("cc" (game-loop #\a #\b computer computer (board-construct)))))))) 153 | -------------------------------------------------------------------------------- /testsuite/mk/test.mk: -------------------------------------------------------------------------------- 1 | # ----------------------------------------------------------------------------- 2 | # Examples of use: 3 | # 4 | # make -- run all the tests in the current directory 5 | # make verbose -- as make test, but up the verbosity 6 | # make accept -- run the tests, accepting the current output 7 | # 8 | # The following variables may be set on the make command line: 9 | # 10 | # TEST -- specific test to run 11 | # TESTS -- specific tests to run (same as $TEST really) 12 | # EXTRA_HC_OPTS -- extra flags to send to the Haskell compiler 13 | # EXTRA_RUNTEST_OPTS -- extra flags to give the test driver 14 | # CONFIG -- use a different configuration file 15 | # COMPILER -- select a configuration file from config/ 16 | # THREADS -- run n tests at once 17 | # 18 | # ----------------------------------------------------------------------------- 19 | 20 | include $(TOP)/mk/wordsize.mk 21 | 22 | $(TOP)/mk/wordsize.mk : $(TOP)/mk/wordsize.mk.in 23 | $(CPP) $(RAWCPP_FLAGS) -x c $(TOP)/mk/wordsize.mk.in > $(TOP)/mk/wordsize.mk 24 | 25 | ifeq "$(PYTHON)" "" 26 | PYTHON=python 27 | #$(error Python must be installed in order to use the testsuite) 28 | endif 29 | 30 | # export the value of $MAKE for invocation in ghc-regress/driver/ 31 | export MAKE 32 | 33 | # ghastly hack, because the driver requires that $tool be an absolute path name. 34 | ifeq "$(Windows)" "YES" 35 | GHC_STAGE1_ABS = $(GHC_COMPILER_DIR_ABS)/stage1/ghc-inplace.bat 36 | GHC_STAGE2_ABS = $(GHC_COMPILER_DIR_ABS)/stage2/ghc-inplace.bat 37 | GHC_STAGE3_ABS = $(GHC_COMPILER_DIR_ABS)/stage3/ghc-inplace.bat 38 | GHC_PKG_ABS = $(GHC_PKG_DIR_ABS)/ghc-pkg-inplace.bat 39 | else 40 | GHC_STAGE1_ABS = liskell 41 | GHC_STAGE2_ABS = liskell 42 | GHC_STAGE3_ABS = liskell 43 | GHC_PKG_ABS = $(GHC_PKG_DIR_ABS)/ghc-pkg-inplace 44 | endif 45 | 46 | RUNTESTS = $(TOP)/driver/runtests.py 47 | COMPILER = ghc 48 | CONFIG = $(TOP)/config/$(COMPILER) 49 | 50 | # can be overriden from the command line 51 | ifneq "$(stage)" "" 52 | TEST_HC = $(GHC_STAGE$(stage)_ABS) 53 | else 54 | TEST_HC = $(GHC_STAGE1_ABS) 55 | endif 56 | 57 | RUNTEST_OPTS = 58 | 59 | GHC_PKG = $(GHC_PKG_ABS) 60 | 61 | ifeq "$(GhcWithNativeCodeGen)" "YES" 62 | RUNTEST_OPTS += -e ghc_with_native_codegen=1 63 | else 64 | RUNTEST_OPTS += -e ghc_with_native_codegen=0 65 | endif 66 | 67 | ifeq "$(filter p, $(GhcLibWays))" "p" 68 | RUNTEST_OPTS += -e ghc_with_profiling=1 69 | else 70 | RUNTEST_OPTS += -e ghc_with_profiling=0 71 | endif 72 | 73 | ifeq "$(filter u, $(GhcLibWays))" "u" 74 | RUNTEST_OPTS += -e ghc_with_unreg=1 75 | else 76 | RUNTEST_OPTS += -e ghc_with_unreg=0 77 | endif 78 | 79 | ifeq "$(GhcWithInterpreter)" "YES" 80 | RUNTEST_OPTS += -e ghc_with_interpreter=1 81 | else 82 | RUNTEST_OPTS += -e ghc_with_interpreter=0 83 | endif 84 | 85 | ifeq "$(filter thr, $(GhcRTSWays))" "thr" 86 | RUNTEST_OPTS += -e ghc_with_threaded_rts=1 87 | else 88 | RUNTEST_OPTS += -e ghc_with_threaded_rts=0 89 | endif 90 | 91 | ifeq "$(GhcWithSMP)" "YES" 92 | RUNTEST_OPTS += -e ghc_with_smp=1 93 | else 94 | RUNTEST_OPTS += -e ghc_with_smp=0 95 | endif 96 | 97 | ifneq "$(THREADS)" "" 98 | RUNTEST_OPTS += --thread=$(THREADS) 99 | else 100 | USETHREADS=0 101 | endif 102 | 103 | RUNTEST_OPTS += \ 104 | --config=$(CONFIG) \ 105 | -e config.compiler=\"$(TEST_HC)\" \ 106 | -e config.compiler_always_flags.append"(\"-D$(HostPlatform_CPP)\")" \ 107 | -e config.compiler_always_flags.append"(\"$(EXTRA_HC_OPTS)\")" \ 108 | -e config.ghc_pkg=\"$(GHC_PKG)\" \ 109 | -e config.platform=\"$(TARGETPLATFORM)\" \ 110 | -e config.wordsize=\"$(WORDSIZE)\" \ 111 | -e default_testopts.cleanup=\"$(CLEANUP)\" \ 112 | -e "if '$(USETHREADS)': config.use_threads=int($(USETHREADS))" \ 113 | -e config.timeout="int($(TIMEOUT)) or config.timeout" \ 114 | -e config.timeout_prog=\"$(TOP)/timeout/timeout\" \ 115 | -e config.top=\"$(TOP)\" \ 116 | $(EXTRA_RUNTEST_OPTS) 117 | 118 | # HostPlatform_CPP should ideally be TargetPlatform_CPP, but that 119 | # doesn't exist; they're always the same anyway 120 | 121 | ifeq "$(fast)" "YES" 122 | setfast = -e config.fast=1 123 | else 124 | setfast = 125 | endif 126 | 127 | ifeq "$(accept)" "YES" 128 | setaccept = -e config.accept=1 129 | else 130 | setaccept = 131 | endif 132 | 133 | TESTS = 134 | TEST = 135 | WAY = 136 | 137 | all :: test 138 | 139 | timeout : $(TOP)/timeout/timeout$(exeext) 140 | 141 | $(TOP)/timeout/timeout$(exeext) : 142 | @echo "Looks like you don't have timeout, building it first..." 143 | cd $(TOP)/timeout && $(MAKE) $(MFLAGS) all 144 | 145 | test: timeout 146 | $(PYTHON) $(RUNTESTS) $(RUNTEST_OPTS) \ 147 | $(patsubst %, --only=%, $(TEST)) \ 148 | $(patsubst %, --only=%, $(TESTS)) \ 149 | $(patsubst %, --way=%, $(WAY)) \ 150 | $(patsubst %, --skipway=%, $(SKIPWAY)) \ 151 | $(setfast) \ 152 | $(setaccept) 153 | 154 | verbose: test 155 | 156 | accept: 157 | $(MAKE) accept=YES 158 | 159 | fast: 160 | $(MAKE) fast=YES 161 | 162 | -------------------------------------------------------------------------------- /testsuite/driver/testglobals.py: -------------------------------------------------------------------------------- 1 | # 2 | # (c) Simon Marlow 2002 3 | # 4 | 5 | # ----------------------------------------------------------------------------- 6 | # Configuration info 7 | 8 | # There is a single global instance of this structure, stored in the 9 | # variable config below. The fields of the structure are filled in by 10 | # the appropriate config script(s) for this compiler/platform, in 11 | # ../config. 12 | # 13 | # Bits of the structure may also be filled in from the command line, 14 | # via the build system, using the '-e' option to runtests. 15 | 16 | class TestConfig: 17 | def __init__(self): 18 | 19 | # Where the testsuite root is 20 | self.top = '' 21 | 22 | # Directory below which to look for test description files (foo.T) 23 | self.rootdir = '.' 24 | 25 | # Run these tests only (run all tests if empty) 26 | self.only = [] 27 | 28 | # Accept new output which differs from the sample? 29 | self.accept = 0 30 | 31 | # File in which to save the summary 32 | self.output_summary = '' 33 | 34 | # File in which to save the times 35 | self.times_file = '' 36 | 37 | # What platform are we running on? 38 | self.platform = '' 39 | 40 | # What is the wordsize (in bits) of this platform? 41 | self.wordsize = '' 42 | 43 | # Verbosity level 44 | self.verbose = 1 45 | 46 | # run the "fast" version of the test suite 47 | self.fast = 0 48 | 49 | # Compiler type (ghc, hugs, nhc, etc.) 50 | self.compiler_type = '' 51 | 52 | # Path to the compiler 53 | self.compiler = '' 54 | # and ghc-pkg 55 | self.ghc_pkg = '' 56 | 57 | # Flags we always give to this compiler 58 | self.compiler_always_flags = [] 59 | 60 | # Which ways to run tests (when compiling and running respectively) 61 | # Other ways are added from the command line if we have the appropriate 62 | # libraries. 63 | self.compile_ways = [] 64 | self.run_ways = [] 65 | 66 | # Lists of flags for each way 67 | self.way_flags = {} 68 | self.way_rts_flags = {} 69 | 70 | # Do we have profiling support? 71 | self.have_profiling = False 72 | 73 | # the timeout program 74 | self.timeout_prog = '' 75 | self.timeout = 300 76 | 77 | # threads 78 | self.threads = 1 79 | self.use_threads = 1 80 | 81 | global config 82 | config = TestConfig() 83 | 84 | def getConfig(): 85 | return config 86 | 87 | # ----------------------------------------------------------------------------- 88 | # Information about the current test run 89 | 90 | class TestRun: 91 | def __init__(self): 92 | self.start_time = '' 93 | self.total_tests = 0 94 | self.total_test_cases = 0 95 | self.n_framework_failures = 0 96 | self.framework_failures = {} 97 | self.n_tests_skipped = 0 98 | self.tests_skipped = {} 99 | self.n_expected_passes = 0 100 | self.expected_passes = {} 101 | self.n_expected_failures = 0 102 | self.expected_failures = {} 103 | self.n_unexpected_passes = 0 104 | self.unexpected_passes = {} 105 | self.n_unexpected_failures = 0 106 | self.unexpected_failures = {} 107 | 108 | global t 109 | t = TestRun() 110 | 111 | def getTestRun(): 112 | return t 113 | 114 | # ----------------------------------------------------------------------------- 115 | # Information about the current test 116 | 117 | class TestOptions: 118 | def __init__(self): 119 | 120 | # skip this test? 121 | self.skip = 0; 122 | 123 | # skip these ways 124 | self.omit_ways = [] 125 | 126 | # skip all ways except these ([] == do all ways) 127 | self.only_ways = [] 128 | 129 | # the result we normally expect for this test 130 | self.expect = 'pass'; 131 | 132 | # override the expected result for certain ways 133 | self.expect_fail_for = []; 134 | 135 | # the stdin file that this test will use (empty for .stdin) 136 | self.stdin = '' 137 | 138 | # compile this test to .hc only 139 | self.compile_to_hc = 0 140 | 141 | # extra compiler opts for this test 142 | self.extra_hc_opts = '' 143 | 144 | # extra run opts for this test 145 | self.extra_run_opts = '' 146 | 147 | # expected exit code 148 | self.exit_code = 0 149 | 150 | # should we clean up after ourselves? 151 | self.cleanup = '' 152 | 153 | # should we run this test alone, i.e. not run it in parallel with 154 | # any other threads 155 | self.alone = 0 156 | 157 | # Does this test use a literate (.lhs) file? 158 | self.literate = 0 159 | 160 | # Does this test use a .c file? 161 | self.c_src = 0 162 | # Does this test use a .lsk file? 163 | self.liskell = 0 164 | 165 | # The default set of options 166 | global default_testopts 167 | default_testopts = TestOptions() 168 | 169 | -------------------------------------------------------------------------------- /GHCSalat/TcRnDriver4Lsk.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} 2 | 3 | ----------------------------------------------------------------------------- 4 | -- 5 | -- GHC Driver program 6 | -- 7 | -- (c) The University of Glasgow 2005 8 | -- 9 | ----------------------------------------------------------------------------- 10 | 11 | module GHCSalat.TcRnDriver4Lsk 12 | where 13 | 14 | #ifdef GHCI 15 | --import Linker ( HValue, linkExpr ) 16 | import Desugar ( deSugarExpr ) 17 | import GHCSalat.InteractiveUI ( interactiveUI ) 18 | import TcRnDriver -- ( tcRnStmt, tcRnExpr, tcRnType ) 19 | import PrelNames ( iNTERACTIVE ) 20 | #endif 21 | import LskToHs 22 | import LskParseTree 23 | import LskTransformationMonad 24 | import GHC.Exts 25 | import HscTypes 26 | import HsSyn 27 | import DynFlags ( defaultDynFlags ) 28 | 29 | import Panic 30 | 31 | import Control.Monad 32 | import HscMain as HM (compileExpr,hscStmt) 33 | 34 | -- The official GHC API 35 | -- Implementations of the various modes (--show-iface, mkdependHS. etc.) 36 | --import HscMain ( newHscEnv ) 37 | 38 | 39 | -- Various other random stuff that we need 40 | import HscTypes 41 | import SrcLoc 42 | import MonadUtils ( liftIO ) 43 | 44 | -- Standard Haskell libraries 45 | import Control.Monad 46 | import Data.List 47 | import Data.Maybe 48 | import Module 49 | import Parser 50 | import Outputable 51 | import ErrUtils 52 | import Lexer 53 | import StringBuffer 54 | import FastString 55 | import Control.Exception 56 | import Bag 57 | 58 | 59 | 60 | import TcRnMonad 61 | import RnExpr 62 | import TcSimplify 63 | import TcExpr 64 | import TcMType 65 | import Inst 66 | import TcEnv 67 | import FamInstEnv 68 | import TypeRep 69 | --- 70 | import HscMain hiding (compileExpr) 71 | import HscTypes 72 | import TcRnDriver 73 | import Type hiding (typeKind) 74 | import TcType hiding (typeKind) 75 | import InstEnv 76 | import Var 77 | import Id 78 | import IdInfo 79 | import Name hiding ( varName ) 80 | import NameSet 81 | import RdrName 82 | import VarSet 83 | import VarEnv 84 | import ByteCodeInstr 85 | import Linker 86 | import DynFlags 87 | import Unique 88 | import UniqSupply 89 | import Module 90 | import Panic 91 | import LazyUniqFM 92 | import Maybes 93 | import ErrUtils 94 | import Util 95 | import SrcLoc 96 | import BreakArray 97 | import RtClosureInspect 98 | import BasicTypes 99 | import Outputable 100 | import FastString 101 | import MonadUtils 102 | 103 | import Data.Dynamic 104 | import Data.List (find) 105 | import Control.Monad 106 | import Foreign 107 | import Foreign.C 108 | import GHC.Exts 109 | import Data.Array 110 | import Exception 111 | import Control.Concurrent 112 | import Data.List (sortBy) 113 | import Foreign.StablePtr 114 | import System.IO 115 | -- 116 | 117 | setInteractiveContext' :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a 118 | setInteractiveContext' hsc_env icxt thing_inside 119 | = let -- Initialise the tcg_inst_env with instances from all home modules. 120 | -- This mimics the more selective call to hptInstances in tcRnModule. 121 | (home_insts, home_fam_insts) = hptInstances hsc_env (\mod -> True) 122 | in 123 | updGblEnv (\env -> env { 124 | tcg_rdr_env = ic_rn_gbl_env icxt, 125 | tcg_inst_env = extendInstEnvList (tcg_inst_env env) home_insts, 126 | tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env env) 127 | home_fam_insts 128 | }) $ 129 | 130 | tcExtendGhciEnv (ic_tmp_ids icxt) $ 131 | -- tcExtendGhciEnv does lots: 132 | -- - it extends the local type env (tcl_env) with the given Ids, 133 | -- - it extends the local rdr env (tcl_rdr) with the Names from 134 | -- the given Ids 135 | -- - it adds the free tyvars of the Ids to the tcl_tyvars 136 | -- set. 137 | -- 138 | -- later ids in ic_tmp_ids must shadow earlier ones with the same 139 | -- OccName, and tcExtendIdEnv implements this behaviour. 140 | 141 | do { traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt)) 142 | ; thing_inside } 143 | 144 | 145 | tcRnExpr' :: HscEnv 146 | -> InteractiveContext 147 | -> LHsExpr RdrName 148 | -> IO (Messages, Maybe (LHsExpr TcId, Type)) 149 | tcRnExpr' hsc_env ictxt rdr_expr 150 | = initTcPrintErrors hsc_env (error "Juhu") $ 151 | setInteractiveContext' hsc_env ictxt $ do { 152 | 153 | (rn_expr, fvs) <- rnLExpr rdr_expr ; 154 | failIfErrsM ; 155 | 156 | -- Now typecheck the expression; 157 | -- it might have a rank-2 type (e.g. :t runST) 158 | ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ; 159 | ((qtvs, dict_insts, _), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ; 160 | tcSimplifyInteractive lie_top ; 161 | 162 | let { all_expr_ty = mkForAllTys qtvs $ 163 | mkFunTys (map (idType . instToId) dict_insts) $ 164 | res_ty } ; 165 | zonked <- zonkTcType all_expr_ty; 166 | return (tc_expr, zonked) 167 | } 168 | where 169 | smpl_doc = ptext (sLit "main expression") 170 | 171 | -------------------------------------------------------------------------------- /LskMain.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} 2 | 3 | ----------------------------------------------------------------------------- 4 | -- 5 | -- GHC Driver program 6 | -- 7 | -- (c) The University of Glasgow 2005 8 | -- 9 | ----------------------------------------------------------------------------- 10 | 11 | module LskMain 12 | where 13 | 14 | #ifdef GHCI 15 | --import Linker ( HValue, linkExpr ) 16 | import Desugar ( deSugarExpr ) 17 | import InteractiveUI ( interactiveUI ) 18 | import TcRnDriver -- ( tcRnStmt, tcRnExpr, tcRnType ) 19 | import PrelNames ( iNTERACTIVE ) 20 | #endif 21 | import GHC4Lsk 22 | import LskToHs 23 | import LskParseTree 24 | import LexLiskell 25 | import ParseLiskell 26 | import LskTransformationMonad 27 | import GHC.Exts 28 | import HscTypes 29 | 30 | import DynFlags ( defaultDynFlags ) 31 | 32 | import Panic 33 | 34 | import Control.Monad 35 | import HscMain as HM (compileExpr,hscStmt) 36 | 37 | -- The official GHC API 38 | -- Implementations of the various modes (--show-iface, mkdependHS. etc.) 39 | --import HscMain ( newHscEnv ) 40 | 41 | 42 | -- Various other random stuff that we need 43 | import HscTypes 44 | import SrcLoc 45 | import MonadUtils ( liftIO ) 46 | 47 | -- Standard Haskell libraries 48 | import Control.Monad 49 | import Data.List 50 | import Data.Maybe 51 | import Module 52 | import Parser 53 | import Outputable 54 | import ErrUtils 55 | import Lexer 56 | import StringBuffer 57 | import FastString 58 | import Control.Exception 59 | import Bag 60 | 61 | 62 | 63 | import TcRnMonad 64 | import RnExpr 65 | import TcSimplify 66 | import TcExpr 67 | import TcMType 68 | import Inst 69 | import TcEnv 70 | import FamInstEnv 71 | import TypeRep 72 | import TcRnDriver4Lsk 73 | --- 74 | import HscMain hiding (compileExpr) 75 | import HscTypes 76 | import TcRnDriver 77 | import Type hiding (typeKind) 78 | import TcType hiding (typeKind) 79 | import InstEnv 80 | import Var 81 | import Id 82 | import IdInfo 83 | import Name hiding ( varName ) 84 | import NameSet 85 | import RdrName 86 | import VarSet 87 | import VarEnv 88 | import ByteCodeInstr 89 | import Linker 90 | import DynFlags 91 | import Unique 92 | import UniqSupply 93 | import Module 94 | import Panic 95 | import LazyUniqFM 96 | import Maybes 97 | import ErrUtils 98 | import Util 99 | import SrcLoc 100 | import BreakArray 101 | import RtClosureInspect 102 | import BasicTypes 103 | import Outputable 104 | import FastString 105 | import MonadUtils 106 | 107 | import Data.Dynamic 108 | import Data.List (find) 109 | import Control.Monad 110 | import Foreign 111 | import Foreign.C 112 | import GHC.Exts 113 | import Data.Array 114 | import Exception 115 | import Control.Concurrent 116 | import Data.List (sortBy) 117 | import Foreign.StablePtr 118 | import System.IO 119 | -- 120 | 121 | compileHsExpr -- Compile a stmt all the way to an HValue, but don't run it 122 | :: GhcMonad m => 123 | HscEnv 124 | -> LHsExpr RdrName -- The statement 125 | -> m (Maybe HValue) 126 | -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error 127 | compileHsExpr hsc_env parsed_expr = do 128 | -- let parsed_expr = (L noSrcSpan (HsLit (HsVar (mkFastString "Test.foo")))); 129 | -- Rename and typecheck it 130 | let icontext = hsc_IC hsc_env 131 | (_,Just (tc_expr,zonkedType)) <- liftIO $ tcRnExpr' hsc_env icontext parsed_expr 132 | let rdr_env = ic_rn_gbl_env icontext 133 | type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext)) 134 | ds_expr <- ioMsgMaybe $ 135 | deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr 136 | -- Then desugar, code gen, and link it 137 | liftIO $ putStrLn (showSDoc $ ppr ds_expr) 138 | let src_span = srcLocSpan interactiveSrcLoc 139 | hval <- liftIO $ HM.compileExpr hsc_env src_span ds_expr 140 | -- return undefined 141 | liftIO $ putStrLn (showSDoc $ pprType zonkedType) 142 | return $ Just hval 143 | 144 | --} 145 | 146 | parseLSKModule :: GhcMonad m => ModSummary -> m ParsedModule 147 | parseLSKModule ms = do 148 | hsc_env0 <- getSession 149 | let hsc_env = hsc_env0 { hsc_dflags = ms_hspp_opts ms } 150 | stringbuffer <- liftIO $ hGetStringBuffer (ms_hspp_file ms) 151 | lskenv <- liftIO $ seedLskTrfEnv 152 | (Right (_,rdr_module)) <- liftIO $ runTM (liskell_transform_source stringbuffer noSrcLoc) (lskenv, newFreshVarStream "x") -- parseLiskell $ lexLiskell stringbuffer noSrcLoc 153 | return (ParsedModule ms rdr_module) 154 | 155 | libdir = "/home/clemens/deploy/ghc-6.10.1/lib/ghc-6.10.1/" 156 | main = 157 | defaultErrorHandler defaultDynFlags { ghcMode = CompManager, 158 | hscTarget = HscInterpreted, 159 | ghcLink = LinkInMemory, 160 | -- leave out hscOutName for now 161 | hscOutName = panic "Main.main:hscOutName not set", 162 | verbosity = 0 163 | } 164 | $ do 165 | runGhc (Just libdir) $ do 166 | dflags <- getSessionDynFlags 167 | setSessionDynFlags dflags 168 | dflags <- getSessionDynFlags 169 | let myModSum = ModSummary { 170 | ms_mod = mkModule mainPackageId (mkModuleName "Test"), -- (error "pkgid") (error "modname"), -- ^ Identity of the module 171 | ms_hsc_src = HsSrcFile, -- error "ms_hsc_src accessed", -- ^ The module source either plain Haskell, hs-boot or external core 172 | ms_location = error "ms_location accessed", -- ^ Location of the various files belonging to the module 173 | ms_hs_date = error "ms_hs_date accessed", -- ^ Timestamp of source file 174 | ms_obj_date = error "ms_obj_date accessed", -- ^ Timestamp of object, if we have one 175 | ms_srcimps = error "ms_srcimps accessed", -- ^ Source imports of the module 176 | ms_imps = error "ms_imps accessed", -- ^ Non-source imports of the module 177 | ms_hspp_file = "test_main.lsk", -- error "ms_hspp_file accessed", -- ^ Filename of preprocessed source file 178 | ms_hspp_opts = dflags, -- error "ms_hspp_opts accessed", -- ^ Cached flags from @OPTIONS@, @INCLUDE@ 179 | -- and @LANGUAGE@ pragmas in the modules source code 180 | ms_hspp_buf = Nothing -- error "ms_hspp_buf accessed" -- ^ The actual preprocessed source, if we have it 181 | }; 182 | -- target <- guessTarget "test_main.hs" Nothing 183 | -- setTargets [target] 184 | -- load LoadAllTargets 185 | parsed <- parseLSKModule myModSum 186 | typechecked <- typecheckModule parsed 187 | loaded <- GHC4Lsk.loadModule typechecked 188 | -- let withlinkables = loaded { 189 | prel_mod <- GHC4Lsk.findModule (GHC4Lsk.mkModuleName "Prelude") Nothing --(Just (error "hey it's him")) 190 | bar_mod <- GHC4Lsk.findModule (GHC4Lsk.mkModuleName "Test") (Just (error "hey it's me")) 191 | GHC4Lsk.setContext [] [prel_mod,bar_mod] 192 | lskenv <- liftIO $ seedLskTrfEnv 193 | (Right (_,hsExpr)) <- liftIO $ runTM (trf_expr_prim (PSym noSrcSpan "Test.foostring")) (lskenv, newFreshVarStream "x") 194 | hval <- withSession (\e -> compileHsExpr e hsExpr) 195 | let (Just thing_to_run) = unsafeCoerce# hval :: (Maybe String) 196 | liftIO $ putStrLn thing_to_run -- block $ forkIO $ do 197 | -- return () -- Exception.try (unblock $ rethrow dflags thing_to_run) --res <- Exception.try (unblock $ rethrow dflags thing) 198 | -- putMVar statusMVar (Complete res) -- empty: can't block 199 | return () 200 | -------------------------------------------------------------------------------- /GHCSalat/GhciMonad.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-} 2 | -- -fno-cse is needed for GLOBAL_VAR's to behave properly 3 | 4 | ----------------------------------------------------------------------------- 5 | -- 6 | -- Monadery code used in InteractiveUI 7 | -- 8 | -- (c) The GHC Team 2005-2006 9 | -- 10 | ----------------------------------------------------------------------------- 11 | 12 | module GHCSalat.GhciMonad where 13 | 14 | #include "HsVersions4Lsk.h" 15 | 16 | import qualified GHC 17 | import Outputable hiding (printForUser, printForUserPartWay) 18 | import qualified Outputable 19 | import qualified Pretty 20 | import Panic hiding (showException) 21 | import Util 22 | import DynFlags 23 | import HscTypes hiding (liftIO) 24 | import SrcLoc 25 | import Module 26 | import ObjLink 27 | import Linker 28 | import StaticFlags 29 | import qualified MonadUtils as MonadUtils 30 | import qualified ErrUtils as ErrUtils 31 | 32 | import Exception 33 | import Data.Maybe 34 | import Numeric 35 | import Data.Array 36 | import Data.Char 37 | import Data.Int ( Int64 ) 38 | import Data.IORef 39 | import Data.List 40 | import System.CPUTime 41 | import System.Environment 42 | import System.IO 43 | import Control.Monad as Monad 44 | import GHC.Exts 45 | 46 | import System.Console.Haskeline (CompletionFunc, InputT) 47 | import qualified System.Console.Haskeline as Haskeline 48 | import System.Console.Haskeline.Encoding 49 | import Control.Monad.Trans as Trans 50 | import qualified Data.ByteString as B 51 | 52 | ----------------------------------------------------------------------------- 53 | -- GHCi monad 54 | 55 | type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi) 56 | 57 | data GHCiState = GHCiState 58 | { 59 | progname :: String, 60 | args :: [String], 61 | prompt :: String, 62 | editor :: String, 63 | stop :: String, 64 | options :: [GHCiOption], 65 | prelude :: GHC.Module, 66 | break_ctr :: !Int, 67 | breaks :: ![(Int, BreakLocation)], 68 | tickarrays :: ModuleEnv TickArray, 69 | -- tickarrays caches the TickArray for loaded modules, 70 | -- so that we don't rebuild it each time the user sets 71 | -- a breakpoint. 72 | -- ":" at the GHCi prompt repeats the last command, so we 73 | -- remember is here: 74 | last_command :: Maybe Command, 75 | cmdqueue :: [String], 76 | remembered_ctx :: [(CtxtCmd, [String], [String])], 77 | -- we remember the :module commands between :loads, so that 78 | -- on a :reload we can replay them. See bugs #2049, 79 | -- \#1873, #1360. Previously we tried to remember modules that 80 | -- were supposed to be in the context but currently had errors, 81 | -- but this was complicated. Just replaying the :module commands 82 | -- seems to be the right thing. 83 | ghc_e :: Bool -- True if this is 'ghc -e' (or runghc) 84 | } 85 | 86 | data CtxtCmd 87 | = SetContext 88 | | AddModules 89 | | RemModules 90 | 91 | type TickArray = Array Int [(BreakIndex,SrcSpan)] 92 | 93 | data GHCiOption 94 | = ShowTiming -- show time/allocs after evaluation 95 | | ShowType -- show the type of expressions 96 | | RevertCAFs -- revert CAFs after every evaluation 97 | deriving Eq 98 | 99 | data BreakLocation 100 | = BreakLocation 101 | { breakModule :: !GHC.Module 102 | , breakLoc :: !SrcSpan 103 | , breakTick :: {-# UNPACK #-} !Int 104 | , onBreakCmd :: String 105 | } 106 | 107 | instance Eq BreakLocation where 108 | loc1 == loc2 = breakModule loc1 == breakModule loc2 && 109 | breakTick loc1 == breakTick loc2 110 | 111 | prettyLocations :: [(Int, BreakLocation)] -> SDoc 112 | prettyLocations [] = text "No active breakpoints." 113 | prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs 114 | 115 | instance Outputable BreakLocation where 116 | ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+> 117 | if null (onBreakCmd loc) 118 | then empty 119 | else doubleQuotes (text (onBreakCmd loc)) 120 | 121 | recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int) 122 | recordBreak brkLoc = do 123 | st <- getGHCiState 124 | let oldActiveBreaks = breaks st 125 | -- don't store the same break point twice 126 | case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of 127 | (nm:_) -> return (True, nm) 128 | [] -> do 129 | let oldCounter = break_ctr st 130 | newCounter = oldCounter + 1 131 | setGHCiState $ st { break_ctr = newCounter, 132 | breaks = (oldCounter, brkLoc) : oldActiveBreaks 133 | } 134 | return (False, oldCounter) 135 | 136 | newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a } 137 | 138 | reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a 139 | reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s 140 | 141 | reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a 142 | reifyGHCi f = GHCi f' 143 | where 144 | -- f' :: IORef GHCiState -> Ghc a 145 | f' gs = reifyGhc (f'' gs) 146 | -- f'' :: IORef GHCiState -> Session -> IO a 147 | f'' gs s = f (s, gs) 148 | 149 | startGHCi :: GHCi a -> GHCiState -> Ghc a 150 | startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref 151 | 152 | instance Monad GHCi where 153 | (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s 154 | return a = GHCi $ \_ -> return a 155 | 156 | instance Functor GHCi where 157 | fmap f m = m >>= return . f 158 | 159 | ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a 160 | ghciHandleGhcException = handleGhcException 161 | 162 | getGHCiState :: GHCi GHCiState 163 | getGHCiState = GHCi $ \r -> liftIO $ readIORef r 164 | setGHCiState :: GHCiState -> GHCi () 165 | setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s 166 | 167 | liftGhc :: Ghc a -> GHCi a 168 | liftGhc m = GHCi $ \_ -> m 169 | 170 | instance MonadUtils.MonadIO GHCi where 171 | liftIO = liftGhc . MonadUtils.liftIO 172 | 173 | instance Trans.MonadIO Ghc where 174 | liftIO = MonadUtils.liftIO 175 | 176 | instance GhcMonad GHCi where 177 | setSession s' = liftGhc $ setSession s' 178 | getSession = liftGhc $ getSession 179 | 180 | instance GhcMonad (InputT GHCi) where 181 | setSession = lift . setSession 182 | getSession = lift getSession 183 | 184 | instance MonadUtils.MonadIO (InputT GHCi) where 185 | liftIO = Trans.liftIO 186 | 187 | instance WarnLogMonad (InputT GHCi) where 188 | setWarnings = lift . setWarnings 189 | getWarnings = lift getWarnings 190 | 191 | instance ExceptionMonad GHCi where 192 | gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r) 193 | gblock (GHCi m) = GHCi $ \r -> gblock (m r) 194 | gunblock (GHCi m) = GHCi $ \r -> gunblock (m r) 195 | 196 | instance WarnLogMonad GHCi where 197 | setWarnings warns = liftGhc $ setWarnings warns 198 | getWarnings = liftGhc $ getWarnings 199 | 200 | instance MonadIO GHCi where 201 | liftIO = io 202 | 203 | instance Haskeline.MonadException GHCi where 204 | catch = gcatch 205 | block = gblock 206 | unblock = gunblock 207 | 208 | instance ExceptionMonad (InputT GHCi) where 209 | gcatch = Haskeline.catch 210 | gblock = Haskeline.block 211 | gunblock = Haskeline.unblock 212 | 213 | -- for convenience... 214 | getPrelude :: GHCi Module 215 | getPrelude = getGHCiState >>= return . prelude 216 | 217 | getDynFlags :: GhcMonad m => m DynFlags 218 | getDynFlags = do 219 | GHC.getSessionDynFlags 220 | 221 | setDynFlags :: DynFlags -> GHCi [PackageId] 222 | setDynFlags dflags = do 223 | GHC.setSessionDynFlags dflags 224 | 225 | isOptionSet :: GHCiOption -> GHCi Bool 226 | isOptionSet opt 227 | = do st <- getGHCiState 228 | return (opt `elem` options st) 229 | 230 | setOption :: GHCiOption -> GHCi () 231 | setOption opt 232 | = do st <- getGHCiState 233 | setGHCiState (st{ options = opt : filter (/= opt) (options st) }) 234 | 235 | unsetOption :: GHCiOption -> GHCi () 236 | unsetOption opt 237 | = do st <- getGHCiState 238 | setGHCiState (st{ options = filter (/= opt) (options st) }) 239 | 240 | io :: IO a -> GHCi a 241 | io = MonadUtils.liftIO 242 | 243 | printForUser :: SDoc -> GHCi () 244 | printForUser doc = do 245 | unqual <- GHC.getPrintUnqual 246 | io $ Outputable.printForUser stdout unqual doc 247 | 248 | printForUser' :: SDoc -> InputT GHCi () 249 | printForUser' doc = do 250 | unqual <- GHC.getPrintUnqual 251 | Haskeline.outputStrLn $ showSDocForUser unqual doc 252 | 253 | printForUserPartWay :: SDoc -> GHCi () 254 | printForUserPartWay doc = do 255 | unqual <- GHC.getPrintUnqual 256 | io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc 257 | 258 | -- We set log_action to write encoded output. 259 | -- This fails whenever GHC tries to mention an (already encoded) filename, 260 | -- but I don't know how to work around that. 261 | setLogAction :: InputT GHCi () 262 | setLogAction = do 263 | encoder <- getEncoder 264 | dflags <- GHC.getSessionDynFlags 265 | GHC.setSessionDynFlags dflags {log_action = logAction encoder} 266 | return () 267 | where 268 | logAction encoder severity srcSpan style msg = case severity of 269 | GHC.SevInfo -> printEncErrs encoder (msg style) 270 | GHC.SevFatal -> printEncErrs encoder (msg style) 271 | _ -> do 272 | hPutChar stderr '\n' 273 | printEncErrs encoder (ErrUtils.mkLocMessage srcSpan msg style) 274 | printEncErrs encoder doc = do 275 | str <- encoder (Pretty.showDocWith Pretty.PageMode doc) 276 | B.hPutStrLn stderr str 277 | hFlush stderr 278 | 279 | runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult 280 | runStmt expr step = do 281 | st <- getGHCiState 282 | reifyGHCi $ \x -> 283 | withProgName (progname st) $ 284 | withArgs (args st) $ 285 | reflectGHCi x $ do 286 | GHC.handleSourceError (\e -> do GHC.printExceptionAndWarnings e 287 | return GHC.RunFailed) $ do 288 | GHC.runStmt expr step 289 | 290 | resume :: (GHC.SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult 291 | resume canLogSpan step = GHC.resume canLogSpan step 292 | 293 | -- -------------------------------------------------------------------------- 294 | -- timing & statistics 295 | 296 | timeIt :: InputT GHCi a -> InputT GHCi a 297 | timeIt action 298 | = do b <- lift $ isOptionSet ShowTiming 299 | if not b 300 | then action 301 | else do allocs1 <- liftIO $ getAllocations 302 | time1 <- liftIO $ getCPUTime 303 | a <- action 304 | allocs2 <- liftIO $ getAllocations 305 | time2 <- liftIO $ getCPUTime 306 | liftIO $ printTimes (fromIntegral (allocs2 - allocs1)) 307 | (time2 - time1) 308 | return a 309 | 310 | foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64 311 | -- defined in ghc/rts/Stats.c 312 | 313 | printTimes :: Integer -> Integer -> IO () 314 | printTimes allocs psecs 315 | = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float 316 | secs_str = showFFloat (Just 2) secs 317 | putStrLn (showSDoc ( 318 | parens (text (secs_str "") <+> text "secs" <> comma <+> 319 | text (show allocs) <+> text "bytes"))) 320 | 321 | ----------------------------------------------------------------------------- 322 | -- reverting CAFs 323 | 324 | revertCAFs :: GHCi () 325 | revertCAFs = do 326 | io $ rts_revertCAFs 327 | s <- getGHCiState 328 | when (not (ghc_e s)) $ io turnOffBuffering 329 | -- Have to turn off buffering again, because we just 330 | -- reverted stdout, stderr & stdin to their defaults. 331 | 332 | foreign import ccall "revertCAFs" rts_revertCAFs :: IO () 333 | -- Make it "safe", just in case 334 | 335 | ----------------------------------------------------------------------------- 336 | -- To flush buffers for the *interpreted* computation we need 337 | -- to refer to *its* stdout/stderr handles 338 | 339 | GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ()) 340 | GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ()) 341 | GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ()) 342 | 343 | -- After various attempts, I believe this is the least bad way to do 344 | -- what we want. We know look up the address of the static stdin, 345 | -- stdout, and stderr closures in the loaded base package, and each 346 | -- time we need to refer to them we cast the pointer to a Handle. 347 | -- This avoids any problems with the CAF having been reverted, because 348 | -- we'll always get the current value. 349 | -- 350 | -- The previous attempt that didn't work was to compile an expression 351 | -- like "hSetBuffering stdout NoBuffering" into an expression of type 352 | -- IO () and run this expression each time we needed it, but the 353 | -- problem is that evaluating the expression might cache the contents 354 | -- of the Handle rather than referring to it from its static address 355 | -- each time. There's no safe workaround for this. 356 | 357 | initInterpBuffering :: Ghc () 358 | initInterpBuffering = do -- make sure these are linked 359 | dflags <- GHC.getSessionDynFlags 360 | liftIO $ do 361 | initDynLinker dflags 362 | 363 | -- ToDo: we should really look up these names properly, but 364 | -- it's a fiddle and not all the bits are exposed via the GHC 365 | -- interface. 366 | mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdin_closure" 367 | mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdout_closure" 368 | mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stderr_closure" 369 | 370 | let f ref (Just ptr) = writeIORef ref ptr 371 | f _ Nothing = panic "interactiveUI:setBuffering2" 372 | zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr] 373 | [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr] 374 | return () 375 | 376 | flushInterpBuffers :: GHCi () 377 | flushInterpBuffers 378 | = io $ do getHandle stdout_ptr >>= hFlush 379 | getHandle stderr_ptr >>= hFlush 380 | 381 | turnOffBuffering :: IO () 382 | turnOffBuffering 383 | = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr] 384 | mapM_ (\h -> hSetBuffering h NoBuffering) hdls 385 | 386 | getHandle :: IORef (Ptr ()) -> IO Handle 387 | getHandle ref = do 388 | (Ptr addr) <- readIORef ref 389 | case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval) 390 | -------------------------------------------------------------------------------- /testsuite/README: -------------------------------------------------------------------------------- 1 | Running the test suite against a GHC build 2 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3 | 4 | NOTE: you need Python (any version >= 1.5 will probably do) in order 5 | to use the testsuite. 6 | 7 | To run the test suite against stage 1 of a GHC build in the same 8 | source tree: 9 | 10 | cd tests/ghc-regress 11 | make 12 | 13 | (from now on, we'll assume that you're in the tests/ghc-regress 14 | directory). 15 | 16 | To run a fast version of the testsuite, which should complete in under 17 | 5 minutes on a fast machine with an optimised GHC build: 18 | 19 | make fast 20 | 21 | To run the testsuite with the stage2 compiler (this is often what you 22 | want, because GHCi tests will fail with stage1): 23 | 24 | make stage=2 25 | 26 | To run the test suite against a different GHC, say ghc-5.04: 27 | 28 | make TEST_HC=ghc-5.04 29 | 30 | To run an individual test or tests (eg. tc054): 31 | 32 | make TEST=tc054 33 | 34 | (you can also go straight to the directory containing the test and say 35 | 'make TEST=tc054' from there, which will save some time). 36 | 37 | To run the tests one particular way only (eg. GHCi): 38 | 39 | make WAY=ghci 40 | 41 | For more details, see below. 42 | 43 | 44 | Running the testsuite with a compiler other than GHC 45 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 46 | 47 | (to be written. The plan is something like: 48 | 49 | cvs checkout fpconfig 50 | cd fptools 51 | cvs checkout testsuite 52 | autoconf 53 | ./configure 54 | cd testsuite 55 | make TEST_HC=nhc98 COMPILER=nhc98 56 | ) 57 | 58 | 59 | Running individual tests or subdirectories of the testsuite 60 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 61 | 62 | Most of the subdirectories in the testsuite have a Makefile. In these 63 | subdirectories you can use 'make' to run the test driver in two 64 | ways: 65 | 66 | make -- run all the tests in the current directory 67 | make accept -- run the tests, accepting the current output 68 | 69 | The following variables may be set on the make command line: 70 | 71 | TESTS -- specific tests to run 72 | TEST_HC -- compiler to use 73 | EXTRA_HC_OPTS -- extra flags to send to the Haskell compiler 74 | EXTRA_RUNTEST_OPTS -- extra flags to give the test driver 75 | CONFIG -- use a different configuration file 76 | COMPILER -- stem of a different configuration file 77 | -- from the config directory [default: ghc] 78 | WAY -- just this way 79 | 80 | The following ways are defined (for GHC, also see the file config/ghc): 81 | 82 | normal -- no special options 83 | opt -- -O 84 | optasm -- -O -fasm 85 | prof -- -O -prof -auto-all 86 | profasm -- -O -prof -auto-all -fasm 87 | unreg -- -unreg 88 | ghci -- (run only, not compile) run test under GHCi 89 | extcore -- -fext-core 90 | optextcore -- -O -fext-core 91 | threaded -- -threaded 92 | 93 | certain ways are enabled automatically if the GHC build in the local 94 | tree supports them. Ways that are enabled this way are optasm, prof, 95 | profasm, unreg, threaded, and ghci. 96 | 97 | 98 | Updating tests when the output changes 99 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 100 | 101 | If the output of a test has changed, but the new output is still 102 | correct, you can automatically update the sample output to match the 103 | new output like so: 104 | 105 | make accept TESTS= 106 | 107 | where is the name of the test. In a directory which 108 | contains a single test, or if you want to update *all* the tests in 109 | the current directory, just omit the 'TESTS=' part. 110 | 111 | 112 | Adding a new test 113 | ~~~~~~~~~~~~~~~~~ 114 | 115 | For a test which can be encapsulated in a single source file, follow 116 | these steps: 117 | 118 | 1. Find the appropriate place for the test. The GHC regression suite 119 | is generally organised in a "white-box" manner: a regression which 120 | originally illustrated a bug in a particular part of the compiler 121 | is placed in the directory for that part. For example, typechecker 122 | regression tests go in the typechecker/ directory, parser tests 123 | go in parser/, and so on. 124 | 125 | It's not always possible to find a single best place for a test; 126 | in those cases just pick one which seems reasonable. 127 | 128 | Under each main directory may be up to three subdirectories: 129 | 130 | - should_compile: tests which need to compile only 131 | 132 | - should_fail: tests which should fail to compile 133 | and generate a particular error message 134 | 135 | - should_run: tests which should compile, run with 136 | some specific input, and generate a 137 | particular output. 138 | 139 | We don't always divide the tests up like this, and it's not 140 | essential to do so (the directory names have no meaning as 141 | far as the test driver is concerned). 142 | 143 | 144 | 2. Having found a suitable place for the test, give the test a name. 145 | Follow the convention for the directory in which you place the 146 | test: for example, in typecheck/should_compile, tests are named 147 | tc001, tc002, and so on. Suppose you name your test T, then 148 | you'll have the following files: 149 | 150 | T.hs The source file containing the test 151 | 152 | T.stdin (for tests that run, and optional) 153 | A file to feed the test as standard input when it 154 | runs. 155 | 156 | T.stdout (for tests that run, and optional) 157 | For tests that run, this file is compared against 158 | the standard output generated by the program. If 159 | T.stdout does not exist, then the program must not 160 | generate anything on stdout. 161 | 162 | T.stderr (optional) For tests that run, this file is compared 163 | against the standard error generated by the program. 164 | 165 | For tests that compile only, this file is compared 166 | against the standard error output of the compiler, 167 | which is normalised to eliminate bogus differences 168 | (eg. absolute pathnames are removed, whitespace 169 | differences are ignored, etc.) 170 | 171 | 172 | 2. Edit all.T in the relevant directory and add a line for the 173 | test. The line is always of the form 174 | 175 | test(, , , ) 176 | 177 | where 178 | 179 | is the name of the test, in quotes (' or "). 180 | 181 | is a function (i.e. any callable object in Python) 182 | which allows the options for this test to be changed. 183 | There are several pre-defined functions which can be 184 | used in this field: 185 | 186 | normal don't change any options from the defaults 187 | skip skip this test 188 | omit_ways(ways) skip this test for certain ways 189 | only_ways(ways) do this test certain ways only 190 | omit_compiler_types(compilers) 191 | skip this test for certain compilers 192 | only_compiler_types(compilers) 193 | do this test for certain compilers only 194 | expect_fail this test is an expected failure 195 | expect_fail_for(ways) expect failure for certain ways 196 | expect_fail_if_platform(plat) 197 | expect failure on a certain platform 198 | expect_fail_if_compiler_type(compiler) 199 | expect failure from a certain compiler 200 | set_stdin(file) use a different file for stdin 201 | exit_code(n) expect an exit code of 'n' from the prog 202 | extra_run_opts(opts) pass some extra opts to the prog 203 | no_clean don't clean up after this test 204 | 205 | you can compose two of these functions together by 206 | saying compose(f,g). For example, to expect an exit 207 | code of 3 and omit way 'opt', we could use 208 | 209 | compose(omit_ways(['opt']), exit_code(3)) 210 | 211 | as the argument. Calls to compose() can of 212 | course be nested. 213 | 214 | 215 | is a function which describes how the test should be 216 | run, and determines the form of . The possible 217 | values are: 218 | 219 | compile Just compile the program, the 220 | compilation should succeed. 221 | 222 | compile_fail Just compile the program, the 223 | compilation should fail (error 224 | messages will be in T.stderr). 225 | 226 | compile_and_run 227 | Compile the program and run it, 228 | comparing the output against the 229 | relevant files. 230 | 231 | multimod_compile 232 | Compile a multi-module program 233 | (more about multi-module programs 234 | below). 235 | 236 | multimod_compile_fail 237 | Compile a multi-module program, 238 | and expect the compilation to fail 239 | with error messages in T.stderr 240 | 241 | multimod_compile_and_run 242 | Compile and run a multi-module 243 | program. 244 | 245 | run_command 246 | Just run an arbitrary command. The 247 | output is checked against T.stdout and 248 | T.stderr, and the stdin and expected 249 | exit code can be changed in the same 250 | way as for compile_and_run. 251 | 252 | run_command_ignore_output 253 | Same as run_command, except the output 254 | (both stdout and stderr) from the 255 | command is ignored. 256 | 257 | ghci_script 258 | Runs the current compiler, passing 259 | --interactive and using the specified 260 | script as standard input. 261 | 262 | is a list of arguments to be passed to . 263 | 264 | For compile, compile_fail and compile_and_run, 265 | is a list with a single string which contains extra 266 | compiler options with which to run the test. eg. 267 | 268 | test(tc001, normal, compile, ['-fglasgow-exts']) 269 | 270 | would pass the flag -fglasgow-exts to the compiler 271 | when compiling tc001. 272 | 273 | The multimod_ versions of compile and compile_and_run 274 | expect an extra argument on the front of the list: the 275 | name of the top module in the program to be compiled 276 | (usually this will be 'Main'). 277 | 278 | 279 | A multi-module test is straightforward. It usually goes in a 280 | directory of its own (although this isn't essential), and the source 281 | files can be named anything you like. The test must have a name, in 282 | the same way as a single-module test; and the stdin/stdout/stderr 283 | files follow the name of the test as before. In the same directory, 284 | place a file 'test.T' containing a line like 285 | 286 | test(multimod001, normal, multimod_compile_and_run, \ 287 | [ 'Main', '-fglasgow-exts', '', 0 ]) 288 | 289 | as described above. 290 | 291 | For some examples, take a look in tests/ghc-regress/programs. 292 | 293 | 294 | The details 295 | ~~~~~~~~~~~ 296 | 297 | The test suite driver is just a set of Python scripts, as are all of 298 | the .T files in the test suite. The driver (driver/runtests.py) first 299 | searches for all the .T files it can find, and then proceeds to 300 | execute each one, keeping a track of the number of tests run, and 301 | which ones succeeded and failed. 302 | 303 | The script runtests.py takes several options: 304 | 305 | --config 306 | 307 | is just a file containing Python code which is 308 | executed. The purpose of this option is so that a file 309 | containing settings for the configuration options can 310 | be specified on the command line. Multiple --config options 311 | may be given. 312 | 313 | --rootdir 314 | 315 | is the directory below which to search for .T files 316 | to run. 317 | 318 | --output-summary 319 | 320 | In addition to dumping the test summary to stdout, also 321 | put it in . (stdout also gets a lot of other output 322 | when running a series of tests, so redirecting it isn't 323 | always the right thing). 324 | 325 | --only 326 | 327 | Only run tests named (multiple --only options can 328 | be given). Useful for running a single test from a .T file 329 | containing multiple tests. 330 | 331 | -e 332 | 333 | executes the Python statement before running any tests. 334 | The main purpose of this option is to allow certain 335 | configuration options to be tweaked from the command line; for 336 | example, the build system adds '-e config.accept=1' to the 337 | command line when 'make accept' is invoked. 338 | 339 | Most of the code for running tests is located in driver/testlib.py. 340 | Take a look. 341 | 342 | There is a single Python class (TestConfig) containing the global 343 | configuration for the test suite. It contains information such as the 344 | kind of compiler being used, which flags to give it, which platform 345 | we're running on, and so on. The idea is that each platform and 346 | compiler would have its own file containing assignments for elements 347 | of the configuration, which are sourced by passing the appropriate 348 | --config options to the test driver. For example, the GHC 349 | configuration is contained in the file config/ghc. 350 | 351 | A .T file can obviously contain arbitrary Python code, but the general 352 | idea is that it contains a sequence of calls to the function test(), 353 | which resides in testlib.py. As described above, test() takes four 354 | arguments: 355 | 356 | test(, , , ) 357 | 358 | The function is allowed to be any Python callable object, 359 | which takes a single argument of type TestOptions. TestOptions is a 360 | class containing options which affect the way that the current test is 361 | run: whether to skip it, whether to expect failure, extra options to 362 | pass to the compiler, etc. (see testlib.py for the definition of the 363 | TestOptions class). The idea is that the function modifies 364 | the TestOptions object that it is passed. For example, to expect 365 | failure for a test, we might do this in the .T file: 366 | 367 | def fn(opts): 368 | opts.expect = 'fail' 369 | 370 | test(test001, fn, compile, ['']) 371 | 372 | so when fn is called, it sets the instance variable "expect" in the 373 | instance of TestOptions passed as an argument, to the value 'fail'. 374 | This indicates to the test driver that the current test is expected to 375 | fail. 376 | 377 | Some of these functions, such as the one above, are common, so rather 378 | than forcing every .T file to redefine them, we provide canned 379 | versions. For example, the provided function expect_fail does the 380 | same as fn in the example above. See testlib.py for all the canned 381 | functions we provide for . 382 | 383 | The argument is a function which performs the test. It 384 | takes three or more arguments: 385 | 386 | ( , , ... ) 387 | 388 | where is the name of the test, is the way in which it is 389 | to be run (eg. opt, optasm, prof, etc.), and the rest of the arguments 390 | are constructed from the list in the original call to test(). 391 | The following s are provided at the moment: 392 | 393 | compile 394 | compile_fail 395 | compile_and_run 396 | multimod_compile 397 | multimod_compile_fail 398 | multimod_compile_and_run 399 | run_command 400 | run_command_ignore_output 401 | ghci_script 402 | 403 | and obviously others can be defined. The function should return 404 | either 'pass' or 'fail' indicating that the test passed or failed 405 | respectively. 406 | 407 | -------------------------------------------------------------------------------- /LskPrelude/LskPrelude.lsk: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;; LISKELL Prelude 3 | ;;; 4 | ;;; Author(s): Clemens Fruhwirth 5 | ;;; 6 | ;;; It defines syntax sugar for pure Liskell. 7 | ;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (defmodule LskPrelude 11 | (dspr-namespace-dspr 12 | define-dspr-dspr 13 | quote 14 | pString 15 | __dspr-add-dspr 16 | __dspr-cond 17 | __dspr-simple-list 18 | __dspr-backquote 19 | __dspr-def-hdsprs 20 | __dspr-defmacros 21 | __dspr-sParseTree-e 22 | __dspr-sParseTree-p 23 | __dspr-++* 24 | __dspr-:* 25 | __dspr-defdata-deriving 26 | __dspr-derive-eq 27 | __dspr-derive-show 28 | __dspr-def-binary-fun-as-prefix 29 | mapSymId 30 | lsec 31 | (module Liskell)) 32 | (Liskell Debug.Trace Data.Maybe List)) 33 | 34 | ;; Primitive quoting helpers 35 | 36 | ;; basically they resemble the interface of the ParseTree constructors 37 | ;; with the difference that they will construct a parsetree, that when 38 | ;; evaluated will return a parsetree. 39 | 40 | ; left section - actuall FLIP!? 41 | (define (lsec fun right-arg) 42 | (lambda (left-arg) 43 | (fun left-arg right-arg))) 44 | 45 | (define (pString loc sym) 46 | (PSym loc (: #\" (++ sym ([] #\"))))) 47 | 48 | (define (qPSym loc sym) 49 | (PList loc ([] (PSym noSrcSpan "PSym") 50 | (PSym noSrcSpan "ghc-6.10.1:SrcLoc.noSrcSpan") 51 | (pString noSrcSpan sym)) 52 | noPP)) 53 | 54 | (define (quote-pp loc (, ps pe)) 55 | (PList loc ([] 56 | (PSym noSrcSpan ",") 57 | (pString loc ps) 58 | (pString loc pe)) 59 | noPP)) 60 | 61 | ;; qPList does not recursive quote its elements. lst is expected to 62 | ;; evaluated to a parsetree list. 63 | ;; Recursive quoting for lists is built into quote. 64 | 65 | (define (qPList loc lst pp) 66 | (PList loc ([] 67 | (PSym noSrcSpan "PList") 68 | (PSym noSrcSpan "ghc-6.10.1:SrcLoc.noSrcSpan") 69 | lst 70 | (quote-pp loc pp)) 71 | noPP)) 72 | 73 | (define (quote pt) 74 | (case pt 75 | ((PSym loc sym) 76 | (qPSym loc sym)) 77 | ((PList loc lst pp) 78 | (qPList loc (PList noSrcSpan (: (PSym noSrcSpan "[]") 79 | (map quote lst)) 80 | noPP) pp)))) 81 | 82 | 83 | 84 | ;; Quote for pattern matching. This is a bit sensitive. 85 | 86 | (define (qPList-pat loc lst pp) 87 | (PList loc ([] 88 | (PSym noSrcSpan "PList") 89 | (PSym noSrcSpan "_") 90 | lst 91 | (quote-pp loc pp)) 92 | noPP)) 93 | 94 | (define (quote-pat pt) 95 | (case pt 96 | ((PSym loc sym) 97 | (PList loc ([] (PSym noSrcSpan "PSym") 98 | (PSym noSrcSpan "_") 99 | (pString noSrcSpan sym)) 100 | noPP)) 101 | ((PList loc lst pp) 102 | (qPList-pat loc (PList noSrcSpan (: (PSym noSrcSpan "[]") 103 | (map quote-pat lst)) 104 | noPP) pp)))) 105 | 106 | (define (mapSymId (PSym loc str) f) 107 | (case (parseOrig str) 108 | ((, "" "" s) (PSym loc (f s))) 109 | ((, "" q s) (PSym loc (++ q (++ "." (f s))))) 110 | ((, o q s) (PSym loc (++ o (++ ":" (++ q (++ "." (f s))))))))) 111 | 112 | (defwithsig (get-dspr-name symbol) 113 | (-> ParseTree ParseTree) 114 | (mapSymId symbol (++ "__dspr-"))) 115 | 116 | 117 | ;; define-dspr is just another term for define. It only redresses a 118 | ;; function-name into (get-dspr-name function-name) to kick it into 119 | ;; dispatcher namespace 120 | 121 | (define (define-dspr-dspr kn (@ pt (PList loc1 pts (, "" ""))) ks kf) 122 | (case pts 123 | ((: (PList loc2 ([] (PSym _ "define-dspr") 124 | defname 125 | expr) (, "" "")) 126 | t) 127 | (ks (PList loc1 (: (PList loc2 ([] (PSym noSrcSpan "define") 128 | (case defname 129 | ((PList loc3 (: funhead funargs) (, "" "")) 130 | (PList loc3 (: (get-dspr-name funhead) funargs) (, "" ""))) 131 | ((@ sym (PSym _ _)) 132 | (get-dspr-name sym))) 133 | expr) 134 | (, "" "")) 135 | t) 136 | (, "" "")))) 137 | (_ (kn pt ks kf)))) 138 | 139 | (define (dspr-namespace-dspr kn pt ks kf) 140 | (case pt 141 | ((PList loc ([] sym) (, "d" "")) 142 | (ks (get-dspr-name sym))) 143 | (_ (kn pt ks kf)))) 144 | 145 | ;; Due to incomprehensible fight with the eternal regression, we can 146 | ;; not name these two dispatchers properly 147 | (defenv (lambda ((LskEnv e p t d)) 148 | (return (LskEnv (dspr-namespace-dspr e) p t (define-dspr-dspr d))))) 149 | 150 | ;; This is the most simple case of backquoting, namely symbol quoting. 151 | ;; It is not a full-flexed backquoting facility and shall only be used 152 | ;; in this prelude as syntax sugar to aid the definition of other 153 | ;; syntax sugar. 154 | 155 | (define-dspr (backquote-on-syms kn pt ks kf) 156 | (case pt 157 | ((PSym loc sym) 158 | (if (== (head sym) #\`) 159 | (ks (qPSym loc (tail sym))) 160 | (kn pt ks kf))) 161 | (_ (kn pt ks kf)))) 162 | 163 | (envlet 164 | (lambda ((LskEnv e p t d)) 165 | (return (LskEnv (d(backquote-on-syms) e) p t d))) 166 | 167 | 168 | ;; Rewrite this function. It's kind ugly. 169 | (define-dspr (add-dspr kn (@ pt (PList loc1 pts (, "" ""))) ks kf) 170 | (case pts 171 | ((: (PList loc2 (: (PSym _ "add-dspr") 172 | add-directives) 173 | (, "" "")) 174 | t) 175 | (let ((transformed ;; This is a list that aggregates all dspr per function category .. 176 | ;; I guess that's kinda ugly? 177 | (map (lambda (lst) 178 | (, (let (((PList _ ([] (PSym _ where) _) (, "" "")) (head lst))) 179 | where) 180 | (map (lambda ((PList _ ([] (PSym _ _) function) (, "" ""))) 181 | (get-dspr-name function)) 182 | lst))) 183 | (groupBy (lambda ((PList _ ([] (PSym _ where1) _) (, "" "")) 184 | (PList _ ([] (PSym _ where2) _) (, "" ""))) 185 | (== where1 where2)) 186 | (sortBy (lambda ((PList _ ([] (PSym _ where1) _) (, "" "")) 187 | (PList _ ([] (PSym _ where2) _) (, "" ""))) 188 | (compare where1 where2)) 189 | add-directives)))) 190 | ((wrapper startsym lst) 191 | (foldr (lambda (pt1 pt2) 192 | (PList noSrcSpan ([] pt1 pt2) noPP)) 193 | startsym 194 | lst)) 195 | ((get-snd key lst) 196 | (snd (fromMaybe (, "" ([])) 197 | (find (lambda (element) 198 | (== (fst element) key)) 199 | lst))))) 200 | (ks (PList loc1 (: (PList noSrcSpan ([] `defenv 201 | (PList noSrcSpan 202 | ([] `lambda 203 | (PList noSrcSpan ([] (PList noSrcSpan ([] `LskEnv `e `p `t `d) noPP)) noPP) 204 | (PList noSrcSpan ([] `return 205 | (PList noSrcSpan ([] `LskEnv 206 | (wrapper `e 207 | (get-snd "expression" transformed)) 208 | (wrapper `p 209 | (get-snd "pattern" transformed)) 210 | (wrapper `t 211 | (get-snd "type" transformed)) 212 | (wrapper `d 213 | (get-snd "declaration" transformed))) noPP)) noPP)) 214 | noPP)) 215 | noPP) 216 | t) 217 | (, "" ""))))) 218 | (_ (kn pt ks kf)))) 219 | 220 | (defenv (lambda ((LskEnv e p t d)) 221 | (return (LskEnv e p t (d(add-dspr) d))))) 222 | 223 | (define (trf_cond capairs) 224 | (case capairs 225 | (([]) `undefined) ; no actions. return undefined. 226 | ((: (PList _ ([] cond action) _) 227 | rest) 228 | (PList noSrcSpan ([] `if 229 | cond 230 | action 231 | (trf_cond rest)) 232 | noPP)) 233 | (_ (error (show capairs))))) 234 | 235 | (define-dspr (cond kn pt ks kf) 236 | (case pt 237 | ((PList _ (: (PSym _ "cond") rest) _) 238 | (ks (trf_cond rest))) 239 | (_ (kn pt ks kf)))) 240 | 241 | ;; The simple list dispatcher defines a short form on explicit lists 242 | ;; They resemble the syntactic markup of CL quoted lists 243 | ;; %(a b c d) 244 | ;; In contrast to CL, they are _evaluated_. CL, should think of it as (list a b c). 245 | ;; nil is rewritten to the empty list ([]). 246 | 247 | (define-dspr (simple-list kn pt ks kf) 248 | (case pt 249 | ((PList loc lst (, "%" "")) 250 | (ks (PList loc (: (PSym noSrcSpan "[]") lst) noPP))) 251 | ((PSym loc "nil") 252 | (ks (PList loc ([] (PSym noSrcSpan "[]")) noPP))) 253 | (_ (kn pt ks kf)))) 254 | 255 | ; (define-dspr (quote kn pt ks kf) 256 | ; (case pt 257 | ; ((PList loc lst (, "'" "")) 258 | ; (ks (PList loc (: (PSym noSrcSpan "[]" "") lst) noPP))) 259 | ; ((PSym loc "nil" "") 260 | ; (ks (PList loc ([] (PSym noSrcSpan "[]" "")) noPP))) 261 | ; (_ (kn pt ks kf)))) 262 | 263 | ;; Add simple-list and cond dsprs 264 | (add-dspr (expression simple-list) 265 | (expression cond) 266 | (pattern simple-list)) 267 | 268 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 269 | ;; BACKQUOTING 270 | ;; 271 | ;; For a basic explaination of Backquoting (aka Quasiquoting) refer to 272 | ;; http://citeseer.ist.psu.edu/bawden99quasiquotation.html 273 | ;; 274 | ;; The basic process is 275 | ;; 276 | ;; ` is equal to (quote pt) except for two cases 277 | ;; 1. `, is equal to pt 278 | ;; 2. when pt is a list. Then `( ..) is equal to 279 | ;; (SList (concat ([] [] [] []))). 280 | ;; 281 | ;; (The bracket operator [] is different from the list 282 | ;; construction operator []. The similarity in syntax is a mere 283 | ;; coincidience.) 284 | ;; 285 | ;; For the bracket operator, 286 | ;; [] is equal to ([] `) 287 | ;; except in one case, namely 288 | ;; [,@] is equal to (pt_list ). 289 | ;; 290 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 291 | 292 | 293 | ;; Predicate on a parse tree that either Just returns the payload of 294 | ;; a comma-ed item or returns Nothing, when pt is not prefixed by a comma. 295 | (define (comma? pt) 296 | (>>= (case pt 297 | ((PList loc lst (, ps pe)) 298 | (if (&& (not (null ps)) 299 | (== (head ps) #\,)) 300 | (Just (PList loc lst (, (tail ps) pe))) ; ,(..) 301 | Nothing)) ; (..expand comma items..) 302 | ((PSym loc sym) 303 | (if (&& (|| (not (null sym)) 304 | (error "Invalid null symbol encountered")) 305 | (&& (== (head sym) #\,) 306 | (not (null (tail sym))))) ; if tail is null we see a comma for tuples. 307 | (Just (PSym loc (tail sym))) 308 | Nothing))) 309 | (lambda (pt) 310 | (return (PList (pt_loc pt) %(`toParseTree pt) noPP))))) 311 | 312 | ;; Returns either Just a parsetree that evaluates to a parse tree 313 | ;; list, or Nothing when pt is not prefixed by ,@. 314 | (define (comma-at? pt) 315 | (>>= (case pt 316 | ((PList loc lst (, ps pe)) 317 | (if (and %((not (null ps)) 318 | (== (head ps) #\,) 319 | (not (null (tail ps))) 320 | (== (head (tail ps)) #\@))) 321 | (Just (PList loc lst (, (drop 2 ps) pe))) ; ,(..) 322 | Nothing)) ; (..expand comma items..) 323 | ((PSym loc sym) 324 | (if (and %((|| (not (null sym)) 325 | (error "Invalid null symbol encountered")) 326 | (== (head sym) #\,) 327 | (not (null (tail sym))) 328 | (== (head (tail sym)) #\@))) 329 | (Just (PSym loc (drop 2 sym))) ; ,@a 330 | Nothing))) 331 | (lambda (pt) 332 | (return (PList (pt_loc pt) %(`pt_list 333 | (PList (pt_loc pt) %(`toParseTree pt) noPP)) 334 | noPP))))) 335 | 336 | ;; Either returns the payload of a backquoted parse tree or returns 337 | ;; Nothing when pt is not backquoted. 338 | (define (quoted? pt) 339 | (case pt 340 | ((PList loc %((PSym _ "backquote") payload) (, "" "")) 341 | (Just payload)) 342 | ((PSym loc sym) 343 | (if (&& (|| (not (null sym)) (error "Invalid null symbol")) 344 | (== (head sym) #\`)) 345 | (Just (PSym loc (tail sym))) 346 | Nothing)) 347 | ((PList loc lst (, pre post)) 348 | (if (&& (not (null pre)) 349 | (== (head pre) #\`)) 350 | (Just (PList loc lst (, (tail pre) post))) 351 | Nothing)))) 352 | 353 | ;; Parse tree dispatcher for backquoting 354 | (defwithsig (bq-process kn pt ks kf) 355 | (-> (-> ParseTree 356 | (-> ParseTree a) 357 | (-> ParseTree a) 358 | a) 359 | ParseTree 360 | (-> ParseTree a) 361 | (-> ParseTree a) 362 | a) 363 | (fromMaybe (kn pt ks kf) 364 | (>>= (quoted? pt) 365 | (lambda (pt) 366 | (let ((pt' (bq-process (lambda (pt ks kf) pt) 367 | pt 368 | id 369 | (error "Don't touch kf!")))) 370 | (return (ks (fromMaybe (case pt' 371 | ((PList loc lst pp) 372 | (qPList loc (PList loc %(`concat (PList loc (: `[] (map bq-bracket lst)) noPP)) 373 | noPP) 374 | pp)) 375 | (_ (quote pt'))) 376 | (comma? pt'))))))))) 377 | ;; This function returns a parse tree that when evaluated produces a parse tree list. 378 | (defwithsig (bq-bracket pt) 379 | (-> ParseTree ParseTree) 380 | (fromMaybe (PList noSrcSpan %(`[] (bq-process 381 | (error "Don't touch kn!") 382 | (PList noSrcSpan %(`backquote pt) noPP) 383 | id 384 | (error "Don't touch kf!")) 385 | ) noPP) 386 | (comma-at? pt))) 387 | 388 | (define-dspr backquote bq-process)) 389 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 390 | 391 | 392 | ;; Return to a vanilla compiler environment and add a properly coded backquote. 393 | (defenv (lambda ((LskEnv e p t d)) 394 | (return (LskEnv e p t (d(add-dspr) d))))) 395 | 396 | (add-dspr (expression simple-list) 397 | (expression cond) 398 | (expression backquote) 399 | (pattern simple-list)) 400 | 401 | 402 | ;; The following macros for defining head dispatchers 403 | ;; A head dispatchers tests for a specified symbol 'sym' for the ParseTree form (PList _ (PSym _ sym _) _), 404 | ;; that is a list (sym .. ..) 405 | ;; 406 | ;; In general the defheadX-dispatcher top level macro takes 3 arguments 407 | ;; name, a name for the new dispatcher 408 | ;; head, usually a symbol the dispatcher should look for (also can be a different parse tree form) 409 | ;; callable, a callable one-argument expression that takes a list of parsetree. 410 | ;; 411 | 412 | (define (emit-hdspr-decls %(dspr-name dispatch-on dspr-fun)) 413 | `(define (,dspr-name kn pt_lst ks kf) 414 | (case (pt_list pt_lst) 415 | (nil (kn pt_lst ks kf)) 416 | ((: p ps) 417 | (case p 418 | ((PList loc (: h t) (, "" "")) 419 | (if (== h ,dispatch-on) 420 | (ks (PList ghc-6.10.1:SrcLoc.noSrcSpan 421 | (++ (,dspr-fun t) 422 | ps) 423 | noPP)) 424 | (kn pt_lst ks kf))) 425 | (_ (kn pt_lst ks kf))))))) 426 | 427 | ;; defheadm is able to define dspr that emit a series of declarations 428 | 429 | 430 | ;; symbol capture problem for kn p ks kf FIXME 431 | (define (emit-hdspr %(dspr-name dispatch-on dspr-fun)) 432 | `(define (,dspr-name kn p ks kf) 433 | (case p 434 | ((PList loc (: h t) (, "" "")) 435 | (if (== h ,dispatch-on) 436 | (ks (,dspr-fun t)) 437 | (kn p ks kf))) 438 | (_ (kn p ks kf))))) 439 | 440 | (define (def-hdspr-dspr-generic dispatch-on dispatch-fun kn pt-lst ks kf) 441 | (case (pt_list pt-lst) 442 | (nil (kn pt-lst ks kf)) 443 | ((: p ps) 444 | (case p 445 | ((PList loc (: h t) (, "" "")) 446 | (if (== h dispatch-on) 447 | (ks (PList noSrcSpan 448 | (: (dispatch-fun t) 449 | ps) 450 | noPP)) 451 | (kn pt-lst ks kf))) 452 | (_ (kn pt-lst ks kf)))))) 453 | 454 | (define def-hdspr-dspr 455 | (def-hdspr-dspr-generic `def-hdspr emit-hdspr)) 456 | 457 | (define def-hdspr-decls-dspr 458 | (def-hdspr-dspr-generic `def-hdspr-decls emit-hdspr-decls)) 459 | 460 | (define-dspr (def-hdsprs kn) 461 | (def-hdspr-dspr (def-hdspr-decls-dspr kn))) 462 | 463 | (add-dspr (declaration def-hdsprs)) 464 | 465 | ;; Now here comes the macro facility stuff 466 | 467 | (def-hdspr-decls 468 | defmacro-dspr 469 | `defmacro 470 | (lambda (%(funhead expr)) 471 | (let (((, dispatch-fun dspr-name) 472 | (case (head (pt_list funhead)) 473 | ((PList _ %(macroname dispatchername) (, "" "")) 474 | (, macroname dispatchername)) 475 | ((@ s (PSym _ _)) 476 | (, s (get-dspr-name s))) 477 | (_ (error "Unknown macro head"))))) 478 | %(`(def-hdspr 479 | ,dspr-name 480 | ,(quote dispatch-fun) 481 | (lambda ,(tail (pt_list funhead)) 482 | ,expr)))))) 483 | 484 | (def-hdspr-decls 485 | defmacro-decl-dspr 486 | `defmacro-decl 487 | (lambda (%(funhead expr)) 488 | (let (((, dispatch-fun dspr-name) 489 | (case (head (pt_list funhead)) 490 | ((PList _ %(macroname dispatchername) (, "" "")) 491 | (, macroname dispatchername)) 492 | ((@ s (PSym _ _)) 493 | (, s (get-dspr-name s))) 494 | (_ (error "Unknown macro head"))))) 495 | %(`(def-hdspr-decls 496 | ,dspr-name 497 | ,(quote dispatch-fun) 498 | (lambda ,(tail (pt_list funhead)) 499 | ,expr)))))) 500 | 501 | (define-dspr (defmacros d) 502 | (defmacro-dspr (defmacro-decl-dspr d))) 503 | 504 | (add-dspr (declaration defmacros)) 505 | 506 | (defmacro ((SSym sSym-p-dspr) pts) 507 | (let ((ml (length pts))) 508 | (case ml 509 | (1 `(PSym _ ,(!! pts 0))) 510 | (_ (error "Unknown arity for SSym"))))) 511 | 512 | (defmacro ((SSym sSym-e-dspr) pts) 513 | (let ((ml (length pts ))) 514 | (case ml 515 | (1 `(PSym ghc-6.10.1:SrcLoc.noSrcSpan ,(!! pts 0))) 516 | (_ (error "Unknown arity for SSym"))))) 517 | 518 | (defmacro ((SList sList-p-dspr) pts) 519 | (let ((ml (length pts))) 520 | (case ml 521 | (1 `(PList _ ,(!! pts 0) (, "" ""))) 522 | (2 `(PList _ ,(!! pts 0) ,(!! pts 1))) 523 | (_ (error "Unknown arity for SList"))))) 524 | 525 | (defmacro ((SList sList-e-dspr) pts) 526 | (let ((ml (length pts))) 527 | (case ml 528 | (1 `(PList ghc-6.10.1:SrcLoc.noSrcSpan ,(!! pts 0) (, "" ""))) 529 | (2 `(PList ghc-6.10.1:SrcLoc.noSrcSpan ,(!! pts 0) ,(!! pts 1))) 530 | (_ (error "Unknown arity for SList"))))) 531 | 532 | (defmacro ((SString sString-e-dspr) %(string)) 533 | `(pString ghc-6.10.1:SrcLoc.noSrcSpan ,string)) 534 | 535 | (define-dspr (sParseTree-e k) 536 | (sString-e-dspr (sList-e-dspr (sSym-e-dspr k)))) 537 | (define-dspr (sParseTree-p k) 538 | (sList-p-dspr (sSym-p-dspr k))) 539 | 540 | (add-dspr (expression sParseTree-e) 541 | (pattern sParseTree-p)) 542 | 543 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;: 544 | ;; Infix operator to multi-argument prefix macro conversion. 545 | ;; 546 | ;; Infix operators are convenient because they allow easy composition 547 | ;; of expression only abitrated by precedence levels and associativity 548 | ;; declarations. 549 | ;; 550 | ;; To regain a bit of this flexibility, we create multi-arguments 551 | ;; macros to do the neccessary expansion parametrizable in its 552 | ;; associtivity. 553 | ;; 554 | ;; (+* 1 2 3 4) can be rewritten to (+ 1 (+ 2 (+ 3 4))) 555 | ;; (/ 1 2 3 4) while (/ (/ (/ (1 2) 3) 4) 556 | ;; 557 | ;; Notice, the macro declaration below is a higher order PTT 558 | ;; in LskPrelude. 559 | 560 | (defmacro-decl (def-binary-fun-as-prefix %(function associativity)) 561 | (let ((function* (mapSymId function (lsec ++ "*")))) 562 | %(`(defmacro (,function* pts) 563 | (case (length pts) 564 | (0 (error "Empty infix lift")) 565 | (1 (error (++ "Singular infix lift" 566 | (show pts)))) 567 | (2 `(,,(quote function) ,@pts)) 568 | (_ ,(case associativity 569 | ((SSym "right") 570 | ``(,,(quote function) ,(head pts) (,,(quote function*) ,@(tail pts)))) 571 | ((SSym "left") 572 | ``(,,(quote function) (,,(quote function*) ,@(init pts)) ,(last pts)))))))))) 573 | 574 | (add-dspr (declaration def-binary-fun-as-prefix)) 575 | 576 | (def-binary-fun-as-prefix : right) 577 | (def-binary-fun-as-prefix ++ right) 578 | (def-binary-fun-as-prefix + right) 579 | 580 | (add-dspr (expression :*) 581 | (expression ++*) 582 | (pattern :*)) 583 | 584 | ;; This dispatcher splits 585 | ;; (defdata Type (Constructor1 ..) (Constructor2) ... (derive Eq Show)) 586 | ;; into a cleaned defdata definition 587 | ;; (defdata Type (Constructor1 ..) (Constructor2) ... ) 588 | ;; and 589 | ;; (derive Eq Type (Constructor1 ..) (Constructor2) ... ) 590 | ;; (derive Show Type (Constructor1 ..) (Constructor2) ... ) 591 | 592 | (define-dspr (defdata-deriving kn (SList lst) ks kf) 593 | (case lst 594 | ((: (SList (: (SSym "defdata") 595 | args)) 596 | t) 597 | (case (find (lambda (arg) 598 | (case arg 599 | ((SList (: (SSym cname) payload)) 600 | (== cname "derive")) 601 | (_ False))) 602 | (tail args)) 603 | ((Just (@ deriving-clause 604 | (SList (: (SSym "derive") 605 | subclauses)))) 606 | (let ((cleaned-clause (: (head args) 607 | (delete deriving-clause 608 | (tail args))))) 609 | (ks (SList (: (SList (: (SSym "defdata") 610 | cleaned-clause)) 611 | (++ (map (lambda (symbol) 612 | `(derive ,symbol ,@(cleaned-clause))) 613 | subclauses) 614 | t)))))) 615 | (Nothing (kn (SList lst) ks kf)))) 616 | (_ (kn (SList lst) ks kf)))) 617 | 618 | (add-dspr (declaration defdata-deriving)) 619 | 620 | (define-dspr (derive-eq kn (SList lst) ks kf) 621 | (let ((a1stream (map (lambda (number) 622 | (SSym (: #\a (show number)))) 623 | (enumFrom 1))) 624 | (b1stream (map (lambda (number) 625 | (SSym (: #\b (show number)))) 626 | (enumFrom 1)))) 627 | (case lst 628 | ((: (SList (:* (SSym "derive") 629 | (SSym "Eq") 630 | head 631 | constructors)) 632 | t) 633 | (ks (SList (: `(definstance (Eq ,head) 634 | ,@(map (lambda ((SList (: constructor 635 | args))) 636 | `((== (,constructor ,@(take (length args) a1stream)) (,constructor ,@(take (length args) b1stream))) 637 | (and %(,@(zipWith3 (lambda (aelem belem _) 638 | `(== ,aelem ,belem)) 639 | a1stream 640 | b1stream 641 | (enumFromTo 1 (length args))))))) 642 | constructors) 643 | ((== _ _) False)) 644 | t)))) 645 | (_ (kn (SList lst) ks kf))))) 646 | 647 | (define-dspr (derive-show kn (SList lst) ks kf) 648 | (let ((a1stream (map (lambda (number) 649 | (SSym (: #\a (show number)))) 650 | (enumFrom 1))) 651 | (b1stream (map (lambda (number) 652 | (SSym (: #\b (show number)))) 653 | (enumFrom 1)))) 654 | (case lst 655 | ((: (SList (:* (SSym "derive") 656 | (SSym "Show") 657 | head 658 | constructors)) 659 | t) 660 | (ks (SList (: `(definstance (Show ,head) 661 | ,@(map (lambda ((SList (: constructor 662 | args))) 663 | (if (null args) 664 | `((show (,constructor)) 665 | ,(SString (pt_sym constructor))) 666 | `((show (,constructor ,@(take (length args) a1stream))) 667 | (++* "(" 668 | ,(SString (pt_sym constructor)) 669 | ,@(concat (map (lambda (x) %((SSym (show " ")) `(show ,x))) (take (length args) a1stream))) 670 | ")")))) 671 | constructors)) 672 | t)))) 673 | (_ (kn (SList lst) ks kf))))) 674 | 675 | 676 | (add-dspr (declaration derive-eq)) 677 | (add-dspr (declaration derive-show)) 678 | -------------------------------------------------------------------------------- /GHCSalat/HscMain4Lsk.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000 3 | -- 4 | 5 | module GHCSalat.HscMain4Lsk where 6 | import TcRnMonad ( initIfaceCheck, TcGblEnv(..) ) 7 | import TcIface ( typecheckIface ) 8 | import ErrUtils 9 | import HscTypes 10 | import CorePrep ( corePrepPgm ) 11 | import TyCon ( isDataTyCon ) 12 | import CodeGen ( codeGen ) 13 | import System.IO 14 | import Data.IORef 15 | import Panic 16 | import DynFlags 17 | import CmmInfo 18 | import CodeOutput ( codeOutput ) 19 | import TidyPgm 20 | import MkIface 21 | import Bag ( unitBag, emptyBag, unionBags ) 22 | import qualified HscMain as HM 23 | import SimplCore ( core2core ) 24 | import MonadUtils 25 | import LoadIface ( ifaceStats, initExternalPackageState ) 26 | import Module 27 | import CoreSyn 28 | import StgSyn 29 | import Id ( Id ) 30 | import CostCentre 31 | import Cmm ( Cmm ) 32 | import CoreToStg ( coreToStg ) 33 | import SimplStg ( stg2stg ) 34 | import CmmCPS 35 | import TcRnDriver ( tcRnModule ) 36 | import Desugar ( deSugar ) 37 | import Outputable 38 | import UniqSupply ( mkSplitUniqSupply ) 39 | import CmmTx 40 | import CmmContFlowOpt 41 | import CmmCvt 42 | import UniqSupply ( initUs_ ) 43 | import CmmCPSZ 44 | import Parser 45 | import Lexer 46 | import SrcLoc ( mkSrcLoc ) 47 | import SrcLoc ( Located(..) ) 48 | import HsSyn 49 | import RdrName 50 | import StringBuffer 51 | import FastString 52 | import Control.Monad 53 | import System.Exit 54 | import HscStats ( ppSourceStats ) 55 | import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) 56 | import CodeOutput ( outputForeignStubs ) 57 | import LskFileHandler 58 | import LskToHs 59 | import LskTransformationMonad 60 | import LazyUniqFM 61 | 62 | hscNormalIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, CgGuts) 63 | hscNormalIface guts = do 64 | state <- gets id 65 | (msgs,a) <- liftIO $ HM.evalComp (HM.hscNormalIface guts) (state :: HM.CompState) 66 | logMsgs msgs 67 | return a 68 | 69 | hscWriteIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a) 70 | hscWriteIface details = do 71 | state <- gets id 72 | (msgs,a) <- liftIO $ HM.evalComp (HM.hscWriteIface details) (state :: HM.CompState) 73 | logMsgs msgs 74 | return a 75 | 76 | compHscEnv = HM.compHscEnv 77 | compModSummary = HM.compModSummary 78 | compOldIface = HM.compOldIface 79 | 80 | 81 | hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails) 82 | hscCompileBatch 83 | = hscCompiler norecompBatch batchMsg (genComp backend boot_backend) 84 | where 85 | backend inp = hscSimplify inp >>= hscNormalIface >>= hscWriteIface >>= hscBatch 86 | boot_backend inp = hscSimpleIface inp >>= hscWriteIface >>= hscNothing 87 | 88 | data HscStatus 89 | = HscNoRecomp 90 | | HscRecomp Bool -- Has stub files. 91 | -- This is a hack. We can't compile C files here 92 | -- since it's done in DriverPipeline. For now we 93 | -- just return True if we want the caller to compile 94 | -- them for us. 95 | -- Status of a compilation to byte-code. 96 | data InteractiveStatus 97 | = InteractiveNoRecomp 98 | | InteractiveRecomp Bool -- Same as HscStatus 99 | CompiledByteCode 100 | ModBreaks 101 | 102 | norecompBatch :: NoRecomp (HscStatus, ModIface, ModDetails) 103 | norecompBatch = norecompWorker HscNoRecomp False 104 | 105 | norecompWorker :: a -> Bool -> NoRecomp (a, ModIface, ModDetails) 106 | norecompWorker a _isInterp old_iface 107 | = do hsc_env <- gets compHscEnv 108 | liftIO $ do 109 | new_details <- {-# SCC "tcRnIface" #-} 110 | initIfaceCheck hsc_env $ 111 | typecheckIface old_iface 112 | dumpIfaceStats hsc_env 113 | return (a, old_iface, new_details) 114 | 115 | 116 | batchMsg :: Maybe (Int,Int) -> Bool -> Comp () 117 | batchMsg mb_mod_index recomp 118 | = do hsc_env <- gets compHscEnv 119 | mod_summary <- gets compModSummary 120 | let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $ 121 | (showModuleIndex mb_mod_index ++ 122 | msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) recomp mod_summary) 123 | liftIO $ do 124 | if recomp 125 | then showMsg "Compiling " 126 | else if verbosity (hsc_dflags hsc_env) >= 2 127 | then showMsg "Skipping " 128 | else return () 129 | 130 | hscSimpleIface :: TcGblEnv -> Comp (ModIface, Bool, ModDetails, TcGblEnv) 131 | hscSimpleIface tc_result 132 | = do hsc_env <- gets compHscEnv 133 | maybe_old_iface <- gets compOldIface 134 | liftIO $ do 135 | details <- mkBootModDetailsTc hsc_env tc_result 136 | (new_iface, no_change) 137 | <- {-# SCC "MkFinalIface" #-} 138 | mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result 139 | -- And the answer is ... 140 | dumpIfaceStats hsc_env 141 | return (new_iface, no_change, details, tc_result) 142 | 143 | hscNothing :: (ModIface, ModDetails, a) -> Comp (Maybe (HscStatus, ModIface, ModDetails)) 144 | hscNothing (iface, details, _) 145 | = return (Just (HscRecomp False, iface, details)) 146 | 147 | 148 | hscSimplify :: ModGuts -> Comp ModGuts 149 | hscSimplify ds_result 150 | = do hsc_env <- gets compHscEnv 151 | liftIO $ do 152 | ------------------- 153 | -- SIMPLIFY 154 | ------------------- 155 | simpl_result <- {-# SCC "Core2Core" #-} 156 | core2core hsc_env ds_result 157 | return simpl_result 158 | 159 | -------------------------------------------------------------- 160 | -- BackEnd combinators 161 | -------------------------------------------------------------- 162 | 163 | -- Generate code and return both the new ModIface and the ModDetails. 164 | hscBatch :: (ModIface, ModDetails, CgGuts) -> Comp (Maybe (HscStatus, ModIface, ModDetails)) 165 | hscBatch (iface, details, cgguts) 166 | = do hasStub <- hscCompile cgguts 167 | return (Just (HscRecomp hasStub, iface, details)) 168 | 169 | -- Compile to hard-code. 170 | hscCompile :: CgGuts -> Comp Bool 171 | hscCompile cgguts 172 | = do hsc_env <- gets compHscEnv 173 | mod_summary <- gets compModSummary 174 | liftIO $ do 175 | let CgGuts{ -- This is the last use of the ModGuts in a compilation. 176 | -- From now on, we just use the bits we need. 177 | cg_module = this_mod, 178 | cg_binds = core_binds, 179 | cg_tycons = tycons, 180 | cg_dir_imps = dir_imps, 181 | cg_foreign = foreign_stubs, 182 | cg_dep_pkgs = dependencies, 183 | cg_hpc_info = hpc_info } = cgguts 184 | dflags = hsc_dflags hsc_env 185 | location = ms_location mod_summary 186 | data_tycons = filter isDataTyCon tycons 187 | -- cg_tycons includes newtypes, for the benefit of External Core, 188 | -- but we don't generate any code for newtypes 189 | 190 | ------------------- 191 | -- PREPARE FOR CODE GENERATION 192 | -- Do saturation and convert to A-normal form 193 | prepd_binds <- {-# SCC "CorePrep" #-} 194 | corePrepPgm dflags core_binds data_tycons ; 195 | ----------------- Convert to STG ------------------ 196 | (stg_binds, cost_centre_info) 197 | <- {-# SCC "CoreToStg" #-} 198 | myCoreToStg dflags this_mod prepd_binds 199 | ------------------ Code generation ------------------ 200 | cmms <- {-# SCC "CodeGen" #-} 201 | codeGen dflags this_mod data_tycons 202 | dir_imps cost_centre_info 203 | stg_binds hpc_info 204 | --- Optionally run experimental Cmm transformations --- 205 | cmms <- optionallyConvertAndOrCPS hsc_env cmms 206 | -- unless certain dflags are on, the identity function 207 | ------------------ Code output ----------------------- 208 | rawcmms <- cmmToRawCmm cmms 209 | (_stub_h_exists, stub_c_exists) 210 | <- codeOutput dflags this_mod location foreign_stubs 211 | dependencies rawcmms 212 | return stub_c_exists 213 | 214 | 215 | hscCompiler 216 | :: NoRecomp result -- No recomp necessary 217 | -> (Maybe (Int,Int) -> Bool -> Comp ()) -- Message callback 218 | -> Comp (Maybe result) 219 | -> Compiler result 220 | hscCompiler norecomp messenger recomp hsc_env mod_summary 221 | source_unchanged mbOldIface mbModIndex 222 | = do 223 | -- liftIO $ putStrLn ("hscCompiler home package table length " ++ (show (length $ ufmToList $ (hsc_HPT hsc_env)))) 224 | ioMsgMaybe $ 225 | flip evalComp (HM.CompState hsc_env mod_summary mbOldIface) $ 226 | do (recomp_reqd, mbCheckedIface) 227 | <- {-# SCC "checkOldIface" #-} 228 | liftIO $ checkOldIface hsc_env mod_summary 229 | source_unchanged mbOldIface 230 | -- save the interface that comes back from checkOldIface. 231 | -- In one-shot mode we don't have the old iface until this 232 | -- point, when checkOldIface reads it from the disk. 233 | modify (\s -> s{ HM.compOldIface = mbCheckedIface }) 234 | case mbCheckedIface of 235 | Just iface | not recomp_reqd 236 | -> do messenger mbModIndex False 237 | result <- norecomp iface 238 | return (Just result) 239 | _otherwise 240 | -> do messenger mbModIndex True 241 | recomp 242 | 243 | -- the usual way to build the Comp (Maybe result) to pass to hscCompiler 244 | genComp :: (ModGuts -> Comp (Maybe a)) 245 | -> (TcGblEnv -> Comp (Maybe a)) 246 | -> Comp (Maybe a) 247 | genComp backend boot_backend = do 248 | mod_summary <- gets compModSummary 249 | case ms_hsc_src mod_summary of 250 | ExtCoreFile -> do 251 | panic "GHC does not currently support reading External Core files" 252 | _not_core -> do 253 | mb_tc <- hscFileFrontEnd 254 | case mb_tc of 255 | Nothing -> return Nothing 256 | Just tc_result -> 257 | case ms_hsc_src mod_summary of 258 | HsBootFile -> boot_backend tc_result 259 | _other -> do 260 | mb_guts <- hscDesugar tc_result 261 | case mb_guts of 262 | Nothing -> return Nothing 263 | Just guts -> backend guts 264 | 265 | 266 | -- I want Control.Monad.State! --Lemmih 03/07/2006 267 | newtype Comp a = Comp {runComp :: HM.CompState -> IORef Messages -> IO (a, HM.CompState)} 268 | 269 | instance Monad Comp where 270 | g >>= fn = Comp $ \s r -> runComp g s r >>= \(a,s') -> runComp (fn a) s' r 271 | return a = Comp $ \s _ -> return (a,s) 272 | fail = error 273 | 274 | evalComp :: Comp a -> HM.CompState -> IO (Messages, a) 275 | evalComp comp st = do r <- newIORef emptyMessages 276 | (val,_st') <- runComp comp st r 277 | msgs <- readIORef r 278 | return (msgs, val) 279 | 280 | logMsgs :: Messages -> Comp () 281 | logMsgs (warns', errs') = Comp $ \s r -> do 282 | (warns, errs) <- readIORef r 283 | writeIORef r $! ( warns' `unionBags` warns 284 | , errs' `unionBags` errs ) 285 | return ((), s) 286 | 287 | get :: Comp HM.CompState 288 | get = Comp $ \s _ -> return (s,s) 289 | 290 | modify :: (HM.CompState -> HM.CompState) -> Comp () 291 | modify f = Comp $ \s _ -> return ((), f s) 292 | 293 | gets :: (HM.CompState -> a) -> Comp a 294 | gets getter = do st <- get 295 | return (getter st) 296 | 297 | instance MonadIO Comp where 298 | liftIO ioA = Comp $ \s _ -> do a <- ioA; return (a,s) 299 | 300 | type NoRecomp result = ModIface -> Comp result 301 | 302 | -- FIXME: The old interface and module index are only using in 'batch' and 303 | -- 'interactive' mode. They should be removed from 'oneshot' mode. 304 | type Compiler result = GhcMonad m => 305 | HscEnv 306 | -> ModSummary 307 | -> Bool -- True <=> source unchanged 308 | -> Maybe ModIface -- Old interface, if available 309 | -> Maybe (Int,Int) -- Just (i,n) <=> module i of n (for msgs) 310 | -> m result 311 | 312 | dumpIfaceStats :: HscEnv -> IO () 313 | dumpIfaceStats hsc_env 314 | = do { eps <- readIORef (hsc_EPS hsc_env) 315 | ; dumpIfSet (dump_if_trace || dump_rn_stats) 316 | "Interface statistics" 317 | (ifaceStats eps) } 318 | where 319 | dflags = hsc_dflags hsc_env 320 | dump_rn_stats = dopt Opt_D_dump_rn_stats dflags 321 | dump_if_trace = dopt Opt_D_dump_if_trace dflags 322 | 323 | showModuleIndex :: Maybe (Int, Int) -> String 324 | showModuleIndex Nothing = "" 325 | showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] " 326 | where 327 | n_str = show n 328 | i_str = show i 329 | padded = replicate (length n_str - length i_str) ' ' ++ i_str 330 | 331 | myCoreToStg :: DynFlags -> Module -> [CoreBind] 332 | -> IO ( [(StgBinding,[(Id,[Id])])] -- output program 333 | , CollectedCCs) -- cost centre info (declared and used) 334 | 335 | myCoreToStg dflags this_mod prepd_binds 336 | = do 337 | stg_binds <- {-# SCC "Core2Stg" #-} 338 | coreToStg (thisPackage dflags) prepd_binds 339 | 340 | (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-} 341 | stg2stg dflags this_mod stg_binds 342 | 343 | return (stg_binds2, cost_centre_info) 344 | 345 | optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm] 346 | optionallyConvertAndOrCPS hsc_env cmms = 347 | do let dflags = hsc_dflags hsc_env 348 | -------- Optionally convert to and from zipper ------ 349 | cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags 350 | then mapM (testCmmConversion hsc_env) cmms 351 | else return cmms 352 | --------- Optionally convert to CPS (MDA) ----------- 353 | cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) && 354 | dopt Opt_RunCPSZ dflags 355 | then cmmCPS dflags cmms 356 | else return cmms 357 | return cmms 358 | 359 | hscFileFrontEnd :: Comp (Maybe TcGblEnv) 360 | hscFileFrontEnd = 361 | do hsc_env <- gets compHscEnv 362 | mod_summary <- gets compModSummary 363 | 364 | ------------------- 365 | -- PARSE 366 | ------------------- 367 | let dflags = hsc_dflags hsc_env 368 | hspp_file = ms_hspp_file mod_summary 369 | hspp_buf = ms_hspp_buf mod_summary 370 | 371 | maybe_parsed <- 372 | if isLiskellSrcFilename hspp_file then 373 | liftIO $ myParseLiskellModule dflags hspp_file hspp_buf (newFreshVarStream (moduleNameString $ ms_mod_name mod_summary)) hsc_env 374 | else 375 | liftIO $ myParseModule dflags hspp_file hspp_buf 376 | case maybe_parsed of 377 | Left err 378 | -> do logMsgs (emptyBag, unitBag err) 379 | return Nothing 380 | Right rdr_module 381 | ------------------- 382 | -- RENAME and TYPECHECK 383 | ------------------- 384 | -> do (tc_msgs, maybe_tc_result) 385 | <- {-# SCC "Typecheck-Rename" #-} 386 | liftIO $ tcRnModule hsc_env (ms_hsc_src mod_summary) 387 | False rdr_module 388 | logMsgs tc_msgs 389 | return maybe_tc_result 390 | 391 | -------------------------------------------------------------- 392 | -- Desugaring 393 | -------------------------------------------------------------- 394 | 395 | hscDesugar :: TcGblEnv -> Comp (Maybe ModGuts) 396 | hscDesugar tc_result 397 | = do mod_summary <- gets compModSummary 398 | hsc_env <- gets compHscEnv 399 | 400 | ------------------- 401 | -- DESUGAR 402 | ------------------- 403 | (msgs, ds_result) 404 | <- {-# SCC "DeSugar" #-} 405 | liftIO $ deSugar hsc_env (ms_location mod_summary) tc_result 406 | logMsgs msgs 407 | return ds_result 408 | 409 | testCmmConversion :: HscEnv -> Cmm -> IO Cmm 410 | testCmmConversion hsc_env cmm = 411 | do let dflags = hsc_dflags hsc_env 412 | showPass dflags "CmmToCmm" 413 | dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm) 414 | --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm 415 | us <- mkSplitUniqSupply 'C' 416 | let cfopts = runTx $ runCmmOpts cmmCfgOptsZ 417 | let cvtm = do g <- cmmToZgraph cmm 418 | return $ cfopts g 419 | let zgraph = initUs_ us cvtm 420 | cps_zgraph <- protoCmmCPSZ hsc_env zgraph 421 | let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph 422 | dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph) 423 | showPass dflags "Convert from Z back to Cmm" 424 | let cvt = cmmOfZgraph $ cfopts $ chosen_graph 425 | dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt) 426 | return cvt 427 | -- return cmm -- don't use the conversion 428 | 429 | 430 | myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer 431 | -> IO (Either ErrMsg (Located (HsModule RdrName))) 432 | myParseModule dflags src_filename maybe_src_buf 433 | = -------------------------- Parser ---------------- 434 | showPass dflags "Parser" >> 435 | {-# SCC "Parser" #-} do 436 | 437 | -- sometimes we already have the buffer in memory, perhaps 438 | -- because we needed to parse the imports out of it, or get the 439 | -- module name. 440 | buf <- case maybe_src_buf of 441 | Just b -> return b 442 | Nothing -> hGetStringBuffer src_filename 443 | 444 | let loc = mkSrcLoc (mkFastString src_filename) 1 0 445 | 446 | case unP parseModule (mkPState buf loc dflags) of { 447 | 448 | PFailed span err -> return (Left (mkPlainErrMsg span err)); 449 | 450 | POk pst rdr_module -> do { 451 | 452 | let {ms = getMessages pst}; 453 | printErrorsAndWarnings dflags ms; -- XXX 454 | when (errorsFound dflags ms) $ exitWith (ExitFailure 1); 455 | 456 | dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; 457 | 458 | dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" 459 | (ppSourceStats False rdr_module) ; 460 | 461 | return (Right rdr_module) 462 | -- ToDo: free the string buffer later. 463 | }} 464 | 465 | myParseLiskellModule dflags src_filename maybe_src_buf fresh_var_stream hsc_env 466 | = -------------------------- Parser ---------------- 467 | showPass dflags "Parser" >> 468 | {-# SCC "Parser" #-} do 469 | 470 | -- sometimes we already have the buffer in memory, perhaps 471 | -- because we needed to parse the imports out of it, or get the 472 | -- module name. 473 | buf <- case maybe_src_buf of 474 | Just b -> return b 475 | Nothing -> hGetStringBuffer src_filename 476 | 477 | let loc = mkSrcLoc (mkFastString src_filename) 1 0 478 | 479 | env <- seedLskTrfEnv 480 | 481 | module_t <- runTM (liskell_transform_source buf loc) (TransformationState env hsc_env fresh_var_stream ([], [])) 482 | 483 | case module_t of { 484 | 485 | (Left (TrErr span err)) -> return (Left (mkPlainErrMsg span err)); 486 | 487 | Right (new_fresh_vars,rdr_module) -> 488 | do { 489 | dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module); 490 | dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" (ppSourceStats False rdr_module); 491 | 492 | return (Right rdr_module) 493 | -- ToDo: free the string buffer later. 494 | }} 495 | 496 | -- Type-check Haskell and .hs-boot only (no external core) 497 | hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails) 498 | hscCompileNothing 499 | = hscCompiler norecompBatch batchMsg comp 500 | where 501 | backend tc = hscSimpleIface tc >>= hscIgnoreIface >>= hscNothing 502 | 503 | comp = do -- genComp doesn't fit here, because we want to omit 504 | -- desugaring and for the backend to take a TcGblEnv 505 | mod_summary <- gets compModSummary 506 | case ms_hsc_src mod_summary of 507 | ExtCoreFile -> panic "hscCompileNothing: cannot do external core" 508 | _other -> do 509 | mb_tc <- hscFileFrontEnd 510 | case mb_tc of 511 | Nothing -> return Nothing 512 | Just tc_result -> backend tc_result 513 | 514 | hscIgnoreIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a) 515 | hscIgnoreIface (iface, _no_change, details, a) 516 | = return (iface, details, a) 517 | 518 | hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails) 519 | hscCompileInteractive 520 | = hscCompiler norecompInteractive batchMsg (genComp backend boot_backend) 521 | where 522 | backend inp = hscSimplify inp >>= hscNormalIface >>= hscIgnoreIface >>= hscInteractive 523 | boot_backend _ = panic "hscCompileInteractive: HsBootFile" 524 | 525 | norecompInteractive :: NoRecomp (InteractiveStatus, ModIface, ModDetails) 526 | norecompInteractive = norecompWorker InteractiveNoRecomp True 527 | 528 | 529 | hscInteractive :: (ModIface, ModDetails, CgGuts) 530 | -> Comp (Maybe (InteractiveStatus, ModIface, ModDetails)) 531 | #ifdef GHCI 532 | hscInteractive (iface, details, cgguts) 533 | = do hsc_env <- gets compHscEnv 534 | mod_summary <- gets compModSummary 535 | liftIO $ do 536 | let CgGuts{ -- This is the last use of the ModGuts in a compilation. 537 | -- From now on, we just use the bits we need. 538 | cg_module = this_mod, 539 | cg_binds = core_binds, 540 | cg_tycons = tycons, 541 | cg_foreign = foreign_stubs, 542 | cg_modBreaks = mod_breaks } = cgguts 543 | dflags = hsc_dflags hsc_env 544 | location = ms_location mod_summary 545 | data_tycons = filter isDataTyCon tycons 546 | -- cg_tycons includes newtypes, for the benefit of External Core, 547 | -- but we don't generate any code for newtypes 548 | 549 | ------------------- 550 | -- PREPARE FOR CODE GENERATION 551 | -- Do saturation and convert to A-normal form 552 | prepd_binds <- {-# SCC "CorePrep" #-} 553 | corePrepPgm dflags core_binds data_tycons ; 554 | ----------------- Generate byte code ------------------ 555 | comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks 556 | ------------------ Create f-x-dynamic C-side stuff --- 557 | (_istub_h_exists, istub_c_exists) 558 | <- outputForeignStubs dflags this_mod location foreign_stubs 559 | return (Just (InteractiveRecomp istub_c_exists comp_bc mod_breaks, iface, details)) 560 | #else 561 | hscInteractive _ = panic "GHC not compiled with interpreter" 562 | #endif 563 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} 2 | 3 | ----------------------------------------------------------------------------- 4 | -- 5 | -- GHC Driver program 6 | -- 7 | -- (c) The University of Glasgow 2005 8 | -- 9 | ----------------------------------------------------------------------------- 10 | module Main (main) where 11 | --import LskMain 12 | import LskFileHandler 13 | 14 | -- The official GHC API 15 | import qualified GHCSalat.GHC4Lsk as GHC 16 | import GHCSalat.GHC4Lsk ( DynFlags(..), HscTarget(..), 17 | GhcMode(..), GhcLink(..), 18 | LoadHowMuch(..), dopt, DynFlag(..) ) 19 | import CmdLineParser 20 | 21 | -- Implementations of the various modes (--show-iface, mkdependHS. etc.) 22 | import LoadIface ( showIface ) 23 | import HscMain ( newHscEnv ) 24 | import GHCSalat.DriverPipeline4Lsk ( oneShot, compileFile ) 25 | import DriverMkDepend ( doMkDependHS ) 26 | #ifdef GHCI 27 | import GHCSalat.InteractiveUI ( interactiveUI, ghciWelcomeMsg ) 28 | #endif 29 | 30 | -- Various other random stuff that we need 31 | import Config 32 | import HscTypes 33 | import Packages ( dumpPackages ) 34 | import DriverPhases ( Phase(..), isSourceFilename, anyHsc, 35 | startPhase, isHaskellSrcFilename ) 36 | import BasicTypes ( failed ) 37 | import StaticFlags 38 | import StaticFlagParser 39 | import DynFlags 40 | import ErrUtils 41 | import FastString 42 | import Outputable 43 | import SrcLoc 44 | import Util 45 | import Panic 46 | import MonadUtils ( liftIO ) 47 | 48 | -- Standard Haskell libraries 49 | import System.IO 50 | import System.Environment 51 | import System.Exit 52 | import System.FilePath 53 | import Control.Monad 54 | import Data.List 55 | import Data.Maybe 56 | import qualified GHC.Paths (libdir) 57 | 58 | ----------------------------------------------------------------------------- 59 | -- ToDo: 60 | 61 | -- time commands when run with -v 62 | -- user ways 63 | -- Win32 support: proper signal handling 64 | -- reading the package configuration file is too slow 65 | -- -K 66 | 67 | ----------------------------------------------------------------------------- 68 | -- GHC's command-line interface 69 | 70 | main :: IO () 71 | main = 72 | 73 | GHC.defaultErrorHandler defaultDynFlags $ do 74 | -- 1. extract the -B flag from the args 75 | argv0 <- getArgs 76 | 77 | let 78 | (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0 79 | mbMinusB | null minusB_args = Nothing 80 | | otherwise = Just (drop 2 (last minusB_args)) 81 | 82 | let argv1' = map (mkGeneralLocated "on the commandline") argv1 83 | (argv2, staticFlagWarnings) <- parseStaticFlags argv1' 84 | 85 | -- 2. Parse the "mode" flags (--make, --interactive etc.) 86 | (m_uber_mode, cli_mode, argv3, modeFlagWarnings) <- parseModeFlags argv2 87 | 88 | -- If all we want to do is to show the version number then do it 89 | -- now, before we start a GHC session etc. 90 | -- If we do it later then bootstrapping gets confused as it tries 91 | -- to find out what version of GHC it's using before package.conf 92 | -- exists, so starting the session fails. 93 | case m_uber_mode of 94 | -- ShowUsage currently has to be handled specially, as it needs to 95 | -- actually start up GHC so that it can find the usage.txt files 96 | -- in the libdir. It would be nice to embed the text in the 97 | -- executable so that we don't have to do that, and things are more 98 | -- uniform here. 99 | Just ShowUsage -> return () 100 | Just um -> 101 | do case um of 102 | ShowInfo -> showInfo 103 | ShowSupportedLanguages -> showSupportedLanguages 104 | ShowVersion -> showVersion 105 | ShowNumVersion -> putStrLn cProjectVersion 106 | exitWith ExitSuccess 107 | Nothing -> return () 108 | 109 | -- start our GHC session 110 | GHC.runGhc (Just GHC.Paths.libdir) $ do 111 | 112 | dflags0 <- GHC.getSessionDynFlags 113 | 114 | -- set the default GhcMode, HscTarget and GhcLink. The HscTarget 115 | -- can be further adjusted on a module by module basis, using only 116 | -- the -fvia-C and -fasm flags. If the default HscTarget is not 117 | -- HscC or HscAsm, -fvia-C and -fasm have no effect. 118 | let dflt_target = hscTarget dflags0 119 | (mode, lang, link) 120 | = case cli_mode of 121 | DoInteractive -> (CompManager, HscInterpreted, LinkInMemory) 122 | DoEval _ -> (CompManager, HscInterpreted, LinkInMemory) 123 | DoMake -> (CompManager, dflt_target, LinkBinary) 124 | DoMkDependHS -> (MkDepend, dflt_target, LinkBinary) 125 | _ -> (OneShot, dflt_target, LinkBinary) 126 | 127 | let dflags1 = dflags0{ ghcMode = mode, 128 | hscTarget = lang, 129 | ghcLink = link, 130 | -- leave out hscOutName for now 131 | hscOutName = panic "Main.main:hscOutName not set", 132 | verbosity = case cli_mode of 133 | DoEval _ -> 0 134 | _other -> 1 135 | } 136 | 137 | -- turn on -fimplicit-import-qualified for GHCi now, so that it 138 | -- can be overriden from the command-line 139 | dflags1a | DoInteractive <- cli_mode = imp_qual_enabled 140 | | DoEval _ <- cli_mode = imp_qual_enabled 141 | | otherwise = dflags1 142 | where imp_qual_enabled = dflags1 `dopt_set` Opt_ImplicitImportQualified 143 | 144 | -- The rest of the arguments are "dynamic" 145 | -- Leftover ones are presumably files 146 | (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1a argv3 147 | 148 | -- As noted earlier, currently we hvae to handle ShowUsage down here 149 | case m_uber_mode of 150 | Just ShowUsage -> liftIO $ showGhcUsage dflags2 cli_mode 151 | _ -> return () 152 | 153 | let flagWarnings = staticFlagWarnings 154 | ++ modeFlagWarnings 155 | ++ dynamicFlagWarnings 156 | liftIO $ handleFlagWarnings dflags2 flagWarnings 157 | 158 | -- make sure we clean up after ourselves 159 | GHC.defaultCleanupHandler dflags2 $ do 160 | 161 | liftIO $ showBanner cli_mode dflags2 162 | 163 | -- we've finished manipulating the DynFlags, update the session 164 | GHC.setSessionDynFlags dflags2 165 | dflags3 <- GHC.getSessionDynFlags 166 | hsc_env <- GHC.getSession 167 | 168 | let 169 | -- To simplify the handling of filepaths, we normalise all filepaths right 170 | -- away - e.g., for win32 platforms, backslashes are converted 171 | -- into forward slashes. 172 | normal_fileish_paths = map (normalise . unLoc) fileish_args 173 | (srcs, objs) = partition_args normal_fileish_paths [] [] 174 | 175 | -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on 176 | -- the command-line. 177 | liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse objs) 178 | 179 | ---------------- Display configuration ----------- 180 | when (verbosity dflags3 >= 4) $ 181 | liftIO $ dumpPackages dflags3 182 | 183 | when (verbosity dflags3 >= 3) $ do 184 | liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) 185 | 186 | ---------------- Final sanity checking ----------- 187 | liftIO $ checkOptions cli_mode dflags3 srcs objs 188 | 189 | ---------------- Do the business ----------- 190 | handleSourceError (\e -> do 191 | GHC.printExceptionAndWarnings e 192 | liftIO $ exitWith (ExitFailure 1)) $ do 193 | case cli_mode of 194 | PrintLibdir -> liftIO $ putStrLn (topDir dflags3) 195 | ShowInterface f -> liftIO $ doShowIface dflags3 f 196 | DoMake -> doMake srcs 197 | DoMkDependHS -> doMkDependHS (map fst srcs) 198 | StopBefore p -> oneShot hsc_env p srcs >> GHC.printWarnings 199 | DoInteractive -> interactiveUI srcs Nothing 200 | DoEval exprs -> interactiveUI srcs $ Just $ reverse exprs 201 | 202 | liftIO $ dumpFinalStats dflags3 203 | liftIO $ exitWith ExitSuccess 204 | 205 | #ifndef GHCI 206 | interactiveUI :: b -> c -> Ghc () 207 | interactiveUI _ _ = 208 | ghcError (CmdLineError "not built for interactive use") 209 | #endif 210 | 211 | -- ----------------------------------------------------------------------------- 212 | -- Splitting arguments into source files and object files. This is where we 213 | -- interpret the -x option, and attach a (Maybe Phase) to each source 214 | -- file indicating the phase specified by the -x option in force, if any. 215 | 216 | partition_args :: [String] -> [(String, Maybe Phase)] -> [String] 217 | -> ([(String, Maybe Phase)], [String]) 218 | partition_args [] srcs objs = (reverse srcs, reverse objs) 219 | partition_args ("-x":suff:args) srcs objs 220 | | "none" <- suff = partition_args args srcs objs 221 | | StopLn <- phase = partition_args args srcs (slurp ++ objs) 222 | | otherwise = partition_args rest (these_srcs ++ srcs) objs 223 | where phase = startPhase suff 224 | (slurp,rest) = break (== "-x") args 225 | these_srcs = zip slurp (repeat (Just phase)) 226 | partition_args (arg:args) srcs objs 227 | | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs 228 | | otherwise = partition_args args srcs (arg:objs) 229 | 230 | {- 231 | We split out the object files (.o, .dll) and add them 232 | to v_Ld_inputs for use by the linker. 233 | 234 | The following things should be considered compilation manager inputs: 235 | 236 | - haskell source files (strings ending in .hs, .lhs or other 237 | haskellish extension), 238 | 239 | - module names (not forgetting hierarchical module names), 240 | 241 | - and finally we consider everything not containing a '.' to be 242 | a comp manager input, as shorthand for a .hs or .lhs filename. 243 | 244 | Everything else is considered to be a linker object, and passed 245 | straight through to the linker. 246 | -} 247 | looks_like_an_input :: String -> Bool 248 | looks_like_an_input m = isSourceFilename m 249 | || looksLikeModuleName m 250 | || '.' `notElem` m 251 | 252 | -- ----------------------------------------------------------------------------- 253 | -- Option sanity checks 254 | 255 | -- | Ensure sanity of options. 256 | -- 257 | -- Throws 'UsageError' or 'CmdLineError' if not. 258 | checkOptions :: CmdLineMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO () 259 | -- Final sanity checking before kicking off a compilation (pipeline). 260 | checkOptions cli_mode dflags srcs objs = do 261 | -- Complain about any unknown flags 262 | let unknown_opts = [ f | (f@('-':_), _) <- srcs ] 263 | when (notNull unknown_opts) (unknownFlagsErr unknown_opts) 264 | 265 | when (notNull (filter isRTSWay (wayNames dflags)) 266 | && isInterpretiveMode cli_mode) $ 267 | hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi") 268 | 269 | -- -prof and --interactive are not a good combination 270 | when (notNull (filter (not . isRTSWay) (wayNames dflags)) 271 | && isInterpretiveMode cli_mode) $ 272 | do ghcError (UsageError 273 | "--interactive can't be used with -prof or -unreg.") 274 | -- -ohi sanity check 275 | if (isJust (outputHi dflags) && 276 | (isCompManagerMode cli_mode || srcs `lengthExceeds` 1)) 277 | then ghcError (UsageError "-ohi can only be used when compiling a single source file") 278 | else do 279 | 280 | -- -o sanity checking 281 | if (srcs `lengthExceeds` 1 && isJust (outputFile dflags) 282 | && not (isLinkMode cli_mode)) 283 | then ghcError (UsageError "can't apply -o to multiple source files") 284 | else do 285 | 286 | let not_linking = not (isLinkMode cli_mode) || isNoLink (ghcLink dflags) 287 | 288 | when (not_linking && not (null objs)) $ 289 | hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs) 290 | 291 | -- Check that there are some input files 292 | -- (except in the interactive case) 293 | if null srcs && (null objs || not_linking) && needsInputsMode cli_mode 294 | then ghcError (UsageError "no input files") 295 | else do 296 | 297 | -- Verify that output files point somewhere sensible. 298 | verifyOutputFiles dflags 299 | 300 | 301 | -- Compiler output options 302 | 303 | -- called to verify that the output files & directories 304 | -- point somewhere valid. 305 | -- 306 | -- The assumption is that the directory portion of these output 307 | -- options will have to exist by the time 'verifyOutputFiles' 308 | -- is invoked. 309 | -- 310 | verifyOutputFiles :: DynFlags -> IO () 311 | verifyOutputFiles dflags = do 312 | -- not -odir: we create the directory for -odir if it doesn't exist (#2278). 313 | let ofile = outputFile dflags 314 | when (isJust ofile) $ do 315 | let fn = fromJust ofile 316 | flg <- doesDirNameExist fn 317 | when (not flg) (nonExistentDir "-o" fn) 318 | let ohi = outputHi dflags 319 | when (isJust ohi) $ do 320 | let hi = fromJust ohi 321 | flg <- doesDirNameExist hi 322 | when (not flg) (nonExistentDir "-ohi" hi) 323 | where 324 | nonExistentDir flg dir = 325 | ghcError (CmdLineError ("error: directory portion of " ++ 326 | show dir ++ " does not exist (used with " ++ 327 | show flg ++ " option.)")) 328 | 329 | ----------------------------------------------------------------------------- 330 | -- GHC modes of operation 331 | 332 | data UberMode 333 | = ShowUsage -- ghc -? 334 | | ShowVersion -- ghc -V/--version 335 | | ShowNumVersion -- ghc --numeric-version 336 | | ShowSupportedLanguages -- ghc --supported-languages 337 | | ShowInfo -- ghc --info 338 | deriving (Show) 339 | 340 | data CmdLineMode 341 | = PrintLibdir -- ghc --print-libdir 342 | | ShowInterface String -- ghc --show-iface 343 | | DoMkDependHS -- ghc -M 344 | | StopBefore Phase -- ghc -E | -C | -S 345 | -- StopBefore StopLn is the default 346 | | DoMake -- ghc --make 347 | | DoInteractive -- ghc --interactive 348 | | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"] 349 | deriving (Show) 350 | 351 | #ifdef GHCI 352 | isInteractiveMode :: CmdLineMode -> Bool 353 | isInteractiveMode DoInteractive = True 354 | isInteractiveMode _ = False 355 | #endif 356 | 357 | -- isInterpretiveMode: byte-code compiler involved 358 | isInterpretiveMode :: CmdLineMode -> Bool 359 | isInterpretiveMode DoInteractive = True 360 | isInterpretiveMode (DoEval _) = True 361 | isInterpretiveMode _ = False 362 | 363 | needsInputsMode :: CmdLineMode -> Bool 364 | needsInputsMode DoMkDependHS = True 365 | needsInputsMode (StopBefore _) = True 366 | needsInputsMode DoMake = True 367 | needsInputsMode _ = False 368 | 369 | -- True if we are going to attempt to link in this mode. 370 | -- (we might not actually link, depending on the GhcLink flag) 371 | isLinkMode :: CmdLineMode -> Bool 372 | isLinkMode (StopBefore StopLn) = True 373 | isLinkMode DoMake = True 374 | isLinkMode DoInteractive = True 375 | isLinkMode (DoEval _) = True 376 | isLinkMode _ = False 377 | 378 | isCompManagerMode :: CmdLineMode -> Bool 379 | isCompManagerMode DoMake = True 380 | isCompManagerMode DoInteractive = True 381 | isCompManagerMode (DoEval _) = True 382 | isCompManagerMode _ = False 383 | 384 | 385 | -- ----------------------------------------------------------------------------- 386 | -- Parsing the mode flag 387 | 388 | parseModeFlags :: [Located String] 389 | -> IO (Maybe UberMode, 390 | CmdLineMode, 391 | [Located String], 392 | [Located String]) 393 | parseModeFlags args = do 394 | let ((leftover, errs, warns), (mUberMode, mode, _, flags')) = 395 | runCmdLine (processArgs mode_flags args) 396 | (Nothing, StopBefore StopLn, "", []) 397 | when (not (null errs)) $ ghcError $ errorsToGhcException errs 398 | return (mUberMode, mode, flags' ++ leftover, warns) 399 | 400 | type ModeM = CmdLineP (Maybe UberMode, CmdLineMode, String, [Located String]) 401 | -- mode flags sometimes give rise to new DynFlags (eg. -C, see below) 402 | -- so we collect the new ones and return them. 403 | 404 | mode_flags :: [Flag ModeM] 405 | mode_flags = 406 | [ ------- help / version ---------------------------------------------- 407 | Flag "?" (NoArg (setUberMode ShowUsage)) 408 | Supported 409 | , Flag "-help" (NoArg (setUberMode ShowUsage)) 410 | Supported 411 | , Flag "V" (NoArg (setUberMode ShowVersion)) 412 | Supported 413 | , Flag "-version" (NoArg (setUberMode ShowVersion)) 414 | Supported 415 | , Flag "-numeric-version" (NoArg (setUberMode ShowNumVersion)) 416 | Supported 417 | , Flag "-info" (NoArg (setUberMode ShowInfo)) 418 | Supported 419 | , Flag "-supported-languages" (NoArg (setUberMode ShowSupportedLanguages)) 420 | Supported 421 | , Flag "-print-libdir" (PassFlag (setMode PrintLibdir)) 422 | Supported 423 | 424 | ------- interfaces ---------------------------------------------------- 425 | , Flag "-show-iface" (HasArg (\f -> setMode (ShowInterface f) 426 | "--show-iface")) 427 | Supported 428 | 429 | ------- primary modes ------------------------------------------------ 430 | , Flag "M" (PassFlag (setMode DoMkDependHS)) 431 | Supported 432 | , Flag "E" (PassFlag (setMode (StopBefore anyHsc))) 433 | Supported 434 | , Flag "C" (PassFlag (\f -> do setMode (StopBefore HCc) f 435 | addFlag "-fvia-C")) 436 | Supported 437 | , Flag "S" (PassFlag (setMode (StopBefore As))) 438 | Supported 439 | , Flag "-make" (PassFlag (setMode DoMake)) 440 | Supported 441 | , Flag "-interactive" (PassFlag (setMode DoInteractive)) 442 | Supported 443 | , Flag "e" (HasArg (\s -> updateMode (updateDoEval s) "-e")) 444 | Supported 445 | 446 | -- -fno-code says to stop after Hsc but don't generate any code. 447 | , Flag "fno-code" (PassFlag (\f -> do setMode (StopBefore HCc) f 448 | addFlag "-fno-code" 449 | addFlag "-fforce-recomp")) 450 | Supported 451 | ] 452 | 453 | setUberMode :: UberMode -> ModeM () 454 | setUberMode m = do 455 | (_, cmdLineMode, flag, flags') <- getCmdLineState 456 | putCmdLineState (Just m, cmdLineMode, flag, flags') 457 | 458 | setMode :: CmdLineMode -> String -> ModeM () 459 | setMode m flag = updateMode (\_ -> m) flag 460 | 461 | updateDoEval :: String -> CmdLineMode -> CmdLineMode 462 | updateDoEval expr (DoEval exprs) = DoEval (expr : exprs) 463 | updateDoEval expr _ = DoEval [expr] 464 | 465 | updateMode :: (CmdLineMode -> CmdLineMode) -> String -> ModeM () 466 | updateMode f flag = do 467 | (m_uber_mode, old_mode, old_flag, flags') <- getCmdLineState 468 | if null old_flag || flag == old_flag 469 | then putCmdLineState (m_uber_mode, f old_mode, flag, flags') 470 | else ghcError (UsageError 471 | ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'")) 472 | 473 | addFlag :: String -> ModeM () 474 | addFlag s = do 475 | (u, m, f, flags') <- getCmdLineState 476 | -- XXX Can we get a useful Loc? 477 | putCmdLineState (u, m, f, mkGeneralLocated "addFlag" s : flags') 478 | 479 | 480 | -- ---------------------------------------------------------------------------- 481 | -- Run --make mode 482 | 483 | doMake :: [(String,Maybe Phase)] -> Ghc () 484 | doMake [] = ghcError (UsageError "no input files") 485 | doMake srcs = do 486 | let (hs_srcs, non_hs_srcs) = partition haskellish srcs 487 | 488 | haskellish (f,Nothing) = 489 | looksLikeModuleName f || isHaskellSrcFilename f || isLiskellSrcFilename f || '.' `notElem` f 490 | haskellish (_,Just phase) = 491 | phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn] 492 | 493 | hsc_env <- GHC.getSession 494 | o_files <- mapM (\x -> do 495 | f <- compileFile hsc_env StopLn x 496 | GHC.printWarnings 497 | return f) 498 | non_hs_srcs 499 | liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files) 500 | 501 | targets <- mapM (uncurry GHC.guessTarget) hs_srcs 502 | GHC.setTargets targets 503 | ok_flag <- GHC.load LoadAllTargets 504 | 505 | when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1)) 506 | return () 507 | 508 | 509 | -- --------------------------------------------------------------------------- 510 | -- --show-iface mode 511 | 512 | doShowIface :: DynFlags -> FilePath -> IO () 513 | doShowIface dflags file = do 514 | hsc_env <- newHscEnv dflags 515 | showIface hsc_env file 516 | 517 | -- --------------------------------------------------------------------------- 518 | -- Various banners and verbosity output. 519 | 520 | showBanner :: CmdLineMode -> DynFlags -> IO () 521 | showBanner _cli_mode dflags = do 522 | let verb = verbosity dflags 523 | 524 | #ifdef GHCI 525 | -- Show the GHCi banner 526 | when (isInteractiveMode _cli_mode && verb >= 1) $ putStrLn ghciWelcomeMsg 527 | #endif 528 | 529 | -- Display details of the configuration in verbose mode 530 | when (verb >= 2) $ 531 | do hPutStr stderr "Glasgow Haskell Compiler, Version " 532 | hPutStr stderr cProjectVersion 533 | hPutStr stderr ", for Haskell 98, stage " 534 | hPutStr stderr cStage 535 | hPutStr stderr " booted by GHC version " 536 | hPutStrLn stderr cBooterVersion 537 | 538 | -- We print out a Read-friendly string, but a prettier one than the 539 | -- Show instance gives us 540 | showInfo :: IO () 541 | showInfo = do 542 | let sq x = " [" ++ x ++ "\n ]" 543 | putStrLn $ sq $ concat $ intersperse "\n ," $ map show compilerInfo 544 | exitWith ExitSuccess 545 | 546 | showSupportedLanguages :: IO () 547 | showSupportedLanguages = do mapM_ putStrLn supportedLanguages 548 | exitWith ExitSuccess 549 | 550 | showVersion :: IO () 551 | showVersion = do 552 | putStrLn (cProjectName ++ ", version " ++ cProjectVersion) 553 | exitWith ExitSuccess 554 | 555 | showGhcUsage :: DynFlags -> CmdLineMode -> IO () 556 | showGhcUsage dflags cli_mode = do 557 | let usage_path 558 | | DoInteractive <- cli_mode = ghciUsagePath dflags 559 | | otherwise = ghcUsagePath dflags 560 | usage <- readFile usage_path 561 | dump usage 562 | exitWith ExitSuccess 563 | where 564 | dump "" = return () 565 | dump ('$':'$':s) = putStr progName >> dump s 566 | dump (c:s) = putChar c >> dump s 567 | 568 | dumpFinalStats :: DynFlags -> IO () 569 | dumpFinalStats dflags = 570 | when (dopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags 571 | 572 | dumpFastStringStats :: DynFlags -> IO () 573 | dumpFastStringStats dflags = do 574 | buckets <- getFastStringTable 575 | let (entries, longest, is_z, has_z) = countFS 0 0 0 0 buckets 576 | msg = text "FastString stats:" $$ 577 | nest 4 (vcat [text "size: " <+> int (length buckets), 578 | text "entries: " <+> int entries, 579 | text "longest chain: " <+> int longest, 580 | text "z-encoded: " <+> (is_z `pcntOf` entries), 581 | text "has z-encoding: " <+> (has_z `pcntOf` entries) 582 | ]) 583 | -- we usually get more "has z-encoding" than "z-encoded", because 584 | -- when we z-encode a string it might hash to the exact same string, 585 | -- which will is not counted as "z-encoded". Only strings whose 586 | -- Z-encoding is different from the original string are counted in 587 | -- the "z-encoded" total. 588 | putMsg dflags msg 589 | where 590 | x `pcntOf` y = int ((x * 100) `quot` y) <> char '%' 591 | 592 | countFS :: Int -> Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int, Int) 593 | countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z) 594 | countFS entries longest is_z has_z (b:bs) = 595 | let 596 | len = length b 597 | longest' = max len longest 598 | entries' = entries + len 599 | is_zs = length (filter isZEncoded b) 600 | has_zs = length (filter hasZEncoding b) 601 | in 602 | countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs 603 | 604 | -- ----------------------------------------------------------------------------- 605 | -- Util 606 | 607 | unknownFlagsErr :: [String] -> a 608 | unknownFlagsErr fs = ghcError (UsageError ("unrecognised flags: " ++ unwords fs)) 609 | --------------------------------------------------------------------------------