├── PolyTest ├── .gitignore └── Implementation │ ├── GADT.hs │ ├── FD.hs │ ├── Fun.hs │ ├── Fun2.hs │ ├── Fun.agda │ └── FunProd.agda ├── FunctionalIncrementalParsing ├── .gitignore ├── DraftList ├── Full ├── tree.dia ├── Bidir │ ├── Full │ ├── Stack.lhs │ ├── Progress.lhs │ ├── Parser.lhs │ ├── Polish2.lhs │ ├── SExpr.lhs │ ├── Example.lhs │ └── Full.lhs ├── Attic │ └── progress.dia ├── talk2 │ ├── progress.pdf │ ├── overview.dot │ ├── states.dot │ ├── Makefile │ ├── ast.svg │ └── progress.svg ├── talk │ ├── ChalmGUmarke.pdf │ ├── Makefile │ ├── mid.svg │ └── begin.svg ├── yi-ghc-simplifier.png ├── Stack.lhs ├── Progress.lhs ├── Sort.hs ├── Parser.lhs ├── Compiler.hs ├── response ├── Example2.hs ├── Example0.hs ├── Polish2.lhs ├── A.hs ├── progress.dot ├── Makefile ├── SExpr.lhs ├── pgf-tree.tex ├── Outline.markdown ├── scratchpad ├── Example.lhs.bak ├── Example.lhs ├── Tree.hs ├── mid.svg ├── Full.lhs.bak └── begin.svg ├── Parsers ├── TestCase1.hs ├── README.markdown ├── Polish.agda ├── SimplePolish.hs └── Polish.hs ├── .gitignore ├── README.markdown ├── Machines ├── HOAM.hs ├── ComposVM.hs ├── SuspensionAM.hs ├── SuspensionPMatchAM.hs ├── KAMCC.hs ├── TypedHOAM2.hs ├── TypedHOAM.hs ├── KAM.hs ├── PolishVM.hs └── SuspensionVM.hs ├── OnlineTree ├── CBNOnlineTree.hs ├── README.markdown ├── IndexedOnlineTree.hs └── OnlineTree.agda ├── PHOAS └── PHOAS.hs ├── CPSZipper ├── EvalToAbstract.hs ├── CBNCPS.hs ├── Map.hs ├── List.hs ├── Dissect.agda ├── ZipperForTheTypedApplicativeLanguage.hs ├── ZipperToZipper.hs ├── Dissect.hs ├── HinzeZipper.hs └── CJ.agda ├── log └── 20081020.markdown ├── TransDistr └── Distr.hs ├── FullIncrementalParsing ├── Lex.hs ├── PP.hs └── PPT1.hs ├── Open ├── Open.agda ├── Open2.agda ├── Open4.agda └── Open3.agda └── TypeClasses ├── MPTC.agda └── ClassesAsPredicate.agda /PolyTest/.gitignore: -------------------------------------------------------------------------------- 1 | PolyTest.tex 2 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | *.tex 3 | *.out 4 | *.vrb -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/DraftList: -------------------------------------------------------------------------------- 1 | Patrik 2 | Krasimir 3 | 4 | Ralf 5 | Wouter 6 | Doaitse 7 | Don 8 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Full: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jyp/topics/HEAD/FunctionalIncrementalParsing/Full -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/tree.dia: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jyp/topics/HEAD/FunctionalIncrementalParsing/tree.dia -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Bidir/Full: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jyp/topics/HEAD/FunctionalIncrementalParsing/Bidir/Full -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Attic/progress.dia: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jyp/topics/HEAD/FunctionalIncrementalParsing/Attic/progress.dia -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/talk2/progress.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jyp/topics/HEAD/FunctionalIncrementalParsing/talk2/progress.pdf -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/talk/ChalmGUmarke.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jyp/topics/HEAD/FunctionalIncrementalParsing/talk/ChalmGUmarke.pdf -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/yi-ghc-simplifier.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jyp/topics/HEAD/FunctionalIncrementalParsing/yi-ghc-simplifier.png -------------------------------------------------------------------------------- /Parsers/TestCase1.hs: -------------------------------------------------------------------------------- 1 | module TestCase1 where 2 | 3 | best ls 4 | | ([]:) <- -- typing a [ after the colon makes yi loop. 5 | 6 | where xs = f x y 7 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Stack.lhs: -------------------------------------------------------------------------------- 1 | \ignore{ 2 | 3 | \begin{code} 4 | module Stack where 5 | \end{code} 6 | 7 | } 8 | 9 | 10 | 11 | 12 | \begin{code} 13 | data top :< rest = (:<) {top :: top, rest :: rest} 14 | data Nil = Nil 15 | infixr 4 :< 16 | \end{code} 17 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Bidir/Stack.lhs: -------------------------------------------------------------------------------- 1 | \ignore{ 2 | 3 | \begin{code} 4 | module Stack where 5 | \end{code} 6 | 7 | } 8 | 9 | 10 | 11 | 12 | \begin{code} 13 | data top :< rest = (:<) {top :: top, rest :: rest} 14 | data Nil = Nil 15 | infixr 4 :< 16 | \end{code} 17 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Ignore loads of file types. 2 | 3 | *# 4 | *.aux 5 | *.bbl 6 | *.blg 7 | *.beam 8 | *.dvi 9 | *.eps 10 | *.gfc 11 | *.gfr 12 | *.hi 13 | *.log 14 | *.nav 15 | *.o 16 | *.pdf 17 | *.prof 18 | *.ps 19 | *.ptb 20 | *.tmp 21 | *.toc 22 | *.snm 23 | */.svn 24 | *~ 25 | .#* 26 | .*.agda.el 27 | *.agdai 28 | .DS_Store 29 | ._* 30 | .yi.dbg 31 | _darcs 32 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/talk2/overview.dot: -------------------------------------------------------------------------------- 1 | 2 | 3 | digraph progress { 4 | rankdir=LR; 5 | ranksep=0.5; 6 | node [height=.1,shape=box, width = 0.5]; 7 | node [style=filled, color=lightgrey]; 8 | edge [headport=w] 9 | 10 | Text -> AST [label="parser"]; 11 | AST -> "Highlighted code"; 12 | AST -> "Paren-matching hints"; 13 | AST -> "Indentation hints"; 14 | 15 | } -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Progress.lhs: -------------------------------------------------------------------------------- 1 | \ignore{ 2 | \begin{code} 3 | {-# LANGUAGE TypeOperators, GADTs #-} 4 | module Progress where 5 | import Stack 6 | import Parser 7 | 8 | mapSucc S = S 9 | mapSucc (D x) = D (succ x) 10 | mapSucc (x :# xs) = succ x :# mapSucc xs 11 | 12 | dislikeThreshold _ = 0 13 | 14 | \end{code} 15 | } 16 | 17 | 18 | \begin{code} 19 | data Progress = S | D Int | Int :# Progress 20 | \end{code} 21 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Bidir/Progress.lhs: -------------------------------------------------------------------------------- 1 | \ignore{ 2 | \begin{code} 3 | {-# LANGUAGE TypeOperators, GADTs #-} 4 | module Progress where 5 | import SExpr 6 | import Stack 7 | import Parser 8 | 9 | mapSucc PSusp = PSusp 10 | mapSucc (PRes x) = PRes (succ x) 11 | mapSucc (x :> xs) = succ x :> mapSucc xs 12 | 13 | dislikeThreshold _ = 0 14 | 15 | \end{code} 16 | } 17 | 18 | 19 | \begin{code} 20 | data Progress = PSusp | PRes Int | Int :> Progress 21 | \end{code} 22 | -------------------------------------------------------------------------------- /PolyTest/Implementation/GADT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, EmptyDataDecls, GADTs, TypeOperators, FlexibleInstances #-} 2 | 3 | data Poly a t where 4 | Var :: Poly a a 5 | Fun :: Poly a t -> Poly a u -> Poly a (t -> u) 6 | Con :: Z1 t -> Poly a t 7 | 8 | 9 | 10 | newtype Fix f = In { out :: f (Fix f)} 11 | 12 | data Z1 a 13 | data Id a = Id a 14 | data K x a = K x 15 | data (f :+: g) a = L1 (f a) | L2 (g a) 16 | data (f :*: g) a = f a :*: g a 17 | 18 | 19 | functorOf :: Poly a t -> -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/talk/Makefile: -------------------------------------------------------------------------------- 1 | default: slides.pdf 2 | 3 | 4 | %.view: %.pdf 5 | evince $< 6 | 7 | %.print: %.pdf 8 | lpr $< 9 | 10 | 11 | %.pdf: %.tex 12 | pdflatex $< 13 | 14 | %.pdf: %.svg 15 | # inkscape --export-pdf=$@ $< 16 | convert $< $@ 17 | 18 | slides.pdf: begin.pdf mid.pdf 19 | 20 | 21 | %.tex: %.lhs 22 | lhs2TeX $< > $@ 23 | 24 | 25 | %.tex: %.dot 26 | dot -Txdot $< | dot2tex --texmode=raw --figonly > $@ 27 | # dot2tex --preproc $< | dot2tex --figonly > $@ 28 | 29 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/talk2/states.dot: -------------------------------------------------------------------------------- 1 | 2 | 3 | digraph states { 4 | rankdir=LR; 5 | ranksep=0.7; 6 | node [height=.1, width = 0.2, height=0.2 ]; 7 | 8 | node[label="",shape=box,color=black]; 9 | D[label=" ... ", style=filled,color=white]; 10 | 11 | A -> B -> C -> D -> E [dir=back]; 12 | 13 | node[style=filled,color=white, fontsize=8]; 14 | nA [label="module"] 15 | nB [label="M"] 16 | nC [label="where"] 17 | nD [label="..."] 18 | nE [label="z"] 19 | 20 | nA -> nB -> nC -> nD -> nE [dir=none,color=white] 21 | 22 | } 23 | 24 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Sort.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -i../Machines #-} 2 | import SuspensionVM 3 | import Control.Applicative 4 | 5 | insert y [] = [y] 6 | insert y (x:xs) = if x < y then x : insert y xs else y : x : xs 7 | 8 | sort (x:xs) = insert x (sort xs) 9 | sort [] = [] 10 | 11 | -- Unfortunately evalL will not do any computation : 12 | -- profile $ evalL $ pushSyms "jcsdjqwioheof" $ toProc sort' == "$.$.$.$.$.$.$.$.$.$.$.$.$.?" 13 | sort' :: P Char [Char] 14 | sort' = case_ (pure []) $ 15 | \x -> insert x <$> sort' 16 | 17 | 18 | 19 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | This directory contains projects that do not deserve their own repository. 2 | 3 | * [Towards an encoding for open datatypes in Agda](master/Open) 4 | 5 | * [Abstract and virtual machines in theory of computation](master/Machines) 6 | 7 | * [Lazy data structure with quick access](master/OnlineTree) 8 | 9 | * [Parameterized Higher Order Abstract Syntax](master/PHOAS) 10 | 11 | * [What is the connection between the Zipper and direct traversal?](master/CPSZipper) 12 | 13 | * [Encoding type classes in Agda](master/TypeClasses) -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Parser.lhs: -------------------------------------------------------------------------------- 1 | \ignore{ 2 | \begin{code} 3 | {-# LANGUAGE TypeOperators, GADTs #-} 4 | module Parser where 5 | import SExpr 6 | import Stack 7 | 8 | \end{code} 9 | } 10 | 11 | \begin{code} 12 | data Parser s a where 13 | Pure :: a -> Parser s a 14 | (:*:) :: Parser s (b -> a) -> Parser s b -> Parser s a 15 | Symb :: Parser s a -> (s -> Parser s a) -> Parser s a 16 | Disj :: Parser s a -> Parser s a -> Parser s a 17 | Yuck :: Parser s a -> Parser s a 18 | \end{code} 19 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Bidir/Parser.lhs: -------------------------------------------------------------------------------- 1 | \ignore{ 2 | \begin{code} 3 | {-# LANGUAGE TypeOperators, GADTs #-} 4 | module Parser where 5 | import SExpr 6 | import Stack 7 | 8 | \end{code} 9 | } 10 | 11 | \begin{code} 12 | data Parser s a where 13 | Pure :: a -> Parser s a 14 | (:*:) :: Parser s (b -> a) -> Parser s b -> Parser s a 15 | Symb :: Parser s a -> (s -> Parser s a) -> Parser s a 16 | Disj :: Parser s a -> Parser s a -> Parser s a 17 | Yuck :: Parser s a -> Parser s a 18 | \end{code} 19 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/talk2/Makefile: -------------------------------------------------------------------------------- 1 | default: slides.pdf 2 | 3 | 4 | %.view: %.pdf 5 | evince $< 6 | 7 | %.print: %.pdf 8 | lpr $< 9 | 10 | 11 | %.pdf: %.tex 12 | pdflatex $< 13 | 14 | %.pdf: %.svg 15 | inkscape --export-pdf=$@ $< 16 | # convert $< $@ 17 | 18 | slides.pdf: states.tex overview.tex progress.pdf 19 | 20 | 21 | %.tex: %.lhs 22 | lhs2TeX $< > $@ 23 | 24 | states.tex: states.dot 25 | dot -Txdot $< | dot2tex --texmode=raw --codeonly > $@ 26 | # dot2tex --preproc $< | dot2tex --figonly > $@ 27 | 28 | 29 | %.tex: %.dot 30 | # dot -Txdot $< | dot2tex --texmode=raw --figonly > $@ 31 | dot2tex --preproc $< | dot2tex --figonly > $@ 32 | 33 | -------------------------------------------------------------------------------- /Machines/HOAM.hs: -------------------------------------------------------------------------------- 1 | data Term = Lam (Term -> Term) | App Term Term | Con String 2 | -- deriving Show 3 | 4 | parens s = "("++s++")" 5 | 6 | -- Higher order encoding of lambda-calculus. 7 | instance Show Term where 8 | showsPrec d (Con x) = showString x 9 | showsPrec d (Lam f) = showString "\\" 10 | showsPrec d (App t1 t2) = showParen (d > 1) (showsPrec 1 t1 . showString " " . showsPrec 2 t2) 11 | 12 | data Closure = Term 13 | deriving Show 14 | type Env = [Closure] 15 | type State = (Closure, Stack) 16 | type Stack = [Closure] 17 | 18 | -- Adaptation of the KAM to evaluate it. 19 | step (Lam f , v:s) = step (f v, s) 20 | step (App t1 t2 , s) = step (t1, t2:s) 21 | 22 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Compiler.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -i../Machines #-} 2 | import SuspensionVM 3 | import Control.Applicative 4 | import Data.Char 5 | 6 | data Term = Bin Term (Int -> Int -> Int) Term | Con Int 7 | 8 | data ByteCode = App (Int -> Int -> Int) | Push Int 9 | 10 | scan = case_ (error "unexpected eof!") (\s -> pure s) 11 | 12 | expect s0 = case_ (error "unexpected eof!") (\s -> if s /= s0 then error "expected ..." else pure ()) 13 | 14 | parseAtom = case_ (error "eof!") $ 15 | \s -> case s of 16 | '(' -> parseExpr <* expect ')' 17 | c -> pure $ Con (ord c - ord '0') 18 | 19 | parseOp = expect '+' *> pure (+) 20 | 21 | -- whoops, we need monad interface :( (and look ahead) 22 | parseExpr = do 23 | a <- parseAtom 24 | case parseOp of 25 | Nothing -> return a 26 | Just x -> Bin <$> parseAtom <*> parseOp <*> parseExpr 27 | 28 | 29 | 30 | 31 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/response: -------------------------------------------------------------------------------- 1 | In response to review #1, I'd like to say that, while there is a lot of 2 | folklore about the expressive power of lazy evaluation, I feel that there are 3 | few documented non-trivial applications. Detailing what laziness implies in 4 | the case of incremental parsing is a useful contribution to the functional 5 | programming community. 6 | 7 | In response to review #3: 8 | 9 | About the simplification of compositions: 10 | * Yes, evaluation under lambda would solve the problem; 11 | * Yes, using combinators can solve the problem. Indeed, the solution 12 | presented in the paper is an instance of this approach. 13 | 14 | About the essential uses of lazy evaluation: 15 | Section 8 details the benefits of using lazy evaluation. 16 | I'm not sure how this falls short of listing the essential usages 17 | of lazy evaluation. 18 | 19 | Thanks for the helpful reviews! 20 | 21 | -------------------------------------------------------------------------------- /OnlineTree/CBNOnlineTree.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fglasgow-exts #-} 2 | 3 | import Prelude hiding (sum, foldl) 4 | import PolishParse3 5 | import Data.Maybe 6 | import qualified Data.Tree as S 7 | import Control.Applicative 8 | import Data.Traversable 9 | import Data.Foldable 10 | 11 | data Tree0 a = Node0 a (Tree0 a) (Tree0 a) 12 | | Leaf0 13 | deriving Show 14 | 15 | type K a = forall b. (Tree a -> b) -> b 16 | 17 | data Tree a = Node a (K a) (K a) 18 | | Leaf 19 | 20 | factor = 2 21 | 22 | initialLeftSize = 2 23 | 24 | direct :: Int -> [a] -> (Tree a -> b) -> b 25 | direct leftSize [] k = k Leaf 26 | direct leftSize (x:xs) k = 27 | k (Node x 28 | (direct initialLeftSize xl) 29 | (direct (leftSize * factor) xr) 30 | ) 31 | where (xl, xr) = splitAt leftSize xs 32 | 33 | 34 | 35 | 36 | toTree0 Leaf = Leaf0 37 | toTree0 (Node a l r) = Node0 a (toTree0 (l id)) (toTree0 (r id)) -------------------------------------------------------------------------------- /PHOAS/PHOAS.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fglasgow-exts #-} 2 | -- This is inspired by Ryan Ingram 3 | -- http://www.haskell.org//pipermail/haskell-cafe/2008-November/050768.html 4 | 5 | import Data.Char 6 | 7 | data Term v t where 8 | Var :: v t -> Term v t 9 | App :: Term v (a -> b) -> Term v a -> Term v b 10 | Lam :: (v a -> Term v b) -> Term v (a -> b) 11 | 12 | newtype Exp t = Exp (forall v. Term v t) 13 | 14 | -- An evaluator 15 | eval :: Exp t -> t 16 | eval (Exp e) = evalP e 17 | 18 | newtype Id a = Id {fromId :: a} 19 | 20 | evalP :: Term Id t -> t 21 | evalP (Var (Id a)) = a 22 | evalP (App e1 e2) = evalP e1 $ evalP e2 23 | evalP (Lam f) = \a -> evalP (f (Id a)) 24 | 25 | -- Using "show" to peek inside functions! 26 | 27 | newtype K t a = K t 28 | 29 | show' :: Int -> Term (K Int) t -> String 30 | show' _ (Var (K c)) = [chr (ord 'a' + c)] 31 | show' d (App f x) = show' d f ++ " " ++ show' d x 32 | show' d (Lam a) = show' (d+1) (a (K d)) 33 | 34 | 35 | -------------------------------------------------------------------------------- /Parsers/README.markdown: -------------------------------------------------------------------------------- 1 | 2 | This directory contains various implementations of parser combinators. 3 | 4 | * [An implementation of the exact stuff presented in the Polish Parsers](master/Polish.hs) 5 | * [A copy of Koen's Parsek library](master/Parsek.hs) 6 | * [Simple Polish Parsers](master/SimplePolish.hs), My (simplified/clarified) version of the Polish combinators 7 | * [Incremental Parsing with error correction](master/IncrementalParserWithGeneralizedErrorCorrection.hs), 8 | based on the Simple Polish Parsers 9 | * [Enhanced ways to manipulate the Polish representation](master/PolishStack.hs) 10 | * [Manipulation of polish expressions in a fully typed way](master/Polish.agda) 11 | 12 | And some less interesting stuff: 13 | 14 | * [Some crappy version of error correction](master/IncrementalParserWithErrorCorrectionHack.hs), 15 | and a [test case](master/TestCase1.hs) where it fails . 16 | 17 | I'm not sure why this is here: 18 | 19 | references: 20 | - [left fold] 21 | [left fold]: http://okmij.org/ftp/Streams.html#iteratee 22 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Example2.hs: -------------------------------------------------------------------------------- 1 | import Code 2 | ------------------------------------------------------------ 3 | -- Examples 4 | 5 | data SExpr = S [SExpr] (Maybe Char) | Atom Char | Quoted [SExpr] (Maybe Char) | Missing | Deleted Char 6 | deriving Show 7 | -- the only place we use disjunction is in many. 8 | 9 | symb = Symb 10 | oops _ = Yuck 11 | pure = Pure 12 | f <$> x = pure f <*> x 13 | (<*>) = (:*:) 14 | (<|>) = (:|:) 15 | x <* y = const <$> x <*> y 16 | 17 | many v = some v <|> pure [] 18 | some v = (:) <$> v <*> many v 19 | 20 | parseExpr = symb 21 | (oops "no input" $ pure Missing) 22 | -- empty 23 | (\c ->case c of 24 | '(' -> S <$> many parseExpr <*> closing ')' 25 | ')' -> oops ("unmatched )") $ pure $ Deleted ')' 26 | c -> pure $ Atom c) 27 | 28 | closing close = symb 29 | (oops "not closed" $ pure Nothing) 30 | -- empty 31 | (\c ->if c == close then pure (Just ')') 32 | else oops ("closed with: " ++ show c) $ pure (Just c) 33 | ) 34 | 35 | eof' = symb (pure ()) (\_ -> oops "eof expected!" eof') 36 | 37 | test = mkProcess (parseExpr <* eof') 38 | 39 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Example0.hs: -------------------------------------------------------------------------------- 1 | import Parsers.Incremental 2 | import Control.Applicative 3 | ------------------------------------------------------------ 4 | -- Examples 5 | 6 | data SExpr = S [SExpr] (Maybe Char) 7 | | Atom Char 8 | | Quoted [SExpr] (Maybe Char) 9 | | Inserted Char 10 | | Deleted Char 11 | deriving Show 12 | -- the only place we use disjunction is in many. 13 | 14 | symb n c = Look (Shif n) (Shif . c) 15 | 16 | manyx v = some v <|> oops "closing..." (pure []) 17 | somex v = (:) <$> v <*> manyx v 18 | 19 | parseExpr = symb 20 | (oops "no input" $ pure (Inserted '?')) 21 | -- empty 22 | (\c ->case c of 23 | '(' -> S <$> many parseExpr <*> closing ')' 24 | ')' -> oops ("unmatched )") $ pure $ Deleted ')' 25 | c -> pure $ Atom c) 26 | 27 | closing close = symb 28 | (oops "not closed" $ pure Nothing) 29 | -- empty 30 | (\c ->if c == close then pure (Just ')') 31 | else oops ("closed with: " ++ show c) $ pure (Just c) 32 | ) 33 | 34 | eof' = symb (pure ()) (\_ -> oops "eof expected!" eof') 35 | 36 | test = mkProcess (parseExpr <* eof') 37 | 38 | -------------------------------------------------------------------------------- /CPSZipper/EvalToAbstract.hs: -------------------------------------------------------------------------------- 1 | -- This follows 2 | 3 | -- "A functional correspondence between 4 | -- evaluators and abstract machines" 5 | -- Mads Sig Ager, Dariusz Biernacki, Olivier Danvy, Jan Midtgaard 6 | 7 | -- 2.1 8 | data Term 9 | = Ind Int 10 | | Abs Term 11 | | App Term Term 12 | 13 | 14 | -- 2.1.1 15 | -- Interpreter as in the paper: 16 | 17 | data EnvVal = Thunk (() -> ExpVal) 18 | data ExpVal = Funct (EnvVal -> ExpVal) 19 | 20 | type Env = [EnvVal] 21 | 22 | eval :: (Term, Env) -> ExpVal 23 | eval (Ind n, e) = let Thunk thunk = e !! n 24 | in thunk () 25 | eval (Abs t, e) = Funct (\v -> eval (t, v:e)) 26 | eval (App t0 t1, e) = let 27 | Funct f = eval (t0, e) 28 | in f (Thunk (\() -> eval (t1,e))) 29 | 30 | 31 | evalClosed t = eval (t, []) 32 | 33 | 34 | 35 | -- Simplified interpreter (no need for thunks in haskell!) 36 | {- 37 | data ExpVal = Funct (ExpVal -> ExpVal) -- Values are functions. 38 | 39 | type Env = [ExpVal] 40 | 41 | eval :: (Term, Env) -> ExpVal 42 | eval (Ind n, e) = e !! n 43 | eval (Abs t, e) = Funct (\v -> eval (t, v:e)) 44 | eval (App t0 t1, e) = let 45 | Funct f = eval (t0, e) 46 | in f (eval (t1,e)) 47 | 48 | evalClosed t = eval (t, []) 49 | 50 | 51 | -} -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Polish2.lhs: -------------------------------------------------------------------------------- 1 | \ignore{ 2 | \begin{code} 3 | {-# LANGUAGE TypeOperators, GADTs #-} 4 | module Choice where 5 | import SExpr 6 | import Stack 7 | import Parser 8 | import Progress 9 | 10 | \end{code} 11 | } 12 | 13 | \begin{code} 14 | data Polish s a where 15 | Push :: a -> Polish s r -> Polish s (a :< r) 16 | App :: Polish s ((b -> a) :< b :< r) 17 | -> Polish s (a :< r) 18 | Done :: Polish s Nil 19 | Shift :: Polish s a -> Polish s a 20 | Sus :: Polish s a -> (s -> Polish s a) 21 | -> Polish s a 22 | Best :: Polish s a -> Polish s a -> Polish s a 23 | Dislike :: Polish s a -> Polish s a 24 | 25 | toP :: Parser s a -> (Polish s r -> Polish s (a :< r)) 26 | toP (Pure x) = Push x 27 | toP (f :*: x) = App . toP f . toP x 28 | toP (Symb a f) = \fut -> Sus (toP a fut) 29 | (\s -> toP (f s) fut) 30 | toP (Disj a b) = \fut -> Best (toP a fut) (toP b fut) 31 | toP (Yuck p) = Dislike . toP p 32 | \end{code} 33 | 34 | 35 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Bidir/Polish2.lhs: -------------------------------------------------------------------------------- 1 | \ignore{ 2 | \begin{code} 3 | {-# LANGUAGE TypeOperators, GADTs #-} 4 | module Choice where 5 | import SExpr 6 | import Stack 7 | import Parser 8 | import Progress 9 | 10 | \end{code} 11 | } 12 | 13 | \begin{code} 14 | data Polish s a where 15 | Push :: a -> Polish s r -> Polish s (a :< r) 16 | App :: Polish s ((b -> a) :< b :< r) 17 | -> Polish s (a :< r) 18 | Done :: Polish s Nil 19 | Shift :: Polish s a -> Polish s a 20 | Sus :: Polish s a -> (s -> Polish s a) 21 | -> Polish s a 22 | Best :: Polish s a -> Polish s a -> Polish s a 23 | Dislike :: Polish s a -> Polish s a 24 | 25 | toP :: Parser s a -> (Polish s r -> Polish s (a :< r)) 26 | toP (Pure x) = Push x 27 | toP (f :*: x) = App . toP f . toP x 28 | toP (Symb a f) = \fut -> Sus (toP a fut) 29 | (\s -> toP (f s) fut) 30 | toP (Disj a b) = \fut -> Best (toP a fut) (toP b fut) 31 | toP (Yuck p) = Dislike . toP p 32 | \end{code} 33 | 34 | 35 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/A.hs: -------------------------------------------------------------------------------- 1 | import Code 2 | import Data.Char 3 | 4 | data Expr = Int Int | Add Expr Expr | Mul Expr Expr | Paren Expr | Err String 5 | deriving Show 6 | 7 | failure = Yuck $ Symb failure (const failure) 8 | eof = Symb unit (const $ Yuck eof) 9 | 10 | many v = some v `Disj` Pure [] 11 | some v = Pure (:) :*: v :*: many v 12 | sepBy1 p s = Pure (:) :*: p :*: many (s *> p) 13 | 14 | expr lvl op c el = please 2 (foldr1 op <$> sepBy1 el (symbol lvl c)) (Err $ "not a " ++ [c] ++ "-expr") 15 | 16 | factors = expr 5 Mul '*' atom 17 | terms = expr 5 Add '+' factors 18 | 19 | int = (Int . read) <$> some (digit 10) 20 | 21 | paren = Paren <$> (symbol 10 '(' *> terms <* symbol 5 ')') 22 | 23 | atom = int <|> paren 24 | 25 | 26 | digit lvl = satisfy lvl (isDigit) '0' 27 | 28 | please lvl p d = p <|> power lvl Yuck (Pure d) 29 | 30 | 31 | satisfy lvl f def = Symb err (\s ->if f s then Pure s else err) 32 | where err = power lvl Yuck $ Pure def 33 | 34 | power 0 f = id 35 | power n f = f . power (n-1) f 36 | 37 | symbol lvl s = satisfy lvl (== s) s 38 | 39 | 40 | unit = Pure () 41 | 42 | (<|>) = Disj 43 | f <$> p = Pure f <*> p 44 | (<*>) = (:*:) 45 | a *> b = Pure (flip const) :*: a :*: b 46 | a <* b = Pure const :*: a :*: b 47 | 48 | 49 | test p = runParser (p <* eof) -------------------------------------------------------------------------------- /Machines/ComposVM.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) JP Bernardy 2008 2 | 3 | {-# OPTIONS -fglasgow-exts -Wall #-} 4 | import Control.Applicative 5 | 6 | data Void 7 | 8 | -- Code for the machine 9 | data Steps r where 10 | X :: (r -> r') -> Steps r -> Steps r' 11 | Done :: Steps Void 12 | 13 | 14 | -- | Right-eval with input 15 | evalR :: Steps r -> r 16 | evalR (X f r) = f (evalR r) 17 | evalR Done = error "VM stack overflow" 18 | 19 | -- | Pre-compute a left-prefix of some steps (as far as possible) 20 | evalL :: Steps a -> Steps a 21 | evalL (X f (X g s)) = evalL (X (f . g) s) 22 | evalL x = x 23 | 24 | 25 | -- Translating applicative language into the codes. 26 | 27 | -- The data will be a stack that we can transform. 28 | data a :< b = (:<) { hd :: a, tl :: b } 29 | 30 | infixr :< 31 | 32 | apply :: Steps ((b -> a) :< b :< r) -> Steps (a :< r) 33 | apply = X $ \(f :< ~(a :< r)) -> f a :< r 34 | 35 | push :: a -> Steps r -> Steps (a :< r) 36 | push a = X (a :<) 37 | 38 | newtype P s a = P {fromP :: forall r. Steps r -> Steps (a :< r)} 39 | 40 | instance Functor (P s) where 41 | fmap f x = pure f <*> x 42 | 43 | instance Applicative (P s) where 44 | P f <*> P x = P (\fut -> (apply (f (x fut)))) 45 | pure x = P (\fut -> push x $ fut) 46 | 47 | 48 | data Zip b where 49 | Zip :: (a -> b) -> Steps a -> Zip b 50 | 51 | 52 | right :: Zip b -> Zip b 53 | right (Zip f (X g r)) = Zip (f . g) r 54 | right z = z 55 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/progress.dot: -------------------------------------------------------------------------------- 1 | 2 | 3 | digraph progress { 4 | rankdir=LR; 5 | ranksep=0.35; 6 | size=5; 7 | node [fontsize=10,shape=circle,fixedsize = true, width = 0.5]; 8 | node [style=filled, color=lightgrey]; 9 | c4a; c5a; c4b; 10 | node [style=solid,color=black]; 11 | c0 [label = "Shift"]; 12 | c1 [label = "Dislike"]; 13 | c2 [label = "Dislike"]; 14 | c3 [label = "Best"]; 15 | c4a [label = "Dislike"]; 16 | c5a [label = "Done"]; 17 | c4b [label = "Shift"]; 18 | c5b [label = "Dislike"]; 19 | c6b [label = "Shift"]; 20 | c7b [label = "Done"]; 21 | c0 -> c1 -> c2 -> c3 -> c4a -> c5a; 22 | c3 -> c4b -> c5b -> c6b -> c7b; 23 | 24 | // Progress info 25 | node [shape=filled,color=white,height=0.2] // rectangle 26 | edge [minlen=0,style=dotted,arrowtail=none,headport=n,tailport=s,arrowhead=none] 27 | 28 | 29 | p5a [label = "D 0"]; 30 | c5a -> p5a; 31 | 32 | p4a [label = "D 1"]; 33 | c4a -> p4a; 34 | 35 | p7b [label = "D 0"]; 36 | c7b -> p7b 37 | 38 | p6b [label = "0\\prog{}D 0"]; 39 | c6b -> p6b 40 | 41 | p5b [label = "1\\prog{}D 1"]; 42 | c5b -> p5b 43 | 44 | p4b [label = "0\\prog{}1\\prog{}D 1"]; 45 | c4b -> p4b 46 | 47 | p3 [label = "0\\prog{}1\\prog{}D 1"]; 48 | c3 -> p3; 49 | 50 | p2 [label = "1\\prog{}2\\prog{}D 2"]; 51 | c2 -> p2; 52 | 53 | p1 [label = "2\\prog{}3\\prog{}D 3"]; 54 | c1 -> p1; 55 | 56 | p0 [label = "0\\prog{}2\\prog{}3\\prog{}D 3"]; 57 | c0 -> p0; 58 | 59 | 60 | } 61 | 62 | 63 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Makefile: -------------------------------------------------------------------------------- 1 | %.view: %.html 2 | firefox $< 3 | 4 | %.pdf: %.svg 5 | inkscape --export-pdf=$@ $< 6 | # convert $< $@ 7 | 8 | Paper.pdf: begin.pdf mid.pdf progress.tex pgf-tree.tex 9 | Paper.tex: SExpr.lhs Stack.lhs Applicative.lhs Input.lhs Choice.lhs Sublinear.lhs Code.lhs Full.lhs Example.lhs 10 | 11 | test: 12 | ghc --make Full 13 | ./Full 14 | 15 | checks: 16 | ghc -c Code.lhs 17 | ghc -c SExpr.lhs 18 | ghc -c Stack.lhs 19 | ghc -c Applicative.lhs 20 | ghc -c Parser.lhs 21 | ghc -c Progress.lhs 22 | ghc -c Input.lhs 23 | ghc -c Choice.lhs 24 | ghc -c Sublinear.lhs 25 | ghc -c Polish2.lhs 26 | ghc -c Example.lhs 27 | ghc -c Code.lhs 28 | ghc -c Full.lhs 29 | 30 | %.html: %.markdown 31 | pandoc --smart --standalone --css=home.css --from=markdown --to=html --output=$@ $< 32 | 33 | %.direct.tex: %.markdown 34 | pandoc --smart --standalone --from=markdown --to=latex --output=$@ $< 35 | 36 | %.lhs: %.markdown 37 | pandoc --smart --standalone --from=markdown --to=latex+lhs --output=$@ $< 38 | 39 | %.tex: %.lhs 40 | lhs2TeX $< > $@ 41 | 42 | 43 | %.fig: %.dia 44 | dia -e $@ $< 45 | 46 | %.tex: %.dia 47 | dia -e $@ $< 48 | 49 | %.ps: %.dot 50 | dot -Tps $< -o $@ 51 | 52 | %.tex: %.dot 53 | dot -Txdot $< | dot2tex --texmode=raw --figonly > $@ 54 | # dot2tex --preproc $< | dot2tex --figonly > $@ 55 | 56 | %.pdf: %.tex 57 | pdflatex $< 58 | bibtex $* 59 | pdflatex $< 60 | pdflatex $< 61 | 62 | 63 | 64 | -------------------------------------------------------------------------------- /PolyTest/Implementation/FD.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, EmptyDataDecls, GADTs, TypeOperators, FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies #-} 2 | 3 | data True = T 4 | data False 5 | 6 | type Nat = Int -- sic. 7 | 8 | data Equals a b where 9 | Refl :: Equals a a 10 | 11 | -- type family Occurs a b :: * 12 | -- type instance (a ~ b) => Occurs a b = True 13 | 14 | data A 15 | 16 | 17 | newtype Fix f = In { out :: f (Fix f)} 18 | 19 | data Z1 a 20 | data Id a = Id a 21 | data K x a = K x 22 | data (f :+: g) a = L1 (f a) | L2 (g a) 23 | data (f :*: g) a = f a :*: g a 24 | 25 | class OneArg t where 26 | type OneArgF t :: * -> * 27 | 28 | 29 | 30 | 31 | 32 | instance OneArg (f -> A) where 33 | 34 | 35 | class AFunctor t (aFunctor :: * -> *) | t -> aFunctor where 36 | 37 | instance AFunctor A Id where 38 | 39 | instance AFunctor k (K k) where 40 | 41 | -- instance AFunctor (Either a b) where 42 | -- type AFunctorF (Either a b) = AFunctorF a :+: AFunctorF b 43 | 44 | 45 | 46 | class PolyTestable t where 47 | type ExtractedFunctor t :: * -> * 48 | -- type MonoType t :: * 49 | 50 | -- toMonoTest :: t -> MonoType t 51 | 52 | 53 | instance (PolyTestable res, OneArg arg) => PolyTestable (arg -> res) where 54 | type ExtractedFunctor (arg -> res) = OneArgF arg :*: ExtractedFunctor res 55 | 56 | instance PolyTestable A where 57 | type ExtractedFunctor A = Z1 58 | 59 | f :: a -> a 60 | f = undefined 61 | 62 | 63 | -------------------------------------------------------------------------------- /Machines/SuspensionAM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# OPTIONS -fglasgow-exts #-} 3 | 4 | import Control.Applicative 5 | 6 | 7 | data Ter a where 8 | Lam :: (Ter a -> Ter b) -> Ter (a -> b) 9 | App :: Ter (a -> b) -> Ter a -> Ter b 10 | Con :: a -> Ter a 11 | 12 | data Term a where 13 | Lamb :: State t -> (Term a -> Term b) -> Term (a -> b) 14 | Appl :: State t -> Term (a -> b) -> Term a -> Term b 15 | Cons :: State t -> a -> Term a 16 | 17 | 18 | the current arg will be put in a lam; entered later. 19 | --> need to remember where to store the state upon entering the arg. 20 | --> this is the rhs of the Appl. 21 | 22 | cbnExec :: State t -> t 23 | cbnExec (State (App t1 t2) s) = cbnExec (State t1 (Cons t2 s)) 24 | cbnExec (State (Lam f) (Cons a s)) = cbnExec (State (f a) s) 25 | cbnExec (State (Lam f) Nil) = \x -> cbnExec (State (f (Con x)) Nil) 26 | -- this is a rule that cannot be in the untyped version. 27 | cbnExec (State (Con x) s) = app x s 28 | 29 | 30 | 31 | instance Functor Term where 32 | fmap f = (pure f <*>) 33 | 34 | instance Applicative Term where 35 | pure = Con 36 | (<*>) = App 37 | 38 | 39 | ---------------------------- 40 | -- Direct evaluation 41 | 42 | eval :: Term t -> t 43 | eval (App t1 t2) = eval t1 (eval t2) 44 | eval (Lam f) = \x -> eval (f (Con x)) 45 | eval (Con x) = x 46 | 47 | 48 | 49 | instance Monad Term where 50 | return = Con 51 | k >>= f = f (eval k) 52 | 53 | 54 | 55 | 56 | 57 | 58 | -------------------------------------------------------------------------------- /log/20081020.markdown: -------------------------------------------------------------------------------- 1 | Down the rabbit hole! 2 | 3 | 1. Let's try to CPS the shit 4 | Whoops. I used CPS cbv... It's strict alright. 5 | 6 | 2. I don't have the guts to find the correct transform; 7 | AND it's probably not going to work anyway: doing one step 8 | of computation will always require to do some pattern matching 9 | (was this a suspension?). Probably 10 | 11 | 3. I guess I have to represent the computation explicitly, and 12 | do partial evaluation by hand. Back into the wonderful realm of 13 | abstract machines. 14 | 15 | Brain explodes; let's go back to good ol' parsers. 16 | 17 | 3': (Intermission) Oh yeah... I /do/ represent the computation in my Steps type, 18 | it's just hand-taylored computation for parsing. 19 | 20 | 4. I want to have a freakin' monadic interface for my parsers. 21 | Re-read relevant section in Polish Parsers. re-re-re-re-re-read. Does not make sense!!! 22 | Test. Fail. 23 | 24 | Read Doaitse stuff: The cunning wizard had found out already. Implement the Horizon/Future 25 | parsers using my own progress data type. It works. It looks like the shit is compatible 26 | with my generalized error correction stuff. Great! 27 | 28 | 5. Doaitse has the same "stack" representation as I got in my agda version. I get it now! 29 | I never figured you could do it in Haskell! This means I can port back all my agda stuff! 30 | AND I can use the "almost tail recursive version of evalR" 31 | 32 | 6. This pro'lly means I can do the evalL and evalL stuff in // to tie them up. Back to work! 33 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/SExpr.lhs: -------------------------------------------------------------------------------- 1 | \ignore{ 2 | 3 | \begin{code} 4 | module SExpr where 5 | import Control.Applicative 6 | import Data.Tree 7 | \end{code} 8 | 9 | } 10 | 11 | \begin{code} 12 | data SExpr = S [SExpr] | Atom Char 13 | \end{code} 14 | 15 | \ignore{ 16 | 17 | data SExpr = S [SExpr] (Maybe Char) | Atom Char | Quoted [SExpr] (Maybe Char) | Inserted Char | Deleted Char 18 | 19 | showS _ (Atom c) = [c] 20 | showS ([open,close]:ps) (S cl) = open : concatMap (showS ps) s ++ [close] 21 | 22 | instance Show SExpr where 23 | show = showS (cycle ["()","[]","{}"]) 24 | 25 | parseList :: Parser Char [SExpr] 26 | parseList = Symb 27 | (Pure []) 28 | (\c -> case c of 29 | ' ' -> parseList -- ignore spaces 30 | '(' -> Pure (\h t -> S h : t) :*: parseList :*: parseList 31 | c -> Pure (Atom c :) :*: parseList) 32 | 33 | 34 | ----- 35 | 36 | 37 | data SExpr = Cons SExpr SExpr | Leaf Char | Tip 38 | deriving Show 39 | 40 | eof = case_ (pure ()) (error "expected eof") 41 | 42 | readSExpr :: P Char SExpr 43 | readSExpr = case_ (error "unexpected end of input") $ 44 | \s -> case s of 45 | ':' -> Cons <$> readSExpr <*> readSExpr 46 | '.' -> pure Tip 47 | c -> pure $ Leaf c 48 | 49 | 50 | toForest (Cons l r) = toTree l : toForest r 51 | toForest (Leaf c) = [Node [c] []] 52 | toForest Tip = [] 53 | 54 | toTree (Leaf c) = Node [c] [] 55 | toTree t = Node "*" (toForest t) 56 | 57 | sampleInput = ":a:b::c:d:e.:f:g:h.asdfs" 58 | sampleResult = -- drawForest $ toForest $ 59 | hd $ evalR sampleInput $ fromP ((,) <$> readSExpr <*> eof) Done 60 | 61 | 62 | } -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Bidir/SExpr.lhs: -------------------------------------------------------------------------------- 1 | \ignore{ 2 | 3 | \begin{code} 4 | module SExpr where 5 | import Control.Applicative 6 | import Data.Tree 7 | \end{code} 8 | 9 | } 10 | 11 | \begin{code} 12 | data SExpr = S [SExpr] | Atom Char 13 | \end{code} 14 | 15 | \ignore{ 16 | 17 | data SExpr = S [SExpr] (Maybe Char) | Atom Char | Quoted [SExpr] (Maybe Char) | Inserted Char | Deleted Char 18 | 19 | showS _ (Atom c) = [c] 20 | showS ([open,close]:ps) (S cl) = open : concatMap (showS ps) s ++ [close] 21 | 22 | instance Show SExpr where 23 | show = showS (cycle ["()","[]","{}"]) 24 | 25 | parseList :: Parser Char [SExpr] 26 | parseList = Symb 27 | (Pure []) 28 | (\c -> case c of 29 | ' ' -> parseList -- ignore spaces 30 | '(' -> Pure (\h t -> S h : t) :*: parseList :*: parseList 31 | c -> Pure (Atom c :) :*: parseList) 32 | 33 | 34 | ----- 35 | 36 | 37 | data SExpr = Cons SExpr SExpr | Leaf Char | Tip 38 | deriving Show 39 | 40 | eof = case_ (pure ()) (error "expected eof") 41 | 42 | readSExpr :: P Char SExpr 43 | readSExpr = case_ (error "unexpected end of input") $ 44 | \s -> case s of 45 | ':' -> Cons <$> readSExpr <*> readSExpr 46 | '.' -> pure Tip 47 | c -> pure $ Leaf c 48 | 49 | 50 | toForest (Cons l r) = toTree l : toForest r 51 | toForest (Leaf c) = [Node [c] []] 52 | toForest Tip = [] 53 | 54 | toTree (Leaf c) = Node [c] [] 55 | toTree t = Node "*" (toForest t) 56 | 57 | sampleInput = ":a:b::c:d:e.:f:g:h.asdfs" 58 | sampleResult = -- drawForest $ toForest $ 59 | hd $ evalR sampleInput $ fromP ((,) <$> readSExpr <*> eof) Done 60 | 61 | 62 | } -------------------------------------------------------------------------------- /CPSZipper/CBNCPS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification, RankNTypes #-} 2 | 3 | data Expr = ConstE Int | AddE Expr Expr | NegE Expr 4 | 5 | data Code = Push Int | Add | Neg | Seq Code Code 6 | 7 | comp :: Expr -> Code 8 | comp (ConstE n) = Push n 9 | comp (NegE e) = Seq (comp e) Neg 10 | comp (AddE e1 e2) = Seq (comp e1) (Seq (comp e2) Add) 11 | 12 | intStack :: Code -> Int 13 | intStack i = head (int' i []) 14 | where 15 | int' (Push n) s = n :s 16 | int' Neg (n:s) = (negate n) : s 17 | int' Add (n : m : s) = (m + n) : s 18 | int' (Seq i1 i2) s = int' i2 (int' i1 s) 19 | 20 | intExp e = intStack (comp e) 21 | 22 | example = AddE (ConstE 5) (ConstE 3) 23 | 24 | test = intExp example 25 | 26 | 27 | -- CBN CPS 28 | 29 | data Code' = Push' Int | Add' | Neg' 30 | | Seq' (forall a. (Code' -> a) -> a) (forall a. (Code' -> a) -> a) 31 | 32 | comp' :: forall a. Expr -> (Code' -> a) -> a 33 | comp' (ConstE n) k = k (Push' n) 34 | comp' (NegE e) k = k (Seq' (comp' e) (\k -> k Neg')) 35 | comp' (AddE e1 e2) k = k (Seq' (comp' e1) (\k -> k (Seq' (comp' e2) (\k -> k Add')))) 36 | 37 | intStack' :: (forall a. (Code' -> a) -> a) -> Int 38 | intStack' i = head (int' i []) 39 | where 40 | int' :: (forall a. (Code' -> a) -> a) -> [Int] -> [Int] 41 | int' i s = i $ \v -> case (v,s) of 42 | (Push' n , s ) -> n :s 43 | (Neg' , (n:s) ) -> (negate n) : s 44 | (Add' , (n : m : s) ) -> (m + n) : s 45 | ((Seq' i1 i2), s ) -> int' i2 (int' i1 s) 46 | 47 | 48 | intExp' e = intStack' (comp' e) 49 | 50 | -- example = AddE (ConstE 5) (ConstE 3) 51 | -- 52 | -- test = intExp example 53 | 54 | 55 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/pgf-tree.tex: -------------------------------------------------------------------------------- 1 | \begin{tikzpicture}[very thick, 2 | % Label style 3 | % label distance=3mm, 4 | % every label/.style={blue}, 5 | % Children and edges style 6 | % edge from parent/.style={draw=black!70}, 7 | % edge from parent path={(\tikzparentnode.south) % -- ++(0,-1.05cm) 8 | % -- (\tikzchildnode.north)}, 9 | level 1/.style={% sibling distance=7cm, 10 | level distance=1.4cm} 11 | % growth parent anchor=south} 12 | % level 2/.style={sibling distance=2.8cm}, 13 | % level 3/.style={sibling distance=1.4cm}, 14 | % level 4/.style={sibling distance=1.4cm} 15 | %% For compatability with PGF CVS add the absolute option: 16 | % absolute 17 | ] 18 | % \tikzstyle{} 19 | \tikzstyle{every node}=[circle,draw,minimum size=6mm,inner sep=0pt,text centered] 20 | \node (n1) {1} 21 | child{node (n2) {2}} 22 | ; 23 | 24 | \node (n3) [right=of n1] {3} edge (n1) 25 | child{node (n4) {4} 26 | child{node (n5) {5}} 27 | child{node (n6) {6}} 28 | } 29 | ; 30 | 31 | \tikzstyle{level 2}=[sibling distance=3cm] 32 | \tikzstyle{level 3}=[sibling distance=1.5cm] 33 | \node at (5,0) (n7) {7} edge (n3) 34 | child{node (n8) {8} 35 | child{node (n9) {9} 36 | child{node (n10) {10}} 37 | child{node (n11) {11}} 38 | } 39 | child{node (n12) {12} 40 | child{node (n13) {13}} 41 | child{node (n14) {14}} 42 | } 43 | } 44 | ; 45 | 46 | \node [coordinate] at (7,0) (n15) {} edge [dashed](n7); 47 | 48 | 49 | \end{tikzpicture} 50 | 51 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Outline.markdown: -------------------------------------------------------------------------------- 1 | % Functional Incremental Parsing 2 | % Jean-Philippe Bernardy 3 | 4 | Questions: can we use function composition? 5 | 6 | # Introduction 7 | 8 | Problem we solve: 9 | 10 | functions 11 | * parse : String -> t 12 | * view : t -> String 13 | 14 | Additional hypothesis: 15 | * the user observes a small portion of the output at a time (window) 16 | * the window moves by small steps. 17 | * the view function has online behaviour as well. 18 | 19 | 20 | Result: 21 | Incremental modifications of input should incur incremental re-computations of 22 | the output. 23 | 24 | 25 | 26 | ## Outline 27 | 28 | * Lazy evaluation solves half of the problem 29 | * Solving the other half 30 | * evaluating and caching partial results 31 | * get rid of inefficiencies due to naive usage of linear structures 32 | 33 | # Representing online computations: polish expressions 34 | 35 | # Polish expressions with suspensions 36 | 37 | # Efficient evaluation of intermediate states: Zipping through polish expressions 38 | 39 | # Parsing: disjunction and error correction 40 | 41 | # Getting rid of linear operations 42 | 43 | ## Directly jumping at the correct place in the output 44 | ## Efficient representation of output 45 | ## Directly jumping at the correct position in the cached states 46 | ## Efficient representation of intermediate structures 47 | 48 | # Related work 49 | 50 | * Polish parsers 51 | * Attribute grammars 52 | : Attribute grammars are best suited for synthesis of information; our system to create it. 53 | * Carlsson's recomputations 54 | * All the incremental computing stuff 55 | 56 | # Conclusion 57 | 58 | 59 | Advantages: the user code does not need to specify caching points; caching points are dependent on the input. 60 | -------------------------------------------------------------------------------- /CPSZipper/Map.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | list = [1..5] 3 | 4 | -------- 5 | -- Direct 6 | 7 | mapD f [] = [] 8 | mapD f (x:xs) = f x : mapD f xs 9 | 10 | testD = mapD succ list 11 | 12 | -------- 13 | -- CPS0 14 | 15 | succC n k = k (n + 1) 16 | 17 | mapC f [] k = k [] 18 | mapC f (x:xs) k = 19 | (f x) $ \a -> 20 | (mapC f xs) $ \b -> 21 | k (a : b) 22 | 23 | testC = mapC succC list 24 | 25 | -------- 26 | -- CPS1 27 | 28 | mapC1 f [] k = k [] 29 | mapC1 f (x:xs) k = 30 | (mapC1 f xs) $ \b -> 31 | k (f x : b) 32 | 33 | testC1 = mapC1 succ list 34 | 35 | -------------- 36 | -- CPS2: put arguments in better order 37 | 38 | mapC2 :: (t -> a) -> ([a] -> b) -> [t] -> b 39 | mapC2 = \f -> \k -> \l -> case l of 40 | [] -> k [] 41 | (x:xs) -> mapC2 f (\b -> k (f x : b)) xs 42 | 43 | testC2 = mapC2 succ id list 44 | 45 | 46 | 47 | 48 | --------------- 49 | -- Defun CPS2 50 | 51 | rec :: ([a] -> t) -> [a] -> t 52 | rec k [] = k [] 53 | rec k (x:xs) = rec (\b -> k (x : b)) xs 54 | 55 | 56 | {- 57 | data LamF1 a t where 58 | LamF1 :: ([a] -> t) -> a -> LamF1 a t -- (\b -> k (x : b)) 59 | 60 | aux :: LamF1 a t -> [a] -> t 61 | aux (LamF1 k x) b = k (x : b) 62 | 63 | mp k [] = k [] 64 | mp k (x:xs) = mp (aux (LamF1 k x)) xs 65 | 66 | -} 67 | 68 | -- but!!!! 69 | rec' :: ([a] -> [a]) -> ([a] -> [a]) 70 | rec' k [] = k [] 71 | rec' k (x:xs) = rec' (\b -> k (x : b)) xs 72 | 73 | mp' = rec' id 74 | 75 | data ListFun a where -- defunctionalized list functions 76 | Id :: ListFun a 77 | CompCons :: ListFun a -> a -> ListFun a 78 | 79 | appFun :: ListFun a -> [a] -> [a] 80 | appFun (CompCons k x) b = appFun k (x : b) -- (\b -> k (x : b)) 81 | appFun (Id) b = b 82 | 83 | mp :: ListFun a -> [a] -> [a] 84 | mp k [] = appFun k [] 85 | mp k (x:xs) = mp (CompCons k x) xs 86 | 87 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/scratchpad: -------------------------------------------------------------------------------- 1 | \subsection{Example} 2 | 3 | \textmeta{The example here is not properly used: we do not do anything with it!} 4 | 5 | For the purpose of illustration, we sketch how the technique works on a simple 6 | problem: interactive feedback of parenthesis matching for a LISP-like language. 7 | This example is developped throughout the paper. Given an input such as \verb!(+ 8 | 1 (* 5 (+ 3 4)) 2)!, the program will display an annotated version: \verb!(+ 1 9 | {* 5 [+ 3 4]} 2)!. The idea is that matching pairs are displayed using different 10 | parenthetical symbols for each level, making the extent of each sub-expression 11 | more apparent. 12 | 13 | The production of the output is a two-phase process. First, the AST 14 | is produced, by parsing the input. A value of the |SExpr| type 15 | is constructed. Second, it is linearized back and 16 | printed to the user. 17 | 18 | % %include SExpr.lhs 19 | 20 | 21 | In an interactive system, a lazy evaluation strategy provides a 22 | special form of incremental computation: the amount of output that 23 | is demanded drives the computation to be performed. In other words, 24 | the system responds to incremental movements of the portion of the 25 | output being viewed by the user (window) by incremental computation 26 | of the intermediate structures. 27 | 28 | The above observation suggests that we can take advantage of lazy evaluation to 29 | implement incremental parsing for a text editor. 30 | Indeed, if we suppose that the user makes changes in the part of the input that 31 | ``corresponds to'' the window being viewed, it suffices to cache 32 | partially computed results for each point in the input, to obtain a 33 | system that responds to changes in the input independently of the 34 | total size of that input. 35 | 36 | 37 | 38 | 39 | -------------------------------------------------------------------------------- /TransDistr/Distr.hs: -------------------------------------------------------------------------------- 1 | import Control.Exception (assert) 2 | 3 | import Data.Array 4 | 5 | type Matrix a = Array (Int,Int) a 6 | type Vector a = Array Int a 7 | type Graph = Matrix Bool 8 | 9 | constV n x = listArray (1,n) (repeat x) 10 | 11 | mul :: Num a => Matrix a -> Vector a -> Vector a 12 | mul m v = array (1,b) [(j,sum [m!(i,j) * v!i | i <- [1..a]]) | j <- [1..b]] 13 | where ((1,1),(a,b)) = bounds m 14 | (1,a') = bounds v 15 | p = assert (a == a') "dimensions must match" 16 | 17 | simul :: (Num a) => Matrix a -> Vector a -> [Vector a] 18 | simul m = iterate (mul m) 19 | 20 | degree :: Graph -> Int -> Int 21 | degree g i = length [() | j <- [1..b], g!(i,j) ] 22 | where ((1,1),(_,b)) = bounds g 23 | 24 | metropolis :: (Fractional p, Ord p) => Graph -> Vector p -> Matrix p 25 | metropolis g pi = listArray bnds $ map p (range bnds) 26 | where p (i,j) | i /= j = if g!(i,j) then min 1 ((pi!j * d i)/(pi!i * d j) ) / d i 27 | else 0 28 | | i == j = 1 - sum [p (i,l) | l <- [1..b], l /= i] 29 | d = fromIntegral . degree g 30 | bnds@((1,1),(_,b)) = bounds g 31 | 32 | 33 | 34 | 35 | -- r l u r' w 36 | test = {- r -} [[ 1, 1, 0, 0, 0] 37 | {- l -} ,[ 0, 0, 1, 1, 1] 38 | {- u -} ,[ 1, 1, 0, 0, 0] 39 | {- r'-} ,[ 0, 0, 1, 1, 1] 40 | {- w -} ,[ 0, 0, 1, 1, 1] 41 | ] 42 | 43 | testG = listArray bnds [ind(test?i?j) | (i,j) <- range bnds ] 44 | where bnds = ((1,1),(5,5)) 45 | (x:_) ? 1 = x 46 | (_:xs) ? n = xs ? (n-1) 47 | ind 0 = False 48 | ind 1 = True 49 | 50 | -- resP = metropolis testG (constV 5 (1 / 5)) 51 | resP = metropolis testG (listArray (1,5) $ norm [1,1,1,1,10]) 52 | 53 | 54 | norm l = map (/ sum l) l 55 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Bidir/Example.lhs: -------------------------------------------------------------------------------- 1 | \ignore{ 2 | \begin{code} 3 | {-# LANGUAGE TypeOperators, GADTs #-} 4 | module Example where 5 | import Code 6 | \end{code} 7 | } 8 | 9 | First, we can define repetition and sequence in the traditional way: 10 | 11 | 12 | \begin{code} 13 | 14 | data BList a = BList ([a] -> [a]) [a] 15 | cons x ~(BList l r) = BList l (x:r) 16 | cons' x ~(BList l r) = BList ((x:).l) r 17 | nil = BList id [] 18 | 19 | toList ~(BList l r) = reverse (l []) ++ r 20 | 21 | many v = some v `Disj` pure nil 22 | some v = Pure2 cons' cons :*: v :*: many v 23 | \end{code} 24 | 25 | Checking for the end of file can be done as follows. Notice that if 26 | the end of file is not encountered, we keep parsing the input, but 27 | complain while doing so. 28 | 29 | \begin{code} 30 | eof = Symb (pure ()) (\_ -> Yuck eof) 31 | \end{code} 32 | 33 | Checking for a specific symbol can be done in a similar way: we 34 | accept anything but be reluctant to get anything unexpected. 35 | 36 | \begin{code} 37 | pleaseSymbol s = Symb 38 | (Yuck $ pure Nothing) 39 | (\s' ->if s == s' then pure (Just ')') 40 | else Yuck $ pure (Just s')) 41 | \end{code} 42 | 43 | All of the above can be combined to write the parser for s-expressions. 44 | Note that we need to amend the result type to accomotate for erroneous inputs. 45 | 46 | \begin{code} 47 | 48 | data SExpr 49 | = S (BList SExpr) (Maybe Char) 50 | | Atom Char 51 | | Missing 52 | | Deleted Char 53 | 54 | type Top = BList SExpr 55 | 56 | 57 | 58 | parseExpr = Symb 59 | (Yuck $ pure Missing) 60 | (\c ->case c of 61 | '(' -> pure S :*: parseList :*: pleaseSymbol ')' 62 | ')' -> Yuck $ pure $ Deleted ')' 63 | c -> pure $ Atom c) 64 | 65 | parseList = many parseExpr 66 | 67 | parseTopLevel 68 | = pure const :*: parseList :*: eof 69 | \end{code} 70 | 71 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Example.lhs.bak: -------------------------------------------------------------------------------- 1 | \ignore{ 2 | \begin{code} 3 | {-# LANGUAGE TypeOperators, GADTs #-} 4 | module Example where 5 | import Code 6 | \end{code} 7 | } 8 | 9 | In this section we rewrite our parser for s-expr of section \ref{sec:input} 10 | using disjunction. The goal is to obtain a more modular description. 11 | 12 | 13 | First, we can define repetition and sequence in the traditional way: 14 | 15 | \begin{code} 16 | many v = some v `Disj` Pure [] 17 | some v = Pure (:) :*: v :*: many v 18 | \end{code} 19 | 20 | Checking for the end of file can be done as follows. Notice that if 21 | the end of file is not encountered, we keep parsing the input, but 22 | complain while doing so. 23 | 24 | \begin{code} 25 | eof = Symb (Pure ()) (\_ -> Yuck eof) 26 | \end{code} 27 | 28 | Checking for a specific symbol can be done in a similar way: we 29 | accept anything but be reluctant to get anything unexpected. 30 | 31 | \begin{code} 32 | pleaseSymbol s = Symb 33 | (Yuck $ Pure Nothing) 34 | (\s' ->if s == s' then Pure (Just ')') 35 | else Yuck $ Pure (Just s')) 36 | \end{code} 37 | 38 | All of the above can be combined to write the parser for s-expressions. 39 | Note that we need to amend the result type to accomotate for erroneous inputs. 40 | 41 | \begin{code} 42 | 43 | data SExpr 44 | = S [SExpr] (Maybe Char) 45 | | Atom Char 46 | | Missing 47 | | Deleted Char 48 | 49 | parseExpr = Symb 50 | (Yuck $ Pure Missing) 51 | (\c ->case c of 52 | '(' -> Pure S :*: many parseExpr :*: pleaseSymbol ')' 53 | ')' -> Yuck $ Pure $ Deleted ')' 54 | c -> Pure $ Atom c) 55 | 56 | parseTopLevel 57 | = Pure const :*: parseExpr :*: eof 58 | \end{code} 59 | 60 | 61 | We have seen that the constructs introduced in this section (|Disj|, |Yuck|) 62 | permit to write general purpose derived combinators, such as |many|, in a 63 | traditional style. 64 | 65 | -------------------------------------------------------------------------------- /CPSZipper/List.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, RankNTypes #-} 2 | 3 | data Tree a where 4 | Cat :: Tree a -> Tree a -> Tree a 5 | Unit :: a -> Tree a 6 | 7 | append [] ys = ys 8 | append (x:xs) ys = x : append xs ys 9 | 10 | 11 | toList :: Tree a -> [a] 12 | toList (Unit a) = a : [] 13 | toList (Cat l r) = toList l ++ toList r 14 | 15 | (+++) :: (([a] -> [a]) -> [a]) -> (([a] -> [a]) -> [a]) -> [a] 16 | f +++ g = undefined 17 | 18 | 19 | appendCBNCPS :: [t] -> [t] -> (forall b. ([t] -> b) -> b) 20 | appendCBNCPS [] ys k = k ys 21 | appendCBNCPS (x:xs) ys k = k (appendCBNCPS xs ys) (x :) 22 | 23 | toListCBNCPS :: Tree a -> ([a] -> [a]) -> [a] 24 | toListCBNCPS (Unit a) k = k [a] 25 | toListCBNCPS (Cat l r) k = k ((+++) (toListCBNCPS l) (toListCBNCPS r)) 26 | 27 | toListCBNCPS' t = toListCBNCPS t id 28 | 29 | 30 | 31 | 32 | 33 | toListCBVCPS :: Tree a -> ([a] -> b) -> b 34 | toListCBVCPS (Unit a) k = k [a] 35 | toListCBVCPS (Cat l r) k = 36 | toListCBVCPS l $ \x1 -> 37 | toListCBVCPS r $ \x2 -> 38 | -- k (x1 ++ x2) 39 | appendCBVCPS x1 x2 k 40 | 41 | 42 | toListCBVCPS' t = toListCBVCPS t id 43 | 44 | 45 | 46 | appendCBVCPS :: [t] -> [t] -> (forall b. ([t] -> b) -> b) 47 | appendCBVCPS [] ys k = k ys 48 | appendCBVCPS (x:xs) ys k = appendCBVCPS xs ys $ \zs -> k (x : zs) 49 | 50 | 51 | -- let b = [a] 52 | 53 | type K a = [a] -> [a] 54 | 55 | data Lam a = Id | Lam1 (Lam a) (Tree a) | Lam2 (Lam a) [a] 56 | 57 | toListCBVCPSDefun :: Tree a -> Lam a -> [a] 58 | toListCBVCPSDefun (Unit a) k = apply k [a] 59 | toListCBVCPSDefun (Cat l r) k = toListCBVCPSDefun l (Lam1 k r) 60 | 61 | apply :: Lam a -> [a] -> [a] 62 | apply (Lam1 k r) x1 = toListCBVCPSDefun r (Lam2 k x1) 63 | apply (Lam2 k x1) x2 = apply k (x1 ++ x2) 64 | apply Id x1 = x1 65 | 66 | toListCBVCPSDefun' t = toListCBVCPSDefun t Id 67 | 68 | 69 | 70 | 71 | realToList :: Tree a -> ([a] -> [a]) 72 | realToList (Cat l r) = \k -> realToList l (realToList r k) 73 | realToList (Unit a) = \k -> a : k 74 | -------------------------------------------------------------------------------- /CPSZipper/Dissect.agda: -------------------------------------------------------------------------------- 1 | module Dissect where 2 | 3 | -- Copied directly from McBride's Jokers & Clowns. 4 | 5 | -- Constant functor 6 | data K1 a x = K1 a 7 | data (p :+ q) x = L1 (p x) | R1 (q x) 8 | data (p :* q) x = (p x) :* (q x) 9 | 10 | -- Identity functor ? 11 | data Id a = Id a 12 | 13 | -- Constant bifunctor 14 | data K2 a x y = K2 a 15 | 16 | data Fst x y = Fst x 17 | data Snd x y = Snd y 18 | 19 | -- Sum bifunctor 20 | data (p :++ q) x y = L2 (p x y) | R2 (q x y) 21 | 22 | -- Product bifunctor 23 | data (p :** q) x y = (p x y) :** (q x y) 24 | 25 | type T12 = K2 () 26 | 27 | class Bifunctor p where 28 | bimap :: (s1 -> t1) -> (s2 -> t2) -> p s1 s2 -> p t1 t2 29 | 30 | instance Bifunctor (K2 a) where 31 | bimap f g (K2 a) = K2 a 32 | 33 | instance Bifunctor Fst where 34 | bimap f g (Fst x) =Fst (f x) 35 | 36 | instance Bifunctor Snd where 37 | bimap f g (Snd y) = Snd (g y) 38 | 39 | instance (Bifunctor p,Bifunctor q) => Bifunctor (p :++ q) where 40 | bimap f g (L2 p) =L2 (bimap f g p) 41 | bimap f g (R2 q) =R2 (bimap f g q) 42 | 43 | instance (Bifunctor p,Bifunctor q) => Bifunctor (p :** q) where 44 | bimap f g (p :** q) = bimap f g p :** bimap f g q 45 | 46 | 47 | data Zero 48 | 49 | refute :: Zero -> a 50 | refute x = x `seq` error "we never get this far" 51 | 52 | inflate :: Functor p => p Zero -> p x 53 | inflate = fmap refute 54 | 55 | 56 | type T01 = K1 Zero 57 | 58 | type T02 = K2 Zero 59 | 60 | 61 | -- All clowns (left) 62 | data CC p c j = CC (p c) 63 | 64 | instance Functor f => Bifunctor (CC f) where 65 | bimap f g (CC pc) = CC (fmap f pc) 66 | 67 | -- All jokers (right) 68 | 69 | data JJ p c j = JJ (p j) 70 | 71 | instance Functor f => Bifunctor (JJ f) where 72 | bimap f g (JJ pj) = JJ (fmap g pj) 73 | 74 | -- dissection 75 | type family DD a :: * -> * 76 | 77 | type instance DD (K1 a x) = T02 x -- this is an \eta-expanded version... 78 | type instance DD (Id x) = T12 79 | type instance DD ((p :+ q) x) = DD (p x) :++ DD (q x) 80 | 81 | 82 | 83 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Example.lhs: -------------------------------------------------------------------------------- 1 | \ignore{ 2 | \begin{code} 3 | {-# LANGUAGE TypeOperators, GADTs #-} 4 | module Example where 5 | import Code 6 | \end{code} 7 | } 8 | 9 | In this section we rewrite our parser for S-expressions from section \ref{sec:input} 10 | using disjunction and error-correction. 11 | The goal is to illustrate how these new constructs can help in writing more modular parser descriptions. 12 | 13 | 14 | First, we can define repetition and sequence in the traditional way: 15 | 16 | \begin{code} 17 | many,some :: Parser s a -> Parser s [a] 18 | many v = some v `Disj` Pure [] 19 | some v = Pure (:) :*: v :*: many v 20 | \end{code} 21 | 22 | Checking for the end of file can be done as follows. Notice that if 23 | the end of file is not encountered, we keep parsing the input, but 24 | complain while doing so. 25 | 26 | \begin{code} 27 | eof = Symb (Pure ()) (\_ -> Yuck eof) 28 | \end{code} 29 | 30 | Checking for a specific symbol can be done in a similar way: we 31 | accept anything but dislike (|Yuck|!) anything unexpected. 32 | 33 | \begin{code} 34 | pleaseSymbol :: Eq s => s -> Parser s (Maybe s) 35 | pleaseSymbol s = Symb 36 | (Yuck $ Pure Nothing) 37 | (\s' ->if s == s' then Pure (Just s') 38 | else Yuck $ Pure (Just s')) 39 | \end{code} 40 | 41 | All of the above can be combined to write the parser for S-expressions. 42 | Note that we need to amend the result type to accommodate for erroneous inputs. 43 | 44 | \begin{code} 45 | 46 | data SExpr 47 | = S [SExpr] (Maybe Char) 48 | | Atom Char 49 | | Missing 50 | | Deleted Char 51 | 52 | parseExpr = Symb 53 | (Yuck $ Pure Missing) 54 | (\c ->case c of 55 | '(' -> Pure S :*: many parseExpr :*: pleaseSymbol ')' 56 | ')' -> Yuck $ Pure $ Deleted ')' 57 | c -> Pure $ Atom c) 58 | 59 | parseTopLevel 60 | = Pure const :*: parseExpr :*: eof 61 | \end{code} 62 | 63 | 64 | We see that the constructs introduced in this section (|Disj|, |Yuck|) 65 | permit to write general purpose derived combinators, such as |many|, in a 66 | traditional style. 67 | 68 | -------------------------------------------------------------------------------- /PolyTest/Implementation/Fun.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, EmptyDataDecls, GADTs, TypeOperators, FlexibleInstances #-} 2 | 3 | import Test.QuickCheck 4 | 5 | data True = T 6 | data False 7 | 8 | 9 | type Nat = Int -- sic. 10 | 11 | data Equals a b where 12 | Refl :: Equals a a 13 | 14 | -- type family Occurs a b :: * 15 | -- type instance (a ~ b) => Occurs a b = True 16 | 17 | data A 18 | 19 | 20 | newtype Fix f = In { out :: f (Fix f)} 21 | 22 | data Z1 a 23 | data Id a = Id a 24 | data K x a = K x 25 | data (f :+: g) a = L1 (f a) | L2 (g a) 26 | data (f :*: g) a = f a :*: g a 27 | 28 | type family SubstA t a' :: * 29 | 30 | type instance SubstA A a' = a' 31 | type instance SubstA Int a' = Int 32 | type instance SubstA (a -> b) a' = SubstA a a' -> SubstA b a' 33 | 34 | class OneArg t where 35 | type OneArgF t :: * -> * 36 | type ArgType t :: * -> * 37 | -- con :: (OneArgF t fixPoint -> fixPoint) -> SubstA t fixPoint 38 | 39 | 40 | instance AFunctor f => OneArg (f -> A) where 41 | type OneArgF (f -> A) = AFunctorF f 42 | type ArgType (f -> A) = SubstA (f -> A) 43 | -- con inj = \x -> inj (aCon x) 44 | 45 | class AFunctor t where 46 | type AFunctorF t :: * -> * 47 | aCon :: SubstA t fixPoint -> AFunctorF t fixPoint 48 | 49 | instance AFunctor A where 50 | type AFunctorF A = Id 51 | aCon = Id 52 | 53 | instance AFunctor Int where 54 | type AFunctorF Int = K Int 55 | aCon = K 56 | 57 | -- instance AFunctor (Either a b) where 58 | -- type AFunctorF (Either a b) = AFunctorF a :+: AFunctorF b 59 | -- aCon (Left x) = aCon x 60 | 61 | 62 | class PolyTestable t where 63 | type ExtractedFunctor t :: * -> * 64 | type Monotype t :: * -> * 65 | polyRun :: Gen (Monotype t initalA) 66 | 67 | 68 | instance (PolyTestable res, OneArg arg) => PolyTestable (arg -> res) where 69 | type ExtractedFunctor (arg -> res) = OneArgF arg :*: ExtractedFunctor res 70 | type Monotype (arg -> res) initialA = SubstA ArgType arg initialA (Monotype res) 71 | 72 | instance PolyTestable A where 73 | type ExtractedFunctor A = Z1 74 | -- toMonoTest = 75 | 76 | f :: a -> a 77 | f = undefined 78 | 79 | 80 | 81 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Bidir/Full.lhs: -------------------------------------------------------------------------------- 1 | \begin{code} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | 4 | module Main where 5 | 6 | import Code 7 | import Example 8 | import System.IO 9 | import Control.Monad (when) 10 | data State = State 11 | { 12 | lt, rt :: String, 13 | ls :: [Process Char Top] 14 | } 15 | 16 | 17 | data Focus = L | M | R 18 | 19 | cur M = "^" 20 | cur _ = "" 21 | 22 | showS focus _ (Atom c) = cur focus ++ [c] 23 | showS focus _ Missing = cur focus ++ "*expected atom*" 24 | showS focus _ (Deleted c) = cur focus ++ "?"++[c]++"?" 25 | showS focus ([open,close]:ps) (S s@(BList l r) actualClose) = 26 | case focus of 27 | M -> open : mid ++ closing 28 | f -> open : concatMap (showS f ps) (toList s) ++ closing 29 | where 30 | closing = case actualClose of 31 | (Just ')') ->[close] 32 | (Just c) -> "?" ++ [c] ++ "?" 33 | Nothing -> "*expected )*" 34 | mid = concatMap (showS L ps) (l []) ++ case r of 35 | [] ->"" 36 | [x] ->concatMap (showS R ps) r 37 | (a:x:rs) -> showS L ps a ++ showS M ps x ++ concatMap (showS R ps) rs 38 | 39 | instance Show SExpr where 40 | show = showS M (cycle ["()","[]","{}"]) 41 | instance Show (BList SExpr) where 42 | show ss = showS M (cycle ["()","[]","{}"]) (S ss (Just ')')) 43 | 44 | 45 | loop s@State{ls = pst:psts } = do 46 | putStrLn "" 47 | putStrLn $ reverse (lt s) ++ "^" ++ rt s 48 | putStrLn $ show $ evalZR $ feedSyms Nothing $ feedSyms (Just (rt s)) $ pst 49 | c <- getChar 50 | loop $ case c of 51 | '<' -> case lt s of 52 | [] -> s 53 | (x:xs) -> s {lt = xs, rt = x : rt s, ls = psts} 54 | '>' -> case rt s of 55 | [] -> s 56 | (x:xs) -> s {lt = x : lt s, rt = xs, ls = feed x} 57 | ',' -> case lt s of 58 | [] -> s 59 | (x:xs) -> s {lt = xs, ls = psts} 60 | '.' -> case rt s of 61 | [] -> s 62 | (x:xs) -> s {rt = xs} 63 | c -> s {lt = c : lt s, ls = feed c} 64 | where feed c = evalZL (feedSyms (Just [c]) pst) : ls s 65 | 66 | 67 | main = hSetBuffering stdin NoBuffering >> loop State {lt = "", rt = "", ls = [mkProcess parseTopLevel]} 68 | 69 | 70 | 71 | \end{code} -------------------------------------------------------------------------------- /Machines/SuspensionPMatchAM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# OPTIONS -fglasgow-exts #-} 3 | 4 | import Control.Applicative 5 | 6 | 7 | data Term a where 8 | Lam :: (Term a -> Term b) -> Term (a -> b) 9 | App :: Term (a -> b) -> Term a -> Term b 10 | Con :: a -> Term a 11 | 12 | Disj :: Term (f a -> c) -> Term (g a -> c) -> Term ((f :+: g) a -> c) 13 | Conj :: Term (f a -> g a -> c) -> Term ((f :*: g) a -> c) 14 | Kons :: (x -> Term c) -> Term (K x a -> c) 15 | Wrap :: Term (f (T f) -> c) -> Term ((T f) -> c) 16 | 17 | 18 | instance Functor Term where 19 | fmap f = (pure f <*>) 20 | 21 | instance Applicative Term where 22 | pure = Con 23 | (<*>) = App 24 | 25 | 26 | ---------------------------- 27 | -- Direct evaluation 28 | 29 | eval :: Term t -> t 30 | eval (App t1 t2) = eval t1 (eval t2) 31 | eval (Lam f) = \x -> eval (f (Con x)) 32 | eval (Con x) = x 33 | eval (Disj f g) = \x -> case x of 34 | Inl a -> eval (f <*> pure a) 35 | Inr a -> eval (g <*> pure a) 36 | eval (Conj f) = \(x :*: y) -> eval (f <*> pure x <*> pure y) 37 | eval (Wrap f) = \(In x) -> eval (f <*> pure x) 38 | 39 | 40 | instance Monad Term where 41 | return = Con 42 | k >>= f = f (eval k) 43 | 44 | data T (f :: * -> *) where 45 | In :: f (T f) -> T f 46 | Suspend :: T f 47 | out (In x) = x 48 | 49 | infixr :+: 50 | data (:+:) f g a where 51 | Inl :: f a -> (:+:) f g a 52 | Inr :: g a -> (:+:) f g a 53 | 54 | instance (Functor f, Functor g) => Functor (f :+: g) where 55 | fmap h (Inl x) = Inl (fmap h x) 56 | fmap h (Inr x) = Inr (fmap h x) 57 | 58 | infixr :*: 59 | data (:*:) f g a where 60 | (:*:) :: f a -> g a -> (:*:) f g a 61 | 62 | instance (Functor f, Functor g) => Functor (f :*: g) where 63 | fmap h (x :*: y) = fmap h x :*: fmap h y 64 | 65 | data K x a = K {fromK :: x} 66 | instance Functor (K x) where 67 | fmap f (K x) = K x 68 | 69 | data Id a = Id {fromId :: a} 70 | instance Functor (Id) where 71 | fmap f (Id a) = Id (f a) 72 | 73 | type List x = T (K () :+: (K x :*: Id)) 74 | 75 | prod :: Term (List Int -> Int) 76 | prod = Wrap $ Disj 77 | (Kons $ \_ -> pure 1) 78 | (Conj $ Lam $ \x -> Lam $ \xs -> (*) <$> (fromK <$> x) <*> (prod <*> (fromId <$> xs))) 79 | 80 | 81 | 82 | 83 | -------------------------------------------------------------------------------- /CPSZipper/ZipperForTheTypedApplicativeLanguage.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ImpredicativeTypes, ScopedTypeVariables, TypeFamilies, GADTs, EmptyDataDecls #-} 2 | 3 | import Prelude hiding (Left, Right) 4 | 5 | -- Applicative expressions 6 | data Appl a where 7 | (:*:) :: Appl (a -> b) -> Appl a -> Appl b 8 | Pure :: a -> Appl a 9 | 10 | -- And their semantics 11 | evalAppl :: Appl a -> a 12 | evalAppl (f :*: x) = evalAppl f $ evalAppl x 13 | evalAppl (Pure x) = x 14 | 15 | -- One-hole contexts for Appl 16 | data Context hole result where 17 | Root :: Context hole hole 18 | Left :: Context hole result -> Appl a -> Context (a -> hole) result 19 | Right :: Appl (hole -> hole') -> Context hole' result -> Context hole result 20 | 21 | -- Plug a hole: 22 | plug :: Context hole result -> Appl hole -> Appl result 23 | plug Root x = x 24 | plug (Left z r) x = plug z (x :*: r) 25 | plug (Right l z) x = plug z (l :*: x) 26 | 27 | 28 | -- Interestingly, contexts can be evaluated indepentently: 29 | 30 | -- (This suggests that contexts can represent any form of lambda expression with 31 | -- one hole) 32 | evalCtx :: Context hole result -> hole -> result 33 | evalCtx Root = id 34 | evalCtx (Left ctx a) = \a_to_hole -> (evalCtx ctx) (a_to_hole (evalAppl a)) 35 | evalCtx (Right a ctx) = \hole -> (evalCtx ctx) (evalAppl a hole) 36 | 37 | 38 | -- Zipper = context + expr 39 | data Zipper result where 40 | Zip :: Context hole result -> Appl hole -> Zipper result 41 | 42 | -- navigation: 43 | up, next, downLeft, downRight, preorder :: Zipper a -> Zipper a 44 | 45 | up (Zip (Left ctx b) a) = Zip ctx (a :*: b) 46 | up (Zip (Right a ctx) b) = Zip ctx (a :*: b) 47 | up (Zip Root _) = error "All the way up" 48 | 49 | downLeft :: Zipper result -> Zipper result 50 | downLeft (Zip ctx (a :*: b)) = Zip (Left ctx b) a 51 | downLeft (Zip ctx (Pure x)) = error "All the way down" 52 | 53 | downRight (Zip ctx (a :*: b)) = Zip (Right a ctx) b 54 | downRight (Zip ctx (Pure x)) = error "All the way down" 55 | 56 | preorder z@(Zip _ (_ :*: _)) = downLeft z 57 | preorder z@(Zip _ (Pure _)) = next z 58 | 59 | -- helper for pre-order traversal 60 | next z@(Zip (Left ctx r) l) = Zip (Right l ctx) r 61 | next z@(Zip (Right l ctx) r) = next $ Zip ctx (l :*: r) 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | -------------------------------------------------------------------------------- /OnlineTree/README.markdown: -------------------------------------------------------------------------------- 1 | references: 2 | http://hackage.haskell.org/cgi-bin/hackage-scripts/package/lazyarray 3 | http://citeseer.ist.psu.edu/95126.html 4 | 5 | 6 | class EfficientLazy t p where 7 | index :: Int -> t a -> a 8 | initial :: t a 9 | continue :: Int -> [a] -> t a -> t a 10 | 11 | toTree l = continue 0 l $ initial 12 | 13 | 14 | let ev(n,t) indicate that the spine of the tree is evaluated up element n. 15 | 16 | 17 | ev(i,t) => index i t is O(log i) 18 | ev(i0,t), i0 < i1 => index i1 t is O(max (log i1) (t1-t0)) and ev(i1,t) 19 | 20 | We have choices for continue: we can make it strict or lazy in the tree. 21 | 22 | strict: 23 | ev(i0,t), i0 < i1 => continue i1 t l is O(max (log i1) (t1-t0)) and ev(i1,t) 24 | 25 | lazy: 26 | ev(i0,t), i0 < i1 => continue i1 t l is O(log i1) (amortized) and ev(i0) 27 | 28 | 29 | ---------------------------- 30 | OLD STUFF 31 | 32 | 33 | Requirements on the data type: 34 | 35 | * indexed data type 36 | 37 | index :: Int -> T a -> a 38 | 39 | * _can_ be constructed as such: 40 | 41 | fromList :: [a] -> T a 42 | 43 | * $index i t$ in $O(\log i)$ 44 | 45 | This is the most important property. 46 | Note that access does not depend on the size of the tree! 47 | In particular the above still holds if bottoms are present 48 | in the non-accessed part of the tree. 49 | 50 | * $fromList (l ++ \bottom) [i]$ will work for all $i < |l|$ 51 | 52 | 53 | 54 | Disentangling the construction from the parsing can be done by 55 | CPS-transforming the direct construction algorithm. 56 | 57 | we obtain the following functions: 58 | 59 | initial :: Partial a 60 | continue :: [a] -> Partial a -> Partial a 61 | finish :: Partial a -> T a 62 | 63 | Given this, we can express the incremental performance as follows: 64 | 65 | p1 := continue l1 initial 66 | f1 := spine (finish p1) -- O (|l1|), where spine evaluates the spine. 67 | p2 := continue l2 p1 68 | f2 := spine (finish p2) -- O (|l2| + log |l1|) 69 | 70 | 71 | We could also assign amortized costs as such: 72 | 73 | 74 | function cost 75 | ------------ -------------------- 76 | initial O(1) 77 | continue l p O(length l) 78 | finish p O(log (length p)) 79 | f[i] O(log i) 80 | 81 | However, this is not really descriptive of what we want, because 82 | we want to make explicit that we don't pay the cost for "continue" 83 | until we actually access the corresponding elements. 84 | 85 | 86 | # Applications 87 | 88 | - Reading a file on disk 89 | - GUI for a PDF reader 90 | - Incremental parsing :) -------------------------------------------------------------------------------- /Machines/KAMCC.hs: -------------------------------------------------------------------------------- 1 | import Text.Show 2 | import Control.Arrow 3 | import Data.List 4 | import Prelude hiding (succ) 5 | type Sym = String 6 | data Term = Var Sym | Lam Sym Term | App Term Term | Con String | CC 7 | -- deriving Show 8 | 9 | substClosed v s (Var v') = if v == v' then s else Var v' 10 | substClosed v s (App t1 t2) = App (substClosed v s t1) (substClosed v s t2) 11 | substClosed v s (Lam v' t) = if v == v' then Lam v' t else Lam v' (substClosed v s t) 12 | substClosed v s (Con x) = Con x 13 | 14 | 15 | parens s = "("++s++")" 16 | 17 | instance Show Term where 18 | showsPrec d (Con x) = showString x 19 | showsPrec d (Var x) = showString x 20 | showsPrec d (Lam x t) = showParen (d > 0) (showString "\\" . showString x . showString "->" . showsPrec 0 t) 21 | showsPrec d (App t1 t2) = showParen (d > 1) (showsPrec 1 t1 . showString " " . showsPrec 2 t2) 22 | 23 | type Value = Closure 24 | data Closure = Term :+ Env | Cont Stack 25 | deriving Show 26 | type Env = [(Sym,Value)] 27 | 28 | type State = (Closure, Stack) 29 | 30 | type Stack = [Value] 31 | 32 | lookupEnv :: Sym -> Env -> Value 33 | lookupEnv x [] = error $ x ++ " not found in env!" 34 | lookupEnv x ((y,v):rho) = if x == y then v else lookupEnv x rho 35 | 36 | step (Var x :+ rho, s) = Just (lookupEnv x rho, s) 37 | step (Lam x t :+ rho, []) = Nothing 38 | step (Lam x t :+ rho, v:s) = Just (t :+ ((x,v):rho), s) 39 | step (App t1 t2 :+ rho, s) = Just (t1 :+ rho, (t2 :+ rho):s) 40 | step (CC :+ rho, e:s) = Just (e, Cont s:s) 41 | step (Cont gamma , e:s) = Just (e, gamma) 42 | step _ = Nothing 43 | 44 | dup x = (x,x) 45 | 46 | run t = init : unfoldr (fmap dup . step) init 47 | where init = (t :+ [], []) 48 | 49 | test = mapM_ print . run 50 | test' = mapM_ (print . evalState) . run 51 | 52 | subsAll t [] = t 53 | subsAll t ((v,s):rho) = substClosed v s (subsAll t rho) 54 | 55 | evalClosure (t :+ rho) = subsAll t (map (second evalClosure) rho) 56 | 57 | evalState (cl,s) = foldl1 App (map evalClosure (cl:s)) 58 | -------------------- 59 | 60 | i_ = Lam "x" (Var "x") 61 | 62 | infixl `App` 63 | 64 | 65 | zero = Lam "f" $ Lam "x" $ Var "x" 66 | succ = Lam "n" $ Lam "f" $ Lam "x" $ ((Var "n") `App` (Var "f")) `App` ((Var "f") `App` (Var "x")) 67 | two = succ `App` (succ `App` zero) 68 | twice = Lam "f" $ Lam "x" $ (Var "f" `App` ( Var "f" `App` Var "x")) 69 | _id = Lam "y" $ Var "y" 70 | 71 | 72 | value1 = twice `App` _id 73 | value2 = (twice `App` _id) `App` (Con "V") 74 | 75 | testChurch = two `App` (Con "F") `App` (Con "X") 76 | 77 | 78 | delta = Lam "x" $ App (Var "x") (Var "x") 79 | 80 | 81 | s0 = (App delta delta, [], []) 82 | 83 | 84 | -------------------------------------------------------------------------------- /FullIncrementalParsing/Lex.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | 3 | import Data.Monoid 4 | import Data.Array 5 | 6 | 7 | -- Each symbol of the input can be converted into a transition function: 8 | class Monoid o => Lexer i s o where 9 | transition :: i -> Trans s o 10 | 11 | -- A transition transforms the state and yields some output. 12 | type Trans s o = s -> (s,o) 13 | 14 | 15 | -- We also assume a monoid on the output data. (It can be put in a tree, parsed by a monoidal parser, go through a 2nd stage of monoidal lexing, etc.) 16 | (<>) :: Monoid o => o -> o -> o 17 | (<>) = mappend 18 | 19 | -- So the empty transition is 20 | emptyTransition s = (s,mempty) 21 | 22 | -- We can also assume a finite number of states. 23 | class (Ix s, Bounded s) => Finite s where 24 | 25 | series :: Finite s => [s] 26 | series = range (minBound, maxBound) 27 | 28 | -- Goal: make the lexer monoidal. 29 | -- That is, we need a conversion function from transitions to a monoid structure. 30 | 31 | -- Version 0: not useful, because the ouputs are not reusable/cached 32 | 33 | {- 34 | 35 | data Monotrans s o = Monotrans (s -> (s,o)) 36 | 37 | toMono = Monotrans 38 | 39 | instance (Monoid o, Finite s) => Monoid (Monotrans s o) where 40 | mappend (Monotrans f) (Monotrans g) = Monotrans (\s0 -> let (s1,o) = f s0 41 | (s2,o') = g s1 42 | in (s2,o <> o')) 43 | mempty = Monotrans (\s -> (s,mempty)) 44 | 45 | -} 46 | 47 | {- 48 | --------------- 49 | -- V1 50 | -- Here the outputs are precomputed/reusable, but the append operation is very slow! 51 | 52 | 53 | 54 | data Monotrans s o = Monotrans [(s,o,s)] 55 | 56 | toMono t = Monotrans [(s,o,s') | s <- series, let (s',o) = t s] 57 | 58 | instance (Monoid o, Finite s) => Monoid (Monotrans s o) where 59 | mappend (Monotrans f) (Monotrans g) = Monotrans [(s0,o <> o',s2) | (s0,o,s1) <- f, (s1',o',s2) <- g, s1 == s1'] 60 | mempty = Monotrans [(s,mempty,s) | s <- series] 61 | 62 | 63 | -} 64 | 65 | -- V2. 66 | 67 | -- Make it fast by using arrays. 68 | 69 | data Monotrans s o = Monotrans (Array s (o,s)) 70 | 71 | toMono t = Monotrans $ listArray (minBound,maxBound) (map t [minBound..maxBound]) 72 | 73 | instance (Monoid o, Finite s) => Monoid (Monotrans s o) where 74 | mappend (Monotrans f) (Monotrans g) = Monotrans $ listArray bnds [(o <> o',s2) | s0 <- range bnds, let (o,s1) = f ! s0, let (o',s2) = g ! s1] 75 | where bnds = bounds f 76 | mempty = Monotrans $ listArray bnds [(mempty,s) | s <- series] 77 | where bnds = (minBound,maxBound) 78 | 79 | 80 | 81 | 82 | -------------------------------------------------------------------------------- /PolyTest/Implementation/Fun2.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fglasgow-exts #-} 2 | {-# LANGUAGE TypeFamilies, EmptyDataDecls, GADTs, TypeOperators, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} 3 | 4 | import Test.QuickCheck 5 | 6 | import Unsafe.Coerce 7 | 8 | data True = T 9 | data False 10 | 11 | 12 | type Nat = Int -- sic. 13 | 14 | data Equals a b where 15 | Refl :: Equals a a 16 | 17 | -- type family Occurs a b :: * 18 | -- type instance (a ~ b) => Occurs a b = True 19 | 20 | data A 21 | 22 | 23 | newtype Fix f = In { out :: f (Fix f)} 24 | 25 | data Z1 a 26 | data Id a = Id a 27 | data K x a = K x 28 | data (f :+: g) a = L1 (f a) | L2 (g a) 29 | data (f :*: g) a = f a :*: g a 30 | 31 | type family SubstA t a' :: * 32 | 33 | type instance SubstA A a' = a' 34 | type instance SubstA Int a' = Int 35 | type instance SubstA (a -> b) a' = SubstA a a' -> SubstA b a' 36 | 37 | class OneArg t initialA where 38 | type OneArgF t :: * -> * 39 | type AddArgType t initialA :: * -> * 40 | 41 | applyOneArg :: (t -> rest) -> AddArgType t initialA rest 42 | -- con :: (OneArgF t fixPoint -> fixPoint) -> SubstA t fixPoint 43 | 44 | -- type AddArgType t initialA = (->) (SubstA (f) initialA) "default" 45 | 46 | 47 | instance AFunctor f => OneArg (f -> A) initialA where 48 | type OneArgF (f -> A) = AFunctorF f 49 | type AddArgType (f -> A) initialA = Id 50 | -- con inj = \x -> inj (aCon x) 51 | 52 | class AFunctor t where 53 | type AFunctorF t :: * -> * 54 | aCon :: SubstA t fixPoint -> AFunctorF t fixPoint 55 | 56 | instance AFunctor A where 57 | type AFunctorF A = Id 58 | aCon = Id 59 | 60 | instance AFunctor Int where 61 | type AFunctorF Int = K Int 62 | aCon = K 63 | 64 | -- instance AFunctor (Either a b) where 65 | -- type AFunctorF (Either a b) = AFunctorF a :+: AFunctorF b 66 | -- aCon (Left x) = aCon x 67 | 68 | 69 | class PolyTestable t initialA where 70 | type ExtractedFunctor t :: * -> * 71 | type Monotype t initialA :: * 72 | polyRun :: t -> Monotype t initialA 73 | 74 | 75 | instance (PolyTestable res initalA, OneArg arg initialA) => PolyTestable (arg -> res) initialA where 76 | type ExtractedFunctor (arg -> res) = OneArgF arg :*: ExtractedFunctor res 77 | type Monotype (arg -> res) initialA = AddArgType arg initialA (Monotype res initialA) 78 | polyRun f = polyRun (applyOneArg f) 79 | 80 | instance PolyTestable A initialA where 81 | type ExtractedFunctor A = Z1 82 | type Monotype A initialA = initialA 83 | polyRun a = restorePoly a 84 | 85 | restorePoly :: A -> a 86 | restorePoly = unsafeCoerce 87 | 88 | f :: a -> a 89 | f = undefined 90 | 91 | 92 | 93 | -------------------------------------------------------------------------------- /Machines/TypedHOAM2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, TypeOperators #-} 2 | 3 | -- | This is a type "higher order" abstract machines with abitrary Haskell constants. 4 | -- Everything is fully typed. 5 | 6 | -- The cool thing is that the evaluator can go further than whnf. 7 | -- This is important because the Haskell "environment" is interested in the fully evaluated 8 | -- value in the end. We can also finely control how much we want to evaluate. 9 | 10 | import Control.Applicative 11 | 12 | data a :< b = (:<) {top :: a, _rest :: b} 13 | infixr :< 14 | 15 | 16 | data Term a where 17 | Lam :: (Term a -> Term b) -> Term (a -> b) 18 | App :: Term (a -> b) -> Term a -> Term b 19 | Con :: a -> Term a 20 | 21 | 22 | instance Functor Term where 23 | fmap f = (pure f <*>) 24 | 25 | instance Applicative Term where 26 | pure = Con 27 | (<*>) = App 28 | 29 | 30 | ex1 = Lam $ \a -> Lam $ \b -> Con (+) `App` a `App` b 31 | 32 | ---------------------------- 33 | -- Direct evaluation 34 | 35 | eval :: Term t -> t 36 | eval (App t1 t2) = eval t1 (eval t2) 37 | eval (Lam f) = \x -> eval (f (Con x)) 38 | eval (Con x) = x 39 | 40 | instance Monad Term where 41 | return = Con 42 | k >>= f = f (eval k) 43 | 44 | 45 | --------------------------- 46 | -- Call by name machinery 47 | 48 | data RPolish input output where 49 | RPush :: a -> RPolish (a :< rest) output -> RPolish rest output 50 | RAppp :: RPolish (b :< rest) output -> RPolish ((a -> b) :< a :< rest) output 51 | RStop :: RPolish rest rest 52 | 53 | data Polish a where 54 | Push :: Term a -> Polish r -> Polish (a :< r) 55 | Appp :: Polish ((b -> a) :< (b :< r)) -> Polish (a :< r) 56 | Stop :: Polish () 57 | 58 | data State output where 59 | State :: RPolish s output ->Polish s -> State output 60 | 61 | -- Try to perform one step of evaluation. 62 | stp :: State t -> State t 63 | stp (State l Stop) = (State l Stop) 64 | stp (State l (Appp r)) = State (RAppp l) r 65 | stp (State l (Push (App t1 t2) r)) = State l (Appp (Push t1 (Push t2 r))) 66 | stp (State (RAppp l) (Push (Lam f) (Push a r))) = State l (Push (f a) r) 67 | stp (State l (Push (Con x) r)) = State (RPush x l) r -- TODO: simplify! 68 | 69 | -- Unmatched: 70 | -- State RStop (Push (Lam _) _) 71 | -- State (RPush _ _) (Push (Lam _) _) 72 | 73 | -- State (RAppp _) (Push (Lam _) Stop) 74 | 75 | 76 | -- State (RAppp _) (Push (Lam _) (Appp _)) 77 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Tree.hs: -------------------------------------------------------------------------------- 1 | 2 | data Tree a = Node a (Tree a) (Tree a) 3 | | Leaf 4 | deriving (Show) 5 | 6 | toTree d [] = Leaf 7 | toTree d (x:xs) = Node x l (toTree (d+1) xs') 8 | where (l,xs') = toFullTree d xs 9 | 10 | toFullTree 0 xs = (Leaf, xs) 11 | toFullTree d [] = (Leaf, []) 12 | toFullTree d (x:xs) = (Node x l r, xs'') 13 | where (l,xs' ) = toFullTree (d-1) xs 14 | (r,xs'') = toFullTree (d-1) xs' 15 | 16 | Node 1 (Node 2 Leaf Leaf) 17 | (Node 3 (Node 4 (Node 5 Leaf Leaf) 18 | (Node 6 Leaf Leaf)) 19 | (Node 7 (Node 8 (Node 9 (Node 10 Leaf Leaf) 20 | Leaf) 21 | Leaf) 22 | Leaf)) 23 | 24 | Node 1 (Node 2 Leaf Leaf) 25 | (Node 3 (Node 4 (Node 5 Leaf Leaf) 26 | (Node 6 Leaf Leaf)) 27 | (Node 7 (Node 8 (Node 9 (Node 10 Leaf Leaf) 28 | (Node 11 Leaf Leaf)) 29 | (Node 12 (Node 13 Leaf Leaf) 30 | (Node 14 Leaf Leaf))) 31 | (Node 15 (Node 16 (Node 17 (Node 18 (Node 19 Leaf Leaf) 32 | (Node 20 Leaf Leaf)) 33 | (Node 21 (Node 22 Leaf Leaf) 34 | (Node 23 Leaf Leaf))) 35 | (Node 24 (Node 25 (Node 26 Leaf Leaf) 36 | (Node 27 Leaf Leaf)) 37 | (Node 28 (Node 29 Leaf Leaf) 38 | (Node 30 Leaf Leaf)))) 39 | (Node 31 (Node 32 (Node 33 (Node 34 (Node 35 (Node 36 Leaf Leaf) 40 | (Node 37 Leaf Leaf)) 41 | (Node 38 (Node 39 Leaf Leaf) 42 | (Node 40 Leaf Leaf))) 43 | (Node 41 (Node 42 (Node 43 Leaf Leaf) 44 | (Node 44 Leaf Leaf)) 45 | (Node 45 (Node 46 Leaf Leaf) 46 | (Node 47 Leaf Leaf)))) 47 | (Node 48 (Node 49 (Node 50 Leaf Leaf) Leaf) Leaf)) Leaf)))) 48 | -------------------------------------------------------------------------------- /CPSZipper/ZipperToZipper.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ImpredicativeTypes, ScopedTypeVariables, TypeFamilies, GADTs, EmptyDataDecls #-} 2 | 3 | import Prelude hiding (Left, Right) 4 | 5 | -- Applicative expressions 6 | data Appl a where 7 | (:*:) :: Appl (a -> b) -> Appl a -> Appl b 8 | Pure :: a -> Appl a 9 | 10 | -- And their semantics 11 | evalAppl :: Appl a -> a 12 | evalAppl (f :*: x) = evalAppl f $ evalAppl x 13 | evalAppl (Pure x) = x 14 | 15 | -- One-hole contexts for Appl 16 | data Context hole result where 17 | Root :: Context hole hole 18 | Left :: Appl a -> Context hole result -> Context (a -> hole) result 19 | Right :: Appl (hole -> hole') -> Context hole' result -> Context hole result 20 | 21 | -- Plug a hole: 22 | plug :: Context hole result -> Appl hole -> Appl result 23 | plug Root x = x 24 | plug (Left r z) x = plug z (x :*: r) 25 | plug (Right l z) x = plug z (l :*: x) 26 | 27 | 28 | -- Interestingly, contexts can be evaluated indepentently: 29 | 30 | -- (This suggests that contexts can represent any form of lambda expression with 31 | -- one hole) 32 | evalCtx :: Context hole result -> hole -> result 33 | evalCtx Root = id 34 | evalCtx (Left a ctx) = \a_to_hole -> (evalCtx ctx) (a_to_hole (evalAppl a)) 35 | evalCtx (Right a ctx) = \hole -> (evalCtx ctx) (evalAppl a hole) 36 | 37 | 38 | -- Zipper = context + expr 39 | data Zipper result where 40 | Zip :: Context hole result -> Appl hole -> Zipper result 41 | 42 | -- navigation: 43 | up, next, downLeft, downRight, preorder :: Zipper a -> Zipper a 44 | 45 | up (Zip (Left b ctx) a) = Zip ctx (a :*: b) 46 | up (Zip (Right a ctx) b) = Zip ctx (a :*: b) 47 | up (Zip Root _) = error "All the way up" 48 | 49 | downLeft (Zip ctx (a :*: b)) = Zip (Left b ctx) a 50 | downLeft (Zip ctx (Pure x)) = error "All the way down" 51 | 52 | downRight (Zip ctx (a :*: b)) = Zip (Right a ctx) b 53 | downRight (Zip ctx (Pure x)) = error "All the way down" 54 | 55 | preorder z@(Zip _ (_ :*: _)) = downLeft z 56 | preorder z@(Zip _ (Pure _)) = next z 57 | 58 | -- helper for pre-order traversal 59 | next z@(Zip (Left r ctx) l) = Zip (Right l ctx) r 60 | next z@(Zip (Right l ctx) r) = next $ Zip ctx (l :*: r) 61 | 62 | 63 | data Bin = Y Bin Bin | B 64 | 65 | -- type of contexts 66 | data CBin = T | L Bin CBin | R Bin CBin 67 | 68 | 69 | specCtx :: Context Bin Bin -> CBin 70 | specCtx (Right l ctx) = continueSpecCtx ctx (fetchContext 0 l) 71 | 72 | continueSpecCtx :: Context Bin Bin -> (CBin -> CBin) -> CBin 73 | continueSpecCtx (Right l ctx) precontext = continueSpecCtx ctx (precontext (fetchContext 0 l)) 74 | 75 | continueSpecCtx :: Context Bin Bin -> (Bin -> CBin -> CBin) -> CBin 76 | continueSpecCtx (Left r ctx) precontext = continueSpecCtx ctx (precontext (evalAppl r)) 77 | 78 | fetchContext :: 1 -> Appl (Bin -> Bin -> Bin) -> (Bin -> CBin -> CBin) 79 | fetchContext :: 0 -> Appl (Bin -> Bin) -> (CBin -> CBin) 80 | -------------------------------------------------------------------------------- /Machines/TypedHOAM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | import Control.Applicative 4 | 5 | 6 | data Term a where 7 | Lam :: (Term a -> Term b) -> Term (a -> b) 8 | App :: Term (a -> b) -> Term a -> Term b 9 | Con :: a -> Term a 10 | 11 | data Code stack where 12 | Push :: a -> Code stack -> Code (a :< stack) 13 | Appl :: Code ((b -> a) :< b :< stack) -> Code (a :< stack) 14 | 15 | 16 | instance Functor Term where 17 | fmap f = (pure f <*>) 18 | 19 | instance Applicative Term where 20 | pure = Con 21 | (<*>) = App 22 | 23 | 24 | ex1 = Lam $ \a -> Lam $ \b -> Con (+) `App` a `App` b 25 | 26 | ---------------------------- 27 | -- Direct evaluation 28 | 29 | eval :: Term t -> t 30 | eval (App t1 t2) = eval t1 (eval t2) 31 | eval (Lam f) = \x -> eval (f (Con x)) 32 | eval (Con x) = x 33 | 34 | instance Monad Term where 35 | return = Con 36 | k >>= f = f (eval k) 37 | 38 | --------------------------- 39 | -- Call by name machinery 40 | 41 | data State output where 42 | State :: Term fct -> Stack fct output -> State output 43 | 44 | data Stack fct output where 45 | Nil :: Stack output output 46 | Cons :: Term a -> Stack fct output -> Stack (a -> fct) output 47 | 48 | step :: State t -> State t 49 | step (State (App t1 t2) s) = State t1 (Cons t2 s) 50 | step (State (Lam f) (Cons a s)) = State (f a) s 51 | 52 | 53 | cbnExec :: State t -> t 54 | cbnExec (State (App t1 t2) s) = cbnExec (State t1 (Cons t2 s)) 55 | cbnExec (State (Lam f) (Cons a s)) = cbnExec (State (f a) s) 56 | cbnExec (State (Lam f) Nil) = \x -> cbnExec (State (f (Con x)) Nil) 57 | -- this is a rule that cannot be in the untyped version. 58 | cbnExec (State (Con x) s) = app x s 59 | 60 | app :: fct -> Stack fct output -> output 61 | app x s = case s of 62 | Nil -> x 63 | (Cons y z) -> app (x (cbnExec (State y Nil))) z 64 | 65 | state t = State t Nil 66 | 67 | cbnEval = cbnExec . state 68 | 69 | data BNCode = Enter BNCode | Apply BNCode | Return BNCode 70 | 71 | 72 | ----------------------------------------------- 73 | -- Examples 74 | 75 | cyc :: Term [[Char]] 76 | cyc = Con (:) `App` Con "k" `App` cyc 77 | -- cyc = (:) <$> pure "k" <*> cyc 78 | 79 | -- church encoding 80 | newtype List a r = List { fromList :: r -> (a -> List a r -> r) -> r } 81 | 82 | prod :: Term (List Int Int -> Int) 83 | prod = Lam $ \l -> 84 | fromList <$> l <*> Con 1 <*> (Lam $ \h -> Lam $ \t -> (*) <$> h <*> (prod <*> t) ) 85 | 86 | 87 | nil :: Term (List a r) 88 | nil = List <$> (Lam $ \n -> Lam $ \c -> n) 89 | 90 | cons :: Term (a -> List a r -> List a r) 91 | cons = Lam $ \h -> Lam $ \t -> List <$> (Lam $ \n -> Lam $ \c -> c <*> h <*> t) 92 | 93 | list1 :: Term (List Int r) 94 | list1 = cons <*> Con 2 <*> (cons <*> Con 3 <*> nil) 95 | 96 | test = prod <*> list1 97 | 98 | 99 | -- why this works is a bit misterious to me. :) 100 | main = print $ take 10 $ cbnEval cyc 101 | -------------------------------------------------------------------------------- /Machines/KAM.hs: -------------------------------------------------------------------------------- 1 | import Data.Tree 2 | import Text.Show 3 | import Control.Arrow 4 | import Data.List 5 | import Prelude hiding (succ) 6 | type Sym = String 7 | data Term = Var Sym | Lam Sym Term | App Term Term | Con String 8 | -- deriving Show 9 | 10 | substClosed v s (Var v') = if v == v' then s else Var v' 11 | substClosed v s (App t1 t2) = App (substClosed v s t1) (substClosed v s t2) 12 | substClosed v s (Lam v' t) = if v == v' then Lam v' t else Lam v' (substClosed v s t) 13 | substClosed v s (Con x) = Con x 14 | 15 | 16 | parens s = "("++s++")" 17 | 18 | instance Show Term where 19 | showsPrec d (Con x) = showString x 20 | showsPrec d (Var x) = showString x 21 | showsPrec d (Lam x t) = showParen (d > 0) (showString "\\" . showString x . showString "->" . showsPrec 0 t) 22 | showsPrec d (App t1 t2) = showParen (d > 1) (showsPrec 1 t1 . showString " " . showsPrec 2 t2) 23 | 24 | data Closure = Term :+ Env 25 | deriving Show 26 | type Env = [(Sym,Closure)] 27 | type State = (Closure, Stack) 28 | type Stack = [Closure] 29 | 30 | lookupEnv :: Sym -> Env -> Closure 31 | lookupEnv x [] = error $ x ++ " not found in env!" 32 | lookupEnv x ((y,v):rho) = if x == y then v else lookupEnv x rho 33 | 34 | step (Var x :+ rho, s) = Just (lookupEnv x rho, s) 35 | step (Lam x t :+ rho, v:s) = Just (t :+ ((x,v):rho), s) 36 | step (App t1 t2 :+ rho, s) = Just (t1 :+ rho, (t2 :+ rho):s) 37 | step _ = Nothing 38 | 39 | dup x = (x,x) 40 | 41 | -- run the KAM on a closure 42 | runClosure cl = init : unfoldr (fmap dup . step) init 43 | where init = (cl, []) 44 | 45 | -- run the KAM on a term 46 | run t = runClosure (t :+ []) 47 | 48 | -- evaluate a term using KAM. 49 | eval = last . run 50 | 51 | evalClosure :: Closure -> (Closure, [Closure]) 52 | evalClosure = last . runClosure 53 | 54 | evalFullClosure :: Closure -> Tree Sym 55 | evalFullClosure cl = Node v (fmap evalFullClosure args) 56 | where (Con v :+ rho, args) = evalClosure cl 57 | 58 | 59 | testFull = putStrLn . drawForest . return . evalFullClosure . (:+ []) 60 | 61 | test = mapM_ print . run 62 | test' = mapM_ (print . rebuildState) . run 63 | 64 | subsAll t [] = t 65 | subsAll t ((v,s):rho) = substClosed v s (subsAll t rho) 66 | 67 | rebuildClosure (t :+ rho) = subsAll t (map (second rebuildClosure) rho) 68 | 69 | rebuildState (cl,s) = foldl1 App (map rebuildClosure (cl:s)) 70 | -------------------- 71 | 72 | i_ = Lam "x" (Var "x") 73 | 74 | infixl `App` 75 | 76 | 77 | zero = Lam "f" $ Lam "x" $ Var "x" 78 | succ = Lam "n" $ Lam "f" $ Lam "x" $ ((Var "n") `App` (Var "f")) `App` ((Var "f") `App` (Var "x")) 79 | two = succ `App` (succ `App` zero) 80 | twice = Lam "f" $ Lam "x" $ (Var "f" `App` ( Var "f" `App` Var "x")) 81 | _id = Lam "y" $ Var "y" 82 | 83 | value1 = twice `App` _id 84 | value2 = (twice `App` _id) `App` (Con "V") 85 | 86 | testChurch = two `App` (Con "F") `App` (Con "X") 87 | 88 | 89 | delta = Lam "x" $ App (Var "x") (Var "x") 90 | 91 | d 92 | s0 = (App delta delta, [], []) 93 | 94 | 95 | -------------------------------------------------------------------------------- /FullIncrementalParsing/PP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, GADTs #-} 2 | 3 | import Data.Char 4 | import Data.List 5 | import Data.Maybe 6 | import Data.FingerTree 7 | import Data.Monoid 8 | -- import Data.Sequence 9 | 10 | -- Eventually one should convert this type to a grammar. 11 | -- (See UU tricks to do this) 12 | data P s where 13 | Sym :: (s -> Bool) -> P s 14 | (:*:) :: P s -> P s -> P s 15 | (:|:) :: P s -> P s -> P s 16 | (:>) :: String -> P sc 17 | 18 | 19 | ---------------------------- 20 | 21 | 22 | -- An element of the parse tree can be either a symbol or a non-terminal 23 | data El = S Char | Nt Int [El] 24 | deriving (Show,Eq) 25 | 26 | -- Predicates over elements 27 | type Check = El -> Bool 28 | 29 | -- A production rule. The non-terminal is the 1st argument. 30 | data Rule = Rule Int [Check] 31 | 32 | -- A grammar is a set of rule. 33 | type Grammar = [Rule] 34 | 35 | -- A proto-phrase: an unstructured list of elements. 36 | type Seq = [El] 37 | 38 | -- The state is a collection of all possible proto-phrases. 39 | type State = [Seq] 40 | 41 | -- Match a proto-phrase against the rhs of a production rule 42 | match :: [Check] -> [El] -> Bool 43 | match [] _ = True 44 | match (x:xs) (y:ys) = x y && match xs ys 45 | match _ _ = False 46 | 47 | -- Try to apply a rule to a proto-phrase. 48 | apply :: Rule -> Seq -> Maybe Seq 49 | apply (Rule n xs) ys = listToMaybe [prefix ++ [Nt n matched] ++ suffix | 50 | (prefix,rest) <- zip (inits ys) (tails ys), 51 | match xs rest, let (matched,suffix) = splitAt (length xs) rest] 52 | 53 | -- Apply all rues to a proto-phrase 54 | applyAll :: Grammar -> Seq -> Seq 55 | applyAll g s = foldr (\rule -> tillConverge (apply rule)) s g 56 | 57 | tillConverge :: (a -> Maybe a) -> (a -> a) 58 | tillConverge f a = case f a of 59 | Nothing -> a 60 | Just x -> tillConverge f x 61 | 62 | -- Merge (sequence) two sets of proto-phrases 63 | merge :: Grammar -> State -> State -> State 64 | merge g ls rs = nub [applyAll g (l ++ r) | l <- ls, r <- rs] 65 | 66 | -- Wrap it up as a monoid... 67 | newtype M = M State deriving Show 68 | 69 | instance Measured M Char where 70 | measure c = M [[S c]] 71 | 72 | instance Monoid M where 73 | mappend (M s) (M t) = M (merge grammar s t) 74 | mempty = M [[]] 75 | 76 | ------------------------------ 77 | -- Helper functions to write rules. 78 | sym c (S c') = c == c' 79 | sym _ _ = False 80 | 81 | symbol f (S c) = f c 82 | symbol _ _ = False 83 | 84 | nt x (Nt y _) = x == y 85 | nt _ _ = False 86 | 87 | 88 | -- Test grammar. 89 | grammar = [Rule 1 [sym '(', nt 1, sym ')'], 90 | Rule 1 [nt 1, sym '+', nt 1], 91 | Rule 1 [symbol isDigit] 92 | ] 93 | 94 | 95 | 96 | test = measure $ fromList $ "1+((2+4)+(5+4))" ++ concat (replicate 1000 "+1+((2+4)+(5+4))") 97 | 98 | 99 | 100 | -------------------------------------------------------------------------------- /FullIncrementalParsing/PPT1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, UndecidableInstances, TypeOperators #-} 2 | 3 | import Data.Char 4 | import Data.List 5 | import Data.Maybe 6 | import Data.FingerTree 7 | import Data.Monoid 8 | import Control.Applicative hiding (empty) 9 | import qualified Control.Applicative as A (empty) 10 | 11 | -- import Data.Sequence 12 | 13 | -- data P s where 14 | -- Sym :: (s -> Bool) -> P s 15 | -- (:*:) :: P s -> P s -> P s 16 | -- (:|:) :: P s -> P s -> P s 17 | -- (:>) :: String -> P s 18 | 19 | 20 | 21 | ---------------------------- 22 | 23 | 24 | 25 | type Check el = el -> Bool 26 | 27 | data Rule el = Rule ([el] -> el) [Check el] 28 | 29 | type Seq el = [el] 30 | 31 | type Grammar el = [Rule el] 32 | 33 | type State el = [Seq el] 34 | 35 | match :: [Check el] -> [el] -> Bool 36 | match [] _ = True 37 | match (x:xs) (y:ys) = x y && match xs ys 38 | match _ _ = False 39 | 40 | 41 | apply :: Rule el -> Seq el -> Maybe (Seq el) 42 | apply (Rule f xs) ys = listToMaybe [prefix ++ [f matched] ++ suffix | 43 | (prefix,rest) <- zip (inits ys) (tails ys), 44 | match xs rest, let (matched,suffix) = splitAt (length xs) rest] 45 | 46 | applyAny :: Grammar el -> Seq el -> Maybe (Seq el) 47 | applyAny g s = (foldr (<|>) Nothing) [apply r s | r <- g] 48 | 49 | applyAll :: Grammar el -> Seq el -> Seq el 50 | applyAll g = tillConverge (applyAny g) 51 | 52 | newtype (f :.: g) a = O (f (g a)) 53 | 54 | instance (Functor f, Functor g) => Functor (f :.: g) where 55 | fmap f (O v) = O $ fmap (fmap f) $ v 56 | 57 | instance Applicative g => Applicative ((->) b :.: g) where 58 | pure = O . const . pure 59 | O f <*> O x = O $ \b -> f b <*> x b 60 | 61 | instance Alternative f => Alternative (((->) b) :.: f) where 62 | empty = O $ \b -> A.empty 63 | O f <|> O g = O $ \a -> f a <|> g a 64 | 65 | tillConverge :: (a -> Maybe a) -> (a -> a) 66 | tillConverge f a = case f a of 67 | Nothing -> a 68 | Just x -> tillConverge f x 69 | 70 | merge :: Tree el => Grammar el -> State el -> State el -> State el 71 | -- TODO: in fact nub should just be comparing the top-level kind of non-terminal 72 | merge g ls rs = nub [applyAll g (l ++ r) | l <- ls, r <- rs] 73 | 74 | 75 | class Eq el => Tree el where 76 | getGrammar :: Grammar el 77 | 78 | newtype M el = M (State el) deriving Show 79 | 80 | 81 | instance Tree el => Monoid (M el) where 82 | mappend (M s) (M t) = M (merge getGrammar s t) 83 | mempty = M [[]] 84 | 85 | 86 | ------------------------------ 87 | 88 | 89 | 90 | data Expr = C Char | Add Expr Expr | Paren Expr | I Int 91 | deriving (Show, Eq) 92 | 93 | sym c = symbol (== c) 94 | 95 | symbol f (C c) = f c 96 | symbol _ _ = False 97 | 98 | proper (C _) = False 99 | proper _ = True 100 | 101 | instance Tree Expr where 102 | getGrammar = [Rule (\[_,m,_] -> Paren m) [sym '(', proper, sym ')'], 103 | Rule (\[l,_,r] -> Add l r) [proper, sym '+', proper], 104 | Rule (\[C d] -> I (ord d - ord '0')) [symbol isDigit] 105 | ] 106 | 107 | instance Measured (M Expr) Char where 108 | measure c = M [[C c]] 109 | 110 | t :: FingerTree (M Expr) Char 111 | t = fromList $ "1+((2+4)+(5+4))" -- ++ concat (replicate 1000 "+1+((2+4)+(5+4))") 112 | 113 | test = measure $ t 114 | 115 | -------------------------------------------------------------------------------- /OnlineTree/IndexedOnlineTree.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fglasgow-exts #-} 2 | 3 | import PolishParse3 4 | import Data.Maybe 5 | import qualified Data.Tree as S 6 | import Control.Applicative 7 | 8 | data Tree a = Node a (Tree a) (Tree a) 9 | | Leaf 10 | deriving Show 11 | 12 | instance Traversable Tree where 13 | traverse f (Node x l r) = Node <$> f x <*> traverse f l <*> traverse f r 14 | traverse f Leaf = pure Leaf 15 | 16 | instance Foldable Tree where 17 | foldMap = foldMapDefault 18 | 19 | instance Functor Tree where 20 | fmap = fmapDefault 21 | 22 | 23 | factor = 2 24 | initialSize = 5 25 | 26 | shape :: Show a => Tree a -> [S.Tree String] 27 | shape Leaf = [] -- [S.Node "o"[]] 28 | shape (Node x l r) = [S.Node (show x) (shape l ++ shape r)] 29 | 30 | trans :: (S.Tree a -> b) -> (S.Tree a -> S.Tree b) 31 | trans f n@(S.Node x xs) = S.Node (f n) (map (trans f) xs) 32 | 33 | ev f (S.Node x xs) = S.Node (f x) (map (ev f) xs) 34 | 35 | -- leftBound, rightBound 36 | parse leftSize lB rB 37 | | rB <= lB = pure Leaf 38 | | otherwise 39 | = Node <$> symbolBefore rB 40 | <*> parse factor lB midB 41 | <*> parse (leftSize * factor) midB rB 42 | <|> (isAfter rB *> pure Leaf) 43 | where midB = min rB (lB + leftSize) 44 | -- NOTE: eof (isAfter) here is important for performance (otherwise the 45 | -- parser would have to keep this case until the very end of input 46 | -- is reached. 47 | 48 | 49 | symbolBefore rB = symbol (< rB) 50 | 51 | isAfter rB = symbol (>= rB) 52 | 53 | 54 | --getNextItem :: Int -> P s s 55 | getNextItem sz 56 | | sz <= 0 = empty 57 | | otherwise = symbol (const True) 58 | 59 | test1 = parse initialSize 0 40 <* symbol (== 41) 60 | 61 | sym x = symbol (== x) 62 | 63 | -- main = putStrLn $ S.drawForest $ shape $ snd $ fromJust $ unP test1 [1..100] 64 | tree = runPolish test1 [1..100] 65 | main = putStrLn $ S.drawForest $ shape $ tree 66 | 67 | 68 | dropBut amount t = drop' initialLeftSize id t amount [] 69 | where 70 | drop' :: Int -> E [a] -> Tree a -> Int -> E [a] 71 | drop' leftsize prec Leaf n = prec 72 | drop' leftsize prec t@(Node x l r) index 73 | | index == 0 = prec . toEndo t 74 | | index <= leftsize = drop' initialLeftSize (x :) l (index - 1) . toEndo r 75 | | otherwise = drop' (leftsize * factor) (last prec l) r (index - 1 - leftsize) 76 | last :: E [a] -> Tree a -> [a] -> [a] 77 | last prec t = case toReverseList t of 78 | (x:xs) -> (x :) 79 | _ -> prec 80 | 81 | 82 | {- 83 | newtype P s a = P ([s] -> Maybe ([s], a)) 84 | 85 | unP (P f) ss = f ss 86 | 87 | 88 | instance Functor (P s) where 89 | fmap f (P x) = P $ \i -> case x i of 90 | Nothing -> Nothing 91 | Just (i', xx) -> Just (i', f xx) 92 | 93 | instance Applicative (P s) where 94 | pure x = P $ \i -> Just (i,x) 95 | (P f) <*> (P x) = P $ \i -> case f i of 96 | Nothing -> Nothing 97 | Just (i', ff) -> let ~(Just (i'',xx)) = x i' 98 | -- notice the rhs of <*> can never fail. 99 | in Just (i'',ff xx) 100 | 101 | 102 | 103 | instance Alternative (P s) where 104 | empty = P $ \i -> Nothing 105 | (P x) <|> (P y) = P $ \i -> case x i of 106 | Nothing -> y i 107 | r -> r 108 | 109 | getItem :: P s s 110 | getItem = P $ \ i -> case i of 111 | [] -> Nothing 112 | (x:xs) -> Just (xs, x) 113 | 114 | -} 115 | 116 | -------------------------------------------------------------------------------- /Machines/PolishVM.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) JP Bernardy 2008 2 | 3 | {-# OPTIONS -fglasgow-exts #-} 4 | module PolishVM where 5 | import Control.Applicative 6 | import Data.Foldable 7 | import Data.Traversable 8 | import Data.List hiding (map, minimumBy) 9 | import Data.Char 10 | import Data.Maybe (listToMaybe) 11 | 12 | data Void 13 | 14 | data a :< b = a :< b 15 | 16 | hd (a :< _) = a 17 | 18 | infixr :< 19 | 20 | 21 | data Steps r where 22 | Val :: a -> Steps r -> Steps (a :< r) 23 | App :: (Steps ((b -> a) :< b :< r)) -> Steps (a :< r) 24 | Done :: Steps Void 25 | 26 | 27 | apply ~(f:< ~(a: r 33 | evalR (Val a r) = push a $ evalR r 34 | evalR (App s) = apply (evalR s) 35 | 36 | 37 | -- | A computation segment 38 | newtype P s a = P {fromP :: forall r. Steps r -> Steps (a :< r)} 39 | 40 | 41 | instance Functor (P s) where 42 | fmap f x = pure f <*> x 43 | 44 | instance Applicative (P s) where 45 | P f <*> P x = P (\fut -> (App (f (x fut)))) 46 | pure x = P (\fut -> Val x $ fut) 47 | 48 | -- | Pre-compute a left-prefix of some steps (as far as possible) 49 | evalL :: Steps a -> Steps a 50 | evalL (Val x r) = Val x (evalL r) 51 | evalL (App f) = case evalL f of 52 | (Val a (Val b r)) -> Val (a b) r 53 | (Val f1 (App (Val f2 r))) -> App (Val (f1 . f2) r) 54 | r -> App r 55 | evalL x = x 56 | 57 | 58 | -- The zipper for efficient evaluation: 59 | 60 | -- Arbitrary expressions in Reverse Polish notation. 61 | -- This can also be seen as an automaton that transforms a stack. 62 | -- RPolish is indexed by the types in the stack consumed by the automaton (input), 63 | -- and the stack produced (output) 64 | data RPolish input output where 65 | RVal :: a -> RPolish (a :< rest) output -> RPolish rest output 66 | RApp :: RPolish (b :< rest) output -> RPolish ((a -> b) :< a :< rest) output 67 | RStop :: RPolish rest rest 68 | 69 | -- Evaluate the output of an RP automaton, given an input stack 70 | evalRP :: RPolish input output -> input -> output 71 | evalRP RStop acc = acc 72 | evalRP (RVal v r) acc = evalRP r (v :< acc) 73 | evalRP (RApp r) (f :< a :< acc) = evalRP r (f a :< acc) 74 | 75 | 76 | -- execute the automaton as far as possible 77 | simplify :: RPolish s output -> RPolish s output 78 | simplify (RVal a (RVal f (RApp r))) = simplify (RVal (f a) r) 79 | simplify x = x 80 | 81 | -- Gluing a Polish expression and an RP automaton. 82 | -- This can also be seen as a zipper of Polish expressions. 83 | data Zip output where 84 | Zip :: RPolish stack output -> Steps stack -> Zip output 85 | -- note that the Stack produced by the Polish expression matches 86 | -- the stack consumed by the RP automaton. 87 | 88 | -- Move the zipper to the right, if possible. The type gives evidence 89 | -- that this function does not change the (type of) output produced. 90 | right :: Zip output -> Zip output 91 | right (Zip l (Val a r)) = Zip (RVal a l) r 92 | right (Zip l (App r)) = Zip (RApp l) r 93 | right (Zip l s) = (Zip l s) 94 | 95 | -- | Pre-compute a left-prefix of some steps (as far as possible) 96 | evalZL :: Zip output -> Zip output 97 | evalZL z = case right z of 98 | Zip l r -> Zip (simplify l) r 99 | 100 | 101 | evalZ :: Zip output -> output 102 | evalZ (Zip rp p) = evalRP rp (evalR p) 103 | 104 | -- | Eval in both directions 105 | evalX :: Zip output -> Steps s -> (s, [Zip output]) 106 | evalX z s0 = case s0 of 107 | Val a r -> m (push a) (evalX z' r) 108 | App s -> m apply (evalX z' s) 109 | where z' = right z 110 | m f ~(s, zz) = z' `seq` (f s, z':zz) -- tie the evaluation of the intermediate stuffs 111 | -------------------------------------------------------------------------------- /CPSZipper/Dissect.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, EmptyDataDecls, TypeFamilies, GADTs #-} 2 | 3 | -- Copied directly from McBride's Jokers & Clowns. 4 | -- http://portal.acm.org/citation.cfm?id=1328438.1328474&coll=GUIDE&dl=GUIDE&CFID=4573058&CFTOKEN=30689630 5 | 6 | -- Polynomial functors 7 | data K1 a x = K1 a 8 | data Id a = Id a 9 | data (p :+ q) x = L1 (p x) | R1 (q x) 10 | data (p :* q) x = (p x) :* (q x) 11 | 12 | type T11 = K1 () 13 | 14 | -- Constant bifunctor 15 | data K2 a x y = K2 a 16 | 17 | data Fst x y = Fst x 18 | data Snd x y = Snd y 19 | 20 | -- Sum bifunctor 21 | data (p :++ q) x y = L2 (p x y) | R2 (q x y) 22 | 23 | -- Product bifunctor 24 | data (p :** q) x y = (p x y) :** (q x y) 25 | 26 | type T12 = K2 () 27 | 28 | class Bifunctor p where 29 | bimap :: (s1 -> t1) -> (s2 -> t2) -> p s1 s2 -> p t1 t2 30 | 31 | instance Bifunctor (K2 a) where 32 | bimap f g (K2 a) = K2 a 33 | 34 | instance Bifunctor Fst where 35 | bimap f g (Fst x) =Fst (f x) 36 | 37 | instance Bifunctor Snd where 38 | bimap f g (Snd y) = Snd (g y) 39 | 40 | instance (Bifunctor p,Bifunctor q) => Bifunctor (p :++ q) where 41 | bimap f g (L2 p) =L2 (bimap f g p) 42 | bimap f g (R2 q) =R2 (bimap f g q) 43 | 44 | instance (Bifunctor p,Bifunctor q) => Bifunctor (p :** q) where 45 | bimap f g (p :** q) = bimap f g p :** bimap f g q 46 | 47 | 48 | data Zero 49 | 50 | refute :: Zero -> a 51 | refute x = x `seq` error "we never get this far" 52 | 53 | inflate :: Functor p => p Zero -> p x 54 | inflate = fmap refute 55 | 56 | 57 | type T01 = K1 Zero 58 | 59 | type T02 = K2 Zero 60 | 61 | 62 | -- All clowns (left) 63 | data CC p c j = CC (p c) 64 | 65 | instance Functor f => Bifunctor (CC f) where 66 | bimap f g (CC pc) = CC (fmap f pc) 67 | 68 | -- All jokers (right) 69 | 70 | data JJ p c j = JJ (p j) 71 | 72 | instance Functor f => Bifunctor (JJ f) where 73 | bimap f g (JJ pj) = JJ (fmap g pj) 74 | 75 | -- dissection: turns a functor into a bifunctor 76 | 77 | class Dissect (p :: * -> *) where 78 | type DD p :: (* -> * -> *) 79 | plug :: x -> DD p x x -> p x 80 | right :: Either (p j) (DD p c j, c) -> Either (j, DD p c j) (p c) 81 | 82 | instance Dissect (K1 a) where 83 | type DD (K1 a) = T02 84 | plug x (K2 z) = refute z 85 | 86 | right (Left (K1 a)) = Right (K1 a) 87 | right (Right (K2 z, c)) = refute z 88 | 89 | 90 | instance Dissect Id where 91 | type DD (Id) = T12 92 | plug x (K2 ()) = Id x 93 | 94 | right (Left (Id j)) = Left (j, K2 ()) 95 | right (Right (K2 (), c)) = Right (Id c) 96 | 97 | instance (Dissect p, Dissect q) => Dissect (p :+ q) where 98 | type DD (p :+ q) = DD p :++ DD q 99 | plug x (L2 pd) = L1 (plug x pd) 100 | plug x (R2 qd) = R1 (plug x qd) 101 | 102 | right x = case x of 103 | (Left (L1 pj)) -> mindp (right (Left pj)) 104 | (Left (R1 qj)) -> mindq (right (Left qj)) 105 | (Right ((L2 pd, c))) -> mindp (right (Right (pd, c))) 106 | (Right ((R2 qd, c))) -> mindq (right (Right (qd, c))) 107 | where mindp (Left (j,pd)) = Left (j, L2 pd) 108 | mindp (Right pc) = Right (L1 pc) 109 | mindq (Left (j,pd)) = Left (j, R2 pd) 110 | mindq (Right pc) = Right (R1 pc) 111 | 112 | 113 | instance (Dissect p, Dissect q) => Dissect (p :* q) where 114 | type DD (p :* q) = (DD p :** JJ q) :++ (CC p :** DD q) 115 | plug x (L2 (pd :** JJ qx)) = plug x pd :* qx 116 | plug x (R2 (CC px :** qd)) = px :* plug x qd 117 | 118 | 119 | newtype Mu f = In { out :: f (Mu f) } 120 | 121 | type Zipper f = (Mu f, [DD f (Mu f) (Mu f)]) 122 | 123 | zUp,zDown :: Dissect f => Zipper f -> Maybe (Zipper f) 124 | 125 | zUp (t, []) = Nothing 126 | zUp (t, pd : pds) = Just (In (plug t pd), pds) 127 | 128 | zDown (In pt, pds) = case right (Left pt) of 129 | Left (t', pd') -> Just (t', pd': pds) 130 | Right _ -> Nothing 131 | 132 | 133 | 134 | 135 | 136 | -------------------------------------------------------------------------------- /CPSZipper/HinzeZipper.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, EmptyDataDecls, TypeFamilies, GADTs #-} 2 | 3 | -- Copied directly from McBride's Jokers & Clowns. 4 | -- http://portal.acm.org/citation.cfm?id=1328438.1328474&coll=GUIDE&dl=GUIDE&CFID=4573058&CFTOKEN=30689630 5 | 6 | -- Polynomial functors 7 | data K1 a x = K1 a 8 | data Id a = Id a 9 | data (p :+ q) x = L1 (p x) | R1 (q x) 10 | data (p :* q) x = (p x) :* (q x) 11 | 12 | type T11 = K1 () 13 | 14 | -- Constant bifunctor 15 | data K2 a x y = K2 a 16 | 17 | data Fst x y = Fst x 18 | data Snd x y = Snd y 19 | 20 | -- Sum bifunctor 21 | data (p :++ q) x y = L2 (p x y) | R2 (q x y) 22 | 23 | -- Product bifunctor 24 | data (p :** q) x y = (p x y) :** (q x y) 25 | 26 | type T12 = K2 () 27 | 28 | class Bifunctor p where 29 | bimap :: (s1 -> t1) -> (s2 -> t2) -> p s1 s2 -> p t1 t2 30 | 31 | instance Bifunctor (K2 a) where 32 | bimap f g (K2 a) = K2 a 33 | 34 | instance Bifunctor Fst where 35 | bimap f g (Fst x) =Fst (f x) 36 | 37 | instance Bifunctor Snd where 38 | bimap f g (Snd y) = Snd (g y) 39 | 40 | instance (Bifunctor p,Bifunctor q) => Bifunctor (p :++ q) where 41 | bimap f g (L2 p) =L2 (bimap f g p) 42 | bimap f g (R2 q) =R2 (bimap f g q) 43 | 44 | instance (Bifunctor p,Bifunctor q) => Bifunctor (p :** q) where 45 | bimap f g (p :** q) = bimap f g p :** bimap f g q 46 | 47 | 48 | data Zero 49 | 50 | refute :: Zero -> a 51 | refute x = x `seq` error "we never get this far" 52 | 53 | inflate :: Functor p => p Zero -> p x 54 | inflate = fmap refute 55 | 56 | 57 | type T01 = K1 Zero 58 | 59 | type T02 = K2 Zero 60 | 61 | 62 | -- We emulate lambdas at the type lever by using special combinators, 63 | -- ie. the clowns & jokers from Mc Bride. 64 | -- All clowns (left) 65 | data CC p c j = CC (p c) 66 | 67 | instance Functor f => Bifunctor (CC f) where 68 | bimap f g (CC pc) = CC (fmap f pc) 69 | 70 | -- All jokers (right) 71 | 72 | data JJ p c j = JJ (p j) 73 | 74 | instance Functor f => Bifunctor (JJ f) where 75 | bimap f g (JJ pj) = JJ (fmap g pj) 76 | 77 | -- dissection: turns a functor into a bifunctor 78 | 79 | class Dissect (p :: * -> *) where 80 | type Ctx p :: (* -> * -> *) 81 | plug :: x -> Ctx p x x -> p x 82 | right :: Either (p j) (Ctx p c j, c) -> Either (j, Ctx p c j) (p c) 83 | 84 | instance Dissect (K1 a) where 85 | type Ctx (K1 a) = T02 86 | plug x (K2 z) = refute z 87 | 88 | right (Left (K1 a)) = Right (K1 a) 89 | right (Right (K2 z, c)) = refute z 90 | 91 | 92 | instance Dissect Id where 93 | type Ctx (Id) = T12 94 | plug x (K2 ()) = Id x 95 | 96 | right (Left (Id j)) = Left (j, K2 ()) 97 | right (Right (K2 (), c)) = Right (Id c) 98 | 99 | instance (Dissect p, Dissect q) => Dissect (p :+ q) where 100 | type Ctx (p :+ q) = Ctx p :++ Ctx q 101 | plug x (L2 pd) = L1 (plug x pd) 102 | plug x (R2 qd) = R1 (plug x qd) 103 | 104 | right x = case x of 105 | (Left (L1 pj)) -> mindp (right (Left pj)) 106 | (Left (R1 qj)) -> mindq (right (Left qj)) 107 | (Right ((L2 pd, c))) -> mindp (right (Right (pd, c))) 108 | (Right ((R2 qd, c))) -> mindq (right (Right (qd, c))) 109 | where mindp (Left (j,pd)) = Left (j, L2 pd) 110 | mindp (Right pc) = Right (L1 pc) 111 | mindq (Left (j,pd)) = Left (j, R2 pd) 112 | mindq (Right pc) = Right (R1 pc) 113 | 114 | 115 | instance (Dissect p, Dissect q) => Dissect (p :* q) where 116 | type Ctx (p :* q) = (Ctx p :** JJ q) :++ (CC p :** Ctx q) 117 | plug x (L2 (pd :** JJ qx)) = plug x pd :* qx 118 | plug x (R2 (CC px :** qd)) = px :* plug x qd 119 | 120 | 121 | 122 | newtype Fix f = In { out :: f (Fix f) } 123 | 124 | type Loc f = (Fix f, [Ctx f (Fix f) (Fix f)]) 125 | 126 | type Context f r = Fix (K1 () :+ Ctx f r) -- note that the order of parameter is adapted from the paper. 127 | 128 | -- This ends up being exactly as Dissect, so I stop here. -------------------------------------------------------------------------------- /Open/Open.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --no-positivity-check 2 | #-} 3 | 4 | module Open where 5 | open import Data.Unit 6 | open import Logic 7 | import Data.Nat as Nat 8 | open import Data.Function 9 | open Nat using (ℕ) 10 | open Nat using (suc; zero) 11 | open Nat renaming ( _+_ to _+n_) 12 | 13 | 14 | data _×_ (a : Set) (b : Set) : Set where 15 | _,_ : a -> b -> a × b 16 | 17 | data _×₁_ (a : Set1) (b : Set1) : Set1 where 18 | _,₁_ : a -> b -> a ×₁ b 19 | 20 | outr : forall {a b} -> a × b -> b 21 | outr ( x , y ) = y 22 | 23 | outl : forall {a b} -> a × b -> a 24 | outl ( x , y ) = x 25 | 26 | data _+_ (a : Set) (b : Set) : Set where 27 | inl : a -> a + b 28 | inr : b -> a + b 29 | 30 | [_,_] : {a b c : Set} 31 | -> (a -> c) -> (b -> c) -> (a + b -> c) 32 | [ f , g ] (inl x) = f x 33 | [ f , g ] (inr y) = g y 34 | 35 | ⟨_,_⟩ : {a b c : Set} 36 | -> (a -> b) -> (a -> c) -> (a -> b × c) 37 | ⟨ f , g ⟩ x = ( f x , g x ) 38 | 39 | 40 | _×f_ : {a b c d : Set} -> (a -> b) -> (c -> d) -> (a × c -> b × d) 41 | f ×f g = ⟨ f ∘ outl , g ∘ outr ⟩ 42 | 43 | record Functor : Set1 where 44 | field 45 | F : Set -> Set 46 | f : {A B : Set} -> (A -> B) -> F A -> F B 47 | 48 | 49 | 50 | record TermAlgebra : Set1 where 51 | field BaseFunctor : Functor 52 | open Functor BaseFunctor 53 | 54 | data T : Set where 55 | α : F T -> T 56 | 57 | α⁻¹ : T -> F T 58 | α⁻¹ (α x) = x 59 | 60 | cata : {A : Set} -> (F A -> A) -> (T -> A) 61 | cata h = h ∘ f (cata h) ∘ α⁻¹ 62 | 63 | 64 | nat : TermAlgebra 65 | nat = record { 66 | BaseFunctor = record { 67 | F = \A -> ⊤ + A; 68 | f = \h -> [ inl , inr ∘ h ] 69 | } 70 | } 71 | 72 | 73 | list : Set -> TermAlgebra 74 | list A = record { 75 | BaseFunctor = record { 76 | F = \B -> ⊤ + (A × B); 77 | f = \h -> [ inl , inr ∘ id ×f h ] 78 | } 79 | } 80 | 81 | bool : TermAlgebra 82 | bool = record { 83 | BaseFunctor = record { 84 | F = \B -> ⊤ + ⊤; 85 | f = \h -> [ inl , inr ] 86 | } 87 | } 88 | 89 | 90 | boolAlgebra : TermAlgebra 91 | boolAlgebra = record { 92 | BaseFunctor = record { 93 | F = \B -> ⊤ + ⊤; 94 | f = \h -> [ inl , inr ] 95 | } 96 | } 97 | 98 | record BoolAlgebra : Set1 where 99 | open TermAlgebra boolAlgebra 100 | open Functor BaseFunctor 101 | 102 | true0 : _ -> _ + _ 103 | true0 = inl 104 | 105 | false0 : _ -> _ + _ 106 | false0 = inr 107 | 108 | true : ⊤ -> T 109 | true = α ∘ inl 110 | 111 | false : ⊤ -> T 112 | false = α ∘ inr 113 | 114 | not : T -> T 115 | not = cata [ false , true ] 116 | 117 | not0 : _ + _ -> _ + _ 118 | not0 = [ false0 , true0 ] 119 | 120 | not1 : ⊤ + ⊤ -> T 121 | not1 = α ∘ [ false0 , true0 ] 122 | 123 | unitAlgebra : TermAlgebra 124 | unitAlgebra = record { 125 | BaseFunctor = record { 126 | F = \B -> ⊤; 127 | f = \h -> id 128 | } 129 | } 130 | 131 | module UnitAlgebra where 132 | open TermAlgebra unitAlgebra 133 | 134 | unit : ⊤ -> T 135 | unit = α ∘ id 136 | 137 | not : T -> T 138 | not = cata unit 139 | 140 | 141 | _+Functor_ : Functor -> Functor -> Functor 142 | a +Functor b = record { 143 | F = \T -> Functor.F a T + Functor.F b T; 144 | f = \h -> [ inl ∘ Functor.f a h , inr ∘ Functor.f b h ] 145 | } 146 | 147 | 148 | _+Algebra_ : TermAlgebra -> TermAlgebra -> TermAlgebra 149 | a +Algebra b = record { BaseFunctor = TermAlgebra.BaseFunctor a +Functor TermAlgebra.BaseFunctor b } 150 | 151 | -- 152 | -- record PlusAlgebra : Set1 where 153 | -- field 154 | -- left : TermAlgebra 155 | -- right : TermAlgebra 156 | -- 157 | -- mix = left +Algebra right 158 | -- 159 | -- 160 | 161 | mixAlgebra = boolAlgebra +Algebra unitAlgebra 162 | 163 | record MixAlgebra : Set1 where 164 | open TermAlgebra mixAlgebra 165 | 166 | unit' : ⊤ -> T 167 | unit' = α ∘ inr ∘ TermAlgebra.α⁻¹ unitAlgebra ∘ UnitAlgebra.unit 168 | 169 | X = [ [ inl , inr ] , id ] -------------------------------------------------------------------------------- /Open/Open2.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --no-positivity-check 2 | #-} 3 | 4 | module Open2 where 5 | open import Data.Unit 6 | -- open import Logic 7 | import Data.Nat as Nat 8 | open import Data.Function 9 | open Nat using (ℕ) 10 | open Nat using (suc; zero) 11 | open Nat renaming ( _+_ to _+n_) 12 | open import Data.Bool 13 | 14 | data _×_ (a : Set) (b : Set) : Set where 15 | _,_ : a -> b -> a × b 16 | 17 | infixr 6 _×_ 18 | infixr 6 _,_ 19 | 20 | data _×₁_ (a : Set1) (b : Set1) : Set1 where 21 | _,₁_ : a -> b -> a ×₁ b 22 | 23 | outr : forall {a b} -> a × b -> b 24 | outr ( x , y ) = y 25 | 26 | outl : forall {a b} -> a × b -> a 27 | outl ( x , y ) = x 28 | 29 | data _+_ (a : Set) (b : Set) : Set where 30 | inl : a -> a + b 31 | inr : b -> a + b 32 | 33 | [_,_] : {a b c : Set} 34 | -> (a -> c) -> (b -> c) -> (a + b -> c) 35 | [ f , g ] (inl x) = f x 36 | [ f , g ] (inr y) = g y 37 | 38 | ⟨_,_⟩ : {a b c : Set} 39 | -> (a -> b) -> (a -> c) -> (a -> b × c) 40 | ⟨ f , g ⟩ x = ( f x , g x ) 41 | 42 | 43 | _×f_ : {a b c d : Set} -> (a -> b) -> (c -> d) -> (a × c -> b × d) 44 | f ×f g = ⟨ f ∘ outl , g ∘ outr ⟩ 45 | infixr 6 _×f_ 46 | 47 | record Functor : Set1 where 48 | field 49 | F : Set -> Set 50 | f : {A B : Set} -> (A -> B) -> F A -> F B 51 | 52 | o : Functor -> Set -> Set 53 | o = Functor.F 54 | 55 | Alg : Functor -> {A : Set} -> Set 56 | Alg F {A} = o F A -> A 57 | 58 | 59 | map : (F : Functor) {A : Set} {B : Set} -> (A -> B) -> o F A -> o F B 60 | map = Functor.f 61 | 62 | 63 | data T {F : Functor} : Set where 64 | α : o F (T {F}) -> T 65 | 66 | α⁻¹ : {F : Functor} -> T {F} -> o F T 67 | α⁻¹ (α x) = x 68 | 69 | cata : {F : Functor} -> {A : Set} -> Alg F -> (T {F} -> A) 70 | cata {F} h = h ∘ map F (cata h) ∘ α⁻¹ 71 | 72 | irr : {F : Functor} -> {A : Set} -> (T {F} × o F A -> A) -> (T {F} -> A) 73 | irr {F} h = h ∘ (id ×f map F (irr h)) ∘ ⟨ id , α⁻¹ ⟩ 74 | 75 | natF : Functor 76 | natF = record { 77 | F = \A -> ⊤ + A; 78 | f = \h -> [ inl , inr ∘ h ] 79 | } 80 | 81 | unitF : Functor 82 | unitF = record { 83 | F = \B -> ⊤; 84 | f = \h -> \x -> x 85 | } 86 | 87 | rec1F : Set -> Functor 88 | rec1F A = record { 89 | F = \B -> A × B; 90 | f = \h -> id ×f h 91 | } 92 | 93 | listF : Set -> Functor 94 | listF A = record { 95 | F = \B -> ⊤ + (A × B); 96 | f = \h -> [ inl , inr ∘ (id ×f h) ] 97 | } 98 | 99 | treeF : Set -> Functor 100 | treeF A = record { 101 | F = \B -> ⊤ + (B × A × B); 102 | f = \h -> [ inl , inr ∘ (h ×f id ×f h) ] 103 | } 104 | 105 | rec2F : Set -> Functor 106 | rec2F A = record { 107 | F = \B -> B × A × B; 108 | f = \h -> h ×f id ×f h 109 | } 110 | 111 | 112 | boolF : Functor 113 | boolF = record { 114 | F = \B -> ⊤ + ⊤; 115 | f = \h -> [ inl , inr ] 116 | } 117 | 118 | 119 | _+F_ : Functor -> Functor -> Functor 120 | a +F b = record { 121 | F = \T -> Functor.F a T + Functor.F b T; 122 | f = \h -> [ inl ∘ Functor.f a h , inr ∘ Functor.f b h ] 123 | } 124 | infixr 6 _+F_ 125 | 126 | _+A_ : {A : Set} {F G : Functor} -> Alg F -> Alg G -> Alg (F +F G) {A} 127 | f +A g = [ f , g ] 128 | 129 | 130 | max : ℕ -> ℕ -> ℕ 131 | max zero x = x 132 | max x zero = x 133 | max (suc x) (suc y) = suc (max x y) 134 | 135 | depthU : Alg unitF 136 | depthU = const 0 137 | 138 | depthT : {A : Set} -> Alg (rec2F A) 139 | depthT ( l , x , r ) = suc (max l r) 140 | 141 | depthL : {A : Set} -> Alg (rec1F A) 142 | depthL ( x , rec ) = suc rec 143 | 144 | mixF : Set -> Functor 145 | mixF A = unitF +F rec1F A +F rec2F A 146 | 147 | mixDepth : {A : Set} -> T {mixF A} -> ℕ 148 | mixDepth = cata [ depthU , [ depthL , depthT ] ] 149 | 150 | addCase : {F : Functor } -> {A : Set} -> (o F A -> Bool) -> Alg F {A} -> Alg F {A} -> Alg F 151 | addCase pred algT algF input with pred input 152 | ... | False = algT input 153 | ... | True = algF input 154 | 155 | 156 | -------------------------------------------------------------------------------- /Machines/SuspensionVM.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) JP Bernardy 2008 2 | 3 | {-# OPTIONS -fglasgow-exts #-} 4 | module SuspensionVM where 5 | import Control.Applicative 6 | import Data.Foldable 7 | import Data.Traversable 8 | import Data.List hiding (map, minimumBy) 9 | import Data.Char 10 | import Data.Maybe (listToMaybe) 11 | 12 | data Void 13 | 14 | data a :< b = a :< b 15 | 16 | hd (a :< _) = a 17 | 18 | infixr :< 19 | 20 | 21 | data Steps s r where 22 | Val :: a -> Steps s r -> Steps s (a :< r) 23 | App :: (Steps s ((b -> a) :< b :< r)) -> Steps s (a :< r) 24 | Done :: Steps s Void 25 | Suspend :: Steps s r -> (s -> Steps s r) -> Steps s r 26 | -- note1. the similarity with list-eliminator 27 | -- note2. the 1st argument should not be suspendable at all! 28 | -- note3. the 2nd argument cannot depend on the tail of the list, 29 | -- because this will be provided in further steps. 30 | 31 | profile :: Steps s r -> String 32 | profile (Val x s) = '.' : profile s 33 | profile (App s) = '$' : profile s 34 | profile (Suspend _ _) = "?" 35 | profile (Done) = "!" 36 | 37 | -- | Right-eval with input 38 | evalR :: [s] -> Steps s r -> r 39 | evalR ss (Val a r) = a :< evalR ss r 40 | evalR ss (App s) = (\(f:< ~(a: f a :< r) (evalR ss s) 41 | evalR [] (Suspend nil cons) = evalR [] nil 42 | evalR (s:ss)(Suspend nil cons) = evalR ss (cons s) 43 | 44 | -- | A computation segment 45 | newtype P s a = P {fromP :: forall r. Steps s r -> Steps s (a :< r)} 46 | 47 | toProc :: P s a -> Steps s (a :< Void) 48 | toProc (P p) = p Done 49 | 50 | instance Functor (P s) where 51 | fmap f x = pure f <*> x 52 | 53 | instance Applicative (P s) where 54 | P f <*> P x = P (\fut -> (App (f (x fut)))) 55 | pure x = P (\fut -> Val x $ fut) 56 | 57 | -- | Pre-compute a left-prefix of some steps (as far as possible) 58 | evalL :: Steps s a -> Steps s a 59 | evalL (Val x r) = Val x (evalL r) 60 | evalL (App f) = case evalL f of 61 | (Val a (Val b r)) -> Val (a b) r 62 | -- (Val f1 (App (Val f2 r))) -> App (Val (f1 . f2) r) 63 | r -> App r 64 | evalL x = x 65 | 66 | 67 | evalLAll :: Steps s a -> [s] -> [Steps s a] 68 | evalLAll = scanl (\c -> evalL . pushOne c) 69 | 70 | 71 | pushEof :: Steps s a -> Steps s a 72 | pushEof (Val x s) = Val x (pushEof s) 73 | pushEof (App f) = App (pushEof f) 74 | pushEof (Suspend nil cons) = pushEof nil 75 | 76 | 77 | pushOne :: Steps s a -> s -> Steps s a 78 | pushOne (Val x s) ss = Val x (pushOne s ss) 79 | pushOne (App f) ss = App (pushOne f ss) 80 | pushOne (Suspend nil cons) s = cons s 81 | 82 | 83 | pushSyms :: [s] -> Steps s a -> Steps s a 84 | pushSyms [] x = x 85 | pushSyms ss (Val x s) = Val x (pushSyms ss s) 86 | pushSyms ss (App f) = App (pushSyms ss f) 87 | pushSyms (s:ss) (Suspend nil cons) = pushSyms ss (cons s) 88 | 89 | 90 | -------------- 91 | -- Example: Online Tree 92 | 93 | data Tree a = Node a (Tree a) (Tree a) 94 | | Leaf 95 | deriving Show 96 | 97 | {- 98 | 99 | Why not the more classical definition? 100 | 101 | data Bin a = Bin (Tree a) (Tree a) 102 | | Leaf a 103 | | Nil 104 | 105 | Leaf or Bin? 106 | We cannot to decide which constructor to return with a minimal look ahead! 107 | 108 | -} 109 | 110 | instance Traversable Tree where 111 | traverse f (Node x l r) = Node <$> f x <*> traverse f l <*> traverse f r 112 | traverse f Leaf = pure Leaf 113 | 114 | case_ :: P s a -> (s -> P s a) -> P s a 115 | case_ (P nil) cons = P $ \fut -> Suspend (nil fut) (\s -> fromP (cons s) fut) 116 | 117 | instance Foldable Tree where 118 | foldMap = foldMapDefault 119 | 120 | instance Functor Tree where 121 | fmap = fmapDefault 122 | 123 | 124 | toTree leftSize maxSize 125 | | maxSize <= 0 = pure Leaf 126 | | otherwise = case_ (pure Leaf) $ 127 | \x -> Node <$> pure x 128 | <*> toTree factor (min leftSize (maxSize - 1)) 129 | <*> toTree (leftSize * factor) (maxSize - leftSize - 1) 130 | 131 | factor = 2 132 | initialLeftSize = 2 133 | 134 | tt :: P s (Tree s) 135 | tt = toTree initialLeftSize (maxBound :: Int) -------------------------------------------------------------------------------- /TypeClasses/MPTC.agda: -------------------------------------------------------------------------------- 1 | open import Data.Nat 2 | open import Data.Fin 3 | open import Data.Bool 4 | open import Data.Maybe 5 | open import Data.Vec 6 | 7 | module MPTC where 8 | 9 | -- test if two boolean values are equal 10 | boolTest : Bool -> Bool -> Bool 11 | boolTest true true = true 12 | boolTest false false = true 13 | boolTest _ _ = false 14 | 15 | 16 | -- we work on a closed universe of types, whose codes are as follows: 17 | data Code : Set where 18 | boolCode : Code 19 | natCode : Code 20 | -- listCode : Code -> Code 21 | 22 | ⟦_⟧ : Code -> Set 23 | ⟦ boolCode ⟧ = Bool 24 | ⟦ natCode ⟧ = ℕ 25 | 26 | data Vec₁ (a : Set1) : ℕ -> Set1 where 27 | []₁ : Vec₁ a zero 28 | _∷₁_ : forall {n} -> a -> Vec₁ a n -> Vec₁ a (suc n) 29 | 30 | lookup₁ : forall {a n} -> Fin n -> Vec₁ a n -> a 31 | lookup₁ zero (x ∷₁ xs) = x 32 | lookup₁ (suc i) (x ∷₁ xs) = lookup₁ i xs 33 | 34 | 35 | map₀₁ : forall {a b n} -> (a -> b) -> Vec a n -> Vec₁ b n 36 | map₀₁ f [] = []₁ 37 | map₀₁ f (x ∷ xs) = f x ∷₁ map₀₁ f xs 38 | 39 | ⟦_⟧ⁿ : forall {n} -> Vec Code n -> Vec₁ Set n 40 | ⟦_⟧ⁿ = map₀₁ ⟦_⟧ 41 | 42 | 43 | -- a class 44 | record Class : Set1 where 45 | field 46 | arity : ℕ 47 | sig : Vec₁ Set arity -> Set -- mapping parameters to specific signature 48 | instances : (c : Vec Code arity) -> Maybe (sig ⟦ c ⟧ⁿ) -- mapping codes to definitions 49 | 50 | -- Helper type to enforce that a value is "just" (in Maybe) 51 | data IsJust {a : Set} : Maybe a -> Set where 52 | isJust : {x : a} -> IsJust (just x) 53 | 54 | -- Constraint on a given class 55 | Constraint : (class : Class) -> Vec Code (Class.arity class) -> Set 56 | Constraint class c = IsJust (Class.instances class c) 57 | 58 | 59 | ----------------------------- 60 | -- Example: "Equality" class 61 | 62 | 63 | -- Signature for Eq class 64 | record EqClassSig (t : Vec₁ Set 2) : Set where 65 | field 66 | == : lookup₁ zero t -> lookup₁ (suc zero) t -> Bool 67 | 68 | -- Instances for the Eq class 69 | eqClassInstances : (c : Vec Code 2) -> Maybe (EqClassSig ⟦ c ⟧ⁿ) 70 | eqClassInstances (boolCode ∷ boolCode ∷ []) = just (record {== = boolTest}) 71 | eqClassInstances _ = nothing 72 | 73 | -- Definition of the Eq class 74 | eqClass : Class 75 | eqClass = record {arity = 2; sig = EqClassSig; instances = eqClassInstances} 76 | 77 | -- matching on having a type-class or not (see "beautiful" example) 78 | eq2 : {c : Code} -> ⟦ c ⟧ -> ⟦ c ⟧ -> ⟦ c ⟧ -> Bool 79 | eq2 {c} x y z with Class.instances eqClass (c ∷ c ∷ []) 80 | ... | just sig = let _==_ = EqClassSig.== sig in (x == y) ∧ (y == z) 81 | ... | nothing = false 82 | 83 | 84 | -- The "Eq" constraint 85 | Eq : Code -> Code -> Set 86 | Eq c d = Constraint eqClass (c ∷ d ∷ []) 87 | 88 | -- enforcing class constraints: 89 | eq2' : {c : Code} -> {p : Eq c c} -> ⟦ c ⟧ -> ⟦ c ⟧ -> ⟦ c ⟧ -> Bool 90 | eq2' {c} {p} x y z with Class.instances eqClass (c ∷ c ∷ []) 91 | eq2' {c} {IsJust} x y z | just sig = let _==_ = EqClassSig.== sig in (x == y) ∧ (y == z) 92 | eq2' {c} {()} x y z | nothing 93 | 94 | 95 | -- using at a monomorphic type 96 | eqBools : Bool -> Bool -> Bool -> Bool 97 | eqBools = eq2' {boolCode} {isJust} -- strange that these can't be inferred! 98 | 99 | 100 | -- misusing at a monomorphic type 101 | eqNats : ℕ -> ℕ -> ℕ -> Bool 102 | eqNats = eq2' {natCode} {{! !}} 103 | -- Note: we can define a "wrong" function, and leave the burden of proof to the caller. 104 | -- (I think this is akin to so called "axiomatic classes" in Isabelle.) 105 | 106 | 107 | ---------------------------------------------------------------- 108 | -- Signature for zero-parameter class 109 | record ZeroClassSig (t : Vec₁ Set 0) : Set where 110 | field 111 | hello : ℕ 112 | -- Instances for the Zero class 113 | zeroClassInstances : ℕ -> (c : Vec Code 0) -> Maybe (ZeroClassSig ⟦ c ⟧ⁿ) 114 | zeroClassInstances n _ = just (record { hello = n }) 115 | 116 | -- Definition of the Zero class 117 | zero5Class : Class 118 | zero5Class = record {arity = 0; sig = ZeroClassSig; instances = zeroClassInstances 5} 119 | 120 | -- The zero-parameter concepts are basically records. 121 | -------------------------------------------------------------------------------- /Parsers/Polish.agda: -------------------------------------------------------------------------------- 1 | module Polish where 2 | 3 | open import Data.Nat 4 | open import Data.List hiding (zip) 5 | 6 | data List1 (T : Set1) : Set1 where 7 | Nil : List1 T 8 | Cons : (A : T) -> List1 T -> List1 T 9 | 10 | -- Lists of Sets 11 | SetList : Set1 12 | SetList = List1 Set 13 | 14 | -- Heterogeneous lists, indexed by the types of values in it. 15 | data HList : SetList -> Set1 where 16 | Nil0 : HList Nil 17 | Cons0 : {A : Set} {Ts : SetList} -> (a : A) -> HList Ts -> HList (Cons A Ts) 18 | 19 | -- Arbitary expressions in Polish notation. 20 | -- Polish is indexed by the types in the stack produced by the expression. 21 | data Polish : SetList -> Set1 where 22 | Val : {A : Set} {Rest : SetList} -> A -> Polish Rest -> Polish (Cons A Rest) 23 | App : {A B : Set} {Rest : SetList} -> Polish (Cons (A -> B) (Cons A Rest)) -> Polish (Cons B Rest) 24 | Stop : Polish Nil 25 | 26 | -- Evaluate the output of an expression 27 | evalP : (Ts : SetList) -> Polish Ts -> HList Ts 28 | evalP Nil Stop = Nil0 29 | evalP (Cons A Ts) (Val a rest) = Cons0 a (evalP Ts rest) 30 | evalP (Cons B Ts) (App p) with evalP _ p 31 | ... | Cons0 f (Cons0 a rest) = Cons0 (f a) rest 32 | 33 | -- Arbitrary expressions in Reverse Polish notation. 34 | -- This can also be seen as an automaton that transforms a stack. 35 | -- RPolish is indexed by the types in the stack consumed by the automaton. 36 | data RPolish : SetList -> Set1 where 37 | RVal : {A : Set} {Rest : SetList} -> A -> RPolish (Cons A Rest) -> RPolish Rest 38 | RApp : {A B : Set} {Rest : SetList} -> RPolish (Cons B Rest) -> RPolish (Cons (A -> B) (Cons A Rest)) 39 | RStop : {Rest : SetList} -> RPolish Rest 40 | 41 | 42 | -- Compute the final stack produced by an RPolish automaton. 43 | produced : {input : SetList} -> RPolish input -> SetList 44 | produced {input} RStop = input 45 | produced (RApp {A} {B} {Rest} r) = produced {Cons B Rest} r 46 | produced (RVal {A} {Rest} _ r) = produced {Cons A Rest} r 47 | 48 | -- Evaluate the output of an RP automaton, given an input stack 49 | evalRP : {Ts : SetList} -> (rp : RPolish Ts) -> HList Ts -> HList (produced rp) 50 | evalRP RStop acc = acc 51 | evalRP (RVal v r) acc = evalRP r (Cons0 v acc) 52 | evalRP (RApp r) (Cons0 f (Cons0 a acc)) = evalRP r (Cons0 (f a) acc) 53 | 54 | -- Evaluate "as much as possible" of an RP automaton, /without knowing its input stack/ 55 | simplify : {Ts : SetList} -> RPolish Ts -> RPolish Ts 56 | simplify (RVal a (RVal f (RApp r))) = simplify (RVal (f a) r) 57 | simplify r = r 58 | 59 | -- Gluing a Polish expression and an RP automaton. 60 | -- This can also be seen as a zipper of Polish expressions. 61 | -- Zip is indexed by the types produced in the final stack. 62 | data Zip : SetList -> Set1 where 63 | zip : {Stack : SetList} -> (rp : RPolish Stack) -> Polish Stack -> Zip (produced rp) 64 | -- note that the Stack produced by the Polish expression matches 65 | -- the stack consumed by the automaton. 66 | 67 | -- Move the zipper to the right, if possible. The type gives evidence 68 | -- that this function does not change the (type of) output produced. 69 | right : {Stack : SetList} -> Zip Stack -> Zip Stack 70 | right (zip l Stop) = (zip l Stop) 71 | right (zip l (Val a r)) = zip (RVal a l) r 72 | right (zip l (App r)) = zip (RApp l) r 73 | 74 | -- Move the zipper to the left if possible. The type gives evidence 75 | -- that this function does not change the (type of) output produced. 76 | left : {Stack : SetList} -> Zip Stack -> Zip Stack 77 | left (zip RStop r) = (zip RStop r) 78 | left (zip (RVal a l) r) = zip l (Val a r) 79 | left (zip (RApp l) r) = zip l (App r) 80 | 81 | -- Evaluate the output of a whole Zip 82 | evalZ : (Stack : SetList) -> Zip Stack -> HList Stack 83 | evalZ .(produced rp) (zip {intermediateStack} rp p) = evalRP rp (evalP intermediateStack p) 84 | 85 | 86 | 87 | infixr 0 _$_ 88 | 89 | _$_ : {A B : Set1} -> (A -> B) -> A -> B 90 | f $ x = f x 91 | 92 | test1 = {! (eval _ (App $ App $ Val _∷_ $ Val 1 $ App $ App $ Val _∷_ $ Val 2 $ Val [] $ Stop)) !} 93 | 94 | test0 : {R : SetList} -> RPolish R 95 | test0 = RVal 1 $ RVal 2 $ RVal _+_ $ RApp $ RApp $ RStop 96 | 97 | -------------------------------------------------- 98 | -- Follows obsolete stuff. 99 | 100 | data Couple12 (A : Set) (B : Set1) : Set1 where 101 | _,_ : A -> B -> Couple12 A B 102 | 103 | fst : {A : Set} {B : Set1} -> Couple12 A B -> A 104 | fst (a , b) = a 105 | 106 | 107 | snd : {A : Set} {B : Set1} -> Couple12 A B -> B 108 | snd (a , b) = b 109 | 110 | 111 | eval0 : {A : Set} {Rest : SetList} -> Polish (Cons A Rest) -> Couple12 A (Polish Rest) 112 | eval0 (Val a rest) = a , rest 113 | eval0 (App p) = let 114 | fp' = eval0 p 115 | ap'' = eval0 (snd fp') 116 | in fst fp' (fst ap'') , snd ap'' 117 | 118 | 119 | -------------------------------------------------------------------------------- /OnlineTree/OnlineTree.agda: -------------------------------------------------------------------------------- 1 | 2 | 3 | module OnlineTree where 4 | 5 | import Relation.Binary.EqReasoning 6 | 7 | open import Data.Nat 8 | open import Data.Empty 9 | open import Data.Unit 10 | open import Data.Vec 11 | open import Data.Product 12 | open import Relation.Binary.PropositionalEquality 13 | 14 | 15 | 16 | Nat = ℕ 17 | 18 | open Relation.Binary.EqReasoning (≡-setoid Nat) 19 | 20 | factor = 2 21 | initial = 2 22 | 23 | True = ⊤ 24 | 25 | _-_ : Nat -> Nat -> Nat 26 | zero - n = zero 27 | n - zero = n 28 | suc n - suc m = n - m 29 | infixl 1 _-_ 30 | 31 | lemma-sub : forall n -> (n - 0) ≡ n 32 | lemma-sub zero = ≡-refl 33 | lemma-sub (suc n) = ≡-refl 34 | 35 | min = _⊓_ 36 | 37 | 38 | 39 | lemma-min : forall n -> zero ≡ min n zero 40 | lemma-min zero = ≡-refl 41 | lemma-min (suc n) = ≡-refl 42 | 43 | ⊓-assoc : forall a b c -> (a ⊓ b) ⊓ c ≡ a ⊓ (b ⊓ c) 44 | ⊓-assoc zero b c = ≡-refl 45 | ⊓-assoc (suc n) zero c = ≡-refl 46 | ⊓-assoc (suc n) (suc n') zero = ≡-refl 47 | ⊓-assoc (suc a) (suc b) (suc c) = ≡-cong suc (⊓-assoc a b c) 48 | 49 | max : Nat -> Nat -> Nat 50 | max zero n = n 51 | max m zero = m 52 | max (suc m) (suc n) = suc (max m n) 53 | 54 | data Tree (a : Set) (maxLeftSize : Nat) : (size : Nat) -> Set where 55 | Leaf : Tree a maxLeftSize 0 56 | Node : forall size-1 -> 57 | let leftSize = min maxLeftSize (size-1) 58 | rightSize = size-1 - leftSize in 59 | a -> Tree a initial leftSize -> Tree a (maxLeftSize * factor) rightSize -> 60 | Tree a maxLeftSize (1 + size-1) 61 | 62 | measure : forall {a maxLeftSize size} -> Tree a maxLeftSize size -> Nat 63 | measure Leaf = 0 64 | measure {a} {maxLeftSize} (Node _ _ l r) = 1 + measure l + measure r 65 | 66 | 67 | 68 | 69 | thm-0 : forall n m -> min m n + (n - min m n) ≡ n 70 | thm-0 zero m = ≡-cong (\x -> x + 0) (≡-sym (lemma-min m)) 71 | thm-0 (suc n) zero = ≡-refl 72 | thm-0 (suc n) (suc m) = ≡-cong suc (thm-0 n m) 73 | 74 | -- The measure and the size coincide. 75 | thm-measure : forall {a maxLeftSize} -> {size : Nat} -> (t : Tree a maxLeftSize size) -> measure t ≡ size 76 | thm-measure Leaf = ≡-refl 77 | thm-measure (Node size _ l r) with measure l | measure r | thm-measure l | thm-measure r 78 | thm-measure {a} {maxLeftSize} {.(suc size-1)} (Node size-1 y l r) 79 | | .(min maxLeftSize (size-1)) 80 | | .(size-1 - min maxLeftSize (size-1)) 81 | | ≡-refl | ≡-refl 82 | = ≡-cong suc (thm-0 size-1 maxLeftSize) 83 | 84 | depth : forall {a maxLeftSize size} -> Tree a maxLeftSize size -> Nat 85 | depth Leaf = 0 86 | depth (Node size-1 _ l r ) = 1 + max (depth l) (depth r) 87 | 88 | lookTime : forall {a maxLeftSize size} -> Tree a maxLeftSize size -> Nat -> Nat 89 | lookTime Leaf n = 0 -- not found 90 | lookTime (Node size-1 _ l r) zero = 0 -- at the root 91 | lookTime {a} {maxLeftSize} {.(suc size-1)} (Node size-1 _ l r) (suc index-1) with compare (suc index-1) maxLeftSize 92 | lookTime {a} {.(suc (suc (index-1 + k)))} {.(suc size-1)} 93 | (Node size-1 _ l r) 94 | (suc index-1) 95 | | less .(suc index-1) k 96 | = lookTime l index-1 -- in left. 97 | lookTime {a} {.(suc index-1)} {.(suc size-1)} (Node size-1 y l r) 98 | (suc index-1) 99 | | equal .(suc index-1) 100 | = lookTime l index-1 101 | lookTime {a} {maxLeftSize} {.(suc size-1)} (Node size-1 y l r) 102 | (suc .(maxLeftSize + k)) 103 | | greater .maxLeftSize k 104 | = lookTime r k 105 | 106 | -- Whoops! 107 | 108 | lemma-min-sub : forall n m -> (m - n) ≡ (m - min n m) 109 | lemma-min-sub zero n = ≡-refl 110 | lemma-min-sub (suc m) zero = ≡-refl 111 | lemma-min-sub (suc m) (suc n) = lemma-min-sub m n 112 | 113 | 114 | lemma-xs : forall n m o -> (n - m ⊓ o - (o - m ⊓ o)) ≡ (n - o) 115 | lemma-xs zero m o = ≡-refl 116 | lemma-xs (suc n) zero o = ≡-cong (\x -> suc n - x) (lemma-sub o) 117 | lemma-xs (suc n) (suc n') zero = ≡-refl 118 | lemma-xs (suc n) (suc n') (suc n0) = lemma-xs n n' n0 119 | 120 | lemma-r : forall n m o -> ((o - m ⊓ o) ⊓ (n - m ⊓ o)) ≡ (o ⊓ n - m ⊓ (o ⊓ n)) 121 | lemma-r zero zero zero = ≡-refl 122 | lemma-r zero zero (suc n) = ≡-refl 123 | lemma-r zero (suc n) zero = ≡-refl 124 | lemma-r zero (suc m) (suc o) = ≡-sym (lemma-min (o - m ⊓ o)) 125 | lemma-r (suc n) zero zero = ≡-refl 126 | lemma-r (suc n) zero (suc n') = ≡-refl 127 | lemma-r (suc n) (suc n') zero = ≡-refl 128 | lemma-r (suc n) (suc m) (suc o) = lemma-r n m o 129 | 130 | -- leftBudget = min leftSize budget-1 131 | toTree' : (a : Set) (n : Nat) -> (budget : Nat) -> (leftSize : Nat) -> Vec a n -> (Tree a leftSize (min budget n) × Vec a (n - budget)) 132 | toTree' a zero budget leftSize [] = ≡-subst (Tree a leftSize) (lemma-min budget) Leaf , [] 133 | toTree' a (suc n) zero leftSize xs = Leaf , xs 134 | toTree' a (suc n) (suc budget-1) leftSize (x ∷ xs) with toTree' a n (min leftSize budget-1) initial xs 135 | ... | (l , xs') with toTree' a (n - min leftSize budget-1) (budget-1 - min leftSize budget-1) (leftSize * factor) xs' 136 | ... | (r , xs'' ) = Node (min budget-1 n) x 137 | (≡-subst (Tree a initial) (⊓-assoc leftSize budget-1 n) l) 138 | (≡-subst (Tree a (leftSize * factor)) (lemma-r n leftSize budget-1) r) 139 | , 140 | ≡-subst (Vec a) (lemma-xs n leftSize budget-1) xs'' 141 | 142 | -------------------------------------------------------------------------------- /PolyTest/Implementation/Fun.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --no-positivity-check #-} 2 | 3 | module Fun where 4 | 5 | 6 | open import Data.Unit 7 | open import Data.Nat hiding (_+_) 8 | open import Data.Bool 9 | open import Data.Maybe 10 | open import Data.Empty 11 | open import Data.String 12 | open import Relation.Nullary 13 | open import Relation.Binary.PropositionalEquality 14 | open import Relation.Binary.PropositionalEquality1 15 | 16 | data _+0_ (A : Set) (B : Set) : Set where 17 | L : A -> A +0 B 18 | R : B -> A +0 B 19 | 20 | data _×0_ (A : Set) (B : Set) : Set where 21 | _,_ : A -> B -> A ×0 B 22 | 23 | 24 | data Type : Set1 where 25 | var : Type 26 | _==>_ : (arg : Type) -> (res : Type) -> Type 27 | con : (k : Set) -> Type 28 | 29 | infixr 2 _==>_ 30 | 31 | NoFun : ℕ -> Type -> Set 32 | NoFun n var = ⊤ 33 | NoFun n (con _) = ⊤ 34 | NoFun zero (_ ==> _) = ⊥ 35 | NoFun (suc n) (arg ==> res) = NoFun n arg ×0 NoFun (suc n) res 36 | 37 | 38 | data Functor : Set1 where 39 | id : Functor 40 | k1 : Set -> Functor 41 | _+_ : Functor -> Functor -> Functor 42 | _×_ : Functor -> Functor -> Functor 43 | z1 : Functor 44 | 45 | infixr 1 _+_ 46 | infixr 3 _×_ 47 | 48 | 49 | f[_] : Functor -> Set -> Set 50 | f[_] id s = s 51 | f[_] (k1 y) s = y 52 | f[_] (y + y') s = f[ y ] s +0 f[ y' ] s 53 | f[_] (y × y') s = f[ y ] s ×0 f[ y' ] s 54 | f[_] z1 s = ⊥ 55 | 56 | functor[[_]] : Type -> Set -> Set 57 | functor[[ var ]] v = v 58 | functor[[ con t ]] v = t 59 | functor[[ _==>_ t1 t2 ]] v = functor[[ t1 ]] v → functor[[ t2 ]] v 60 | 61 | functorOf : (t : Type) -> NoFun 0 t -> Functor 62 | functorOf var _ = id 63 | functorOf (_==>_ y y') () 64 | functorOf (con y) _ = k1 y 65 | 66 | [[_]] : Type -> Set1 67 | [[ t ]] = (a : Set) -> functor[[ t ]] a 68 | 69 | wellBehaved : (i : Set) (t : Type) -> (nf : NoFun 0 t) -> functor[[ t ]] i ≡₁ f[ functorOf t nf ] i 70 | wellBehaved i var _ = refl 71 | wellBehaved i (y ==> y') () 72 | wellBehaved i (con y) nf = refl 73 | 74 | 75 | convert : forall {a b : Set} -> (a ≡₁ b) -> a -> b 76 | convert refl a = a 77 | 78 | -- Bit of a functor to extract from an argument. 79 | functorBit : (t : Type) -> NoFun 1 t -> Functor 80 | functorBit var _ = (k1 ⊤) 81 | functorBit (arg ==> res) (nfa , nf) = functorOf arg nfa × functorBit res nf 82 | functorBit (con y) _ = z1 83 | 84 | 85 | -- Functor of the algebra that the function depends on. 86 | extractFunctor : (t : Type) -> NoFun 2 t -> Functor 87 | extractFunctor var _ = z1 88 | extractFunctor (_==>_ y y') (nfa , nf) = functorBit y nfa + extractFunctor y' nf 89 | extractFunctor (con y) _ = z1 90 | 91 | 92 | 93 | YieldsAlgebra : Type -> Set 94 | YieldsAlgebra var = ⊤ 95 | YieldsAlgebra (y ==> y') = YieldsAlgebra y' 96 | YieldsAlgebra (con y) = ⊥ 97 | 98 | doesYieldAlgebra : (t : Type) -> Dec (YieldsAlgebra t) 99 | doesYieldAlgebra var = yes tt 100 | doesYieldAlgebra (y ==> y') = doesYieldAlgebra y' 101 | doesYieldAlgebra (con y) = no (λ ()) 102 | 103 | 104 | data Fix (f : Set -> Set) : Set where In : f (Fix f) -> Fix f 105 | 106 | 107 | toMonotypeArgAcc : (initialType : Set) -> (t : Type) -> (Set -> Set) -> Set 108 | toMonotypeArgAcc i var acc = ⊤ 109 | toMonotypeArgAcc i (y ==> y') acc = toMonotypeArgAcc i y' (λ rhs → acc ((functor[[ y ]] i) → rhs)) 110 | toMonotypeArgAcc i (con y) acc = acc y 111 | 112 | toMonotypeArg : (initialType : Set) -> (t : Type) -> Set 113 | toMonotypeArg i t with doesYieldAlgebra t 114 | ... | no _ = functor[[ t ]] i 115 | ... | yes _ = ⊤ 116 | 117 | -- Compute the monotype for the testing 118 | toMonotype : (initialType : Set) -> (t : Type) -> Set 119 | toMonotype i var = i 120 | toMonotype i (y ==> y') = toMonotypeArg i y → toMonotype i y' 121 | toMonotype i (con y) = y 122 | 123 | 124 | algebraBit : (initialType : Set) -> (t : Type) -> (nf : NoFun 1 t) -> (f[ functorBit t nf ] initialType -> initialType) -> YieldsAlgebra t -> functor[[ t ]] initialType 125 | algebraBit i var nf inject ya = inject tt 126 | algebraBit i (y ==> y') (nfa , nf) inject ya = λ fyi → algebraBit i y' nf (λ bit → inject (convert (wellBehaved i y nfa) fyi , bit)) ya 127 | algebraBit i (con y) nf inject () 128 | 129 | 130 | toMono' : (initialType : Set) -> (t : Type) -> (nf : NoFun 2 t) -> (f[ extractFunctor t nf ] initialType -> initialType) -> functor[[ t ]] initialType -> toMonotype initialType t 131 | toMono' i var nf inj v = v 132 | toMono' i (y ==> y') nf inj v with doesYieldAlgebra y 133 | toMono' i (y ==> y') (nfa , nf) inj v | yes p = λ arg → toMono' i y' nf (λ subArg → inj (R subArg)) (v (algebraBit i y nfa (λ subArg → inj (L subArg)) p)) 134 | toMono' i (y ==> y') (nfa , nf) inj v | no _ = λ arg → toMono' i y' nf (λ subArg → inj (R subArg)) (v arg) 135 | toMono' i (con y) nf inj v = v 136 | 137 | toTestType : (t : Type) -> NoFun 2 t -> Set 138 | toTestType t nf = toMonotype (Fix f[ extractFunctor t nf ]) t 139 | 140 | toMono : (t : Type) -> (nf : NoFun 2 t) -> [[ t ]] -> toTestType t nf 141 | toMono t nf v = toMono' initialType t nf In (v initialType) 142 | where initialType = Fix f[ extractFunctor t nf ] 143 | 144 | 145 | 146 | postulate InitialType : Set 147 | 148 | binT = var ==> var ==> var 149 | predT = var ==> con Bool 150 | filterT = (var ==> con Bool) ==> (con ℕ ==> var) ==> con ℕ ==> var 151 | 152 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/mid.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 19 | 21 | 28 | 29 | 49 | 54 | 55 | 57 | 58 | 60 | image/svg+xml 61 | 63 | 64 | 65 | 66 | 71 | 76 | 84 | 89 | 94 | 98 | 106 | 111 | 112 | 113 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/talk/mid.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 19 | 21 | 28 | 29 | 49 | 54 | 55 | 57 | 58 | 60 | image/svg+xml 61 | 63 | 64 | 65 | 66 | 71 | 76 | 84 | 89 | 94 | 98 | 106 | 111 | 112 | 113 | -------------------------------------------------------------------------------- /Open/Open4.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --no-positivity-check #-} 2 | 3 | module Open4 where 4 | open import Data.Unit 5 | -- open import Logic 6 | import Data.Nat as Nat 7 | open import Data.Function 8 | open Nat 9 | open import Data.Bool 10 | open import Data.List 11 | open import Data.Product 12 | open import Data.Empty 13 | open import Data.Sum 14 | open import List1 15 | import Data.Vec1 as Vec1 16 | open Vec1 hiding (lookup) 17 | open import HList 18 | open import Data.Maybe 19 | open import Data.Vec hiding (_∈_) 20 | 21 | postulate Tag : Set 22 | {-# BUILTIN STRING Tag #-} 23 | Enumeration = List Tag 24 | 25 | -- Member of an enumeration 26 | data Member (ts : Enumeration) : Set where 27 | member : (t : Tag) -> t ∈ ts -> Member ts 28 | 29 | data Case1 (A : Set1) : Set1 where 30 | _↦_ : Tag -> A -> Case1 A 31 | 32 | tagOf1 : {A : Set1} -> Case1 A -> Tag 33 | tagOf1 (t ↦ _) = t 34 | 35 | data Table1 (A : Set1) : Enumeration -> Set1 where 36 | [] : Table1 A [] 37 | _∷_ : forall {ts} -> (c : Case1 A) -> Table1 A ts -> Table1 A (tagOf1 c ∷ ts) 38 | infixr 5 _∷_ 39 | 40 | lookup1 : forall {A ts} -> Table1 A ts -> Member ts -> A 41 | lookup1 [] (member _ ()) 42 | lookup1 ((.t ↦ v) ∷ tbl) (member t here) = v 43 | lookup1 ((_ ↦ v) ∷ tbl) (member t (there p)) = lookup1 tbl (member t p) 44 | 45 | 46 | 47 | data Leaf : Set1 where 48 | rec : Leaf 49 | dat : (A : Set) -> Leaf 50 | 51 | 52 | 53 | Prod : Set1 54 | Prod = List1 Leaf 55 | 56 | countRec : Prod -> ℕ 57 | countRec [] = 0 58 | countRec (rec ∷ l) = 1 + countRec l 59 | countRec (dat _ ∷ l) = countRec l 60 | 61 | Code : Enumeration -> Set1 62 | Code tags = Table1 Prod tags 63 | 64 | l2s : Set -> Leaf -> Set 65 | l2s r rec = r 66 | l2s r (dat a) = a 67 | 68 | p2s : Set -> Prod -> Set 69 | p2s _ [] = ⊤ 70 | p2s r (c ∷ s) = l2s r c × p2s r s 71 | 72 | c2s : {Tags : ?} -> Set -> Code Tags -> Set 73 | c2s r [] = ⊥ 74 | c2s r ((_ ↦ c) ∷ s) = p2s r c ⊎ c2s r s 75 | 76 | -- Semantic of a code is a functor ... 77 | [[_]] : {Tags : ?} -> Code Tags -> Set -> Set 78 | [[ c ]] = \s -> c2s s c 79 | 80 | -- Tying the recursive knot. (hence turning off positivity check...) 81 | data μ {Tags : ?} (C : Code Tags) : Set where 82 | <_> : [[ C ]] (μ C) -> μ C 83 | 84 | primitive primStringEquality : Tag -> Tag -> Bool 85 | 86 | 87 | 88 | data Pattern {Tags : Enumeration} (C : Code Tags) : Set1 where 89 | _:?_ : (tag : Member Tags) -> (subPatterns : Vec₁ (Pattern C) (countRec (lookup1 C tag))) -> Pattern C 90 | ?? : Pattern C 91 | 92 | 93 | 94 | mutual 95 | matched' : {Tags : Enumeration} {C : Code Tags} -> (X : Set) -> (p : Prod) -> Vec₁ (Pattern C) (countRec p) -> SetList 96 | matched' X [] [] = [] 97 | matched' X (rec ∷ p) (pat ∷ pats) = List1._++_ (matched X pat) (matched' X p pats) 98 | matched' X (dat A ∷ p) (pats) = A ∷ matched' X p pats 99 | 100 | matchedT : {Tags0 Tags : Enumeration} {C : Code Tags} {C0 : Code Tags0} -> 101 | (X : Set) -> (tag : Member Tags) -> (subPatterns : Vec₁ (Pattern C0) (countRec (lookup1 C tag))) -> SetList 102 | matchedT {C = C} X tag subPatterns = matched' X (lookup1 C tag) subPatterns 103 | 104 | matched : {Tags : Enumeration} {C : Code Tags} -> (X : Set) -> Pattern C -> SetList 105 | matched X ?? = X ∷ [] 106 | matched X (tag :? subPatterns) = matchedT X tag subPatterns 107 | 108 | 109 | data Maybe1 (A : Set1) : Set1 where 110 | just : (x : A) -> Maybe1 A 111 | nothing : Maybe1 A 112 | 113 | 114 | _<*>_ : forall {a b} -> Maybe1 (a -> b) -> Maybe1 a -> Maybe1 b 115 | nothing <*> _ = nothing 116 | _ <*> nothing = nothing 117 | just f <*> just a = just (f a) 118 | 119 | _<$>_ : forall {a b} -> (a -> b) -> Maybe1 a -> Maybe1 b 120 | f <$> nothing = nothing 121 | f <$> (just x) = just (f x) 122 | infixr 5 _<$>_ 123 | infixl 6 _<*>_ 124 | 125 | 126 | data FunCase {Tags : Enumeration} (C : Code Tags) (Result : Set) : Set1 where 127 | _?->_ : (p : Pattern C) -> (lambdas (matched Result p) Result) -> FunCase C Result 128 | 129 | 130 | Function : {Tags : Enumeration} (C : Code Tags) (Result : Set) -> Set1 131 | Function C Result = List1 (FunCase C Result) 132 | 133 | subTags1 : Prod -> ℕ 134 | subTags1 [] = 0 135 | subTags1 (rec ∷ ts) = 1 + subTags1 ts 136 | subTags1 (dat _ ∷ ts) = subTags1 ts 137 | 138 | Key : Enumeration -> ℕ -> Set 139 | Key Tags n = Vec (Maybe (Member Tags)) n 140 | 141 | subTags : forall {n}{Tags : Enumeration} -> (C : Code Tags) -> Key Tags n -> ℕ 142 | subTags _ [] = 0 143 | subTags C (nothing ∷ ts) = subTags C ts 144 | subTags C (just t ∷ ts) = subTags1 (lookup1 C t) + subTags C ts 145 | 146 | data Compiled {Tags : Enumeration} (C : Code Tags) (Result : Set) : ℕ -> (Args : SetList) -> Set1 where 147 | directResult : {n : ℕ} -> (Args *-> Result) -> Compiled C Result n 148 | analysis : {n : ℕ} -> let tags = Key Tags n in Table1 (Compiled C (Args ) Result (subTags tags)) tags -> Compiled C Result n Args 149 | 150 | -- case-wise inclusion. 151 | -- _:<_ : Code _ -> Code _ -> Bool 152 | -- _:<_ [] _ = true 153 | -- _:<_ _ [] = false 154 | -- _:<_ (dataCase t _ ∷ s) (dataCase t' _ ∷ s') = primStringEquality t t' ∧ s :< s' 155 | -- _:<_ s (_ ∷ s') = s :< s' 156 | 157 | 158 | `Val` : Case1 Prod 159 | `Val` = "Val" ↦ (dat ℕ ∷ []) 160 | 161 | `Add` : Case1 Prod 162 | `Add` = "Add" ↦ (rec ∷ (rec ∷ [])) 163 | 164 | `Expr` : Code ? 165 | `Expr` = `Val` ∷ `Add` ∷ [] 166 | 167 | 168 | 169 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/Full.lhs.bak: -------------------------------------------------------------------------------- 1 | % -*- latex -*- 2 | 3 | 4 | \ignore{ 5 | \begin{code} 6 | module Main where 7 | 8 | import Code 9 | import Example 10 | import System.IO 11 | import Control.Monad (when) 12 | \end{code} 13 | } 14 | 15 | \section{Main loop} 16 | \label{sec:mainloop} 17 | 18 | In this section we write a toy editor written using the interface decribed in 19 | section \ref{sec:interface}. This editor lacks most features you would expect 20 | from a real application, and is therefore just a toy. It is however a complete 21 | implementation which tackles the issues related to incremental parsing. 22 | 23 | The main loop alternates beween displaying the contents of the file being 24 | edited and updating its internal state in response to user input. Notice 25 | that we make our code polymorphic over the type of the AST we process (|a|), 26 | merely requiring it to be |Show|-able. 27 | 28 | \begin{code} 29 | loop :: Show a => State a -> IO () 30 | loop s = display s >> update s >>= loop 31 | \end{code} 32 | 33 | The |State| structure stores the ``current state'' of our toy editor. 34 | The fields |lt| and |rt| contain the text respectively to the left and to the right of the edit point. 35 | The |ls| field is our main interest: it contains the parsing processes corresponding to each symbol to the left of the edit point. 36 | Note that there is always ore more element in |ls| than |lt|, because we also have a parser state for the empty input. 37 | 38 | \begin{code} 39 | data State a = State 40 | { 41 | lt, rt :: String, 42 | ls :: [Process Char a] 43 | } 44 | 45 | \end{code} 46 | 47 | We do not display the input document as typed by the user, but an annotated version. 48 | Therefore, we have to parse the input and then serialize the result. 49 | First, we feed the remainder of the input to the current state and then 50 | run the online parser. The display is then trimmed to show only a window around the edition point. 51 | 52 | \begin{code} 53 | display s = 54 | putStrLn "" 55 | let windowBegin = length (lt s) - windowSize 56 | putStrLn $ take windowSize 57 | $ drop windowBegin 58 | $ show 59 | $ finish 60 | $ feedEof 61 | $ feed (rt s) 62 | $ pst 63 | where windowSize = 10 -- arbitrary value 64 | \end{code} 65 | 66 | 67 | There are three types of user input to take care of: movement, deletion and insertion of text. 68 | The main difficulty here is to keep the list of intermediate states synchronized with the 69 | text. For example, every time a character is typed, a new parser state is 70 | computed and stored. The other edition operations proceed in similar fashion. 71 | 72 | \begin{code} 73 | update s@State{ls = pst:psts} = do 74 | c <- getChar 75 | return $ case c of 76 | -- cursor movements 77 | '<' -> case lt s of -- left 78 | [] -> s 79 | (x:xs) -> s {lt = xs, rt = x : rt s, ls = psts} 80 | '>' -> case rt s of -- right 81 | [] -> s 82 | (x:xs) -> s {lt = x : lt s, rt = xs, ls = addState x} 83 | -- deletions 84 | ',' -> case lt s of -- backspace 85 | [] -> s 86 | (x:xs) -> s {lt = xs, ls = psts} 87 | '.' -> case rt s of -- delete 88 | [] -> s 89 | (x:xs) -> s {rt = xs} 90 | -- insertion of text 91 | c -> s {lt = c : lt s, ls = addState c} 92 | where addState c = feed [c] pst : ls s 93 | \end{code} 94 | 95 | Desides disabling buffering of the input for real-time responsivity, 96 | the top-level program has to instanciate the main loop with an initial state, 97 | and pick a specific parser to use: |parseTopLevel|. As we have seen before, this can 98 | be any parser of type |Parser s a|. In sections \ref{sec:input} and \ref{sec:choice} 99 | we give an examples of such parsers written using our library. 100 | 101 | \begin{code} 102 | main = do hSetBuffering stdin NoBuffering 103 | loop State { 104 | lt = "", 105 | rt = "", 106 | ls = [mkProcess parseTopLevel]} 107 | \end{code} 108 | 109 | This code forms the skeleton of any program using our library. A number 110 | of issues are glossed over though. Notably, we would like to avoid re-parsing when 111 | moving in the file even if no modification is made. Also, the displayed output 112 | is computed from its start, and then trimmed. Instead we would like to directly 113 | print the portion corresponding to the current window. This issue can be tricky 114 | to fix, but for the time being we assume that displaying is much faster than 115 | parsing and therefore the running time of the former can be neglected. 116 | 117 | 118 | \ignore{ 119 | The only missing piece is the |Show| instance for that type. 120 | \begin{code} 121 | showS _ (Atom c) = [c] 122 | showS _ Missing = "*expected atom*" 123 | showS _ (Deleted c) = "?"++[c]++"?" 124 | showS ([open,close]:ps) (S s userClose) = open 125 | : concatMap (showS ps) s 126 | ++ closing 127 | where closing = case userClose of 128 | Just ')' ->[close] 129 | Nothing - "*expected )*" 130 | Just c - "?" ++ [c] ++ "?" 131 | 132 | 133 | instance Show SExpr where 134 | show = showS (cycle ["()","[]","{}"]) 135 | 136 | \end{code} 137 | } 138 | 139 | -------------------------------------------------------------------------------- /Parsers/SimplePolish.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) JP Bernardy 2008 2 | -- | This is a re-implementation of the "Polish Parsers" in a clearer way. (imho) 3 | {-# OPTIONS -fglasgow-exts #-} 4 | module SimplePolish (Process, Void, 5 | symbol, eof, lookNext, runPolish, 6 | runP, progress, evalR, 7 | P) where 8 | import Control.Applicative 9 | import Data.List hiding (map, minimumBy) 10 | import Data.Char 11 | import Data.Maybe (listToMaybe) 12 | 13 | data Void 14 | 15 | data Steps a where 16 | Val :: a -> Steps r -> Steps (a,r) 17 | App :: (Steps (b -> a,(b,r))) -> Steps (a,r) 18 | Done :: Steps Void 19 | Shift :: Steps a -> Steps a 20 | Fail :: Steps a 21 | Best :: Ordering -> Progress -> Steps a -> Steps a -> Steps a 22 | 23 | data Progress = PFail | PDone | PShift Progress 24 | deriving Show 25 | 26 | better :: Progress -> Progress -> (Ordering, Progress) 27 | better PFail p = (GT, p) -- avoid failure 28 | better p PFail = (LT, p) 29 | better PDone PDone = (EQ, PDone) 30 | better (PShift p) (PShift q) = pstep (better p q) 31 | 32 | pstep ~(ordering, xs) = (ordering, PShift xs) 33 | 34 | progress :: Steps a -> Progress 35 | progress (Val _ p) = progress p 36 | progress (App p) = progress p 37 | progress (Shift p) = PShift (progress p) 38 | progress (Done) = PDone 39 | progress (Fail) = PFail 40 | progress (Best _ pr _ _) = pr 41 | 42 | -- | Right-eval a fully defined process 43 | evalR :: Steps (a,r) -> (a, Steps r) 44 | evalR z@(Val a r) = (a,r) 45 | evalR (App s) = let (f, s') = evalR s 46 | (x, s'') = evalR s' 47 | in (f x, s'') 48 | evalR (Shift v) = evalR v 49 | evalR (Fail) = error "evalR: No parse!" 50 | evalR (Best choice _ p q) = case choice of 51 | LT -> evalR p 52 | GT -> evalR q 53 | EQ -> error $ "evalR: Ambiguous parse: " ++ show p ++ " ~~~ " ++ show q 54 | 55 | -- | A parser. (This is actually a parsing process segment) 56 | newtype P s a = P {fromP :: forall b r. ([s] -> Steps r) -> ([s] -> Steps (a,r))} 57 | 58 | -- | A complete process 59 | type Process a = Steps (a,Void) 60 | 61 | instance Functor (P s) where 62 | fmap f x = pure f <*> x 63 | 64 | instance Applicative (P s) where 65 | P f <*> P x = P ((App .) . f . x) 66 | pure x = P (\fut input -> Val x $ fut input) 67 | 68 | instance Alternative (P s) where 69 | empty = P $ \_fut _input -> Fail 70 | P a <|> P b = P $ \fut input -> iBest (a fut input) (b fut input) 71 | where iBest p q = let ~(choice, pr) = better (progress p) (progress q) in Best choice pr p q 72 | 73 | runP :: forall s a. P s a -> [s] -> Process a 74 | runP (P p) input = p (\_input -> Done) input 75 | 76 | -- | Run a parser. 77 | runPolish :: forall s a. P s a -> [s] -> a 78 | runPolish p input = fst $ evalR $ runP p input 79 | 80 | -- | Parse a symbol 81 | symbol :: (s -> Bool) -> P s s 82 | symbol f = P $ \fut input -> case input of 83 | [] -> Fail -- This is the eof! 84 | (s:ss) -> if f s then Shift (Val s (fut ss)) 85 | else Fail 86 | 87 | -- | Parse the eof 88 | eof :: P s () 89 | eof = P $ \fut input -> case input of 90 | [] -> Shift (Val () $ fut input) 91 | _ -> Fail 92 | 93 | -------------------------------------------------- 94 | -- Extra stuff 95 | 96 | 97 | lookNext :: (Maybe s -> Bool) -> P s () 98 | lookNext f = P $ \fut input -> 99 | if (f $ listToMaybe input) then Val () (fut input) 100 | else Fail 101 | 102 | 103 | instance Show (Steps a) where 104 | show (Val _ p) = "v" ++ show p 105 | show (App p) = "*" ++ show p 106 | show (Done) = "1" 107 | show (Shift p) = ">" ++ show p 108 | show (Fail) = "0" 109 | show (Best _ _ p q) = "(" ++ show p ++ ")" ++ show q 110 | 111 | -- | Pre-compute a left-prefix of some steps (as far as possible) 112 | evalL :: Steps a -> Steps a 113 | evalL (Shift p) = evalL p 114 | evalL (Val x r) = Val x (evalL r) 115 | evalL (App f) = case evalL f of 116 | (Val a (Val b r)) -> Val (a b) r 117 | (Val f1 (App (Val f2 r))) -> App (Val (f1 . f2) r) 118 | r -> App r 119 | evalL x@(Best choice _ p q) = case choice of 120 | LT -> evalL p 121 | GT -> evalL q 122 | EQ -> x -- don't know where to go: don't speculate on evaluating either branch. 123 | evalL x = x 124 | 125 | 126 | ------------------ 127 | 128 | data Expr = V Int | Add Expr Expr 129 | deriving Show 130 | 131 | sym x = symbol (== x) 132 | 133 | pExprParen = symbol (== '(') *> pExprTop <* symbol (== ')') 134 | 135 | pExprVal = V <$> toInt <$> symbol (isDigit) 136 | where toInt c = ord c - ord '0' 137 | 138 | pExprAtom = pExprVal <|> pExprParen 139 | 140 | pExprAdd = pExprAtom <|> Add <$> pExprAtom <*> (symbol (== '+') *> pExprAdd) 141 | 142 | pExprTop = pExprAdd 143 | 144 | pExpr = pExprTop <* eof 145 | {- 146 | syms [] = pure () 147 | syms (s:ss) = sym s *> syms ss 148 | 149 | pTag = sym '<' *> many (symbol (/= '>')) <* sym '>' 150 | pTag' s = sym '<' *> syms s <* sym '>' 151 | 152 | pTagged t p = do 153 | open <- pTag 154 | p <* pTag' open 155 | 156 | 157 | p0 = (pure 1 <* sym 'a') <|> (pure 2) 158 | 159 | p1 = \x -> if x == 2 then sym 'a' *> pure 3 else sym 'b' *> pure 4 160 | 161 | test = runPolish (p0 >>= p1) "ab" 162 | -} -------------------------------------------------------------------------------- /PolyTest/Implementation/FunProd.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --no-positivity-check #-} 2 | 3 | module Fun5 where 4 | 5 | 6 | open import Data.Unit 7 | open import Data.Nat hiding (_+_) 8 | open import Data.Bool 9 | open import Data.Maybe 10 | open import Data.Empty 11 | open import Data.String 12 | open import Relation.Nullary 13 | open import Relation.Binary.PropositionalEquality 14 | open import Relation.Binary.PropositionalEquality1 15 | 16 | data _+0_ (A : Set) (B : Set) : Set where 17 | L : A -> A +0 B 18 | R : B -> A +0 B 19 | 20 | data _×0_ (A : Set) (B : Set) : Set where 21 | _,_ : A -> B -> A ×0 B 22 | 23 | 24 | data Type : Set1 where 25 | var : Type 26 | _==>_ : (arg : Type) -> (res : Type) -> Type 27 | _××_ : (l : Type) -> (r : Type) -> Type 28 | con : (k : Set) -> Type 29 | 30 | infixr 2 _==>_ 31 | 32 | NoFun : ℕ -> Type -> Set 33 | NoFun n var = ⊤ 34 | NoFun n (con _) = ⊤ 35 | NoFun n (l ×× r) = NoFun n l ×0 NoFun n r 36 | NoFun zero (_ ==> _) = ⊥ 37 | NoFun (suc n) (arg ==> res) = NoFun n arg ×0 NoFun (suc n) res 38 | 39 | 40 | data Functor : Set1 where 41 | id : Functor 42 | k1 : Set -> Functor 43 | _+_ : Functor -> Functor -> Functor 44 | _×_ : Functor -> Functor -> Functor 45 | z1 : Functor 46 | 47 | infixr 1 _+_ 48 | infixr 3 _×_ 49 | 50 | 51 | f[_] : Functor -> Set -> Set 52 | f[_] id s = s 53 | f[_] (k1 y) s = y 54 | f[_] (y + y') s = f[ y ] s +0 f[ y' ] s 55 | f[_] (y × y') s = f[ y ] s ×0 f[ y' ] s 56 | f[_] z1 s = ⊥ 57 | 58 | functor[[_]] : Type -> Set -> Set 59 | functor[[ var ]] v = v 60 | functor[[ con t ]] v = t 61 | functor[[ _==>_ t1 t2 ]] v = functor[[ t1 ]] v → functor[[ t2 ]] v 62 | functor[[ _××_ t1 t2 ]] v = functor[[ t1 ]] v ×0 functor[[ t2 ]] v 63 | 64 | functorOf : (t : Type) -> NoFun 0 t -> Functor 65 | functorOf var _ = id 66 | functorOf (_==>_ y y') () 67 | functorOf (con y) _ = k1 y 68 | functorOf (l ×× r) (nfl , nfr) = functorOf l nfl × functorOf r nfr 69 | 70 | [[_]] : Type -> Set1 71 | [[ t ]] = (a : Set) -> functor[[ t ]] a 72 | 73 | wellBehaved : (i : Set) (t : Type) -> (nf : NoFun 0 t) -> functor[[ t ]] i ≡₁ f[ functorOf t nf ] i 74 | wellBehaved i var _ = refl 75 | wellBehaved i (y ==> y') () 76 | wellBehaved i (con y) nf = refl 77 | wellBehaved i (l ×× r) nf = {!!} 78 | 79 | convert : forall {a b : Set} -> (a ≡₁ b) -> a -> b 80 | convert refl a = a 81 | 82 | -- Bit of a functor to extract from an argument. 83 | functorBit : (t : Type) -> NoFun 1 t -> Functor 84 | functorBit var _ = (k1 ⊤) 85 | functorBit (arg ==> res) (nfa , nf) = functorOf arg nfa × functorBit res nf 86 | functorBit (con y) _ = z1 87 | functorBit (l ×× r) nf = {!!} 88 | 89 | 90 | -- Functor of the algebra that the function depends on. 91 | extractFunctor : (t : Type) -> NoFun 2 t -> Functor 92 | extractFunctor var _ = z1 93 | extractFunctor (_==>_ y y') (nfa , nf) = functorBit y nfa + extractFunctor y' nf 94 | extractFunctor (con y) _ = z1 95 | extractFunctor (l ×× r) _ = {!!} 96 | 97 | 98 | 99 | YieldsAlgebra : Type -> Set 100 | YieldsAlgebra var = ⊤ 101 | YieldsAlgebra (y ==> y') = YieldsAlgebra y' 102 | YieldsAlgebra (con y) = ⊥ 103 | YieldsAlgebra (l ×× r) = {!!} 104 | 105 | doesYieldAlgebra : (t : Type) -> Dec (YieldsAlgebra t) 106 | doesYieldAlgebra var = yes tt 107 | doesYieldAlgebra (y ==> y') = doesYieldAlgebra y' 108 | doesYieldAlgebra (con y) = no (λ ()) 109 | doesYieldAlgebra (l ×× r) = {!!} 110 | 111 | 112 | data Fix (f : Set -> Set) : Set where In : f (Fix f) -> Fix f 113 | 114 | toMonotypeArg : (initialType : Set) -> (t : Type) -> Set 115 | toMonotypeArg i t with doesYieldAlgebra t 116 | ... | no _ = functor[[ t ]] i 117 | ... | yes _ = ⊤ 118 | 119 | -- Compute the monotype for the testing 120 | toMonotype : (initialType : Set) -> (t : Type) -> Set 121 | toMonotype i var = i 122 | toMonotype i (y ==> y') = toMonotypeArg i y → toMonotype i y' 123 | toMonotype i (con y) = y 124 | toMonotype i (l ×× r) = {!!} 125 | 126 | 127 | algebraBit : (initialType : Set) -> (t : Type) -> (nf : NoFun 1 t) -> (f[ functorBit t nf ] initialType -> initialType) -> YieldsAlgebra t -> functor[[ t ]] initialType 128 | algebraBit i var nf inject ya = inject tt 129 | algebraBit i (y ==> y') (nfa , nf) inject ya = λ fyi → algebraBit i y' nf (λ bit → inject (convert (wellBehaved i y nfa) fyi , bit)) ya 130 | algebraBit i (con y) nf inject () 131 | algebraBit i (l ×× r) nf inject ya = {!!} 132 | 133 | 134 | toMono' : (initialType : Set) -> (t : Type) -> (nf : NoFun 2 t) -> (f[ extractFunctor t nf ] initialType -> initialType) -> functor[[ t ]] initialType -> toMonotype initialType t 135 | toMono' i var nf inj v = v 136 | toMono' i (y ==> y') nf inj v with doesYieldAlgebra y 137 | toMono' i (y ==> y') (nfa , nf) inj v | yes p = λ arg → toMono' i y' nf (λ subArg → inj (R subArg)) (v (algebraBit i y nfa (λ subArg → inj (L subArg)) p)) 138 | toMono' i (y ==> y') (nfa , nf) inj v | no _ = λ arg → toMono' i y' nf (λ subArg → inj (R subArg)) (v arg) 139 | toMono' i (con y) nf inj v = v 140 | toMono' i (l ×× r) nf inj v = {!!} 141 | 142 | toTestType : (t : Type) -> NoFun 2 t -> Set 143 | toTestType t nf = toMonotype (Fix f[ extractFunctor t nf ]) t 144 | 145 | toMono : (t : Type) -> (nf : NoFun 2 t) -> [[ t ]] -> toTestType t nf 146 | toMono t nf v = toMono' initialType t nf In (v initialType) 147 | where initialType = Fix f[ extractFunctor t nf ] 148 | 149 | 150 | 151 | postulate InitialType : Set 152 | 153 | binT = var ==> var ==> var 154 | predT = var ==> con Bool 155 | filterT = (var ==> con Bool) ==> (con ℕ ==> var) ==> con ℕ ==> var 156 | 157 | -------------------------------------------------------------------------------- /TypeClasses/ClassesAsPredicate.agda: -------------------------------------------------------------------------------- 1 | module ClassesAsPredicate where 2 | 3 | open import Data.Nat 4 | open import Data.Bool 5 | open import Data.Unit 6 | open import Data.List 7 | open import Data.Empty 8 | open import Relation.Binary.PropositionalEquality 9 | 10 | 11 | data Maybe1 (a : Set1) : Set1 where 12 | just : a -> Maybe1 a 13 | nothing : Maybe1 a 14 | 15 | 16 | -- test if two boolean values are equal 17 | boolTest : Bool -> Bool -> Bool 18 | boolTest true true = true 19 | boolTest false false = true 20 | boolTest _ _ = false 21 | 22 | 23 | -- we work on a closed universe of types, whose codes are as follows: 24 | data Code : Set where 25 | boolCode : Code 26 | natCode : Code 27 | listCode : Code -> Code 28 | 29 | ⟦_⟧ : Code -> Set 30 | ⟦ boolCode ⟧ = Bool 31 | ⟦ natCode ⟧ = ℕ 32 | ⟦ listCode c ⟧ = List ⟦ c ⟧ 33 | 34 | IsJust : {a : Set1} -> Maybe1 a -> Set 35 | IsJust (just _) = ⊤ 36 | IsJust nothing = ⊥ 37 | 38 | 39 | -- encoding a type class 40 | record Class : Set2 where 41 | field 42 | sig : Set -> Set1 43 | -- Mapping (type) parameter to specific signature 44 | 45 | -- This returns a "Set1" so that the result can contain associated types, 46 | 47 | instances : (c : Code) -> Maybe1 (sig ⟦ c ⟧) -- mapping codes to definitions 48 | -- we need to use a code so that the "instances" function can pattern-match on something. 49 | 50 | 51 | -- Constraint on a given class 52 | Constraint : Class -> Code -> Set 53 | Constraint class c = IsJust (Class.instances class c) 54 | 55 | -- generalizing: one can use a "method" given the constraint. 56 | use : {res : Set} -> {cl : Class} -> {c : Code} -> (method : (Class.sig cl ⟦ c ⟧ -> res)) -> {p : Constraint cl c} -> res 57 | use {res} {cl} {c} method {p} with Class.instances cl c 58 | use {res} {cl} {c} method {p} | just sig = method sig 59 | use {res} {cl} {c} method {()} | nothing 60 | 61 | 62 | module EqualityExample where 63 | 64 | -- Signature for Eq class 65 | record EqClassSig (t : Set) : Set1 where 66 | field 67 | equality : t -> t -> Bool 68 | 69 | mapMaybe : forall {a b} -> (a -> b) -> Maybe1 a -> Maybe1 b 70 | mapMaybe f nothing = nothing 71 | mapMaybe f (just x) = just (f x) 72 | 73 | -- Instances for the Eq class 74 | eqClassInstances : (c : Code) -> Maybe1 (EqClassSig ⟦ c ⟧) 75 | eqClassInstances boolCode = just (record {equality = boolTest}) 76 | eqClassInstances natCode = nothing 77 | eqClassInstances (listCode c) = mapMaybe 78 | (\argDict -> record {equality = \l1 l2 -> and (zipWith (EqClassSig.equality argDict) l1 l2) }) 79 | (eqClassInstances c) 80 | -- example: modelling a polymorphic instance 81 | 82 | -- Definition of the Eq class 83 | eqClass : Class 84 | eqClass = record {sig = EqClassSig; instances = eqClassInstances} 85 | 86 | -- "concept-based overloading" 87 | eq2 : {c : Code} -> ⟦ c ⟧ -> ⟦ c ⟧ -> ⟦ c ⟧ -> Bool 88 | eq2 {c} x y z with Class.instances eqClass c 89 | ... | just sig = let _==_ = EqClassSig.equality sig in (x == y) ∧ (y == z) 90 | ... | nothing = false 91 | 92 | 93 | -- The "Eq" constraint 94 | Eq : Code -> Set 95 | Eq = Constraint eqClass 96 | 97 | -- enforcing class constraints / convenient access: 98 | _==_ : {c : Code} -> {p : Eq c} -> ⟦ c ⟧ -> ⟦ c ⟧ -> Bool 99 | _==_ {c} {p} with Class.instances eqClass c 100 | _==_ {c} {_} | just sig = EqClassSig.equality sig 101 | _==_ {c} {()} | nothing 102 | 103 | 104 | -- Alternate definition using the generic "use" function 105 | _===_ : {c : Code} -> {p : Eq c} -> ⟦ c ⟧ -> ⟦ c ⟧ -> Bool 106 | _===_ {p = p} = use {cl = eqClass} EqClassSig.equality {p = p} 107 | 108 | -- propagation of constraints 109 | _≠_ : {c : Code} -> {p : Eq c} -> ⟦ c ⟧ -> ⟦ c ⟧ -> Bool 110 | _≠_ {p = p} x y = _==_ {p = p} x y 111 | 112 | -- using at a monomorphic type 113 | neqBools : Bool -> Bool -> Bool 114 | neqBools = _≠_ 115 | 116 | -- propagation of constraints 117 | test : {c : Code} -> {p : Eq c} -> ⟦ c ⟧ -> ⟦ c ⟧ -> ⟦ c ⟧ -> Bool 118 | test {p = p} x y z = (_≠_ {p = p} x y) ∨ (_≠_ {p = p} y z) 119 | -- we have to specify constraints explicitly: no solver in Agda. 120 | 121 | -- misusing at a monomorphic type 122 | neqNats : {p : Eq natCode} -> ℕ -> ℕ -> Bool 123 | neqNats {p} = _≠_ {p = p} 124 | -- Note: we can define a "wrong" function, and leave the burden of proof to the caller. 125 | -- (I think this is akin to so called "axiomatic classes" in Isabelle.) 126 | 127 | -- In other words, it's possible to leave the constraint "floating" 128 | -- (not discharge it) even when instanciated at precise types. 129 | 130 | 131 | 132 | -- simplifying constraints: 133 | -- We can construct a "more complex" constraint if it's implied by a 134 | -- simpler one, as such: 135 | simplify : (c : Code) -> Eq c -> Eq (listCode c) 136 | simplify c cons with eqClassInstances c 137 | simplify c cons | just x = tt 138 | simplify c () | nothing 139 | 140 | module OrdExample where 141 | 142 | import Relation.Binary using (Rel) 143 | 144 | record OrdClassSig (t : Set) : Set1 where 145 | field 146 | _[<=]_ : t -> t -> Bool 147 | [>=-trans] : {a b c : t} -> T (a [<=] b) -> T (b [<=] c) -> T (a [<=] c) 148 | [superEq] : {c : Code} {- -> [[c]] == t -} -> EqualityExample.Eq c 149 | 150 | -------------------------------------------------------------------------------- /Parsers/Polish.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fglasgow-exts #-} 2 | module Polish (Process, Void, 3 | symbol, eof, lookNext, runPolish, 4 | runP, evalR, 5 | P) where 6 | import Control.Applicative 7 | import Data.List hiding (map, minimumBy) 8 | import Data.Char 9 | import Data.Maybe (listToMaybe) 10 | 11 | data Void 12 | 13 | data Steps a r where 14 | Val :: a -> Steps b r -> Steps a (Steps b r) 15 | App :: Steps (b -> a) (Steps b r) -> Steps a r 16 | Shift :: Steps a r -> Steps a r 17 | Done :: Steps a r -> Steps a r 18 | Fail :: Steps a r 19 | 20 | best :: Steps a r -> Steps a r -> Steps a r 21 | Fail `best` p = p 22 | q `best` Fail = q 23 | Done _ `best` Done _ = error "ambiguous" 24 | Done a `best` q = Done a 25 | p `best` Done a = Done a 26 | Shift v `best` Shift w = Shift (v `best` w) 27 | p `best` q = getProgress id p `best` getProgress id q 28 | 29 | 30 | -- | Advance in the result steps, pushing results in the continuation. 31 | -- (Must return one of: Done, Shift, Fail) 32 | getProgress :: (Steps a r -> Steps b t) -> Steps a r -> Steps b t 33 | getProgress f (Val a s) = getProgress (f . Val a) s 34 | getProgress f (App s) = getProgress (f . App) s 35 | getProgress f (Done p) = Done (f p) 36 | getProgress f (Shift p) = Shift (f p) 37 | getProgress _ (Fail) = Fail 38 | 39 | -- | Right-eval a fully defined process 40 | evalR :: Steps a r -> (a, r) 41 | evalR z@(Val a r) = (a,r) 42 | evalR (App s) = let (f, s') = evalR s 43 | (x, s'') = evalR s' 44 | in (f x, s'') 45 | evalR (Done v) = evalR v 46 | evalR (Shift v) = evalR v 47 | evalR (Fail) = error "evalR: No parse!" 48 | 49 | -- | A parser. (This is actually a parsing process segment) 50 | newtype P s a = P {fromP :: forall b r. ([s] -> Steps b r) -> ([s] -> Steps a (Steps b r))} 51 | 52 | -- | A complete process 53 | type Process a = Steps a (Steps Void Void) 54 | 55 | instance Functor (P s) where 56 | fmap f x = pure f <*> x 57 | 58 | instance Applicative (P s) where 59 | P f <*> P x = P ((App .) . f . x) 60 | pure x = P (\fut input -> Val x $ fut input) 61 | 62 | instance Alternative (P s) where 63 | empty = P $ \_fut _input -> Fail 64 | P a <|> P b = P $ \fut input -> best (a fut input) (b fut input) 65 | 66 | runP :: forall s a. P s a -> [s] -> Process a 67 | runP (P p) input = p (\rest -> stop) input 68 | 69 | stop = Done stop 70 | void :: Void 71 | void = error "no such thing as void" 72 | 73 | -- | Run a parser. 74 | runPolish :: forall s a. P s a -> [s] -> a 75 | runPolish p input = fst $ evalR $ runP p input 76 | 77 | -- | Parse a symbol 78 | symbol :: (s -> Bool) -> P s s 79 | symbol f = P $ \fut input -> case input of 80 | [] -> Fail -- This is the eof! 81 | (s:ss) -> if f s then Shift (Val s (fut ss)) 82 | else Fail 83 | 84 | -- | Parse the eof 85 | eof :: P s () 86 | eof = P $ \fut input -> case input of 87 | [] -> Shift (Val () $ fut input) 88 | _ -> Fail 89 | 90 | ------------------------ 91 | -- Monad interface 92 | 93 | 94 | getVal :: Steps a (Steps b r) -> (a, Steps b r) 95 | getVal (Val a s) = (a,s) 96 | getVal (App s) = let (f,s') = getVal s 97 | (a,s'') = getVal s' -- hugh, this will dig again in the same shit. 98 | in (f a, s'') 99 | getVal (Shift v) = let (a,r) = getVal v in (a,Shift r) 100 | getVal (Fail) = error "getVal: Fail!" 101 | 102 | instance Monad (P s) where 103 | return = pure 104 | P p >>= q = P $ \fut input -> let (a,ps_qres) = getVal (p (fromP (q a) fut) input) 105 | in ps_qres 106 | -- This is from polish parsers, but is ~w~r~o~n~g~! 107 | -- Indeed: 108 | -- q depends on a; 109 | -- a depends on the result of p 110 | -- the result of p can be influenced by q, 111 | --- indeed, q follows p, so if p has a disjunction, q will influence its result. 112 | 113 | -------------------------------------------------- 114 | -- Extra stuff 115 | 116 | 117 | lookNext :: (Maybe s -> Bool) -> P s () 118 | lookNext f = P $ \fut input -> 119 | if (f $ listToMaybe input) then Val () (fut input) 120 | else Fail 121 | 122 | 123 | instance Show (Steps a r) where 124 | show (Val _ p) = "v" ++ show p 125 | show (App p) = "*" ++ show p 126 | show (Done _) = "1" 127 | show (Shift p) = ">" ++ show p 128 | show (Fail) = "0" 129 | 130 | -- | Pre-compute a left-prefix of some steps (as far as possible) 131 | evalL :: Steps a r -> Steps a r 132 | evalL (Shift p) = evalL p 133 | evalL (Val x r) = Val x (evalL r) 134 | evalL (App f) = case evalL f of 135 | (Val a (Val b r)) -> Val (a b) r 136 | (Val f1 (App (Val f2 r))) -> App (Val (f1 . f2) r) 137 | r -> App r 138 | evalL x = x 139 | 140 | 141 | ------------------ 142 | 143 | data Expr = V Int | Add Expr Expr 144 | deriving Show 145 | 146 | sym x = symbol (== x) 147 | 148 | pExprParen = symbol (== '(') *> pExprTop <* symbol (== ')') 149 | 150 | pExprVal = V <$> toInt <$> symbol (isDigit) 151 | where toInt c = ord c - ord '0' 152 | 153 | pExprAtom = pExprVal <|> pExprParen 154 | 155 | pExprAdd = pExprAtom <|> Add <$> pExprAtom <*> (symbol (== '+') *> pExprAdd) 156 | 157 | pExprTop = pExprAdd 158 | 159 | pExpr = pExprTop <* eof 160 | 161 | syms [] = pure () 162 | syms (s:ss) = sym s *> syms ss 163 | 164 | pTag = sym '<' *> many (symbol (/= '>')) <* sym '>' 165 | pTag' s = sym '<' *> syms s <* sym '>' 166 | 167 | pTagged t p = do 168 | open <- pTag 169 | p <* pTag' open 170 | 171 | 172 | p0 = (pure 1 <* sym 'a') <|> (pure 2) 173 | 174 | p1 = \x -> if x == 2 then sym 'a' *> pure 3 else sym 'b' *> pure 4 175 | 176 | test = runPolish (p0 >>= p1) "ab" -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/talk2/ast.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 19 | 21 | 28 | 29 | 51 | 56 | 57 | 59 | 60 | 62 | image/svg+xml 63 | 65 | 66 | 67 | 68 | 73 | 78 | 86 | 91 | 99 | 104 | 109 | 113 | 123 | 128 | 129 | 130 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/talk2/progress.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 19 | 21 | 28 | 29 | 52 | 58 | 59 | 61 | 62 | 64 | image/svg+xml 65 | 67 | 68 | 69 | 70 | 75 | 78 | 83 | 88 | 89 | 92 | 97 | 102 | 103 | 106 | 111 | 116 | 117 | 122 | 132 | 133 | 134 | -------------------------------------------------------------------------------- /CPSZipper/CJ.agda: -------------------------------------------------------------------------------- 1 | module CJ where 2 | 3 | open import Data.Nat 4 | open import Data.Maybe 5 | open import Data.Fin 6 | open import Data.Empty 7 | open import Data.Unit 8 | open import Data.Sum 9 | open import Data.Product 10 | open import Data.Bool 11 | open import Data.List 12 | open import Relation.Binary.PropositionalEquality1 13 | 14 | data Funct : ℕ -> Set1 where 15 | K : forall n -> Set -> Funct n 16 | _⊕_ : forall {n} -> Funct n -> Funct n -> Funct n 17 | _⊗_ : forall {n} -> Funct n -> Funct n -> Funct n 18 | π : forall {n} -> Fin n -> Funct n 19 | 20 | -- Id = π 0 21 | -- Fst = π 0 22 | -- Snd = π 1 23 | 24 | 25 | weaken : forall {n} -> Bool -> Funct n -> Funct (suc n) 26 | weaken n (K o s) = K (suc o) s 27 | weaken true (π i) = π (inject₁ i) 28 | weaken false (π i) = π (suc i) 29 | weaken n (p ⊕ q) = weaken n p ⊕ weaken n q 30 | weaken n (p ⊗ q) = weaken n p ⊗ weaken n q 31 | 32 | ◃ = weaken true 33 | ▷ = weaken false 34 | 35 | 36 | Zero : forall n -> Funct n 37 | Zero n = K n ⊥ 38 | 39 | One : forall n -> Funct n 40 | One n = K n ⊤ 41 | 42 | 43 | Fun : ℕ -> Set1 44 | Fun 0 = Set 45 | Fun (suc n) = Set -> Fun n 46 | 47 | consts : (n : ℕ) -> Set -> Fun n 48 | consts 0 s = s 49 | consts (suc n) s = \_ -> consts n s 50 | 51 | lift2 : {n : ℕ} -> (Set -> Set -> Set) -> Fun n -> Fun n -> Fun n 52 | lift2 {0} _x_ l r = l x r 53 | lift2 {suc n} _x_ l r = \t -> lift2 _x_ (l t) (r t) 54 | 55 | 56 | sem : forall n -> Funct n -> Fun n 57 | sem zero (K .0 y) = y 58 | sem (suc n) (K .(suc n) y) = \t -> sem n (K n y) 59 | sem n (p ⊕ q) = lift2 _⊎_ (sem n p) (sem n q) 60 | sem n (p ⊗ q) = lift2 _×_ (sem n p) (sem n q) 61 | sem .(suc n) (π (zero {n})) = consts n 62 | sem .(suc n) (π (suc {n} i)) = \t -> sem n (π i) 63 | 64 | [[_]] : forall {n} -> Funct n -> Fun n 65 | [[_]] {n} f = sem n f 66 | 67 | lemma< : (q : Funct 1) (x y : Set) -> sem 2 (weaken true q) x y ≡₁ sem 1 q x 68 | lemma< (K .1 _) x y = refl 69 | lemma< (p ⊕ q) x y = cong₂ _⊎_ (lemma< p x y) (lemma< q x y) 70 | lemma< (p ⊗ q) x y = cong₂ _×_ (lemma< p x y) (lemma< q x y) 71 | lemma< (π zero) x y = refl 72 | lemma< (π (suc ())) x y 73 | 74 | lemma> : (q : Funct 1) (x y : Set) -> sem 2 (weaken false q) x y ≡₁ sem 1 q y 75 | lemma> (K .1 _) x y = refl 76 | lemma> (p ⊕ q) x y = cong₂ _⊎_ (lemma> p x y) (lemma> q x y) 77 | lemma> (p ⊗ q) x y = cong₂ _×_ (lemma> p x y) (lemma> q x y) 78 | lemma> (π zero) x y = refl 79 | lemma> (π (suc ())) x y 80 | 81 | if1_then_else_ : {a : Set1} -> Bool -> a -> a -> a 82 | if1 true then t else f = t 83 | if1 false then t else f = f 84 | 85 | 86 | lemma : forall dir -> (q : Funct 1) (x y : Set) -> sem 2 (weaken dir q) x y ≡₁ sem 1 q (if1 dir then x else y) 87 | lemma true q x y = lemma< q x y 88 | lemma false q x y = lemma> q x y 89 | 90 | lem : {q : Funct 1} {dir : Bool} {x y : Set} -> sem 2 (weaken dir q) x y ≡₁ sem 1 q (if1 dir then x else y) 91 | lem {q} {dir} {x} {y} = lemma dir q x y 92 | 93 | 94 | △ : Funct 1 -> Funct 2 95 | △ (K .1 y) = Zero 2 96 | △ (p ⊕ q) = △ p ⊕ △ q 97 | △ (p ⊗ q) = (△ p ⊗ ▷ q) ⊕ (◃ p ⊗ △ q) 98 | △ (π zero) = One 2 99 | △ (π (suc ())) 100 | 101 | mindp : forall {j pd pc x y} -> ( j × pd ) ⊎ pc -> j × ( pd ⊎ x) ⊎ ( pc ⊎ y ) 102 | mindp (inj₁ (j , pd)) = inj₁ (j , inj₁ pd) 103 | mindp (inj₂ pc) = inj₂ (inj₁ pc) 104 | 105 | mindq : forall {j qd qc x y} -> ( j × qd ) ⊎ qc -> (j × ( x ⊎ qd)) ⊎ ( y ⊎ qc ) 106 | mindq (inj₁ (j , qd)) = inj₁ (j , inj₂ qd) 107 | mindq (inj₂ qc) = inj₂ (inj₂ qc) 108 | 109 | 110 | cvt : forall {x y : Set} -> x ≡₁ y -> (a : x) -> y 111 | cvt ≡₁-refl a = a 112 | 113 | mutual 114 | mndp : forall p q -> forall {c j} -> (j × [[ △ p ]] c j) ⊎ [[ p ]] c -> [[ q ]] j -> (j × [[ △ (p ⊗ q) ]] c j) ⊎ [[ (p ⊗ q) ]] c 115 | mndp p q (inj₁ (j , pd)) qj = inj₁ (j , inj₁ (pd , cvt (sym (lem {q})) qj)) 116 | mndp p q (inj₂ pc) qj = mndq p q pc (right q (inj₁ qj)) 117 | 118 | mndq : forall p q -> forall {c j} -> [[ p ]] c -> (j × [[ △ q ]] c j) ⊎ [[ q ]] c -> (j × [[ △ (p ⊗ q) ]] c j) ⊎ [[ (p ⊗ q) ]] c 119 | mndq p q pc (inj₁ (j , qd)) = inj₁ (j , inj₂ ( cvt (sym (lem {p})) pc , qd)) 120 | mndq p q pc (inj₂ qc) = inj₂ ( pc , qc) 121 | 122 | right : forall {j c : Set} -> (p : Funct 1) -> ([[ p ]] j ⊎ ([[ △ p ]] c j × c)) -> (j × [[ △ p ]] c j) ⊎ [[ p ]] c 123 | right (K .1 y) (inj₁ x) = inj₂ x 124 | right (K .1 y) (inj₂ (() , y')) 125 | right (p ⊕ q) (inj₁ (inj₁ pj)) = mindp (right p (inj₁ pj)) 126 | right (p ⊕ q) (inj₁ (inj₂ qj)) = mindq (right q (inj₁ qj)) 127 | right (p ⊕ q) (inj₂ (inj₁ pd , c)) = mindp (right p (inj₂ (pd , c))) 128 | right (p ⊕ q) (inj₂ (inj₂ qd , c)) = mindq (right q (inj₂ (qd , c))) 129 | right (p ⊗ q) (inj₁ (pj , qj)) = mndp p q (right p (inj₁ pj)) qj 130 | right (p ⊗ q) (inj₂ (inj₁ (pd , qj) , c)) = mndp p q (right p (inj₂ (pd , c))) (cvt (lem {q}) qj) 131 | right (p ⊗ q) (inj₂ (inj₂ (pc , qd) , c)) = mndq p q (cvt (lem {p}) pc) (right q (inj₂ (qd , c))) 132 | right (π zero) (inj₁ j) = inj₁ (j , tt) 133 | right (π zero) (inj₂ (tt , c)) = inj₂ c 134 | right (π (suc ())) x 135 | 136 | 137 | ∂ : Funct 1 -> Fun 1 138 | ∂ p x = [[ △ p ]] x x 139 | 140 | 141 | plug : forall {x} -> (p : Funct 1) -> x -> ∂ p x -> [[ p ]] x 142 | plug (K .1 y) x () 143 | plug (p ⊕ q) x (inj₁ pd) = inj₁ (plug p x pd) 144 | plug (p ⊕ q) x (inj₂ pq) = inj₂ (plug q x pq) 145 | plug {X} (p ⊗ q) x (inj₁ (pd , qx)) = plug p x pd , cvt (lem {q}) qx 146 | plug {X} (p ⊗ q) x (inj₂ (px , qd)) = cvt (lem {p}) px , (plug q x qd) 147 | plug (π zero) x tt = x 148 | plug (π (suc ())) x z 149 | 150 | data μ (p : Funct 1) : Set where 151 | In : [[ p ]] (μ p) -> μ p 152 | 153 | Move : Set1 154 | Move = (p : Funct 1) -> (μ p × List (∂ p (μ p))) -> Maybe (μ p × List (∂ p (μ p))) 155 | 156 | zUp : Move 157 | zUp p (t , []) = nothing 158 | zUp p (t , pd ∷ pds) = just (In (plug p t pd), pds) 159 | 160 | zRight : Move 161 | zRight p (x , []) = nothing 162 | zRight p (t , pd ∷ pds) with right p (inj₂ (pd , t)) 163 | ... | (inj₁ (t' , pd')) = just (t' , pd' ∷ pds) 164 | ... | (inj₂ _) = nothing 165 | 166 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/begin.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 19 | 21 | 28 | 29 | 50 | 55 | 56 | 58 | 59 | 61 | image/svg+xml 62 | 64 | 65 | 66 | 67 | 72 | 80 | 85 | 93 | 97 | 113 | 118 | 123 | 128 | 129 | 130 | -------------------------------------------------------------------------------- /FunctionalIncrementalParsing/talk/begin.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 19 | 21 | 28 | 29 | 50 | 55 | 56 | 58 | 59 | 61 | image/svg+xml 62 | 64 | 65 | 66 | 67 | 72 | 80 | 85 | 93 | 97 | 113 | 118 | 123 | 128 | 129 | 130 | -------------------------------------------------------------------------------- /Open/Open3.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --no-positivity-check #-} 2 | 3 | module Open3 where 4 | open import Data.Unit 5 | -- open import Logic 6 | import Data.Nat as Nat 7 | open import Data.Function 8 | open Nat 9 | open import Data.Bool 10 | open import Data.List 11 | open import Data.Product 12 | open import Data.Empty 13 | open import Data.Sum 14 | open import List1 15 | import Data.Vec1 as Vec1 16 | open Vec1 hiding (lookup) 17 | open import HList 18 | open import Data.Maybe 19 | 20 | postulate Tag : Set 21 | {-# BUILTIN STRING Tag #-} 22 | Enumeration = List Tag 23 | 24 | -- Member of an enumeration 25 | data Member (ts : Enumeration) : Set where 26 | member : (t : Tag) -> t ∈ ts -> Member ts 27 | 28 | data Case1 (A : Set1) : Set1 where 29 | _↦_ : Tag -> A -> Case1 A 30 | 31 | tagOf1 : {A : Set1} -> Case1 A -> Tag 32 | tagOf1 (t ↦ _) = t 33 | 34 | data Table1 (A : Set1) : Enumeration -> Set1 where 35 | [] : Table1 A [] 36 | _∷_ : forall {ts} -> (c : Case1 A) -> Table1 A ts -> Table1 A (tagOf1 c ∷ ts) 37 | infixr 5 _∷_ 38 | 39 | lookup1 : forall {A ts} -> Table1 A ts -> Member ts -> A 40 | lookup1 [] (member _ ()) 41 | lookup1 ((.t ↦ v) ∷ tbl) (member t here) = v 42 | lookup1 ((_ ↦ v) ∷ tbl) (member t (there p)) = lookup1 tbl (member t p) 43 | 44 | 45 | 46 | data Leaf : Set1 where 47 | rec : Leaf 48 | dat : (A : Set) -> Leaf 49 | 50 | 51 | 52 | Prod : Set1 53 | Prod = List1 Leaf 54 | 55 | countRec : Prod -> ℕ 56 | countRec [] = 0 57 | countRec (rec ∷ l) = 1 + countRec l 58 | countRec (dat _ ∷ l) = countRec l 59 | 60 | Code : Enumeration -> Set1 61 | Code tags = Table1 Prod tags 62 | 63 | l2s : Set -> Leaf -> Set 64 | l2s r rec = r 65 | l2s r (dat a) = a 66 | 67 | p2s : Set -> Prod -> Set 68 | p2s _ [] = ⊤ 69 | p2s r (c ∷ s) = l2s r c × p2s r s 70 | 71 | c2s : {Tags : ?} -> Set -> Code Tags -> Set 72 | c2s r [] = ⊥ 73 | c2s r ((_ ↦ c) ∷ s) = p2s r c ⊎ c2s r s 74 | 75 | -- Semantic of a code is a functor ... 76 | [[_]] : {Tags : ?} -> Code Tags -> Set -> Set 77 | [[ c ]] = \s -> c2s s c 78 | 79 | -- Tying the recursive knot. (hence turning off positivity check...) 80 | data μ {Tags : ?} (C : Code Tags) : Set where 81 | <_> : [[ C ]] (μ C) -> μ C 82 | 83 | primitive primStringEquality : Tag -> Tag -> Bool 84 | 85 | 86 | 87 | data Pattern {Tags : Enumeration} (C : Code Tags) : Set1 where 88 | _:?_ : (tag : Member Tags) -> (subPatterns : Vec₁ (Pattern C) (countRec (lookup1 C tag))) -> Pattern C 89 | ?? : Pattern C 90 | 91 | 92 | 93 | mutual 94 | matched' : {Tags : Enumeration} {C : Code Tags} -> (X : Set) -> (p : Prod) -> Vec₁ (Pattern C) (countRec p) -> SetList 95 | matched' X [] [] = [] 96 | matched' X (rec ∷ p) (pat ∷ pats) = List1._++_ (matched X pat) (matched' X p pats) 97 | matched' X (dat A ∷ p) (pats) = A ∷ matched' X p pats 98 | 99 | matchedT : {Tags0 Tags : Enumeration} {C : Code Tags} {C0 : Code Tags0} -> 100 | (X : Set) -> (tag : Member Tags) -> (subPatterns : Vec₁ (Pattern C0) (countRec (lookup1 C tag))) -> SetList 101 | matchedT {C = C} X tag subPatterns = matched' X (lookup1 C tag) subPatterns 102 | 103 | matched : {Tags : Enumeration} {C : Code Tags} -> (X : Set) -> Pattern C -> SetList 104 | matched X ?? = X ∷ [] 105 | matched X (tag :? subPatterns) = matchedT X tag subPatterns 106 | 107 | 108 | data Maybe1 (A : Set1) : Set1 where 109 | just : (x : A) -> Maybe1 A 110 | nothing : Maybe1 A 111 | 112 | 113 | _<*>_ : forall {a b} -> Maybe1 (a -> b) -> Maybe1 a -> Maybe1 b 114 | nothing <*> _ = nothing 115 | _ <*> nothing = nothing 116 | just f <*> just a = just (f a) 117 | 118 | _<$>_ : forall {a b} -> (a -> b) -> Maybe1 a -> Maybe1 b 119 | f <$> nothing = nothing 120 | f <$> (just x) = just (f x) 121 | infixr 5 _<$>_ 122 | infixl 6 _<*>_ 123 | 124 | mutual 125 | extractP : {Tags : Enumeration} {C : Code Tags} -> 126 | (X : Set) -> (p : Prod) -> (subPatterns : Vec₁ (Pattern C) (countRec p)) -> p2s (μ C) p -> Maybe1 (HList (matched' p subPatterns)) 127 | extractP [] [] _ = just [] 128 | extractP {C = C} (rec ∷ p) (pat ∷ pats) (c , cs) = just HList._++_ <*> (extract pat c) <*> (extractP p pats cs) 129 | extractP (dat A ∷ p) (pats) (c , cs) = just (_∷_ c) <*> (extractP p pats cs) 130 | 131 | extractT : (X : Set) -> {Tags0 Tags : Enumeration} {C0 : Code Tags0} (C : Code Tags) -> 132 | (tag : Member Tags) -> (subPatterns : Vec₁ (Pattern C0) (countRec (lookup1 C tag))) -> c2s (μ C0) C -> Maybe1 (HList (matchedT tag subPatterns)) 133 | extractT ((.t ↦ p) ∷ _ ) (member t here ) subPatterns (inj₁ content) = extractP p subPatterns content 134 | extractT ((.t ↦ p) ∷ _ ) (member t here ) subPatterns (inj₂ _) = nothing 135 | extractT ((_ ↦ _) ∷ tbl) (member t (there p)) subPatterns (inj₂ content) = extractT tbl (member t p) subPatterns content 136 | extractT ((_ ↦ _) ∷ tbl) (member t (there p)) subPatterns (inj₁ _) = nothing 137 | extractT [] (member _ ()) _ _ 138 | 139 | extract : (X : Set) -> {Tags : Enumeration} {C : Code Tags} -> (p : Pattern C) -> μ C -> Maybe1 (HList (matched p)) 140 | extract {C = C} (tag :? subPatterns) < v > = extractT C tag subPatterns v 141 | extract ?? _ = just [] 142 | 143 | data FunCase {Tags : Enumeration} (C : Code Tags) (Result : Set) : Set1 where 144 | _?->_ : (p : Pattern C) -> (lambdas (matched p) Result) -> FunCase C Result 145 | 146 | 147 | Function : {Tags : Enumeration} (C : Code Tags) (Result : Set) -> Set1 148 | Function C Result = List1 (FunCase C Result) 149 | 150 | 151 | 152 | -- data Compiled (Result : ResultDesc) where 153 | -- directResult : Result -> Compiled Result 154 | -- analysis : Table (Vec n (Maybe Tag)) (Compiled ModifiedResult) -> Compiled Result 155 | 156 | -- case-wise inclusion. 157 | -- _:<_ : Code _ -> Code _ -> Bool 158 | -- _:<_ [] _ = true 159 | -- _:<_ _ [] = false 160 | -- _:<_ (dataCase t _ ∷ s) (dataCase t' _ ∷ s') = primStringEquality t t' ∧ s :< s' 161 | -- _:<_ s (_ ∷ s') = s :< s' 162 | 163 | 164 | `Val` : Case1 Prod 165 | `Val` = "Val" ↦ (dat ℕ ∷ []) 166 | 167 | `Add` : Case1 Prod 168 | `Add` = "Add" ↦ (rec ∷ (rec ∷ [])) 169 | 170 | `Expr` : Code ? 171 | `Expr` = `Val` ∷ `Add` ∷ [] 172 | 173 | 174 | 175 | --------------------------------------------------------------------------------