├── .gitmodules ├── Dockerfile ├── README.md ├── demo-01-tsumupto └── tsumupto.hs ├── demo-02-minigame ├── c.build ├── c.clean ├── debug │ ├── minigame.dbg │ └── minigame.run ├── delete-stack-work.sh ├── minigame │ ├── Collision.hs │ ├── Entities.hs │ ├── GameLogic.hs │ ├── Graphics.hs │ ├── LICENSE │ ├── LensMiniGame.hs │ ├── Visuals.hs │ ├── World.hs │ └── minigame.cabal ├── stack.yaml └── unordered-containers-0.2.10.0 │ ├── CHANGES.md │ ├── Data │ ├── HashMap │ │ ├── Array.hs │ │ ├── Base.hs │ │ ├── Lazy.hs │ │ ├── List.hs │ │ ├── Strict.hs │ │ ├── Strict │ │ │ └── Base.hs │ │ ├── Unsafe.hs │ │ └── UnsafeShift.hs │ ├── HashSet.hs │ └── HashSet │ │ └── Base.hs │ ├── LICENSE │ ├── Setup.hs │ ├── benchmarks │ ├── Benchmarks.hs │ └── Util │ │ ├── ByteString.hs │ │ ├── Int.hs │ │ └── String.hs │ ├── tests │ ├── HashMapProperties.hs │ ├── HashSetProperties.hs │ ├── List.hs │ ├── Regressions.hs │ └── Strictness.hs │ └── unordered-containers.cabal ├── demo-03-alex ├── alex-3.2.5 │ ├── CHANGELOG.md │ ├── LICENSE │ ├── README.md │ ├── Setup.hs │ ├── TODO │ ├── alex.cabal │ ├── alex.spec │ ├── data │ │ ├── AlexTemplate │ │ ├── AlexTemplate-debug │ │ ├── AlexTemplate-ghc │ │ ├── AlexTemplate-ghc-debug │ │ ├── AlexTemplate-ghc-nopred │ │ ├── AlexWrapper-basic │ │ ├── AlexWrapper-basic-bytestring │ │ ├── AlexWrapper-gscan │ │ ├── AlexWrapper-monad │ │ ├── AlexWrapper-monad-bytestring │ │ ├── AlexWrapper-monadUserState │ │ ├── AlexWrapper-monadUserState-bytestring │ │ ├── AlexWrapper-posn │ │ ├── AlexWrapper-posn-bytestring │ │ └── AlexWrapper-strict-bytestring │ ├── doc │ │ ├── Makefile │ │ ├── aclocal.m4 │ │ ├── alex.1.in │ │ ├── alex.xml │ │ ├── config.mk.in │ │ ├── configure.ac │ │ ├── docbook-xml.mk │ │ └── fptools.css │ ├── examples │ │ ├── Makefile │ │ ├── Tokens.x │ │ ├── Tokens_gscan.x │ │ ├── Tokens_posn.x │ │ ├── examples.x │ │ ├── haskell.x │ │ ├── lit.x │ │ ├── pp.x │ │ ├── state.x │ │ ├── tiny.y │ │ ├── words.x │ │ ├── words_monad.x │ │ └── words_posn.x │ ├── src │ │ ├── AbsSyn.hs │ │ ├── CharSet.hs │ │ ├── DFA.hs │ │ ├── DFAMin.hs │ │ ├── DFS.hs │ │ ├── Data │ │ │ ├── Ranged.hs │ │ │ └── Ranged │ │ │ │ ├── Boundaries.hs │ │ │ │ ├── RangedSet.hs │ │ │ │ └── Ranges.hs │ │ ├── Info.hs │ │ ├── Main.hs │ │ ├── Map.hs │ │ ├── NFA.hs │ │ ├── Output.hs │ │ ├── ParseMonad.hs │ │ ├── Parser.hs │ │ ├── Parser.y.boot │ │ ├── Scan.hs │ │ ├── Scan.x.boot │ │ ├── Set.hs │ │ ├── Sort.hs │ │ ├── UTF8.hs │ │ ├── Util.hs │ │ └── ghc_hooks.c │ ├── templates │ │ ├── GenericTemplate.hs │ │ └── wrappers.hs │ ├── test.hs │ └── tests │ │ ├── Makefile │ │ ├── basic_typeclass.x │ │ ├── basic_typeclass_bytestring.x │ │ ├── default_typeclass.x │ │ ├── gscan_typeclass.x │ │ ├── monadUserState_typeclass.x │ │ ├── monadUserState_typeclass_bytestring.x │ │ ├── monad_typeclass.x │ │ ├── monad_typeclass_bytestring.x │ │ ├── null.x │ │ ├── posn_typeclass.x │ │ ├── posn_typeclass_bytestring.x │ │ ├── simple.x │ │ ├── strict_typeclass.x │ │ ├── tokens.x │ │ ├── tokens_bytestring.x │ │ ├── tokens_bytestring_unicode.x │ │ ├── tokens_gscan.x │ │ ├── tokens_monadUserState_bytestring.x │ │ ├── tokens_monad_bytestring.x │ │ ├── tokens_posn.x │ │ ├── tokens_posn_bytestring.x │ │ ├── tokens_scan_user.x │ │ ├── tokens_strict_bytestring.x │ │ └── unicode.x ├── c.build ├── c.clean ├── delete-stack-work.sh ├── stack.yaml └── test-run │ ├── Tokens.x │ └── run ├── demo-04-ghc ├── A1.hs ├── A2.hs ├── ghc.dbg ├── hello.hs └── run ├── fetch_ghcup.sh └── mc-zstd-support.zip /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "ghc-whole-program-compiler-project"] 2 | path = ghc-whole-program-compiler-project 3 | url = git@github.com:grin-compiler/ghc-whole-program-compiler-project.git 4 | [submodule "unzip-zstd"] 5 | path = unzip-zstd 6 | url = git@github.com:csabahruska/unzip-zstd.git 7 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM haskell 2 | 3 | # 1. these add system dependencies for the stg-interpreter 4 | RUN apt update && apt install -y pkg-config libbz2-dev 5 | 6 | RUN echo "Installing system dependencies required to compile GHC." &&\ 7 | apt install -y \ 8 | libzstd-dev \ 9 | mc \ 10 | autoconf \ 11 | build-essential \ 12 | curl \ 13 | gcc \ 14 | git \ 15 | libc6-dev \ 16 | libffi-dev \ 17 | libgmp-dev \ 18 | libncurses-dev \ 19 | libtinfo5 \ 20 | python3 \ 21 | python3-sphinx \ 22 | wget \ 23 | xz-utils \ 24 | libgl1-mesa-dev \ 25 | libxi-dev \ 26 | libxrandr-dev \ 27 | libxcursor-dev \ 28 | libxinerama-dev \ 29 | openjdk-11-jre \ 30 | vim \ 31 | freeglut3-dev 32 | 33 | RUN wget -q --show-progress https://github.com/gephi/gephi/releases/download/v0.9.2/gephi-0.9.2-linux.tar.gz &&\ 34 | tar xzf gephi-0.9.2-linux.tar.gz 35 | 36 | 37 | RUN cabal update && cabal install happy-1.19.12 && cabal install alex-3.2.6 38 | 39 | # 2. ghcup is required for installing a specific version of ghc systemwide. 40 | ARG GHCUP_BIN_DIR="/root/.ghcup/bin" 41 | ARG GHCUP_VERSION="0.1.17.2" 42 | ARG GHCUP_CHECKSUM="e9adb022b9bcfe501caca39e76ae7241af0f30fbb466a2202837a7a578607daf" 43 | 44 | ENV PATH=${GHCUP_BIN_DIR}:${PATH} 45 | ENV DISPLAY=:0 46 | 47 | COPY ./fetch_ghcup.sh /tmp/fetch_ghcup.sh 48 | RUN chmod +x /tmp/fetch_ghcup.sh 49 | 50 | RUN echo "Downloading and installing 'ghcup'." &&\ 51 | ./tmp/fetch_ghcup.sh \ 52 | "${GHCUP_VERSION}" \ 53 | "${GHCUP_CHECKSUM}" \ 54 | "/tmp/ghcup" &&\ 55 | mv /tmp/ghcup /usr/bin/ghcup &&\ 56 | chmod +x /usr/bin/ghcup &&\ 57 | rm /tmp/fetch_ghcup.sh 58 | 59 | # 3. install the specific ghc version 60 | RUN ghcup install ghc 8.8.3 && ghcup set ghc 8.8.3 61 | 62 | # 4. add the projects to the image so we can build them 63 | ADD ./. /root/ 64 | 65 | # 5. we first install the stg interpreter as per instructions, note the sytem dependencies of (1) 66 | WORKDIR /root/ghc-whole-program-compiler-project/external-stg-interpreter/ 67 | RUN stack setup && stack install 68 | 69 | WORKDIR /root/ghc-whole-program-compiler-project/mod-pak 70 | RUN stack install 71 | WORKDIR /root/ghc-whole-program-compiler-project/ghc-wpc 72 | 73 | RUN ./boot 74 | RUN ./configure 75 | RUN hadrian/build-stack -j || hadrian/build-stack -j 76 | 77 | # 6. zstd .zip support 78 | 79 | # zstd support for unzip 80 | WORKDIR /root/unzip-zstd 81 | RUN make -f unix/Makefile generic_zstd && cp unzip $HOME/.local/bin 82 | 83 | # midnight commander zstd-zip browsing 84 | WORKDIR /root/ 85 | RUN unzip mc-zstd-support.zip 86 | 87 | # make base available (who knows how t 88 | WORKDIR /root/ghc-whole-program-compiler-project/external-stg-interpreter/data/cbits.so-script/ 89 | RUN cp /root/ghc-whole-program-compiler-project/external-stg-interpreter/data/libHSbase-4.14.0.0.cbits.so ./ 90 | RUN ./c 91 | RUN cp /root/ghc-whole-program-compiler-project/ghc-wpc/_build/stage1/rts/build/libffi.so /usr/lib/x86_64-linux-gnu/libffi.so.7 92 | RUN cp ./libHSbase-4.14.0.0.cbits.so /root/demo-01-tsumupto/ 93 | WORKDIR /root/ 94 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # External STG interpreter presentation demos 2 | 3 | Demo programs of the presentation 4 | 5 | ## Why and How the External STG Interpreter is Useful 6 | 7 | **Abstract** 8 | *The external STG interpreter is a from scratch implementation of the STG machine in Haskell. 9 | Currently it supports almost all GHC primops and RTS features. 10 | It can run real world Haskell programs that were compiled with GHC Whole Program Compiler (GHC-WPC). 11 | GHC-WPC is a GHC fork that exports the whole program STG IR. 12 | The external STG interpreter is an excellent tool to study the runtime behaviour of Haskell programs, i.e. it can run/interpret GHC or Pandoc. 13 | The implementation of the interpreter is in plain simple Haskell, so it makes compiler backend and tooling development approachable for everyone. 14 | It already has a programmable debugger which supports step-by-step evaluation, breakpoints and execution region based inspection. 15 | It also can export the whole program memory state and call-graphs to files for further investigation. 16 | These features make it easy to find a memory leak or to identify a performance bottleneck in a large real world Haskell application.* 17 | 18 | [![Watch the video](https://img.youtube.com/vi/wt6iCgYmVGA/hqdefault.jpg)](https://youtu.be/wt6iCgYmVGA) 19 | 20 | [youtube video](https://www.youtube.com/watch?v=wt6iCgYmVGA) 21 | [youtube video with fullscreen view](https://www.youtube.com/watch?v=Ey5OFPkxF_w) 22 | [slides](https://docs.google.com/presentation/d/1Lmfpwtx_7TbIAGYnSE0HqkawRu75y2GGwbObuu0xYPY/edit#slide=id.p) 23 | 24 | 25 | ## Build & Run 26 | 27 | **You'll need 15GB of free space in total** 28 | 29 | 1. Watch the presentation 30 | 2. Clone this repository: 31 | ``` 32 | git clone --recursive git@github.com:grin-compiler/ext-stg-interpreter-presentation-demos.git 33 | ``` 34 | 2. Install External STG Interpreter 35 | ``` 36 | cd ghc-whole-program-compiler-project/external-stg-interpreter 37 | stack install 38 | ``` 39 | see: https://github.com/grin-compiler/ghc-whole-program-compiler-project/tree/master/external-stg-interpreter#example-usage 40 | 3. Install GHC-WPC 41 | ``` 42 | cd ghc-whole-program-compiler-project 43 | 44 | (cd mod-pak ; stack install) 45 | 46 | cd ghc-wpc 47 | ./boot 48 | ./configure 49 | hadrian/build-stack -j 50 | ``` 51 | see: https://github.com/grin-compiler/ghc-whole-program-compiler-project#usage 52 | 4. Fix paths in the build scripts and stack.yaml files. 53 | i.e. in `demo-02-minigame/stack.yaml` fix this path to point to your ghc-wpc: 54 | ``` 55 | # use local GHC (for development) 56 | system-ghc: true 57 | extra-path: 58 | - /home/csaba/haskell/grin-compiler/ghc-whole-program-compiler-project/ghc-wpc/_build/stage1/bin 59 | ``` 60 | 5. Compile `unzip` with zstd support **(optional)** 61 | You'll need this to browse the content of `.modpak` and `.fullpak` files manually. 62 | ``` 63 | cd unzip-zstd 64 | make -f unix/Makefile generic_zstd 65 | cp unzip $HOME/.local/bin 66 | ``` 67 | 6. Reproduce the demo part of the presentation 68 | https://youtu.be/wt6iCgYmVGA?t=2054 69 | 70 | *If you have questions or if you have issues with the build steps please open an issue in this repo.* 71 | 72 | 73 | ### Docker instructions 74 | **You'll need 15GB of free space in total** 75 | This is an option if you're familiar with docker and don't want to build a compiler. 76 | The container comes with ghc-wpc and ext-stg-interpreter build and the demo files are 77 | available in `/root/`. 78 | 1. Watch the presentation 79 | 2. (optional) disable access control for X, 80 | this allows you to run X applications from within the container, 81 | but keep in mind this makes your system slightly less secure. 82 | ``` 83 | xhost + 84 | ``` 85 | 3. Run the container, it'll fetch it from dockerhub if not found: 86 | ``` 87 | docker run -v /tmp/.X11-unix:/tmp/.X11-unix -it jappie/ext-stg-demo 88 | ``` 89 | 4. Reproduce the demo part of the presentation 90 | https://youtu.be/wt6iCgYmVGA?t=2054 91 | 92 | 93 | #### Docker build instructions 94 | 95 | 1. Watch the presentation 96 | 2. Clone this repository: 97 | ``` 98 | git clone --recursive git@github.com:grin-compiler/ext-stg-interpreter-presentation-demos.git 99 | ``` 100 | 3. ``` 101 | cd ext-stg-interpreter-presentation-demos 102 | git submodule update --init --recursive 103 | docker build . 104 | xhost + 105 | docker run -v /tmp/.X11-unix:/tmp/.X11-unix -it whateverhash bash 106 | ``` 107 | 108 | 4. Reproduce the demo part of the presentation 109 | https://youtu.be/wt6iCgYmVGA?t=2054 110 | 111 | + note that the compiler lives in /root/ghc-whole-program-compiler-project/ghc-wpc/_build/stage1/bin/ghc 112 | + you can install additional programs with apt 113 | -------------------------------------------------------------------------------- /demo-01-tsumupto/tsumupto.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = print (xsum 0 (upto 1 10000)) 3 | 4 | upto :: Int -> Int -> [Int] 5 | upto m n = if m > n then [] else m : upto (m+1) n 6 | 7 | xsum :: Int -> [Int] -> Int 8 | xsum n [] = n 9 | xsum n (x:xs) = xsum (n+x) xs 10 | -------------------------------------------------------------------------------- /demo-02-minigame/c.build: -------------------------------------------------------------------------------- 1 | reset 2 | 3 | set -x -e 4 | 5 | time stack --stack-root `pwd`/.stack-root build 6 | -------------------------------------------------------------------------------- /demo-02-minigame/c.clean: -------------------------------------------------------------------------------- 1 | set -x -e 2 | 3 | stack --stack-root `pwd`/.stack-root clean 4 | -------------------------------------------------------------------------------- /demo-02-minigame/debug/minigame.dbg: -------------------------------------------------------------------------------- 1 | wait-b 2 | 3 | +b main_Graphics.$wrenderFun 280 4 | +r main_Graphics.$wrenderFun 5 | 6 | c 7 | 8 | wait-b 9 | 10 | ?r main_Graphics.$wrenderFun 11 | 12 | gc 13 | 14 | ?r-dump main_Graphics.$wrenderFun 15 | 16 | ?r main_Graphics.$wrenderFun 17 | 18 | loaddb 19 | -------------------------------------------------------------------------------- /demo-02-minigame/debug/minigame.run: -------------------------------------------------------------------------------- 1 | set -x -e 2 | 3 | ext-stg-interpreter -d --debug-script minigame.dbg minigame.fullpak 4 | -------------------------------------------------------------------------------- /demo-02-minigame/delete-stack-work.sh: -------------------------------------------------------------------------------- 1 | set -x -e 2 | rm -r `find . -name '.stack-work' -type d` 3 | -------------------------------------------------------------------------------- /demo-02-minigame/minigame/Collision.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Collision where 3 | 4 | import Data.Maybe 5 | import Lens.Micro.Platform 6 | import Graphics.Gloss.Data.Vector 7 | import Entities 8 | 9 | collide :: [Entity] -> [(Int,Int)] 10 | collide ents = x where 11 | ients = zip [0..] ents 12 | x = [ (i1,i2) 13 | | (i1,e1) <- ients 14 | , (i2,e2) <- ients 15 | , i1 < i2 16 | , (p1,r1) <- maybeToList (brush e1) 17 | , (p2,r2) <- maybeToList (brush e2) 18 | , magV (p1 - p2) < r1 + r2 19 | ] 20 | brush = \case 21 | EPlayer a -> Just (a^.pPosition, 20) 22 | EBullet a -> Just (a^.bPosition, 2) 23 | EWeapon a -> Just (a^.wPosition, 10) 24 | EAmmo a -> Just (a^.aPosition, 8) 25 | EArmor a -> Just (a^.rPosition, 10) 26 | EHealth a -> Just (a^.hPosition, 10) 27 | ELava a -> Just (a^.lPosition, 50) 28 | ETeleport a -> Just (a^.tPosition, 20) 29 | EKillbox a -> Just (a^.kPosition, 20) 30 | _ -> Nothing 31 | -------------------------------------------------------------------------------- /demo-02-minigame/minigame/Entities.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, FlexibleInstances #-} 2 | module Entities where 3 | 4 | import qualified Graphics.Gloss.Data.Point.Arithmetic as P 5 | import Graphics.Gloss.Data.Vector 6 | import Lens.Micro.Platform 7 | 8 | type Vec2 = Vector 9 | 10 | -- entities for game logic 11 | 12 | data Player 13 | = Player 14 | { _pPosition :: Vec2 15 | , _pFVelocity :: Float 16 | , _pSVelocity :: Float 17 | , _pAngle :: Float 18 | , _pHealth :: Int 19 | , _pAmmo :: Int 20 | , _pArmor :: Int 21 | , _pShootTime :: Float 22 | , _pDamageTimer :: Float 23 | , _pName :: String 24 | , _pId :: Int 25 | } deriving Show 26 | 27 | data Bullet 28 | = Bullet 29 | { _bPosition :: Vec2 30 | , _bDirection :: Vec2 31 | , _bDamage :: Int 32 | , _bLifeTime :: Float 33 | } deriving Show 34 | 35 | data Weapon 36 | = Weapon 37 | { _wPosition :: Vec2 38 | , _wDropped :: Bool 39 | } deriving Show 40 | 41 | data Ammo 42 | = Ammo 43 | { _aPosition :: Vec2 44 | , _aQuantity :: Int 45 | , _aDropped :: Bool 46 | } deriving Show 47 | 48 | data Armor 49 | = Armor 50 | { _rPosition :: Vec2 51 | , _rQuantity :: Int 52 | , _rDropped :: Bool 53 | } deriving Show 54 | 55 | data Health 56 | = Health 57 | { _hPosition :: Vec2 58 | , _hQuantity :: Int 59 | } deriving Show 60 | 61 | data Spawn 62 | = Spawn 63 | { _sSpawnTime :: Float 64 | , _sEntity :: Entity 65 | } deriving Show 66 | 67 | data Lava 68 | = Lava 69 | { _lPosition :: Vec2 70 | , _lDamage :: Int 71 | } deriving Show 72 | 73 | data Teleport 74 | = Teleport 75 | { _tPosition :: Vec2 76 | , _tTarget :: String 77 | } deriving Show 78 | 79 | data Target 80 | = Target 81 | { _ttPosition :: Vec2 82 | , _ttTargetName :: String 83 | } deriving Show 84 | 85 | data Killbox 86 | = Killbox 87 | { _kPosition :: Vec2 88 | , _kTargetName :: String 89 | } deriving Show 90 | 91 | data Entity 92 | = EPlayer Player 93 | | EBullet Bullet 94 | | EWeapon Weapon 95 | | EAmmo Ammo 96 | | EArmor Armor 97 | | EHealth Health 98 | | ELava Lava 99 | | ETeleport Teleport 100 | | ETarget Target 101 | | EKillbox Killbox 102 | | PSpawn Spawn 103 | deriving Show 104 | 105 | concat <$> mapM makeLenses [''Player, ''Bullet, ''Weapon, ''Ammo, ''Armor, ''Spawn, ''Health, ''Lava, ''Teleport, ''Target, ''Killbox] 106 | 107 | -- workaround 108 | 109 | instance Num (Float, Float) where 110 | (+) = (P.+) 111 | (-) = (P.-) 112 | (a1, b1) * (a2, b2) = (a1 * a2, b1 * b2) 113 | negate = P.negate 114 | abs (a, b) = (abs a, abs b) 115 | signum (a, b) = (signum a, signum b) 116 | fromInteger a = (fromInteger a, fromInteger a) 117 | -------------------------------------------------------------------------------- /demo-02-minigame/minigame/Graphics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Graphics where 3 | 4 | import Text.Printf 5 | import Graphics.Gloss 6 | import Lens.Micro.Platform 7 | import Entities 8 | import Visuals 9 | import World 10 | 11 | renderFun :: World -> Picture 12 | renderFun w = Pictures $ ents ++ vis where 13 | ents = flip map (w^.wEntities) $ \case 14 | EPlayer p -> let (x,y) = p^.pPosition 15 | gfx = Translate x y $ text (p^.pName) $ Rotate (-p^.pAngle) $ Pictures [Polygon [(-10,-6),(10,0),(-10,6)],Circle 20] 16 | hud = Translate (-50) 250 $ Scale 0.2 0.2 $ Text $ printf "health:%d ammo:%d armor:%d" (p^.pHealth) (p^.pAmmo) (p^.pArmor) 17 | in Pictures [hud,gfx] 18 | EBullet b -> Translate x y $ Color green $ Circle 2 where (x,y) = b^.bPosition 19 | EWeapon a -> Translate x y $ text "Weapon" $ Color blue $ Circle 10 where (x,y) = a^.wPosition 20 | EAmmo a -> Translate x y $ text "Ammo" $ Color (light blue) $ Circle 8 where (x,y) = a^.aPosition 21 | EArmor a -> Translate x y $ text "Armor" $ Color red $ Circle 10 where (x,y) = a^.rPosition 22 | EHealth a -> Translate x y $ text "Health" $ Color yellow $ Circle 10 where (x,y) = a^.hPosition 23 | ELava a -> Translate x y $ text "Lava" $ Color orange $ Circle 50 where (x,y) = a^.lPosition 24 | ETeleport a -> Translate x y $ text "Teleport" $ Color magenta $ Circle 20 where (x,y) = a^.tPosition 25 | ETarget a -> Translate x y $ text "Target" Blank where (x,y) = a^.ttPosition 26 | EKillbox a -> Translate x y $ Color violet $ Circle 20 where (x,y) = a^.kPosition 27 | _ -> Blank 28 | 29 | text s p = Pictures [Scale 0.1 0.1 $ Text s, p] 30 | 31 | vis = flip map (w^.wVisuals) $ \case 32 | VParticle a -> Translate x y $ Color red $ Circle 1 where (x,y) = a^.vpPosition 33 | _ -> Blank 34 | -------------------------------------------------------------------------------- /demo-02-minigame/minigame/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Csaba Hruska 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Csaba Hruska nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /demo-02-minigame/minigame/LensMiniGame.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, Rank2Types, NoMonomorphismRestriction, LambdaCase, RecordWildCards, FlexibleContexts, TupleSections #-} 2 | 3 | import Graphics.Gloss.Interface.Pure.Game 4 | import Control.Monad.State.Strict 5 | import System.Random.Mersenne.Pure64 6 | 7 | import Lens.Micro.Platform 8 | 9 | import Entities 10 | import World 11 | import Graphics 12 | import GameLogic 13 | 14 | {- 15 | minigame 16 | done - shoot bullets with limited lifetime 17 | done - respawn player 18 | done - pick up health, weapon and ammo powerups 19 | done - respawn items 20 | done - touch lava that cause damage once per second since the first touch 21 | done - control player's acceleration instead of position, also add friction 22 | done - don't pickup items when the inventory is full (filter collision by entity state, i.e. they collide when they accepts the event) 23 | done - randomize spawn time 24 | done - drop inventory on death 25 | done - animated visual only elements (i.e. particles on collision) 26 | * count deaths and kills (persistent data support) 27 | higher level rules: 28 | time limit 29 | frag/ctf score limit 30 | count score 31 | keep track of statistics 32 | idea: emit frags on deathmatch kills, containing the necessary info 33 | emit flag scores / events 34 | question: does this break state locality? (this is ad hoc, but it's ok to me) 35 | done - teleport (target support) 36 | * teleport telefrag with killbox 37 | jump pad 38 | door 39 | button + movable 40 | full q3 inventory 41 | 42 | goals: 43 | rule based 44 | compositional with reusable small components 45 | intuitive and easy to use 46 | simple and efficient operational semantics and implementation (should be easy to imagine the compilation/codegen) 47 | 48 | events: 49 | collision between entities and client 50 | 51 | design ideas: 52 | transfer function can emit events (data for higher level rules) 53 | 54 | rule hierarchy 55 | #1 - game mode 56 | high score tracking 57 | count frags / flag scores 58 | measure time 59 | #2 - action rules 60 | kills, teleports, collisions, etc. 61 | -} 62 | {- 63 | random missing features: 64 | character animations 65 | weapon change animation 66 | weapon animations 67 | shoot 68 | explosion 69 | weapon idle/etc 70 | -} 71 | {- 72 | interactions to handle 73 | item on a mover - problem: relative position 74 | killbox - problem: many things in one interaction 75 | teleport target - problem: target = referencex 76 | -} 77 | {- 78 | quake 3 inventory 79 | weapons 80 | gauntlet 81 | machinegun 82 | shotgun 83 | grenade launcher 84 | rocket launcher 85 | lightning 86 | railgun 87 | plasmagun 88 | bfg 89 | grappling hook 90 | ammos 91 | for each weapon 92 | armors 93 | armor shard 5 94 | armor combat 50 95 | armor body 100 96 | health 97 | health small 5 98 | health 25 99 | health large 50 100 | health mega 100 101 | powerup 102 | quad (quad damage) 103 | enviro (battle suit) 104 | haste (speed) 105 | invis (invisibility) 106 | regen (regeneration) 107 | flight 108 | holdable 109 | teleporter 110 | medkit 111 | team 112 | redflag 113 | blueflag 114 | -} 115 | 116 | 117 | 118 | ----- 119 | 120 | inputFun :: Event -> World -> World 121 | inputFun e w = w & wInput .~ i' where 122 | f Down = 300 123 | f Up = -300 124 | 125 | i@Input{..} = w^.wInput 126 | i' = case e of 127 | EventKey (Char 'w') s _ _ -> i {forwardmove = forwardmove + f s} 128 | EventKey (Char 's') s _ _ -> i {forwardmove = forwardmove - f s} 129 | EventKey (Char 'd') s _ _ -> i {rightmove = rightmove - f s} 130 | EventKey (Char 'a') s _ _ -> i {rightmove = rightmove + f s} 131 | EventKey (Char 'e') s _ _ -> i {sidemove = sidemove + f s} 132 | EventKey (Char 'q') s _ _ -> i {sidemove = sidemove - f s} 133 | EventKey (SpecialKey KeySpace) s _ _ -> i {shoot = s == Down} 134 | EventKey (Char 'x') s _ _ -> error "terminate game" 135 | _ -> i 136 | 137 | stepFun :: Float -> World -> World 138 | stepFun dt = execState $ do 139 | -- update time 140 | wInput %= (\i -> i {dtime = dt, time = time i + dt}) 141 | input <- use wInput 142 | ents <- use wEntities 143 | vis <- use wVisuals 144 | rand <- use wRandomGen 145 | let (r1,e,v1) = updateEntities rand input ents 146 | Input{..} = input 147 | (r2,v2) = updateVisuals r1 time dtime vis 148 | wEntities .= e 149 | wRandomGen .= r2 150 | wVisuals .= v1 ++ v2 151 | 152 | emptyWorld = World 153 | [ EPlayer initialPlayer 154 | , EBullet (Bullet (30,30) (10,10) 100 10) 155 | , EWeapon (Weapon (10,20) False) 156 | , EAmmo (Ammo (100,100) 20 False) 157 | , EArmor (Armor (200,100) 30 False) 158 | , EHealth (Health (100, 200) 50) 159 | , ELava (Lava (-200,-100) 10) 160 | , ETeleport (Teleport (-200,100) "t1") 161 | , ETarget (Target (300,-100) "t1") 162 | -- , EKillbox (Killbox (300,-100) "t1") 163 | ] [] emptyInput (pureMT 123456789) where emptyInput = Input 0 0 0 False 0 0 164 | 165 | main = play (InWindow "Lens MiniGame" (800, 600) (10, 10)) white 20 emptyWorld renderFun inputFun stepFun 166 | -------------------------------------------------------------------------------- /demo-02-minigame/minigame/Visuals.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, TemplateHaskell #-} 2 | module Visuals where 3 | 4 | import Graphics.Gloss.Data.Vector 5 | import Lens.Micro.Platform 6 | import Control.Monad 7 | 8 | -- visuals for game graphics 9 | type Vec2 = Vector 10 | 11 | data Particle 12 | = Particle 13 | { _vpPosition :: Vec2 14 | , _vpDirection :: Vec2 15 | , _vpLifeTime :: Float 16 | } deriving Show 17 | 18 | data Visual 19 | = VParticle Particle 20 | deriving Show 21 | 22 | concat <$> mapM makeLenses [''Particle] 23 | -------------------------------------------------------------------------------- /demo-02-minigame/minigame/World.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module World where 3 | 4 | import Lens.Micro.Platform 5 | import System.Random.Mersenne.Pure64 6 | 7 | import Visuals 8 | import Entities 9 | 10 | data Input 11 | = Input 12 | { forwardmove :: Float 13 | , rightmove :: Float 14 | , sidemove :: Float 15 | , shoot :: Bool 16 | , dtime :: Float 17 | , time :: Float 18 | } deriving Show 19 | 20 | data World 21 | = World 22 | { _wEntities :: [Entity] 23 | , _wVisuals :: [Visual] 24 | , _wInput :: Input 25 | , _wRandomGen :: !PureMT -- fix mem leak 26 | } deriving Show 27 | 28 | makeLenses ''World 29 | -------------------------------------------------------------------------------- /demo-02-minigame/minigame/minigame.cabal: -------------------------------------------------------------------------------- 1 | -- Initial minigame.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: minigame 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Csaba Hruska 11 | maintainer: csaba.hruska@gmail.com 12 | -- copyright: 13 | category: Game 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | executable minigame 19 | main-is: LensMiniGame.hs 20 | other-modules: Collision 21 | Entities 22 | GameLogic 23 | Graphics 24 | Visuals 25 | World 26 | 27 | other-extensions: TemplateHaskell, Rank2Types, NoMonomorphismRestriction, LambdaCase, RecordWildCards, FlexibleContexts 28 | build-depends: base >=4.8, 29 | gloss >=1.10, 30 | mtl >=2.2, 31 | transformers >=0.4, 32 | vector >=0.11, 33 | mersenne-random-pure64, 34 | MonadRandom, 35 | microlens-platform >=0.3 36 | -- hs-source-dirs: 37 | default-language: Haskell2010 -------------------------------------------------------------------------------- /demo-02-minigame/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-15.6 2 | 3 | allow-newer: true 4 | 5 | packages: 6 | - 'minigame' 7 | - 'unordered-containers-0.2.10.0' 8 | 9 | apply-ghc-options: everything 10 | ghc-options: 11 | "$everything": -split-sections -O2 12 | 13 | # use custom ext-stg whole program compiler GHC 14 | compiler: ghc-8.11.0.20200527 15 | 16 | # use local GHC (for development) 17 | system-ghc: true 18 | extra-path: 19 | - /home/csaba/haskell/grin-compiler/ghc-whole-program-compiler-project/ghc-wpc/_build/stage1/bin 20 | -------------------------------------------------------------------------------- /demo-02-minigame/unordered-containers-0.2.10.0/CHANGES.md: -------------------------------------------------------------------------------- 1 | ## 0.2.10.0 2 | 3 | * Add `HashMap.alterF`. 4 | 5 | * Add `HashMap.keysSet`. 6 | 7 | * Make `HashMap.Strict.traverseWithKey` force the results before 8 | installing them in the map. 9 | 10 | ## 0.2.9.0 11 | 12 | * Add `Ord/Ord1/Ord2` instances. (Thanks, Oleg Grenrus) 13 | 14 | * Use `SmallArray#` instead of `Array#` for GHC versions 7.10 and above. 15 | (Thanks, Dmitry Ivanov) 16 | 17 | * Adjust for `Semigroup => Monoid` proposal implementation. 18 | (Thanks, Ryan Scott) 19 | 20 | ### Bug fixes 21 | 22 | * Fix a strictness bug in `fromListWith`. 23 | 24 | * Enable eager blackholing for pre-8.2 GHC versions to work around 25 | a runtime system bug. (Thanks, Ben Gamari) 26 | 27 | * Avoid sketchy reimplementation of `ST` when compiling with recent 28 | GHC. 29 | 30 | ### Other changes 31 | 32 | * Remove support for GHC versions before 7.8. (Thanks, Dmitry Ivanov) 33 | 34 | * Add internal documentaton. (Thanks, Johan Tibell) 35 | 36 | ## 0.2.8.0 37 | 38 | * Add `Eq1/2`, `Show1/2`, `Read1` instances with `base-4.9` 39 | 40 | * `Eq (HashSet a)` doesn't require `Hashable a` anymore, only `Eq a`. 41 | 42 | * Add `Hashable1/2` with `hashable-1.2.6.0` 43 | 44 | * Add `differenceWith` function. 45 | 46 | ## 0.2.7.2 47 | 48 | * Don't use -fregs-graphs 49 | 50 | * Fix benchmark compilation on stack. 51 | 52 | ## 0.2.7.1 53 | 54 | * Fix linker error related to popcnt. 55 | 56 | * Haddock improvements. 57 | 58 | * Fix benchmark compilation when downloaded from Hackage. 59 | 60 | ## 0.2.7.0 61 | 62 | * Support criterion 1.1 63 | 64 | * Add unionWithKey for hash maps. 65 | 66 | ## 0.2.6.0 67 | 68 | * Mark several modules as Trustworthy. 69 | 70 | * Add Hashable instances for HashMap and HashSet. 71 | 72 | * Add mapMaybe, mapMaybeWithKey, update, alter, and 73 | intersectionWithKey. 74 | 75 | * Add roles. 76 | 77 | * Add Hashable and Semigroup instances. 78 | 79 | ## 0.2.5.1 (2014-10-11) 80 | 81 | * Support base-4.8 82 | -------------------------------------------------------------------------------- /demo-02-minigame/unordered-containers-0.2.10.0/Data/HashMap/Lazy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Trustworthy #-} 3 | 4 | ------------------------------------------------------------------------ 5 | -- | 6 | -- Module : Data.HashMap.Lazy 7 | -- Copyright : 2010-2012 Johan Tibell 8 | -- License : BSD-style 9 | -- Maintainer : johan.tibell@gmail.com 10 | -- Stability : provisional 11 | -- Portability : portable 12 | -- 13 | -- A map from /hashable/ keys to values. A map cannot contain 14 | -- duplicate keys; each key can map to at most one value. A 'HashMap' 15 | -- makes no guarantees as to the order of its elements. 16 | -- 17 | -- The implementation is based on /hash array mapped tries/. A 18 | -- 'HashMap' is often faster than other tree-based set types, 19 | -- especially when key comparison is expensive, as in the case of 20 | -- strings. 21 | -- 22 | -- Many operations have a average-case complexity of /O(log n)/. The 23 | -- implementation uses a large base (i.e. 16) so in practice these 24 | -- operations are constant time. 25 | module Data.HashMap.Lazy 26 | ( 27 | -- * Strictness properties 28 | -- $strictness 29 | 30 | HashMap 31 | 32 | -- * Construction 33 | , empty 34 | , singleton 35 | 36 | -- * Basic interface 37 | , null 38 | , size 39 | , member 40 | , lookup 41 | , lookupDefault 42 | , (!) 43 | , insert 44 | , insertWith 45 | , delete 46 | , adjust 47 | , update 48 | , alter 49 | , alterF 50 | 51 | -- * Combine 52 | -- ** Union 53 | , union 54 | , unionWith 55 | , unionWithKey 56 | , unions 57 | 58 | -- * Transformations 59 | , map 60 | , mapWithKey 61 | , traverseWithKey 62 | 63 | -- * Difference and intersection 64 | , difference 65 | , differenceWith 66 | , intersection 67 | , intersectionWith 68 | , intersectionWithKey 69 | 70 | -- * Folds 71 | , foldl' 72 | , foldlWithKey' 73 | , foldr 74 | , foldrWithKey 75 | 76 | -- * Filter 77 | , filter 78 | , filterWithKey 79 | , mapMaybe 80 | , mapMaybeWithKey 81 | 82 | -- * Conversions 83 | , keys 84 | , elems 85 | 86 | -- ** Lists 87 | , toList 88 | , fromList 89 | , fromListWith 90 | 91 | -- ** HashSets 92 | , HS.keysSet 93 | ) where 94 | 95 | import Data.HashMap.Base as HM 96 | import qualified Data.HashSet.Base as HS 97 | import Prelude () 98 | 99 | -- $strictness 100 | -- 101 | -- This module satisfies the following strictness property: 102 | -- 103 | -- * Key arguments are evaluated to WHNF 104 | -------------------------------------------------------------------------------- /demo-02-minigame/unordered-containers-0.2.10.0/Data/HashMap/List.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} 3 | -- | Extra list functions 4 | -- 5 | -- In separate module to aid testing. 6 | module Data.HashMap.List 7 | ( isPermutationBy 8 | , deleteBy 9 | , unorderedCompare 10 | ) where 11 | 12 | import Data.Maybe (fromMaybe) 13 | import Data.List (sortBy) 14 | import Data.Monoid 15 | import Prelude 16 | 17 | -- Note: previous implemenation isPermutation = null (as // bs) 18 | -- was O(n^2) too. 19 | -- 20 | -- This assumes lists are of equal length 21 | isPermutationBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool 22 | isPermutationBy f = go 23 | where 24 | f' = flip f 25 | 26 | go [] [] = True 27 | go (x : xs) (y : ys) 28 | | f x y = go xs ys 29 | | otherwise = fromMaybe False $ do 30 | xs' <- deleteBy f' y xs 31 | ys' <- deleteBy f x ys 32 | return (go xs' ys') 33 | go [] (_ : _) = False 34 | go (_ : _) [] = False 35 | 36 | -- The idea: 37 | -- 38 | -- Homogeonous version 39 | -- 40 | -- uc :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering 41 | -- uc c as bs = compare (sortBy c as) (sortBy c bs) 42 | -- 43 | -- But as we have only (a -> b -> Ordering), we cannot directly compare 44 | -- elements from the same list. 45 | -- 46 | -- So when comparing elements from the list, we count how many elements are 47 | -- "less and greater" in the other list, and use the count as a metric. 48 | -- 49 | unorderedCompare :: (a -> b -> Ordering) -> [a] -> [b] -> Ordering 50 | unorderedCompare c as bs = go (sortBy cmpA as) (sortBy cmpB bs) 51 | where 52 | go [] [] = EQ 53 | go [] (_ : _) = LT 54 | go (_ : _) [] = GT 55 | go (x : xs) (y : ys) = c x y `mappend` go xs ys 56 | 57 | cmpA a a' = compare (inB a) (inB a') 58 | cmpB b b' = compare (inA b) (inA b') 59 | 60 | inB a = (length $ filter (\b -> c a b == GT) bs, negate $ length $ filter (\b -> c a b == LT) bs) 61 | inA b = (length $ filter (\a -> c a b == LT) as, negate $ length $ filter (\a -> c a b == GT) as) 62 | 63 | -- Returns Nothing is nothing deleted 64 | deleteBy :: (a -> b -> Bool) -> a -> [b] -> Maybe [b] 65 | deleteBy _ _ [] = Nothing 66 | deleteBy eq x (y:ys) = if x `eq` y then Just ys else fmap (y :) (deleteBy eq x ys) 67 | -------------------------------------------------------------------------------- /demo-02-minigame/unordered-containers-0.2.10.0/Data/HashMap/Strict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | ------------------------------------------------------------------------ 4 | -- | 5 | -- Module : Data.HashMap.Strict 6 | -- Copyright : 2010-2012 Johan Tibell 7 | -- License : BSD-style 8 | -- Maintainer : johan.tibell@gmail.com 9 | -- Stability : provisional 10 | -- Portability : portable 11 | -- 12 | -- A map from /hashable/ keys to values. A map cannot contain 13 | -- duplicate keys; each key can map to at most one value. A 'HashMap' 14 | -- makes no guarantees as to the order of its elements. 15 | -- 16 | -- The implementation is based on /hash array mapped tries/. A 17 | -- 'HashMap' is often faster than other tree-based set types, 18 | -- especially when key comparison is expensive, as in the case of 19 | -- strings. 20 | -- 21 | -- Many operations have a average-case complexity of /O(log n)/. The 22 | -- implementation uses a large base (i.e. 16) so in practice these 23 | -- operations are constant time. 24 | module Data.HashMap.Strict 25 | ( 26 | -- * Strictness properties 27 | -- $strictness 28 | 29 | HashMap 30 | 31 | -- * Construction 32 | , empty 33 | , singleton 34 | 35 | -- * Basic interface 36 | , null 37 | , size 38 | , member 39 | , lookup 40 | , lookupDefault 41 | , (!) 42 | , insert 43 | , insertWith 44 | , delete 45 | , adjust 46 | , update 47 | , alter 48 | , alterF 49 | 50 | -- * Combine 51 | -- ** Union 52 | , union 53 | , unionWith 54 | , unionWithKey 55 | , unions 56 | 57 | -- * Transformations 58 | , map 59 | , mapWithKey 60 | , traverseWithKey 61 | 62 | -- * Difference and intersection 63 | , difference 64 | , differenceWith 65 | , intersection 66 | , intersectionWith 67 | , intersectionWithKey 68 | 69 | -- * Folds 70 | , foldl' 71 | , foldlWithKey' 72 | , foldr 73 | , foldrWithKey 74 | 75 | -- * Filter 76 | , filter 77 | , filterWithKey 78 | , mapMaybe 79 | , mapMaybeWithKey 80 | 81 | -- * Conversions 82 | , keys 83 | , elems 84 | 85 | -- ** Lists 86 | , toList 87 | , fromList 88 | , fromListWith 89 | 90 | -- ** HashSets 91 | , HS.keysSet 92 | ) where 93 | 94 | import Data.HashMap.Strict.Base as HM 95 | import qualified Data.HashSet.Base as HS 96 | import Prelude () 97 | -------------------------------------------------------------------------------- /demo-02-minigame/unordered-containers-0.2.10.0/Data/HashMap/Unsafe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | #if !MIN_VERSION_base(4,9,0) 4 | {-# LANGUAGE MagicHash, Rank2Types, UnboxedTuples #-} 5 | #endif 6 | 7 | -- | This module exports a workaround for this bug: 8 | -- 9 | -- http://hackage.haskell.org/trac/ghc/ticket/5916 10 | -- 11 | -- Please read the comments in ghc/libraries/base/GHC/ST.lhs to 12 | -- understand what's going on here. 13 | -- 14 | -- Code that uses this module should be compiled with -fno-full-laziness 15 | module Data.HashMap.Unsafe 16 | ( runST 17 | ) where 18 | 19 | #if MIN_VERSION_base(4,9,0) 20 | -- The GHC issue was fixed in GHC 8.0/base 4.9 21 | import Control.Monad.ST 22 | 23 | #else 24 | 25 | import GHC.Base (realWorld#) 26 | import qualified GHC.ST as ST 27 | 28 | -- | Return the value computed by a state transformer computation. 29 | -- The @forall@ ensures that the internal state used by the 'ST' 30 | -- computation is inaccessible to the rest of the program. 31 | runST :: (forall s. ST.ST s a) -> a 32 | runST st = runSTRep (case st of { ST.ST st_rep -> st_rep }) 33 | {-# INLINE runST #-} 34 | 35 | runSTRep :: (forall s. ST.STRep s a) -> a 36 | runSTRep st_rep = case st_rep realWorld# of 37 | (# _, r #) -> r 38 | {-# INLINE [0] runSTRep #-} 39 | #endif 40 | -------------------------------------------------------------------------------- /demo-02-minigame/unordered-containers-0.2.10.0/Data/HashMap/UnsafeShift.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | 3 | module Data.HashMap.UnsafeShift 4 | ( unsafeShiftL 5 | , unsafeShiftR 6 | ) where 7 | 8 | import GHC.Exts (Word(W#), Int(I#), uncheckedShiftL#, uncheckedShiftRL#) 9 | 10 | unsafeShiftL :: Word -> Int -> Word 11 | unsafeShiftL (W# x#) (I# i#) = W# (x# `uncheckedShiftL#` i#) 12 | {-# INLINE unsafeShiftL #-} 13 | 14 | unsafeShiftR :: Word -> Int -> Word 15 | unsafeShiftR (W# x#) (I# i#) = W# (x# `uncheckedShiftRL#` i#) 16 | {-# INLINE unsafeShiftR #-} 17 | -------------------------------------------------------------------------------- /demo-02-minigame/unordered-containers-0.2.10.0/Data/HashSet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if __GLASGOW_HASKELL__ >= 702 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | 6 | ------------------------------------------------------------------------ 7 | -- | 8 | -- Module : Data.HashSet 9 | -- Copyright : 2011 Bryan O'Sullivan 10 | -- License : BSD-style 11 | -- Maintainer : johan.tibell@gmail.com 12 | -- Stability : provisional 13 | -- Portability : portable 14 | -- 15 | -- A set of /hashable/ values. A set cannot contain duplicate items. 16 | -- A 'HashSet' makes no guarantees as to the order of its elements. 17 | -- 18 | -- The implementation is based on /hash array mapped trie/. A 19 | -- 'HashSet' is often faster than other tree-based set types, 20 | -- especially when value comparison is expensive, as in the case of 21 | -- strings. 22 | -- 23 | -- Many operations have a average-case complexity of /O(log n)/. The 24 | -- implementation uses a large base (i.e. 16) so in practice these 25 | -- operations are constant time. 26 | 27 | module Data.HashSet 28 | ( 29 | HashSet 30 | 31 | -- * Construction 32 | , empty 33 | , singleton 34 | 35 | -- * Combine 36 | , union 37 | , unions 38 | 39 | -- * Basic interface 40 | , null 41 | , size 42 | , member 43 | , insert 44 | , delete 45 | 46 | -- * Transformations 47 | , map 48 | 49 | -- * Difference and intersection 50 | , difference 51 | , intersection 52 | 53 | -- * Folds 54 | , foldl' 55 | , foldr 56 | 57 | -- * Filter 58 | , filter 59 | 60 | -- * Conversions 61 | 62 | -- ** Lists 63 | , toList 64 | , fromList 65 | 66 | -- * HashMaps 67 | , toMap 68 | , fromMap 69 | ) where 70 | 71 | import Data.HashSet.Base 72 | import Prelude () 73 | -------------------------------------------------------------------------------- /demo-02-minigame/unordered-containers-0.2.10.0/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010, Johan Tibell 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Johan Tibell nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /demo-02-minigame/unordered-containers-0.2.10.0/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /demo-02-minigame/unordered-containers-0.2.10.0/benchmarks/Util/ByteString.hs: -------------------------------------------------------------------------------- 1 | -- | Benchmarking utilities. For example, functions for generating 2 | -- random 'ByteString's. 3 | module Util.ByteString where 4 | 5 | import qualified Data.ByteString as S 6 | import qualified Data.ByteString.Char8 as C 7 | 8 | import Util.String as String 9 | 10 | -- | Generate a number of fixed length 'ByteString's where the content 11 | -- of the strings are letters in ascending order. 12 | asc :: Int -- ^ Length of each string 13 | -> Int -- ^ Number of strings 14 | -> [S.ByteString] 15 | asc strlen num = map C.pack $ String.asc strlen num 16 | 17 | -- | Generate a number of fixed length 'ByteString's where the content 18 | -- of the strings are letters in random order. 19 | rnd :: Int -- ^ Length of each string 20 | -> Int -- ^ Number of strings 21 | -> [S.ByteString] 22 | rnd strlen num = map C.pack $ String.rnd strlen num 23 | 24 | -- | Generate a number of fixed length 'ByteString's where the content 25 | -- of the strings are letters in random order, different from @rnd@. 26 | rnd' :: Int -- ^ Length of each string 27 | -> Int -- ^ Number of strings 28 | -> [S.ByteString] 29 | rnd' strlen num = map C.pack $ String.rnd' strlen num 30 | -------------------------------------------------------------------------------- /demo-02-minigame/unordered-containers-0.2.10.0/benchmarks/Util/Int.hs: -------------------------------------------------------------------------------- 1 | -- | Benchmarking utilities. For example, functions for generating 2 | -- random integers. 3 | module Util.Int where 4 | 5 | import System.Random (mkStdGen, randomRs) 6 | 7 | -- | Generate a number of uniform random integers in the interval 8 | -- @[0..upper]@. 9 | rnd :: Int -- ^ Upper bound (inclusive) 10 | -> Int -- ^ Number of integers 11 | -> [Int] 12 | rnd upper num = take num $ randomRs (0, upper) $ mkStdGen 1234 13 | 14 | -- | Generate a number of uniform random integers in the interval 15 | -- @[0..upper]@ different from @rnd@. 16 | rnd' :: Int -- ^ Upper bound (inclusive) 17 | -> Int -- ^ Number of integers 18 | -> [Int] 19 | rnd' upper num = take num $ randomRs (0, upper) $ mkStdGen 5678 20 | -------------------------------------------------------------------------------- /demo-02-minigame/unordered-containers-0.2.10.0/benchmarks/Util/String.hs: -------------------------------------------------------------------------------- 1 | -- | Benchmarking utilities. For example, functions for generating 2 | -- random strings. 3 | module Util.String where 4 | 5 | import System.Random (mkStdGen, randomRs) 6 | 7 | -- | Generate a number of fixed length strings where the content of 8 | -- the strings are letters in ascending order. 9 | asc :: Int -- ^ Length of each string 10 | -> Int -- ^ Number of strings 11 | -> [String] 12 | asc strlen num = take num $ iterate (snd . inc) $ replicate strlen 'a' 13 | where inc [] = (True, []) 14 | inc (c:cs) = case inc cs of (True, cs') | c == 'z' -> (True, 'a' : cs') 15 | | otherwise -> (False, succ c : cs') 16 | (False, cs') -> (False, c : cs') 17 | 18 | -- | Generate a number of fixed length strings where the content of 19 | -- the strings are letters in random order. 20 | rnd :: Int -- ^ Length of each string 21 | -> Int -- ^ Number of strings 22 | -> [String] 23 | rnd strlen num = take num $ split $ randomRs ('a', 'z') $ mkStdGen 1234 24 | where 25 | split cs = case splitAt strlen cs of (str, cs') -> str : split cs' 26 | 27 | -- | Generate a number of fixed length strings where the content of 28 | -- the strings are letters in random order, different from rnd 29 | rnd' :: Int -- ^ Length of each string 30 | -> Int -- ^ Number of strings 31 | -> [String] 32 | rnd' strlen num = take num $ split $ randomRs ('a', 'z') $ mkStdGen 5678 33 | where 34 | split cs = case splitAt strlen cs of (str, cs') -> str : split cs' 35 | -------------------------------------------------------------------------------- /demo-02-minigame/unordered-containers-0.2.10.0/tests/List.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Data.HashMap.List 4 | import Data.List (nub, sort, sortBy) 5 | import Data.Ord (comparing) 6 | 7 | import Test.Framework (Test, defaultMain, testGroup) 8 | import Test.Framework.Providers.QuickCheck2 (testProperty) 9 | import Test.QuickCheck ((==>), (===), property, Property) 10 | 11 | tests :: Test 12 | tests = testGroup "Data.HashMap.List" 13 | [ testProperty "isPermutationBy" pIsPermutation 14 | , testProperty "isPermutationBy of different length" pIsPermutationDiffLength 15 | , testProperty "pUnorderedCompare" pUnorderedCompare 16 | , testGroup "modelUnorderedCompare" 17 | [ testProperty "reflexive" modelUnorderedCompareRefl 18 | , testProperty "anti-symmetric" modelUnorderedCompareAntiSymm 19 | , testProperty "transitive" modelUnorderedCompareTrans 20 | ] 21 | ] 22 | 23 | pIsPermutation :: [Char] -> [Int] -> Bool 24 | pIsPermutation xs is = isPermutationBy (==) xs xs' 25 | where 26 | is' = nub is ++ [maximum (0:is) + 1 ..] 27 | xs' = map fst . sortBy (comparing snd) $ zip xs is' 28 | 29 | pIsPermutationDiffLength :: [Int] -> [Int] -> Property 30 | pIsPermutationDiffLength xs ys = 31 | length xs /= length ys ==> isPermutationBy (==) xs ys === False 32 | 33 | -- | Homogenous version of 'unorderedCompare' 34 | -- 35 | -- *Compare smallest non-equal elements of the two lists*. 36 | modelUnorderedCompare :: Ord a => [a] -> [a] -> Ordering 37 | modelUnorderedCompare as bs = compare (sort as) (sort bs) 38 | 39 | modelUnorderedCompareRefl :: [Int] -> Property 40 | modelUnorderedCompareRefl xs = modelUnorderedCompare xs xs === EQ 41 | 42 | modelUnorderedCompareAntiSymm :: [Int] -> [Int] -> Property 43 | modelUnorderedCompareAntiSymm xs ys = case a of 44 | EQ -> b === EQ 45 | LT -> b === GT 46 | GT -> b === LT 47 | where 48 | a = modelUnorderedCompare xs ys 49 | b = modelUnorderedCompare ys xs 50 | 51 | modelUnorderedCompareTrans :: [Int] -> [Int] -> [Int] -> Property 52 | modelUnorderedCompareTrans xs ys zs = 53 | case (modelUnorderedCompare xs ys, modelUnorderedCompare ys zs) of 54 | (EQ, yz) -> xz === yz 55 | (xy, EQ) -> xz === xy 56 | (LT, LT) -> xz === LT 57 | (GT, GT) -> xz === GT 58 | (LT, GT) -> property True 59 | (GT, LT) -> property True 60 | where 61 | xz = modelUnorderedCompare xs zs 62 | 63 | pUnorderedCompare :: [Int] -> [Int] -> Property 64 | pUnorderedCompare xs ys = 65 | unorderedCompare compare xs ys === modelUnorderedCompare xs ys 66 | 67 | main :: IO () 68 | main = defaultMain [tests] 69 | -------------------------------------------------------------------------------- /demo-02-minigame/unordered-containers-0.2.10.0/tests/Regressions.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Applicative ((<$>)) 4 | import Control.Monad (replicateM) 5 | import qualified Data.HashMap.Strict as HM 6 | import Data.List (delete) 7 | import Data.Maybe 8 | import Test.HUnit (Assertion, assert) 9 | import Test.Framework (Test, defaultMain) 10 | import Test.Framework.Providers.HUnit (testCase) 11 | import Test.Framework.Providers.QuickCheck2 (testProperty) 12 | import Test.QuickCheck 13 | 14 | issue32 :: Assertion 15 | issue32 = assert $ isJust $ HM.lookup 7 m' 16 | where 17 | ns = [0..16] :: [Int] 18 | m = HM.fromList (zip ns (repeat [])) 19 | m' = HM.delete 10 m 20 | 21 | ------------------------------------------------------------------------ 22 | -- Issue #39 23 | 24 | -- First regression 25 | 26 | issue39 :: Assertion 27 | issue39 = assert $ hm1 == hm2 28 | where 29 | hm1 = HM.fromList ([a, b] `zip` [1, 1 :: Int ..]) 30 | hm2 = HM.fromList ([b, a] `zip` [1, 1 :: Int ..]) 31 | a = (1, -1) :: (Int, Int) 32 | b = (-1, 1) :: (Int, Int) 33 | 34 | -- Second regression 35 | 36 | newtype Keys = Keys [Int] 37 | deriving Show 38 | 39 | instance Arbitrary Keys where 40 | arbitrary = sized $ \l -> do 41 | pis <- replicateM (l+1) positiveInt 42 | return (Keys $ prefixSum pis) 43 | 44 | shrink (Keys ls) = 45 | let l = length ls 46 | in if l == 1 47 | then [] 48 | else [ Keys (dropAt i ls) | i <- [0..l-1] ] 49 | 50 | positiveInt :: Gen Int 51 | positiveInt = (+1) . abs <$> arbitrary 52 | 53 | prefixSum :: [Int] -> [Int] 54 | prefixSum = loop 0 55 | where 56 | loop _ [] = [] 57 | loop prefix (l:ls) = let n = l + prefix 58 | in n : loop n ls 59 | 60 | dropAt :: Int -> [a] -> [a] 61 | dropAt _ [] = [] 62 | dropAt i (l:ls) | i == 0 = ls 63 | | otherwise = l : dropAt (i-1) ls 64 | 65 | propEqAfterDelete :: Keys -> Bool 66 | propEqAfterDelete (Keys keys) = 67 | let keyMap = mapFromKeys keys 68 | k = head keys 69 | in HM.delete k keyMap == mapFromKeys (delete k keys) 70 | 71 | mapFromKeys :: [Int] -> HM.HashMap Int () 72 | mapFromKeys keys = HM.fromList (zip keys (repeat ())) 73 | 74 | ------------------------------------------------------------------------ 75 | -- * Test list 76 | 77 | tests :: [Test] 78 | tests = 79 | [ 80 | testCase "issue32" issue32 81 | , testCase "issue39a" issue39 82 | , testProperty "issue39b" propEqAfterDelete 83 | ] 84 | 85 | ------------------------------------------------------------------------ 86 | -- * Test harness 87 | 88 | main :: IO () 89 | main = defaultMain tests 90 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## Changes in 3.2.5: 2 | 3 | * Build fixes for GHC 8.8.x 4 | 5 | ## Changes in 3.2.4: 6 | 7 | * Remove dependency on QuickCheck 8 | * Change the way that bootstrapping is done: see README.md for build 9 | instructions 10 | 11 | ## Changes in 3.2.3: 12 | 13 | * fix issue when using cpphs (#116) 14 | 15 | ## Changes in 3.2.2: 16 | 17 | * Manage line length in generated files [GH-84] 18 | * Fix issue when identifier with multiple single quotes, e.g. `foo''` was used 19 | * Allow omitting spaces around `=` in macro definitions 20 | * Include pre-generated Parser.hs and Scan.hs in the Hackage upload, to 21 | make bootstrapping easier. 22 | 23 | ## Changes in 3.2.1: 24 | 25 | * Fix build problem with GHC; add new test tokens_scan_user.x 26 | 27 | ## Changes in 3.2.0: 28 | 29 | * Allow the token type and productions to be overloaded, and add new 30 | directives: %token, %typeclass, %action. See "Type Signatures and 31 | Typeclasses" in the manual. 32 | * Some small space leak fixes 33 | 34 | ## Changes in 3.1.7: 35 | 36 | * Add support for `%encoding` directive 37 | (allows to control `--latin1` from inside Alex scripts) 38 | * Make code forward-compatible with in-progress proposals 39 | * Suppress more warnings 40 | 41 | ## Changes in 3.1.6: 42 | 43 | * `sdist` for 3.1.5 was mis-generated, causing it to ask for Happy 44 | when building. 45 | 46 | ## Changes in 3.1.5: 47 | 48 | * Generate less warning-laden code, and suppress other warnings. 49 | * Bug fixes. 50 | 51 | ## Changes in 3.1.4: 52 | 53 | * Add Applicative/Functor instances for GHC 7.10 54 | 55 | ## Changes in 3.1.3: 56 | 57 | * Fix for clang (XCode 5) 58 | 59 | ## Changes in 3.1.2: 60 | 61 | * Add missing file to extra-source-files 62 | 63 | ## Changes in 3.1.1: 64 | 65 | * Bug fixes (#24, #30, #31, #32) 66 | 67 | ## Changes in 3.1.0: 68 | 69 | * necessary changes to work with GHC 7.8.1 70 | 71 | ## Changes in 3.0 (since 2.3.5) 72 | 73 | * Unicode support (contributed mostly by Jean-Philippe Bernardy, 74 | with help from Alan Zimmerman). 75 | 76 | * An Alex lexer now takes a UTF-8 encoded byte sequence as input 77 | (see Section 5.1, “Unicode and UTF-8”. If you are using the 78 | "basic" wrapper or one of the other wrappers that takes a 79 | Haskell String as input, the string is automatically encoded 80 | into UTF-8 by Alex. If your input is a ByteString, you are 81 | responsible for ensuring that the input is UTF-8 encoded. The 82 | old 8-bit behaviour is still available via the --latin1 83 | option. 84 | 85 | * Alex source files are assumed to be in UTF-8, like Haskell 86 | source files. The lexer specification can use Unicode 87 | characters and ranges. 88 | 89 | * `alexGetChar` is renamed to `alexGetByte` in the generated code. 90 | 91 | * There is a new option, `--latin1`, that restores the old 92 | behaviour. 93 | 94 | * Alex now does DFA minimization, which helps to reduce the size 95 | of the generated tables, especially for lexers that use Unicode. 96 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 1995-2011, Chris Dornan and Simon Marlow 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of the copyright holders, nor the names of the 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/README.md: -------------------------------------------------------------------------------- 1 | # Alex: A Lexical Analyser Generator 2 | 3 | [![Build Status](https://secure.travis-ci.org/simonmar/alex.png?branch=master)](http://travis-ci.org/simonmar/alex) 4 | 5 | Alex is a Lex-like tool for generating Haskell scanners. For complete 6 | documentation, see the doc directory. 7 | 8 | - 9 | 10 | - 11 | 12 | Alex version 2.0 has changed fairly considerably since version 1.x, 13 | and the syntax is almost completely different. For a detailed list of 14 | changes, see the release notes in the documentation. 15 | 16 | Alex is now covered by a BSD-Style licence; see the licence file in 17 | the 'doc' directory for details. 18 | 19 | The sources are in the 'src' directory and the documentation in the 'doc' 20 | directory; various examples are in the 'examples' subdirectory. 21 | 22 | The source code in the 'src' and 'examples' directories is intended 23 | for a Haskell 98 compiler with hierarchical modules. It should work 24 | with GHC >= 5.04. 25 | 26 | ## Build Instructions 27 | 28 | If you just want to *use* Alex, you can download or install (via 29 | `cabal install alex`) an 30 | [Alex release from Hackage](https://hackage.haskell.org/package/alex); also note that 31 | distributions such as the 32 | [Haskell Platform](https://www.haskell.org/platform/) and other package 33 | manager-based distributions provide packages for Alex. Moreover, 34 | recent versions of `cabal` will automatically install the required 35 | version of `alex` based on 36 | [`build-tools`/`build-tool-depends` declarations](http://cabal.readthedocs.io/en/latest/developing-packages.html#pkg-field-build-tool-depends). 37 | 38 | Read on if you want to build Alex directly from Git. 39 | 40 | Alex is built using GHC & Cabal; so first install 41 | [GHC](https://www.haskell.org/ghc) and 42 | [`cabal-install-2.0`](https://www.haskell.org/cabal) (or later). 43 | 44 | Since Alex itself is implemented in terms of an Alex scanner, 45 | bootstrapping Alex is a bit tricky: 46 | 47 | You need to have the build-tools `alex` and `happy` manually 48 | installed; either via your system package manager distribution, the 49 | Haskell Platform, or e.g. via (run this outside the Git repository!): 50 | 51 | $ cabal install alex happy 52 | 53 | which installs them into `${HOME}/.cabal/bin` by default (make sure 54 | they're in your `$PATH` for the next steps!). 55 | 56 | ### Variant A 57 | 58 | First you need to generate the pre-processed templates via 59 | 60 | $ cabal new-run gen-alex-sdist 61 | 62 | (otherwise `cabal install` will complain about 63 | "`data/AlexTemplate: copyFile: does not exist (No such file or directory)`") 64 | 65 | And then you can install `alex` simply by invoking 66 | 67 | $ cabal install 68 | 69 | from inside the Git folder. 70 | 71 | ### Variant B 72 | 73 | Alternatively, you can use the `Makefile` which automates the steps of 74 | producing a self-contained pre-bootstrapped source distribution with 75 | pre-generated lexer/scanners (and which also performs the `cabal 76 | new-run gen-alex-sdist` pre-preprocessing step): 77 | 78 | $ make sdist 79 | $ cabal install dist/alex-*.tar.gz 80 | 81 | For convenience, there's also a `make sdist-test` target which builds the 82 | source source tarball and runs the test-suite from within the source dist. 83 | 84 | ## Contributing & Reporting Issues 85 | 86 | Please report any bugs or comments at https://github.com/simonmar/alex/issues 87 | 88 | Share and enjoy, 89 | 90 | Chris Dornan: cdornan@arm.com 91 | 92 | Isaac Jones: ijones@syntaxpolice.org 93 | 94 | Simon Marlow: simonmar@microsoft.com 95 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/TODO: -------------------------------------------------------------------------------- 1 | - Option for pure Haskell 98 output? 2 | - maybe Haskell 2010 at this point? 3 | - how about an option to use Data.Array.Unboxed? 4 | 5 | - Put in {-# LINE #-} pragmas for token actions 6 | 7 | - Prune states that aren't reachable? 8 | 9 | - Issue a warning for tokens that can't be generated? 10 | 11 | - Info file? 12 | - start codes 13 | - accepting states 14 | 15 | - More compact lexer table encoding: 16 | - equivalence classes? 17 | 18 | - Improve performance of Alex itself 19 | 20 | - AlexEOF doesn't provide a way to get at the text position of the EOF. 21 | 22 | - Allow user-defined wrappers? Wrappers in files relative to the 23 | current directory, for example? 24 | 25 | - case-insensitivity option (like flex's -i). 26 | 27 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/alex.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >= 1.8 2 | name: alex 3 | version: 3.2.5 4 | -- don't forget updating changelog.md! 5 | license: BSD3 6 | license-file: LICENSE 7 | copyright: (c) Chis Dornan, Simon Marlow 8 | author: Chris Dornan and Simon Marlow 9 | maintainer: Simon Marlow 10 | bug-reports: https://github.com/simonmar/alex/issues 11 | stability: stable 12 | homepage: http://www.haskell.org/alex/ 13 | synopsis: Alex is a tool for generating lexical analysers in Haskell 14 | description: 15 | Alex is a tool for generating lexical analysers in Haskell. 16 | It takes a description of tokens based on regular 17 | expressions and generates a Haskell module containing code 18 | for scanning text efficiently. It is similar to the tool 19 | lex or flex for C/C++. 20 | 21 | category: Development 22 | build-type: Simple 23 | 24 | data-dir: data/ 25 | 26 | data-files: 27 | AlexTemplate 28 | AlexTemplate-ghc 29 | AlexTemplate-ghc-nopred 30 | AlexTemplate-ghc-debug 31 | AlexTemplate-debug 32 | AlexWrapper-basic 33 | AlexWrapper-basic-bytestring 34 | AlexWrapper-strict-bytestring 35 | AlexWrapper-posn 36 | AlexWrapper-posn-bytestring 37 | AlexWrapper-monad 38 | AlexWrapper-monad-bytestring 39 | AlexWrapper-monadUserState 40 | AlexWrapper-monadUserState-bytestring 41 | AlexWrapper-gscan 42 | 43 | extra-source-files: 44 | CHANGELOG.md 45 | README.md 46 | TODO 47 | alex.spec 48 | doc/Makefile 49 | doc/aclocal.m4 50 | doc/alex.1.in 51 | doc/alex.xml 52 | doc/config.mk.in 53 | doc/configure.ac 54 | doc/docbook-xml.mk 55 | doc/fptools.css 56 | examples/Makefile 57 | examples/Tokens.x 58 | examples/Tokens_gscan.x 59 | examples/Tokens_posn.x 60 | examples/examples.x 61 | examples/haskell.x 62 | examples/lit.x 63 | examples/pp.x 64 | examples/state.x 65 | examples/tiny.y 66 | examples/words.x 67 | examples/words_monad.x 68 | examples/words_posn.x 69 | src/Parser.y.boot 70 | src/Scan.x.boot 71 | src/ghc_hooks.c 72 | templates/GenericTemplate.hs 73 | templates/wrappers.hs 74 | tests/Makefile 75 | tests/simple.x 76 | tests/null.x 77 | tests/tokens.x 78 | tests/tokens_gscan.x 79 | tests/tokens_posn.x 80 | tests/tokens_bytestring.x 81 | tests/tokens_posn_bytestring.x 82 | tests/tokens_scan_user.x 83 | tests/tokens_strict_bytestring.x 84 | tests/tokens_monad_bytestring.x 85 | tests/tokens_monadUserState_bytestring.x 86 | tests/tokens_bytestring_unicode.x 87 | tests/basic_typeclass.x 88 | tests/basic_typeclass_bytestring.x 89 | tests/default_typeclass.x 90 | tests/gscan_typeclass.x 91 | tests/posn_typeclass.x 92 | tests/monad_typeclass.x 93 | tests/monad_typeclass_bytestring.x 94 | tests/monadUserState_typeclass.x 95 | tests/monadUserState_typeclass_bytestring.x 96 | tests/posn_typeclass_bytestring.x 97 | tests/strict_typeclass.x 98 | tests/unicode.x 99 | 100 | source-repository head 101 | type: git 102 | location: https://github.com/simonmar/alex.git 103 | 104 | flag small_base 105 | description: Choose the new smaller, split-up base package. 106 | 107 | executable alex 108 | hs-source-dirs: src 109 | main-is: Main.hs 110 | 111 | if flag(small_base) 112 | build-depends: base >= 2.1, array, containers, directory 113 | else 114 | build-depends: base >= 1.0 115 | 116 | build-depends: base < 5 117 | 118 | extensions: CPP 119 | ghc-options: -Wall -rtsopts 120 | other-modules: 121 | AbsSyn 122 | CharSet 123 | DFA 124 | DFAMin 125 | DFS 126 | Info 127 | Map 128 | NFA 129 | Output 130 | Paths_alex 131 | Parser 132 | ParseMonad 133 | Scan 134 | Set 135 | Sort 136 | Util 137 | UTF8 138 | Data.Ranged 139 | Data.Ranged.Boundaries 140 | Data.Ranged.RangedSet 141 | Data.Ranged.Ranges 142 | 143 | test-suite tests 144 | type: exitcode-stdio-1.0 145 | main-is: test.hs 146 | -- This line is important as it ensures that the local `exe:alex` component declared above is built before the test-suite component is invoked, as well as making sure that `alex` is made available on $PATH and `$alex_datadir` is set accordingly before invoking `test.hs` 147 | build-tools: alex 148 | 149 | build-depends: base, process 150 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/alex.spec: -------------------------------------------------------------------------------- 1 | %define name alex 2 | %define version 2.2 3 | %define release 1 4 | 5 | Name: %{name} 6 | Version: %{version} 7 | Release: %{release} 8 | License: BSD-like 9 | Group: Development/Languages/Haskell 10 | URL: http://haskell.org/alex/ 11 | Source: http://haskell.org/alex/dist/%{version}/alex-%{version}.tar.gz 12 | Packager: Sven Panne 13 | BuildRoot: %{_tmppath}/%{name}-%{version}-build 14 | Prefix: %{_prefix} 15 | BuildRequires: happy, ghc, docbook-dtd, docbook-xsl-stylesheets, libxslt, libxml2, fop, xmltex, dvips 16 | Summary: The lexer generator for Haskell 17 | 18 | %description 19 | Alex is a tool for generating lexical analysers in Haskell, given a 20 | description of the tokens to be recognised in the form of regular 21 | expressions. It is similar to the tool lex or flex for C/C++. 22 | 23 | %prep 24 | %setup -n alex-%{version} 25 | 26 | %build 27 | runhaskell Setup.lhs configure --prefix=%{_prefix} --docdir=%{_datadir}/doc/packages/%{name} 28 | runhaskell Setup.lhs build 29 | cd doc 30 | test -f configure || autoreconf 31 | ./configure 32 | make html 33 | 34 | %install 35 | runhaskell Setup.lhs copy --destdir=${RPM_BUILD_ROOT} 36 | 37 | %clean 38 | rm -rf ${RPM_BUILD_ROOT} 39 | 40 | %files 41 | %defattr(-,root,root) 42 | %doc ANNOUNCE 43 | %doc LICENSE 44 | %doc README 45 | %doc TODO 46 | %doc doc/alex 47 | %doc examples 48 | %{prefix}/bin/alex 49 | %{prefix}/share/alex-%{version} 50 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/data/AlexTemplate: -------------------------------------------------------------------------------- 1 | {-# LINE 1 "templates/GenericTemplate.hs" #-} 2 | -- ----------------------------------------------------------------------------- 3 | -- ALEX TEMPLATE 4 | -- 5 | -- This code is in the PUBLIC DOMAIN; you may copy it freely and use 6 | -- it for any purpose whatsoever. 7 | 8 | -- ----------------------------------------------------------------------------- 9 | -- INTERNALS and main scanner engine 10 | 11 | 12 | 13 | 14 | 15 | 16 | 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 | alexIndexInt16OffAddr arr off = arr ! off 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | alexIndexInt32OffAddr arr off = arr ! off 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | quickIndex arr i = arr ! i 107 | 108 | 109 | -- ----------------------------------------------------------------------------- 110 | -- Main lexing routines 111 | 112 | data AlexReturn a 113 | = AlexEOF 114 | | AlexError !AlexInput 115 | | AlexSkip !AlexInput !Int 116 | | AlexToken !AlexInput !Int a 117 | 118 | -- alexScan :: AlexInput -> StartCode -> AlexReturn a 119 | alexScan input__ (sc) 120 | = alexScanUser undefined input__ (sc) 121 | 122 | alexScanUser user__ input__ (sc) 123 | = case alex_scan_tkn user__ input__ (0) input__ sc AlexNone of 124 | (AlexNone, input__') -> 125 | case alexGetByte input__ of 126 | Nothing -> 127 | 128 | 129 | 130 | AlexEOF 131 | Just _ -> 132 | 133 | 134 | 135 | AlexError input__' 136 | 137 | (AlexLastSkip input__'' len, _) -> 138 | 139 | 140 | 141 | AlexSkip input__'' len 142 | 143 | (AlexLastAcc k input__''' len, _) -> 144 | 145 | 146 | 147 | AlexToken input__''' len (alex_actions ! k) 148 | 149 | 150 | -- Push the input through the DFA, remembering the most recent accepting 151 | -- state it encountered. 152 | 153 | alex_scan_tkn user__ orig_input len input__ s last_acc = 154 | input__ `seq` -- strict in the input 155 | let 156 | new_acc = (check_accs (alex_accept `quickIndex` (s))) 157 | in 158 | new_acc `seq` 159 | case alexGetByte input__ of 160 | Nothing -> (new_acc, input__) 161 | Just (c, new_input) -> 162 | 163 | 164 | 165 | case fromIntegral c of { (ord_c) -> 166 | let 167 | base = alexIndexInt32OffAddr alex_base s 168 | offset = (base + ord_c) 169 | check = alexIndexInt16OffAddr alex_check offset 170 | 171 | new_s = if (offset >= (0)) && (check == ord_c) 172 | then alexIndexInt16OffAddr alex_table offset 173 | else alexIndexInt16OffAddr alex_deflt s 174 | in 175 | case new_s of 176 | (-1) -> (new_acc, input__) 177 | -- on an error, we want to keep the input *before* the 178 | -- character that failed, not after. 179 | _ -> alex_scan_tkn user__ orig_input (if c < 0x80 || c >= 0xC0 then (len + (1)) else len) 180 | -- note that the length is increased ONLY if this is the 1st byte in a char encoding) 181 | new_input new_s new_acc 182 | } 183 | where 184 | check_accs (AlexAccNone) = last_acc 185 | check_accs (AlexAcc a ) = AlexLastAcc a input__ (len) 186 | check_accs (AlexAccSkip) = AlexLastSkip input__ (len) 187 | 188 | check_accs (AlexAccPred a predx rest) 189 | | predx user__ orig_input (len) input__ 190 | = AlexLastAcc a input__ (len) 191 | | otherwise 192 | = check_accs rest 193 | check_accs (AlexAccSkipPred predx rest) 194 | | predx user__ orig_input (len) input__ 195 | = AlexLastSkip input__ (len) 196 | | otherwise 197 | = check_accs rest 198 | 199 | 200 | data AlexLastAcc 201 | = AlexNone 202 | | AlexLastAcc !Int !AlexInput !Int 203 | | AlexLastSkip !AlexInput !Int 204 | 205 | data AlexAcc user 206 | = AlexAccNone 207 | | AlexAcc Int 208 | | AlexAccSkip 209 | 210 | | AlexAccPred Int (AlexAccPred user) (AlexAcc user) 211 | | AlexAccSkipPred (AlexAccPred user) (AlexAcc user) 212 | 213 | type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool 214 | 215 | -- ----------------------------------------------------------------------------- 216 | -- Predicates on a rule 217 | 218 | alexAndPred p1 p2 user__ in1 len in2 219 | = p1 user__ in1 len in2 && p2 user__ in1 len in2 220 | 221 | --alexPrevCharIsPred :: Char -> AlexAccPred _ 222 | alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__ 223 | 224 | alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__) 225 | 226 | --alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ 227 | alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__ 228 | 229 | --alexRightContext :: Int -> AlexAccPred _ 230 | alexRightContext (sc) user__ _ _ input__ = 231 | case alex_scan_tkn user__ input__ (0) input__ sc AlexNone of 232 | (AlexNone, _) -> False 233 | _ -> True 234 | -- TODO: there's no need to find the longest 235 | -- match when checking the right context, just 236 | -- the first match will do. 237 | 238 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/data/AlexTemplate-debug: -------------------------------------------------------------------------------- 1 | {-# LINE 1 "templates/GenericTemplate.hs" #-} 2 | -- ----------------------------------------------------------------------------- 3 | -- ALEX TEMPLATE 4 | -- 5 | -- This code is in the PUBLIC DOMAIN; you may copy it freely and use 6 | -- it for any purpose whatsoever. 7 | 8 | -- ----------------------------------------------------------------------------- 9 | -- INTERNALS and main scanner engine 10 | 11 | 12 | 13 | 14 | 15 | 16 | 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 | alexIndexInt16OffAddr arr off = arr ! off 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | alexIndexInt32OffAddr arr off = arr ! off 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | quickIndex arr i = arr ! i 107 | 108 | 109 | -- ----------------------------------------------------------------------------- 110 | -- Main lexing routines 111 | 112 | data AlexReturn a 113 | = AlexEOF 114 | | AlexError !AlexInput 115 | | AlexSkip !AlexInput !Int 116 | | AlexToken !AlexInput !Int a 117 | 118 | -- alexScan :: AlexInput -> StartCode -> AlexReturn a 119 | alexScan input__ (sc) 120 | = alexScanUser undefined input__ (sc) 121 | 122 | alexScanUser user__ input__ (sc) 123 | = case alex_scan_tkn user__ input__ (0) input__ sc AlexNone of 124 | (AlexNone, input__') -> 125 | case alexGetByte input__ of 126 | Nothing -> 127 | 128 | trace ("End of input.") $ 129 | 130 | AlexEOF 131 | Just _ -> 132 | 133 | trace ("Error.") $ 134 | 135 | AlexError input__' 136 | 137 | (AlexLastSkip input__'' len, _) -> 138 | 139 | trace ("Skipping.") $ 140 | 141 | AlexSkip input__'' len 142 | 143 | (AlexLastAcc k input__''' len, _) -> 144 | 145 | trace ("Accept.") $ 146 | 147 | AlexToken input__''' len (alex_actions ! k) 148 | 149 | 150 | -- Push the input through the DFA, remembering the most recent accepting 151 | -- state it encountered. 152 | 153 | alex_scan_tkn user__ orig_input len input__ s last_acc = 154 | input__ `seq` -- strict in the input 155 | let 156 | new_acc = (check_accs (alex_accept `quickIndex` (s))) 157 | in 158 | new_acc `seq` 159 | case alexGetByte input__ of 160 | Nothing -> (new_acc, input__) 161 | Just (c, new_input) -> 162 | 163 | trace ("State: " ++ show (s) ++ ", char: " ++ show c) $ 164 | 165 | case fromIntegral c of { (ord_c) -> 166 | let 167 | base = alexIndexInt32OffAddr alex_base s 168 | offset = (base + ord_c) 169 | check = alexIndexInt16OffAddr alex_check offset 170 | 171 | new_s = if (offset >= (0)) && (check == ord_c) 172 | then alexIndexInt16OffAddr alex_table offset 173 | else alexIndexInt16OffAddr alex_deflt s 174 | in 175 | case new_s of 176 | (-1) -> (new_acc, input__) 177 | -- on an error, we want to keep the input *before* the 178 | -- character that failed, not after. 179 | _ -> alex_scan_tkn user__ orig_input (if c < 0x80 || c >= 0xC0 then (len + (1)) else len) 180 | -- note that the length is increased ONLY if this is the 1st byte in a char encoding) 181 | new_input new_s new_acc 182 | } 183 | where 184 | check_accs (AlexAccNone) = last_acc 185 | check_accs (AlexAcc a ) = AlexLastAcc a input__ (len) 186 | check_accs (AlexAccSkip) = AlexLastSkip input__ (len) 187 | 188 | check_accs (AlexAccPred a predx rest) 189 | | predx user__ orig_input (len) input__ 190 | = AlexLastAcc a input__ (len) 191 | | otherwise 192 | = check_accs rest 193 | check_accs (AlexAccSkipPred predx rest) 194 | | predx user__ orig_input (len) input__ 195 | = AlexLastSkip input__ (len) 196 | | otherwise 197 | = check_accs rest 198 | 199 | 200 | data AlexLastAcc 201 | = AlexNone 202 | | AlexLastAcc !Int !AlexInput !Int 203 | | AlexLastSkip !AlexInput !Int 204 | 205 | data AlexAcc user 206 | = AlexAccNone 207 | | AlexAcc Int 208 | | AlexAccSkip 209 | 210 | | AlexAccPred Int (AlexAccPred user) (AlexAcc user) 211 | | AlexAccSkipPred (AlexAccPred user) (AlexAcc user) 212 | 213 | type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool 214 | 215 | -- ----------------------------------------------------------------------------- 216 | -- Predicates on a rule 217 | 218 | alexAndPred p1 p2 user__ in1 len in2 219 | = p1 user__ in1 len in2 && p2 user__ in1 len in2 220 | 221 | --alexPrevCharIsPred :: Char -> AlexAccPred _ 222 | alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__ 223 | 224 | alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__) 225 | 226 | --alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ 227 | alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__ 228 | 229 | --alexRightContext :: Int -> AlexAccPred _ 230 | alexRightContext (sc) user__ _ _ input__ = 231 | case alex_scan_tkn user__ input__ (0) input__ sc AlexNone of 232 | (AlexNone, _) -> False 233 | _ -> True 234 | -- TODO: there's no need to find the longest 235 | -- match when checking the right context, just 236 | -- the first match will do. 237 | 238 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/data/AlexTemplate-ghc-nopred: -------------------------------------------------------------------------------- 1 | {-# LINE 1 "templates/GenericTemplate.hs" #-} 2 | -- ----------------------------------------------------------------------------- 3 | -- ALEX TEMPLATE 4 | -- 5 | -- This code is in the PUBLIC DOMAIN; you may copy it freely and use 6 | -- it for any purpose whatsoever. 7 | 8 | -- ----------------------------------------------------------------------------- 9 | -- INTERNALS and main scanner engine 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | -- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. 28 | #if __GLASGOW_HASKELL__ > 706 29 | #define GTE(n,m) (tagToEnum# (n >=# m)) 30 | #define EQ(n,m) (tagToEnum# (n ==# m)) 31 | #else 32 | #define GTE(n,m) (n >=# m) 33 | #define EQ(n,m) (n ==# m) 34 | #endif 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | data AlexAddr = AlexA# Addr# 55 | -- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. 56 | #if __GLASGOW_HASKELL__ < 503 57 | uncheckedShiftL# = shiftL# 58 | #endif 59 | 60 | {-# INLINE alexIndexInt16OffAddr #-} 61 | alexIndexInt16OffAddr (AlexA# arr) off = 62 | #ifdef WORDS_BIGENDIAN 63 | narrow16Int# i 64 | where 65 | i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) 66 | high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) 67 | low = int2Word# (ord# (indexCharOffAddr# arr off')) 68 | off' = off *# 2# 69 | #else 70 | indexInt16OffAddr# arr off 71 | #endif 72 | 73 | 74 | 75 | 76 | 77 | {-# INLINE alexIndexInt32OffAddr #-} 78 | alexIndexInt32OffAddr (AlexA# arr) off = 79 | #ifdef WORDS_BIGENDIAN 80 | narrow32Int# i 81 | where 82 | i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` 83 | (b2 `uncheckedShiftL#` 16#) `or#` 84 | (b1 `uncheckedShiftL#` 8#) `or#` b0) 85 | b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) 86 | b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) 87 | b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) 88 | b0 = int2Word# (ord# (indexCharOffAddr# arr off')) 89 | off' = off *# 4# 90 | #else 91 | indexInt32OffAddr# arr off 92 | #endif 93 | 94 | 95 | 96 | 97 | 98 | 99 | #if __GLASGOW_HASKELL__ < 503 100 | quickIndex arr i = arr ! i 101 | #else 102 | -- GHC >= 503, unsafeAt is available from Data.Array.Base. 103 | quickIndex = unsafeAt 104 | #endif 105 | 106 | 107 | 108 | 109 | -- ----------------------------------------------------------------------------- 110 | -- Main lexing routines 111 | 112 | data AlexReturn a 113 | = AlexEOF 114 | | AlexError !AlexInput 115 | | AlexSkip !AlexInput !Int 116 | | AlexToken !AlexInput !Int a 117 | 118 | -- alexScan :: AlexInput -> StartCode -> AlexReturn a 119 | alexScan input__ (I# (sc)) 120 | = alexScanUser undefined input__ (I# (sc)) 121 | 122 | alexScanUser user__ input__ (I# (sc)) 123 | = case alex_scan_tkn user__ input__ 0# input__ sc AlexNone of 124 | (AlexNone, input__') -> 125 | case alexGetByte input__ of 126 | Nothing -> 127 | 128 | 129 | 130 | AlexEOF 131 | Just _ -> 132 | 133 | 134 | 135 | AlexError input__' 136 | 137 | (AlexLastSkip input__'' len, _) -> 138 | 139 | 140 | 141 | AlexSkip input__'' len 142 | 143 | (AlexLastAcc k input__''' len, _) -> 144 | 145 | 146 | 147 | AlexToken input__''' len (alex_actions ! k) 148 | 149 | 150 | -- Push the input through the DFA, remembering the most recent accepting 151 | -- state it encountered. 152 | 153 | alex_scan_tkn user__ orig_input len input__ s last_acc = 154 | input__ `seq` -- strict in the input 155 | let 156 | new_acc = (check_accs (alex_accept `quickIndex` (I# (s)))) 157 | in 158 | new_acc `seq` 159 | case alexGetByte input__ of 160 | Nothing -> (new_acc, input__) 161 | Just (c, new_input) -> 162 | 163 | 164 | 165 | case fromIntegral c of { (I# (ord_c)) -> 166 | let 167 | base = alexIndexInt32OffAddr alex_base s 168 | offset = (base +# ord_c) 169 | check = alexIndexInt16OffAddr alex_check offset 170 | 171 | new_s = if GTE(offset,0#) && EQ(check,ord_c) 172 | then alexIndexInt16OffAddr alex_table offset 173 | else alexIndexInt16OffAddr alex_deflt s 174 | in 175 | case new_s of 176 | -1# -> (new_acc, input__) 177 | -- on an error, we want to keep the input *before* the 178 | -- character that failed, not after. 179 | _ -> alex_scan_tkn user__ orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len) 180 | -- note that the length is increased ONLY if this is the 1st byte in a char encoding) 181 | new_input new_s new_acc 182 | } 183 | where 184 | check_accs (AlexAccNone) = last_acc 185 | check_accs (AlexAcc a ) = AlexLastAcc a input__ (I# (len)) 186 | check_accs (AlexAccSkip) = AlexLastSkip input__ (I# (len)) 187 | 188 | 189 | 190 | 191 | 192 | 193 | 194 | 195 | 196 | 197 | 198 | 199 | 200 | data AlexLastAcc 201 | = AlexNone 202 | | AlexLastAcc !Int !AlexInput !Int 203 | | AlexLastSkip !AlexInput !Int 204 | 205 | data AlexAcc user 206 | = AlexAccNone 207 | | AlexAcc Int 208 | | AlexAccSkip 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 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/data/AlexWrapper-basic: -------------------------------------------------------------------------------- 1 | {-# LINE 1 "templates/wrappers.hs" #-} 2 | -- ----------------------------------------------------------------------------- 3 | -- Alex wrapper code. 4 | -- 5 | -- This code is in the PUBLIC DOMAIN; you may copy it freely and use 6 | -- it for any purpose whatsoever. 7 | 8 | 9 | 10 | 11 | 12 | import Data.Word (Word8) 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | import Data.Char (ord) 30 | import qualified Data.Bits 31 | 32 | -- | Encode a Haskell String to a list of Word8 values, in UTF8 format. 33 | utf8Encode :: Char -> [Word8] 34 | utf8Encode = uncurry (:) . utf8Encode' 35 | 36 | utf8Encode' :: Char -> (Word8, [Word8]) 37 | utf8Encode' c = case go (ord c) of 38 | (x, xs) -> (fromIntegral x, map fromIntegral xs) 39 | where 40 | go oc 41 | | oc <= 0x7f = ( oc 42 | , [ 43 | ]) 44 | 45 | | oc <= 0x7ff = ( 0xc0 + (oc `Data.Bits.shiftR` 6) 46 | , [0x80 + oc Data.Bits..&. 0x3f 47 | ]) 48 | 49 | | oc <= 0xffff = ( 0xe0 + (oc `Data.Bits.shiftR` 12) 50 | , [0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) 51 | , 0x80 + oc Data.Bits..&. 0x3f 52 | ]) 53 | | otherwise = ( 0xf0 + (oc `Data.Bits.shiftR` 18) 54 | , [0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f) 55 | , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) 56 | , 0x80 + oc Data.Bits..&. 0x3f 57 | ]) 58 | 59 | 60 | 61 | type Byte = Word8 62 | 63 | -- ----------------------------------------------------------------------------- 64 | -- The input type 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 | -- Token positions 147 | 148 | -- `Posn' records the location of a token in the input text. It has three 149 | -- fields: the address (number of chacaters preceding the token), line number 150 | -- and column of a token within the file. `start_pos' gives the position of the 151 | -- start of the file and `eof_pos' a standard encoding for the end of file. 152 | -- `move_pos' calculates the new position after traversing a given character, 153 | -- assuming the usual eight character tab stops. 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | -- ----------------------------------------------------------------------------- 169 | -- Monad (default and with ByteString input) 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 | -- Basic wrapper 325 | 326 | 327 | type AlexInput = (Char,[Byte],String) 328 | 329 | alexInputPrevChar :: AlexInput -> Char 330 | alexInputPrevChar (c,_,_) = c 331 | 332 | -- alexScanTokens :: String -> [token] 333 | alexScanTokens str = go ('\n',[],str) 334 | where go inp__@(_,_bs,s) = 335 | case alexScan inp__ 0 of 336 | AlexEOF -> [] 337 | AlexError _ -> error "lexical error" 338 | AlexSkip inp__' _ln -> go inp__' 339 | AlexToken inp__' len act -> act (take len s) : go inp__' 340 | 341 | alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) 342 | alexGetByte (c,(b:bs),s) = Just (b,(c,bs,s)) 343 | alexGetByte (_,[],[]) = Nothing 344 | alexGetByte (_,[],(c:s)) = case utf8Encode' c of 345 | (b, bs) -> Just (b, (c, bs, s)) 346 | 347 | 348 | 349 | -- ----------------------------------------------------------------------------- 350 | -- Basic wrapper, ByteString version 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 | 382 | 383 | -- ----------------------------------------------------------------------------- 384 | -- Posn wrapper 385 | 386 | -- Adds text positions to the basic model. 387 | 388 | 389 | 390 | 391 | 392 | 393 | 394 | 395 | 396 | 397 | 398 | 399 | 400 | -- ----------------------------------------------------------------------------- 401 | -- Posn wrapper, ByteString version 402 | 403 | 404 | 405 | 406 | 407 | 408 | 409 | 410 | 411 | 412 | 413 | 414 | 415 | 416 | -- ----------------------------------------------------------------------------- 417 | -- GScan wrapper 418 | 419 | -- For compatibility with previous versions of Alex, and because we can. 420 | 421 | 422 | 423 | 424 | 425 | 426 | 427 | 428 | 429 | 430 | 431 | 432 | 433 | 434 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/data/AlexWrapper-basic-bytestring: -------------------------------------------------------------------------------- 1 | {-# LINE 1 "templates/wrappers.hs" #-} 2 | -- ----------------------------------------------------------------------------- 3 | -- Alex wrapper code. 4 | -- 5 | -- This code is in the PUBLIC DOMAIN; you may copy it freely and use 6 | -- it for any purpose whatsoever. 7 | 8 | 9 | 10 | 11 | 12 | import Data.Word (Word8) 13 | 14 | 15 | import Data.Int (Int64) 16 | import qualified Data.Char 17 | import qualified Data.ByteString.Lazy as ByteString 18 | import qualified Data.ByteString.Internal as ByteString (w2c) 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 | type Byte = Word8 62 | 63 | -- ----------------------------------------------------------------------------- 64 | -- The input type 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 | data AlexInput = AlexInput { alexChar :: {-# UNPACK #-} !Char, -- previous char 111 | alexStr :: !ByteString.ByteString, -- current input string 112 | alexBytePos :: {-# UNPACK #-} !Int64} -- bytes consumed so far 113 | 114 | alexInputPrevChar :: AlexInput -> Char 115 | alexInputPrevChar = alexChar 116 | 117 | alexGetByte (AlexInput {alexStr=cs,alexBytePos=n}) = 118 | case ByteString.uncons cs of 119 | Nothing -> Nothing 120 | Just (c, rest) -> 121 | Just (c, AlexInput { 122 | alexChar = ByteString.w2c c, 123 | alexStr = rest, 124 | alexBytePos = n+1}) 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | -- ----------------------------------------------------------------------------- 146 | -- Token positions 147 | 148 | -- `Posn' records the location of a token in the input text. It has three 149 | -- fields: the address (number of chacaters preceding the token), line number 150 | -- and column of a token within the file. `start_pos' gives the position of the 151 | -- start of the file and `eof_pos' a standard encoding for the end of file. 152 | -- `move_pos' calculates the new position after traversing a given character, 153 | -- assuming the usual eight character tab stops. 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | -- ----------------------------------------------------------------------------- 169 | -- Monad (default and with ByteString input) 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 | -- Basic wrapper 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 | -- Basic wrapper, ByteString version 351 | 352 | 353 | 354 | -- alexScanTokens :: ByteString.ByteString -> [token] 355 | alexScanTokens str = go (AlexInput '\n' str 0) 356 | where go inp__ = 357 | case alexScan inp__ 0 of 358 | AlexEOF -> [] 359 | AlexError _ -> error "lexical error" 360 | AlexSkip inp__' _len -> go inp__' 361 | AlexToken inp__' _ act -> 362 | let len = alexBytePos inp__' - alexBytePos inp__ in 363 | act (ByteString.take len (alexStr inp__)) : go inp__' 364 | 365 | 366 | 367 | 368 | 369 | 370 | 371 | 372 | 373 | 374 | 375 | 376 | 377 | 378 | 379 | 380 | 381 | 382 | 383 | -- ----------------------------------------------------------------------------- 384 | -- Posn wrapper 385 | 386 | -- Adds text positions to the basic model. 387 | 388 | 389 | 390 | 391 | 392 | 393 | 394 | 395 | 396 | 397 | 398 | 399 | 400 | -- ----------------------------------------------------------------------------- 401 | -- Posn wrapper, ByteString version 402 | 403 | 404 | 405 | 406 | 407 | 408 | 409 | 410 | 411 | 412 | 413 | 414 | 415 | 416 | -- ----------------------------------------------------------------------------- 417 | -- GScan wrapper 418 | 419 | -- For compatibility with previous versions of Alex, and because we can. 420 | 421 | 422 | 423 | 424 | 425 | 426 | 427 | 428 | 429 | 430 | 431 | 432 | 433 | 434 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/data/AlexWrapper-posn-bytestring: -------------------------------------------------------------------------------- 1 | {-# LINE 1 "templates/wrappers.hs" #-} 2 | -- ----------------------------------------------------------------------------- 3 | -- Alex wrapper code. 4 | -- 5 | -- This code is in the PUBLIC DOMAIN; you may copy it freely and use 6 | -- it for any purpose whatsoever. 7 | 8 | 9 | 10 | 11 | 12 | import Data.Word (Word8) 13 | 14 | 15 | import Data.Int (Int64) 16 | import qualified Data.Char 17 | import qualified Data.ByteString.Lazy as ByteString 18 | import qualified Data.ByteString.Internal as ByteString (w2c) 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 | type Byte = Word8 62 | 63 | -- ----------------------------------------------------------------------------- 64 | -- The input type 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | type AlexInput = (AlexPosn, -- current position, 88 | Char, -- previous char 89 | ByteString.ByteString, -- current input string 90 | Int64) -- bytes consumed so far 91 | 92 | ignorePendingBytes :: AlexInput -> AlexInput 93 | ignorePendingBytes i = i -- no pending bytes when lexing bytestrings 94 | 95 | alexInputPrevChar :: AlexInput -> Char 96 | alexInputPrevChar (_,c,_,_) = c 97 | 98 | alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) 99 | alexGetByte (p,_,cs,n) = 100 | case ByteString.uncons cs of 101 | Nothing -> Nothing 102 | Just (b, cs') -> 103 | let c = ByteString.w2c b 104 | p' = alexMove p c 105 | n' = n+1 106 | in p' `seq` cs' `seq` n' `seq` Just (b, (p', c, cs',n')) 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 | -- Token positions 147 | 148 | -- `Posn' records the location of a token in the input text. It has three 149 | -- fields: the address (number of chacaters preceding the token), line number 150 | -- and column of a token within the file. `start_pos' gives the position of the 151 | -- start of the file and `eof_pos' a standard encoding for the end of file. 152 | -- `move_pos' calculates the new position after traversing a given character, 153 | -- assuming the usual eight character tab stops. 154 | 155 | 156 | data AlexPosn = AlexPn !Int !Int !Int 157 | deriving (Eq,Show) 158 | 159 | alexStartPos :: AlexPosn 160 | alexStartPos = AlexPn 0 1 1 161 | 162 | alexMove :: AlexPosn -> Char -> AlexPosn 163 | alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (c+alex_tab_size-((c-1) `mod` alex_tab_size)) 164 | alexMove (AlexPn a l _) '\n' = AlexPn (a+1) (l+1) 1 165 | alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) 166 | 167 | 168 | -- ----------------------------------------------------------------------------- 169 | -- Monad (default and with ByteString input) 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 | -- Basic wrapper 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 | -- Basic wrapper, ByteString version 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 | 382 | 383 | -- ----------------------------------------------------------------------------- 384 | -- Posn wrapper 385 | 386 | -- Adds text positions to the basic model. 387 | 388 | 389 | 390 | 391 | 392 | 393 | 394 | 395 | 396 | 397 | 398 | 399 | 400 | -- ----------------------------------------------------------------------------- 401 | -- Posn wrapper, ByteString version 402 | 403 | 404 | --alexScanTokens :: ByteString.ByteString -> [token] 405 | alexScanTokens str0 = go (alexStartPos,'\n',str0,0) 406 | where go inp__@(pos,_,str,n) = 407 | case alexScan inp__ 0 of 408 | AlexEOF -> [] 409 | AlexError ((AlexPn _ line column),_,_,_) -> error $ "lexical error at line " ++ (show line) ++ ", column " ++ (show column) 410 | AlexSkip inp__' _len -> go inp__' 411 | AlexToken inp__'@(_,_,_,n') _ act -> 412 | act pos (ByteString.take (n'-n) str) : go inp__' 413 | 414 | 415 | 416 | -- ----------------------------------------------------------------------------- 417 | -- GScan wrapper 418 | 419 | -- For compatibility with previous versions of Alex, and because we can. 420 | 421 | 422 | 423 | 424 | 425 | 426 | 427 | 428 | 429 | 430 | 431 | 432 | 433 | 434 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/data/AlexWrapper-strict-bytestring: -------------------------------------------------------------------------------- 1 | {-# LINE 1 "templates/wrappers.hs" #-} 2 | -- ----------------------------------------------------------------------------- 3 | -- Alex wrapper code. 4 | -- 5 | -- This code is in the PUBLIC DOMAIN; you may copy it freely and use 6 | -- it for any purpose whatsoever. 7 | 8 | 9 | 10 | 11 | 12 | import Data.Word (Word8) 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | import qualified Data.Char 23 | import qualified Data.ByteString as ByteString 24 | import qualified Data.ByteString.Internal as ByteString hiding (ByteString) 25 | import qualified Data.ByteString.Unsafe as ByteString 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 | type Byte = Word8 62 | 63 | -- ----------------------------------------------------------------------------- 64 | -- The input type 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 | data AlexInput = AlexInput { alexChar :: {-# UNPACK #-} !Char, 129 | alexStr :: {-# UNPACK #-} !ByteString.ByteString, 130 | alexBytePos :: {-# UNPACK #-} !Int} 131 | 132 | alexInputPrevChar :: AlexInput -> Char 133 | alexInputPrevChar = alexChar 134 | 135 | alexGetByte (AlexInput {alexStr=cs,alexBytePos=n}) = 136 | case ByteString.uncons cs of 137 | Nothing -> Nothing 138 | Just (c, rest) -> 139 | Just (c, AlexInput { 140 | alexChar = ByteString.w2c c, 141 | alexStr = rest, 142 | alexBytePos = n+1}) 143 | 144 | 145 | -- ----------------------------------------------------------------------------- 146 | -- Token positions 147 | 148 | -- `Posn' records the location of a token in the input text. It has three 149 | -- fields: the address (number of chacaters preceding the token), line number 150 | -- and column of a token within the file. `start_pos' gives the position of the 151 | -- start of the file and `eof_pos' a standard encoding for the end of file. 152 | -- `move_pos' calculates the new position after traversing a given character, 153 | -- assuming the usual eight character tab stops. 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | -- ----------------------------------------------------------------------------- 169 | -- Monad (default and with ByteString input) 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 | -- Basic wrapper 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 | -- Basic wrapper, ByteString version 351 | 352 | 353 | 354 | 355 | 356 | 357 | 358 | 359 | 360 | 361 | 362 | 363 | 364 | 365 | 366 | 367 | 368 | 369 | -- alexScanTokens :: ByteString.ByteString -> [token] 370 | alexScanTokens str = go (AlexInput '\n' str 0) 371 | where go inp__ = 372 | case alexScan inp__ 0 of 373 | AlexEOF -> [] 374 | AlexError _ -> error "lexical error" 375 | AlexSkip inp__' _len -> go inp__' 376 | AlexToken inp__' _ act -> 377 | let len = alexBytePos inp__' - alexBytePos inp__ in 378 | act (ByteString.take len (alexStr inp__)) : go inp__' 379 | 380 | 381 | 382 | 383 | -- ----------------------------------------------------------------------------- 384 | -- Posn wrapper 385 | 386 | -- Adds text positions to the basic model. 387 | 388 | 389 | 390 | 391 | 392 | 393 | 394 | 395 | 396 | 397 | 398 | 399 | 400 | -- ----------------------------------------------------------------------------- 401 | -- Posn wrapper, ByteString version 402 | 403 | 404 | 405 | 406 | 407 | 408 | 409 | 410 | 411 | 412 | 413 | 414 | 415 | 416 | -- ----------------------------------------------------------------------------- 417 | -- GScan wrapper 418 | 419 | -- For compatibility with previous versions of Alex, and because we can. 420 | 421 | 422 | 423 | 424 | 425 | 426 | 427 | 428 | 429 | 430 | 431 | 432 | 433 | 434 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/doc/Makefile: -------------------------------------------------------------------------------- 1 | include config.mk 2 | 3 | XML_DOC = alex 4 | INSTALL_XML_DOC = alex 5 | 6 | include docbook-xml.mk 7 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/doc/alex.1.in: -------------------------------------------------------------------------------- 1 | .TH ALEX 1 "2003-09-09" "Glasgow FP Suite" "Alex Lexical Analyser Generator" 2 | .SH NAME 3 | alex \- the lexical analyser generator for Haskell 4 | 5 | .SH SYNOPSIS 6 | .B alex 7 | [\fIOPTION\fR]... \fIfile\fR [\fIOPTION\fR]... 8 | 9 | .SH DESCRIPTION 10 | This manual page documents briefly the 11 | .BR alex 12 | command. 13 | 14 | .PP 15 | This manual page was written for the Debian GNU/Linux distribution 16 | because the original program does not have a manual page. Instead, it 17 | has documentation in various other formats, including DVI, Info and 18 | HTML; see below. 19 | 20 | .PP 21 | .B Alex 22 | is a lexical analyser generator system for Haskell. It is similar to the 23 | tool lex or flex for C/C++. 24 | 25 | .PP 26 | Input files are expected to be of the form 27 | .I file.x 28 | and 29 | .B alex 30 | will produce output in 31 | .I file.y 32 | 33 | .PP 34 | Caveat: When using 35 | .I hbc 36 | (Chalmers Haskell) the command argument structure is slightly 37 | different. This is because the hbc run time system takes some flags 38 | as its own (for setting things like the heap size, etc). This problem 39 | can be circumvented by adding a single dash (`-') to your command 40 | line. So when using a hbc generated version of Alex, the argument 41 | structure is: 42 | 43 | .B alex \- 44 | [\fIOPTION\fR]... \fIfile\fR [\fIOPTION\fR]... 45 | 46 | .SH OPTIONS 47 | The programs follow the usual GNU command line syntax, with long 48 | options starting with two dashes (`--'). A summary of options is 49 | included below. For a complete description, see the other 50 | documentation. 51 | 52 | .TP 53 | .BR \-d ", " \-\-debug 54 | Instructs Alex to generate a lexer which will output debugging messages 55 | as it runs. 56 | 57 | .TP 58 | .BR \-g ", " \-\-ghc 59 | Instructs Alex to generate a lexer which is optimised for compiling with 60 | GHC. The lexer will be significantly more efficient, both in terms of 61 | the size of the compiled lexer and its runtime. 62 | 63 | .TP 64 | \fB\-o\fR \fIFILE\fR, \fB\-\-outfile=\fIFILE 65 | Specifies the filename in which the output is to be placed. By default, 66 | this is the name of the input file with the 67 | .I .x 68 | suffix replaced by 69 | .I .hs 70 | 71 | .TP 72 | \fB\-i\fR [\fIFILE\fR], \fB\-\-info\fR[=\fIFILE\fR] 73 | Produces a human-readable rendition of the state machine (DFA) that 74 | Alex derives from the lexer, in 75 | .I FILE 76 | (default: 77 | .I file.info 78 | where the input file is 79 | .I file.x 80 | ). 81 | 82 | The format of the info file is currently a bit basic, and not 83 | particularly informative. 84 | 85 | .TP 86 | .BR \-v ", " \-\-version 87 | Print version information on standard output then exit successfully. 88 | 89 | .SH FILES 90 | .I @DATADIR@ 91 | 92 | .SH "SEE ALSO" 93 | .BR @DOCDIR@ , 94 | the Alex homepage 95 | .UR http://haskell.org/alex/ 96 | (http://haskell.org/alex/) 97 | .UE 98 | 99 | .SH COPYRIGHT 100 | Alex Version @VERSION@ 101 | 102 | Copyright (c) 1995-2003, Chris Dornan and Simon Marlow 103 | 104 | .SH AUTHOR 105 | This manual page was written by Ian Lynagh 106 | , based on the happy manpage, for the Debian GNU/Linux 107 | system (but may be used by others). 108 | 109 | .\" Local variables: 110 | .\" mode: nroff 111 | .\" End: 112 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/doc/config.mk.in: -------------------------------------------------------------------------------- 1 | #----------------------------------------------------------------------------- 2 | # DocBook XML stuff 3 | 4 | XSLTPROC = @XsltprocCmd@ 5 | XMLLINT = @XmllintCmd@ 6 | FOP = @FopCmd@ 7 | XMLTEX = @XmltexCmd@ 8 | DBLATEX = @DbLatexCmd@ 9 | 10 | DIR_DOCBOOK_XSL = @DIR_DOCBOOK_XSL@ 11 | 12 | XSLTPROC_LABEL_OPTS = --stringparam toc.section.depth 3 \ 13 | --stringparam section.autolabel 1 \ 14 | --stringparam section.label.includes.component.label 1 15 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/doc/configure.ac: -------------------------------------------------------------------------------- 1 | 2 | AC_INIT([Alex docs], [1.0], [simonmar@microsoft.com], []) 3 | 4 | AC_CONFIG_SRCDIR([Makefile]) 5 | 6 | dnl ** check for DocBook toolchain 7 | FP_CHECK_DOCBOOK_DTD 8 | FP_DIR_DOCBOOK_XSL([/usr/share/xml/docbook/stylesheet/nwalsh/current /usr/share/xml/docbook/stylesheet/nwalsh /usr/share/sgml/docbook/docbook-xsl-stylesheets* /usr/share/sgml/docbook/xsl-stylesheets* /opt/kde?/share/apps/ksgmltools2/docbook/xsl /usr/share/docbook-xsl /usr/share/sgml/docbkxsl /usr/local/share/xsl/docbook /sw/share/xml/xsl/docbook-xsl /usr/share/xml/docbook/xsl-stylesheets*]) 9 | 10 | AC_PATH_PROG(DbLatexCmd,dblatex) 11 | 12 | AC_CONFIG_FILES([config.mk alex.1]) 13 | AC_OUTPUT 14 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/doc/docbook-xml.mk: -------------------------------------------------------------------------------- 1 | #----------------------------------------------------------------------------- 2 | # DocBook XML 3 | 4 | .PHONY: html html-no-chunks chm HxS fo dvi ps pdf 5 | 6 | ifneq "$(XML_DOC)" "" 7 | 8 | all :: html 9 | 10 | # multi-file XML document: main document name is specified in $(XML_DOC), 11 | # sub-documents (.xml files) listed in $(XML_SRCS). 12 | 13 | ifeq "$(XML_SRCS)" "" 14 | XML_SRCS = $(wildcard *.xml) 15 | endif 16 | 17 | XML_HTML = $(addsuffix /index.html,$(basename $(XML_DOC))) 18 | XML_HTML_NO_CHUNKS = $(addsuffix .html,$(XML_DOC)) 19 | XML_CHM = $(addsuffix .chm,$(XML_DOC)) 20 | XML_HxS = $(addsuffix .HxS,$(XML_DOC)) 21 | XML_DVI = $(addsuffix .dvi,$(XML_DOC)) 22 | XML_PS = $(addsuffix .ps,$(XML_DOC)) 23 | XML_PDF = $(addsuffix .pdf,$(XML_DOC)) 24 | 25 | $(XML_HTML) $(XML_NO_CHUNKS_HTML) $(XML_FO) $(XML_DVI) $(XML_PS) $(XML_PDF) :: $(XML_SRCS) 26 | 27 | html :: $(XML_HTML) 28 | html-no-chunks :: $(XML_HTML_NO_CHUNKS) 29 | chm :: $(XML_CHM) 30 | HxS :: $(XML_HxS) 31 | dvi :: $(XML_DVI) 32 | ps :: $(XML_PS) 33 | pdf :: $(XML_PDF) 34 | 35 | CLEAN_FILES += $(XML_HTML_NO_CHUNKS) $(XML_DVI) $(XML_PS) $(XML_PDF) 36 | 37 | FPTOOLS_CSS = fptools.css 38 | 39 | clean :: 40 | $(RM) -rf $(XML_DOC).out $(basename $(XML_DOC)) $(basename $(XML_DOC))-htmlhelp $(XML_DOC).pdf $(XML_DOC).dvi $(XML_DOC).ps 41 | 42 | validate :: 43 | $(XMLLINT) --valid --noout $(XMLLINT_OPTS) $(XML_DOC).xml 44 | endif 45 | 46 | #----------------------------------------------------------------------------- 47 | # DocBook XML suffix rules 48 | # 49 | 50 | %.html : %.xml 51 | $(XSLTPROC) --output $@ \ 52 | --stringparam html.stylesheet $(FPTOOLS_CSS) \ 53 | $(XSLTPROC_LABEL_OPTS) $(XSLTPROC_OPTS) \ 54 | $(DIR_DOCBOOK_XSL)/html/docbook.xsl $< 55 | 56 | %/index.html : %.xml 57 | $(RM) -rf $(dir $@) 58 | $(XSLTPROC) --stringparam base.dir $(dir $@) \ 59 | --stringparam use.id.as.filename 1 \ 60 | --stringparam html.stylesheet $(FPTOOLS_CSS) \ 61 | $(XSLTPROC_LABEL_OPTS) $(XSLTPROC_OPTS) \ 62 | $(DIR_DOCBOOK_XSL)/html/chunk.xsl $< 63 | cp $(FPTOOLS_CSS) $(dir $@) 64 | 65 | # Note: Numeric labeling seems to be uncommon for HTML Help 66 | %-htmlhelp/index.html : %.xml 67 | $(RM) -rf $(dir $@) 68 | $(XSLTPROC) --stringparam base.dir $(dir $@) \ 69 | --stringparam manifest.in.base.dir 1 \ 70 | --stringparam htmlhelp.chm "..\\"$(basename $<).chm \ 71 | $(XSLTPROC_OPTS) \ 72 | $(DIR_DOCBOOK_XSL)/htmlhelp/htmlhelp.xsl $< 73 | 74 | %-htmlhelp2/collection.HxC : %.xml 75 | $(RM) -rf $(dir $@) 76 | $(XSLTPROC) --stringparam base.dir $(dir $@) \ 77 | --stringparam use.id.as.filename 1 \ 78 | --stringparam manifest.in.base.dir 1 \ 79 | $(XSLTPROC_OPTS) \ 80 | $(DIR_DOCBOOK_XSL)/htmlhelp2/htmlhelp2.xsl $< 81 | 82 | # TODO: Detect hhc & Hxcomp via autoconf 83 | # 84 | # Two obstacles here: 85 | # 86 | # * The reason for the strange "if" below is that hhc returns 0 on error and 1 87 | # on success, the opposite of what shells and make expect. 88 | # 89 | # * There seems to be some trouble with DocBook indices, but the *.chm looks OK, 90 | # anyway, therefore we pacify make by "|| true". Ugly... 91 | # 92 | %.chm : %-htmlhelp/index.html 93 | ( cd $(dir $<) && if hhc htmlhelp.hhp ; then false ; else true ; fi ) || true 94 | 95 | %.HxS : %-htmlhelp2/collection.HxC 96 | ( cd $(dir $<) && if Hxcomp -p collection.HxC -o ../$@ ; then false ; else true ; fi ) 97 | 98 | ifneq "$(DBLATEX)" "" 99 | %.pdf : %.xml 100 | $(DBLATEX) -tpdf $< 101 | 102 | %.dvi : %.xml 103 | $(DBLATEX) -tdvi $< 104 | 105 | %.ps : %.xml 106 | $(DBLATEX) -tps $< 107 | endif 108 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/doc/fptools.css: -------------------------------------------------------------------------------- 1 | div { 2 | font-family: sans-serif; 3 | color: black; 4 | background: white 5 | } 6 | 7 | h1, h2, h3, h4, h5, h6, p.title { color: #005A9C } 8 | 9 | h1 { font: 170% sans-serif } 10 | h2 { font: 140% sans-serif } 11 | h3 { font: 120% sans-serif } 12 | h4 { font: bold 100% sans-serif } 13 | h5 { font: italic 100% sans-serif } 14 | h6 { font: small-caps 100% sans-serif } 15 | 16 | pre { 17 | font-family: monospace; 18 | border-width: 1px; 19 | border-style: solid; 20 | padding: 0.3em 21 | } 22 | 23 | pre.screen { color: #006400 } 24 | pre.programlisting { color: maroon } 25 | 26 | div.example { 27 | background-color: #fffcf5; 28 | margin: 1ex 0em; 29 | border: solid #412e25 1px; 30 | padding: 0ex 0.4em 31 | } 32 | 33 | a:link { color: #0000C8 } 34 | a:hover { background: #FFFFA8 } 35 | a:active { color: #D00000 } 36 | a:visited { color: #680098 } 37 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/examples/Makefile: -------------------------------------------------------------------------------- 1 | ALEX=../dist/build/alex/alex 2 | HC=ghc -Wall -fno-warn-unused-binds -fno-warn-missing-signatures -fno-warn-unused-matches -fno-warn-name-shadowing -fno-warn-unused-imports -fno-warn-tabs 3 | 4 | HAPPY=happy 5 | HAPPY_OPTS=-agc 6 | 7 | ifeq "$(TARGETPLATFORM)" "i386-unknown-mingw32" 8 | exeext=.exe 9 | else 10 | exeext=.bin 11 | endif 12 | 13 | PROGS = lit Tokens Tokens_gscan words words_posn words_monad tiny haskell tiger 14 | 15 | ALEX_OPTS = --template=.. -g 16 | # ALEX_OPTS = --template=.. 17 | 18 | %.alex.hs : %.x 19 | $(ALEX) $(ALEX_OPTS) $< -o $@ 20 | 21 | %.happy.hs : %.y 22 | $(HAPPY) $(HAPPY_OPTS) $< -o $@ 23 | 24 | %.o : %.hs 25 | $(HC) $(HC_OPTS) -c -o $@ $< 26 | 27 | CLEAN_FILES += *.info *.hi *.o *.bin *.exe 28 | 29 | all : $(addsuffix $(exeext),$(PROGS)) 30 | 31 | tiny$(exeext) : tiny.happy.hs Tokens_posn.alex.hs 32 | $(HC) $(HC_OPTS) -o $@ $^ 33 | 34 | lit$(exeext) : lit.alex.hs 35 | $(HC) $(HC_OPTS) -o $@ $^ 36 | 37 | Tokens$(exeext) : Tokens.alex.hs 38 | $(HC) $(HC_OPTS) -o $@ $^ 39 | 40 | Tokens_gscan$(exeext) : Tokens_gscan.alex.hs 41 | $(HC) $(HC_OPTS) -o $@ $^ 42 | 43 | words$(exeext) : words.alex.hs 44 | $(HC) $(HC_OPTS) -o $@ $^ 45 | 46 | words_posn$(exeext) : words_posn.alex.hs 47 | $(HC) $(HC_OPTS) -o $@ $^ 48 | 49 | words_monad$(exeext) : words_monad.alex.hs 50 | $(HC) $(HC_OPTS) -o $@ $^ 51 | 52 | haskell$(exeext) : haskell.alex.hs 53 | $(HC) $(HC_OPTS) -o $@ $^ 54 | 55 | tiger$(exeext) : tiger.alex.hs 56 | $(HC) $(HC_OPTS) -main-is TigerLexer -o $@ $^ 57 | 58 | .PHONY: clean 59 | clean: 60 | rm -f *.o *.hi $(addsuffix $(exeext),$(PROGS)) \ 61 | *.alex.hs *.happy.hs 62 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/examples/Tokens.x: -------------------------------------------------------------------------------- 1 | { 2 | module Main where 3 | } 4 | 5 | %wrapper "basic" 6 | 7 | $digit = 0-9 -- digits 8 | $alpha = [a-zA-Z] -- alphabetic characters 9 | 10 | tokens :- 11 | 12 | $white+ { \s -> White } 13 | "--".* { \s -> Comment } 14 | let { \s -> Let } 15 | in { \s -> In } 16 | $digit+ { \s -> Int (read s) } 17 | [\=\+\-\*\/\(\)] { \s -> Sym (head s) } 18 | $alpha [$alpha $digit \_ \']* { \s -> Var s } 19 | 20 | { 21 | -- Each right-hand side has type :: String -> Token 22 | 23 | -- The token type: 24 | data Token = 25 | White | 26 | Comment | 27 | Let | 28 | In | 29 | Sym Char | 30 | Var String | 31 | Int Int | 32 | Err 33 | deriving (Eq,Show) 34 | 35 | main = do 36 | s <- getContents 37 | print (alexScanTokens s) 38 | } 39 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/examples/Tokens_gscan.x: -------------------------------------------------------------------------------- 1 | { 2 | module Main (main) where 3 | } 4 | 5 | %wrapper "gscan" 6 | 7 | $digit = 0-9 -- digits 8 | $alpha = [a-zA-Z] -- alphabetic characters 9 | 10 | tokens :- 11 | 12 | $white+ ; 13 | "--".* ; 14 | let { tok (\p s -> Let p) } 15 | in { tok (\p s -> In p) } 16 | $digit+ { tok (\p s -> Int p (read s)) } 17 | [\=\+\-\*\/\(\)] { tok (\p s -> Sym p (head s)) } 18 | $alpha [$alpha $digit \_ \']* { tok (\p s -> Var p s) } 19 | 20 | { 21 | -- Some action helpers: 22 | tok f p c str len cont (sc,state) = f p (take len str) : cont (sc,state) 23 | 24 | -- The token type: 25 | data Token = 26 | Let AlexPosn | 27 | In AlexPosn | 28 | Sym AlexPosn Char | 29 | Var AlexPosn String | 30 | Int AlexPosn Int | 31 | Err AlexPosn 32 | deriving (Eq,Show) 33 | 34 | main = do 35 | s <- getContents 36 | print (alexGScan stop undefined s) 37 | where 38 | stop p c "" (sc,s) = [] 39 | stop p c _ (sc,s) = error "lexical error" 40 | } 41 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/examples/Tokens_posn.x: -------------------------------------------------------------------------------- 1 | { 2 | module Tokens_posn (Token(..), AlexPosn(..), alexScanTokens, token_posn) where 3 | } 4 | 5 | %wrapper "posn" 6 | 7 | $digit = 0-9 -- digits 8 | $alpha = [a-zA-Z] -- alphabetic characters 9 | 10 | tokens :- 11 | 12 | $white+ ; 13 | "--".* ; 14 | let { tok (\p s -> Let p) } 15 | in { tok (\p s -> In p) } 16 | $digit+ { tok (\p s -> Int p (read s)) } 17 | [\=\+\-\*\/\(\)] { tok (\p s -> Sym p (head s)) } 18 | $alpha [$alpha $digit \_ \']* { tok (\p s -> Var p s) } 19 | 20 | { 21 | -- Each right-hand side has type :: AlexPosn -> String -> Token 22 | 23 | -- Some action helpers: 24 | tok f p s = f p s 25 | 26 | -- The token type: 27 | data Token = 28 | Let AlexPosn | 29 | In AlexPosn | 30 | Sym AlexPosn Char | 31 | Var AlexPosn String | 32 | Int AlexPosn Int 33 | deriving (Eq,Show) 34 | 35 | token_posn (Let p) = p 36 | token_posn (In p) = p 37 | token_posn (Sym p _) = p 38 | token_posn (Var p _) = p 39 | token_posn (Int p _) = p 40 | } 41 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/examples/examples.x: -------------------------------------------------------------------------------- 1 | "example_rexps":- 2 | 3 | ::= $ | a+ -- = a*, zero or more as 4 | ::= aa* -- = a+, one or more as 5 | ::= $ | a -- = a?, zero or one as 6 | ::= a{3} -- = aaa, three as 7 | ::= a{3,5} -- = a{3}a?a? 8 | ::= a{3,} -- = a{3}a* 9 | 10 | 11 | "example_sets":- 12 | 13 | ::= a-z -- little letters 14 | ::= ~a-z -- anything but little letters 15 | ::= [a-zA-Z0-9] -- letters and digits 16 | ::= `!@@#$' -- the symbols !, @@, # and $ 17 | ::= [`!#@@$'^'^n] -- the above symbols with ' and newline 18 | ::= ^p#^' -- any graphic character except ' 19 | ::= ^127 -- ASCII DEL 20 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/examples/haskell.x: -------------------------------------------------------------------------------- 1 | -- 2 | -- Lexical syntax for Haskell 98. 3 | -- 4 | -- (c) Simon Marlow 2003, with the caveat that much of this is 5 | -- translated directly from the syntax in the Haskell 98 report. 6 | -- 7 | -- This isn't a complete Haskell 98 lexer - it doesn't handle layout 8 | -- for one thing. However, it could be adapted with a small 9 | -- amount of effort. 10 | -- 11 | 12 | { 13 | module Main (main) where 14 | import Data.Char (chr) 15 | } 16 | 17 | %wrapper "monad" 18 | 19 | $whitechar = [ \t\n\r\f\v] 20 | $special = [\(\)\,\;\[\]\`\{\}] 21 | 22 | $ascdigit = 0-9 23 | $unidigit = [] -- TODO 24 | $digit = [$ascdigit $unidigit] 25 | 26 | $ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~] 27 | $unisymbol = [] -- TODO 28 | $symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\'] 29 | 30 | $large = [A-Z \xc0-\xd6 \xd8-\xde] 31 | $small = [a-z \xdf-\xf6 \xf8-\xff \_] 32 | $alpha = [$small $large] 33 | 34 | $graphic = [$small $large $symbol $digit $special \:\"\'] 35 | 36 | $octit = 0-7 37 | $hexit = [0-9 A-F a-f] 38 | $idchar = [$alpha $digit \'] 39 | $symchar = [$symbol \:] 40 | $nl = [\n\r] 41 | 42 | @reservedid = 43 | as|case|class|data|default|deriving|do|else|hiding|if| 44 | import|in|infix|infixl|infixr|instance|let|module|newtype| 45 | of|qualified|then|type|where 46 | 47 | @reservedop = 48 | ".." | ":" | "::" | "=" | \\ | "|" | "<-" | "->" | "@" | "~" | "=>" 49 | 50 | @varid = $small $idchar* 51 | @conid = $large $idchar* 52 | @varsym = $symbol $symchar* 53 | @consym = \: $symchar* 54 | 55 | @decimal = $digit+ 56 | @octal = $octit+ 57 | @hexadecimal = $hexit+ 58 | @exponent = [eE] [\-\+] @decimal 59 | 60 | $cntrl = [$large \@\[\\\]\^\_] 61 | @ascii = \^ $cntrl | NUL | SOH | STX | ETX | EOT | ENQ | ACK 62 | | BEL | BS | HT | LF | VT | FF | CR | SO | SI | DLE 63 | | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN | EM 64 | | SUB | ESC | FS | GS | RS | US | SP | DEL 65 | $charesc = [abfnrtv\\\"\'\&] 66 | @escape = \\ ($charesc | @ascii | @decimal | o @octal | x @hexadecimal) 67 | @gap = \\ $whitechar+ \\ 68 | @string = $graphic # [\"\\] | " " | @escape | @gap 69 | 70 | haskell :- 71 | 72 | <0> $white+ { skip } 73 | <0> "--"\-*[^$symbol].* { skip } 74 | 75 | "{-" { nested_comment } 76 | 77 | <0> $special { mkL LSpecial } 78 | 79 | <0> @reservedid { mkL LReservedId } 80 | <0> @conid \. @varid { mkL LQVarId } 81 | <0> @conid \. @conid { mkL LQConId } 82 | <0> @varid { mkL LVarId } 83 | <0> @conid { mkL LConId } 84 | 85 | <0> @reservedop { mkL LReservedOp } 86 | <0> @conid \. @varsym { mkL LVarSym } 87 | <0> @conid \. @consym { mkL LConSym } 88 | <0> @varsym { mkL LVarSym } 89 | <0> @consym { mkL LConSym } 90 | 91 | <0> @decimal 92 | | 0[oO] @octal 93 | | 0[xX] @hexadecimal { mkL LInteger } 94 | 95 | <0> @decimal \. @decimal @exponent? 96 | | @decimal @exponent { mkL LFloat } 97 | 98 | <0> \' ($graphic # [\'\\] | " " | @escape) \' 99 | { mkL LChar } 100 | 101 | <0> \" @string* \" { mkL LString } 102 | 103 | { 104 | data Lexeme = L AlexPosn LexemeClass String 105 | 106 | data LexemeClass 107 | = LInteger 108 | | LFloat 109 | | LChar 110 | | LString 111 | | LSpecial 112 | | LReservedId 113 | | LReservedOp 114 | | LVarId 115 | | LQVarId 116 | | LConId 117 | | LQConId 118 | | LVarSym 119 | | LQVarSym 120 | | LConSym 121 | | LQConSym 122 | | LEOF 123 | deriving Eq 124 | 125 | mkL :: LexemeClass -> AlexInput -> Int -> Alex Lexeme 126 | mkL c (p,_,_,str) len = return (L p c (take len str)) 127 | 128 | nested_comment :: AlexInput -> Int -> Alex Lexeme 129 | nested_comment _ _ = do 130 | input <- alexGetInput 131 | go 1 input 132 | where go 0 input = do alexSetInput input; alexMonadScan 133 | go n input = do 134 | case alexGetByte input of 135 | Nothing -> err input 136 | Just (c,input) -> do 137 | case chr (fromIntegral c) of 138 | '-' -> do 139 | let temp = input 140 | case alexGetByte input of 141 | Nothing -> err input 142 | Just (125,input) -> go (n-1) input 143 | Just (45, input) -> go n temp 144 | Just (c,input) -> go n input 145 | '\123' -> do 146 | case alexGetByte input of 147 | Nothing -> err input 148 | Just (c,input) | c == fromIntegral (ord '-') -> go (n+1) input 149 | Just (c,input) -> go n input 150 | c -> go n input 151 | 152 | err input = do alexSetInput input; lexError "error in nested comment" 153 | 154 | lexError s = do 155 | (p,c,_,input) <- alexGetInput 156 | alexError (showPosn p ++ ": " ++ s ++ 157 | (if (not (null input)) 158 | then " before " ++ show (head input) 159 | else " at end of file")) 160 | 161 | scanner str = runAlex str $ do 162 | let loop i = do tok@(L _ cl _) <- alexMonadScan; 163 | if cl == LEOF 164 | then return i 165 | else do loop $! (i+1) 166 | loop 0 167 | 168 | alexEOF = return (L undefined LEOF "") 169 | 170 | showPosn (AlexPn _ line col) = show line ++ ':': show col 171 | 172 | main = do 173 | s <- getContents 174 | print (scanner s) 175 | } 176 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/examples/lit.x: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE NPlusKPatterns #-} 3 | module Main (main) where 4 | } 5 | 6 | %wrapper "gscan" 7 | 8 | $space = $white # \n 9 | @blank = \n $space* 10 | @scrap = \n \> .* 11 | @comment = \n ( [^ \> $white] | $space+ ~$white ) .* 12 | 13 | lit :- 14 | 15 | @blank @scrap+ { scrap } 16 | @blank @comment* { comment } 17 | 18 | { 19 | scrap _ _ inp len cont st = strip len inp 20 | where 21 | strip 0 _ = cont st 22 | strip (n+1) (c:rst) = 23 | if c=='\n' 24 | then '\n':strip_nl n rst 25 | else c:strip n rst 26 | 27 | strip_nl (n+1) ('>':rst) = ' ':strip n rst 28 | strip_nl n rst = strip n rst 29 | 30 | comment _ _ inp len cont st = strip len inp 31 | where 32 | strip 0 _ = cont st 33 | strip (n+1) (c:rst) = if c=='\n' then c:strip n rst else strip n rst 34 | 35 | 36 | main:: IO () 37 | main = interact literate 38 | 39 | literate:: String -> String 40 | literate inp = drop 2 (alexGScan stop_act () ('\n':'\n':inp)) 41 | 42 | stop_act p _ "" st = [] 43 | stop_act p _ _ _ = error (msg ++ loc p ++ "\n") 44 | 45 | msg = "literate preprocessing error at " 46 | 47 | loc (AlexPn _ l c) = "line " ++ show(l-2) ++ ", column " ++ show c 48 | } 49 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/examples/pp.x: -------------------------------------------------------------------------------- 1 | %{ 2 | import System 3 | import Char 4 | import Alex 5 | %} 6 | 7 | 8 | "pp_lx"/"pp_acts":- 9 | 10 | { ^s = ^w#^n } -- spaces and tabs, etc. 11 | { ^f = [A-Za-z0-9`~%-_.,/'] } -- file name character 12 | 13 | ::= ^#include^s+^"^f+^"^s*^n 14 | ::= .*^n 15 | 16 | 17 | %{ 18 | inc p c inp len cont st = pp fn >> cont st 19 | where 20 | fn = (takeWhile ('"'/=) . tail . dropWhile isSpace . drop 8) inp 21 | 22 | txt p c inp len cont st = putStr (take len inp) >> cont st 23 | 24 | 25 | main:: IO () 26 | main = getArgs >>= \args -> 27 | case args of 28 | [fn] -> pp fn 29 | _ -> error "usage: pp file\n" 30 | 31 | pp:: String -> IO () 32 | pp fn = readFile fn >>= \cts -> gscan pp_scan () cts 33 | 34 | pp_scan:: GScan () (IO ()) 35 | pp_scan = load_gscan (pp_acts,stop_act) pp_lx 36 | where 37 | stop_act _ _ _ _ = return () 38 | %} 39 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/examples/state.x: -------------------------------------------------------------------------------- 1 | { 2 | module Main (main) where 3 | } 4 | 5 | %wrapper "gscan" 6 | 7 | state :- 8 | 9 | $white+ { skip } 10 | \{ [^\}]* \} { code } 11 | [A-Za-z]+ { ide } 12 | 13 | { 14 | code _ _ inp len cont (sc,frags) = cont (sc,frag:frags) 15 | where 16 | frag = take (len-4) (drop 2 inp) 17 | 18 | ide _ _ inp len cont st = Ide (take len inp):cont st 19 | 20 | skip _ _ inp len cont st = cont st 21 | 22 | data Token = Ide String | Eof String | Err deriving Show 23 | 24 | stop_act _ _ "" (_,frags) = [Eof (unlines(reverse frags))] 25 | stop_act _ _ _ _ = [Err] 26 | 27 | tokens:: String -> [Token] 28 | tokens inp = alexGScan stop_act [] inp 29 | 30 | main:: IO () 31 | main = interact (show.tokens) 32 | } 33 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/examples/tiny.y: -------------------------------------------------------------------------------- 1 | -- An example demonstrating how to connect a Happy parser to an Alex lexer. 2 | { 3 | import Tokens_posn 4 | } 5 | 6 | %name calc 7 | %tokentype { Token } 8 | 9 | %token let { Let _ } 10 | in { In _ } 11 | int { Int _ $$ } 12 | var { Var _ $$ } 13 | '=' { Sym _ '=' } 14 | '+' { Sym _ '+' } 15 | '-' { Sym _ '-' } 16 | '*' { Sym _ '*' } 17 | '/' { Sym _ '/' } 18 | '(' { Sym _ '(' } 19 | ')' { Sym _ ')' } 20 | 21 | %% 22 | 23 | Exp :: { Exp } 24 | Exp : let var '=' Exp in Exp { LetE $2 $4 $6 } 25 | | Exp1 { $1 } 26 | 27 | Exp1 : Exp1 '+' Term { PlusE $1 $3 } 28 | | Exp1 '-' Term { MinusE $1 $3 } 29 | | Term { $1 } 30 | 31 | Term : Term '*' Factor { TimesE $1 $3 } 32 | | Term '/' Factor { DivE $1 $3 } 33 | | Factor { $1 } 34 | 35 | Factor : '-' Atom { NegE $2 } 36 | | Atom { $1 } 37 | 38 | Atom : int { IntE $1 } 39 | | var { VarE $1 } 40 | | '(' Exp ')' { $2 } 41 | 42 | { 43 | data Exp = 44 | LetE String Exp Exp | 45 | PlusE Exp Exp | 46 | MinusE Exp Exp | 47 | TimesE Exp Exp | 48 | DivE Exp Exp | 49 | NegE Exp | 50 | IntE Int | 51 | VarE String 52 | deriving Show 53 | 54 | 55 | main:: IO () 56 | main = interact (show.runCalc) 57 | 58 | runCalc :: String -> Exp 59 | runCalc = calc . alexScanTokens 60 | 61 | happyError :: [Token] -> a 62 | happyError tks = error ("Parse error at " ++ lcn ++ "\n") 63 | where 64 | lcn = case tks of 65 | [] -> "end of file" 66 | tk:_ -> "line " ++ show l ++ ", column " ++ show c 67 | where 68 | AlexPn _ l c = token_posn tk 69 | } 70 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/examples/words.x: -------------------------------------------------------------------------------- 1 | -- Performance test; run with input /usr/dict/words, for example 2 | { 3 | module Main (main) where 4 | } 5 | 6 | %wrapper "basic" 7 | 8 | words :- 9 | 10 | $white+ ; 11 | [A-Za-z0-9\'\-]+ { \s -> () } 12 | 13 | { 14 | main = do 15 | s <- getContents 16 | print (length (alexScanTokens s)) 17 | } 18 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/examples/words_monad.x: -------------------------------------------------------------------------------- 1 | -- Performance test; run with input /usr/dict/words, for example 2 | { 3 | module Main (main) where 4 | } 5 | 6 | %wrapper "monad" 7 | 8 | words :- 9 | 10 | $white+ { skip } 11 | [A-Za-z0-9\'\-]+ { word } 12 | 13 | { 14 | word (_,_,_,input) len = return (take len input) 15 | 16 | scanner str = runAlex str $ do 17 | let loop i = do tok <- alexMonadScan 18 | if tok == "stopped." || tok == "error." 19 | then return i 20 | else do let i' = i+1 in i' `seq` loop i' 21 | loop 0 22 | 23 | alexEOF = return "stopped." 24 | 25 | main = do 26 | s <- getContents 27 | print (scanner s) 28 | } 29 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/examples/words_posn.x: -------------------------------------------------------------------------------- 1 | -- Performance test; run with input /usr/dict/words, for example 2 | { 3 | module Main (main) where 4 | } 5 | 6 | %wrapper "posn" 7 | 8 | words :- 9 | 10 | $white+ ; 11 | [A-Za-z0-9\'\-]+ { \p s -> () } 12 | 13 | { 14 | main = do 15 | s <- getContents 16 | print (length (alexScanTokens s)) 17 | } 18 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/src/CharSet.hs: -------------------------------------------------------------------------------- 1 | -- ----------------------------------------------------------------------------- 2 | -- 3 | -- CharSet.hs, part of Alex 4 | -- 5 | -- (c) Chris Dornan 1995-2000, Simon Marlow 2003 6 | -- 7 | -- An abstract CharSet type for Alex. To begin with we'll use Alex's 8 | -- original definition of sets as functions, then later will 9 | -- transition to something that will work better with Unicode. 10 | -- 11 | -- ----------------------------------------------------------------------------} 12 | 13 | module CharSet ( 14 | setSingleton, 15 | 16 | Encoding(..), 17 | 18 | Byte, 19 | ByteSet, 20 | byteSetSingleton, 21 | byteRanges, 22 | byteSetRange, 23 | 24 | CharSet, -- abstract 25 | emptyCharSet, 26 | charSetSingleton, 27 | charSet, 28 | charSetMinus, 29 | charSetComplement, 30 | charSetRange, 31 | charSetUnion, 32 | charSetQuote, 33 | setUnions, 34 | byteSetToArray, 35 | byteSetElems, 36 | byteSetElem 37 | ) where 38 | 39 | import Data.Array 40 | import Data.Ranged 41 | import Data.Word 42 | import Data.Maybe (catMaybes) 43 | import Data.Char (chr,ord) 44 | import UTF8 45 | 46 | type Byte = Word8 47 | -- Implementation as functions 48 | type CharSet = RSet Char 49 | type ByteSet = RSet Byte 50 | -- type Utf8Set = RSet [Byte] 51 | type Utf8Range = Span [Byte] 52 | 53 | data Encoding = Latin1 | UTF8 54 | deriving (Eq, Show) 55 | 56 | emptyCharSet :: CharSet 57 | emptyCharSet = rSetEmpty 58 | 59 | byteSetElem :: ByteSet -> Byte -> Bool 60 | byteSetElem = rSetHas 61 | 62 | charSetSingleton :: Char -> CharSet 63 | charSetSingleton = rSingleton 64 | 65 | setSingleton :: DiscreteOrdered a => a -> RSet a 66 | setSingleton = rSingleton 67 | 68 | charSet :: [Char] -> CharSet 69 | charSet = setUnions . fmap charSetSingleton 70 | 71 | charSetMinus :: CharSet -> CharSet -> CharSet 72 | charSetMinus = rSetDifference 73 | 74 | charSetUnion :: CharSet -> CharSet -> CharSet 75 | charSetUnion = rSetUnion 76 | 77 | setUnions :: DiscreteOrdered a => [RSet a] -> RSet a 78 | setUnions = foldr rSetUnion rSetEmpty 79 | 80 | charSetComplement :: CharSet -> CharSet 81 | charSetComplement = rSetNegation 82 | 83 | charSetRange :: Char -> Char -> CharSet 84 | charSetRange c1 c2 = makeRangedSet [Range (BoundaryBelow c1) (BoundaryAbove c2)] 85 | 86 | byteSetToArray :: ByteSet -> Array Byte Bool 87 | byteSetToArray set = array (fst (head ass), fst (last ass)) ass 88 | where ass = [(c,rSetHas set c) | c <- [0..0xff]] 89 | 90 | byteSetElems :: ByteSet -> [Byte] 91 | byteSetElems set = [c | c <- [0 .. 0xff], rSetHas set c] 92 | 93 | charToRanges :: Encoding -> CharSet -> [Utf8Range] 94 | charToRanges Latin1 = 95 | map (fmap ((: []).fromIntegral.ord)) -- Span [Byte] 96 | . catMaybes 97 | . fmap (charRangeToCharSpan False) 98 | . rSetRanges 99 | charToRanges UTF8 = 100 | concat -- Span [Byte] 101 | . fmap toUtfRange -- [Span [Byte]] 102 | . fmap (fmap UTF8.encode) -- Span [Byte] 103 | . catMaybes 104 | . fmap (charRangeToCharSpan True) 105 | . rSetRanges 106 | 107 | -- | Turns a range of characters expressed as a pair of UTF-8 byte sequences into a set of ranges, in which each range of the resulting set is between pairs of sequences of the same length 108 | toUtfRange :: Span [Byte] -> [Span [Byte]] 109 | toUtfRange (Span x y) = fix x y 110 | 111 | fix :: [Byte] -> [Byte] -> [Span [Byte]] 112 | fix x y 113 | | length x == length y = [Span x y] 114 | | length x == 1 = Span x [0x7F] : fix [0xC2,0x80] y 115 | | length x == 2 = Span x [0xDF,0xBF] : fix [0xE0,0x80,0x80] y 116 | | length x == 3 = Span x [0xEF,0xBF,0xBF] : fix [0xF0,0x80,0x80,0x80] y 117 | | otherwise = error "fix: incorrect input given" 118 | 119 | 120 | byteRangeToBytePair :: Span [Byte] -> ([Byte],[Byte]) 121 | byteRangeToBytePair (Span x y) = (x,y) 122 | 123 | data Span a = Span a a -- lower bound inclusive, higher bound exclusive 124 | -- (SDM: upper bound inclusive, surely?) 125 | instance Functor Span where 126 | fmap f (Span x y) = Span (f x) (f y) 127 | 128 | charRangeToCharSpan :: Bool -> Range Char -> Maybe (Span Char) 129 | charRangeToCharSpan _ (Range BoundaryAboveAll _) = Nothing 130 | charRangeToCharSpan _ (Range (BoundaryAbove c) _) | c == maxBound = Nothing 131 | charRangeToCharSpan _ (Range _ BoundaryBelowAll) = Nothing 132 | charRangeToCharSpan _ (Range _ (BoundaryBelow c)) | c == minBound = Nothing 133 | charRangeToCharSpan uni (Range x y) = Just (Span (l x) (h y)) 134 | where l b = case b of 135 | BoundaryBelowAll -> '\0' 136 | BoundaryBelow a -> a 137 | BoundaryAbove a -> succ a 138 | BoundaryAboveAll -> error "panic: charRangeToCharSpan" 139 | h b = case b of 140 | BoundaryBelowAll -> error "panic: charRangeToCharSpan" 141 | BoundaryBelow a -> pred a 142 | BoundaryAbove a -> a 143 | BoundaryAboveAll | uni -> chr 0x10ffff 144 | | otherwise -> chr 0xff 145 | 146 | byteRanges :: Encoding -> CharSet -> [([Byte],[Byte])] 147 | byteRanges enc = fmap byteRangeToBytePair . charToRanges enc 148 | 149 | byteSetRange :: Byte -> Byte -> ByteSet 150 | byteSetRange c1 c2 = makeRangedSet [Range (BoundaryBelow c1) (BoundaryAbove c2)] 151 | 152 | byteSetSingleton :: Byte -> ByteSet 153 | byteSetSingleton = rSingleton 154 | 155 | -- TODO: More efficient generated code! 156 | charSetQuote :: CharSet -> String 157 | charSetQuote s = "(\\c -> " ++ foldr (\x y -> x ++ " || " ++ y) "False" (map quoteRange (rSetRanges s)) ++ ")" 158 | where quoteRange (Range l h) = quoteL l ++ " && " ++ quoteH h 159 | quoteL (BoundaryAbove a) = "c > " ++ show a 160 | quoteL (BoundaryBelow a) = "c >= " ++ show a 161 | quoteL (BoundaryAboveAll) = "False" 162 | quoteL (BoundaryBelowAll) = "True" 163 | quoteH (BoundaryAbove a) = "c <= " ++ show a 164 | quoteH (BoundaryBelow a) = "c < " ++ show a 165 | quoteH (BoundaryAboveAll) = "True" 166 | quoteH (BoundaryBelowAll) = "False" 167 | 168 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/src/DFAMin.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE PatternGuards #-} 3 | module DFAMin (minimizeDFA) where 4 | 5 | import AbsSyn 6 | 7 | import Data.Map (Map) 8 | import qualified Data.Map as Map 9 | import Data.IntSet (IntSet) 10 | import qualified Data.IntSet as IS 11 | import Data.IntMap (IntMap) 12 | import qualified Data.IntMap as IM 13 | import Data.List as List 14 | 15 | 16 | -- Hopcroft's Algorithm for DFA minimization (cut/pasted from Wikipedia): 17 | 18 | -- P := {{all accepting states}, {all nonaccepting states}}; 19 | -- Q := {{all accepting states}}; 20 | -- while (Q is not empty) do 21 | -- choose and remove a set A from Q 22 | -- for each c in ∑ do 23 | -- let X be the set of states for which a transition on c leads to a state in A 24 | -- for each set Y in P for which X ∩ Y is nonempty do 25 | -- replace Y in P by the two sets X ∩ Y and Y \ X 26 | -- if Y is in Q 27 | -- replace Y in Q by the same two sets 28 | -- else 29 | -- add the smaller of the two sets to Q 30 | -- end; 31 | -- end; 32 | -- end; 33 | 34 | minimizeDFA :: Ord a => DFA Int a -> DFA Int a 35 | minimizeDFA dfa@DFA { dfa_start_states = starts, 36 | dfa_states = statemap 37 | } 38 | = DFA { dfa_start_states = starts, 39 | dfa_states = Map.fromList states } 40 | where 41 | equiv_classes = groupEquivStates dfa 42 | 43 | numbered_states = number (length starts) equiv_classes 44 | 45 | -- assign each state in the minimized DFA a number, making 46 | -- sure that we assign the numbers [0..] to the start states. 47 | number _ [] = [] 48 | number n (ss:sss) = 49 | case filter (`IS.member` ss) starts of 50 | [] -> (n,ss) : number (n+1) sss 51 | starts' -> zip starts' (repeat ss) ++ number n sss 52 | -- if one of the states of the minimized DFA corresponds 53 | -- to multiple starts states, we just have to duplicate 54 | -- that state. 55 | 56 | states = [ 57 | let old_states = map (lookup statemap) (IS.toList equiv) 58 | accs = map fix_acc (state_acc (head old_states)) 59 | -- accepts should all be the same 60 | out = IM.fromList [ (b, get_new old) 61 | | State _ out <- old_states, 62 | (b,old) <- IM.toList out ] 63 | in (n, State accs out) 64 | | (n, equiv) <- numbered_states 65 | ] 66 | 67 | fix_acc acc = acc { accRightCtx = fix_rctxt (accRightCtx acc) } 68 | 69 | fix_rctxt (RightContextRExp s) = RightContextRExp (get_new s) 70 | fix_rctxt other = other 71 | 72 | lookup m k = Map.findWithDefault (error "minimizeDFA") k m 73 | get_new = lookup old_to_new 74 | 75 | old_to_new :: Map Int Int 76 | old_to_new = Map.fromList [ (s,n) | (n,ss) <- numbered_states, 77 | s <- IS.toList ss ] 78 | 79 | 80 | groupEquivStates :: (Ord a) => DFA Int a -> [IntSet] 81 | groupEquivStates DFA { dfa_states = statemap } 82 | = go init_p init_q 83 | where 84 | (accepting, nonaccepting) = Map.partition acc statemap 85 | where acc (State as _) = not (List.null as) 86 | 87 | nonaccepting_states = IS.fromList (Map.keys nonaccepting) 88 | 89 | -- group the accepting states into equivalence classes 90 | accept_map = {-# SCC "accept_map" #-} 91 | foldl' (\m (n,s) -> Map.insertWith (++) (state_acc s) [n] m) 92 | Map.empty 93 | (Map.toList accepting) 94 | 95 | -- accept_groups :: Ord s => [Set s] 96 | accept_groups = map IS.fromList (Map.elems accept_map) 97 | 98 | init_p = nonaccepting_states : accept_groups 99 | init_q = accept_groups 100 | 101 | -- map token T to 102 | -- a map from state S to the list of states that transition to 103 | -- S on token T 104 | -- This is a cache of the information needed to compute x below 105 | bigmap :: IntMap (IntMap [SNum]) 106 | bigmap = IM.fromListWith (IM.unionWith (++)) 107 | [ (i, IM.singleton to [from]) 108 | | (from, state) <- Map.toList statemap, 109 | (i,to) <- IM.toList (state_out state) ] 110 | 111 | -- incoming I A = the set of states that transition to a state in 112 | -- A on token I. 113 | incoming :: Int -> IntSet -> IntSet 114 | incoming i a = IS.fromList (concat ss) 115 | where 116 | map1 = IM.findWithDefault IM.empty i bigmap 117 | ss = [ IM.findWithDefault [] s map1 118 | | s <- IS.toList a ] 119 | 120 | -- The outer loop: recurse on each set in Q 121 | go p [] = p 122 | go p (a:q) = go1 0 p q 123 | where 124 | -- recurse on each token (0..255) 125 | go1 256 p q = go p q 126 | go1 i p q = go1 (i+1) p' q' 127 | where 128 | (p',q') = go2 p [] q 129 | 130 | x = incoming i a 131 | 132 | -- recurse on each set in P 133 | go2 [] p' q = (p',q) 134 | go2 (y:p) p' q 135 | | IS.null i || IS.null d = go2 p (y:p') q 136 | | otherwise = go2 p (i:d:p') q1 137 | where 138 | i = IS.intersection x y 139 | d = IS.difference y x 140 | 141 | q1 = replaceyin q 142 | where 143 | replaceyin [] = 144 | if IS.size i < IS.size d then [i] else [d] 145 | replaceyin (z:zs) 146 | | z == y = i : d : zs 147 | | otherwise = z : replaceyin zs 148 | 149 | 150 | 151 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/src/DFS.hs: -------------------------------------------------------------------------------- 1 | {------------------------------------------------------------------------------ 2 | DFS 3 | 4 | This module is a portable version of the ghc-specific `DFS.g.hs', which is 5 | itself a straightforward encoding of the Launchbury/King paper on linear graph 6 | algorithms. This module uses balanced binary trees instead of mutable arrays 7 | to implement the depth-first search so the complexity of the algorithms is 8 | n.log(n) instead of linear. 9 | 10 | The vertices of the graphs manipulated by these modules are labelled with the 11 | integers from 0 to n-1 where n is the number of vertices in the graph. 12 | 13 | The module's principle products are `mk_graph' for constructing a graph from an 14 | edge list, `t_close' for taking the transitive closure of a graph and `scc' 15 | for generating a list of strongly connected components; the components are 16 | listed in dependency order and each component takes the form of a `dfs tree' 17 | (see Launchberry and King). Thus if each edge (fid,fid') encodes the fact that 18 | function `fid' references function `fid'' in a program then `scc' performs a 19 | dependency analysis. 20 | 21 | Chris Dornan, 23-Jun-94, 2-Jul-96, 29-Aug-96, 29-Sep-97 22 | ------------------------------------------------------------------------------} 23 | 24 | module DFS where 25 | 26 | import Set ( Set ) 27 | import qualified Set hiding ( Set ) 28 | 29 | import Data.Array ( (!), accumArray, listArray ) 30 | 31 | -- The result of a depth-first search of a graph is a list of trees, 32 | -- `GForrest'. `post_order' provides a post-order traversal of a forrest. 33 | 34 | type GForrest = [GTree] 35 | data GTree = GNode Int GForrest 36 | 37 | postorder:: GForrest -> [Int] 38 | postorder ts = po ts [] 39 | where 40 | po ts' l = foldr po_tree l ts' 41 | 42 | po_tree (GNode a ts') l = po ts' (a:l) 43 | 44 | list_tree:: GTree -> [Int] 45 | list_tree t = l_t t [] 46 | where 47 | l_t (GNode x ts) l = foldr l_t (x:l) ts 48 | 49 | 50 | -- Graphs are represented by a pair of an integer, giving the number of nodes 51 | -- in the graph, and function mapping each vertex (0..n-1, n=size of graph) to 52 | -- its neighbouring nodes. `mk_graph' takes a size and an edge list and 53 | -- constructs a graph. 54 | 55 | type Graph = (Int,Int->[Int]) 56 | type Edge = (Int,Int) 57 | 58 | mk_graph:: Int -> [Edge] -> Graph 59 | mk_graph sz es = (sz,\v->ar!v) 60 | where 61 | ar = accumArray (flip (:)) [] (0,sz-1) [(v,v')| (v,v')<-es] 62 | 63 | vertices:: Graph -> [Int] 64 | vertices (sz,_) = [0..sz-1] 65 | 66 | out:: Graph -> Int -> [Int] 67 | out (_,f) = f 68 | 69 | edges:: Graph -> [Edge] 70 | edges g = [(v,v')| v<-vertices g, v'<-out g v] 71 | 72 | rev_edges:: Graph -> [Edge] 73 | rev_edges g = [(v',v)| v<-vertices g, v'<-out g v] 74 | 75 | reverse_graph:: Graph -> Graph 76 | reverse_graph g@(sz,_) = mk_graph sz (rev_edges g) 77 | 78 | 79 | -- `t_close' takes the transitive closure of a graph; `scc' returns the stronly 80 | -- connected components of the graph and `top_sort' topologically sorts the 81 | -- graph. Note that the array is given one more element in order to avoid 82 | -- problems with empty arrays. 83 | 84 | t_close:: Graph -> Graph 85 | t_close g@(sz,_) = (sz,\v->ar!v) 86 | where 87 | ar = listArray (0,sz) ([postorder(dff' [v] g)| v<-vertices g]++[und]) 88 | und = error "t_close" 89 | 90 | scc:: Graph -> GForrest 91 | scc g = dff' (reverse (top_sort (reverse_graph g))) g 92 | 93 | top_sort:: Graph -> [Int] 94 | top_sort = postorder . dff 95 | 96 | 97 | -- `dff' computes the depth-first forrest. It works by unrolling the 98 | -- potentially infinite tree from each of the vertices with `generate_g' and 99 | -- then pruning out the duplicates. 100 | 101 | dff:: Graph -> GForrest 102 | dff g = dff' (vertices g) g 103 | 104 | dff':: [Int] -> Graph -> GForrest 105 | dff' vs (_bs, f) = prune (map (generate_g f) vs) 106 | 107 | generate_g:: (Int->[Int]) -> Int -> GTree 108 | generate_g f v = GNode v (map (generate_g f) (f v)) 109 | 110 | prune:: GForrest -> GForrest 111 | prune ts = snd(chop(empty_int,ts)) 112 | where 113 | empty_int:: Set Int 114 | empty_int = Set.empty 115 | 116 | chop:: (Set Int,GForrest) -> (Set Int,GForrest) 117 | chop p@(_, []) = p 118 | chop (vstd,GNode v ts:us) = 119 | if v `Set.member` vstd 120 | then chop (vstd,us) 121 | else let vstd1 = Set.insert v vstd 122 | (vstd2,ts') = chop (vstd1,ts) 123 | (vstd3,us') = chop (vstd2,us) 124 | in 125 | (vstd3,GNode v ts' : us') 126 | 127 | 128 | {-- Some simple test functions 129 | 130 | test:: Graph Char 131 | test = mk_graph (char_bds ('a','h')) (mk_pairs "eefggfgegdhfhged") 132 | where 133 | mk_pairs [] = [] 134 | mk_pairs (a:b:l) = (a,b):mk_pairs l 135 | 136 | -} 137 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/src/Data/Ranged.hs: -------------------------------------------------------------------------------- 1 | module Data.Ranged ( 2 | module Data.Ranged.Boundaries, 3 | module Data.Ranged.Ranges, 4 | module Data.Ranged.RangedSet 5 | ) where 6 | 7 | import Data.Ranged.Boundaries 8 | import Data.Ranged.Ranges 9 | import Data.Ranged.RangedSet 10 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/src/Info.hs: -------------------------------------------------------------------------------- 1 | -- ----------------------------------------------------------------------------- 2 | -- 3 | -- Info.hs, part of Alex 4 | -- 5 | -- (c) Simon Marlow 2003 6 | -- 7 | -- Generate a human-readable rendition of the state machine. 8 | -- 9 | -- ----------------------------------------------------------------------------} 10 | 11 | module Info (infoDFA) where 12 | 13 | import AbsSyn 14 | import qualified Map 15 | import qualified Data.IntMap as IntMap 16 | import Util 17 | 18 | -- ----------------------------------------------------------------------------- 19 | -- Generate a human readable dump of the state machine 20 | 21 | infoDFA :: Int -> String -> DFA SNum Code -> ShowS 22 | infoDFA _ func_nm dfa 23 | = str "Scanner : " . str func_nm . nl 24 | . str "States : " . shows (length dfa_list) . nl 25 | . nl . infoDFA' 26 | where 27 | dfa_list = Map.toAscList (dfa_states dfa) 28 | 29 | infoDFA' = interleave_shows nl (map infoStateN dfa_list) 30 | 31 | infoStateN (i,s) = str "State " . shows i . nl . infoState s 32 | 33 | infoState :: State SNum Code -> ShowS 34 | infoState (State accs out) 35 | = foldr (.) id (map infoAccept accs) 36 | . infoArr out . nl 37 | 38 | infoArr out 39 | = char '\t' . interleave_shows (str "\n\t") 40 | (map infoTransition (IntMap.toAscList out)) 41 | 42 | infoAccept (Acc p act lctx rctx) 43 | = str "\tAccept" . paren (shows p) . space 44 | . outputLCtx lctx . space 45 | . showRCtx rctx 46 | . (case act of 47 | Nothing -> id 48 | Just code -> str " { " . str code . str " }") 49 | . nl 50 | 51 | infoTransition (char',state) 52 | = str (ljustify 8 (show char')) 53 | . str " -> " 54 | . shows state 55 | 56 | outputLCtx Nothing 57 | = id 58 | outputLCtx (Just set) 59 | = paren (show set ++) . char '^' 60 | 61 | -- outputArr arr 62 | -- = str "Array.array " . shows (bounds arr) . space 63 | -- . shows (assocs arr) 64 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/src/Map.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Map ( 3 | Map, 4 | member, lookup, findWithDefault, 5 | empty, 6 | insert, insertWith, 7 | delete, 8 | union, unionWith, unions, 9 | mapWithKey, 10 | elems, 11 | fromList, fromListWith, 12 | toAscList 13 | ) where 14 | 15 | #if __GLASGOW_HASKELL__ >= 603 16 | import Data.Map 17 | import Prelude () 18 | #else 19 | import Data.FiniteMap 20 | import Prelude hiding ( lookup ) 21 | 22 | type Map k a = FiniteMap k a 23 | 24 | member :: Ord k => k -> Map k a -> Bool 25 | member = elemFM 26 | 27 | lookup :: Ord k => k -> Map k a -> Maybe a 28 | lookup = flip lookupFM 29 | 30 | findWithDefault :: Ord k => a -> k -> Map k a -> a 31 | findWithDefault a k m = lookupWithDefaultFM m a k 32 | 33 | empty :: Map k a 34 | empty = emptyFM 35 | 36 | insert :: Ord k => k -> a -> Map k a -> Map k a 37 | insert k a m = addToFM m k a 38 | 39 | insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a 40 | insertWith c k a m = addToFM_C c m k a 41 | 42 | delete :: Ord k => k -> Map k a -> Map k a 43 | delete = flip delFromFM 44 | 45 | union :: Ord k => Map k a -> Map k a -> Map k a 46 | union = flip plusFM 47 | 48 | unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a 49 | unionWith c l r = plusFM_C c r l 50 | 51 | unions :: Ord k => [Map k a] -> Map k a 52 | unions = foldl (flip plusFM) emptyFM 53 | 54 | mapWithKey :: (k -> a -> b) -> Map k a -> Map k b 55 | mapWithKey = mapFM 56 | 57 | elems :: Map k a -> [a] 58 | elems = eltsFM 59 | 60 | fromList :: Ord k => [(k,a)] -> Map k a 61 | fromList = listToFM 62 | 63 | fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a 64 | fromListWith c = addListToFM_C (flip c) emptyFM 65 | 66 | toAscList :: Map k a -> [(k,a)] 67 | toAscList = fmToList 68 | #endif 69 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/src/ParseMonad.hs: -------------------------------------------------------------------------------- 1 | -- ----------------------------------------------------------------------------- 2 | -- 3 | -- ParseMonad.hs, part of Alex 4 | -- 5 | -- (c) Simon Marlow 2003 6 | -- 7 | -- ----------------------------------------------------------------------------} 8 | 9 | module ParseMonad ( 10 | AlexInput, alexInputPrevChar, alexGetChar, alexGetByte, 11 | AlexPosn(..), alexStartPos, 12 | 13 | P, runP, StartCode, failP, lookupSMac, lookupRMac, newSMac, newRMac, 14 | setStartCode, getStartCode, getInput, setInput, 15 | ) where 16 | 17 | import AbsSyn hiding ( StartCode ) 18 | import CharSet ( CharSet ) 19 | import Map ( Map ) 20 | import qualified Map hiding ( Map ) 21 | import UTF8 22 | 23 | #if __GLASGOW_HASKELL__ < 710 24 | import Control.Applicative ( Applicative(..) ) 25 | #endif 26 | import Control.Monad ( liftM, ap ) 27 | import Data.Word (Word8) 28 | -- ----------------------------------------------------------------------------- 29 | -- The input type 30 | --import Codec.Binary.UTF8.Light as UTF8 31 | 32 | type Byte = Word8 33 | 34 | type AlexInput = (AlexPosn, -- current position, 35 | Char, -- previous char 36 | [Byte], 37 | String) -- current input string 38 | 39 | alexInputPrevChar :: AlexInput -> Char 40 | alexInputPrevChar (_,c,_,_) = c 41 | 42 | 43 | alexGetChar :: AlexInput -> Maybe (Char,AlexInput) 44 | alexGetChar (_,_,[],[]) = Nothing 45 | alexGetChar (p,_,[],(c:s)) = let p' = alexMove p c in p' `seq` 46 | Just (c, (p', c, [], s)) 47 | alexGetChar (_, _ ,_ : _, _) = undefined -- hide compiler warning 48 | 49 | alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) 50 | alexGetByte (p,c,(b:bs),s) = Just (b,(p,c,bs,s)) 51 | alexGetByte (_,_,[],[]) = Nothing 52 | alexGetByte (p,_,[],(c:s)) = let p' = alexMove p c 53 | (b:bs) = UTF8.encode c 54 | in p' `seq` Just (b, (p', c, bs, s)) 55 | 56 | -- ----------------------------------------------------------------------------- 57 | -- Token positions 58 | 59 | -- `Posn' records the location of a token in the input text. It has three 60 | -- fields: the address (number of chacaters preceding the token), line number 61 | -- and column of a token within the file. `start_pos' gives the position of the 62 | -- start of the file and `eof_pos' a standard encoding for the end of file. 63 | -- `move_pos' calculates the new position after traversing a given character, 64 | -- assuming the usual eight character tab stops. 65 | 66 | data AlexPosn = AlexPn !Int !Int !Int 67 | deriving (Eq,Show) 68 | 69 | alexStartPos :: AlexPosn 70 | alexStartPos = AlexPn 0 1 1 71 | 72 | alexMove :: AlexPosn -> Char -> AlexPosn 73 | alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+7) `div` 8)*8+1) 74 | alexMove (AlexPn a l _) '\n' = AlexPn (a+1) (l+1) 1 75 | alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) 76 | 77 | -- ----------------------------------------------------------------------------- 78 | -- Alex lexing/parsing monad 79 | 80 | type ParseError = (Maybe AlexPosn, String) 81 | type StartCode = Int 82 | 83 | data PState = PState { 84 | smac_env :: Map String CharSet, 85 | rmac_env :: Map String RExp, 86 | startcode :: Int, 87 | input :: AlexInput 88 | } 89 | 90 | newtype P a = P { unP :: PState -> Either ParseError (PState,a) } 91 | 92 | instance Functor P where 93 | fmap = liftM 94 | 95 | instance Applicative P where 96 | pure a = P $ \env -> Right (env,a) 97 | (<*>) = ap 98 | 99 | instance Monad P where 100 | (P m) >>= k = P $ \env -> case m env of 101 | Left err -> Left err 102 | Right (env',ok) -> unP (k ok) env' 103 | return = pure 104 | 105 | runP :: String -> (Map String CharSet, Map String RExp) 106 | -> P a -> Either ParseError a 107 | runP str (senv,renv) (P p) 108 | = case p initial_state of 109 | Left err -> Left err 110 | Right (_,a) -> Right a 111 | where initial_state = 112 | PState{ smac_env=senv, rmac_env=renv, 113 | startcode = 0, input=(alexStartPos,'\n',[],str) } 114 | 115 | failP :: String -> P a 116 | failP str = P $ \PState{ input = (p,_,_,_) } -> Left (Just p,str) 117 | 118 | -- Macros are expanded during parsing, to simplify the abstract 119 | -- syntax. The parsing monad passes around two environments mapping 120 | -- macro names to sets and regexps respectively. 121 | 122 | lookupSMac :: (AlexPosn,String) -> P CharSet 123 | lookupSMac (posn,smac) 124 | = P $ \s@PState{ smac_env = senv } -> 125 | case Map.lookup smac senv of 126 | Just ok -> Right (s,ok) 127 | Nothing -> Left (Just posn, "unknown set macro: $" ++ smac) 128 | 129 | lookupRMac :: String -> P RExp 130 | lookupRMac rmac 131 | = P $ \s@PState{ rmac_env = renv } -> 132 | case Map.lookup rmac renv of 133 | Just ok -> Right (s,ok) 134 | Nothing -> Left (Nothing, "unknown regex macro: %" ++ rmac) 135 | 136 | newSMac :: String -> CharSet -> P () 137 | newSMac smac set 138 | = P $ \s -> Right (s{smac_env = Map.insert smac set (smac_env s)}, ()) 139 | 140 | newRMac :: String -> RExp -> P () 141 | newRMac rmac rexp 142 | = P $ \s -> Right (s{rmac_env = Map.insert rmac rexp (rmac_env s)}, ()) 143 | 144 | setStartCode :: StartCode -> P () 145 | setStartCode sc = P $ \s -> Right (s{ startcode = sc }, ()) 146 | 147 | getStartCode :: P StartCode 148 | getStartCode = P $ \s -> Right (s, startcode s) 149 | 150 | getInput :: P AlexInput 151 | getInput = P $ \s -> Right (s, input s) 152 | 153 | setInput :: AlexInput -> P () 154 | setInput inp = P $ \s -> Right (s{ input = inp }, ()) 155 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/src/Set.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Set ( Set, member, empty, insert ) where 3 | 4 | import Data.Set 5 | 6 | #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603 7 | member :: Ord a => a -> Set a -> Bool 8 | member = elementOf 9 | 10 | empty :: Set a 11 | empty = emptySet 12 | 13 | insert :: Ord a => a -> Set a -> Set a 14 | insert = flip addToSet 15 | #endif 16 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/src/Sort.hs: -------------------------------------------------------------------------------- 1 | {------------------------------------------------------------------------------ 2 | SORTING LISTS 3 | 4 | This module provides properly parameterised insertion and merge sort functions, 5 | complete with associated functions for inserting and merging. `isort' is the 6 | standard lazy version and can be used to the minimum k elements of a list in 7 | linear time. The merge sort is based on a Bob Buckley's (Bob Buckley 8 | 18-AUG-95) coding of Knuth's natural merge sort (see Vol. 2). It seems to be 9 | fast in the average case; it makes use of natural runs in the data becomming 10 | linear on ordered data; and it completes in worst time O(n.log(n)). It is 11 | divinely elegant. 12 | 13 | `nub'' is an n.log(n) version of `nub' and `group_sort' sorts a list into 14 | strictly ascending order, using a combining function in its arguments to 15 | amalgamate duplicates. 16 | 17 | Chris Dornan, 14-Aug-93, 17-Nov-94, 29-Dec-95 18 | ------------------------------------------------------------------------------} 19 | 20 | module Sort where 21 | 22 | -- Hide (<=) so that we don't get name shadowing warnings for it 23 | import Prelude hiding ((<=)) 24 | 25 | -- `isort' is an insertion sort and is here for historical reasons; msort is 26 | -- better in almost every situation. 27 | 28 | isort:: (a->a->Bool) -> [a] -> [a] 29 | isort (<=) = foldr (insrt (<=)) [] 30 | 31 | insrt:: (a->a->Bool) -> a -> [a] -> [a] 32 | insrt _ e [] = [e] 33 | insrt (<=) e l@(h:t) = if e<=h then e:l else h:insrt (<=) e t 34 | 35 | 36 | msort :: (a->a->Bool) -> [a] -> [a] 37 | msort _ [] = [] -- (foldb f []) is undefined 38 | msort (<=) xs = foldb (mrg (<=)) (runs (<=) xs) 39 | 40 | runs :: (a->a->Bool) -> [a] -> [[a]] 41 | runs (<=) xs0 = foldr op [] xs0 42 | where 43 | op z xss@(xs@(x:_):xss') | z<=x = (z:xs):xss' 44 | | otherwise = [z]:xss 45 | op z xss = [z]:xss 46 | 47 | foldb :: (a->a->a) -> [a] -> a 48 | foldb _ [x] = x 49 | foldb f xs0 = foldb f (fold xs0) 50 | where 51 | fold (x1:x2:xs) = f x1 x2 : fold xs 52 | fold xs = xs 53 | 54 | mrg:: (a->a->Bool) -> [a] -> [a] -> [a] 55 | mrg _ [] l = l 56 | mrg _ l@(_:_) [] = l 57 | mrg (<=) l1@(h1:t1) l2@(h2:t2) = 58 | if h1<=h2 59 | then h1:mrg (<=) t1 l2 60 | else h2:mrg (<=) l1 t2 61 | 62 | 63 | nub':: (a->a->Bool) -> [a] -> [a] 64 | nub' (<=) l = group_sort (<=) const l 65 | 66 | 67 | group_sort:: (a->a->Bool) -> (a->[a]->b) -> [a] -> [b] 68 | group_sort le cmb l = s_m (msort le l) 69 | where 70 | s_m [] = [] 71 | s_m (h:t) = cmb h (takeWhile (`le` h) t):s_m (dropWhile (`le` h) t) 72 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/src/UTF8.hs: -------------------------------------------------------------------------------- 1 | module UTF8 where 2 | 3 | import Data.Word 4 | import Data.Bits 5 | import Data.Char 6 | 7 | {- 8 | -- Could also be imported: 9 | 10 | import Codec.Binary.UTF8.Light as UTF8 11 | 12 | encode :: Char -> [Word8] 13 | encode c = head (UTF8.encodeUTF8' [UTF8.c2w c]) 14 | 15 | -} 16 | 17 | -- | Encode a Haskell String to a list of Word8 values, in UTF8 format. 18 | encode :: Char -> [Word8] 19 | encode = map fromIntegral . go . ord 20 | where 21 | go oc 22 | | oc <= 0x7f = [oc] 23 | 24 | | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6) 25 | , 0x80 + oc .&. 0x3f 26 | ] 27 | 28 | | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12) 29 | , 0x80 + ((oc `shiftR` 6) .&. 0x3f) 30 | , 0x80 + oc .&. 0x3f 31 | ] 32 | | otherwise = [ 0xf0 + (oc `shiftR` 18) 33 | , 0x80 + ((oc `shiftR` 12) .&. 0x3f) 34 | , 0x80 + ((oc `shiftR` 6) .&. 0x3f) 35 | , 0x80 + oc .&. 0x3f 36 | ] 37 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/src/Util.hs: -------------------------------------------------------------------------------- 1 | -- ----------------------------------------------------------------------------- 2 | -- 3 | -- Util.hs, part of Alex 4 | -- 5 | -- (c) Simon Marlow 2003 6 | -- 7 | -- General utilities used in various parts of Alex 8 | -- 9 | -- ----------------------------------------------------------------------------} 10 | 11 | module Util 12 | ( str 13 | , char 14 | , nl 15 | , paren 16 | , brack 17 | , interleave_shows 18 | , space 19 | , cjustify 20 | , ljustify 21 | , rjustify 22 | , spaces 23 | , hline 24 | ) where 25 | 26 | -- Pretty-printing utilities 27 | 28 | str :: String -> String -> String 29 | str = showString 30 | 31 | char :: Char -> String -> String 32 | char c = (c :) 33 | 34 | nl :: String -> String 35 | nl = char '\n' 36 | 37 | paren :: (String -> String) -> String -> String 38 | paren s = char '(' . s . char ')' 39 | 40 | brack :: (String -> String) -> String -> String 41 | brack s = char '[' . s . char ']' 42 | 43 | interleave_shows :: (String -> String) -> [String -> String] -> String -> String 44 | interleave_shows _ [] = id 45 | interleave_shows s xs = foldr1 (\a b -> a . s . b) xs 46 | 47 | space :: String -> String 48 | space = char ' ' 49 | 50 | cjustify, ljustify, rjustify :: Int -> String -> String 51 | cjustify n s = spaces halfm ++ s ++ spaces (m - halfm) 52 | where 53 | m = n - length s 54 | halfm = m `div` 2 55 | ljustify n s = s ++ spaces (max 0 (n - length s)) 56 | rjustify n s = spaces (n - length s) ++ s 57 | 58 | spaces :: Int -> String 59 | spaces n = replicate n ' ' 60 | 61 | hline :: String 62 | hline = replicate 77 '-' 63 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/src/ghc_hooks.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | void ErrorHdrHook(chan) 4 | FILE *chan; 5 | {} 6 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/test.hs: -------------------------------------------------------------------------------- 1 | import System.Process (system) 2 | import System.Exit (exitWith) 3 | 4 | main = system "make -k -C tests clean all" >>= exitWith 5 | 6 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/Makefile: -------------------------------------------------------------------------------- 1 | # NOTE: `cabal test` will take care to build the local `alex` 2 | # executable and place it into $PATH for us to pick up. 3 | # 4 | # If it doesn't look like the alex binary in $PATH comes from the 5 | # build tree, then we'll fall back to pointing to 6 | # ../dist/build/alex/alex to support running tests via "runghc 7 | # Setup.hs test". 8 | # 9 | ALEX=$(shell which alex) 10 | ifeq "$(filter $(dir $(shell pwd))%,$(ALEX))" "" 11 | ALEX=../dist/build/alex/alex 12 | endif 13 | 14 | # NOTE: This assumes that a working `ghc` is on $PATH; this may not necessarily be the same GHC used by `cabal` for building `alex`. 15 | HC=ghc 16 | HC_OPTS=-Wall -fwarn-incomplete-uni-patterns -fno-warn-missing-signatures -fno-warn-unused-imports -fno-warn-tabs -Werror 17 | 18 | .PRECIOUS: %.n.hs %.g.hs %.o %.exe %.bin 19 | 20 | ifeq "$(TARGETPLATFORM)" "i386-unknown-mingw32" 21 | HS_PROG_EXT = .exe 22 | else 23 | HS_PROG_EXT = .bin 24 | endif 25 | 26 | TESTS = \ 27 | basic_typeclass.x \ 28 | basic_typeclass_bytestring.x \ 29 | default_typeclass.x \ 30 | gscan_typeclass.x \ 31 | monad_typeclass.x \ 32 | monad_typeclass_bytestring.x \ 33 | monadUserState_typeclass.x \ 34 | monadUserState_typeclass_bytestring.x \ 35 | null.x \ 36 | posn_typeclass.x \ 37 | posn_typeclass_bytestring.x \ 38 | strict_typeclass.x \ 39 | simple.x \ 40 | tokens.x \ 41 | tokens_bytestring.x \ 42 | tokens_bytestring_unicode.x \ 43 | tokens_gscan.x \ 44 | tokens_monad_bytestring.x \ 45 | tokens_monadUserState_bytestring.x \ 46 | tokens_posn.x \ 47 | tokens_posn_bytestring.x \ 48 | tokens_scan_user.x \ 49 | tokens_strict_bytestring.x \ 50 | unicode.x 51 | 52 | # NOTE: `cabal` will set the `alex_datadir` env-var accordingly before invoking the test-suite 53 | #TEST_ALEX_OPTS = --template=../data/ 54 | TEST_ALEX_OPTS= 55 | 56 | %.n.hs : %.x 57 | $(ALEX) $(TEST_ALEX_OPTS) $< -o $@ 58 | 59 | %.g.hs : %.x 60 | $(ALEX) $(TEST_ALEX_OPTS) -g $< -o $@ 61 | 62 | CLEAN_FILES += *.n.hs *.g.hs *.info *.hi *.o *.bin *.exe 63 | 64 | ALL_TEST_HS = $(shell echo $(TESTS) | sed -e 's/\([^\. ]*\)\.\(l\)\{0,1\}x/\1.n.hs \1.g.hs/g') 65 | 66 | ALL_TESTS = $(patsubst %.hs, %.run, $(ALL_TEST_HS)) 67 | 68 | %.run : %$(HS_PROG_EXT) 69 | ./$< 70 | 71 | %$(HS_PROG_EXT) : %.hs 72 | $(HC) $(HC_OPTS) -package array -package bytestring $($*_LD_OPTS) $< -o $@ 73 | 74 | all :: $(ALL_TESTS) 75 | 76 | .PHONY: clean 77 | clean: 78 | rm -f $(CLEAN_FILES) 79 | 80 | # NOTE: The `../dist` path belows don't aren't accurate anymore for recent cabals 81 | interact: 82 | ghci -cpp -i../src -i../dist/build/autogen -i../dist/build/alex/alex-tmp Main -fbreak-on-exception 83 | # -args='--template=.. simple.x -o simple.n.hs' 84 | # :set args --template=.. simple.x -o simple.n.hs 85 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/basic_typeclass.x: -------------------------------------------------------------------------------- 1 | { 2 | 3 | module Main (main) where 4 | import System.Exit 5 | import Prelude hiding (lex) 6 | 7 | } 8 | 9 | %wrapper "basic" 10 | %token "Token s" 11 | %typeclass "Read s" 12 | 13 | tokens :- 14 | 15 | [a-b]+$ { idtoken 0 } 16 | [c-d]+/"." { idtoken 1 } 17 | [e-f]+/{ tokpred } { idtoken 2 } 18 | ^[g-h]+$ { idtoken 3 } 19 | ^[i-j]+/"." { idtoken 4 } 20 | ^[k-l]+/{ tokpred } { idtoken 5 } 21 | [m-n]+$ { idtoken 6 } 22 | [o-p]+/"." { idtoken 7 } 23 | [q-r]+/{ tokpred } { idtoken 8 } 24 | [0-1]^[s-t]+$ { idtoken 9 } 25 | [2-3]^[u-v]+/"." { idtoken 10 } 26 | [4-5]^[w-x]+/{ tokpred } { idtoken 11 } 27 | [y-z]+ { idtoken 12 } 28 | [A-B]+$ ; 29 | [C-D]+/"." ; 30 | [E-F]+/{ tokpred } ; 31 | ^[G-H]+$ ; 32 | ^[I-J]+/"." ; 33 | ^[K-L]+/{ tokpred } ; 34 | [M-N]+$ ; 35 | [O-P]+/"." ; 36 | [Q-R]+/{ tokpred } ; 37 | [0-1]^[S-T]+$ ; 38 | [2-3]^[U-V]+/"." ; 39 | [4-5]^[W-X]+/{ tokpred } ; 40 | [Y-Z]+ ; 41 | \. ; 42 | [ \n\t\r]+ ; 43 | [0-9] ; 44 | 45 | { 46 | 47 | tokpred :: () -> AlexInput -> Int -> AlexInput -> Bool 48 | tokpred _ _ _ _ = True 49 | 50 | idtoken :: Read s => Int -> String -> Token s 51 | idtoken n s = Id n (read ("\"" ++ s ++ "\"")) 52 | 53 | data Token s = Id Int s 54 | deriving (Show, Ord, Eq) 55 | 56 | lex :: Read s => String -> [Token s] 57 | lex = alexScanTokens 58 | 59 | input = "abab\ndddc.fff\ngh\nijji.\nllmnm\noop.rq0tsst\n3uuvu.5xxw" 60 | 61 | tokens = [ Id 0 "abab", Id 1 "dddc", Id 2 "fff", Id 3 "gh", Id 4 "ijji", 62 | Id 5 "ll", Id 6 "mnm", Id 7 "oop", Id 8 "rq", Id 9 "tsst", 63 | Id 10 "uuvu", Id 11 "xxw"] 64 | 65 | main :: IO () 66 | main = 67 | let 68 | result :: [Token String] 69 | result = lex input 70 | in do 71 | if result /= tokens 72 | then exitFailure 73 | else exitWith ExitSuccess 74 | 75 | } 76 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/basic_typeclass_bytestring.x: -------------------------------------------------------------------------------- 1 | { 2 | 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Main (main) where 6 | import System.Exit 7 | import Prelude hiding (lex) 8 | 9 | import Data.ByteString.Lazy.Char8 as Lazy 10 | 11 | } 12 | 13 | %wrapper "basic-bytestring" 14 | %token "Token s" 15 | %typeclass "Read s" 16 | 17 | tokens :- 18 | 19 | [a-b]+$ { idtoken 0 } 20 | [c-d]+/"." { idtoken 1 } 21 | [e-f]+/{ tokpred } { idtoken 2 } 22 | ^[g-h]+$ { idtoken 3 } 23 | ^[i-j]+/"." { idtoken 4 } 24 | ^[k-l]+/{ tokpred } { idtoken 5 } 25 | [m-n]+$ { idtoken 6 } 26 | [o-p]+/"." { idtoken 7 } 27 | [q-r]+/{ tokpred } { idtoken 8 } 28 | [0-1]^[s-t]+$ { idtoken 9 } 29 | [2-3]^[u-v]+/"." { idtoken 10 } 30 | [4-5]^[w-x]+/{ tokpred } { idtoken 11 } 31 | [y-z]+ { idtoken 12 } 32 | [A-B]+$ ; 33 | [C-D]+/"." ; 34 | [E-F]+/{ tokpred } ; 35 | ^[G-H]+$ ; 36 | ^[I-J]+/"." ; 37 | ^[K-L]+/{ tokpred } ; 38 | [M-N]+$ ; 39 | [O-P]+/"." ; 40 | [Q-R]+/{ tokpred } ; 41 | [0-1]^[S-T]+$ ; 42 | [2-3]^[U-V]+/"." ; 43 | [4-5]^[W-X]+/{ tokpred } ; 44 | [Y-Z]+ ; 45 | \. ; 46 | [ \n\t\r]+ ; 47 | [0-9] ; 48 | 49 | { 50 | 51 | tokpred :: () -> AlexInput -> Int -> AlexInput -> Bool 52 | tokpred _ _ _ _ = True 53 | 54 | idtoken :: Read s => Int -> Lazy.ByteString -> Token s 55 | idtoken n s = Id n (read ("\"" ++ (Lazy.unpack s) ++ "\"")) 56 | 57 | data Token s = Id Int s 58 | deriving (Show, Ord, Eq) 59 | 60 | lex :: Read s => Lazy.ByteString -> [Token s] 61 | lex = alexScanTokens 62 | 63 | input = "abab\ndddc.fff\ngh\nijji.\nllmnm\noop.rq0tsst\n3uuvu.5xxw" 64 | 65 | tokens = [ Id 0 "abab", Id 1 "dddc", Id 2 "fff", Id 3 "gh", Id 4 "ijji", 66 | Id 5 "ll", Id 6 "mnm", Id 7 "oop", Id 8 "rq", Id 9 "tsst", 67 | Id 10 "uuvu", Id 11 "xxw"] 68 | 69 | main :: IO () 70 | main = 71 | let 72 | result :: [Token String] 73 | result = lex input 74 | in do 75 | if result /= tokens 76 | then exitFailure 77 | else exitWith ExitSuccess 78 | 79 | } 80 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/gscan_typeclass.x: -------------------------------------------------------------------------------- 1 | { 2 | 3 | module Main (main) where 4 | import System.Exit 5 | import Prelude hiding (lex) 6 | 7 | } 8 | 9 | %wrapper "gscan" 10 | %token "[Token s]" 11 | %typeclass "Read s" 12 | 13 | tokens :- 14 | 15 | [a-b]+$ { idtoken 0 } 16 | [c-d]+/"." { idtoken 1 } 17 | [e-f]+/{ tokpred } { idtoken 2 } 18 | ^[g-h]+$ { idtoken 3 } 19 | ^[i-j]+/"." { idtoken 4 } 20 | ^[k-l]+/{ tokpred } { idtoken 5 } 21 | [m-n]+$ { idtoken 6 } 22 | [o-p]+/"." { idtoken 7 } 23 | [q-r]+/{ tokpred } { idtoken 8 } 24 | [0-1]^[s-t]+$ { idtoken 9 } 25 | [2-3]^[u-v]+/"." { idtoken 10 } 26 | [4-5]^[w-x]+/{ tokpred } { idtoken 11 } 27 | [y-z]+ { idtoken 12 } 28 | [A-B]+$ ; 29 | [C-D]+/"." ; 30 | [E-F]+/{ tokpred } ; 31 | ^[G-H]+$ ; 32 | ^[I-J]+/"." ; 33 | ^[K-L]+/{ tokpred } ; 34 | [M-N]+$ ; 35 | [O-P]+/"." ; 36 | [Q-R]+/{ tokpred } ; 37 | [0-1]^[S-T]+$ ; 38 | [2-3]^[U-V]+/"." ; 39 | [4-5]^[W-X]+/{ tokpred } ; 40 | [Y-Z]+ ; 41 | \. ; 42 | [ \n\t\r]+ ; 43 | [0-9] ; 44 | 45 | { 46 | 47 | tokpred :: () -> AlexInput -> Int -> AlexInput -> Bool 48 | tokpred _ _ _ _ = True 49 | 50 | idtoken :: Read s => Int -> AlexPosn -> Char -> String -> Int -> 51 | ((Int,state) -> [Token s]) -> (Int,state) -> [Token s] 52 | idtoken n _ _ s len cont st = Id n (read ("\"" ++ take len s ++ "\"")) : cont st 53 | 54 | data Token s = Id Int s deriving Eq 55 | 56 | lex :: Read s => String -> [Token s] 57 | lex str = alexGScan (\_ _ _ _ -> []) (0 :: Int) str 58 | 59 | input = "abab\ndddc.fff\ngh\nijji.\nllmnm\noop.rq0tsst\n3uuvu.5xxw" 60 | 61 | tokens = [ Id 0 "abab", Id 1 "dddc", Id 2 "fff", Id 3 "gh", Id 4 "ijji", 62 | Id 5 "ll", Id 6 "mnm", Id 7 "oop", Id 8 "rq", Id 9 "tsst", 63 | Id 10 "uuvu", Id 11 "xxw"] 64 | 65 | main :: IO () 66 | main = 67 | let 68 | result :: [Token String] 69 | result = lex input 70 | in do 71 | if result /= tokens 72 | then exitFailure 73 | else exitWith ExitSuccess 74 | 75 | } 76 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/monadUserState_typeclass.x: -------------------------------------------------------------------------------- 1 | { 2 | 3 | module Main (main) where 4 | import System.Exit 5 | import Prelude hiding (lex) 6 | 7 | } 8 | 9 | %wrapper "monadUserState" 10 | %token "Token s" 11 | %typeclass "Read s" 12 | 13 | tokens :- 14 | 15 | [a-b]+$ { idtoken 0 } 16 | [c-d]+/"." { idtoken 1 } 17 | [e-f]+/{ tokpred } { idtoken 2 } 18 | ^[g-h]+$ { idtoken 3 } 19 | ^[i-j]+/"." { idtoken 4 } 20 | ^[k-l]+/{ tokpred } { idtoken 5 } 21 | [m-n]+$ { idtoken 6 } 22 | [o-p]+/"." { idtoken 7 } 23 | [q-r]+/{ tokpred } { idtoken 8 } 24 | [0-1]^[s-t]+$ { idtoken 9 } 25 | [2-3]^[u-v]+/"." { idtoken 10 } 26 | [4-5]^[w-x]+/{ tokpred } { idtoken 11 } 27 | [y-z]+ { idtoken 12 } 28 | [A-B]+$ ; 29 | [C-D]+/"." ; 30 | [E-F]+/{ tokpred } ; 31 | ^[G-H]+$ ; 32 | ^[I-J]+/"." ; 33 | ^[K-L]+/{ tokpred } ; 34 | [M-N]+$ ; 35 | [O-P]+/"." ; 36 | [Q-R]+/{ tokpred } ; 37 | [0-1]^[S-T]+$ ; 38 | [2-3]^[U-V]+/"." ; 39 | [4-5]^[W-X]+/{ tokpred } ; 40 | [Y-Z]+ ; 41 | \. ; 42 | [ \n\t\r]+ ; 43 | [0-9] ; 44 | 45 | { 46 | 47 | type AlexUserState = Int 48 | 49 | alexInitUserState = 0 50 | 51 | alexEOF :: Alex (Token s) 52 | alexEOF = return EOF 53 | 54 | tokpred :: AlexUserState -> AlexInput -> Int -> AlexInput -> Bool 55 | tokpred _ _ _ _ = True 56 | 57 | idtoken :: Read s => Int -> AlexInput -> Int -> Alex (Token s) 58 | idtoken n (_, _, _, s) len = return (Id n (read ("\"" ++ take len s ++ "\""))) 59 | 60 | data Token s = Id Int s | EOF deriving Eq 61 | 62 | lex :: Read s => String -> Either String [Token s] 63 | lex inp = 64 | let 65 | lexAll = 66 | do 67 | res <- alexMonadScan 68 | case res of 69 | EOF -> return [] 70 | tok -> 71 | do 72 | rest <- lexAll 73 | return (tok : rest) 74 | in 75 | runAlex inp lexAll 76 | 77 | input = "abab\ndddc.fff\ngh\nijji.\nllmnm\noop.rq0tsst\n3uuvu.5xxw" 78 | 79 | tokens = [ Id 0 "abab", Id 1 "dddc", Id 2 "fff", Id 3 "gh", Id 4 "ijji", 80 | Id 5 "ll", Id 6 "mnm", Id 7 "oop", Id 8 "rq", Id 9 "tsst", 81 | Id 10 "uuvu", Id 11 "xxw"] 82 | 83 | main :: IO () 84 | main = 85 | let 86 | result = lex input 87 | in do 88 | case result of 89 | Left _ -> exitFailure 90 | Right toks -> 91 | do 92 | if toks /= tokens 93 | then exitFailure 94 | else exitWith ExitSuccess 95 | 96 | } 97 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/monadUserState_typeclass_bytestring.x: -------------------------------------------------------------------------------- 1 | { 2 | 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Main (main) where 6 | import System.Exit 7 | import Prelude hiding (lex) 8 | 9 | import qualified Data.ByteString.Lazy.Char8 as Lazy 10 | 11 | } 12 | 13 | %wrapper "monadUserState-bytestring" 14 | %token "Token s" 15 | %typeclass "Read s" 16 | 17 | tokens :- 18 | 19 | [a-b]+$ { idtoken 0 } 20 | [c-d]+/"." { idtoken 1 } 21 | [e-f]+/{ tokpred } { idtoken 2 } 22 | ^[g-h]+$ { idtoken 3 } 23 | ^[i-j]+/"." { idtoken 4 } 24 | ^[k-l]+/{ tokpred } { idtoken 5 } 25 | [m-n]+$ { idtoken 6 } 26 | [o-p]+/"." { idtoken 7 } 27 | [q-r]+/{ tokpred } { idtoken 8 } 28 | [0-1]^[s-t]+$ { idtoken 9 } 29 | [2-3]^[u-v]+/"." { idtoken 10 } 30 | [4-5]^[w-x]+/{ tokpred } { idtoken 11 } 31 | [y-z]+ { idtoken 12 } 32 | [A-B]+$ ; 33 | [C-D]+/"." ; 34 | [E-F]+/{ tokpred } ; 35 | ^[G-H]+$ ; 36 | ^[I-J]+/"." ; 37 | ^[K-L]+/{ tokpred } ; 38 | [M-N]+$ ; 39 | [O-P]+/"." ; 40 | [Q-R]+/{ tokpred } ; 41 | [0-1]^[S-T]+$ ; 42 | [2-3]^[U-V]+/"." ; 43 | [4-5]^[W-X]+/{ tokpred } ; 44 | [Y-Z]+ ; 45 | \. ; 46 | [ \n\t\r]+ ; 47 | [0-9] ; 48 | 49 | { 50 | 51 | type AlexUserState = Int 52 | 53 | alexInitUserState = 0 54 | 55 | alexEOF :: Alex (Token s) 56 | alexEOF = return EOF 57 | 58 | tokpred :: AlexUserState -> AlexInput -> Int -> AlexInput -> Bool 59 | tokpred _ _ _ _ = True 60 | 61 | idtoken :: Read s => Int -> AlexInput -> Int64 -> Alex (Token s) 62 | idtoken n (_, _, s, _) len = 63 | return (Id n (read ("\"" ++ Lazy.unpack (Lazy.take (fromIntegral len) s) ++ 64 | "\""))) 65 | 66 | data Token s = Id Int s | EOF deriving Eq 67 | 68 | lex :: Read s => Lazy.ByteString -> Either String [Token s] 69 | lex inp = 70 | let 71 | lexAll = 72 | do 73 | res <- alexMonadScan 74 | case res of 75 | EOF -> return [] 76 | tok -> 77 | do 78 | rest <- lexAll 79 | return (tok : rest) 80 | in 81 | runAlex inp lexAll 82 | 83 | input = "abab\ndddc.fff\ngh\nijji.\nllmnm\noop.rq0tsst\n3uuvu.5xxw" 84 | 85 | tokens = [ Id 0 "abab", Id 1 "dddc", Id 2 "fff", Id 3 "gh", Id 4 "ijji", 86 | Id 5 "ll", Id 6 "mnm", Id 7 "oop", Id 8 "rq", Id 9 "tsst", 87 | Id 10 "uuvu", Id 11 "xxw"] 88 | 89 | main :: IO () 90 | main = 91 | let 92 | result :: Either String [Token String] 93 | result = lex input 94 | in do 95 | case result of 96 | Left _ -> exitFailure 97 | Right toks -> 98 | do 99 | if toks /= tokens 100 | then exitFailure 101 | else exitWith ExitSuccess 102 | 103 | } 104 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/monad_typeclass.x: -------------------------------------------------------------------------------- 1 | { 2 | 3 | module Main (main) where 4 | import System.Exit 5 | import Prelude hiding (lex) 6 | 7 | } 8 | 9 | %wrapper "monad" 10 | %token "Token s" 11 | %typeclass "Read s" 12 | 13 | tokens :- 14 | 15 | [a-b]+$ { idtoken 0 } 16 | [c-d]+/"." { idtoken 1 } 17 | [e-f]+/{ tokpred } { idtoken 2 } 18 | ^[g-h]+$ { idtoken 3 } 19 | ^[i-j]+/"." { idtoken 4 } 20 | ^[k-l]+/{ tokpred } { idtoken 5 } 21 | [m-n]+$ { idtoken 6 } 22 | [o-p]+/"." { idtoken 7 } 23 | [q-r]+/{ tokpred } { idtoken 8 } 24 | [0-1]^[s-t]+$ { idtoken 9 } 25 | [2-3]^[u-v]+/"." { idtoken 10 } 26 | [4-5]^[w-x]+/{ tokpred } { idtoken 11 } 27 | [y-z]+ { idtoken 12 } 28 | [A-B]+$ ; 29 | [C-D]+/"." ; 30 | [E-F]+/{ tokpred } ; 31 | ^[G-H]+$ ; 32 | ^[I-J]+/"." ; 33 | ^[K-L]+/{ tokpred } ; 34 | [M-N]+$ ; 35 | [O-P]+/"." ; 36 | [Q-R]+/{ tokpred } ; 37 | [0-1]^[S-T]+$ ; 38 | [2-3]^[U-V]+/"." ; 39 | [4-5]^[W-X]+/{ tokpred } ; 40 | [Y-Z]+ ; 41 | \. ; 42 | [ \n\t\r]+ ; 43 | [0-9] ; 44 | 45 | { 46 | 47 | alexEOF :: Alex (Token s) 48 | alexEOF = return EOF 49 | 50 | tokpred :: () -> AlexInput -> Int -> AlexInput -> Bool 51 | tokpred _ _ _ _ = True 52 | 53 | idtoken :: Read s => Int -> AlexInput -> Int -> Alex (Token s) 54 | idtoken n (_, _, _, s) len = return (Id n (read ("\"" ++ take len s ++ "\""))) 55 | 56 | data Token s = Id Int s | EOF deriving Eq 57 | 58 | lex :: Read s => String -> Either String [Token s] 59 | lex inp = 60 | let 61 | lexAll = 62 | do 63 | res <- alexMonadScan 64 | case res of 65 | EOF -> return [] 66 | tok -> 67 | do 68 | rest <- lexAll 69 | return (tok : rest) 70 | in 71 | runAlex inp lexAll 72 | 73 | input = "abab\ndddc.fff\ngh\nijji.\nllmnm\noop.rq0tsst\n3uuvu.5xxw" 74 | 75 | tokens = [ Id 0 "abab", Id 1 "dddc", Id 2 "fff", Id 3 "gh", Id 4 "ijji", 76 | Id 5 "ll", Id 6 "mnm", Id 7 "oop", Id 8 "rq", Id 9 "tsst", 77 | Id 10 "uuvu", Id 11 "xxw"] 78 | 79 | main :: IO () 80 | main = 81 | let 82 | result = lex input 83 | in do 84 | case result of 85 | Left _ -> exitFailure 86 | Right toks -> 87 | do 88 | if toks /= tokens 89 | then exitFailure 90 | else exitWith ExitSuccess 91 | 92 | } 93 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/monad_typeclass_bytestring.x: -------------------------------------------------------------------------------- 1 | { 2 | 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Main (main) where 6 | import System.Exit 7 | import Prelude hiding (lex) 8 | 9 | import qualified Data.ByteString.Lazy.Char8 as Lazy 10 | 11 | } 12 | 13 | %wrapper "monad-bytestring" 14 | %token "Token s" 15 | %typeclass "Read s" 16 | 17 | tokens :- 18 | 19 | [a-b]+$ { idtoken 0 } 20 | [c-d]+/"." { idtoken 1 } 21 | [e-f]+/{ tokpred } { idtoken 2 } 22 | ^[g-h]+$ { idtoken 3 } 23 | ^[i-j]+/"." { idtoken 4 } 24 | ^[k-l]+/{ tokpred } { idtoken 5 } 25 | [m-n]+$ { idtoken 6 } 26 | [o-p]+/"." { idtoken 7 } 27 | [q-r]+/{ tokpred } { idtoken 8 } 28 | [0-1]^[s-t]+$ { idtoken 9 } 29 | [2-3]^[u-v]+/"." { idtoken 10 } 30 | [4-5]^[w-x]+/{ tokpred } { idtoken 11 } 31 | [y-z]+ { idtoken 12 } 32 | [A-B]+$ ; 33 | [C-D]+/"." ; 34 | [E-F]+/{ tokpred } ; 35 | ^[G-H]+$ ; 36 | ^[I-J]+/"." ; 37 | ^[K-L]+/{ tokpred } ; 38 | [M-N]+$ ; 39 | [O-P]+/"." ; 40 | [Q-R]+/{ tokpred } ; 41 | [0-1]^[S-T]+$ ; 42 | [2-3]^[U-V]+/"." ; 43 | [4-5]^[W-X]+/{ tokpred } ; 44 | [Y-Z]+ ; 45 | \. ; 46 | [ \n\t\r]+ ; 47 | [0-9] ; 48 | 49 | { 50 | 51 | alexEOF :: Alex (Token s) 52 | alexEOF = return EOF 53 | 54 | tokpred :: () -> AlexInput -> Int -> AlexInput -> Bool 55 | tokpred _ _ _ _ = True 56 | 57 | idtoken :: Read s => Int -> AlexInput -> Int64 -> Alex (Token s) 58 | idtoken n (_, _, s, _) len = 59 | return (Id n (read ("\"" ++ Lazy.unpack (Lazy.take (fromIntegral len) s) ++ 60 | "\""))) 61 | 62 | data Token s = Id Int s | EOF deriving Eq 63 | 64 | lex :: Read s => Lazy.ByteString -> Either String [Token s] 65 | lex inp = 66 | let 67 | lexAll = 68 | do 69 | res <- alexMonadScan 70 | case res of 71 | EOF -> return [] 72 | tok -> 73 | do 74 | rest <- lexAll 75 | return (tok : rest) 76 | in 77 | runAlex inp lexAll 78 | 79 | input = "abab\ndddc.fff\ngh\nijji.\nllmnm\noop.rq0tsst\n3uuvu.5xxw" 80 | 81 | tokens = [ Id 0 "abab", Id 1 "dddc", Id 2 "fff", Id 3 "gh", Id 4 "ijji", 82 | Id 5 "ll", Id 6 "mnm", Id 7 "oop", Id 8 "rq", Id 9 "tsst", 83 | Id 10 "uuvu", Id 11 "xxw"] 84 | 85 | main :: IO () 86 | main = 87 | let 88 | result :: Either String [Token String] 89 | result = lex input 90 | in do 91 | case result of 92 | Left _ -> exitFailure 93 | Right toks -> 94 | do 95 | if toks /= tokens 96 | then exitFailure 97 | else exitWith ExitSuccess 98 | 99 | } 100 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/null.x: -------------------------------------------------------------------------------- 1 | { 2 | -- Tests the basic operation. 3 | module Main where 4 | 5 | import Data.Char (toUpper) 6 | import Control.Monad 7 | import System.Exit 8 | import System.IO 9 | import Prelude hiding (null) 10 | } 11 | 12 | %wrapper "monad" 13 | 14 | @word = [A-Za-z]+ 15 | @null = \0 16 | 17 | $escchars = [abfnrtv\\"\'&] 18 | @escape = \\ ($escchars | \0) 19 | @gap = \\ $white+ \\ 20 | @string = $printable # [\"] | " " | @escape | @gap 21 | 22 | @inComment = ([^\*] | $white)+ | ([\*]+ ([\x00-\xff] # [\/])) 23 | 24 | tokens :- 25 | 26 | $white+ ; 27 | 28 | <0> { 29 | @null { null } 30 | @word { word } 31 | \" @string \" { string } 32 | "--" @inComment \n { word } 33 | } 34 | 35 | { 36 | {- we can now have comments in source code? -} 37 | word (_,_,_,input) len = return (take len input) 38 | 39 | null (_,_,_,_) _ = return "\0" 40 | 41 | string (_,_,_,input) _ = return (drop 1 (reverse (drop 1 (reverse input)))) 42 | 43 | alexEOF = return "stopped." 44 | 45 | scanner str = runAlex str $ do 46 | let loop = do tok <- alexMonadScan 47 | if tok == "stopped." || tok == "error." 48 | then return [tok] 49 | else do toks <- loop 50 | return (tok:toks) 51 | loop 52 | 53 | main = do 54 | let test1 = scanner str1 55 | when (test1 /= out1) $ 56 | do hPutStrLn stderr "Test 1 failed:" 57 | print test1 58 | exitFailure 59 | 60 | let test2 = scanner str2 61 | when (test2 /= out2) $ 62 | do hPutStrLn stderr "Test 2 failed:" 63 | print test2 64 | exitFailure 65 | 66 | str1 = "a\0bb\0ccc\0\0\"\\\0\"" 67 | out1 = Right ["a","\NUL","bb","\NUL","ccc","\NUL","\NUL","\\\NUL", "stopped."] 68 | 69 | str2 = "." 70 | out2 = Left "lexical error at line 1, column 1" 71 | } 72 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/posn_typeclass.x: -------------------------------------------------------------------------------- 1 | { 2 | 3 | module Main (main) where 4 | import System.Exit 5 | import Prelude hiding (lex) 6 | 7 | } 8 | 9 | %wrapper "posn" 10 | %token "Token s" 11 | %typeclass "Read s" 12 | 13 | tokens :- 14 | 15 | [a-b]+$ { idtoken 0 } 16 | [c-d]+/"." { idtoken 1 } 17 | [e-f]+/{ tokpred } { idtoken 2 } 18 | ^[g-h]+$ { idtoken 3 } 19 | ^[i-j]+/"." { idtoken 4 } 20 | ^[k-l]+/{ tokpred } { idtoken 5 } 21 | [m-n]+$ { idtoken 6 } 22 | [o-p]+/"." { idtoken 7 } 23 | [q-r]+/{ tokpred } { idtoken 8 } 24 | [0-1]^[s-t]+$ { idtoken 9 } 25 | [2-3]^[u-v]+/"." { idtoken 10 } 26 | [4-5]^[w-x]+/{ tokpred } { idtoken 11 } 27 | [y-z]+ { idtoken 12 } 28 | [A-B]+$ ; 29 | [C-D]+/"." ; 30 | [E-F]+/{ tokpred } ; 31 | ^[G-H]+$ ; 32 | ^[I-J]+/"." ; 33 | ^[K-L]+/{ tokpred } ; 34 | [M-N]+$ ; 35 | [O-P]+/"." ; 36 | [Q-R]+/{ tokpred } ; 37 | [0-1]^[S-T]+$ ; 38 | [2-3]^[U-V]+/"." ; 39 | [4-5]^[W-X]+/{ tokpred } ; 40 | [Y-Z]+ ; 41 | \. ; 42 | [ \n\t\r]+ ; 43 | [0-9] ; 44 | 45 | { 46 | 47 | tokpred :: () -> AlexInput -> Int -> AlexInput -> Bool 48 | tokpred _ _ _ _ = True 49 | 50 | idtoken :: Read s => Int -> AlexPosn -> String -> Token s 51 | idtoken n _ s = Id n (read ("\"" ++ s ++ "\"")) 52 | 53 | data Token s = Id Int s 54 | deriving (Show, Ord, Eq) 55 | 56 | lex :: Read s => String -> [Token s] 57 | lex = alexScanTokens 58 | 59 | input = "abab\ndddc.fff\ngh\nijji.\nllmnm\noop.rq0tsst\n3uuvu.5xxw" 60 | 61 | tokens = [ Id 0 "abab", Id 1 "dddc", Id 2 "fff", Id 3 "gh", Id 4 "ijji", 62 | Id 5 "ll", Id 6 "mnm", Id 7 "oop", Id 8 "rq", Id 9 "tsst", 63 | Id 10 "uuvu", Id 11 "xxw"] 64 | 65 | main :: IO () 66 | main = 67 | let 68 | result :: [Token String] 69 | result = lex input 70 | in do 71 | if result /= tokens 72 | then exitFailure 73 | else exitWith ExitSuccess 74 | 75 | } 76 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/posn_typeclass_bytestring.x: -------------------------------------------------------------------------------- 1 | { 2 | 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Main (main) where 6 | import System.Exit 7 | import Prelude hiding (lex) 8 | 9 | import Data.ByteString.Lazy.Char8 as Lazy 10 | 11 | } 12 | 13 | %wrapper "posn-bytestring" 14 | %token "Token s" 15 | %typeclass "Read s" 16 | 17 | tokens :- 18 | 19 | [a-b]+$ { idtoken 0 } 20 | [c-d]+/"." { idtoken 1 } 21 | [e-f]+/{ tokpred } { idtoken 2 } 22 | ^[g-h]+$ { idtoken 3 } 23 | ^[i-j]+/"." { idtoken 4 } 24 | ^[k-l]+/{ tokpred } { idtoken 5 } 25 | [m-n]+$ { idtoken 6 } 26 | [o-p]+/"." { idtoken 7 } 27 | [q-r]+/{ tokpred } { idtoken 8 } 28 | [0-1]^[s-t]+$ { idtoken 9 } 29 | [2-3]^[u-v]+/"." { idtoken 10 } 30 | [4-5]^[w-x]+/{ tokpred } { idtoken 11 } 31 | [y-z]+ { idtoken 12 } 32 | [A-B]+$ ; 33 | [C-D]+/"." ; 34 | [E-F]+/{ tokpred } ; 35 | ^[G-H]+$ ; 36 | ^[I-J]+/"." ; 37 | ^[K-L]+/{ tokpred } ; 38 | [M-N]+$ ; 39 | [O-P]+/"." ; 40 | [Q-R]+/{ tokpred } ; 41 | [0-1]^[S-T]+$ ; 42 | [2-3]^[U-V]+/"." ; 43 | [4-5]^[W-X]+/{ tokpred } ; 44 | [Y-Z]+ ; 45 | \. ; 46 | [ \n\t\r]+ ; 47 | [0-9] ; 48 | 49 | { 50 | 51 | tokpred :: () -> AlexInput -> Int -> AlexInput -> Bool 52 | tokpred _ _ _ _ = True 53 | 54 | idtoken :: Read s => Int -> AlexPosn -> Lazy.ByteString -> Token s 55 | idtoken n _ s = Id n (read ("\"" ++ (Lazy.unpack s) ++ "\"")) 56 | 57 | data Token s = Id Int s 58 | deriving (Show, Ord, Eq) 59 | 60 | lex :: Read s => Lazy.ByteString -> [Token s] 61 | lex = alexScanTokens 62 | 63 | input = "abab\ndddc.fff\ngh\nijji.\nllmnm\noop.rq0tsst\n3uuvu.5xxw" 64 | 65 | tokens = [ Id 0 "abab", Id 1 "dddc", Id 2 "fff", Id 3 "gh", Id 4 "ijji", 66 | Id 5 "ll", Id 6 "mnm", Id 7 "oop", Id 8 "rq", Id 9 "tsst", 67 | Id 10 "uuvu", Id 11 "xxw"] 68 | 69 | main :: IO () 70 | main = 71 | let 72 | result :: [Token String] 73 | result = lex input 74 | in do 75 | if result /= tokens 76 | then exitFailure 77 | else exitWith ExitSuccess 78 | 79 | } 80 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/simple.x: -------------------------------------------------------------------------------- 1 | { 2 | -- Tests the basic operation. 3 | module Main where 4 | 5 | import Data.Char (toUpper) 6 | import Control.Monad 7 | import System.Exit 8 | import System.IO 9 | } 10 | 11 | %wrapper "monad" 12 | 13 | @word = [A-Za-z]+ 14 | 15 | tokens :- 16 | 17 | $white+ ; 18 | 19 | <0> { 20 | "magic" { magic } -- should override later patterns 21 | ^ @word $ { both } -- test both trailing and left context 22 | @word $ { eol } -- test trailing context 23 | ^ @word { bol } -- test left context 24 | @word { word } 25 | } 26 | 27 | <0> \( { begin parens } 28 | [A-Za-z]+ { parenword } 29 | \) { begin 0 } 30 | 31 | { 32 | {- we can now have comments in source code? -} 33 | word (_,_,_,input) len = return (take len input) 34 | 35 | both (_,_,_,input) len = return ("BOTH:"++ take len input) 36 | 37 | eol (_,_,_,input) len = return ("EOL:"++ take len input) 38 | 39 | bol (_,_,_,input) len = return ("BOL:"++ take len input) 40 | 41 | parenword (_,_,_,input) len = return (map toUpper (take len input)) 42 | 43 | magic (_,_,_,_) _ = return "PING!" 44 | 45 | alexEOF = return "stopped." 46 | 47 | scanner str = runAlex str $ do 48 | let loop = do tok <- alexMonadScan 49 | if tok == "stopped." || tok == "error." 50 | then return [tok] 51 | else do toks <- loop 52 | return (tok:toks) 53 | loop 54 | 55 | main = do 56 | let test1 = scanner str1 57 | when (test1 /= out1) $ 58 | do hPutStrLn stderr "Test 1 failed:" 59 | print test1 60 | exitFailure 61 | 62 | let test2 = scanner str2 63 | when (test2 /= out2) $ 64 | do hPutStrLn stderr "Test 2 failed:" 65 | print test2 66 | exitFailure 67 | 68 | str1 = "a b c (d e f) magic (magic) eol\nbol \nboth\n" 69 | out1 = Right ["BOL:a","b","c","D","E","F","PING!","MAGIC","EOL:eol", "BOL:bol", "BOTH:both", "stopped."] 70 | 71 | str2 = "." 72 | out2 = Left "lexical error at line 1, column 1" 73 | } 74 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/strict_typeclass.x: -------------------------------------------------------------------------------- 1 | { 2 | 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Main (main) where 6 | import System.Exit 7 | import Prelude hiding (lex) 8 | 9 | import Data.ByteString.Char8 as Strict 10 | 11 | } 12 | 13 | %wrapper "strict-bytestring" 14 | %token "Token s" 15 | %typeclass "Read s" 16 | 17 | tokens :- 18 | 19 | [a-b]+$ { idtoken 0 } 20 | [c-d]+/"." { idtoken 1 } 21 | [e-f]+/{ tokpred } { idtoken 2 } 22 | ^[g-h]+$ { idtoken 3 } 23 | ^[i-j]+/"." { idtoken 4 } 24 | ^[k-l]+/{ tokpred } { idtoken 5 } 25 | [m-n]+$ { idtoken 6 } 26 | [o-p]+/"." { idtoken 7 } 27 | [q-r]+/{ tokpred } { idtoken 8 } 28 | [0-1]^[s-t]+$ { idtoken 9 } 29 | [2-3]^[u-v]+/"." { idtoken 10 } 30 | [4-5]^[w-x]+/{ tokpred } { idtoken 11 } 31 | [y-z]+ { idtoken 12 } 32 | [A-B]+$ ; 33 | [C-D]+/"." ; 34 | [E-F]+/{ tokpred } ; 35 | ^[G-H]+$ ; 36 | ^[I-J]+/"." ; 37 | ^[K-L]+/{ tokpred } ; 38 | [M-N]+$ ; 39 | [O-P]+/"." ; 40 | [Q-R]+/{ tokpred } ; 41 | [0-1]^[S-T]+$ ; 42 | [2-3]^[U-V]+/"." ; 43 | [4-5]^[W-X]+/{ tokpred } ; 44 | [Y-Z]+ ; 45 | \. ; 46 | [ \n\t\r]+ ; 47 | [0-9] ; 48 | 49 | { 50 | 51 | tokpred :: () -> AlexInput -> Int -> AlexInput -> Bool 52 | tokpred _ _ _ _ = True 53 | 54 | idtoken :: Read s => Int -> Strict.ByteString -> Token s 55 | idtoken n s = Id n (read ("\"" ++ (Strict.unpack s) ++ "\"")) 56 | 57 | data Token s = Id Int s deriving Eq 58 | 59 | lex :: Read s => Strict.ByteString -> [Token s] 60 | lex = alexScanTokens 61 | 62 | input = "abab\ndddc.fff\ngh\nijji.\nllmnm\noop.rq0tsst\n3uuvu.5xxw" 63 | 64 | tokens = [ Id 0 "abab", Id 1 "dddc", Id 2 "fff", Id 3 "gh", Id 4 "ijji", 65 | Id 5 "ll", Id 6 "mnm", Id 7 "oop", Id 8 "rq", Id 9 "tsst", 66 | Id 10 "uuvu", Id 11 "xxw"] 67 | 68 | main :: IO () 69 | main = 70 | let 71 | result :: [Token String] 72 | result = lex input 73 | in do 74 | if result /= tokens 75 | then exitFailure 76 | else exitWith ExitSuccess 77 | 78 | } 79 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/tokens.x: -------------------------------------------------------------------------------- 1 | { 2 | module Main (main) where 3 | import System.Exit 4 | } 5 | 6 | %wrapper "basic" 7 | 8 | $digit=0-9 -- digits 9 | $alpha = [a-zA-Z] -- alphabetic characters 10 | 11 | tokens :- 12 | 13 | $white+ ; 14 | "--".* ; 15 | let { \_ -> Let } 16 | in { \_ -> In } 17 | $digit+ { \s -> Int (read s) } 18 | [\=\+\-\*\/\(\)] { \s -> Sym (head s) } 19 | $alpha [$alpha $digit \_ \']* { \s -> Var s } 20 | 21 | -- a left-context pattern for testing 22 | ^ \# ; 23 | 24 | { 25 | -- Each right-hand side has type :: String -> Token 26 | 27 | -- The token type: 28 | data Token = 29 | Let | 30 | In | 31 | Sym Char | 32 | Var String | 33 | Int Int | 34 | Err 35 | deriving (Eq,Show) 36 | 37 | main = if test1 /= result1 then exitFailure 38 | else exitWith ExitSuccess 39 | 40 | test1 = alexScanTokens " let in 012334\n=+*foo bar__'" 41 | result1 = identifierWithLotsOfQuotes'' 42 | 43 | identifierWithLotsOfQuotes'' :: [Token] 44 | identifierWithLotsOfQuotes'' = 45 | [Let,In,Int 12334,Sym '=',Sym '+',Sym '*',Var "foo",Var "bar__'"] 46 | 47 | } 48 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/tokens_bytestring.x: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main (main) where 4 | import System.Exit 5 | import Data.ByteString.Lazy.Char8 (unpack) 6 | } 7 | 8 | %wrapper "basic-bytestring" 9 | %encoding "latin1" 10 | 11 | $digit = 0-9 -- digits 12 | $alpha = [a-zA-Z] -- alphabetic characters 13 | 14 | tokens :- 15 | 16 | $white+ ; 17 | "--".* ; 18 | let { \_ -> Let } 19 | in { \_ -> In } 20 | $digit+ { \s -> Int (read (unpack s)) } 21 | [\=\+\-\*\/\(\)] { \s -> Sym (head (unpack s)) } 22 | $alpha [$alpha $digit \_ \']* { \s -> Var (unpack s) } 23 | 24 | { 25 | -- Each right-hand side has type :: ByteString -> Token 26 | 27 | -- The token type: 28 | data Token = 29 | Let | 30 | In | 31 | Sym Char | 32 | Var String | 33 | Int Int | 34 | Err 35 | deriving (Eq,Show) 36 | 37 | main = if test1 /= result1 then exitFailure 38 | else exitWith ExitSuccess 39 | 40 | test1 = alexScanTokens " let in 012334\n=+*foo bar__'" 41 | result1 = [Let,In,Int 12334,Sym '=',Sym '+',Sym '*',Var "foo",Var "bar__'"] 42 | 43 | } 44 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/tokens_bytestring_unicode.x: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main (main) where 4 | import System.Exit 5 | import Data.ByteString.Lazy.Char8 (unpack) 6 | } 7 | 8 | %wrapper "basic-bytestring" 9 | %encoding "utf-8" 10 | 11 | $digit = 0-9 -- digits 12 | $alpha = [a-zA-Zαβ] -- alphabetic characters 13 | 14 | tokens :- 15 | 16 | $white+ ; 17 | "--".* ; 18 | let { \_ -> Let } 19 | in { \_ -> In } 20 | $digit+ { \s -> Int (read (unpack s)) } 21 | [\=\+\-\*\/\(\)] { \s -> Sym (head (unpack s)) } 22 | $alpha [$alpha $digit \_ \']* { \s -> Var (unpack s) } 23 | 24 | { 25 | -- Each right-hand side has type :: ByteString -> Token 26 | 27 | -- The token type: 28 | data Token = 29 | Let | 30 | In | 31 | Sym Char | 32 | Var String | 33 | Int Int | 34 | Err 35 | deriving (Eq,Show) 36 | 37 | main = if test1 /= result1 then exitFailure 38 | else exitWith ExitSuccess 39 | 40 | -- \206\177\206\178\206\178 is "αββ" utf-8 encoded 41 | test1 = alexScanTokens " let in 012334\n=+*foo \206\177\206\178\206\178 bar__'" 42 | result1 = [Let,In,Int 12334,Sym '=',Sym '+',Sym '*',Var "foo",Var "\206\177\206\178\206\178",Var "bar__'"] 43 | } 44 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/tokens_gscan.x: -------------------------------------------------------------------------------- 1 | { 2 | module Main (main) where 3 | import System.Exit 4 | } 5 | 6 | %wrapper "gscan" 7 | 8 | $digit = 0-9 -- digits 9 | $alpha = [a-zA-Z] -- alphabetic characters 10 | 11 | tokens :- 12 | 13 | $white+ ; 14 | "--".* ; 15 | let { tok (\p _ -> Let p) } 16 | in { tok (\p _ -> In p) } 17 | $digit+ { tok (\p s -> Int p (read s)) } 18 | [\=\+\-\*\/\(\)] { tok (\p s -> Sym p (head s)) } 19 | $alpha [$alpha $digit \_ \']* { tok (\p s -> Var p s) } 20 | 21 | { 22 | -- Some action helpers: 23 | tok f p _ str len cont (sc,state) = f p (take len str) : cont (sc,state) 24 | 25 | -- The token type: 26 | data Token = 27 | Let AlexPosn | 28 | In AlexPosn | 29 | Sym AlexPosn Char | 30 | Var AlexPosn String | 31 | Int AlexPosn Int | 32 | Err AlexPosn 33 | deriving (Eq,Show) 34 | 35 | main = if test1 /= result1 then exitFailure 36 | else exitWith ExitSuccess 37 | 38 | test1 = alexGScan stop undefined " let in 012334\n=+*foo bar__'" 39 | 40 | stop _ _ "" (_,_) = [] 41 | stop _ _ _ (_,_) = error "lexical error" 42 | 43 | result1 = [Let (AlexPn 2 1 3),In (AlexPn 6 1 7),Int (AlexPn 9 1 10) 12334,Sym (AlexPn 16 2 1) '=',Sym (AlexPn 17 2 2) '+',Sym (AlexPn 18 2 3) '*',Var (AlexPn 19 2 4) "foo",Var (AlexPn 23 2 8) "bar__'"] 44 | } 45 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/tokens_monadUserState_bytestring.x: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main (main) where 4 | import System.Exit 5 | import qualified Data.ByteString.Lazy.Char8 as B 6 | } 7 | 8 | %wrapper "monadUserState-bytestring" 9 | %encoding "iso-8859-1" 10 | 11 | $digit = 0-9 -- digits 12 | $alpha = [a-zA-Z] -- alphabetic characters 13 | 14 | tokens :- 15 | 16 | $white+ ; 17 | "--".* ; 18 | let { tok (\p _ -> Let p) } 19 | in { tok (\p _ -> In p) } 20 | $digit+ { tok (\p s -> Int p (read (B.unpack s))) } 21 | [\=\+\-\*\/\(\)] { tok (\p s -> Sym p (head (B.unpack s))) } 22 | $alpha [$alpha $digit \_ \']* { tok (\p s -> Var p (B.unpack s)) } 23 | 24 | { 25 | -- Each right-hand side has type :: AlexPosn -> String -> Token 26 | 27 | -- Some action helpers: 28 | tok f (p,_,input,_) len = return (f p (B.take (fromIntegral len) input)) 29 | 30 | -- The token type: 31 | data Token = 32 | Let AlexPosn | 33 | In AlexPosn | 34 | Sym AlexPosn Char | 35 | Var AlexPosn String | 36 | Int AlexPosn Int | 37 | Err AlexPosn | 38 | EOF 39 | deriving (Eq,Show) 40 | 41 | alexEOF = return EOF 42 | 43 | main = if test1 /= result1 then do print test1; exitFailure 44 | else exitWith ExitSuccess 45 | 46 | type AlexUserState = () 47 | alexInitUserState = () 48 | 49 | scanner str = runAlex str $ do 50 | let loop = do tk <- alexMonadScan 51 | if tk == EOF 52 | then return [tk] 53 | else do toks <- loop 54 | return (tk:toks) 55 | loop 56 | 57 | test1 = case scanner " let in 012334\n=+*foo bar__'" of 58 | Left err -> error err 59 | Right toks -> toks 60 | 61 | result1 = [Let (AlexPn 2 1 3),In (AlexPn 6 1 7),Int (AlexPn 9 1 10) 12334,Sym (AlexPn 16 2 1) '=',Sym (AlexPn 17 2 2) '+',Sym (AlexPn 18 2 3) '*',Var (AlexPn 19 2 4) "foo",Var (AlexPn 23 2 8) "bar__'", EOF] 62 | 63 | 64 | } 65 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/tokens_monad_bytestring.x: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main (main) where 4 | import System.Exit 5 | import qualified Data.ByteString.Lazy.Char8 as B 6 | } 7 | 8 | %wrapper "monad-bytestring" 9 | %encoding "Latin1" 10 | 11 | $digit = 0-9 -- digits 12 | $alpha = [a-zA-Z] -- alphabetic characters 13 | 14 | tokens :- 15 | 16 | $white+ ; 17 | "--".* ; 18 | let { tok (\p _ -> Let p) } 19 | in { tok (\p _ -> In p) } 20 | $digit+ { tok (\p s -> Int p (read (B.unpack s))) } 21 | [\=\+\-\*\/\(\)] { tok (\p s -> Sym p (head (B.unpack s))) } 22 | $alpha [$alpha $digit \_ \']* { tok (\p s -> Var p (B.unpack s)) } 23 | 24 | { 25 | -- Each right-hand side has type :: AlexPosn -> String -> Token 26 | 27 | -- Some action helpers: 28 | tok f (p,_,input,_) len = return (f p (B.take (fromIntegral len) input)) 29 | 30 | -- The token type: 31 | data Token = 32 | Let AlexPosn | 33 | In AlexPosn | 34 | Sym AlexPosn Char | 35 | Var AlexPosn String | 36 | Int AlexPosn Int | 37 | Err AlexPosn | 38 | EOF 39 | deriving (Eq,Show) 40 | 41 | alexEOF = return EOF 42 | 43 | main = if test1 /= result1 then do print test1; exitFailure 44 | else exitWith ExitSuccess 45 | 46 | scanner str = runAlex str $ do 47 | let loop = do tk <- alexMonadScan 48 | if tk == EOF 49 | then return [tk] 50 | else do toks <- loop 51 | return (tk:toks) 52 | loop 53 | 54 | test1 = case scanner " let in 012334\n=+*foo bar__'" of 55 | Left err -> error err 56 | Right toks -> toks 57 | 58 | result1 = [Let (AlexPn 2 1 3),In (AlexPn 6 1 7),Int (AlexPn 9 1 10) 12334,Sym (AlexPn 16 2 1) '=',Sym (AlexPn 17 2 2) '+',Sym (AlexPn 18 2 3) '*',Var (AlexPn 19 2 4) "foo",Var (AlexPn 23 2 8) "bar__'", EOF] 59 | 60 | 61 | } 62 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/tokens_posn.x: -------------------------------------------------------------------------------- 1 | { 2 | module Main (main) where 3 | import System.Exit 4 | } 5 | 6 | %wrapper "posn" 7 | 8 | $digit = 0-9 -- digits 9 | $alpha = [a-zA-Z] -- alphabetic characters 10 | 11 | tokens :- 12 | 13 | $white+ ; 14 | "--".* ; 15 | let { tok (\p _ -> Let p) } 16 | in { tok (\p _ -> In p) } 17 | $digit+ { tok (\p s -> Int p (read s)) } 18 | [\=\+\-\*\/\(\)] { tok (\p s -> Sym p (head s)) } 19 | $alpha [$alpha $digit \_ \']* { tok (\p s -> Var p s) } 20 | 21 | { 22 | -- Each right-hand side has type :: AlexPosn -> String -> Token 23 | 24 | -- Some action helpers: 25 | tok f p s = f p s 26 | 27 | -- The token type: 28 | data Token = 29 | Let AlexPosn | 30 | In AlexPosn | 31 | Sym AlexPosn Char | 32 | Var AlexPosn String | 33 | Int AlexPosn Int | 34 | Err AlexPosn 35 | deriving (Eq,Show) 36 | 37 | main = if test1 /= result1 then exitFailure 38 | else exitWith ExitSuccess 39 | 40 | test1 = alexScanTokens " let in 012334\n=+*foo bar__'" 41 | result1 = [Let (AlexPn 2 1 3),In (AlexPn 6 1 7),Int (AlexPn 9 1 10) 12334,Sym (AlexPn 16 2 1) '=',Sym (AlexPn 17 2 2) '+',Sym (AlexPn 18 2 3) '*',Var (AlexPn 19 2 4) "foo",Var (AlexPn 23 2 8) "bar__'"] 42 | 43 | 44 | } 45 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/tokens_posn_bytestring.x: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main (main) where 4 | import System.Exit 5 | import Data.ByteString.Lazy.Char8 (unpack) 6 | } 7 | 8 | %wrapper "posn-bytestring" 9 | %encoding "UTF8" 10 | 11 | $digit = 0-9 -- digits 12 | $alpha = [a-zA-Z] -- alphabetic characters 13 | 14 | tokens :- 15 | 16 | $white+ ; 17 | "--".* ; 18 | let { tok (\p _ -> Let p) } 19 | in { tok (\p _ -> In p) } 20 | $digit+ { tok (\p s -> Int p (read (unpack s))) } 21 | [\=\+\-\*\/\(\)] { tok (\p s -> Sym p (head (unpack s))) } 22 | $alpha [$alpha $digit \_ \']* { tok (\p s -> Var p (unpack s)) } 23 | 24 | { 25 | -- Each right-hand side has type :: AlexPosn -> String -> Token 26 | 27 | -- Some action helpers: 28 | tok f p s = f p s 29 | 30 | -- The token type: 31 | data Token = 32 | Let AlexPosn | 33 | In AlexPosn | 34 | Sym AlexPosn Char | 35 | Var AlexPosn String | 36 | Int AlexPosn Int | 37 | Err AlexPosn 38 | deriving (Eq,Show) 39 | 40 | main = if test1 /= result1 then exitFailure 41 | else exitWith ExitSuccess 42 | 43 | test1 = alexScanTokens " let in 012334\n=+*foo bar__'" 44 | result1 = [Let (AlexPn 2 1 3),In (AlexPn 6 1 7),Int (AlexPn 9 1 10) 12334,Sym (AlexPn 16 2 1) '=',Sym (AlexPn 17 2 2) '+',Sym (AlexPn 18 2 3) '*',Var (AlexPn 19 2 4) "foo",Var (AlexPn 23 2 8) "bar__'"] 45 | 46 | 47 | } 48 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/tokens_scan_user.x: -------------------------------------------------------------------------------- 1 | { 2 | module Main (main) where 3 | import System.Exit 4 | } 5 | 6 | %wrapper "basic" -- Defines: AlexInput, alexGetByte, alexPrevChar 7 | 8 | $digit = 0-9 9 | $alpha = [a-zA-Z] 10 | $ws = [\ \t\n] 11 | 12 | tokens :- 13 | 14 | 5 / {\ u _ibt _l _iat -> u == FiveIsMagic} { \s -> TFive (head s) } 15 | $digit { \s -> TDigit (head s) } 16 | $alpha { \s -> TAlpha (head s) } 17 | $ws { \s -> TWSpace (head s) } 18 | 19 | { 20 | 21 | data Token = TDigit Char 22 | | TAlpha Char 23 | | TWSpace Char 24 | | TFive Char -- Predicated only 25 | | TLexError 26 | deriving (Eq,Show) 27 | 28 | data UserLexerMode = NormalMode 29 | | FiveIsMagic 30 | deriving Eq 31 | 32 | main | test1 /= result1 = exitFailure 33 | | test2 /= result2 = exitFailure 34 | -- all succeeded 35 | | otherwise = exitWith ExitSuccess 36 | 37 | run_lexer :: UserLexerMode -> String -> [Token] 38 | run_lexer m s = go ('\n', [], s) 39 | where go i@(_,_,s') = case alexScanUser m i 0 of 40 | AlexEOF -> [] 41 | AlexError _i -> [TLexError] 42 | AlexSkip i' _len -> go i' 43 | AlexToken i' len t -> t (take len s') : go i' 44 | 45 | test1 = run_lexer FiveIsMagic "5 x" 46 | result1 = [TFive '5',TWSpace ' ',TAlpha 'x'] 47 | 48 | test2 = run_lexer NormalMode "5 x" 49 | result2 = [TDigit '5',TWSpace ' ',TAlpha 'x'] 50 | } 51 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/tokens_strict_bytestring.x: -------------------------------------------------------------------------------- 1 | { 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main (main) where 4 | import System.Exit 5 | import Data.ByteString.Char8 (unpack) 6 | } 7 | 8 | %wrapper "strict-bytestring" 9 | %encoding "ISO-8859-1" 10 | 11 | $digit = 0-9 -- digits 12 | $alpha = [a-zA-Z] -- alphabetic characters 13 | 14 | tokens :- 15 | 16 | $white+ ; 17 | "--".* ; 18 | let { \_ -> Let } 19 | in { \_ -> In } 20 | $digit+ { \s -> Int (read (unpack s)) } 21 | [\=\+\-\*\/\(\)] { \s -> Sym (head (unpack s)) } 22 | $alpha [$alpha $digit \_ \']* { \s -> Var (unpack s) } 23 | 24 | { 25 | -- Each right-hand side has type :: ByteString -> Token 26 | 27 | -- The token type: 28 | data Token = 29 | Let | 30 | In | 31 | Sym Char | 32 | Var String | 33 | Int Int | 34 | Err 35 | deriving (Eq,Show) 36 | 37 | main = if test1 /= result1 then exitFailure 38 | else exitWith ExitSuccess 39 | 40 | test1 = alexScanTokens " let in 012334\n=+*foo bar__'" 41 | result1 = [Let,In,Int 12334,Sym '=',Sym '+',Sym '*',Var "foo",Var "bar__'"] 42 | 43 | } 44 | -------------------------------------------------------------------------------- /demo-03-alex/alex-3.2.5/tests/unicode.x: -------------------------------------------------------------------------------- 1 | { 2 | -- Tests the basic operation. 3 | module Main where 4 | 5 | import Data.Char (toUpper) 6 | import Control.Monad 7 | import System.Exit 8 | import System.IO 9 | } 10 | 11 | %wrapper "monad" 12 | 13 | @word = [A-Za-z]+ 14 | 15 | tokens :- 16 | 17 | <0> { 18 | "αω" { string } 19 | [AΓ] { character } 20 | . { other } 21 | } 22 | 23 | 24 | { 25 | string :: AlexInput -> Int -> Alex String 26 | string (_,_,_,_) _ = return "string!" 27 | 28 | other :: AlexInput -> Int -> Alex String 29 | other (_,_,_,input) len = return (take len input) 30 | 31 | character :: AlexInput -> Int -> Alex String 32 | character (_,_,_,_) _ = return "PING!" 33 | 34 | alexEOF :: Alex String 35 | alexEOF = return "stopped." 36 | 37 | scanner :: String -> Either String [String] 38 | scanner str = runAlex str $ do 39 | let loop = do tok <- alexMonadScan 40 | if tok == "stopped." || tok == "error." 41 | then return [tok] 42 | else do toks <- loop 43 | return (tok:toks) 44 | loop 45 | 46 | main :: IO () 47 | main = do 48 | let test1 = scanner str1 49 | when (test1 /= out1) $ 50 | do hPutStrLn stderr "Test 1 failed:" 51 | print test1 52 | exitFailure 53 | 54 | let test2 = scanner str2 55 | when (test2 /= out2) $ 56 | do hPutStrLn stderr "Test 2 failed:" 57 | print test2 58 | exitFailure 59 | 60 | let test3 = scanner str3 61 | when (test3 /= out3) $ 62 | do hPutStrLn stderr "Test 3 failed:" 63 | print test3 64 | exitFailure 65 | 66 | let test4 = scanner str4 67 | when (test4 /= out4) $ 68 | do hPutStrLn stderr "Test 4 failed:" 69 | print test4 70 | exitFailure 71 | 72 | 73 | 74 | str1 = "A." 75 | out1 = Right ["PING!",".","stopped."] 76 | 77 | str2 = "\n" 78 | out2 = Left "lexical error at line 1, column 1" 79 | 80 | 81 | str3 = "αω --" 82 | out3 = Right ["string!"," ","-","-","stopped."] 83 | 84 | str4 = "βΓ" 85 | out4 = Right ["β","PING!","stopped."] 86 | 87 | } 88 | -------------------------------------------------------------------------------- /demo-03-alex/c.build: -------------------------------------------------------------------------------- 1 | reset 2 | 3 | set -x -e 4 | 5 | #time stack --stack-root `pwd`/.stack-root build --profile --executable-profiling --library-profiling 6 | time stack --stack-root `pwd`/.stack-root build 7 | -------------------------------------------------------------------------------- /demo-03-alex/c.clean: -------------------------------------------------------------------------------- 1 | set -x -e 2 | 3 | stack --stack-root `pwd`/.stack-root clean 4 | -------------------------------------------------------------------------------- /demo-03-alex/delete-stack-work.sh: -------------------------------------------------------------------------------- 1 | set -x -e 2 | rm -r `find . -name '.stack-work' -type d` 3 | -------------------------------------------------------------------------------- /demo-03-alex/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-15.6 2 | 3 | allow-newer: true 4 | 5 | packages: 6 | - 'alex-3.2.5' 7 | 8 | apply-ghc-options: everything 9 | ghc-options: 10 | "$everything": -split-sections -O2 11 | 12 | # use custom ext-stg whole program compiler GHC 13 | compiler: ghc-8.11.0.20200527 14 | 15 | # use local GHC (for development) 16 | system-ghc: true 17 | extra-path: 18 | - /home/csaba/haskell/grin-compiler/ghc-whole-program-compiler-project/ghc-wpc/_build/stage1/bin 19 | -------------------------------------------------------------------------------- /demo-03-alex/test-run/Tokens.x: -------------------------------------------------------------------------------- 1 | { 2 | module Main where 3 | } 4 | 5 | %wrapper "basic" 6 | 7 | $digit = 0-9 -- digits 8 | $alpha = [a-zA-Z] -- alphabetic characters 9 | 10 | tokens :- 11 | 12 | $white+ { \s -> White } 13 | "--".* { \s -> Comment } 14 | let { \s -> Let } 15 | in { \s -> In } 16 | $digit+ { \s -> Int (read s) } 17 | [\=\+\-\*\/\(\)] { \s -> Sym (head s) } 18 | $alpha [$alpha $digit \_ \']* { \s -> Var s } 19 | 20 | { 21 | -- Each right-hand side has type :: String -> Token 22 | 23 | -- The token type: 24 | data Token = 25 | White | 26 | Comment | 27 | Let | 28 | In | 29 | Sym Char | 30 | Var String | 31 | Int Int | 32 | Err 33 | deriving (Eq,Show) 34 | 35 | main = do 36 | s <- getContents 37 | print (alexScanTokens s) 38 | } 39 | -------------------------------------------------------------------------------- /demo-03-alex/test-run/run: -------------------------------------------------------------------------------- 1 | set -e -x 2 | 3 | time ext-stg-interpreter -t alex.fullpak --args="Tokens.x -t ../alex-3.2.5/data" 4 | -------------------------------------------------------------------------------- /demo-04-ghc/A1.hs: -------------------------------------------------------------------------------- 1 | 2 | module A1 where 3 | 4 | doPrint :: IO () 5 | doPrint = putStrLn "greetings from module A1" 6 | 7 | -------------------------------------------------------------------------------- /demo-04-ghc/A2.hs: -------------------------------------------------------------------------------- 1 | 2 | module A2 where 3 | 4 | doPrint :: IO () 5 | doPrint = putStrLn "greetings from module A2" 6 | 7 | -------------------------------------------------------------------------------- /demo-04-ghc/ghc.dbg: -------------------------------------------------------------------------------- 1 | wait-b 2 | 3 | +b traceMarker# 191 4 | 5 | +r traceMarker# 6 | 7 | c 8 | 9 | wait-b 10 | 11 | gc 12 | 13 | save-state .ghc-post-gc-post-link-stage 14 | -------------------------------------------------------------------------------- /demo-04-ghc/hello.hs: -------------------------------------------------------------------------------- 1 | 2 | import qualified A1 3 | import qualified A2 4 | 5 | main = do 6 | putStrLn "hello ext-stg-interpreter!" 7 | A1.doPrint 8 | A2.doPrint 9 | 10 | -------------------------------------------------------------------------------- /demo-04-ghc/run: -------------------------------------------------------------------------------- 1 | set -x 2 | 3 | rm hello *.hi *.o *.o_modpak hello.o_ghc_stgapp 4 | 5 | cp `which ext-stg-interpreter` /home/csaba/haskell/grin-compiler/ghc-whole-program-compiler-project/ghc-wpc/_build/stage1/bin 6 | 7 | cat hello.hs 8 | 9 | /home/csaba/haskell/grin-compiler/ghc-whole-program-compiler-project/ghc-wpc/_build/stage1/bin/ext-stg-interpreter ghc.fullpak -d --debug-script ghc.dbg --args="-v -O2 hello.hs" 10 | -------------------------------------------------------------------------------- /fetch_ghcup.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | set -eu 3 | 4 | ghcup_version="$1" 5 | ghcup_checksum="$2" 6 | file_path="$3" 7 | 8 | wget \ 9 | -O "/tmp/ghcup" \ 10 | "https://downloads.haskell.org/~ghcup/${ghcup_version}/x86_64-linux-ghcup-${ghcup_version}" &&\ 11 | 12 | if ! echo "${ghcup_checksum} ${file_path}" | sha256sum -c -; then 13 | echo "${file_path} checksum failed" >&2 14 | echo "expected '${ghcup_checksum}', but got '$( sha256sum "${file_path}" )'" >&2 15 | exit 1 16 | fi; 17 | -------------------------------------------------------------------------------- /mc-zstd-support.zip: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/grin-compiler/ext-stg-interpreter-presentation-demos/733af6b8e7c7bd52ad96fcf50763ed3851a574d4/mc-zstd-support.zip --------------------------------------------------------------------------------