atuin (empty) → 0.1.1
raw patch · 14 files changed
+1080/−0 lines, 14 filesdep +Cabaldep +arraydep +basebuild-type:Customsetup-changedbinary-added
Dependencies added: Cabal, array, base, directory, epic, haskell98
Files
- LICENSE +32/−0
- Setup.hs +39/−0
- atuin.cabal +26/−0
- sdl/Makefile +15/−0
- sdl/sdlrun.c +151/−0
- sdl/sdlrun.h +27/−0
- sdl/sdlrun.o binary
- src/Lexer.lhs +213/−0
- src/Main.lhs +18/−0
- src/Makefile +4/−0
- src/MkEpic.lhs +159/−0
- src/Parser.y +148/−0
- src/SDLprims.lhs +199/−0
- src/Turtle.lhs +49/−0
+ LICENSE view
@@ -0,0 +1,32 @@+Copyright (c) 2006 Edwin Brady+ School of Computer Science, University of St Andrews+All rights reserved.++This code is derived from software written by Edwin Brady+(eb@dcs.st-and.ac.uk).++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. None of the names of the copyright holders may be used to endorse+ or promote products derived from this software without specific+ prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ``AS IS'' AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR+BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN+IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++*** End of disclaimer. ***
+ Setup.hs view
@@ -0,0 +1,39 @@+import Distribution.Simple+import Distribution.Simple.InstallDirs+import Distribution.Simple.LocalBuildInfo+import Distribution.PackageDescription++import System++system' cmd = do + exit <- system cmd+ case exit of+ ExitSuccess -> return ()+ ExitFailure _ -> exitWith exit++buildLib args flags desc local + = system' "make -C sdl"++findSDL args flags+ = do system' "make -C src SDLflags.hs"+ return emptyHookedBuildInfo++-- This is a hack. I don't know how to tell cabal that a data file needs+-- installing but shouldn't be in the distribution. And it won't make the+-- distribution if it's not there, so instead I just delete+-- the file after configure.++postConfLib args flags desc local+ = system' "make -C sdl clean"++addPrefix pfx var c = "export " ++ var ++ "=" ++ show pfx ++ "/" ++ c ++ ":$" ++ var++postInstLib args flags desc local+ = do let pfx = prefix (installDirTemplates local)+ system' $ "make -C sdl install PREFIX=" ++ show pfx++main = defaultMainWithHooks (simpleUserHooks { preBuild = findSDL,+ postBuild = buildLib,+ postConf = postConfLib,+ postInst = postInstLib })+
+ atuin.cabal view
@@ -0,0 +1,26 @@+Name: atuin+Version: 0.1.1+Author: Edwin Brady+License: BSD3+License-file: LICENSE+Maintainer: eb@cs.st-andrews.ac.uk+Homepage: http://www.dcs.st-and.ac.uk/~eb/epic.php+Stability: experimental+Category: Compilers/Interpreters+Synopsis: Embedded Turtle language compiler in Haskell, with Epic output+Description: This language is a demonstration of the Epic compiler API.+ It is a dynamically typed language with higher order+ functions and system interaction (specifically graphics). + Requires SDL and SDL_gfx libraries, and their C headers.+Data-files: sdl/sdlrun.o sdl/sdlrun.h+Extra-source-files: sdl/Makefile sdl/sdlrun.c sdl/sdlrun.h src/Makefile++Cabal-Version: >= 1.6+Build-type: Custom++Executable atuin+ Main-is: Main.lhs+ hs-source-dirs: src+ Other-modules: Turtle MkEpic SDLprims Lexer Parser Paths_atuin+ Build-depends: base >=4 && <5, haskell98, Cabal, array,+ directory, epic
+ sdl/Makefile view
@@ -0,0 +1,15 @@+CC = gcc +CFLAGS = `epic -includedirs`++INSTALLDIR = ${PREFIX}/lib/elogo++sdlrun.o : sdlrun.c sdlrun.h++install:+ mkdir -p ${INSTALLDIR}+ install sdlrun.o sdlrun.h ${INSTALLDIR}++clean:+ rm -f sdlrun.o++.PHONY:
+ sdl/sdlrun.c view
@@ -0,0 +1,151 @@+#include <stdio.h>+#include <SDL/SDL.h>+#include <SDL/SDL_gfxPrimitives.h>++#include <closure.h>++SDL_Surface* graphicsInit(int xsize, int ysize) {+ SDL_Surface *screen;++ if(SDL_Init(SDL_INIT_TIMER | SDL_INIT_VIDEO | SDL_INIT_AUDIO) <0 )+ {+ printf("Unable to init SDL: %s\n", SDL_GetError());+ return NULL;+ }++ screen = SDL_SetVideoMode(xsize, ysize, 32,+ SDL_HWSURFACE | SDL_DOUBLEBUF);+ if (screen==NULL) {+ printf("Unable to init SDL: %s\n", SDL_GetError());+ return NULL;+ }++ return screen;+}++void filledRect(void *s_in,+ int x, int y, int w, int h,+ int r, int g, int b, int a) +{+ SDL_Surface* s = (SDL_Surface*)s_in;+ Uint32 colour + = SDL_MapRGBA(s->format, (Uint8)r, (Uint8)g, (Uint8)b, (Uint8) a);+ SDL_Rect rect = { x, y, w, h };+ SDL_FillRect(s, &rect, colour);+}++void filledEllipse(void* s_in,+ int x, int y, int rx, int ry,+ int r, int g, int b, int a) +{+ SDL_Surface* s = (SDL_Surface*)s_in;+ filledEllipseRGBA(s, x, y, rx, ry, r, g, b, a);+}++void drawLine(void* s_in,+ int x, int y, int ex, int ey,+ int r, int g, int b, int a) +{+ SDL_Surface* s = (SDL_Surface*)s_in;+ lineRGBA(s, x, y, ex, ey, r, g, b, a);+}+++void flipBuffers(void* s_in) {+ SDL_Surface* s = (SDL_Surface*)s_in;+ SDL_Flip(s);+}++void* startSDL(int x, int y) {+ SDL_Surface *s = graphicsInit(x, y);+ return (void*)s;+}++VAL KEY(int tag, SDLKey key) {+ VAL k;+ switch(key) {+ case SDLK_UP:+ k = CONSTRUCTOR(0,0,NULL);+ break;+ case SDLK_DOWN:+ k = CONSTRUCTOR(1,0,NULL);+ break;+ case SDLK_LEFT:+ k = CONSTRUCTOR(2,0,NULL);+ break;+ case SDLK_RIGHT:+ k = CONSTRUCTOR(3,0,NULL);+ break;+ default:+ k = CONSTRUCTOR1(4,MKINT((int)key));+ break;+ }+ return CONSTRUCTOR1(tag, k);+}++void* pollEvent() +{+ SDL_Event event; // = (SDL_Event *) GC_MALLOC(sizeof(SDL_Event));+ int r = SDL_PollEvent(&event);+ if (r==0) {+ // FIXME: This will do something different depending on erasure...+ // Probably the only way is to generate C glue for an idris module?+ // Assuming erasure here.+ return CONSTRUCTOR(1,0,NULL); // Nothing+ }+ else {+ VAL ievent = NULL;+ switch(event.type) {+ case SDL_KEYDOWN:+ ievent = KEY(0, event.key.keysym.sym);+ break;+ case SDL_KEYUP:+ ievent = KEY(1, event.key.keysym.sym);+ break;+ case SDL_QUIT:+ ievent = CONSTRUCTOR(2,0,NULL);+ break;+ default:+ // FIXME: This will do something different depending on erasure...+ // Assuming erasure+ return CONSTRUCTOR(1,0,NULL); // Nothing+ }+ // FIXME: This will do something different depending on erasure...+ // Assuming erasure+ return (void*)(CONSTRUCTOR1(0, ievent)); // Just ievent+ }+}++void pressAnyKey() +{+ while(1) {+ SDL_Event event; // = (SDL_Event *) GC_MALLOC(sizeof(SDL_Event));+ SDL_WaitEvent(&event);+ if (event.type == SDL_KEYUP) { return; }+ }+}++void* waitEvent() +{+ SDL_Event event; // = (SDL_Event *) GC_MALLOC(sizeof(SDL_Event));+ SDL_WaitEvent(&event);++ VAL ievent = NULL;+ switch(event.type) {+ case SDL_KEYDOWN:+ ievent = KEY(0, event.key.keysym.sym);+ break;+ case SDL_KEYUP:+ ievent = KEY(1, event.key.keysym.sym);+ break;+ case SDL_QUIT:+ ievent = CONSTRUCTOR(2,0,NULL);+ break;+ default:+ // FIXME: This will do something different depending on erasure...+ // Assuming erasure+ return CONSTRUCTOR(1,0,NULL); // Nothing+ }+ return (void*)(CONSTRUCTOR1(0, ievent)); // Just ievent+}+
+ sdl/sdlrun.h view
@@ -0,0 +1,27 @@+#ifndef __SDLRUN_H+#define __SDLRUN_H++// Start SDL, open a window with dimensions (x,y)+void* startSDL(int x, int y);++void flipBuffers(void* s_in);++// Drawing primitives++void filledRect(void *s,+ int x, int y, int w, int h,+ int r, int g, int b, int a);+void filledEllipse(void* s_in,+ int x, int y, int rx, int ry,+ int r, int g, int b, int a);+void drawLine(void* s_in,+ int x, int y, int ex, int ey,+ int r, int g, int b, int a);++// Events+void* pollEvent(); // builds an Epic value+void* waitEvent(); // builds an Epic value++void pressAnyKey(); ++#endif
+ sdl/sdlrun.o view
binary file changed (absent → 2724 bytes)
+ src/Lexer.lhs view
@@ -0,0 +1,213 @@+> module Lexer where++> import Char++> import Turtle++> type Result a = Either (String, FilePath, Int) a++> type LineNumber = Int+> type P a = String -> String -> LineNumber -> Result a+ +> getLineNo :: P LineNumber+> getLineNo = \s fn l -> Right l+ +> getFileName :: P String+> getFileName = \s fn l -> Right fn+ +> getContent :: P String+> getContent = \s fn l -> Right s+ +> thenP :: P a -> (a -> P b) -> P b+> m `thenP` k = \s fn l -> case m s fn l of+> Right a -> k a s fn l+> Left (e, f, ln) -> Left (e, f, ln)+ +> returnP :: a -> P a+> returnP a = \s fn l -> Right a+> +> failP :: String -> P a+> failP err = \s fn l -> Left (err, fn, l)+ +> catchP :: P a -> (String -> P a) -> P a+> catchP m k = \s fn l ->+> case m s fn l of+> Right a -> Right a+> Left (e, f, ln) -> k e s fn l+ +> happyError :: P a+> happyError = reportError "Parse error"+ +> reportError :: String -> P a+> reportError err = getFileName `thenP` \fn ->+> getLineNo `thenP` \line ->+> getContent `thenP` \content ->+> failP (fn ++ ":" ++ show line ++ ":" ++ err ++ " at " ++ take 40 content ++ " ...")+ +> data Token +> = TokenName Id+> | TokenString String+> | TokenInt Int+> | TokenChar Char+> | TokenBool Bool+> | TokenOB+> | TokenCB+> | TokenOCB+> | TokenCCB+> | TokenOSB+> | TokenCSB+> | TokenPlus+> | TokenMinus+> | TokenTimes+> | TokenDivide+> | TokenEquals+> | TokenEQ+> | TokenGE+> | TokenLE+> | TokenGT+> | TokenLT+> | TokenLet+> | TokenIn+> | TokenIf+> | TokenThen+> | TokenElse+> | TokenRepeat+> | TokenSemi+> | TokenComma+> | TokenMkCol Colour+> | TokenEval+> | TokenFD+> | TokenRight+> | TokenLeft+> | TokenColour+> | TokenPenUp+> | TokenPenDown+> | TokenEOF+> deriving (Show, Eq)+> +> +> lexer :: (Token -> P a) -> P a+> lexer cont [] = cont TokenEOF []+> lexer cont ('\n':cs) = \fn line -> lexer cont cs fn (line+1)+> lexer cont (c:cs)+> | isSpace c = \fn line -> lexer cont cs fn line+> | isAlpha c = lexVar cont (c:cs)+> | isDigit c = lexNum cont (c:cs)+> | c == '_' = lexVar cont (c:cs)+> lexer cont ('"':cs) = lexString cont cs+> lexer cont ('\'':cs) = lexChar cont cs+> lexer cont ('{':'-':cs) = lexerEatComment 0 cont cs+> lexer cont ('-':'-':cs) = lexerEatToNewline cont cs+> lexer cont ('(':cs) = cont TokenOB cs+> lexer cont (')':cs) = cont TokenCB cs+> lexer cont ('{':cs) = cont TokenOCB cs+> lexer cont ('}':cs) = cont TokenCCB cs+> lexer cont ('[':cs) = cont TokenOSB cs+> lexer cont (']':cs) = cont TokenCSB cs+> lexer cont ('+':cs) = cont TokenPlus cs+> lexer cont ('-':cs) = cont TokenMinus cs+> lexer cont ('*':cs) = cont TokenTimes cs+> lexer cont ('/':cs) = cont TokenDivide cs+> lexer cont ('=':'=':cs) = cont TokenEQ cs+> lexer cont ('>':'=':cs) = cont TokenGE cs+> lexer cont ('<':'=':cs) = cont TokenLE cs+> lexer cont ('>':cs) = cont TokenGT cs+> lexer cont ('<':cs) = cont TokenLT cs+> lexer cont ('=':cs) = cont TokenEquals cs+> lexer cont (';':cs) = cont TokenSemi cs+> lexer cont (',':cs) = cont TokenComma cs+> lexer cont (c:cs) = lexError c cs+ +> lexError c s f l = failP (show l ++ ": Unrecognised token '" ++ [c] ++ "'\n") s f l++> lexerEatComment nls cont ('-':'}':cs)+> = \fn line -> lexer cont cs fn (line+nls)+> lexerEatComment nls cont ('\n':cs) = lexerEatComment (nls+1) cont cs+> lexerEatComment nls cont (c:cs) = lexerEatComment nls cont cs+> +> lexerEatToNewline cont ('\n':cs)+> = \fn line -> lexer cont cs fn (line+1)+> lexerEatToNewline cont (c:cs) = lexerEatToNewline cont cs++> lexNum cont cs = case (span isDigit cs) of+> (num, rest) ->+> cont (TokenInt (read num)) rest++> lexString cont cs =+> \fn line ->+> case getstr cs of+> Just (str,rest,nls) -> cont (TokenString str) rest fn (nls+line)+> Nothing -> failP (fn++":"++show line++":Unterminated string contant")+> cs fn line++> lexChar cont cs =+> \fn line ->+> case getchar cs of+> Just (str,rest) -> cont (TokenChar str) rest fn line+> Nothing -> +> failP (fn++":"++show line++":Unterminated character constant")+> cs fn line++> isAllowed c = isAlpha c || isDigit c || c `elem` "_\'?#"++> lexVar cont cs =+> case span isAllowed cs of+> ("true",rest) -> cont (TokenBool True) rest+> ("false",rest) -> cont (TokenBool False) rest+> -- expressions+> ("let",rest) -> cont TokenLet rest+> ("if",rest) -> cont TokenIf rest+> ("then",rest) -> cont TokenThen rest+> ("else",rest) -> cont TokenElse rest+> ("repeat",rest) -> cont TokenRepeat rest+> ("in",rest) -> cont TokenIn rest+> ("eval",rest) -> cont TokenEval rest+> -- commands+> ("forward",rest) -> cont TokenFD rest+> ("right",rest) -> cont TokenRight rest+> ("left",rest) -> cont TokenLeft rest+> ("colour",rest) -> cont TokenColour rest+> ("penup",rest) -> cont TokenPenUp rest+> ("pendown",rest) -> cont TokenPenDown rest+> -- colours+> ("black",rest) -> cont (TokenMkCol Black) rest+> ("red",rest) -> cont (TokenMkCol Red) rest+> ("green",rest) -> cont (TokenMkCol Green) rest+> ("blue",rest) -> cont (TokenMkCol Blue) rest+> ("yellow",rest) -> cont (TokenMkCol Yellow) rest+> ("cyan",rest) -> cont (TokenMkCol Cyan) rest+> ("magenta",rest) -> cont (TokenMkCol Magenta) rest+> ("white",rest) -> cont (TokenMkCol White) rest+> (var,rest) -> cont (mkname var) rest+ +> mkname :: String -> Token+> mkname c = TokenName (mkId c)++> getstr :: String -> Maybe (String,String,Int)+> getstr cs = case getstr' "" cs 0 of+> Just (str,rest,nls) -> Just (reverse str,rest,nls)+> _ -> Nothing+> getstr' acc ('\"':xs) = \nl -> Just (acc,xs,nl)+> getstr' acc ('\\':'n':xs) = getstr' ('\n':acc) xs -- Newline+> getstr' acc ('\\':'r':xs) = getstr' ('\r':acc) xs -- CR+> getstr' acc ('\\':'t':xs) = getstr' ('\t':acc) xs -- Tab+> getstr' acc ('\\':'b':xs) = getstr' ('\b':acc) xs -- Backspace+> getstr' acc ('\\':'a':xs) = getstr' ('\a':acc) xs -- Alert+> getstr' acc ('\\':'f':xs) = getstr' ('\f':acc) xs -- Formfeed+> getstr' acc ('\\':'0':xs) = getstr' ('\0':acc) xs -- null+> getstr' acc ('\\':x:xs) = getstr' (x:acc) xs -- Literal+> getstr' acc ('\n':xs) = \nl ->getstr' ('\n':acc) xs (nl+1) -- Count the newline+> getstr' acc (x:xs) = getstr' (x:acc) xs+> getstr' _ _ = \nl -> Nothing+ +> getchar :: String -> Maybe (Char,String)+> getchar ('\\':'n':'\'':xs) = Just ('\n',xs) -- Newline+> getchar ('\\':'r':'\'':xs) = Just ('\r',xs) -- CR+> getchar ('\\':'t':'\'':xs) = Just ('\t',xs) -- Tab+> getchar ('\\':'b':'\'':xs) = Just ('\b',xs) -- Backspace+> getchar ('\\':'a':'\'':xs) = Just ('\a',xs) -- Alert+> getchar ('\\':'f':'\'':xs) = Just ('\f',xs) -- Formfeed+> getchar ('\\':'0':'\'':xs) = Just ('\0',xs) -- null+> getchar ('\\':x:'\'':xs) = Just (x,xs) -- Literal+> getchar (x:'\'':xs) = Just (x,xs)+> getchar _ = Nothing
+ src/Main.lhs view
@@ -0,0 +1,18 @@+> module Main where++> import Parser+> import MkEpic++> import System++> usage [inf, outf] = return (inf, outf)+> usage _ = fail "Usage: atuin [input] [output]"++> main :: IO ()+> main = do args <- getArgs+> (inf, outf) <- usage args+> putStrLn $ "Compiling " ++ inf ++ " to " ++ outf+> prog <- parseFile (args!!0)+> case prog of+> Left (e, f, l) -> putStrLn $ f ++ ":" ++ show l ++ ":" ++ e+> Right p -> output p (args !! 1)
+ src/Makefile view
@@ -0,0 +1,4 @@+SDLflags.hs: .PHONY+ echo "module SDLflags where\nsdlflags=\"`sdl-config --libs`\"" > SDLflags.hs++.PHONY:
+ src/MkEpic.lhs view
@@ -0,0 +1,159 @@+> module MkEpic(output) where++Convert a Turtle program into an Epic program++> import Turtle+> import SDLprims+> import SDLflags+> import Paths_atuin++> import Epic.Epic as Epic hiding (compile)++> opts = [GCCOpt (sdlflags ++ " -l SDL_gfx"), MainInc "SDL/SDL.h"]++Epic takes Strings as identifiers, so we'll need to convert our identifiers+to strings...++> fullId :: Id -> String+> fullId n = e n+> where e [] = ""+> e (x:xs) = "_" ++ x ++ e xs++...then to Epic identifiers.++> epicId :: Id -> Name+> epicId i = name (fullId i)++The main compiler function, turns a logo program into an Epic+term. Just traverses a Turtle and calls the appropriate Epic+primitives, and the primitives we've defined in SDLprims.++The compiled program maintains a turtle state, so we'll pass the+state to the compiler.++> class Compile a where+> compile :: Expr -> a -> Term++> instance Compile Turtle where++When we sequence commands, we need to pass the new state from the first+command as input to the second command.++> compile state (Seq x y) +> = let_ (compile state x) (\state' -> compile state' y)+> compile state (Turtle c) = compile state c++When applying a function we need to add the state as the first argument.++> compile state (Call i es) +> = app (fn (fullId i) @@ state) es+> where app f [] = f+> app f (e:es) = app (f @@ compile state e) es++> compile state (If a t e) = if_ (getBool (compile state a))+> (compile state t) (compile state e)++To repeat an action n times, call the "repeat" function. The action itself+is parameterised over a state becaue it'll have a different state at each+step of the loop. It's really handy to be able to use a Haskell function+here! ++> compile state (Repeat n e) = fn "repeat" @@ state +> @@ compile state n+> @@ (\st -> compile st e)++> compile state (Let i e scope) +> = letN_ (epicId i) (compile state e) (compile state scope)++To evaluate a delayed expression, pass it the current state.++> compile state (Eval e) = effect_ (compile state e @@ state)+> compile state Pass = unit_++It's a dynamically typed language, so when we compute an expression we+need to check the values are the right type at each step. The primitives+in SDLprims do this for us.++> instance Compile Exp where+> compile state (Infix op l r) +> = (mkOp op) (compile state l) (compile state r)+> where mkOp Turtle.Plus = primPlus+> mkOp Turtle.Minus = primMinus+> mkOp Turtle.Times = primTimes+> mkOp Turtle.Divide = primDivide+> mkOp Turtle.Eq = primEq+> mkOp Turtle.LT = primLT+> mkOp Turtle.LE = primLE+> mkOp Turtle.GT = primGT+> mkOp Turtle.GE = primGE+> compile state (Var i) = ref (epicId i)+> compile state (Const i) = compile state i++Delay evaluation of a code block. When we get around to evaluating it,+we'll want to use the state at that point, not the state when the block is+built, so make this a function.++> compile state (Block t) = lazy_ (\st -> compile st t)++Values are wrapped in an ADT so we can see what type they are.+i.e. data Value = MkInt Int | MkString Str | ...+Primitives are defined for building these in SDLprims.++> instance Compile Const where+> compile state (MkInt i) = mkint (int i)+> compile state (MkString s) = mkstr (str s)+> compile state (MkChar c) = mkchar (char c)+> compile state (MkBool b) = mkbool (bool b)+> compile state (MkCol Black) = mkcol col_black+> compile state (MkCol Red) = mkcol col_red+> compile state (MkCol Green) = mkcol col_green+> compile state (MkCol Blue) = mkcol col_blue+> compile state (MkCol Yellow) = mkcol col_yellow+> compile state (MkCol Cyan) = mkcol col_cyan+> compile state (MkCol Magenta) = mkcol col_magenta+> compile state (MkCol White) = mkcol col_white++For turtle commands, we've also defined some primitives, so we just apply+them to the current state and the given argument.++> instance Compile Command where+> compile state (Fd i) = fn "forward" @@ state @@ compile state i+> compile state (Rt i) = fn "right" @@ state @@ compile state i+> compile state (Lt i) = fn "left" @@ state @@ compile state i+> compile state (Colour c) = fn "colour" @@ state @@ compile state c+> compile state PenUp = fn "pen" @@ state @@ bool False+> compile state PenDown = fn "pen" @@ state @@ bool True++Convert a function with arguments into an Epic definition. We have the+arguments in the definition, plus an additional state added by the system+which carries the turtle state and SDL surface.++> mkEpic :: (Id, Function) -> (Name, EpicDecl)+> mkEpic (i, (args, p)) +> = (epicId i, EpicFn (\ state -> (map epicId args, compile state p)))++Epic main program - initialises SDL, sets up an initial turtle state,+runs the program called "main" and waits for a key press.++> runMain :: Term+> runMain = +> let_ (fn "initSDL" @@ int 640 @@ int 480)+> (\surface -> +> (fn (fullId (mkId "main")) @@ (init_turtle surface)) +>+> flipBuffers surface +>+> pressAnyKey)++Find the support files (the SDL glue code) and compile an Epic program+with the primitives (from SDLprims) and the user's program.++> output :: [(Id, Function)] -> FilePath -> IO ()+> output prog fp = do -- TODO: run sdl-config+> sdlo <- getDataFileName "sdl/sdlrun.o"+> sdlh <- getDataFileName "sdl/sdlrun.h"+> let eprog = map mkEpic prog+> let incs = [(name "hdr", Include sdlh),+> (name "hdr", Include "math.h")]+> compileObj (incs ++ sdlPrims ++ +> (name "main", EpicFn runMain):eprog)+> (fp++".o")+> linkWith opts [fp++".o", sdlo] fp
+ src/Parser.y view
@@ -0,0 +1,148 @@+{ -- -*-Haskell-*-+{-# OPTIONS_GHC -fglasgow-exts #-}++module Parser where++import Char+import Turtle+import Lexer++}++%name mkparse Program++%tokentype { Token }+%monad { P } { thenP } { returnP }+%lexer { lexer } { TokenEOF }++%token + name { TokenName $$ }+ string { TokenString $$ }+ char { TokenChar $$ }+ int { TokenInt $$ }+ bool { TokenBool $$ }+ col { TokenMkCol $$ }+ let { TokenLet }+ in { TokenIn }+ if { TokenIf }+ then { TokenThen }+ else { TokenElse }+ repeat { TokenRepeat }+ '(' { TokenOB }+ ')' { TokenCB }+ '{' { TokenOCB }+ '}' { TokenCCB }+ '[' { TokenOSB }+ ']' { TokenCSB }+ '+' { TokenPlus }+ '-' { TokenMinus }+ '*' { TokenTimes }+ '/' { TokenDivide }+ '=' { TokenEquals }+ eq { TokenEQ }+ le { TokenLE }+ ge { TokenGE }+ '<' { TokenLT }+ '>' { TokenGT }+ ';' { TokenSemi }+ ',' { TokenComma }+ eval { TokenEval }+ forward { TokenFD }+ right { TokenRight }+ left { TokenLeft }+ colour { TokenColour }+ penup { TokenPenUp }+ pendown { TokenPenDown }++%nonassoc NONE+%left eq +%left ';'+%left '<' '>' le ge +%left '+' '-' +%left '*' '/' +%left NEG++%%++Program :: { [(Id, Function)] }+Program : Function { [$1] }+ | Function Program { $1:$2 }++Function :: { (Id, Function) }+Function : name '(' Vars ')' Block { ($1, ($3, $5)) }++Vars :: { [Id] }+Vars : { [] }+ | name { [$1] }+ | name ',' Vars { $1:$3 }++TurtleProg :: { Turtle }+TurtleProg : Turtle { $1 }+ | Turtle TurtleProg { Seq $1 $2 }+ | name '=' Expr TurtleProg { Let $1 $3 $4 }++Block :: { Turtle }+Block : '{' TurtleProg '}' { $2 }+ | Turtle { $1 }++Turtle :: { Turtle }+Turtle : name '(' ExprList ')' { Call $1 $3 }+ | if Expr Block ElseBlock+ { If $2 $3 $4 }+ | eval Expr { Eval $2 }+ | repeat Expr Block { Repeat $2 $3 }+ | forward Expr { Turtle (Fd $2) }+ | right Expr { Turtle (Rt $2) }+ | left Expr { Turtle (Lt $2) }+ | colour Expr { Turtle (Colour $2) }+ | penup { Turtle PenUp }+ | pendown { Turtle PenDown }++ElseBlock :: { Turtle }+ElseBlock : { Pass }+ | else Block { $2 }++ExprList :: { [Exp] }+ExprList : Expr { [$1] }+ | Expr ',' ExprList { $1:$3 }++Expr :: { Exp }+Expr : name { Var $1 }+ | Constant { Const $1 }+ | '-' Expr %prec NEG { Infix Minus (Const (MkInt 0)) $2 }+ | Expr '+' Expr { Infix Plus $1 $3 }+ | Expr '-' Expr { Infix Minus $1 $3 }+ | Expr '*' Expr { Infix Times $1 $3 }+ | Expr '/' Expr { Infix Divide $1 $3 }+ | Expr eq Expr { Infix Eq $1 $3 }+ | Expr '<' Expr { Infix Turtle.LT $1 $3 }+ | Expr '>' Expr { Infix Turtle.GT $1 $3 }+ | Expr le Expr { Infix LE $1 $3 }+ | Expr ge Expr { Infix GE $1 $3 }+ | '(' Expr ')' { $2 }+ | '{' TurtleProg '}' { Block $2 }++Constant :: { Const }+Constant : int { MkInt $1 }+ | string { MkString $1 }+ | char { MkChar $1 }+ | bool { MkBool $1 }+ | col { MkCol $1 }++Line :: { LineNumber }+ : {- empty -} {% getLineNo }++File :: { String } + : {- empty -} %prec NONE {% getFileName }++{++parse :: String -> FilePath -> Result [(Id, Function)]+parse s fn = mkparse s fn 1++parseFile :: FilePath -> IO (Result [(Id, Function)])+parseFile fn = do s <- readFile fn+ let x = parse s fn+ return x++}
+ src/SDLprims.lhs view
@@ -0,0 +1,199 @@+> {-# OPTIONS_GHC -fglasgow-exts #-}++> module SDLprims where++Epic primitives for calling SDL and basic operators++> import Epic.Epic++> initSDL :: Expr -> Expr -> Term+> initSDL xsize ysize +> = foreign_ tyPtr "startSDL" [(xsize, tyInt), (ysize, tyInt)]++> pollEvent = foreignConst_ tyPtr "pollEvent"+> pressAnyKey = foreignConst_ tyUnit "pressAnyKey"++> flipBuffers :: Expr -> Term+> flipBuffers s = foreign_ tyUnit "flipBuffers" [(s, tyPtr)]++Define some colours, and convert a colour into a tuple of the relevant+RGBA values.++> col_black = con_ 0+> col_red = con_ 1+> col_green = con_ 2+> col_blue = con_ 3+> col_yellow = con_ 4+> col_cyan = con_ 5+> col_magenta = con_ 6+> col_white = con_ 7++> rgba col = case_ col +> [con 0 (tuple_ @@ int 0 @@ int 0 @@ int 0 @@ int 255),+> con 1 (tuple_ @@ int 255 @@ int 0 @@ int 0 @@ int 255),+> con 2 (tuple_ @@ int 0 @@ int 255 @@ int 0 @@ int 255),+> con 3 (tuple_ @@ int 0 @@ int 0 @@ int 255 @@ int 255),+> con 4 (tuple_ @@ int 255 @@ int 255 @@ int 0 @@ int 255),+> con 5 (tuple_ @@ int 0 @@ int 255 @@ int 255 @@ int 255),+> con 6 (tuple_ @@ int 255 @@ int 0 @@ int 255 @@ int 255),+> con 7 (tuple_ @@ int 255 @@ int 255 @@ int 255 @@ int 255)]++Constants - it's a dynamically typed language so we wrap them in an ADT+which says what type they are.++> mkint i = con_ 0 @@ i+> mkstr s = con_ 1 @@ s+> mkchar c = con_ 2 @@ c+> mkbool b = con_ 3 @@ b+> mkcol c = con_ 4 @@ c++Every time we use a constant, we'll have to extract it from the wrapper.+If we're asking for the wrong type, quit with an error.++ANNOYANCE: Having to add type annotations because we only have Alternative+instances for (Expr -> e). Is there a way to make type inference know that+it must be an Expr because that's the only instance we define? i.e. can+we stop any other instances for (a -> e) being allowed somehow?++> getInt x = case_ x +> [con 0 (\ (x :: Expr) -> x), defaultcase (error_ "Not an Int")]++> getStr x = case_ x +> [con 1 (\ (x :: Expr) -> x), defaultcase (error_ "Not a String")]++> getChar x = case_ x +> [con 2 (\ (x :: Expr) -> x), defaultcase (error_ "Not a Char")]++> getBool x = case_ x +> [con 3 (\ (x :: Expr) -> x), defaultcase (error_ "Not a Bool")]++> getCol x = case_ x +> [con 4 (\ (x :: Expr) -> x), defaultcase (error_ "Not a Colour")]++Arithmetic operations++> primPlus x y = mkint $ op_ Plus (getInt x) (getInt y)+> primMinus x y = mkint $ op_ Minus (getInt x) (getInt y)+> primTimes x y = mkint $ op_ Times (getInt x) (getInt y)+> primDivide x y = mkint $ op_ Divide (getInt x) (getInt y)++Comparisons++> primEq x y = mkbool $ op_ OpEQ (getInt x) (getInt y)+> primLT x y = mkbool $ op_ OpLT (getInt x) (getInt y)+> primLE x y = mkbool $ op_ OpLE (getInt x) (getInt y)+> primGT x y = mkbool $ op_ OpGT (getInt x) (getInt y)+> primGE x y = mkbool $ op_ OpGE (getInt x) (getInt y)++Graphics primitive, just extracts the tuple of RGBA values for the colour+and calls the SDL_gfx primitive.++> drawLine :: Expr -> Expr -> Expr -> Expr -> Expr -> Expr -> Term+> drawLine surf x y ex ey col+> = case_ (rgba col)+> [tuple (\ r g b a ->+> foreign_ tyUnit "drawLine" +> [(surf, tyPtr),+> (x, tyInt), (y, tyInt), +> (ex, tyInt), (ey, tyInt),+> (r, tyInt), (g, tyInt), +> (b, tyInt), (a, tyInt)]) ]++We have integers and degrees, but sin and cos work with floats and radians.+Here's some primitives to do the necessary conversions.++> intToFloat x = foreign_ tyFloat "intToFloat" [(x, tyInt)]+> floatToInt x = foreign_ tyInt "floatToInt" [(x, tyFloat)]++> rad x = op_ FTimes (intToFloat x) (float (pi/180))++> esin x = foreign_ tyFloat "sin" [(rad x, tyFloat)]+> ecos x = foreign_ tyFloat "cos" [(rad x, tyFloat)]++Turtle functions.+In these, the arguments given by the user are in the Value ADT, so we'll+need to extract the integer.++To move forward, create a new state with the turtle at the new position, +and draw a line in the current colour between the two positions. +Return the new state.++> forward :: Expr -> Expr -> Term+> forward st dist = case_ st +> [tuple (\ (surf :: Expr) (x :: Expr) (y :: Expr) +> (dir :: Expr) (col :: Expr) (pen :: Expr) -> +> let_ (op_ Plus x (floatToInt (op_ FTimes (intToFloat (getInt dist))+> (esin dir))))+> (\x' -> let_ (op_ Plus y (floatToInt +> (op_ FTimes (intToFloat (getInt dist))+> (ecos dir))))+> (\y' -> if_ pen (fn "drawLine" @@ surf @@ x @@ y +> @@ x' @@ y' @@ col)+> unit_ +>+> tuple_ @@ surf @@ x' @@ y' @@ dir @@ col @@ pen)))]++To turn right, create a new state with the turtle turned right. +Return the new state.++> right :: Expr -> Expr -> Term+> right st ang = case_ st+> [tuple (\ (surf :: Expr) (x :: Expr) (y :: Expr) +> (dir :: Expr) (col :: Expr) (pen :: Expr) -> +> (tuple_ @@ surf @@ x @@ y @@ op_ Minus dir (getInt ang) @@ col @@ pen))]++To turn left, create a new state with the turtle turned left. +Return the new state.++> left :: Expr -> Expr -> Term+> left st ang = case_ st+> [tuple (\ (surf :: Expr) (x :: Expr) (y :: Expr) +> (dir :: Expr) (col :: Expr) (pen :: Expr) -> +> (tuple_ @@ surf @@ x @@ y @@ op_ Plus dir (getInt ang) @@ col @@ pen))]++> colour :: Expr -> Expr -> Term+> colour st col' = case_ st+> [tuple (\ (surf :: Expr) (x :: Expr) (y :: Expr) +> (dir :: Expr) (col :: Expr) (pen :: Expr) -> +> (tuple_ @@ surf @@ x @@ y @@ dir @@ getCol col' @@ pen))]++> pen :: Expr -> Expr -> Term+> pen st b = case_ st+> [tuple (\ (surf :: Expr) (x :: Expr) (y :: Expr) +> (dir :: Expr) (col :: Expr) (pen :: Expr) -> +> (tuple_ @@ surf @@ x @@ y @@ dir @@ col @@ b))]++Repeat n times++> primRepeat :: Expr -> Expr -> Expr -> Term+> primRepeat st n e = case_ (getInt n)+> [constcase 0 st,+> defaultcase (let_ (e @@ st)+> (\st' -> fn "repeat" @@ st'+> @@ mkint (op_ Minus (getInt n) (int 1))+> @@ e))]++Turtle state consists of an SDL surface,+a position, a direction, a colour, and pen up/down:+(surf, x, y, dir, col, bool)++Note that we use primitives here, not the Value ADT, because we don't allow+the user direct access to this tuple.++> init_turtle surf = tuple_ @@ surf @@ +> int 320 @@ int 240 @@ int 180 @@ +> col_white @@ bool True++Export the primitives as Epic functions.++> sdlPrims = basic_defs +++> [(name "initSDL", EpicFn initSDL),+> (name "pollEvent", EpicFn pollEvent),+> (name "flipBuffers", EpicFn flipBuffers),+> (name "drawLine", EpicFn drawLine),+> (name "forward", EpicFn forward),+> (name "left", EpicFn left),+> (name "right", EpicFn right),+> (name "colour", EpicFn colour),+> (name "pen", EpicFn pen),+> (name "repeat", EpicFn primRepeat),+> (name "pressAnyKey", EpicFn pressAnyKey)]
+ src/Turtle.lhs view
@@ -0,0 +1,49 @@+> module Turtle where++> type Id = [String]+> type Root = String++> mkId :: String -> Id+> mkId = (:[])++> data Exp = Infix Op Exp Exp+> | Var Id+> | Const Const+> | Block Turtle+> deriving Show++> data Const = MkInt Int+> | MkString String+> | MkChar Char+> | MkBool Bool+> | MkCol Colour+> deriving Show++> data Colour = Black | Red | Green | Blue | Yellow | Cyan | Magenta | White+> deriving (Show, Eq)++> data Turtle = Call Id [Exp]+> | Turtle Command+> | Seq Turtle Turtle+> | If Exp Turtle Turtle+> | Repeat Exp Turtle+> | Let Id Exp Turtle+> | Eval Exp+> | Pass+> deriving Show++> type Function = ([Id], Turtle)++> data Op = Plus | Minus | Times | Divide -- int ops+> | Eq | LT | LE | GT | GE -- bool ops +> | Car | Cdr | Append | Index -- TODO: string/char ops+> deriving Show++> data Command = Fd Exp+> | Rt Exp+> | Lt Exp+> | Colour Exp+> | PenUp+> | PenDown+> deriving Show+