├── test ├── quiet.flags ├── quiet.out ├── nodecl.syrup ├── unittest-html.flags ├── adc2par-html.flags ├── diagram-html.flags ├── diagram-source.flags ├── diagram.out ├── nodecl.out ├── diagram-html.syrup ├── diagram-source.syrup ├── emptywhere.syrup ├── unused.syrup ├── adc2par.out ├── typeunfolding.syrup ├── duplicate.syrup ├── unused.out ├── typeunfolding.out ├── diagram.syrup ├── dnf.out ├── unfold.syrup ├── srff.syrup ├── duplicate.out ├── crash.syrup ├── dup.syrup ├── unittest.syrup ├── unittest-html.syrup ├── hole.syrup ├── definition.syrup ├── unfold.out ├── definition.out ├── dup.out ├── needlesssplit.syrup ├── dnf.syrup ├── needlesssplit.out ├── hole.out ├── emptywhere.out ├── scope.syrup ├── unittest.out ├── srff.out ├── cost.syrup ├── not-impossible-impossible-hadd.syrup ├── cost.out ├── crash.out ├── memories.syrup ├── simplify.syrup ├── experiment.syrup ├── simplify.out ├── Test.hs ├── quiet.syrup ├── scope.out ├── adc2par.syrup ├── not-impossible-impossible-hadd.out ├── stopwatch.syrup ├── memories.out ├── adc2par-html.syrup ├── diagram-source.out ├── experiment.out ├── samples.syrup ├── unittest-html.out ├── diagram-html.out └── stopwatch.out ├── assets ├── syrup.png └── syrup-large.png ├── lib ├── Utilities │ ├── Nat.hs │ ├── Monad.hs │ ├── Bwd.hs │ ├── Lens.hs │ ├── Vector.hs │ └── HTML.hs ├── Data │ ├── Forget.hs │ └── IMaybe.hs └── Language │ └── Syrup │ ├── HalfZip.hs │ ├── Bwd.hs │ ├── Ded.hs │ ├── Fsh.hs │ ├── Sub.hs │ ├── Cst.hs │ ├── Opt.hs │ ├── Utils.hs │ ├── Syn │ └── Base.hs │ ├── Va.hs │ ├── Gph.hs │ ├── Lnt.hs │ ├── Fdk │ └── Base.hs │ ├── Unelab.hs │ ├── Lex.hs │ ├── Run.hs │ ├── DeMorgan.hs │ ├── Smp.hs │ ├── Syn.hs │ ├── Pretty.hs │ ├── Scp.hs │ ├── DNF.hs │ ├── BigArray.hs │ ├── Fdk.hs │ ├── Anf.hs │ └── Doc.hs ├── doc └── manual │ ├── Syrup.pdf │ └── Makefile ├── CHANGELOG.md ├── Makefile ├── .gitignore ├── emacs ├── emacs └── syrup.el ├── README.md ├── src └── Main.hs ├── syrup.cabal └── .github └── workflows └── haskell-ci.yml /test/quiet.flags: -------------------------------------------------------------------------------- 1 | -q -------------------------------------------------------------------------------- /test/quiet.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/nodecl.syrup: -------------------------------------------------------------------------------- 1 | f(X) = X -------------------------------------------------------------------------------- /test/unittest-html.flags: -------------------------------------------------------------------------------- 1 | --html 2 | -------------------------------------------------------------------------------- /test/adc2par-html.flags: -------------------------------------------------------------------------------- 1 | --html 2 | --source-dot -------------------------------------------------------------------------------- /test/diagram-html.flags: -------------------------------------------------------------------------------- 1 | --html 2 | --source-dot -------------------------------------------------------------------------------- /test/diagram-source.flags: -------------------------------------------------------------------------------- 1 | -q 2 | --source-dot -------------------------------------------------------------------------------- /test/diagram.out: -------------------------------------------------------------------------------- 1 | Circuits `not` and `or` are defined. 2 | -------------------------------------------------------------------------------- /test/nodecl.out: -------------------------------------------------------------------------------- 1 | Error: You haven't declared the circuit `f` just now. 2 | -------------------------------------------------------------------------------- /assets/syrup.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pigworker/Syrup/HEAD/assets/syrup.png -------------------------------------------------------------------------------- /lib/Utilities/Nat.hs: -------------------------------------------------------------------------------- 1 | module Utilities.Nat where 2 | 3 | data Nat = Ze | Su Nat 4 | -------------------------------------------------------------------------------- /test/diagram-html.syrup: -------------------------------------------------------------------------------- 1 | not() -> 2 | not(x) = nand(x, x) 3 | 4 | display not -------------------------------------------------------------------------------- /doc/manual/Syrup.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pigworker/Syrup/HEAD/doc/manual/Syrup.pdf -------------------------------------------------------------------------------- /test/diagram-source.syrup: -------------------------------------------------------------------------------- 1 | not() -> 2 | not(x) = nand(x, x) 3 | 4 | display not -------------------------------------------------------------------------------- /assets/syrup-large.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pigworker/Syrup/HEAD/assets/syrup-large.png -------------------------------------------------------------------------------- /test/emptywhere.syrup: -------------------------------------------------------------------------------- 1 | and(,) -> 2 | and(X,Y) = notnand where 3 | 4 | notnand = nand(nand(X,Y),nand(X,Y)) -------------------------------------------------------------------------------- /test/unused.syrup: -------------------------------------------------------------------------------- 1 | f() -> 2 | f(X) = X where 3 | 4 | Y = X 5 | Z = Y 6 | T = [X,Y,Z] 7 | 8 | simplify f -------------------------------------------------------------------------------- /test/adc2par.out: -------------------------------------------------------------------------------- 1 | Circuits `not`, `and`, `or`, `nor`, `xor`, `hadd`, `fadd`, `adc2`, `one`, `mux`, and `adc2par` are defined. 2 | -------------------------------------------------------------------------------- /doc/manual/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | latexmk -pdf Syrup.tex -outdir=__build 3 | cp __build/Syrup.pdf . 4 | 5 | clean: 6 | rm -rf __build 7 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for syrup 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /test/typeunfolding.syrup: -------------------------------------------------------------------------------- 1 | type = 2 | 3 | nand2(, ) -> 4 | nand2(X, Y) = nand(X,Y) 5 | 6 | experiment nand = nand2 -------------------------------------------------------------------------------- /test/duplicate.syrup: -------------------------------------------------------------------------------- 1 | duplicate() -> , 2 | duplicate(X) = Z, Z where 3 | Z = nand(X, X) 4 | 5 | anf duplicate 6 | -- display duplicate -------------------------------------------------------------------------------- /test/unused.out: -------------------------------------------------------------------------------- 1 | Warning: the wires T, Y, Z are defined but never used. 2 | 3 | Circuit `f` is defined. 4 | 5 | Simplification of `f`: 6 | f() -> 7 | f(X) = X 8 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: updatetests TAGS 2 | 3 | all: 4 | cabal build 5 | 6 | updatetests: 7 | cabal run syrup:golden-tests -- --accept 8 | 9 | TAGS: 10 | hasktags --etags . 11 | -------------------------------------------------------------------------------- /lib/Utilities/Monad.hs: -------------------------------------------------------------------------------- 1 | module Utilities.Monad where 2 | 3 | whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () 4 | whenJust Nothing _ = pure () 5 | whenJust (Just a) k = k a 6 | -------------------------------------------------------------------------------- /test/typeunfolding.out: -------------------------------------------------------------------------------- 1 | Type `` is defined. 2 | 3 | Circuit `nand2` is defined. 4 | 5 | Bisimulation between `nand`, `nand2`: 6 | `nand` behaves like `nand2` 7 | `{}` ~ `{}` 8 | -------------------------------------------------------------------------------- /test/diagram.syrup: -------------------------------------------------------------------------------- 1 | not() -> 2 | not(x) = nand(x, x) 3 | 4 | -- display not 5 | 6 | or(, ) -> 7 | or(X,Y) = nand(!X,!Y) 8 | 9 | --display or 10 | --display [not] or -------------------------------------------------------------------------------- /test/dnf.out: -------------------------------------------------------------------------------- 1 | Circuits `not`, `and`, `or`, `one`, and `complex` are defined. 2 | 3 | Disjunctive Normal Form of `complex`: 4 | complex(, , ) -> 5 | complex(X, Y, Z) = !X & !Y | !X & !Z 6 | -------------------------------------------------------------------------------- /test/unfold.syrup: -------------------------------------------------------------------------------- 1 | display nand 2 | 3 | not() -> 4 | not(X) = nand(X,X) 5 | 6 | -- display [nand] not 7 | 8 | f() -> 9 | f(X) = Z 10 | 11 | display f 12 | 13 | --display [g] not -------------------------------------------------------------------------------- /lib/Utilities/Bwd.hs: -------------------------------------------------------------------------------- 1 | module Utilities.Bwd where 2 | 3 | data Bwd a = Lin | (:<) (Bwd a) a 4 | deriving (Eq, Show, Functor, Foldable, Traversable) 5 | 6 | (<><) :: Bwd a -> [a] -> Bwd a 7 | sx <>< [] = sx 8 | sx <>< (x : xs) = (sx :< x) <>< xs 9 | -------------------------------------------------------------------------------- /test/srff.syrup: -------------------------------------------------------------------------------- 1 | experiment srff 2 | experiment srff = srff 3 | 4 | display srff 5 | 6 | type srff 7 | 8 | not() -> 9 | not(X) = nand(X,X) 10 | 11 | dff2() -> @ 12 | dff2(D) = srff(D,!D) 13 | 14 | experiment dff2 15 | experiment dff = dff2 -------------------------------------------------------------------------------- /test/duplicate.out: -------------------------------------------------------------------------------- 1 | Circuit `duplicate` is defined. 2 | 3 | A Normal Form of `duplicate`: 4 | duplicate() -> , 5 | duplicate(X) = __VIRTUAL__2, __VIRTUAL__3 where 6 | __VIRTUAL__0, __VIRTUAL__1 = [X, X] 7 | __VIRTUAL__2, __VIRTUAL__3 = [Z, Z] 8 | Z = nand(__VIRTUAL__0, __VIRTUAL__1) 9 | -------------------------------------------------------------------------------- /test/crash.syrup: -------------------------------------------------------------------------------- 1 | one() -> @ 2 | one(X) = Z where 3 | 4 | Z = dff(Q) 5 | Q = nand(X,Y) 6 | Y = Z 7 | 8 | two() -> @ 9 | two(X) = Z where 10 | 11 | Z = dff(Q) 12 | Q = nand(X,Y) 13 | Y = dff(Q) 14 | 15 | experiment one 16 | experiment two 17 | 18 | experiment one = two 19 | experiment two = one -------------------------------------------------------------------------------- /test/dup.syrup: -------------------------------------------------------------------------------- 1 | dup() -> , 2 | dup(X) = X,X 3 | 4 | experiment dup 5 | 6 | not() -> 7 | not(X) = nand(X,X) 8 | 9 | dop() -> , 10 | dop(X) = dup(!X) 11 | 12 | experiment dop 13 | 14 | doop() -> , , , 15 | doop(X) = dup(!X), dup(!X) 16 | 17 | experiment doop 18 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | cabal.project.local~ 21 | .HTF/ 22 | .ghc.environment.* 23 | *~ 24 | *.html 25 | #* 26 | TAGS -------------------------------------------------------------------------------- /test/unittest.syrup: -------------------------------------------------------------------------------- 1 | experiment nand(00) = 1 2 | experiment nand(11) = 0 3 | 4 | experiment dff{0}(1) = {1}0 5 | 6 | experiment nand{0}(00) = 1 7 | experiment nand() = 1 8 | experiment nand(00) = {1}0 9 | experiment nand(00) = 00 10 | 11 | alternator() -> @ 12 | alternator() = Q where 13 | 14 | Q = dff(nand(Q,Q)) 15 | 16 | experiment alternator{0}() = {1}0 -------------------------------------------------------------------------------- /test/unittest-html.syrup: -------------------------------------------------------------------------------- 1 | experiment nand(00) = 1 2 | experiment nand(11) = 0 3 | 4 | experiment dff{0}(1) = {1}0 5 | 6 | experiment nand{0}(00) = 1 7 | experiment nand() = 1 8 | experiment nand(00) = {1}0 9 | experiment nand(00) = 00 10 | 11 | alternator() -> @ 12 | alternator() = Q where 13 | 14 | Q = dff(nand(Q,Q)) 15 | 16 | experiment alternator{0}() = {1}0 -------------------------------------------------------------------------------- /emacs/emacs: -------------------------------------------------------------------------------- 1 | ;; this should be inserted in your .emacs 2 | ;; be careful to replace PATH/TO/ with the path... 3 | 4 | ;; syrup 5 | (autoload 'syrup-mode "PATH/TO/syrup/emacs/syrup.el" nil t) 6 | (add-to-list 'auto-mode-alist '("\\.syrup\\'" . syrup-mode)) 7 | ;; additionally if you want rainbow delimiters on parens, braces & brackets 8 | (add-hook 'syrup-mode-hook 'rainbow-delimiters-mode) -------------------------------------------------------------------------------- /test/hole.syrup: -------------------------------------------------------------------------------- 1 | not() -> 2 | not(X) = nand(X,X) 3 | 4 | and(, ) -> 5 | and(X,Y) = !nand(X,Y) 6 | 7 | or(, ) -> 8 | or(X,Y) = nand(!X,!Y) 9 | 10 | type = [, ] 11 | 12 | f() -> , 13 | f(X) = !R & S & ?A & (?B | ?C), ?E where 14 | 15 | [R,S] = ?D 16 | 17 | problematic() -> 18 | problematic() = ? -------------------------------------------------------------------------------- /test/definition.syrup: -------------------------------------------------------------------------------- 1 | not() -> 2 | not(X) = nand(X,X) 3 | 4 | and(, ) -> 5 | and(X,Y) = !nand(X,Y) 6 | 7 | or(, ) -> 8 | or(X,Y) = nand(!X,!Y) 9 | 10 | 1 -> 11 | 1 = !0 12 | 13 | definition f [X,Y,Z] [0,0,0,0,1,0,0,1] 14 | definition g [X,Y,X] [0,0,0,0,1,0,0,1] 15 | definition h [] [] 16 | definition i [X] [0] 17 | definition j [] [0] -------------------------------------------------------------------------------- /test/unfold.out: -------------------------------------------------------------------------------- 1 | Warning: I don't have an implementation for `nand`. 2 | 3 | Circuit `not` is defined. 4 | 5 | Error: I was trying to make sense of the following code: 6 | f() -> 7 | f(X) = Z 8 | 9 | Error: You tried to use Z but it is not in scope. 10 | 11 | Warning: Circuit `f` has been stubbed out. 12 | 13 | Warning: I don't have an implementation for `f`. 14 | -------------------------------------------------------------------------------- /lib/Data/Forget.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | module Data.Forget where 4 | 5 | import Data.Void (Void) 6 | import Unsafe.Coerce 7 | 8 | class Forget a b where 9 | instance Forget Void a where 10 | 11 | instance Forget a b => Forget (Maybe a) (Maybe b) where 12 | instance Forget a b => Forget [a] [b] where 13 | 14 | forget :: Forget a b => a -> b 15 | forget = unsafeCoerce 16 | -------------------------------------------------------------------------------- /test/definition.out: -------------------------------------------------------------------------------- 1 | Circuits `not`, `and`, `or`, and `one` are defined. 2 | 3 | DNF circuit for `f`: 4 | f(, , ) -> 5 | f(X, Y, Z) = X & Y & Z | X & !Y & !Z 6 | 7 | Error: You are redefining the local variable X. 8 | 9 | Error: Invalid truth table output for `h`. 10 | 11 | Error: Invalid truth table output for `i`. 12 | 13 | DNF circuit for `j`: 14 | j() -> 15 | j() = 0 16 | -------------------------------------------------------------------------------- /lib/Data/IMaybe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | module Data.IMaybe where 4 | 5 | import Data.Kind (Type) 6 | 7 | data IMaybe (b :: Bool) (a :: Type) :: Type where 8 | IJust :: a -> IMaybe True a 9 | INothing :: IMaybe False a 10 | 11 | deriving instance Show a => Show (IMaybe b a) 12 | deriving instance Functor (IMaybe b) 13 | 14 | fromIJust :: IMaybe True a -> a 15 | fromIJust (IJust x) = x 16 | -------------------------------------------------------------------------------- /test/dup.out: -------------------------------------------------------------------------------- 1 | Circuit `dup` is defined. 2 | 3 | Truth table for `dup`: 4 | X | X X 5 | --|---- 6 | 0 | 0 0 7 | 1 | 1 1 8 | 9 | Circuits `not` and `dop` are defined. 10 | 11 | Truth table for `dop`: 12 | X | 13 | --|---- 14 | 0 | 1 1 15 | 1 | 0 0 16 | 17 | Circuit `doop` is defined. 18 | 19 | Truth table for `doop`: 20 | X | 21 | --|-------- 22 | 0 | 1 1 1 1 23 | 1 | 0 0 0 0 24 | -------------------------------------------------------------------------------- /test/needlesssplit.syrup: -------------------------------------------------------------------------------- 1 | type = [,] 2 | type = [,] 3 | 4 | swap() -> 5 | swap([[X0,X1],[X2,X3]]) = [[X2,X3],[X0,X1]] 6 | 7 | fst() -> 8 | fst([[X0,X1],[X2,X3]]) = [X0,X1] 9 | 10 | snd() -> 11 | snd([_,X23]) = [Y2,Y3] where 12 | [Y2,Y3] = X23 13 | 14 | nowarn() -> ,, 15 | nowarn([[X0,X1],X23]) = X0,[Y2,Y3],Y3 where 16 | [Y2,Y3] = X23 -------------------------------------------------------------------------------- /lib/Language/Syrup/HalfZip.hs: -------------------------------------------------------------------------------- 1 | module Language.Syrup.HalfZip where 2 | 3 | class Functor f => HalfZip f where 4 | halfZip :: f x -> f y -> Maybe (f (x, y)) 5 | 6 | {- 7 | halfZip fx fy = fmap (fmap swap) (halfZip fy fx) 8 | halfZip (fmap g fx) (fmap h fx) = Just (fmap (f &&& g) fx) 9 | halfZip fx fy = Just fxy -> fmap fst fxy = fx * fmap snd fxy = fy 10 | halfZip fx fy = Nothing -> fmap (const ()) fx /= fmap (const ()) fy 11 | 12 | -- are the above redundant? 13 | -} -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Syrup logo 2 | 3 | # Syrup 4 | being a programming language for sequential circuits 5 | 6 | 7 | # Installation 8 | 9 | * First install `ghc` and `cabal` (https://www.haskell.org/ghcup/) 10 | * Install graphviz's `dot` executable (https://graphviz.org/docs/layouts/dot/) 11 | * Then get the content of this repository (https://github.com/pigworker/Syrup/archive/refs/heads/main.zip) 12 | * Unzip it, change directory to `Syrup-main` and run `cabal install` 13 | -------------------------------------------------------------------------------- /test/dnf.syrup: -------------------------------------------------------------------------------- 1 | not() -> 2 | not(X) = nand(X,X) 3 | 4 | and(, ) -> 5 | and(X,Y) = not(nand(X,Y)) 6 | 7 | or(, ) -> 8 | or(X,Y) = nand(Z, S) where 9 | Z = not(X) 10 | S = not(Y) 11 | 12 | one() -> 13 | one() = !0 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | ---------------------------------------------- 40 | 41 | complex(, , ) -> 42 | complex(X,Y,Z) = !(X|Y&Z) & !(!Z&Y&X) 43 | 44 | dnf complex -------------------------------------------------------------------------------- /test/needlesssplit.out: -------------------------------------------------------------------------------- 1 | Types `` and `` are defined. 2 | 3 | Warning: the cables [X0, X1], [X2, X3] are taken apart only to be reconstructed or unused. 4 | Did you consider giving each cable a name without breaking it up? 5 | 6 | Circuit `swap` is defined. 7 | 8 | Warning: the cables [X0, X1], [X2, X3] are taken apart only to be reconstructed or unused. 9 | Did you consider giving each cable a name without breaking it up? 10 | 11 | Circuit `fst` is defined. 12 | 13 | Warning: the cable [Y2, Y3] is taken apart only to be reconstructed or unused. 14 | Did you consider giving each cable a name without breaking it up? 15 | 16 | Circuits `snd` and `nowarn` are defined. 17 | -------------------------------------------------------------------------------- /test/hole.out: -------------------------------------------------------------------------------- 1 | Circuits `not`, `and`, and `or` are defined. 2 | 3 | Type `` is defined. 4 | 5 | Warning: Found holes in circuit `f`: 6 | ?A : 7 | ?B : 8 | ?C : 9 | ?D : [, ] 10 | ?E : 11 | 12 | Warning: Circuit `f` has been stubbed out. 13 | 14 | Error: I was trying to make sense of the following code: 15 | problematic() = ? 16 | I got stuck here: 17 | problematic() = {HERE} ? 18 | I was looking for a definition. 19 | At that point, it made sense, but then I found stuff I didn't expect. 20 | 21 | Error: You haven't defined the circuit `problematic` just now. 22 | 23 | Warning: Circuit `problematic` has been stubbed out. 24 | -------------------------------------------------------------------------------- /test/emptywhere.out: -------------------------------------------------------------------------------- 1 | Warning: Empty where clause in the definition of and. 2 | Did you forget to indent the block of local definitions using spaces? 3 | 4 | Error: I was trying to make sense of the following code: 5 | and(,) -> 6 | and(X,Y) = notnand where 7 | 8 | Error: You tried to use notnand but it is not in scope. 9 | 10 | Warning: Circuit `and` has been stubbed out. 11 | 12 | Error: I was trying to make sense of the following code: 13 | notnand = nand(nand(X,Y),nand(X,Y)) 14 | I got stuck here: 15 | ... notnand {HERE} = nand(nand(X,Y),nand(X,Y)) ... 16 | I was looking for a component template. 17 | At that point, I was hoping for (..) but I found = which vexed me. 18 | -------------------------------------------------------------------------------- /test/scope.syrup: -------------------------------------------------------------------------------- 1 | not() -> 2 | not(c) = nand(c,c) 3 | 4 | not2() -> 5 | not2(c) = !C 6 | 7 | nand(,) -> 8 | nand(X,Y) = nand(X,Y) 9 | 10 | and(,) -> 11 | and(X,Y) = !n where 12 | 13 | N = nand(X,Y) 14 | 15 | or(,) -> 16 | or(X,Y) = nand(!X,!Y) 17 | 18 | xor(,) -> 19 | xor(X,Y) = X&!Y|!X&Y 20 | 21 | h1(,) -> , 22 | h1(X,Y) = C,Z where 23 | 24 | C = X&Y 25 | Z = xor(X,Y) 26 | 27 | f1(,) -> , 28 | f1(X,Y,CIN) = Cin,Z where 29 | 30 | CIN = xor(CiN, CIn) 31 | CiN,Z = h1(D,CIn) 32 | CIn,D = h1(X,Y) 33 | 34 | tff() -> @ 35 | tff(T) = Q where 36 | 37 | Q = dff(D) 38 | D = T & !Q | !T & Q -------------------------------------------------------------------------------- /test/unittest.out: -------------------------------------------------------------------------------- 1 | When unit testing `nand(00) = 1`: 2 | Success! 3 | 4 | When unit testing `nand(11) = 0`: 5 | Success! 6 | 7 | When unit testing `dff{0}(1) = {1}0`: 8 | Success! 9 | 10 | Error: When unit testing `nand{0}(00) = 1`: 11 | Memory for `nand` has type `{}`. 12 | That can't store {0}. 13 | 14 | Error: When unit testing `nand() = 1`: 15 | Inputs for `nand` are typed `(, )`. 16 | That can't accept `()`. 17 | 18 | Error: When unit testing `nand(00) = {1}0`: 19 | Memory for `nand` has type `{}`. 20 | That can't store {1}. 21 | 22 | Error: When unit testing `nand(00) = 00`: 23 | Outputs for `nand` are typed ``. 24 | That can't accept `0, 0`. 25 | 26 | Circuit `alternator` is defined. 27 | 28 | When unit testing `alternator{0}() = {1}0`: 29 | Success! 30 | -------------------------------------------------------------------------------- /test/srff.out: -------------------------------------------------------------------------------- 1 | Truth table for `srff`: 2 | S R { Q -> Q } Q 3 | ----{--------}-- 4 | 0 0 { 0 -> 0 } 0 5 | { 1 -> 1 } 1 6 | 0 1 { 0 -> 0 } 0 7 | { 1 -> 0 } 1 8 | 1 0 { 0 -> 1 } 0 9 | { 1 -> 1 } 1 10 | 1 1 { 0 -> ? } 0 11 | { 1 -> ? } 1 12 | 13 | Bisimulation between `srff`, `srff`: 14 | `srff` behaves like `srff` 15 | `{1}` ~ `{1}` 16 | `{0}` ~ `{0}` 17 | 18 | Warning: I don't have an implementation for `srff`. 19 | 20 | Typing for `srff`: 21 | srff(, ) -> @ 22 | 23 | Circuits `not` and `dff2` are defined. 24 | 25 | Truth table for `dff2`: 26 | D { -> } 27 | --{--------}-- 28 | 0 { 0 -> 0 } 0 29 | { 1 -> 0 } 1 30 | 1 { 0 -> 1 } 0 31 | { 1 -> 1 } 1 32 | 33 | Bisimulation between `dff`, `dff2`: 34 | `dff` behaves like `dff2` 35 | `{1}` ~ `{1}` 36 | `{0}` ~ `{0}` 37 | -------------------------------------------------------------------------------- /test/cost.syrup: -------------------------------------------------------------------------------- 1 | not() -> 2 | not(X) = nand(X,X) 3 | 4 | and(, ) -> 5 | and(X,Y) = not(nand(X,Y)) 6 | 7 | or(, ) -> 8 | or(X,Y) = nand(Z, S) where 9 | Z = not(X) 10 | S = not(Y) 11 | 12 | xor(, ) -> 13 | xor(X,Y) = or(L,R) where 14 | 15 | L = and(X,not(Y)) 16 | R = and(not(X),Y) 17 | 18 | eq(, ) -> 19 | eq(X, Y) = Z where 20 | Z = not(xor(X, Y)) 21 | 22 | one() -> 23 | one() = not(zero()) 24 | 25 | mux(, , ) -> 26 | mux(C, X, Y) = C&X | !C&Y 27 | 28 | xor2(, ) -> 29 | xor2(X, Y) = mux(X, !Y, Y) 30 | 31 | cost not 32 | cost [] and 33 | cost or 34 | cost [or] or 35 | cost [not] or 36 | cost [] xor 37 | cost [and,or,not] xor 38 | cost [and,or,not] eq 39 | cost zero 40 | cost one 41 | cost [not, zero] one 42 | cost [and, or, not] mux 43 | cost [mux] xor2 -------------------------------------------------------------------------------- /lib/Utilities/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | 4 | module Utilities.Lens where 5 | 6 | import Control.Applicative (Const(Const), getConst) 7 | import Control.Monad.Identity (Identity(Identity), runIdentity) 8 | import Control.Monad.State (MonadState, get, modify) 9 | 10 | type Lens i o = forall f. Functor f => (i -> f i) -> (o -> f o) 11 | 12 | (^.) :: o -> Lens i o -> i 13 | v ^. l = getConst (l Const v) 14 | 15 | over :: Lens i o -> (i -> i) -> (o -> o) 16 | over l f = runIdentity . l (Identity . f) 17 | 18 | (.=) :: MonadState o m => Lens i o -> i -> m () 19 | l .= v = l %= const v 20 | 21 | (%=) :: MonadState o m => Lens i o -> (i -> i) -> m () 22 | l %= f = modify (over l f) 23 | 24 | use :: MonadState o m => Lens i o -> m i 25 | use l = getConst . l Const <$> get 26 | 27 | class Has i o where 28 | hasLens :: Lens i o 29 | -------------------------------------------------------------------------------- /test/not-impossible-impossible-hadd.syrup: -------------------------------------------------------------------------------- 1 | ! -> 2 | !X = Z where 3 | Z = nand(X, X) 4 | 5 | & -> 6 | X & Y = Z where 7 | A = nand(X, Y) 8 | Z = !A 9 | 10 | | -> 11 | X | Y = Z where 12 | A, B = !X, !Y 13 | Z = nand(A, B) 14 | 15 | one() -> 16 | one() = !zero() 17 | 18 | xor(, ) -> 19 | xor(X, Y) = Z where 20 | A, B = X | Y, X & Y 21 | C = !B 22 | Z = A & C 23 | 24 | hadd(,) -> , 25 | fadd(,,) -> , 26 | tripleAddTwo(,) -> ,,, 27 | 28 | 29 | hadd(x,y) = a2, b1 where 30 | a2 = and(x,y) 31 | a1 = xor(x,y) 32 | 33 | experiment hadd 34 | 35 | fadd(Cin,Xin,Yin) = Cout,Zout where 36 | a2,a1 = hadd(Xin,Yin) 37 | b2,Zout = hadd(Cin,a1) 38 | Cout = xor(a2,b2) 39 | 40 | experiment fadd 41 | display fadd 42 | 43 | tripleAddTwo -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- Main: Syrup Command Line ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | {-# LANGUAGE LambdaCase #-} 8 | 9 | module Main where 10 | 11 | import Language.Syrup.Opt 12 | import Language.Syrup.Run 13 | 14 | import System.Environment 15 | import System.Exit 16 | 17 | main :: IO () 18 | main = do 19 | opts <- getArgs >>= \args -> case parseOptions defaultOptions args of 20 | Left e -> die ("Error: " ++ e) 21 | Right opts -> pure opts 22 | src <- case filepath opts of 23 | Nothing -> getContents 24 | Just fp -> readFile fp 25 | putStr (syrup opts src) 26 | -------------------------------------------------------------------------------- /test/cost.out: -------------------------------------------------------------------------------- 1 | Circuits `not`, `and`, `or`, `xor`, `eq`, `one`, `mux`, and `xor2` are defined. 2 | 3 | Cost for `not`: 4 | 1 copy of `nand` 5 | 6 | Cost for `and`: 7 | 2 copies of `nand` 8 | 9 | Cost for `or`: 10 | 3 copies of `nand` 11 | 12 | Cost for `or`: 13 | 1 copy of `or` 14 | 15 | Cost for `or`: 16 | 1 copy of `nand` 17 | 2 copies of `not` 18 | 19 | Cost for `xor`: 20 | 9 copies of `nand` 21 | 22 | Cost for `xor`: 23 | 2 copies of `and` 24 | 2 copies of `not` 25 | 1 copy of `or` 26 | 27 | Cost for `eq`: 28 | 2 copies of `and` 29 | 3 copies of `not` 30 | 1 copy of `or` 31 | 32 | Cost for `zero`: 33 | 1 copy of `zero` 34 | 35 | Cost for `one`: 36 | 1 copy of `nand` 37 | 1 copy of `zero` 38 | 39 | Cost for `one`: 40 | 1 copy of `not` 41 | 1 copy of `zero` 42 | 43 | Cost for `mux`: 44 | 2 copies of `and` 45 | 1 copy of `not` 46 | 1 copy of `or` 47 | 48 | Cost for `xor2`: 49 | 1 copy of `mux` 50 | 1 copy of `nand` 51 | -------------------------------------------------------------------------------- /lib/Utilities/Vector.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Utilities.Vector where 4 | 5 | import Data.Kind 6 | import Utilities.Nat 7 | 8 | infixr 5 :* 9 | data Vector (n :: Nat) (a :: Type) where 10 | VNil :: Vector Ze a 11 | (:*) :: a -> Vector n a -> Vector (Su n) a 12 | 13 | hd :: Vector (Su n) a -> a 14 | hd (t :* _) = t 15 | 16 | instance Functor (Vector n) where 17 | fmap f VNil = VNil 18 | fmap f (x :* xs) = f x :* fmap f xs 19 | 20 | instance Foldable (Vector n) where 21 | foldMap f VNil = mempty 22 | foldMap f (x :* xs) = f x <> foldMap f xs 23 | 24 | instance Traversable (Vector n) where 25 | traverse f VNil = pure VNil 26 | traverse f (x :* xs) = (:*) <$> f x <*> traverse f xs 27 | 28 | data AList a where 29 | AList :: forall n a. Vector n a -> AList a 30 | 31 | nil :: AList a 32 | nil = AList VNil 33 | 34 | cons :: a -> AList a -> AList a 35 | cons x (AList xs) = AList (x :* xs) 36 | 37 | fromList :: [a] -> AList a 38 | fromList = foldr cons nil 39 | -------------------------------------------------------------------------------- /test/crash.out: -------------------------------------------------------------------------------- 1 | Circuits `one` and `two` are defined. 2 | 3 | Truth table for `one`: 4 | X { Z -> Z } Z 5 | --{--------}-- 6 | 0 { 0 -> 1 } 0 7 | { 1 -> 1 } 1 8 | 1 { 0 -> 1 } 0 9 | { 1 -> 0 } 1 10 | 11 | Truth table for `two`: 12 | X { Z Y -> Z Y } Z 13 | --{------------}-- 14 | 0 { 0 0 -> 1 1 } 0 15 | { 0 1 -> 1 1 } 0 16 | { 1 0 -> 1 1 } 1 17 | { 1 1 -> 1 1 } 1 18 | 1 { 0 0 -> 1 1 } 0 19 | { 0 1 -> 0 0 } 0 20 | { 1 0 -> 1 1 } 1 21 | { 1 1 -> 0 0 } 1 22 | 23 | Bisimulation between `one`, `two`: 24 | `two` can be distinguished from all possible states of `one`when `two` has memory `{10}` 25 | if `one` has memory like `{1}`, try inputs `0;1;0` 26 | if `one` has memory like `{0}`, try inputs `0` 27 | 28 | Bisimulation between `two`, `one`: 29 | `two` can be distinguished from all possible states of `one` 30 | when `two` has memory `{10}` 31 | if `one` has memory like `{1}`, try inputs `0;1;0` 32 | if `one` has memory like `{0}`, try inputs `0` 33 | -------------------------------------------------------------------------------- /lib/Utilities/HTML.hs: -------------------------------------------------------------------------------- 1 | module Utilities.HTML where 2 | 3 | import Data.List (intersperse, intercalate) 4 | 5 | htmlc :: Char -> String 6 | htmlc '<' = "<" 7 | htmlc '>' = ">" 8 | htmlc '&' = "&" 9 | htmlc c = [c] 10 | 11 | escapeHTML :: String -> String 12 | escapeHTML = concatMap htmlc 13 | 14 | br :: String 15 | br = "
" 16 | 17 | asHTML :: [String] -> String 18 | asHTML ls = intercalate "\n" $ intersperse br (escapeHTML <$> ls) 19 | 20 | tag :: String -> String -> String 21 | tag t txt = concat ["<",t,">",txt,""] 22 | 23 | pre :: String -> String 24 | pre = tag "pre" 25 | 26 | code :: String -> String 27 | code = tag "code" 28 | 29 | span :: [String] -> String -> String 30 | span attrs doc = concat 31 | [ "" 34 | , doc 35 | , "" 36 | ] 37 | 38 | div :: [String] -> String -> String 39 | div attrs doc = concat 40 | [ "
" 43 | , doc 44 | , "
" 45 | ] 46 | -------------------------------------------------------------------------------- /test/memories.syrup: -------------------------------------------------------------------------------- 1 | experiment dff 2 | type dff 3 | 4 | not() -> 5 | not(X) = nand(X,X) 6 | 7 | and(,) -> 8 | and(X,Y) = !nand(X,Y) 9 | 10 | or(,) -> 11 | or(X,Y) = nand(!X,!Y) 12 | 13 | alternator() -> @ 14 | alternator() = ALT where 15 | 16 | ALT = dff(!ALT) 17 | 18 | experiment alternator 19 | 20 | xor(,) -> 21 | xor(X,Y) = !X&Y | X&!Y 22 | 23 | tff() -> @ 24 | tff(T) = Q where 25 | 26 | Q = dff(xor(T,Q)) 27 | 28 | experiment tff 29 | 30 | count2() -> @,@ 31 | count2() = Q2,Q1 where 32 | 33 | Q1 = alternator() 34 | Q2 = tff(Q1) 35 | 36 | experiment count2 37 | 38 | count2tff() -> @[,] 39 | count2tff() = [Q2,Q1] where 40 | 41 | Q1 = tff(ONE) 42 | Q2 = tff(Q1) 43 | ONE = Q1|!Q1 44 | 45 | experiment count2tff 46 | 47 | dff() -> @ 48 | dff(D) = QD where 49 | 50 | QD = tff(xor(D,QD)) 51 | 52 | experiment dff 53 | 54 | zero() -> 55 | zero() = Z where 56 | 57 | Z = W&!W 58 | W = dff(W) 59 | 60 | experiment zero -------------------------------------------------------------------------------- /test/simplify.syrup: -------------------------------------------------------------------------------- 1 | not() -> 2 | not(X) = nand(X,X) 3 | 4 | f() -> 5 | f(X) = not(not(not(not(not(X))))) 6 | 7 | simplify f 8 | 9 | g() -> , , , 10 | g(X) = X,not(Y),Z,E where 11 | Y = not(not(Z)) 12 | Z = not(E) 13 | E = not(X) 14 | 15 | simplify g 16 | 17 | and(, ) -> 18 | and(X, Y) = not (nand (not (not(X)), Y)) 19 | 20 | simplify and 21 | 22 | h(, ) -> 23 | h(X,Y) = not (and(X, not(not(Y)))) 24 | 25 | simplify h 26 | 27 | or(, ) -> 28 | or(X, Y) = nand(not(X), not(Y)) 29 | 30 | i(, ) -> 31 | i(X,Y) = not(or(not(X), Y)) 32 | 33 | simplify i 34 | 35 | j(, ) -> 36 | j(X,Y) = or(not(X), not(Y)) 37 | 38 | simplify j 39 | 40 | k(, ) -> 41 | k(X,Y) = or(or(not(X), not(Y)), not(X)) 42 | 43 | simplify k 44 | 45 | l(, ) -> 46 | l(X, Y) = and(not(or(not(X),not(X))), Y) 47 | 48 | simplify l 49 | 50 | m(, ) -> 51 | m(X, Y) = or(or(not(X),not(X)), not(Y)) 52 | 53 | simplify m -------------------------------------------------------------------------------- /test/experiment.syrup: -------------------------------------------------------------------------------- 1 | not() -> 2 | not(X) = nand(X,X) 3 | 4 | and(, ) -> 5 | and(X,Y) = not(nand(X,Y)) 6 | 7 | or(, ) -> 8 | or(X,Y) = nand(Z, S) where 9 | Z = not(X) 10 | S = not(Y) 11 | 12 | xor(, ) -> 13 | xor(X,Y) = or(L,R) where 14 | 15 | L = and(X,not(Y)) 16 | R = and(not(X),Y) 17 | 18 | hadd(, ) -> , 19 | hadd(X, Y) = X&Y, xor(X,Y) 20 | 21 | experiment hadd 22 | 23 | fadd(, , ) -> , 24 | fadd(X, Y, CI) = CO, Z where 25 | 26 | C1, XY = hadd(X,Y) 27 | C2, Z = hadd(XY,CI) 28 | CO = C1|C2 29 | 30 | experiment fadd 31 | 32 | type = [, ] 33 | 34 | adc2(, , ) -> , 35 | adc2([X1, X0], [Y1, Y0], CI) = CO, [Z1, Z0] where 36 | 37 | C1, Z0 = fadd(X0, Y0, CI) 38 | CO, Z1 = fadd(X1, Y1, C1) 39 | 40 | experiment adc2 41 | 42 | experiment adc2([10][01] 1; [11][10] 0) 43 | 44 | xor1(, ) -> 45 | xor1(X,Y) = !X&Y | X&!Y 46 | 47 | xor2(, ) -> 48 | xor2(X,Y) = (X|Y) & !(X&Y) 49 | 50 | experiment xor1 = xor2 51 | 52 | experiment xor = or 53 | 54 | type adc2 55 | print adc2 -------------------------------------------------------------------------------- /test/simplify.out: -------------------------------------------------------------------------------- 1 | Circuits `not` and `f` are defined. 2 | 3 | Simplification of `f`: 4 | f() -> 5 | f(X) = !X 6 | 7 | Circuit `g` is defined. 8 | 9 | Simplification of `g`: 10 | g() -> , , , 11 | g(X) = X, !X, Z, E where 12 | E = !X 13 | Z = X 14 | 15 | Circuit `and` is defined. 16 | 17 | Simplification of `and`: 18 | & -> 19 | X & Y = !nand(X, Y) 20 | 21 | Circuit `h` is defined. 22 | 23 | Simplification of `h`: 24 | h(, ) -> 25 | h(X, Y) = nand(X, Y) 26 | 27 | Circuits `or` and `i` are defined. 28 | 29 | Simplification of `i`: 30 | i(, ) -> 31 | i(X, Y) = X & !Y 32 | 33 | Circuit `j` is defined. 34 | 35 | Simplification of `j`: 36 | j(, ) -> 37 | j(X, Y) = nand(X, Y) 38 | 39 | Circuit `k` is defined. 40 | 41 | Simplification of `k`: 42 | k(, ) -> 43 | k(X, Y) = nand(X & Y, X) 44 | 45 | Circuit `l` is defined. 46 | 47 | Simplification of `l`: 48 | l(, ) -> 49 | l(X, Y) = X & Y 50 | 51 | Circuit `m` is defined. 52 | 53 | Simplification of `m`: 54 | m(, ) -> 55 | m(X, Y) = nand(X, Y) 56 | -------------------------------------------------------------------------------- /test/Test.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.ByteString.Lazy.Char8 (pack) 4 | import Data.Traversable (for) 5 | 6 | import System.Directory (doesFileExist) 7 | import System.Exit (die) 8 | import System.FilePath (takeBaseName, replaceExtension) 9 | 10 | import Test.Tasty (defaultMain, testGroup) 11 | import Test.Tasty.Golden (findByExtension, goldenVsString) 12 | 13 | import Language.Syrup.Run 14 | import Language.Syrup.Opt (defaultOptions, parseOptions) 15 | 16 | main :: IO () 17 | main = do 18 | sources <- findByExtension [".syrup"] "test" 19 | let mkTest = \ src -> 20 | let testName = takeBaseName src in 21 | let goldenFile = replaceExtension src "out" in 22 | let flagsFile = replaceExtension src "flags" in 23 | goldenVsString testName goldenFile $ do 24 | txt <- readFile src 25 | opts <- do 26 | check <- doesFileExist flagsFile 27 | flags <- if check then words <$> readFile flagsFile else pure [] 28 | case parseOptions defaultOptions flags of 29 | Left err -> die err 30 | Right opts -> pure opts 31 | pure $ pack $ syrup opts txt 32 | defaultMain $ testGroup "Tests" (mkTest <$> sources) 33 | -------------------------------------------------------------------------------- /test/quiet.syrup: -------------------------------------------------------------------------------- 1 | ! -> 2 | !X = Z where 3 | Z = nand(X, X) 4 | 5 | & -> 6 | X & Y = Z where 7 | A = nand(X, Y) 8 | Z = !A 9 | 10 | | -> 11 | X | Y = Z where 12 | A, B = !X, !Y 13 | Z = nand(A, B) 14 | 15 | nor(, ) -> 16 | nor(X,Y) = !(X | Y) 17 | 18 | xor(, ) -> 19 | xor(X, Y) = Z where 20 | A, B = X | Y, X & Y 21 | C = !B 22 | Z = A & C 23 | 24 | hadd(, ) -> , 25 | hadd(X1, Y1) = C2, S1 where 26 | C2 = X1 & Y1 27 | S1 = xor(X1, Y1) 28 | 29 | fadd(, , ) -> , 30 | fadd(X1, Y1, C1) = C2, Z1 where 31 | D2, D1 = hadd(X1, Y1) 32 | E2, Z1 = hadd(D1, C1) 33 | C2 = xor(D2, E2) 34 | 35 | adc2([,],[,],) -> 36 | ,[,] 37 | adc2([X2,X1],[Y2,Y1],C1) = C4,[Z2,Z1] where 38 | C2,Z1 = fadd(X1,Y1,C1) 39 | C4,Z2 = fadd(X2,Y2,C2) 40 | 41 | one() -> 42 | one() = !zero() 43 | 44 | mux(, , ) -> 45 | mux(C, X, Y) = C & X | !C & Y 46 | 47 | adc2par([,],[,],) -> 48 | ,[,] 49 | adc2par([X2,X1],[Y2,Y1],C1) = C4,[Z2,Z1] where 50 | C2,Z1 = fadd(X1,Y1,C1) 51 | C40,Z20 = fadd(X2,Y2,zero()) 52 | C41,Z21 = fadd(X2,Y2,one()) 53 | C4=mux(C2,C41,C40) 54 | Z2=mux(C2,Z21,Z20) 55 | -------------------------------------------------------------------------------- /test/scope.out: -------------------------------------------------------------------------------- 1 | Circuit `not` is defined. 2 | 3 | Error: I was trying to make sense of the following code: 4 | not2() -> 5 | not2(c) = !C 6 | 7 | Error: You tried to use C but it is not in scope. 8 | Did you mean: c? 9 | 10 | Warning: Circuit `not2` has been stubbed out. 11 | 12 | Error: You are redefining the top-level variable nand. 13 | 14 | Circuit `nand` is defined. 15 | 16 | Warning: the wire N is defined but never used. 17 | 18 | Error: I was trying to make sense of the following code: 19 | and(,) -> 20 | and(X,Y) = !n where 21 | 22 | N = nand(X,Y) 23 | 24 | Error: You tried to use n but it is not in scope. 25 | Did you mean: N? 26 | 27 | Warning: Circuit `and` has been stubbed out. 28 | 29 | Circuits `or`, `xor`, and `h1` are defined. 30 | 31 | Warning: the wires CIN, CiN are defined but never used. 32 | 33 | Error: I was trying to make sense of the following code: 34 | f1(,) -> , 35 | f1(X,Y,CIN) = Cin,Z where 36 | 37 | CIN = xor(CiN, CIn) 38 | CiN,Z = h1(D,CIn) 39 | CIn,D = h1(X,Y) 40 | 41 | Error: You are redefining the local variable CIN. 42 | Error: You tried to use Cin but it is not in scope. 43 | Did you mean one of these: CIN, CIn, CiN? 44 | 45 | Warning: Circuit `f1` has been stubbed out. 46 | 47 | Circuit `tff` is defined. 48 | -------------------------------------------------------------------------------- /test/adc2par.syrup: -------------------------------------------------------------------------------- 1 | ! -> 2 | !X = Z where 3 | Z = nand(X, X) 4 | 5 | & -> 6 | X & Y = Z where 7 | A = nand(X, Y) 8 | Z = !A 9 | 10 | | -> 11 | X | Y = Z where 12 | A, B = !X, !Y 13 | Z = nand(A, B) 14 | 15 | nor(, ) -> 16 | nor(X,Y) = !(X | Y) 17 | 18 | xor(, ) -> 19 | xor(X, Y) = Z where 20 | A, B = X | Y, X & Y 21 | C = !B 22 | Z = A & C 23 | 24 | hadd(, ) -> , 25 | hadd(X1, Y1) = C2, S1 where 26 | C2 = X1 & Y1 27 | S1 = xor(X1, Y1) 28 | 29 | fadd(, , ) -> , 30 | fadd(X1, Y1, C1) = C2, Z1 where 31 | D2, D1 = hadd(X1, Y1) 32 | E2, Z1 = hadd(D1, C1) 33 | C2 = xor(D2, E2) 34 | 35 | adc2([,],[,],) -> 36 | ,[,] 37 | adc2([X2,X1],[Y2,Y1],C1) = C4,[Z2,Z1] where 38 | C2,Z1 = fadd(X1,Y1,C1) 39 | C4,Z2 = fadd(X2,Y2,C2) 40 | 41 | one() -> 42 | one() = !zero() 43 | 44 | mux(, , ) -> 45 | mux(C, X, Y) = C & X | !C & Y 46 | 47 | adc2par([,],[,],) -> 48 | ,[,] 49 | adc2par([X2,X1],[Y2,Y1],C1) = C4,[Z2,Z1] where 50 | C2,Z1 = fadd(X1,Y1,C1) 51 | C40,Z20 = fadd(X2,Y2,zero()) 52 | C41,Z21 = fadd(X2,Y2,one()) 53 | C4=mux(C2,C41,C40) 54 | Z2=mux(C2,Z21,Z20) 55 | 56 | --display adc2par -------------------------------------------------------------------------------- /test/not-impossible-impossible-hadd.out: -------------------------------------------------------------------------------- 1 | Circuits `not`, `and`, `or`, `one`, and `xor` are defined. 2 | 3 | Error: I was trying to make sense of the following code: 4 | hadd(,) -> , 5 | hadd(x,y) = a2, b1 where 6 | a2 = and(x,y) 7 | a1 = xor(x,y) 8 | 9 | Error: You tried to use b1 but it is not in scope. 10 | 11 | Warning: Circuit `hadd` has been stubbed out. 12 | 13 | Circuit `fadd` is defined. 14 | 15 | Warning: the wire a1 is defined but never used. 16 | 17 | Error: You haven't defined the circuit `tripleAddTwo` just now. 18 | 19 | Warning: Circuit `tripleAddTwo` has been stubbed out. 20 | 21 | Truth table for `hadd`: 22 | | 23 | ----|---- 24 | 0 0 | ? ? 25 | 0 1 | ? ? 26 | 1 0 | ? ? 27 | 1 1 | ? ? 28 | 29 | Truth table for `fadd`: 30 | Cin Xin Yin | Cout Zout 31 | ------------|---------- 32 | 0 0 0 | ? ? 33 | 0 0 1 | ? ? 34 | 0 1 0 | ? ? 35 | 0 1 1 | ? ? 36 | 1 0 0 | ? ? 37 | 1 0 1 | ? ? 38 | 1 1 0 | ? ? 39 | 1 1 1 | ? ? 40 | 41 | Warning: When displaying `fadd`: 42 | I don't have an implementation for `hadd`. 43 | I don't have an implementation for `hadd`. 44 | 45 | Error: I was trying to make sense of the following code: 46 | tripleAddTwo 47 | I got stuck here: 48 | {HERE} tripleAddTwo 49 | I was looking for Syrup source code. 50 | At that point, I didn't know where to begin. 51 | -------------------------------------------------------------------------------- /test/stopwatch.syrup: -------------------------------------------------------------------------------- 1 | not() -> 2 | not(X) = nand(X,X) 3 | 4 | and(, ) -> 5 | and(X,Y) = !nand(X,Y) 6 | 7 | or(, ) -> 8 | or(X,Y) = nand(!X,!Y) 9 | 10 | mux(, , ) -> 11 | mux(C,X,Y) = !C&X | C&Y 12 | 13 | xor(, ) -> 14 | xor(X,Y) = X&!Y | !X&Y 15 | 16 | hadd(, ) -> , 17 | hadd(X,Y) = X&Y, xor(X,Y) 18 | 19 | fadd(, , ) -> , 20 | fadd(X,Y,C) = Z2, Z1 where 21 | 22 | A2, A1 = hadd(X,Y) 23 | B2, Z1 = hadd(A1,C) 24 | Z2 = A2|B2 25 | 26 | type = [, , ] 27 | 28 | rca3(, , ) -> , 29 | rca3([X4,X2,X1], [Y4,Y2,Y1], C1) = C8,[Z4,Z2,Z1] where 30 | 31 | C2, Z1 = fadd(X1,Y1,C1) 32 | C4, Z2 = fadd(X2,Y2,C2) 33 | C8, Z4 = fadd(X4,Y4,C4) 34 | 35 | dff3() -> @ 36 | dff3([X,Y,Z]) = [Q1,Q2,Q3] where 37 | 38 | Q1 = dff(X) 39 | Q2 = dff(Y) 40 | Q3 = dff(Z) 41 | 42 | mux3(, , ) -> 43 | mux3(C, [X3,X2,X1], [Y3,Y2,Y1]) 44 | = [mux(C,X3,Y3), mux(C,X2,Y2), mux(C,X1,Y1)] 45 | 46 | stopwatch() -> @ 47 | stopwatch(RUN) = SECS where 48 | 49 | Z = RUN & !RUN 50 | O = RUN | !RUN 51 | Z3 = [Z,Z,Z] 52 | 53 | RUNNING = dff(RUN) 54 | _,INCR = rca3(SECS,Z3,O) 55 | SECS = dff3(mux3(!xor(RUN, RUNNING),Z3,INCR)) 56 | 57 | experiment stopwatch 58 | 59 | 60 | stopwatch2() -> @ 61 | stopwatch2(RUN) = SECS where 62 | 63 | Z = RUN & !RUN 64 | O = RUN | !RUN 65 | Z3 = [Z,Z,Z] 66 | 67 | RUNNING = dff(RUN) 68 | _,INCR = rca3(SECS,Z3,O) 69 | SECS = dff3(mux3(RUN,SECS,mux3(RUNNING, Z3, INCR))) 70 | 71 | experiment stopwatch2 -------------------------------------------------------------------------------- /test/memories.out: -------------------------------------------------------------------------------- 1 | Truth table for `dff`: 2 | D { Q -> Q } Q 3 | --{--------}-- 4 | 0 { 0 -> 0 } 0 5 | { 1 -> 0 } 1 6 | 1 { 0 -> 1 } 0 7 | { 1 -> 1 } 1 8 | 9 | Typing for `dff`: 10 | dff() -> @ 11 | 12 | Circuits `not`, `and`, `or`, and `alternator` are defined. 13 | 14 | Truth table for `alternator`: 15 | { ALT -> ALT } ALT 16 | -{------------}---- 17 | { 0 -> 1 } 0 18 | { 1 -> 0 } 1 19 | 20 | Circuits `xor` and `tff` are defined. 21 | 22 | Truth table for `tff`: 23 | T { Q -> Q } Q 24 | --{--------}-- 25 | 0 { 0 -> 0 } 0 26 | { 1 -> 1 } 1 27 | 1 { 0 -> 1 } 0 28 | { 1 -> 0 } 1 29 | 30 | Circuit `count2` is defined. 31 | 32 | Truth table for `count2`: 33 | { Q1 Q2 -> Q1 Q2 } Q2 Q1 34 | -{----------------}------ 35 | { 0 0 -> 1 0 } 0 0 36 | { 0 1 -> 1 1 } 1 0 37 | { 1 0 -> 0 1 } 0 1 38 | { 1 1 -> 0 0 } 1 1 39 | 40 | Circuit `count2tff` is defined. 41 | 42 | Truth table for `count2tff`: 43 | { Q1 Q2 -> Q1 Q2 } [Q2 Q1] 44 | -{----------------}-------- 45 | { 0 0 -> 1 0 } [0 0 ] 46 | { 0 1 -> 1 1 } [1 0 ] 47 | { 1 0 -> 0 1 } [0 1 ] 48 | { 1 1 -> 0 0 } [1 1 ] 49 | 50 | Error: You are redefining the top-level variable dff. 51 | 52 | Circuit `dff` is defined. 53 | 54 | Truth table for `dff`: 55 | D { QD -> QD } QD 56 | --{----------}--- 57 | 0 { 0 -> 0 } 0 58 | { 1 -> 0 } 1 59 | 1 { 0 -> 1 } 0 60 | { 1 -> 1 } 1 61 | 62 | Error: You are redefining the top-level variable zero. 63 | 64 | Circuit `zero` is defined. 65 | 66 | Truth table for `zero`: 67 | { W -> W } Z 68 | -{--------}-- 69 | { 0 -> 0 } 0 70 | { 1 -> 1 } 0 71 | -------------------------------------------------------------------------------- /lib/Language/Syrup/Bwd.hs: -------------------------------------------------------------------------------- 1 | module Language.Syrup.Bwd where 2 | 3 | import Control.Arrow 4 | 5 | import Language.Syrup.HalfZip 6 | 7 | data Bwd x = B0 | Bwd x :< x 8 | deriving (Show, Eq, Functor, Foldable, Traversable) 9 | 10 | infixl 3 :< 11 | 12 | (+<) :: Bwd x -> Bwd x -> Bwd x 13 | xz +< B0 = xz 14 | xz +< (yz :< y) = (xz +< yz) :< y 15 | 16 | infixl 3 +< 17 | 18 | instance Applicative Bwd where 19 | pure x = pure x :< x 20 | (fz :< f) <*> (sz :< s) = (fz <*> sz) :< f s 21 | _ <*> _ = B0 22 | 23 | instance HalfZip Bwd where 24 | halfZip B0 B0 = Just B0 25 | halfZip (xz :< x) (yz :< y) = (:< (x, y)) <$> halfZip xz yz 26 | halfZip _ _ = Nothing 27 | 28 | instance Semigroup (Bwd x) where (<>) = mappend 29 | instance Monoid (Bwd x) where 30 | mempty = B0 31 | mappend = (+<) 32 | 33 | ( Int -> Maybe x 34 | (xz :< x) Bwd String -> String -> String 40 | bwdBr l B0 r = "" 41 | bwdBr l (sz :< s) r = l ++ foldMap (++ ",") sz ++ s ++ r 42 | 43 | (<><) :: Bwd x -> [x] -> Bwd x 44 | xz <>< [] = xz 45 | xz <>< (x : xs) = (xz :< x) <>< xs 46 | 47 | (<>>) :: Bwd x -> [x] -> [x] 48 | B0 <>> xs = xs 49 | (xz :< x) <>> xs = xz <>> (x : xs) 50 | 51 | deBr :: (x -> Bool) -> Bwd x -> Maybe (Int, x) 52 | deBr p B0 = Nothing 53 | deBr p (xz :< x) 54 | | p x = Just (0, x) 55 | | otherwise = ((1 +) *** id) <$> deBr p xz 56 | 57 | bGet :: Eq x => Bwd (x, v) -> x -> Maybe v 58 | bGet B0 _ = Nothing 59 | bGet (xvz :< (x, v)) y 60 | | x == y = Just v 61 | | otherwise = bGet xvz y 62 | 63 | bInx :: (x -> Bool) -> Bwd x -> Maybe Integer 64 | bInx p B0 = Nothing 65 | bInx p (xz :< x) 66 | | p x = Just 0 67 | | otherwise = (1 +) <$> bInx p xz 68 | -------------------------------------------------------------------------------- /test/adc2par-html.syrup: -------------------------------------------------------------------------------- 1 | undefined() -> 2 | 3 | ! -> 4 | !X = Z where 5 | Z = nand(X, X) 6 | 7 | print not 8 | display not 9 | 10 | & -> 11 | X & Y = Z where 12 | A = nand(X, Y) 13 | Z = !A 14 | 15 | print and 16 | display and 17 | 18 | | -> 19 | X | Y = Z where 20 | A, B = !X, !Y 21 | Z = nand(A, B) 22 | 23 | print or 24 | display or 25 | 26 | nor(, ) -> 27 | nor(X,Y) = !(X | Y) 28 | 29 | print nor 30 | display nor 31 | 32 | xor(, ) -> 33 | xor(X, Y) = Z where 34 | A, B = X | Y, X & Y 35 | C = !B 36 | Z = A & C 37 | 38 | print xor 39 | display xor 40 | 41 | hadd(, ) -> , 42 | hadd(X1, Y1) = C2, S1 where 43 | C2 = X1 & Y1 44 | S1 = xor(X1, Y1) 45 | 46 | print hadd 47 | display hadd 48 | 49 | fadd(, , ) -> , 50 | fadd(X1, Y1, C1) = C2, Z1 where 51 | D2, D1 = hadd(X1, Y1) 52 | E2, Z1 = hadd(D1, C1) 53 | C2 = xor(D2, E2) 54 | 55 | print fadd 56 | display fadd 57 | 58 | experiment fadd 59 | 60 | type = [,] 61 | 62 | adc2(,,) -> 63 | , 64 | adc2([X2,X1],[Y2,Y1],C1) = C4,[Z2,Z1] where 65 | C2,Z1 = fadd(X1,Y1,C1) 66 | C4,Z2 = fadd(X2,Y2,C2) 67 | 68 | print adc2 69 | display adc2 70 | 71 | one() -> 72 | one() = !zero() 73 | 74 | print one 75 | display one 76 | 77 | mux(, , ) -> 78 | mux(C, X, Y) = C & X | !C & Y 79 | 80 | print mux 81 | display mux 82 | 83 | adc2par(,,) -> 84 | , 85 | adc2par([X2,X1],[Y2,Y1],C1) = C4,[Z2,Z1] where 86 | C2,Z1 = fadd(X1,Y1,C1) 87 | C40,Z20 = fadd(X2,Y2,zero()) 88 | C41,Z21 = fadd(X2,Y2,one()) 89 | C4=mux(C2,C41,C40) 90 | Z2=mux(C2,Z21,Z20) 91 | 92 | print adc2par 93 | display adc2par -------------------------------------------------------------------------------- /lib/Language/Syrup/Ded.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- Ded: Dead code elimination for Syrup ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | module Language.Syrup.Ded where 8 | 9 | import Control.Monad (guard) 10 | 11 | import Data.Maybe (fromMaybe) 12 | 13 | import Language.Syrup.BigArray 14 | import Language.Syrup.Syn 15 | import Language.Syrup.Utils 16 | 17 | cleanup :: Def' Name ty -> Def' Name ty 18 | cleanup d@Stub{} = d 19 | cleanup d@(Def lhs rhs meqns) = Def lhs rhs meqns' where 20 | meqns' = eqns <$ guard (not (null eqns)) 21 | eqns = filter needed (fromMaybe [] meqns) 22 | needed (ps :=: es) = not (null (intersectSet reached (support ps))) 23 | reached = reachable d 24 | 25 | unused :: Def' Name ty -> Set String 26 | unused Stub{} = emptyArr 27 | unused d@(Def lhs rhs meqns) = 28 | let reached = reachable d in 29 | diffSet (support $ map (\ (ps :=: _) -> ps) (fromMaybe [] meqns)) reached 30 | 31 | 32 | reachable :: Def' Name ty -> Set String 33 | reachable Stub{} = emptyArr 34 | reachable (Def lhs rhs meqns) = collect (support rhs) (fromMaybe [] meqns) 35 | 36 | where 37 | 38 | reached :: Set String -> Eqn' Name ty -> Either (Set String) (Eqn' Name ty) 39 | reached seen eqn@(ps :=: es) = 40 | if null (intersectSet seen $ support ps) 41 | then Right eqn 42 | else Left (support es) 43 | 44 | collect :: Set String -> [Eqn' Name ty] -> Set String 45 | collect seen eqns = case partitionWith (reached seen) eqns of 46 | (seeing, rest) 47 | | null seeing -> seen 48 | | otherwise -> collect (foldl (<>) seen seeing) rest 49 | -------------------------------------------------------------------------------- /lib/Language/Syrup/Fsh.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- Fsh: Fresh monad transformer ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | {-# LANGUAGE FunctionalDependencies #-} 8 | {-# LANGUAGE GeneralisedNewtypeDeriving #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | module Language.Syrup.Fsh where 12 | 13 | import Control.Monad.Except 14 | import Control.Monad.Identity 15 | import Control.Monad.State 16 | import Control.Monad.Writer 17 | 18 | newtype FreshT e m a = FreshT { getFreshT :: StateT e m a } 19 | deriving (Functor, Applicative, Monad) 20 | 21 | type Fresh e = FreshT e Identity 22 | 23 | class MonadFresh e m | m -> e where 24 | fresh :: m e 25 | 26 | runFreshT :: Enum e => FreshT e m a -> m (a, e) 27 | runFreshT f = runStateT (getFreshT f) (toEnum 0) 28 | 29 | execFreshT :: (Functor m, Enum e) => FreshT e m a -> m e 30 | execFreshT = fmap snd . runFreshT 31 | 32 | evalFreshT :: (Functor m, Enum e) => FreshT e m a -> m a 33 | evalFreshT = fmap fst . runFreshT 34 | 35 | runFresh :: Enum e => Fresh e a -> (a, e) 36 | runFresh = runIdentity . runFreshT 37 | 38 | execFresh :: Enum e => Fresh e a -> e 39 | execFresh = runIdentity . execFreshT 40 | 41 | evalFresh :: Enum e => Fresh e a -> a 42 | evalFresh = runIdentity . evalFreshT 43 | 44 | instance MonadTrans (FreshT e) where 45 | lift = FreshT . lift 46 | 47 | instance (Enum e, Monad m) => MonadFresh e (FreshT e m) where 48 | fresh = FreshT $ do 49 | i <- get 50 | put (succ i) 51 | pure i 52 | 53 | instance (MonadFresh e m, Monad m) => MonadFresh e (StateT s m) where 54 | fresh = lift fresh 55 | 56 | instance (MonadFresh e m, Monad m, Monoid s) => MonadFresh e (WriterT s m) where 57 | fresh = lift fresh 58 | 59 | instance (MonadFresh e m, Monad m) => MonadFresh e (ExceptT a m) where 60 | fresh = lift fresh 61 | -------------------------------------------------------------------------------- /test/diagram-source.out: -------------------------------------------------------------------------------- 1 | Displaying `not`: 2 | digraph whitebox { 3 | rankdir = TB; 4 | nodesep = 0.2; 5 | GATE_not_3__INPUTS 6 | [ shape = none 7 | , label = < 8 | 9 | 10 | 11 | 12 |
x
> 13 | ]; 14 | 15 | subgraph cluster_circuit__GATE_not_3 { 16 | style=invis; 17 | subgraph gate_3__0__0 { 18 | style = invis; 19 | GATE_nand_3__0__0 20 | [ shape = none 21 | , label = < 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 |
XY
nand
Z
> 30 | ]; 31 | } 32 | subgraph fanout_3__1 { 33 | style = invis; 34 | COPY_3__1 35 | [ shape = none 36 | , style = filled 37 | , fillcolor = skyblue 38 | , fixedsize = true 39 | , width = 0.14 40 | , height = .1 41 | , label = < 42 | 43 | 44 | 45 | 46 | 47 |
> 48 | ]; 49 | } 50 | } 51 | GATE_not_3__OUTPUTS 52 | [ shape = none 53 | , label = < 54 | 55 | 56 | 57 | 58 |
> 59 | ]; 60 | 61 | COPY_3__1:__VIRTUAL__0:s -> GATE_nand_3__0__0:X:n [label=" ", arrowsize = .5 penwidth= 2]; 62 | COPY_3__1:__VIRTUAL__1:s -> GATE_nand_3__0__0:Y:n [label=" ", arrowsize = .5 penwidth= 2]; 63 | GATE_nand_3__0__0:Z:s -> GATE_not_3__OUTPUTS:__VIRTUAL__2 [label=" ", arrowsize = .5 penwidth= 2]; 64 | GATE_not_3__INPUTS:x -> COPY_3__1:x:n [label=" ", arrowsize = .5 penwidth= 2 , dir = none]; 65 | } 66 | -------------------------------------------------------------------------------- /lib/Language/Syrup/Sub.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- Sub: Type alias Substitution for Syrup ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | module Language.Syrup.Sub where 8 | 9 | import Data.IMaybe (IMaybe(IJust)) 10 | 11 | import Language.Syrup.BigArray 12 | import Language.Syrup.Fdk 13 | import Language.Syrup.Syn 14 | import Language.Syrup.Ty 15 | 16 | class TySubst t where 17 | tySubst :: TyEnv -> t False -> Either TyName (t True) 18 | 19 | instance TySubst TY' where 20 | tySubst rho t = case t of 21 | BIT -> pure BIT 22 | OLD t -> OLD <$> tySubst rho t 23 | CABLE ts -> CABLE <$> mapM (tySubst rho) ts 24 | TYVAR x _ -> case findArr x rho of 25 | Nothing -> Left x 26 | Just v -> pure $ TYVAR x (IJust v) 27 | 28 | instance TySubst DEC' where 29 | tySubst rho (DEC (str, ts) us) = 30 | DEC <$> ((str,) <$> mapM (tySubst rho) ts) 31 | <*> mapM (tySubst rho) us 32 | 33 | subAlias :: TyEnv -> SourceC -> Either TyName (TyEnv, Either TyName Source) 34 | subAlias rho c = case c of 35 | Declaration d -> (rho,) . pure . Declaration <$> tySubst rho d 36 | TypeAlias (n, t) -> do 37 | t' <- tySubst rho t 38 | pure (insertArr (n , t') rho, Left n) 39 | Definition d -> pure (rho, pure (Definition d)) 40 | Experiment e -> pure (rho, pure (Experiment e)) 41 | 42 | inlineAliases :: TyEnv 43 | -> [Either Feedback (SourceC, String)] 44 | -> (TyEnv, [Either Feedback (Source, String)]) 45 | inlineAliases rho [] = (rho, []) 46 | inlineAliases rho (Left s : tl) = (Left s :) <$> inlineAliases rho tl 47 | inlineAliases rho (Right (srcc, s) : tl) = 48 | case subAlias rho srcc of 49 | Right (rho, Left ty) -> (Left (ATypeDefined [ty]) :) <$> inlineAliases rho tl 50 | Right (rho, Right src) -> (Right (src, s) :) <$> inlineAliases rho tl 51 | Left x -> (Left (AnUndefinedType x) :) <$> inlineAliases rho tl 52 | -------------------------------------------------------------------------------- /lib/Language/Syrup/Cst.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- Cst: Costing for Syrup ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | module Language.Syrup.Cst where 8 | 9 | import Control.Monad.State 10 | 11 | import Data.Monoid (Sum(..)) 12 | 13 | import Language.Syrup.BigArray 14 | import Language.Syrup.Syn 15 | import Language.Syrup.Ty 16 | 17 | -- costing in terms of the specified gates (and those that do 18 | -- not have a definition) 19 | type Costing = Arr Name (Sum Int) 20 | 21 | costing :: CoEnv -- Environment containing definitions 22 | -> Set Name -- Express costing in term of these 23 | -> Name -- Definition to cost 24 | -> Costing -- Final costing 25 | costing env supp fn = evalState (loop fn) emptyArr where 26 | 27 | defaultCost :: Name -> State (Arr Name Costing) Costing 28 | defaultCost fn = do 29 | let cost = single (fn, Sum 1) 30 | modify (insertArr (fn, cost)) 31 | pure cost 32 | 33 | loop :: Name -> State (Arr Name Costing) Costing 34 | loop fn = gets (findArr fn) >>= \case 35 | -- If the circuit has already been costed, return that 36 | Just cost -> pure cost 37 | -- If it cannot be found, then we need to cost it 38 | -- if it is part of the support then its cost is 1 of itself 39 | Nothing | fn `inSet` supp -> defaultCost fn 40 | -- Otherwise we break it into its components and cost them recursively 41 | Nothing | otherwise -> 42 | -- look its definition up 43 | case defn =<< findArr fn env of 44 | Just (d@Def{}) -> do 45 | costs <- flip travArr (allGates d) $ \ (comp, number) -> 46 | do cost <- loop comp 47 | pure ((number *) <$> cost) 48 | let cost = foldMapArr snd costs 49 | modify (insertArr (fn, cost)) 50 | pure cost 51 | -- if it does not have a definition, its cost is 1 of itself 52 | _ -> defaultCost fn 53 | -------------------------------------------------------------------------------- /lib/Language/Syrup/Opt.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- Opt: Options for Syrup ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | module Language.Syrup.Opt where 8 | 9 | import Text.Read (readMaybe) 10 | 11 | data GraphFormat 12 | = RenderedSVG 13 | | SourceDot 14 | 15 | data OutputFormat 16 | = TextOutput 17 | | HtmlOutput 18 | 19 | data Options = Options 20 | { quiet :: Bool 21 | , filepath :: Maybe FilePath 22 | , graphFormat :: GraphFormat 23 | , outputFormat :: OutputFormat 24 | , experimentLimit :: Maybe Int 25 | } 26 | 27 | defaultOptions :: Options 28 | defaultOptions = Options 29 | { quiet = False 30 | , filepath = Nothing 31 | , graphFormat = RenderedSVG 32 | , outputFormat = TextOutput 33 | , experimentLimit = Nothing 34 | } 35 | 36 | defaultMarxOptions :: Options 37 | defaultMarxOptions = Options 38 | { quiet = False 39 | , filepath = Nothing 40 | , graphFormat = SourceDot 41 | , outputFormat = HtmlOutput 42 | , experimentLimit = Just 10 43 | } 44 | 45 | parseOptions :: Options -> [String] -> Either String Options 46 | parseOptions acc [] = pure acc 47 | parseOptions acc ("-q" : opts) = parseOptions (acc { quiet = True }) opts 48 | parseOptions acc ("-f" : fp : opts) = parseOptions (acc { filepath = Just fp }) opts 49 | parseOptions acc ("--source-dot" : opts) = parseOptions (acc { graphFormat = SourceDot }) opts 50 | parseOptions acc ("--rendered-svg" : opts) = parseOptions (acc { graphFormat = RenderedSVG }) opts 51 | parseOptions acc ("--html" : opts) = parseOptions (acc { outputFormat = HtmlOutput }) opts 52 | parseOptions acc ("--text" : opts) = parseOptions (acc { outputFormat = TextOutput }) opts 53 | parseOptions acc ("--experiment-limit" : arg : opts) = case readMaybe arg of 54 | Just k | k >= 0 -> parseOptions (acc { experimentLimit = Just k }) opts 55 | _ -> Left ("Invalid experiment limit: " ++ show arg ++ ".") 56 | parseOptions acc (opt : opts) = Left ("Unrecognised option " ++ show opt ++ ".") 57 | -------------------------------------------------------------------------------- /test/experiment.out: -------------------------------------------------------------------------------- 1 | Circuits `not`, `and`, `or`, `xor`, and `hadd` are defined. 2 | 3 | Truth table for `hadd`: 4 | X Y | 5 | ----|---- 6 | 0 0 | 0 0 7 | 0 1 | 0 1 8 | 1 0 | 0 1 9 | 1 1 | 1 0 10 | 11 | Circuit `fadd` is defined. 12 | 13 | Truth table for `fadd`: 14 | X Y CI | CO Z 15 | -------|----- 16 | 0 0 0 | 0 0 17 | 0 0 1 | 0 1 18 | 0 1 0 | 0 1 19 | 0 1 1 | 1 0 20 | 1 0 0 | 0 1 21 | 1 0 1 | 1 0 22 | 1 1 0 | 1 0 23 | 1 1 1 | 1 1 24 | 25 | Type `` is defined. 26 | 27 | Circuit `adc2` is defined. 28 | 29 | Truth table for `adc2`: 30 | [X1 X0] [Y1 Y0] CI | CO [Z1 Z0] 31 | -------------------|----------- 32 | [0 0 ] [0 0 ] 0 | 0 [0 0 ] 33 | [0 0 ] [0 0 ] 1 | 0 [0 1 ] 34 | [0 0 ] [0 1 ] 0 | 0 [0 1 ] 35 | [0 0 ] [0 1 ] 1 | 0 [1 0 ] 36 | [0 0 ] [1 0 ] 0 | 0 [1 0 ] 37 | [0 0 ] [1 0 ] 1 | 0 [1 1 ] 38 | [0 0 ] [1 1 ] 0 | 0 [1 1 ] 39 | [0 0 ] [1 1 ] 1 | 1 [0 0 ] 40 | [0 1 ] [0 0 ] 0 | 0 [0 1 ] 41 | [0 1 ] [0 0 ] 1 | 0 [1 0 ] 42 | [0 1 ] [0 1 ] 0 | 0 [1 0 ] 43 | [0 1 ] [0 1 ] 1 | 0 [1 1 ] 44 | [0 1 ] [1 0 ] 0 | 0 [1 1 ] 45 | [0 1 ] [1 0 ] 1 | 1 [0 0 ] 46 | [0 1 ] [1 1 ] 0 | 1 [0 0 ] 47 | [0 1 ] [1 1 ] 1 | 1 [0 1 ] 48 | [1 0 ] [0 0 ] 0 | 0 [1 0 ] 49 | [1 0 ] [0 0 ] 1 | 0 [1 1 ] 50 | [1 0 ] [0 1 ] 0 | 0 [1 1 ] 51 | [1 0 ] [0 1 ] 1 | 1 [0 0 ] 52 | [1 0 ] [1 0 ] 0 | 1 [0 0 ] 53 | [1 0 ] [1 0 ] 1 | 1 [0 1 ] 54 | [1 0 ] [1 1 ] 0 | 1 [0 1 ] 55 | [1 0 ] [1 1 ] 1 | 1 [1 0 ] 56 | [1 1 ] [0 0 ] 0 | 0 [1 1 ] 57 | [1 1 ] [0 0 ] 1 | 1 [0 0 ] 58 | [1 1 ] [0 1 ] 0 | 1 [0 0 ] 59 | [1 1 ] [0 1 ] 1 | 1 [0 1 ] 60 | [1 1 ] [1 0 ] 0 | 1 [0 1 ] 61 | [1 1 ] [1 0 ] 1 | 1 [1 0 ] 62 | [1 1 ] [1 1 ] 0 | 1 [1 0 ] 63 | [1 1 ] [1 1 ] 1 | 1 [1 1 ] 64 | 65 | Simulation for `adc2`: 66 | 0 {} [10][01]1 -> 1[00] 67 | 1 {} [11][10]0 -> 1[01] 68 | 2 {} 69 | 70 | Circuits `xor1` and `xor2` are defined. 71 | 72 | Bisimulation between `xor1`, `xor2`: 73 | `xor1` behaves like `xor2` 74 | `{}` ~ `{}` 75 | 76 | Bisimulation between `xor`, `or`: 77 | `xor` has a behaviour that `or` does not match 78 | `xor(11) = 0` but `or(11) = 1` 79 | 80 | Typing for `adc2`: 81 | adc2(, , ) -> , 82 | 83 | Printing `adc2`: 84 | adc2([, ], [, ], ) -> , [, ] 85 | adc2([X1, X0], [Y1, Y0], CI) = CO, [Z1, Z0] where 86 | C1, Z0 = fadd(X0, Y0, CI) 87 | CO, Z1 = fadd(X1, Y1, C1) 88 | -------------------------------------------------------------------------------- /lib/Language/Syrup/Utils.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- Utils: Syrup Utility functions ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | {-# LANGUAGE OverloadedStrings #-} 8 | 9 | module Language.Syrup.Utils where 10 | 11 | import Control.Arrow ((***)) 12 | 13 | import qualified Data.Bifunctor as Bi 14 | import Data.Foldable (fold) 15 | import Data.Maybe (mapMaybe) 16 | import Data.String (IsString) 17 | 18 | isNothing :: Maybe a -> Bool 19 | isNothing = \case 20 | Nothing -> True 21 | Just{} -> False 22 | 23 | spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) 24 | spanMaybe p = go where 25 | 26 | go [] = ([], []) 27 | go aas@(a : as) 28 | | Just b <- p a = ((b :) *** id) (go as) 29 | | otherwise = ([], aas) 30 | 31 | isLeft :: Either a b -> Maybe a 32 | isLeft = \case 33 | Left a -> Just a 34 | _ -> Nothing 35 | 36 | isRight :: Either a b -> Maybe b 37 | isRight = \case 38 | Right b -> Just b 39 | _ -> Nothing 40 | 41 | allLeftsOrRight :: [Either a b] -> Either [a] [b] 42 | allLeftsOrRight [] = Left [] 43 | allLeftsOrRight (Left a : rs) = Bi.first (a :) (allLeftsOrRight rs) 44 | allLeftsOrRight (Right b : rs) = Right (b : mapMaybe isRight rs) 45 | 46 | padRight :: Int -> String -> String 47 | padRight n xs 48 | | n <= 0 = xs 49 | | otherwise = xs ++ replicate n ' ' 50 | 51 | unzipWith :: (a -> (b, c)) -> [a] -> ([b], [c]) 52 | unzipWith f [] = ([], []) 53 | unzipWith f (a:as) = 54 | let (b , c) = f a 55 | (bs, cs) = unzipWith f as 56 | in (b:bs, c:cs) 57 | 58 | 59 | partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) 60 | partitionWith p [] = ([], []) 61 | partitionWith p (x : xs) 62 | = either (Bi.first . (:)) (Bi.second . (:)) (p x) 63 | $ partitionWith p xs 64 | 65 | plural :: Monoid s => [a] -> s -> s -> s 66 | plural (_ : _ : _) str s = str <> s 67 | plural _ str _ = str 68 | 69 | oxfordList :: (Monoid a, IsString a) => [a] -> a 70 | oxfordList [] = "" 71 | oxfordList [x] = x 72 | oxfordList [x,y] = fold [x, " and ", y] 73 | oxfordList xs = fold (go xs) where 74 | 75 | go = \case 76 | [] -> [] 77 | [x] -> [x] 78 | [x,y] -> [x, ", and ", y] 79 | (x:xs) -> x : ", " : go xs 80 | 81 | be :: IsString d => [a] -> d 82 | be [_] = "is" 83 | be _ = "are" 84 | 85 | ($$) :: Monoid m => (m -> a) -> [m] -> a 86 | f $$ x = f (fold x) 87 | -------------------------------------------------------------------------------- /test/samples.syrup: -------------------------------------------------------------------------------- 1 | ! -> 2 | !X = Z where 3 | Z = nand(X, X) 4 | 5 | & -> 6 | X & Y = Z where 7 | A = nand(X, Y) 8 | Z = !A 9 | 10 | | -> 11 | X | Y = Z where 12 | A, B = !X, !Y 13 | Z = nand(A, B) 14 | 15 | nor(, ) -> 16 | nor(X,Y) = !(X | Y) 17 | 18 | xor(, ) -> 19 | xor(X, Y) = Z where 20 | A, B = X | Y, X & Y 21 | C = !B 22 | Z = A & C 23 | 24 | xor1(, ) -> 25 | xor1(X,Y) = !X & Y | X & !Y 26 | 27 | xor2(, ) -> 28 | xor2(X,Y) = (X | Y) & !(X & Y) 29 | 30 | hadd(, ) -> , 31 | hadd(X1, Y1) = C2, S1 where 32 | C2 = X1 & Y1 33 | S1 = xor(X1, Y1) 34 | 35 | fadd(, , ) -> , 36 | fadd(X1, Y1, C1) = C2, Z1 where 37 | D2, D1 = hadd(X1, Y1) 38 | E2, Z1 = hadd(D1, C1) 39 | _, C2 = hadd(D2, E2) 40 | 41 | jkff(, ) -> @ 42 | jkff(J, K) = Q where 43 | Q = dff(D) 44 | D = J & !Q | !K & Q 45 | 46 | adc2([,],[,],) -> 47 | ,[,] 48 | adc2([X2,X1],[Y2,Y1],C1) = C4,[Z2,Z1] where 49 | C2,Z1 = fadd(X1,Y1,C1) 50 | C4,Z2 = fadd(X2,Y2,C2) 51 | 52 | type = [,] 53 | 54 | adcTwo(,,) -> , 55 | adcTwo(X,Y,C) = adc2(X,Y,C) 56 | 57 | 58 | ndnff() -> @ 59 | ndnff(D) = !Q where Q = dff(!D) 60 | 61 | tff() -> @ 62 | tff(T) = Q where Q = dff(xor(T,Q)) 63 | 64 | jkt() -> @ 65 | jkt(T) = jkff(T,T) 66 | 67 | one() -> @ 68 | one() = !zero() 69 | 70 | guff() -> @ 71 | guff(T) = xor(Q2,Q1) where 72 | Q2 = tff(!T | Q1) 73 | Q1 = tff(one()) 74 | 75 | tff2() -> @ 76 | tff2(T) = xor(Q2,Q1) where 77 | Q2 = tff(!T | !xor(Q2,Q1)) 78 | Q1 = tff(!T | xor(Q2,Q1)) 79 | 80 | experiment not 81 | experiment and 82 | experiment or 83 | experiment xor 84 | experiment hadd 85 | experiment hadd(00;01;10;11) 86 | experiment fadd 87 | experiment adc2 88 | experiment jkff 89 | experiment jkff{0}(10;00;01;00;11;00;11;00;10;01;00;10;00) 90 | experiment dff = ndnff 91 | experiment dff = tff 92 | experiment dff{0}(1;0;0) 93 | experiment tff{0}(1;0;0) 94 | experiment tff = jkt 95 | experiment nand = nor 96 | experiment nand = nand 97 | experiment xor1 = xor2 98 | experiment xor = or 99 | experiment one 100 | experiment tff2 101 | experiment tff = guff 102 | experiment tff{0}(0;1;0) 103 | experiment guff{00}(0;1;0) 104 | experiment tff = tff2 105 | 106 | 107 | type = [,] 108 | 109 | adc4(,,) -> , 110 | adc4([X32,X10],[Y32,Y10],CI) = CO,[Z32,Z10] where 111 | C2,Z10 = adc2(X10,Y10,CI) 112 | CO,Z32 = adc2(X32,Y32,C2) 113 | 114 | experiment adc4 115 | 116 | --display fadd 117 | --display [hadd] fadd 118 | --display adc2 119 | --display adc4 -------------------------------------------------------------------------------- /test/unittest-html.out: -------------------------------------------------------------------------------- 1 | 43 |
When unit testing nand(00) = 1: 44 |
45 |
Success!
46 |
47 |
When unit testing nand(11) = 0: 48 |
49 |
Success!
50 |
51 |
When unit testing dff{0}(1) = {1}0: 52 |
53 |
Success!
54 |
55 |
When unit testing nand{0}(00) = 1: 56 |
57 |
Memory for nand has type {}. 58 |
59 | That can't store {0}.
60 |
61 |
When unit testing nand() = 1: 62 |
63 |
Inputs for nand are typed (<Bit>, <Bit>). 64 |
65 | That can't accept ().
66 |
67 |
When unit testing nand(00) = {1}0: 68 |
69 |
Memory for nand has type {}. 70 |
71 | That can't store {1}.
72 |
73 |
When unit testing nand(00) = 00: 74 |
75 |
Outputs for nand are typed <Bit>. 76 |
77 | That can't accept 0, 0.
78 |
79 |
Circuit alternator is defined.
80 |
81 |
When unit testing alternator{0}() = {1}0: 82 |
83 |
Success!
-------------------------------------------------------------------------------- /lib/Language/Syrup/Syn/Base.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- Syn: Syntax for Syrup (basic types) ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | {-# LANGUAGE DefaultSignatures #-} 8 | 9 | module Language.Syrup.Syn.Base where 10 | 11 | import Control.Monad (ap, guard) 12 | 13 | import Data.Forget (Forget, forget) 14 | import Data.String (IsString(..)) 15 | import Data.Void (Void) 16 | 17 | import Language.Syrup.BigArray (Set) 18 | 19 | ------------------------------------------------------------------------------ 20 | -- Names 21 | 22 | newtype TyName = TyName { getTyName :: String } deriving (Show, Eq, Ord) 23 | 24 | newtype Name = Name { getName :: String } deriving (Show, Eq, Ord) 25 | instance IsString Name where 26 | fromString = Name 27 | 28 | 29 | type Names = Set Name 30 | 31 | 32 | ------------------------------------------------------------------------------ 33 | -- Values 34 | 35 | data Va 36 | = V0 | V1 | VQ | VC [Va] 37 | deriving (Eq, Ord) 38 | 39 | instance Show Va where 40 | show V0 = "0" 41 | show V1 = "1" 42 | show VQ = "?" 43 | show (VC vs) = "[" ++ foldMap show vs ++ "]" 44 | 45 | ------------------------------------------------------------------------------ 46 | -- Circuit configuration 47 | 48 | data CircuitConfig = CircuitConfig 49 | { memoryConfig :: [Va] 50 | , valuesConfig :: [Va] 51 | } deriving Show 52 | 53 | circuitConfig :: Bool -> CircuitConfig -> String 54 | circuitConfig isLHS (CircuitConfig mems vals) = concat $ 55 | (concat [ "{", foldMap show mems, "}" ] <$ guard (not $ null mems)) 56 | ++ ("(" <$ guard isLHS) 57 | ++ map show vals 58 | ++ (")" <$ guard isLHS) 59 | 60 | ------------------------------------------------------------------------------ 61 | -- Types 62 | 63 | data Ty t x 64 | = Meta x 65 | | TVar TyName (Ty t Void) -- type aliases are closed 66 | | Bit t 67 | | Cable [Ty t x] 68 | deriving (Functor, Foldable, Traversable) 69 | 70 | instance (Eq t, Eq x) => Eq (Ty t x) where 71 | Meta x == Meta y = x == y 72 | TVar nm t == TVar nm' t' = nm == nm' || t == t' 73 | TVar nm t == t' = forget t == t' 74 | t == TVar nm t' = t == forget t' 75 | Bit t == Bit t' = t == t' 76 | Cable ts == Cable ts' = ts == ts' 77 | _ == _ = False 78 | 79 | instance Forget b c => Forget (Ty a b) (Ty a c) where 80 | 81 | isBit :: Ty t x -> Maybe t 82 | isBit (Bit a) = Just a 83 | isBit _ = Nothing 84 | 85 | -- boring instances 86 | 87 | instance Monad (Ty t) where 88 | return = Meta 89 | Meta x >>= k = k x 90 | TVar s t >>= _ = TVar s t 91 | Bit t >>= _ = Bit t 92 | Cable ts >>= k = Cable (fmap (>>= k) ts) 93 | 94 | instance Applicative (Ty t) where 95 | pure = return 96 | (<*>) = ap 97 | 98 | 99 | -- using this rather than () because we want a 100 | -- pretty Unit = "" instance rather than the 101 | -- pretty () = "()" one 102 | data Unit = Unit deriving (Eq) 103 | 104 | ------------------------------------------------------------------------------ 105 | -- Phases 106 | 107 | data Ti = T0 | T1 deriving (Show, Eq) 108 | -------------------------------------------------------------------------------- /test/diagram-html.out: -------------------------------------------------------------------------------- 1 | 43 |
Circuit not is defined.
44 |
45 |
Displaying not: 46 |
47 | 56 |
57 |
-------------------------------------------------------------------------------- /lib/Language/Syrup/Va.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- Va: values for Syrup ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | module Language.Syrup.Va where 8 | 9 | import Data.List 10 | 11 | import Language.Syrup.BigArray 12 | import Language.Syrup.Syn 13 | 14 | 15 | ------------------------------------------------------------------------------ 16 | -- values 17 | ------------------------------------------------------------------------------ 18 | 19 | {- had to move to Syn.hs 20 | data Va 21 | = V0 | V1 | VQ | VC [Va] 22 | deriving Eq 23 | 24 | instance Show Va where 25 | show V0 = "0" 26 | show V1 = "1" 27 | show VQ = "?" 28 | show (VC vs) = "[" ++ foldMap show vs ++ "]" 29 | -} 30 | 31 | 32 | ------------------------------------------------------------------------------ 33 | -- plans 34 | ------------------------------------------------------------------------------ 35 | 36 | data Plan = Plan [Pat] [Task] [Pat] 37 | 38 | plan :: Plan -> [Va] -> [Va] 39 | plan (Plan ips tas ops) ivs = fmap (pval g') ops where 40 | g = match ips ivs emptyArr 41 | g' = foldl task g tas 42 | 43 | 44 | ------------------------------------------------------------------------------ 45 | -- tasks 46 | ------------------------------------------------------------------------------ 47 | 48 | data Task = [Pat] :<- ([Va] -> [Va], [Pat]) 49 | 50 | {- 51 | instance Show Task where 52 | show (qs :<- (_, ps)) = show qs ++ " <- " ++ show ps 53 | -} 54 | task :: Env -> Task -> Env 55 | task g (qs :<- (f, ps)) = match qs (f (fmap (pval g) ps)) g 56 | 57 | 58 | ------------------------------------------------------------------------------ 59 | -- value environments 60 | ------------------------------------------------------------------------------ 61 | 62 | type Env = Arr String Va 63 | 64 | 65 | ------------------------------------------------------------------------------ 66 | -- matching 67 | ------------------------------------------------------------------------------ 68 | 69 | match :: [Pat] -> [Va] -> Env -> Env 70 | match (PVar () x : ps) (v : vs) = 71 | match ps vs . insertArr (x, v) 72 | match (PCab () ps : qs) (VC vs : us) = 73 | match qs us . match ps vs 74 | match _ _ = id 75 | 76 | 77 | ------------------------------------------------------------------------------ 78 | -- pval 79 | ------------------------------------------------------------------------------ 80 | 81 | pval :: Env -> Pat -> Va 82 | pval g (PVar () x) = case findArr x g of 83 | Nothing -> error "this isn't supposed to happen, you know" 84 | Just v -> v 85 | pval g (PCab () ps) = VC (fmap (pval g) ps) 86 | 87 | 88 | ------------------------------------------------------------------------------ 89 | -- glom 90 | ------------------------------------------------------------------------------ 91 | 92 | glom :: ([Task], Set String) -- tasks in order, their support 93 | -> [Task] -- tasks unscheduled 94 | -> ( ([Task], Set String) -- tasks now scheduled 95 | , [Task] -- tasks now unscheduled 96 | ) 97 | glom (tao, known) tas 98 | | null ta1 = ((tao, known), tas) 99 | | otherwise = glom (tao ++ ta1, known <> known') tar 100 | where 101 | (ta1, tar) = partition 102 | (\ (_ :<- (_, ps)) -> foldMap support ps `subSet` known) 103 | tas 104 | known' = foldMap (\ (qs :<- _) -> foldMap support qs) ta1 105 | -------------------------------------------------------------------------------- /test/stopwatch.out: -------------------------------------------------------------------------------- 1 | Circuits `not`, `and`, `or`, `mux`, `xor`, `hadd`, and `fadd` are defined. 2 | 3 | Type `` is defined. 4 | 5 | Circuits `rca3`, `dff3`, `mux3`, and `stopwatch` are defined. 6 | 7 | Truth table for `stopwatch`: 8 | RUN { RUNNING -> RUNNING } SECS 9 | ----{--------------------------------}------ 10 | 0 { 0 0 0 0 -> 0 0 0 1 } [000] 11 | { 0 0 0 1 -> 0 0 1 0 } [001] 12 | { 0 0 1 0 -> 0 0 1 1 } [010] 13 | { 0 0 1 1 -> 0 1 0 0 } [011] 14 | { 0 1 0 0 -> 0 1 0 1 } [100] 15 | { 0 1 0 1 -> 0 1 1 0 } [101] 16 | { 0 1 1 0 -> 0 1 1 1 } [110] 17 | { 0 1 1 1 -> 0 0 0 0 } [111] 18 | { 1 0 0 0 -> 0 0 0 0 } [000] 19 | { 1 0 0 1 -> 0 0 0 0 } [001] 20 | { 1 0 1 0 -> 0 0 0 0 } [010] 21 | { 1 0 1 1 -> 0 0 0 0 } [011] 22 | { 1 1 0 0 -> 0 0 0 0 } [100] 23 | { 1 1 0 1 -> 0 0 0 0 } [101] 24 | { 1 1 1 0 -> 0 0 0 0 } [110] 25 | { 1 1 1 1 -> 0 0 0 0 } [111] 26 | 1 { 0 0 0 0 -> 1 0 0 0 } [000] 27 | { 0 0 0 1 -> 1 0 0 0 } [001] 28 | { 0 0 1 0 -> 1 0 0 0 } [010] 29 | { 0 0 1 1 -> 1 0 0 0 } [011] 30 | { 0 1 0 0 -> 1 0 0 0 } [100] 31 | { 0 1 0 1 -> 1 0 0 0 } [101] 32 | { 0 1 1 0 -> 1 0 0 0 } [110] 33 | { 0 1 1 1 -> 1 0 0 0 } [111] 34 | { 1 0 0 0 -> 1 0 0 1 } [000] 35 | { 1 0 0 1 -> 1 0 1 0 } [001] 36 | { 1 0 1 0 -> 1 0 1 1 } [010] 37 | { 1 0 1 1 -> 1 1 0 0 } [011] 38 | { 1 1 0 0 -> 1 1 0 1 } [100] 39 | { 1 1 0 1 -> 1 1 1 0 } [101] 40 | { 1 1 1 0 -> 1 1 1 1 } [110] 41 | { 1 1 1 1 -> 1 0 0 0 } [111] 42 | 43 | Circuit `stopwatch2` is defined. 44 | 45 | Truth table for `stopwatch2`: 46 | RUN { RUNNING -> RUNNING } SECS 47 | ----{--------------------------------}------ 48 | 0 { 0 0 0 0 -> 0 0 0 0 } [000] 49 | { 0 0 0 1 -> 0 0 0 1 } [001] 50 | { 0 0 1 0 -> 0 0 1 0 } [010] 51 | { 0 0 1 1 -> 0 0 1 1 } [011] 52 | { 0 1 0 0 -> 0 1 0 0 } [100] 53 | { 0 1 0 1 -> 0 1 0 1 } [101] 54 | { 0 1 1 0 -> 0 1 1 0 } [110] 55 | { 0 1 1 1 -> 0 1 1 1 } [111] 56 | { 1 0 0 0 -> 0 0 0 0 } [000] 57 | { 1 0 0 1 -> 0 0 0 1 } [001] 58 | { 1 0 1 0 -> 0 0 1 0 } [010] 59 | { 1 0 1 1 -> 0 0 1 1 } [011] 60 | { 1 1 0 0 -> 0 1 0 0 } [100] 61 | { 1 1 0 1 -> 0 1 0 1 } [101] 62 | { 1 1 1 0 -> 0 1 1 0 } [110] 63 | { 1 1 1 1 -> 0 1 1 1 } [111] 64 | 1 { 0 0 0 0 -> 1 0 0 0 } [000] 65 | { 0 0 0 1 -> 1 0 0 0 } [001] 66 | { 0 0 1 0 -> 1 0 0 0 } [010] 67 | { 0 0 1 1 -> 1 0 0 0 } [011] 68 | { 0 1 0 0 -> 1 0 0 0 } [100] 69 | { 0 1 0 1 -> 1 0 0 0 } [101] 70 | { 0 1 1 0 -> 1 0 0 0 } [110] 71 | { 0 1 1 1 -> 1 0 0 0 } [111] 72 | { 1 0 0 0 -> 1 0 0 1 } [000] 73 | { 1 0 0 1 -> 1 0 1 0 } [001] 74 | { 1 0 1 0 -> 1 0 1 1 } [010] 75 | { 1 0 1 1 -> 1 1 0 0 } [011] 76 | { 1 1 0 0 -> 1 1 0 1 } [100] 77 | { 1 1 0 1 -> 1 1 1 0 } [101] 78 | { 1 1 1 0 -> 1 1 1 1 } [110] 79 | { 1 1 1 1 -> 1 0 0 0 } [111] 80 | -------------------------------------------------------------------------------- /lib/Language/Syrup/Gph.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- Gph: Representation of graphs ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE RecordWildCards #-} 9 | 10 | module Language.Syrup.Gph where 11 | 12 | import Language.Syrup.BigArray 13 | 14 | data Shape = Rectangle 15 | deriving (Eq, Show) 16 | 17 | data Vertex 18 | = Visible String (Maybe Shape) -- label 19 | | Invisible Bool -- splitting? 20 | deriving (Eq) 21 | 22 | instance Semigroup Vertex where 23 | a <> b 24 | | a == b = a 25 | | otherwise = error "This should never happen" 26 | 27 | data Edge = Edge Int Bool -- directed? 28 | deriving (Eq) 29 | 30 | instance Semigroup Edge where 31 | a <> b 32 | | a == b = a 33 | | otherwise = error "This should never happen" 34 | 35 | data Graph' v e = Graph 36 | { vertices :: Arr String v -- named vertices 37 | , edges :: Arr String (Arr String e) -- source -> targets 38 | } 39 | 40 | type Graph = Graph' Vertex Edge 41 | 42 | instance (Semigroup v, Semigroup e) => Semigroup (Graph' v e) where 43 | Graph vs es <> Graph ws fs = Graph (vs <> ws) (es <> fs) 44 | 45 | instance (Semigroup v, Semigroup e) => Monoid (Graph' v e) where 46 | mempty = Graph emptyArr emptyArr 47 | 48 | detectSplit :: Graph -> Graph 49 | detectSplit (Graph vs es) = Graph vs' es where 50 | 51 | vs' = flip foldMapArr vs $ \ v@(str, vertex) -> 52 | case vertex of 53 | Visible{} -> single v 54 | Invisible{} -> case findArr str es of 55 | Nothing -> single v 56 | Just ts | sizeArr ts > 1 -> single (str, Invisible True) 57 | | otherwise -> single v 58 | 59 | shrinkInvisible :: Graph -> Graph 60 | shrinkInvisible g@(Graph vs es) = loop g es where 61 | 62 | loop g@(Graph vs es) queue = case popArr queue of 63 | Nothing -> g 64 | Just ((src, ts), queue) -> 65 | let (vs', es') = case foldMapArr pure ts of 66 | [(t, Edge size False)] -> case (findArr t vs, findArr t es) of 67 | (Just (Invisible False), Just next) -> ( deleteArr t vs 68 | , insertArr (src, next) 69 | $ deleteArr src 70 | $ deleteArr t es) 71 | _ -> (vs, es) 72 | _ -> (vs, es) 73 | in loop (Graph vs' es') queue 74 | 75 | fromShape :: Maybe Shape -> String 76 | fromShape = \case 77 | Nothing -> "none" 78 | Just Rectangle -> "rectangle" 79 | 80 | fromGraph :: Graph -> ([String], [String]) 81 | fromGraph Graph{..} = 82 | ( -- declare vertices first 83 | flip foldMapArr vertices $ \ (nm, v) -> pure $ case v of 84 | Visible lb sh -> nm ++ " [shape = " ++ fromShape sh ++ ", label =\"" ++ lb ++ "\"];" 85 | Invisible sp -> nm ++ " [shape = point" ++ if sp then "];" else ", height = 0];" 86 | 87 | , -- then add edges 88 | flip foldMapArr edges $ \ (src, es) -> 89 | flip foldMapArr es $ \ (tgt, Edge size dir) -> 90 | pure $ concat [ src 91 | , " -> " 92 | , tgt 93 | , " [label=", show " ", ", arrowsize = .5" 94 | , " penwidth= ", show (2 * size) 95 | , if dir then "];" else " , dir = none];" 96 | ] 97 | ) 98 | -------------------------------------------------------------------------------- /lib/Language/Syrup/Lnt.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- Lnt: Linting Syrup ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | {-# LANGUAGE OverloadedStrings #-} 8 | 9 | module Language.Syrup.Lnt where 10 | 11 | import Data.Foldable (fold) 12 | 13 | import Language.Syrup.BigArray 14 | import Language.Syrup.Ded 15 | import Language.Syrup.Doc 16 | import Language.Syrup.Fdk 17 | import Language.Syrup.Pretty () 18 | import Language.Syrup.Syn 19 | 20 | import Language.Syrup.Utils (be, plural) 21 | 22 | class Lint t where 23 | linters :: [t -> [Feedback]] 24 | linters = [] 25 | 26 | lint :: Lint t => t -> [Feedback] 27 | lint t = foldMap ($ t) linters 28 | 29 | instance ty ~ () => Lint (Def' Name ty) where 30 | linters = [ emptyWhere 31 | , deadcode 32 | , needlessSplits 33 | ] where 34 | 35 | emptyWhere = \case 36 | Def (fun, _) _ (Just []) -> pure $ ALint $ foldMap pretty 37 | [ fold [ "Empty where clause in the definition of ", pretty fun, "." ] 38 | , "Did you forget to indent the block of local definitions using spaces?" 39 | ] 40 | _ -> [] 41 | 42 | needlessSplits d = do 43 | let ps = abstractableCables d 44 | if null ps then [] else pure $ ALint $ fold 45 | [ pretty $ fold 46 | [ "the ", plural ps "cable" "s", " " 47 | , csep (pretty . AList <$> ps) 48 | , " ", be ps 49 | , " taken apart only to be reconstructed or unused." 50 | ] 51 | , aLine "Did you consider giving each cable a name without breaking it up?" 52 | ] 53 | 54 | deadcode d = case filter (/= "_") $ foldMapSet pure (unused d) of 55 | [] -> [] 56 | ns -> pure $ ALint $ aLine $ fold 57 | [ "the ", plural ns "wire" "s", " " 58 | , punctuate ", " (highlight AVariable . pretty <$> ns) 59 | , " ", be ns 60 | , " defined but never used." 61 | ] 62 | 63 | 64 | instance Lint (Source' a b) where 65 | linters = [deflint] where 66 | 67 | deflint = \case 68 | Definition d -> lint d 69 | _ -> [] 70 | 71 | linter :: Lint t 72 | => [Either Feedback (t, String)] 73 | -> [Either Feedback (t, String)] 74 | linter xs = xs >>= \case 75 | err@Left{} -> [err] 76 | src@(Right (t, _)) -> map Left (lint t) ++ [src] 77 | 78 | 79 | 80 | ------------------------------------------------------------------------------ 81 | -- Needlessly split cables 82 | 83 | abstractThisCable :: [Pat] -> Exp -> Bool 84 | abstractThisCable ps e = isEmptyArr (foldMap support ps `intersectSet` go e) where 85 | 86 | cable = Cab () (map patToExp ps) 87 | 88 | go :: Exp -> Set String 89 | go e | e == cable = mempty 90 | | otherwise = case e of 91 | Var _ x -> singleton x 92 | Hol _ x -> mempty 93 | App _ _ es -> foldMap go es 94 | Cab _ es -> foldMap go es 95 | 96 | abstractAnyCable :: Pat -> [Exp] -> [[Pat]] 97 | abstractAnyCable p es = case p of 98 | PVar{} -> [] 99 | PCab _ ps -> 100 | if all (abstractThisCable ps) es 101 | then [ps] 102 | else foldMap (`abstractAnyCable` es) ps 103 | 104 | abstractableCables :: Def -> [[Pat]] 105 | abstractableCables Stub{} = [] 106 | abstractableCables (Def (_, lhs) rhs meqs) = 107 | let (ps, es) = (lhs, rhs) <> foldMap (foldMap (\ (ps :=: es) -> (ps, es))) meqs in 108 | foldMap (`abstractAnyCable` es) ps 109 | -------------------------------------------------------------------------------- /lib/Language/Syrup/Fdk/Base.hs: -------------------------------------------------------------------------------- 1 | module Language.Syrup.Fdk.Base where 2 | 3 | import Data.Void (Void) 4 | 5 | import Language.Syrup.Syn.Base 6 | import Language.Syrup.Doc 7 | 8 | ------------------------------------------------------------------------------ 9 | -- Feedback classes 10 | 11 | class Categorise t where 12 | categorise :: t -> FeedbackStatus 13 | 14 | ------------------------------------------------------------------------------ 15 | -- Scope errors 16 | 17 | data ScopeLevel = Local | Global 18 | deriving (Eq) 19 | 20 | levelMsg :: ScopeLevel -> String 21 | levelMsg = \case 22 | Local -> "local" 23 | Global -> "top-level" 24 | 25 | data ScopeError 26 | = OutOfScope ScopeLevel Name Names 27 | -- TODO?: replace with (l :: ScopeLevel) (VarType l) (Set (VarType l)) 28 | -- name that cannot be resolved & suggestions 29 | | Shadowing ScopeLevel Names 30 | -- TODO?: replace with (l :: ScopeLevel) (Set (VarType l)) 31 | -- shadowing an existing variable 32 | 33 | instance Categorise ScopeError where 34 | categorise = \case 35 | OutOfScope{} -> Error 36 | Shadowing Local _ -> Error 37 | Shadowing Global _ -> Warning 38 | 39 | ------------------------------------------------------------------------------ 40 | -- Feedback type 41 | 42 | data Feedback 43 | -- internal errors 44 | = ACouldntFindCircuitDiagram Name 45 | | AnImpossibleError String 46 | 47 | -- error 48 | | ACannotDisplayStub Name 49 | | ANoExecutable String 50 | | AScopeError ScopeError 51 | | ASyntaxError Doc 52 | | ATypeError Doc 53 | | AnAmbiguousDefinition Name [[String]] 54 | | AnInvalidTruthTableOutput Name 55 | | AnUndeclaredCircuit Name 56 | | AnUndefinedCircuit Name 57 | | AnUndefinedType TyName 58 | | AnUnknownIdentifier Name 59 | | AnIllTypedInputs Name [Ty Unit Void] [Va] 60 | | AnIllTypedMemory Name [Ty Unit Void] [Va] 61 | | AnIllTypedOutputs Name [Ty Ti Void] [Va] 62 | | AWrongFinalMemory [Va] [Va] 63 | | AWrongOutputSignals [Va] [Va] 64 | 65 | -- warnings 66 | | AFoundHoles Name [LineDoc] -- non empty list 67 | | ALint Doc 68 | | AMissingImplementation Name 69 | | AStubbedOut Name 70 | | AnUnreasonablyLargeExperiment Int Int Name 71 | 72 | -- comments 73 | | ACircuitDefined [Name] -- non empty list 74 | | ATypeDefined [TyName] -- non empty list 75 | 76 | -- successes 77 | | ADotGraph [Name] Name [String] 78 | | ARawCode LineDoc Name Doc 79 | | ATruthTable Name [String] 80 | | AnExperiment LineDoc [Name] Doc 81 | | AnSVGGraph [Name] Name [String] 82 | | ASuccessfulUnitTest 83 | 84 | -- contextual 85 | | WhenDisplaying Name [Feedback] 86 | | WhenUnitTesting Name CircuitConfig CircuitConfig [Feedback] 87 | 88 | instance Categorise Feedback where 89 | categorise = \case 90 | -- internal errors 91 | AnImpossibleError{} -> Internal 92 | ACouldntFindCircuitDiagram{} -> Internal 93 | 94 | -- errors 95 | ACannotDisplayStub{} -> Error 96 | ANoExecutable{} -> Error 97 | AScopeError{} -> Error 98 | ASyntaxError{} -> Error 99 | ATypeError{} -> Error 100 | AnAmbiguousDefinition{} -> Error 101 | AnInvalidTruthTableOutput{} -> Error 102 | AnUndeclaredCircuit{} -> Error 103 | AnUndefinedCircuit{} -> Error 104 | AnUndefinedType{} -> Error 105 | AnUnknownIdentifier{} -> Error 106 | AnIllTypedInputs{} -> Error 107 | AnIllTypedMemory{} -> Error 108 | AnIllTypedOutputs{} -> Error 109 | AWrongFinalMemory{} -> Error 110 | AWrongOutputSignals{} -> Error 111 | 112 | -- warnings 113 | AFoundHoles{} -> Warning 114 | ALint{} -> Warning 115 | AMissingImplementation{} -> Warning 116 | AStubbedOut{} -> Warning 117 | AnUnreasonablyLargeExperiment{} -> Warning 118 | 119 | -- comments 120 | ACircuitDefined{} -> Comment 121 | ATypeDefined{} -> Comment 122 | 123 | -- successes 124 | ADotGraph{} -> Success 125 | ARawCode{} -> Success 126 | ATruthTable{} -> Success 127 | AnExperiment{} -> Success 128 | AnSVGGraph{} -> Success 129 | ASuccessfulUnitTest{} -> Success 130 | 131 | -- contextual 132 | WhenDisplaying _ fdks -> foldMap categorise fdks 133 | WhenUnitTesting _ _ _ fdks -> foldMap categorise fdks 134 | -------------------------------------------------------------------------------- /lib/Language/Syrup/Unelab.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- Unelab: Unelaboration for Syrup ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | module Language.Syrup.Unelab where 8 | 9 | import Control.Monad.Reader (MonadReader, runReader) 10 | 11 | import Data.Kind (Type) 12 | import Data.Maybe (fromMaybe) 13 | import Data.Void (Void) 14 | 15 | import Language.Syrup.Doc 16 | import Language.Syrup.Syn 17 | import Language.Syrup.Ty 18 | 19 | ------------------------------------------------------------------------ 20 | -- Main utility 21 | 22 | 23 | runUnelab :: Unelab s => CoEnv -> s -> Unelabed s 24 | runUnelab env = flip runReader env . unelab 25 | 26 | 27 | ------------------------------------------------------------------------ 28 | -- Names of unelabed definitions 29 | 30 | data PrettyName 31 | = StandardName Name -- printed e.g. f(X,Y,Z) 32 | | RemarkableName Remarkable -- printed e.g. X & Y 33 | 34 | toName :: PrettyName -> Name 35 | toName (StandardName nm) = nm 36 | toName (RemarkableName r) = Name $ case r of 37 | IsZeroGate -> "zero" 38 | IsOneGate -> "one" 39 | IsNotGate -> "not" 40 | IsAndGate -> "and" 41 | IsOrGate -> "or" 42 | IsNandGate -> "nand" 43 | 44 | ------------------------------------------------------------------------ 45 | -- Unelab monad and class 46 | 47 | type MonadUnelab m = 48 | (MonadReader CoEnv m) 49 | 50 | class Unelab s where 51 | type Unelabed s :: Type 52 | unelab :: MonadUnelab m => s -> m (Unelabed s) 53 | 54 | default unelab 55 | :: (s ~ f s', Unelabed (f s') ~ f (Unelabed s'), Traversable f, Unelab s', MonadUnelab m) 56 | => s -> m (Unelabed s) 57 | unelab = traverse unelab 58 | 59 | ------------------------------------------------------------------------ 60 | -- Unelab instances 61 | 62 | instance Unelab Name where 63 | type Unelabed Name = PrettyName 64 | unelab nm = isRemarkable nm >>= \ mrem -> 65 | pure $ fromMaybe (StandardName nm) $ do 66 | rem <- mrem 67 | let success = Just (RemarkableName rem) 68 | case rem of 69 | IsZeroGate | nm == Name "zero" -> success 70 | IsOneGate | nm == Name "one" -> success 71 | IsNotGate | nm == Name "not" -> success 72 | IsAndGate | nm == Name "and" -> success 73 | IsOrGate | nm == Name "or" -> success 74 | _ -> Nothing 75 | 76 | instance Unelab Integer where 77 | type Unelabed Integer = Integer 78 | unelab = pure 79 | 80 | instance Unelab Void where 81 | type Unelabed Void = Void 82 | unelab = pure 83 | 84 | instance Unelab () where 85 | type Unelabed () = () 86 | unelab = pure 87 | 88 | instance Unelab s => Unelab [s] where 89 | type Unelabed [s] = [Unelabed s] 90 | instance Unelab s => Unelab (Maybe s) where 91 | type Unelabed (Maybe s) = Maybe (Unelabed s) 92 | 93 | instance Unelab a => Unelab (AList a) where 94 | type Unelabed (AList a) = AList (Unelabed a) 95 | unelab (AList a) = AList <$> unelab a 96 | 97 | instance Unelab (Exp' Name ty) where 98 | type Unelabed (Exp' Name ty) = Exp' PrettyName ty 99 | unelab = \case 100 | Var ty x -> pure $ Var ty x 101 | Hol ty x -> pure $ Hol ty x 102 | Cab tys es -> Cab tys <$> unelab es 103 | App tys f es -> App tys <$> unelab f <*> unelab es 104 | 105 | instance Unelab (Pat' ty a) where 106 | type Unelabed (Pat' ty a) = Pat' ty a 107 | unelab = pure 108 | 109 | instance Unelab (Ty ty x) where 110 | type Unelabed (Ty ty x) = Ty ty x 111 | unelab = pure 112 | 113 | instance Unelab (Eqn' Name ty) where 114 | type Unelabed (Eqn' Name ty) = Eqn' PrettyName ty 115 | unelab (ps :=: es) = (ps :=:) <$> unelab es 116 | 117 | instance Unelab (Def' Name ty) where 118 | type Unelabed (Def' Name ty) = Def' PrettyName ty 119 | unelab = \case 120 | Stub nm fdk -> Stub <$> unelab nm <*> pure fdk 121 | Def (nm, lhs) rhs meqn -> Def . (, lhs) <$> unelab nm <*> unelab rhs <*> unelab meqn 122 | 123 | instance Unelab (TypeDecl' Name t x t' x') where 124 | type Unelabed (TypeDecl' Name t x t' x') = TypeDecl' PrettyName t x t' x' 125 | unelab (TypeDecl fn is os) = TypeDecl <$> unelab fn <*> pure is <*> pure os 126 | -------------------------------------------------------------------------------- /lib/Language/Syrup/Lex.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards #-} 2 | 3 | module Language.Syrup.Lex where 4 | 5 | import Data.Char 6 | 7 | import Language.Syrup.Bwd 8 | 9 | lexFile :: String -> [(String, [Token])] 10 | lexFile = fmap tokens . dentLines 11 | 12 | tokens :: String -> (String, [Token]) 13 | tokens r = (r, findBrackets B0 (raw r)) 14 | 15 | data Token 16 | = Spc Int -- never two adjacent 17 | | Id String -- never two adjacent 18 | | QM String -- question mark identifier 19 | | Num Int -- never two adjacent 20 | | Sym String -- two adjacent only if at least one is a solo symbol 21 | | Bracket Bracket [Token] 22 | | BadOpen Bracket [Token] 23 | | BadClose Bracket 24 | deriving Eq 25 | 26 | tokSize :: Token -> Int 27 | tokSize (Bracket _ ts) = 2 + sum (map tokSize ts) 28 | tokSize (BadOpen _ ts) = 1 + sum (map tokSize ts) 29 | tokSize _ = 1 30 | 31 | instance Show Token where 32 | show (Spc n) = replicate n ' ' 33 | show (Id x) = x 34 | show (QM x) = '?':x 35 | show (Num n) = show n 36 | show (Sym s) = s 37 | show (Bracket b ts) = o ++ foldMap show ts ++ c where (o, c) = brackets b 38 | show (BadOpen b ts) = fst (brackets b) ++ foldMap show ts 39 | show (BadClose b) = snd (brackets b) 40 | 41 | data Bracket = Round | Square | Curly deriving (Eq, Show) 42 | brackets :: Bracket -> (String, String) 43 | brackets Round = ("(",")") 44 | brackets Square = ("[","]") 45 | brackets Curly = ("{","}") 46 | 47 | openers, closers :: [(Token, Bracket)] 48 | openers = [(Sym "(", Round),(Sym "[", Square),(Sym "{", Curly)] 49 | closers = [(Sym ")", Round),(Sym "]", Square),(Sym "}", Curly)] 50 | 51 | isAlphaNumU :: Char -> Bool 52 | isAlphaNumU c = c == '_' || isAlphaNum c 53 | 54 | unix :: String -> String 55 | unix [] = [] 56 | unix ('\r' : '\n' : s) = '\n' : unix s 57 | unix ('\n' : '\r' : s) = '\n' : unix s 58 | unix ('\r' : s) = '\n' : unix s 59 | unix (c : s) = c : unix s 60 | 61 | myLines :: String -> [String] 62 | myLines ('-' : '-' : s) = myLines (dropWhile (/= '\n') s) 63 | myLines ('\n' : s) = "" : myLines s 64 | myLines (c : s) = case myLines s of 65 | [] -> [[c]] 66 | s : ss -> (c : s) : ss 67 | myLines [] = [] 68 | 69 | dentLines :: String -> [String] 70 | dentLines = cleanup . dentify B0 . myLines . unix where 71 | dentify lz [] = dump lz [] 72 | dentify lz (l : ls) = case l of 73 | c : _ | not (isSpace c) -> dump lz (dentify (B0 :< l) ls) 74 | _ -> dentify (lz :< l) ls 75 | dump B0 ls = ls 76 | dump lz ls = concat (fmap (++ "\n") lz) : ls 77 | 78 | -- trailing '\n' get attached to the block that came before 79 | -- unfortunately the first block may have been empty and so 80 | -- we used to create a confusing "\n\n\n"-style block. 81 | -- Now we drop instead 82 | cleanup (hd : rest) = if all ('\n' ==) hd then rest else (hd:rest) 83 | cleanup xs = xs 84 | 85 | raw :: String -> [Token] 86 | raw "" = [] 87 | raw (c : s) | elem c " \t\n" = spaces 1 s 88 | raw (c : s) | elem c solos = Sym [c] : raw s 89 | raw (c : c' : s) | c == '?', isAlphaNumU c' = alphanum QM (B0 :< c') s 90 | raw (c : s) | isAlphaNumU c = alphanum Id (B0 :< c) s 91 | raw (c : s) = symbol (B0 :< c) s 92 | 93 | solos :: String 94 | solos = ",;!01()[]{}" 95 | 96 | spaces :: Int -> String -> [Token] 97 | spaces i (c : s) | elem c " \t\n" = spaces (i + 1) s 98 | spaces i s = Spc i : raw s 99 | 100 | alphanum :: (String -> Token) -> Bwd Char -> String -> [Token] 101 | alphanum con cz (c : s) | isAlphaNumU c = alphanum con (cz :< c) s 102 | alphanum con cz s 103 | | all isDigit cz = Num (read (cz <>> [])) : raw s 104 | | otherwise = con (cz <>> []) : raw s 105 | 106 | symbol :: Bwd Char -> String -> [Token] 107 | symbol cz (c : s) | not (or ([isSpace, isAlphaNum, (`elem` solos)] <*> [c])) 108 | = symbol (cz :< c) s 109 | symbol cz s = Sym (cz <>> []) : raw s 110 | 111 | findBrackets :: Bwd (Bracket, Bwd Token) -> [Token] -> [Token] 112 | findBrackets B0 [] = [] 113 | findBrackets (bz :< (b, tz)) [] = findBrackets bz [BadOpen b (tz <>> [])] 114 | findBrackets bz (t : ts) | Just b <- lookup t openers = findBrackets (bz :< (b, B0)) ts 115 | findBrackets bz (t : ts) | Just c <- lookup t closers = case bz of 116 | bz' :< (b, tz) | b == c -> findBrackets bz' (Bracket b (tz <>> []) : ts) 117 | _ -> findBrackets bz (BadClose c : ts) 118 | findBrackets (bz :< (b, tz)) (t : ts) = findBrackets (bz :< (b, tz :< t)) ts 119 | findBrackets B0 (t : ts) = t : findBrackets B0 ts 120 | -------------------------------------------------------------------------------- /lib/Language/Syrup/Run.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- Run: Running Syrup on a default environment ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | module Language.Syrup.Run where 8 | 9 | import Control.Monad.State (execStateT) 10 | import Control.Monad.Writer (tell, runWriter) 11 | import Control.Monad.Reader (runReaderT) 12 | 13 | import Data.Either (partitionEithers) 14 | import Data.Foldable (toList) 15 | import Data.Functor (void) 16 | import qualified Data.Sequence as Seq 17 | import Data.Void (absurd) 18 | 19 | import Text.Blaze.Html5 (Html) 20 | import Text.Blaze.Html.Renderer.String (renderHtml) 21 | 22 | import Language.Syrup.Chk 23 | import Language.Syrup.Dot 24 | import Language.Syrup.Expt 25 | import Language.Syrup.Fdk (Feedback(..), feedbackText, feedbackHtml, keep) 26 | import Language.Syrup.Lnt 27 | import Language.Syrup.Opt 28 | import Language.Syrup.Par 29 | import Language.Syrup.Scp 30 | import Language.Syrup.Sub 31 | import Language.Syrup.Syn 32 | import Language.Syrup.Ty 33 | import Language.Syrup.Utils 34 | 35 | import Utilities.Lens (Has, hasLens, (.=), use, (%=)) 36 | import Utilities.Monad (whenJust) 37 | 38 | getDefsOf :: Name 39 | -> [Either a (Source, String)] 40 | -> ([Either a (Source, String)], [(Def, String)]) 41 | getDefsOf f xs = partitionEithers $ flip map xs $ \case 42 | Right (Definition def, s) | defName def == f -> Right (def,s) 43 | src -> Left src 44 | 45 | grokSy :: MonadExperiment s m 46 | => [Either Feedback (Source, String)] 47 | -> m () 48 | grokSy [] = pure () 49 | grokSy (Left ss : src) = do 50 | tell $ Seq.singleton ss 51 | grokSy src 52 | grokSy (Right (Declaration dec@(DEC (f, _) _), s) : src) = do 53 | let (warn, rest0) = spanMaybe isLeft src 54 | mapM_ (tell . Seq.singleton) warn 55 | let (rest, defs) = getDefsOf f rest0 56 | mdef <- case defs of 57 | [def] -> pure (Just def) 58 | zs@(_ : _ : _) -> do 59 | tell $ Seq.singleton $ AnAmbiguousDefinition f (map (lines . snd) zs) 60 | pure Nothing 61 | [] -> do 62 | tell $ Seq.singleton $ AnUndefinedCircuit f 63 | pure Nothing 64 | (_, mtydef) <- mkComponent' True (dec, s) mdef 65 | whenJust mtydef $ (hasLens %=) . flip addDef 66 | grokSy rest 67 | grokSy (Right (Experiment expt, _) : src) = do 68 | experiment expt 69 | grokSy src 70 | grokSy (Right (Definition d, _) : src) = do 71 | tell $ Seq.singleton $ AnUndeclaredCircuit (defName d) 72 | grokSy src 73 | grokSy (Right (TypeAlias (x, _), _) : src) = absurd x 74 | 75 | data SyrupEnv = SyrupEnv 76 | { syrupTyEnv :: TyEnv 77 | , syrupCoEnv :: CoEnv 78 | , syrupDotSt :: DotSt 79 | } 80 | 81 | instance Has TyEnv SyrupEnv where 82 | hasLens f (SyrupEnv ty co dot) = (\ ty -> SyrupEnv ty co dot) <$> f ty 83 | 84 | instance Has CoEnv SyrupEnv where 85 | hasLens f (SyrupEnv ty co dot) = (\ co -> SyrupEnv ty co dot) <$> f co 86 | 87 | instance Has DotSt SyrupEnv where 88 | hasLens f (SyrupEnv ty co dot) = (\ dot -> SyrupEnv ty co dot) <$> f dot 89 | 90 | type MonadSyrup s m = 91 | ( Has TyEnv s 92 | , MonadExperiment s m 93 | ) 94 | 95 | runSyrup :: MonadSyrup s m => String -> m () 96 | runSyrup txt = do 97 | let ls = syrupFile txt 98 | let linted = linter ls 99 | g <- use hasLens 100 | let scps = check (globalScope (void (g :: CoEnv))) linted 101 | t <- use hasLens 102 | -- TODO: mtl-ise inlineAliases? 103 | let (t', srcs) = inlineAliases t scps 104 | hasLens .= t' 105 | grokSy srcs 106 | 107 | -- The sort of interface Marx prefers 108 | oldRunSyrup 109 | :: ([Feedback] -> a) 110 | -> Options -> SyrupEnv -> String -> (SyrupEnv, a) 111 | oldRunSyrup fdk opts env src 112 | = fmap (fdk . filter (keep opts) . toList) 113 | $ runWriter 114 | $ flip runReaderT opts 115 | $ flip execStateT env 116 | $ runSyrup src 117 | 118 | marxRunSyrup :: Options -> SyrupEnv -> String -> (SyrupEnv, Html) 119 | marxRunSyrup = oldRunSyrup feedbackHtml 120 | 121 | syrup :: Options -> String -> String 122 | syrup opts src = snd $ oldRunSyrup fdk opts env src where 123 | 124 | env :: SyrupEnv 125 | env = SyrupEnv myTyEnv myCoEnv myDotSt 126 | 127 | fdk :: [Feedback] -> String 128 | fdk = case outputFormat opts of 129 | TextOutput -> unlines . feedbackText 130 | HtmlOutput -> renderHtml . feedbackHtml 131 | -------------------------------------------------------------------------------- /lib/Language/Syrup/DeMorgan.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- DeMorgan: Simplifying circuits using laws ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | {-# LANGUAGE OverloadedStrings #-} 8 | 9 | module Language.Syrup.DeMorgan where 10 | 11 | import Control.Monad (guard) 12 | import Control.Monad.Reader (Reader, runReader) 13 | import Control.Monad.State 14 | 15 | import Data.Maybe (fromMaybe) 16 | 17 | import Language.Syrup.Ded 18 | import Language.Syrup.Syn 19 | import Language.Syrup.Ty 20 | import Language.Syrup.Utils (partitionWith) 21 | 22 | ------------------------------------------------------------------------ 23 | -- Deploying De Morgan's laws to simplify circuits 24 | -- Trying to be clever about circuit depth 25 | ------------------------------------------------------------------------ 26 | 27 | deMorgan :: CoEnv -> Def' Name ty -> Def' Name ty 28 | deMorgan env (Def lhs rhs meqns) = 29 | let simpl = simplify Positive rhs in 30 | let (rhs', eqns') = runReader (runStateT simpl (fromMaybe [] meqns)) env in 31 | cleanup $ Def lhs rhs' (eqns' <$ guard (not (null eqns'))) 32 | deMorgan env d = d 33 | 34 | data Polarity nm ty 35 | = Positive 36 | | Negative nm ty 37 | -- ^ this is storing the names of: 38 | -- 1. the not gate 39 | -- 2. the Bit type 40 | 41 | isPositive :: Polarity nm ty -> Bool 42 | isPositive Positive = True 43 | isPositive _ = False 44 | 45 | instance Show (Polarity nm ty) where 46 | show Positive = "+" 47 | show Negative{} = "-" 48 | 49 | inverse :: nm -> ty -> Polarity nm ty -> Polarity nm ty 50 | inverse nm ty Positive = Negative nm ty 51 | inverse _ _ (Negative _ _) = Positive 52 | 53 | type DeMorganM ty = StateT [Eqn' Name ty] (Reader CoEnv) 54 | 55 | class DeMorgan ty t where 56 | simplify :: Polarity Name ty -> t -> DeMorganM ty t 57 | 58 | isAssignment :: String -> Eqn' nm ty -> Either (Exp' nm ty) (Eqn' nm ty) 59 | isAssignment x eqn@([PVar _ y] :=: [e]) 60 | | x == y = Left e 61 | | otherwise = Right eqn 62 | isAssignment x eqn = Right eqn 63 | 64 | isDefined :: String -> DeMorganM ty (Maybe (Exp' Name ty)) 65 | isDefined x = do 66 | eqns <- get 67 | case partitionWith (isAssignment x) eqns of 68 | ([e], es) -> Just e <$ put es 69 | _ -> pure Nothing 70 | 71 | applyPolarity :: Polarity nm ty -> Exp' nm ty -> Exp' nm ty 72 | applyPolarity Positive e = e 73 | applyPolarity (Negative fn ty) e = App [ty] fn [e] 74 | 75 | mkIdempotent :: Eq nm => [ty] -> nm -> Exp' nm ty -> Exp' nm ty -> Exp' nm ty 76 | mkIdempotent tys fn e1 e2 77 | | (() <$ e1) == (() <$ e2) = e1 78 | | otherwise = App tys fn [e1, e2] 79 | 80 | instance DeMorgan ty (Exp' Name ty) where 81 | simplify pol (App [ty] fn [e]) = isRemarkable fn >>= \case 82 | Just IsNotGate -> simplify (inverse fn ty pol) e 83 | _ -> do 84 | e <- simplify Positive e 85 | pure $ applyPolarity pol (App [ty] fn [e]) 86 | simplify pol (App [ty] fn [e1,e2]) = 87 | let structural = do 88 | e1 <- simplify Positive e1 89 | e2 <- simplify Positive e2 90 | pure $ applyPolarity pol (App [ty] fn [e1, e2]) 91 | in isRemarkable fn >>= \case 92 | Just IsAndGate | not (isPositive pol) -> do 93 | e1 <- simplify Positive e1 94 | e2 <- simplify Positive e2 95 | pure $ App [ty] "nand" [e1, e2] 96 | Just IsOrGate | not (isPositive pol) -> 97 | getRemarkable IsAndGate >>= \case 98 | Just and -> do 99 | e1 <- simplify pol e1 100 | e2 <- simplify pol e2 101 | pure $ mkIdempotent [ty] and e1 e2 102 | _ -> structural 103 | Just IsOrGate | otherwise -> do 104 | e1 <- simplify Positive e1 105 | e2 <- simplify Positive e2 106 | let dflt = mkIdempotent [ty] fn e1 e2 107 | case (e1, e2) of 108 | (App [_] ln [e1'], App [_] rn [e2']) -> do 109 | rmkl <- isRemarkable ln 110 | rmkr <- isRemarkable rn 111 | pure $ case (,) <$> rmkl <*> rmkr of 112 | Just (IsNotGate, IsNotGate) -> App [ty] "nand" [e1', e2'] 113 | _ -> dflt 114 | (App [_] ln [e11, e12], App [_] rn [e2']) -> do 115 | rmkl <- isRemarkable ln 116 | rmkr <- isRemarkable rn 117 | mand <- getRemarkable IsAndGate 118 | pure $ case (,,) <$> mand <*> rmkl <*> rmkr of 119 | Just (and, IsNandGate, IsNotGate) -> 120 | App [ty] "nand" [mkIdempotent [ty] and e11 e12, e2'] 121 | _ -> dflt 122 | (App [_] ln [e1'], App [_] rn [e21, e22]) -> do 123 | rmkl <- isRemarkable ln 124 | rmkr <- isRemarkable rn 125 | mand <- getRemarkable IsAndGate 126 | pure $ case (,,) <$> mand <*> rmkl <*> rmkr of 127 | Just (and, IsNotGate, IsNandGate) -> 128 | App [ty] "nand" [e1', mkIdempotent [ty] and e21 e22] 129 | _ -> dflt 130 | _ -> pure dflt 131 | _ -> structural 132 | simplify pol og@(Var ty x) = isDefined x >>= \case 133 | Just e -> do 134 | e <- simplify Positive e 135 | modify (([PVar ty x] :=: [e]) :) 136 | if isPositive pol then pure og else simplify pol e 137 | Nothing -> pure $ applyPolarity pol og 138 | simplify pol og = pure $ applyPolarity pol og 139 | 140 | instance DeMorgan ty a => DeMorgan ty [a] where 141 | simplify pol = traverse (simplify pol) 142 | -------------------------------------------------------------------------------- /lib/Language/Syrup/Smp.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- Smp: Sample programs to run tests on ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | {-# LANGUAGE OverloadedStrings #-} 8 | 9 | module Language.Syrup.Smp where 10 | 11 | import Language.Syrup.Syn 12 | import Language.Syrup.Ty 13 | 14 | zero :: TypedDef 15 | zero = let ty = Bit Unit in 16 | Def ("zero", []) [Var ty "D"] $ Just $ 17 | [ ([PVar ty "D"] :=: [App [ty] "dff" [Var ty "E"]]) 18 | , ([PVar ty "E"] :=: [App [ty] "nand" [Var ty "F", Var ty "F"]]) 19 | , ([PVar ty "F"] :=: [App [ty] "nand" [Var ty "D", Var ty "G"]]) 20 | , ([PVar ty "G"] :=: [App [ty] "nand" [Var ty "D", Var ty "D"]]) 21 | ] 22 | 23 | nand :: TypedDef 24 | nand = let ty = Bit Unit in 25 | Def ("nand", PVar ty <$> ["X", "Y"]) [Var ty "Z"] $ Just $ 26 | [ ([PVar ty "Z"] :=: [App [ty] "nand" (Var ty <$> ["X", "Y"])]) ] 27 | 28 | notG :: TypedDef 29 | notG = let ty = Bit Unit in 30 | Def ("not", [PVar ty "X"]) [Var ty "Z"] $ Just $ 31 | [ [PVar ty "Z"] :=: [App [ty] "nand" [Var ty "X", Var ty "X"]] ] 32 | 33 | andG :: TypedDef 34 | andG = let ty = Bit Unit in 35 | Def ("and", [PVar ty "x", PVar ty "y"]) 36 | [App [ty] "not" [App [ty] "nand" [Var ty "x", Var ty "y"]]] 37 | Nothing 38 | 39 | orG :: TypedDef 40 | orG = let ty = Bit Unit in 41 | Def ("or", PVar ty <$> ["X", "Y"]) [Var ty "Z"] $ Just $ 42 | [ ([PVar ty "Z"] :=: [App [ty] "nand" (App [ty] "not" . pure . Var ty <$> ["X", "Y"])]) ] 43 | 44 | dff :: TypedDef 45 | dff = let ty = Bit Unit in 46 | Def ("dff", [PVar ty "D"]) [Var ty "Q"] $ Just $ 47 | [ ([PVar ty "Q"] :=: [App [ty] "dff" [Var ty "D"]]) ] 48 | 49 | xor :: TypedDef 50 | xor = let ty = Bit Unit in 51 | Def ("xor", PVar ty <$> ["X", "Y"]) [App [ty] "or" (Var ty <$> ["A", "B"])] $ Just 52 | [ ([PVar ty "A"] :=: [App [ty] "and" (Var ty <$> ["Y", "X"])]) 53 | , ([PVar ty "B"] :=: [App [ty] "and" (Var ty <$> ["NX", "NY"])]) 54 | , ([PVar ty "NX"] :=: [App [ty] "not" [Var ty "X"]]) 55 | , ([PVar ty "NY"] :=: [App [ty] "not" [Var ty "Y"]]) 56 | ] 57 | 58 | tff :: TypedDef 59 | tff = let ty = Bit Unit in 60 | Def ("tff", [PVar ty "T"]) [Var ty "Q"] $ Just $ 61 | [ ([PVar ty "D"] :=: [App [ty] "xor" [Var ty "Q", Var ty "T"]]) 62 | , ([PVar ty "Q"] :=: [App [ty] "dff" [Var ty "D"]]) 63 | ] 64 | 65 | foo :: TypedDef 66 | foo = let ty = Bit Unit in 67 | Def ("foo", PVar ty <$> ["A", "B", "C"]) 68 | ([App [ty] "and" [Var ty "A", Var ty "B"], Var ty "Z"]) 69 | $ Just [([PVar ty "Z"] :=: [App [ty] "or" [Var ty "A" 70 | , App [ty] "and" [Var ty "B", Var ty "C"]]])] 71 | 72 | and4 :: TypedDef 73 | and4 = let ty = Bit Unit in 74 | Def ("and4", PVar ty <$> ["A", "B", "C", "D"]) 75 | [foldr1 (\ a b -> App [ty] "and" [a, b]) $ Var ty <$> ["A", "B", "C", "D"]] 76 | Nothing 77 | 78 | and4' :: TypedDef 79 | and4' = let ty = Bit Unit in 80 | Def ("and4'", PVar ty <$> ["A", "B", "C", "D"]) 81 | [App [ty] "and" [ App [ty] "and" (Var ty <$> ["A", "B"]) 82 | , App [ty] "and" (Var ty <$> ["C", "D"]) 83 | ] 84 | ] 85 | Nothing 86 | 87 | swapG :: TypedDef 88 | swapG = let ty = Bit Unit in 89 | Def ("swap", [PVar ty "x", PVar ty "y"]) [Var ty "y", Var ty "x"] Nothing 90 | 91 | mux :: TypedDef 92 | mux = let ty = Bit Unit in 93 | Def ("mux", PVar ty <$> ["C", "X", "Y"]) 94 | [ App [ty] "or" [ App [ty] "and" [App [ty] "not" [Var ty "C"], Var ty "X"] 95 | , App [ty] "and" (Var ty <$> ["C", "Y"]) 96 | ] 97 | ] Nothing 98 | 99 | mux2 :: TypedDef 100 | mux2 = let ty = Bit Unit in 101 | Def ("mux", PVar ty <$> ["C", "X1", "X2", "Y1", "Y2"]) 102 | (Var ty <$> ["A", "B"]) $ Just 103 | [ ([PVar ty "A"] :=: [App [ty] "mux" (Var ty <$> [ "C", "X1", "Y1" ])]) 104 | , ([PVar ty "B"] :=: [App [ty] "mux" (Var ty <$> [ "C", "X2", "Y2" ])]) 105 | ] 106 | 107 | hadd :: TypedDef 108 | hadd = let ty = Bit Unit in 109 | Def ("hadd", PVar ty <$> ["X", "Y"]) 110 | [ App [ty] "and" (Var ty <$> ["X", "Y"]) 111 | , App [ty] "xor" (Var ty <$> ["X", "Y"]) 112 | ] 113 | Nothing 114 | 115 | fadd :: TypedDef 116 | fadd = let ty = Bit Unit in 117 | Def ("fadd", PVar ty <$> ["X", "Y", "C"]) 118 | (Var ty <$> ["C1", "Z0"]) $ Just 119 | [ ((PVar ty <$> ["CA", "D"]) :=: [App [ty, ty] "hadd" (Var ty <$> ["X", "Y"])]) 120 | , ((PVar ty <$> ["CB", "Z0"]) :=: [App [ty, ty] "hadd" (Var ty <$> ["D", "C"])]) 121 | , ([PVar ty "C1"] :=: [App [ty] "xor" (Var ty <$> ["CA", "CB"])]) 122 | ] 123 | 124 | rca4 :: TypedDef 125 | rca4 = let ty = Bit Unit in 126 | Def ("rca4", PVar ty <$> ["X3", "X2", "X1", "X0", "Y3", "Y2", "Y1", "Y0", "CI"]) 127 | (Var ty <$> ["CO", "Z3", "Z2", "Z1", "Z0"]) $ Just 128 | [ ((PVar ty <$> ["CO", "Z3"]) :=: [App [ty, ty] "fadd" (Var ty <$> [ "X3", "Y3", "C3" ])]) 129 | , ((PVar ty <$> ["C3", "Z2"]) :=: [App [ty, ty] "fadd" (Var ty <$> [ "X2", "Y2", "C2" ])]) 130 | , ((PVar ty <$> ["C2", "Z1"]) :=: [App [ty, ty] "fadd" (Var ty <$> [ "X1", "Y1", "C1" ])]) 131 | , ((PVar ty <$> ["C1", "Z0"]) :=: [App [ty, ty] "fadd" (Var ty <$> [ "X0", "Y0", "CI" ])]) 132 | ] 133 | 134 | andnot :: TypedDef 135 | andnot = let ty = Bit Unit in 136 | Def ("andnot", [PVar ty "X"]) [Var ty "R"] $ Just 137 | [ [PVar ty "Z"] :=: [App [ty] "not" [Var ty "X"]] 138 | , [PVar ty "R"] :=: [App [ty] "and" (Var ty <$> ["Z", "Z"])] 139 | ] 140 | -------------------------------------------------------------------------------- /lib/Language/Syrup/Syn.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- Syn: Syntax for Syrup ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | module Language.Syrup.Syn 8 | ( module Language.Syrup.Syn.Base 9 | , module Language.Syrup.Syn 10 | ) where 11 | 12 | import Data.IMaybe (IMaybe(..)) 13 | import Data.Kind (Type) 14 | import Data.Monoid (Sum(..), First(..)) 15 | import Data.Void (Void) 16 | 17 | import Language.Syrup.BigArray 18 | import Language.Syrup.Fdk.Base 19 | import Language.Syrup.Syn.Base 20 | 21 | data Source' a b 22 | = Declaration (DEC' b) 23 | | TypeAlias (a, TY' b) 24 | | Definition Def 25 | | Experiment EXPT 26 | 27 | -- Concrete and internal sources 28 | type SourceC = Source' TyName False 29 | type Source = Source' Void True 30 | 31 | type Exp = Exp' Name () 32 | data Exp' nm ty 33 | = Var ty String 34 | | Hol ty String 35 | | App [ty] nm [Exp' nm ty] 36 | | Cab ty [Exp' nm ty] 37 | deriving (Eq, Functor, Foldable, Traversable) 38 | 39 | expTys :: Exp' nm ty -> [ty] 40 | expTys = \case 41 | Var ty _ -> [ty] 42 | Hol ty _ -> [ty] 43 | App tys _ _ -> tys 44 | Cab ty _ -> [ty] 45 | 46 | type Pat = Pat' () String 47 | data Pat' ty a 48 | = PVar ty a 49 | | PCab ty [Pat' ty a] 50 | deriving (Functor, Traversable, Foldable) 51 | 52 | patTy :: Pat' ty a -> ty 53 | patTy = \case 54 | PVar ty a -> ty 55 | PCab ty _ -> ty 56 | 57 | exPat :: Exp' nm ty -> Maybe (Pat' ty String) 58 | exPat (Var ty x) = return (PVar ty x) 59 | exPat (Hol ty x) = Nothing -- for now? 60 | exPat (Cab ty es) = PCab ty <$> traverse exPat es 61 | exPat _ = Nothing 62 | 63 | patToExp :: Pat' ty String -> Exp' nm ty 64 | patToExp = \case 65 | PVar ty x -> Var ty x 66 | PCab ty ps -> Cab ty $ map patToExp ps 67 | 68 | type Eqn = Eqn' Name () 69 | data Eqn' nm ty = [Pat' ty String] :=: [Exp' nm ty] 70 | type Def = Def' Name () 71 | data Def' nm ty 72 | = Stub nm [Feedback] 73 | -- stubbed out definition together with error msg 74 | | Def (nm, [Pat' ty String]) [Exp' nm ty] (Maybe [Eqn' nm ty]) 75 | 76 | defName :: Def' nm ty -> nm 77 | defName (Stub f _) = f 78 | defName (Def (f, _) _ _) = f 79 | 80 | data TY' b 81 | = BIT 82 | | OLD (TY' b) 83 | | CABLE [TY' b] 84 | | TYVAR TyName (IMaybe b (TY' b)) 85 | deriving (Show) 86 | 87 | -- Concrete and internal types 88 | type TYC = TY' False 89 | type TY = TY' True 90 | 91 | data DEC' b = DEC (Name,[TY' b]) [TY' b] 92 | deriving Show 93 | 94 | -- Concrete and internal declarations 95 | type DECC = DEC' False 96 | type DEC = DEC' True 97 | 98 | data InputName = InputName { getInputName :: String } 99 | deriving Show 100 | 101 | data EXPT 102 | = Anf Name 103 | | Bisimilarity Name Name 104 | | UnitTest Name CircuitConfig CircuitConfig 105 | | Costing [Name] Name 106 | | Display [Name] Name 107 | | Dnf Name 108 | | Print Name 109 | | Simplify Name 110 | | Simulate Name [Va] [[Va]] 111 | | Typing Name 112 | | Tabulate Name 113 | | FromOutputs Name [InputName] [Bool] 114 | deriving Show 115 | 116 | 117 | 118 | ------------------------------------------------------------------------------ 119 | -- operations on syntax 120 | ------------------------------------------------------------------------------ 121 | 122 | class IsCircuit t where 123 | type VarTy t :: Type 124 | allVars :: t -> Arr String (First (VarTy t), Sum Int) 125 | allGates :: t -> Arr Name (Sum Int) 126 | allHoles :: t -> Arr String (First (VarTy t)) 127 | 128 | default allVars 129 | :: (t ~ f a, VarTy t ~ VarTy a, Foldable f, IsCircuit a) 130 | => t -> Arr String (First (VarTy t), Sum Int) 131 | allVars = foldMap allVars 132 | 133 | default allGates 134 | :: (t ~ f a, Foldable f, IsCircuit a) 135 | => t -> Arr Name (Sum Int) 136 | allGates = foldMap allGates 137 | 138 | default allHoles 139 | :: (t ~ f a, VarTy t ~ VarTy a, Foldable f, IsCircuit a) 140 | => t -> Arr String (First (VarTy t)) 141 | allHoles = foldMap allHoles 142 | 143 | instance IsCircuit a => IsCircuit [a] where 144 | type VarTy [a] = VarTy a 145 | instance IsCircuit a => IsCircuit (Maybe a) where 146 | type VarTy (Maybe a) = VarTy a 147 | 148 | instance a ~ String => IsCircuit (Pat' ty a) where 149 | type VarTy (Pat' ty a) = ty 150 | allVars = \case 151 | PVar ty s -> single (s, (First (Just ty), Sum 1)) 152 | PCab _ c -> allVars c 153 | allGates _ = emptyArr 154 | allHoles _ = emptyArr 155 | 156 | instance IsCircuit (Def' Name ty) where 157 | type VarTy (Def' Name ty) = ty 158 | allVars = \case 159 | Stub{} -> emptyArr 160 | Def (fn,ps) es meqns -> allVars ps <> allVars es <> allVars meqns 161 | allGates = \case 162 | Stub{} -> emptyArr 163 | Def (fn,ps) es meqns -> allGates es <> allGates meqns 164 | allHoles = \case 165 | Stub{} -> emptyArr 166 | Def (fn,ps) es meqns -> allHoles es <> allHoles meqns 167 | 168 | instance IsCircuit (Exp' Name ty) where 169 | type VarTy (Exp' Name ty) = ty 170 | allVars = \case 171 | Var ty x -> single (x, (First (Just ty), Sum 1)) 172 | Hol ty x -> emptyArr 173 | App _ fn es -> allVars es 174 | Cab _ es -> allVars es 175 | allGates = \case 176 | Var{} -> emptyArr 177 | Hol{} -> emptyArr 178 | Cab{} -> emptyArr 179 | App _ fn es -> single (fn, Sum 1) <> allGates es 180 | allHoles = \case 181 | Var ty x -> emptyArr 182 | Hol ty x -> single (x, First (Just ty)) 183 | App _ fn es -> allHoles es 184 | Cab _ es -> allHoles es 185 | 186 | instance IsCircuit (Eqn' Name ty) where 187 | type VarTy (Eqn' Name ty) = ty 188 | allVars (ps :=: es) = allVars ps <> allVars es 189 | allGates (ps :=: es) = allGates es 190 | allHoles (ps :=: es) = allHoles es 191 | 192 | support :: IsCircuit t => t -> Set String 193 | support p = () <$ allVars p 194 | -------------------------------------------------------------------------------- /lib/Language/Syrup/Pretty.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- Pretty: Pretty printing for Syrup ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | {-# LANGUAGE OverloadedStrings #-} 8 | 9 | module Language.Syrup.Pretty where 10 | 11 | import Control.Monad.Reader (MonadReader, runReader) 12 | 13 | import Data.Foldable (fold) 14 | import Data.List (intercalate, intersperse) 15 | 16 | import Prelude hiding (unwords, unlines) 17 | 18 | import Language.Syrup.BigArray (emptyArr) 19 | import Language.Syrup.Doc 20 | import Language.Syrup.Syn 21 | import Language.Syrup.Ty 22 | import Language.Syrup.Unelab 23 | import Language.Syrup.Utils (($$)) 24 | 25 | ------------------------------------------------------------------------ 26 | -- Resulting functions 27 | 28 | prettyUnelabed 29 | :: (Unelab s, Pretty (Unelabed s)) 30 | => CoEnv -> s -> PrettyDoc (Unelabed s) 31 | prettyUnelabed env = pretty . runUnelab env 32 | 33 | prettyShow 34 | :: (Unelab s, Pretty (Unelabed s), Render (PrettyDoc (Unelabed s))) 35 | => CoEnv -> s -> String 36 | prettyShow env = concat . renderToString . prettyUnelabed env 37 | 38 | basicShow 39 | :: (Unelab s, Pretty (Unelabed s), Render (PrettyDoc (Unelabed s))) 40 | => s -> String 41 | basicShow = prettyShow emptyArr 42 | 43 | instance Pretty Va where 44 | type PrettyDoc Va = LineDoc 45 | prettyPrec _ = \case 46 | VQ -> "?" 47 | V0 -> "0" 48 | V1 -> "1" 49 | VC vs -> brackets $$ map pretty vs 50 | 51 | circuitExec :: Name -> CircuitConfig -> CircuitConfig -> LineDoc 52 | circuitExec nm is os = fold 53 | [ pretty nm 54 | , let mems = memoryConfig is in 55 | if null mems then mempty else braces (foldMap pretty mems) 56 | , parens (foldMap pretty $ valuesConfig is) 57 | , " = " 58 | , let mems = memoryConfig os in 59 | if null mems then mempty else braces (foldMap pretty mems) 60 | , foldMap pretty (valuesConfig os) 61 | ] 62 | 63 | 64 | ------------------------------------------------------------------------ 65 | -- Pretty instances 66 | 67 | instance Pretty PrettyName where 68 | type PrettyDoc PrettyName = LineDoc 69 | prettyPrec _ = pretty . toName 70 | 71 | data FunctionCall a = FunctionCall 72 | { functionName :: PrettyName 73 | , functionArgs :: [a] 74 | } 75 | 76 | instance (Pretty a, PrettyDoc a ~ LineDoc) => Pretty (FunctionCall a) where 77 | type PrettyDoc (FunctionCall a) = LineDoc 78 | prettyPrec lvl = \case 79 | FunctionCall (RemarkableName IsZeroGate) [] -> highlight AFunction "0" 80 | FunctionCall (RemarkableName IsOneGate) [] -> highlight AFunction "1" 81 | FunctionCall (RemarkableName IsNotGate) [s] -> 82 | highlight AFunction "!" <> prettyPrec NegatedClause s 83 | FunctionCall (RemarkableName IsOrGate) [s, t] -> 84 | parensIf (lvl > OrClause) $ unwords 85 | [ prettyPrec AndClause s 86 | , highlight AFunction "|" 87 | , prettyPrec OrClause t 88 | ] 89 | FunctionCall (RemarkableName IsAndGate) [s, t] -> 90 | parensIf (lvl > AndClause) $ unwords 91 | [ prettyPrec NegatedClause s 92 | , highlight AFunction "&" 93 | , prettyPrec AndClause t 94 | ] 95 | FunctionCall f es -> fold [pretty (toName f), pretty (ATuple es)] 96 | 97 | 98 | instance Pretty (Exp' PrettyName ty) where 99 | type PrettyDoc (Exp' PrettyName ty) = LineDoc 100 | prettyPrec lvl = \case 101 | Var _ x -> highlight AVariable $ pretty x 102 | Hol _ x -> "?" <> pretty x 103 | Cab _ es -> pretty (AList es) 104 | App _ f es -> prettyPrec lvl (FunctionCall f es) 105 | 106 | instance (Pretty a, PrettyDoc a ~ LineDoc) => Pretty (Pat' ty a) where 107 | type PrettyDoc (Pat' ty a) = LineDoc 108 | prettyPrec lvl = \case 109 | PVar _ a -> highlight AVariable $ pretty a 110 | PCab _ ps -> pretty (AList ps) 111 | 112 | instance Pretty Ti where 113 | type PrettyDoc Ti = LineDoc 114 | prettyPrec lvl = \case 115 | T0 -> "@" 116 | T1 -> "" 117 | 118 | instance 119 | ( Pretty t 120 | , PrettyDoc t ~ LineDoc 121 | , Pretty x 122 | , PrettyDoc x ~ LineDoc 123 | ) => Pretty (Ty t x) where 124 | type PrettyDoc (Ty t x) = LineDoc 125 | prettyPrec lvl = \case 126 | Meta x -> highlight AType $ between "<" ">" $ "?" <> pretty x 127 | TVar s _ -> pretty s 128 | Bit t -> pretty t <> pretty (TyName "Bit") 129 | Cable ps -> pretty (AList ps) 130 | 131 | instance Pretty (Eqn' PrettyName ty) where 132 | type PrettyDoc (Eqn' PrettyName ty) = LineDoc 133 | prettyPrec _ (ps :=: es) = 134 | unwords 135 | [ csep $ map pretty ps 136 | , "=" 137 | , csep $ map pretty es] 138 | 139 | instance Pretty (Def' PrettyName Typ) where 140 | type PrettyDoc (Def' PrettyName Typ) = Doc 141 | prettyPrec _ = \case 142 | Stub{} -> aLine "Stubbed out definition" 143 | (Def (fn, ps) rhs meqns) -> 144 | -- Type declaration 145 | let pstys = map patTy ps in 146 | let lhsTy = pretty (FunctionCall fn pstys) in 147 | let rhstys = concatMap expTys rhs in 148 | let rhsTy = csep $ map pretty rhstys in 149 | let decl = unwords [lhsTy, "->", rhsTy] in 150 | -- Circuit definition 151 | let lhsDef = pretty (FunctionCall fn ps) in 152 | let rhsDef = csep $ map pretty rhs in 153 | let defn = case meqns of 154 | Nothing -> pretty (unwords [lhsDef, "=", rhsDef]) 155 | Just eqns -> 156 | pretty (unwords [lhsDef, "=", rhsDef, highlight AKeyword "where"]) 157 | <> nest 2 (foldMap prettyBlock eqns) 158 | -- Combining everything 159 | in pretty decl <> defn 160 | 161 | instance 162 | ( Pretty t 163 | , PrettyDoc t ~ LineDoc 164 | , Pretty x 165 | , PrettyDoc x ~ LineDoc 166 | , Pretty t' 167 | , PrettyDoc t' ~ LineDoc 168 | , Pretty x' 169 | , PrettyDoc x' ~ LineDoc 170 | ) => Pretty (TypeDecl' PrettyName t x t' x') where 171 | type PrettyDoc (TypeDecl' PrettyName t x t' x') = LineDoc 172 | prettyPrec _ (TypeDecl fn is os) = 173 | let lhsTy = pretty (FunctionCall fn is) in 174 | let rhsTy = csep $ map pretty os in 175 | unwords [lhsTy, "->", rhsTy] 176 | -------------------------------------------------------------------------------- /syrup.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | -- The cabal-version field refers to the version of the .cabal specification, 3 | -- and can be different from the cabal-install (the tool) version and the 4 | -- Cabal (the library) version you are using. As such, the Cabal (the library) 5 | -- version used must be equal or greater than the version stated in this field. 6 | -- Starting from the specification version 2.2, the cabal-version field must be 7 | -- the first thing in the cabal file. 8 | 9 | -- Initial package description 'syrup' generated by 10 | -- 'cabal init'. For further documentation, see: 11 | -- http://haskell.org/cabal/users-guide/ 12 | -- 13 | -- The name of the package. 14 | name: syrup 15 | 16 | -- The package version. 17 | -- See the Haskell package versioning policy (PVP) for standards 18 | -- guiding when and how versions should be incremented. 19 | -- https://pvp.haskell.org 20 | -- PVP summary: +-+------- breaking API changes 21 | -- | | +----- non-breaking API additions 22 | -- | | | +--- code changes with no API change 23 | version: 0.1.0.0 24 | 25 | tested-with: 26 | GHC ==9.12.2 27 | || ==9.10.2 28 | || ==9.8.2 29 | || ==9.6.4 30 | || ==9.4.8 31 | || ==9.2.8 32 | 33 | -- A short (one-line) description of the package. 34 | synopsis: Haskell-style circuit description language 35 | 36 | -- A longer description of the package. 37 | description: 38 | Haskell-style circuit description, simulation, and 39 | rendering language. 40 | This is used in the delivery of our hardware first 41 | year class. 42 | 43 | -- The license under which the package is released. 44 | license: NONE 45 | 46 | -- The package author(s). 47 | author: Conor McBride 48 | 49 | -- An email address to which users can send suggestions, bug reports, and patches. 50 | maintainer: guillaume.allais@ens-lyon.org 51 | 52 | 53 | -- A copyright notice. 54 | -- copyright: 55 | category: Language 56 | build-type: Simple 57 | 58 | -- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. 59 | extra-doc-files: CHANGELOG.md 60 | 61 | -- Extra source files to be distributed with the package, such as examples, or a tutorial module. 62 | extra-source-files: 63 | test/*.syrup 64 | test/*.out 65 | test/*.flags 66 | 67 | common warnings 68 | -- Silence some flags 69 | ghc-options: -Wall 70 | -Wno-name-shadowing 71 | -Wno-noncanonical-monad-instances 72 | -Wno-noncanonical-monoid-instances 73 | -Wno-unused-do-bind 74 | -Wno-unused-local-binds 75 | -Wno-unused-matches 76 | -Werror=incomplete-patterns 77 | 78 | library 79 | import: warnings 80 | 81 | -- Modules exported by the library. 82 | exposed-modules: Data.Forget 83 | , Data.IMaybe 84 | , Language.Syrup.Anf 85 | , Language.Syrup.BigArray 86 | , Language.Syrup.Bwd 87 | , Language.Syrup.Chk 88 | , Language.Syrup.Cst 89 | , Language.Syrup.Ded 90 | , Language.Syrup.DeMorgan 91 | , Language.Syrup.DNF 92 | , Language.Syrup.Doc 93 | , Language.Syrup.Dot 94 | , Language.Syrup.Expt 95 | , Language.Syrup.Fdk 96 | , Language.Syrup.Fdk.Base 97 | , Language.Syrup.Fsh 98 | , Language.Syrup.Gph 99 | , Language.Syrup.HalfZip 100 | , Language.Syrup.Lex 101 | , Language.Syrup.Lnt 102 | , Language.Syrup.Opt 103 | , Language.Syrup.Par 104 | , Language.Syrup.Pretty 105 | , Language.Syrup.Run 106 | , Language.Syrup.Scp 107 | , Language.Syrup.Smp 108 | , Language.Syrup.Sub 109 | , Language.Syrup.Syn 110 | , Language.Syrup.Syn.Base 111 | , Language.Syrup.Ty 112 | , Language.Syrup.Unelab 113 | , Language.Syrup.Utils 114 | , Language.Syrup.Va 115 | , Utilities.Bwd 116 | , Utilities.HTML 117 | , Utilities.Lens 118 | , Utilities.Monad 119 | , Utilities.Nat 120 | , Utilities.Vector 121 | 122 | -- Modules included in this library but not exported. 123 | -- other-modules: 124 | 125 | -- LANGUAGE extensions used by modules in this package. 126 | default-extensions: ConstraintKinds 127 | , DataKinds 128 | , DefaultSignatures 129 | , DeriveFoldable 130 | , DeriveFunctor 131 | , DeriveTraversable 132 | , FlexibleContexts 133 | , FlexibleInstances 134 | , GADTs 135 | , GeneralisedNewtypeDeriving 136 | , KindSignatures 137 | , LambdaCase 138 | , MultiParamTypeClasses 139 | , PatternGuards 140 | , TupleSections 141 | , TypeFamilies 142 | , TypeOperators 143 | 144 | -- Other library packages from which modules are imported. 145 | build-depends: base >=4.16 && <4.22 146 | , blaze-html >= 0.9 && <1.0 147 | , containers >= 0.6 && <0.8 148 | , directory >=1.3 && <1.4 149 | , mtl >=2.2 && <2.4 150 | , process >=1.6 && <1.7 151 | 152 | -- Directories containing source files. 153 | hs-source-dirs: lib 154 | 155 | -- Base language which the package is written in. 156 | default-language: Haskell2010 157 | 158 | executable syrup 159 | -- Import common warning flags. 160 | import: warnings 161 | 162 | -- .hs or .lhs file containing the Main module. 163 | main-is: Main.hs 164 | 165 | -- Modules included in this executable, other than Main. 166 | -- other-modules: 167 | 168 | -- LANGUAGE extensions used by modules in this package. 169 | -- other-extensions: 170 | 171 | -- Other library packages from which modules are imported. 172 | build-depends: base >=4.16 && <4.22 173 | , syrup 174 | 175 | -- Directories containing source files. 176 | hs-source-dirs: src 177 | 178 | -- Base language which the package is written in. 179 | default-language: Haskell2010 180 | 181 | test-suite golden-tests 182 | type: exitcode-stdio-1.0 183 | hs-source-dirs: test 184 | main-is: Test.hs 185 | build-depends: base >=4.16 && <4.22 186 | , bytestring >= 0.11 && <0.13 187 | , directory >=1.3 && <1.4 188 | , filepath >= 1.4 && <1.6 189 | , tasty >= 1.5 && <1.6 190 | , tasty-golden >=2.3 && <2.4 191 | , syrup 192 | 193 | -- Base language which the package is written in. 194 | default-language: Haskell2010 195 | -------------------------------------------------------------------------------- /emacs/syrup.el: -------------------------------------------------------------------------------- 1 | (require 'compile) 2 | 3 | ;; based on: http://ergoemacs.org/emacs/elisp_syntax_coloring.html 4 | 5 | ;; define several class of keywords 6 | (setq syrup-keywords '("where" "type" "display" "cost")) 7 | (setq syrup-operators '("!" "&" "|")) 8 | (setq syrup-symbols '("=" "," ":" "->" "@" "[" "]")) 9 | 10 | ;; create the regex string for each class of keywords 11 | (setq syrup-keywords-regexp (regexp-opt syrup-keywords 'words)) 12 | (setq syrup-operators-regexp (regexp-opt syrup-operators)) 13 | (setq syrup-symbols-regexp (regexp-opt syrup-symbols)) 14 | (setq syrup-types-regexp "\<[[:alpha:]][[:alnum:]]*\>") 15 | (setq syrup-functions-regexp "\\([[:alpha:]][[:alnum:]]*\\)\(") 16 | (setq syrup-experiments-regexp "\\(experiment\\|type\\|anf\\|simplify\\|print\\|display\\|dnf\\)[[:space:]]+\\([[:alpha:]][[:alnum:]]*\\)") 17 | (setq syrup-bisimulations-regexp "\\(experiment\\)[[:space:]]+\\([[:alpha:]][[:alnum:]]*\\)[[:space:]]+=[[:space:]]+\\([[:alpha:]][[:alnum:]]*\\)") 18 | 19 | ;; clear memory 20 | (setq syrup-keywords nil) 21 | (setq syrup-operators nil) 22 | (setq syrup-symbols nil) 23 | 24 | ;; create the list for font-lock. 25 | ;; each class of keyword is given a particular face 26 | (setq syrup-font-lock-keywords 27 | `( 28 | (,syrup-keywords-regexp . font-lock-keyword-face) 29 | (,syrup-symbols-regexp . font-lock-builtin-face) 30 | (,syrup-operators-regexp . font-lock-builtin-face) 31 | (,syrup-types-regexp . font-lock-type-face) 32 | (,syrup-functions-regexp . (1 font-lock-function-name-face)) 33 | (,syrup-experiments-regexp (1 font-lock-keyword-face) (2 font-lock-function-name-face)) 34 | (,syrup-bisimulations-regexp (1 font-lock-keyword-face) (2 font-lock-function-name-face) (3 font-lock-function-name-face)) 35 | )) 36 | 37 | ;; syntax table 38 | (defvar syrup-syntax-table nil "Syntax table for `syrup-mode'.") 39 | (setq syrup-syntax-table 40 | (let ((synTable (make-syntax-table))) 41 | 42 | ;; comments 43 | (modify-syntax-entry ?- ". 12" synTable) 44 | (modify-syntax-entry ?\n ">" synTable) 45 | 46 | synTable)) 47 | 48 | 49 | ;; define the mode 50 | (define-derived-mode syrup-mode fundamental-mode 51 | "Syrup mode" 52 | ;; handling comments 53 | :syntax-table syrup-syntax-table 54 | ;; code for syntax highlighting 55 | (set-face-attribute 'default nil :height 175) 56 | (setq font-lock-defaults '((syrup-font-lock-keywords))) 57 | (setq mode-name "syrup") 58 | ;; clear memory 59 | (setq syrup-keywords-regexp nil) 60 | (setq syrup-operators-regexp nil) 61 | ;; kill emacs buffer 62 | (setq inhibit-startup-screen t) 63 | (split-window-right)) 64 | 65 | ;; Customisation options 66 | 67 | (defgroup syrup nil 68 | "A language to define circuit diagrams." 69 | :group 'languages) 70 | 71 | (defcustom syrup-command "syrup" 72 | "The path to the syrup command to run." 73 | :type 'string 74 | :group 'syrup) 75 | 76 | (defcustom syrup-options nil 77 | "Command line options to pass to syrup." 78 | :type 'string 79 | :group 'syrup) 80 | 81 | ;; Compilation mode for running syrup 82 | ;; (based on https://spin.atomicobject.com/2016/05/27/write-emacs-package/ ) 83 | 84 | (defun syrup-compilation-filter () 85 | "Filter function for compilation output." 86 | (progn 87 | (ansi-color-apply-on-region compilation-filter-start (point-max)) 88 | (setq buffer-read-only nil) 89 | (setq show-trailing-whitespace nil) 90 | (render-svg))) 91 | 92 | (define-compilation-mode syrup-compilation-mode "Syrup" 93 | "Syrup compilation mode." 94 | (progn 95 | (set (make-local-variable 'compilation-error-regexp-alist) 96 | '(("\\(^[^[:space:]]*\\):\\([0-9]+\\):\\([0-9]+\\)-\\(\\([0-9]+\\):\\)?\\([0-9]+\\)$" 97 | 1 (2 . 5) (3 . 6) 2) 98 | ("^Parse error \\(at\\|near\\) location: \\([^[:space:]]*\\):\\([0-9]+\\):\\([0-9]+\\)" 99 | 2 3 (4 . 5) 2) 100 | ("^Warning: \\([^[:space:]]*\\):\\([0-9]+\\):\\([0-9]+\\)-\\(\\([0-9]+\\):\\)?\\([0-9]+\\)$" 101 | 1 (2 . 5) (3 . 6) 1) 102 | )) 103 | (add-hook 'compilation-filter-hook 'syrup-compilation-filter nil t))) 104 | 105 | (defface syrup-highlight-error-face 106 | '((t (:underline (:color "red" :style wave)))) 107 | "The face used for errors.") 108 | 109 | (defun syrup-run-on-file (syrup-file options) 110 | "Run syrup in a compilation buffer on SYRUP-FILE." 111 | (setq compilation-auto-jump-to-first-error t) 112 | (setq next-error-highlight-timer t) 113 | (setq next-error-highlight t) 114 | (setq syrup-error-highlight (make-overlay (point-min) (point-min))) 115 | (overlay-put syrup-error-highlight 'face 'syrup-highlight-error-face) 116 | (setq compilation-highlight-overlay syrup-error-highlight) 117 | (save-some-buffers compilation-ask-about-save 118 | (when (boundp 'compilation-save-buffers-predicate) 119 | compilation-save-buffers-predicate)) 120 | 121 | (when (get-buffer "*syrup output*") 122 | (kill-buffer "*syrup output*")) 123 | (let ((syrup-command-to-run (concat syrup-command " " options " -f " syrup-file))) 124 | (with-current-buffer (get-buffer-create "*syrup output*") 125 | (compilation-start syrup-command-to-run 'syrup-compilation-mode (lambda (m) (buffer-name))) 126 | (overlay-put (make-overlay (point-min) (point-max) (current-buffer) nil t) 127 | 'face 128 | `(:background "black",:foreground "white", :height 175, :extend t))))) 129 | 130 | ;;;###autoload 131 | (defun syrup-run (override-options) 132 | "Run syrup on the current file." 133 | (interactive "P") 134 | (let ((opts (if override-options (read-string "Options: ") syrup-options))) 135 | (syrup-run-on-file (shell-quote-argument (buffer-file-name)) opts))) 136 | 137 | (define-key syrup-mode-map (kbd "C-c C-l") 'syrup-run) 138 | 139 | (provide 'syrup-mode) 140 | 141 | (defun render-svg-loop () 142 | "Render all svgs in sight" 143 | (interactive) 144 | (progn 145 | (message "starting at %s" (point)) 146 | (let* ((beginRegex "") 148 | (beg) 149 | (end)) 150 | (if (search-forward beginRegex nil t nil) 151 | (progn 152 | (setq beg (- (point) (length beginRegex))) 153 | (message "found beginning at %s" (point)))) 154 | (if (search-forward endRegex nil t nil) 155 | (progn 156 | (setq end (point)) 157 | (message "found end at %s" (point)))) 158 | (if (and beg end (> end beg)) 159 | (progn 160 | (narrow-to-region beg end) 161 | (goto-char beg) 162 | (insert-char ?\n) 163 | (image-mode) 164 | (image-toggle-display) 165 | (goto-char beg) 166 | (delete-char 1) 167 | (image-toggle-display) 168 | (widen) 169 | (goto-char end) 170 | (render-svg-loop)))))) 171 | 172 | (defun recenter-compilation-buffer () 173 | (interactive) 174 | (let ((compilation-buffer (get-buffer "*syrup output*")) 175 | (window)) 176 | (if (null compilation-buffer) 177 | (message "No compilation buffer") 178 | (setq window (display-buffer compilation-buffer)) 179 | (save-selected-window 180 | (select-window window) 181 | (bury-buffer compilation-buffer) 182 | (goto-char (point-max)) 183 | (condition-case nil 184 | (scroll-down (- (/ (window-height) 2) 2)) 185 | (error nil)))))) 186 | 187 | (defun render-svg () 188 | "Render all svgs in sight" 189 | (interactive) 190 | (progn 191 | (goto-char (point-min)) 192 | (render-svg-loop) 193 | (recenter-compilation-buffer))) 194 | -------------------------------------------------------------------------------- /lib/Language/Syrup/Scp.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- Scp: Scopechecking Syrup ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | module Language.Syrup.Scp where 11 | 12 | import Control.Monad (foldM, unless, when, void) 13 | 14 | import Data.Bifunctor () 15 | import Data.Char (toLower) 16 | import Data.Foldable (traverse_) 17 | import Data.Kind (Type) 18 | import Data.Monoid () 19 | 20 | import Language.Syrup.BigArray 21 | import Language.Syrup.Doc 22 | import Language.Syrup.Fdk 23 | import Language.Syrup.Syn 24 | 25 | data Scope = Scope 26 | { global :: Names 27 | , local :: Set String 28 | } 29 | 30 | emptyScope :: Scope 31 | emptyScope = Scope emptyArr emptyArr 32 | 33 | globalScope :: Names -> Scope 34 | globalScope gl = Scope gl emptyArr 35 | 36 | type family VarType (l :: ScopeLevel) :: Type where 37 | VarType Local = String 38 | VarType Global = Name 39 | 40 | newtype Extension (l :: ScopeLevel) = Extend { getExtension :: Set (VarType l) } 41 | 42 | emptyExtension :: Extension l 43 | emptyExtension = Extend emptyArr 44 | 45 | newtype ScopeM a = ScopeM { runScopeM :: ([ScopeError], a) } 46 | deriving (Functor, Applicative, Monad) 47 | 48 | scopeError :: ScopeError -> ScopeM () 49 | scopeError err = ScopeM ([err], ()) 50 | 51 | mergeLocalScope :: Set String -> Set String -> ScopeM (Set String) 52 | mergeLocalScope lc1 lc2 = do 53 | let i = intersectSet lc1 lc2 54 | unless (isEmptyArr i) $ scopeError (Shadowing Local (mapSet Name i)) 55 | pure $ lc1 <> lc2 56 | 57 | mergeGlobalScope :: Names -> Names -> ScopeM Names 58 | mergeGlobalScope lc1 lc2 = do 59 | let i = intersectSet lc1 lc2 60 | unless (isEmptyArr i) $ scopeError (Shadowing Global i) 61 | pure $ lc1 <> lc2 62 | 63 | mergeScope :: Scope -> Scope -> ScopeM Scope 64 | mergeScope (Scope gl1 lc1) (Scope gl2 lc2) = 65 | Scope (gl1 <> gl2) <$> mergeLocalScope lc1 lc2 66 | 67 | class KnownLevel l where 68 | mergeExtension :: Extension l -> Extension l -> ScopeM (Extension l) 69 | extend :: Scope -> Extension l -> Scope 70 | declareVar :: Scope -> VarType l -> ScopeM (Extension l) 71 | 72 | instance KnownLevel 'Local where 73 | mergeExtension (Extend e1) (Extend e2) = Extend <$> mergeLocalScope e1 e2 74 | extend (Scope gl lc) (Extend lce) = Scope gl (lc <> lce) 75 | declareVar ga nm = do 76 | let lc = local ga 77 | if (nm `inSet` lc) 78 | then emptyExtension <$ scopeError (Shadowing Local $ singleton (Name nm)) 79 | else pure (Extend $ singleton nm) 80 | 81 | instance KnownLevel 'Global where 82 | mergeExtension (Extend e1) (Extend e2) = Extend <$> mergeGlobalScope e1 e2 83 | extend (Scope gl lc) (Extend gle) = Scope (gl <> gle) lc 84 | declareVar ga nm = do 85 | let gc = global ga 86 | let e = singleton nm 87 | Extend e <$ when (nm `inSet` gc) (scopeError (Shadowing Global e)) 88 | 89 | hints :: forall a. Ord a => (a -> String) -> (a -> Name) -> Set a -> a -> Names 90 | hints convert embed ga nm = foldMapSet keep ga where 91 | 92 | check = toLower <$> convert nm 93 | 94 | keep :: a -> Names 95 | keep cnd 96 | | map toLower (convert cnd) == check = singleton (embed cnd) 97 | | otherwise = emptyArr 98 | 99 | isLocalVar :: Scope -> String -> ScopeM () 100 | isLocalVar ga nm = do 101 | let lc = local ga 102 | unless (nm `inSet` lc) $ 103 | scopeError $ OutOfScope Local (Name nm) (hints id Name lc nm) 104 | 105 | isGlobalVar :: Scope -> Name -> ScopeM () 106 | isGlobalVar ga nm = do 107 | let gc = global ga 108 | unless (nm `inSet` gc) $ 109 | scopeError $ OutOfScope Global nm (hints getName id gc nm) 110 | 111 | type family Level t :: ScopeLevel where 112 | Level [a] = Level a 113 | Level (Maybe a) = Level a 114 | Level InputName = 'Local 115 | Level Pat = 'Local 116 | Level Eqn = 'Local 117 | Level (DEC' a) = 'Global 118 | Level (Source' a b) = 'Global 119 | -- TODO?: add NoExtension 120 | Level Exp = 'Local 121 | 122 | class Scoped t where 123 | scopecheck :: Scope -- input scope 124 | -> t -- term to analise 125 | -> ScopeM (Extension (Level t)) -- error or scope extension 126 | 127 | -- we do not define the instance `Scoped a => Scoped [a]` because 128 | -- lists of scoped things can have so many different meanings. 129 | -- Here we define simultaneous binding (for patterns) but we may 130 | -- also want: 131 | -- mutual bindings for lists of equations 132 | -- telescopic bindings for lists of declarations 133 | 134 | default scopecheck 135 | :: (t ~ f a, Traversable f, Scoped a, Level t ~ Level a, KnownLevel (Level a)) 136 | => Scope -> t -> ScopeM (Extension (Level t)) 137 | scopecheck ga ts = do 138 | es <- mapM (scopecheck ga) ts 139 | foldM mergeExtension emptyExtension es 140 | 141 | instance (KnownLevel (Level a), Scoped a) => Scoped (Maybe a) 142 | 143 | instance Scoped Pat where 144 | scopecheck ga = \case 145 | PVar _ x -> declareVar ga x 146 | PCab _ ps -> scopecheck ga ps 147 | 148 | instance Scoped Exp where 149 | scopecheck ga = \case 150 | Var _ s -> emptyExtension <$ isLocalVar ga s 151 | Hol _ s -> pure emptyExtension 152 | App _ f es -> do 153 | isGlobalVar ga f 154 | scopecheck ga es 155 | Cab _ es -> scopecheck ga es 156 | 157 | instance Scoped [InputName] 158 | instance Scoped [Pat] 159 | instance Scoped [Exp] 160 | 161 | instance Scoped [Eqn] where 162 | scopecheck ga whr = do 163 | -- all of these are mutually defined so we must check the 164 | -- body of the equations after having bound the declared 165 | -- variables 166 | let (ps, ts) = foldMap (\ (ps :=: ts) -> (ps, ts)) whr 167 | e <- scopecheck ga ps 168 | e <$ scopecheck (ga `extend` e) ts 169 | 170 | instance Scoped Def where 171 | scopecheck ga (Def (nm, lhs) rhs whr) = do 172 | isGlobalVar ga nm 173 | -- bind patterns in the lhs 174 | elhs <- scopecheck ga lhs 175 | let ga' = ga `extend` elhs 176 | -- bind patterns in the where clauses 177 | ewhr <- scopecheck ga' whr 178 | let ga'' = ga' `extend` ewhr 179 | -- check rhs in the extended scope 180 | emptyExtension <$ scopecheck ga'' rhs 181 | scopecheck ga Stub{} = pure emptyExtension 182 | 183 | instance Scoped (DEC' a) where 184 | scopecheck ga (DEC (nm, _) _) = declareVar ga nm 185 | 186 | instance Scoped EXPT where 187 | scopecheck ga = \case 188 | Tabulate nm -> emptyExtension <$ isGlobalVar ga nm 189 | Simulate nm _ _ -> emptyExtension <$ isGlobalVar ga nm 190 | Bisimilarity nm nm' -> do 191 | isGlobalVar ga nm 192 | isGlobalVar ga nm' 193 | pure emptyExtension 194 | UnitTest nm ins outs -> do 195 | isGlobalVar ga nm 196 | pure emptyExtension 197 | Display nms nm -> do 198 | traverse_ (isGlobalVar ga) nms 199 | isGlobalVar ga nm 200 | pure emptyExtension 201 | Dnf nm -> do 202 | isGlobalVar ga nm 203 | pure emptyExtension 204 | Print nm -> do 205 | isGlobalVar ga nm 206 | pure emptyExtension 207 | Typing nm -> do 208 | isGlobalVar ga nm 209 | pure emptyExtension 210 | Anf nm -> do 211 | isGlobalVar ga nm 212 | pure emptyExtension 213 | Costing nms nm -> do 214 | traverse_ (isGlobalVar ga) nms 215 | isGlobalVar ga nm 216 | pure emptyExtension 217 | Simplify nm -> do 218 | isGlobalVar ga nm 219 | pure emptyExtension 220 | FromOutputs f xs bs -> do 221 | void $ scopecheck ga xs 222 | pure emptyExtension 223 | 224 | instance Scoped InputName where 225 | scopecheck ga (InputName x) = declareVar ga x 226 | 227 | instance Scoped (Source' a b) where 228 | scopecheck ga = \case 229 | Declaration d -> scopecheck ga d 230 | TypeAlias{} -> emptyExtension <$ pure () 231 | Definition d -> emptyExtension <$ scopecheck ga d 232 | Experiment e -> emptyExtension <$ scopecheck ga e 233 | 234 | stub :: (Source' a b, String) -> [Feedback] 235 | -> [Either Feedback (Source' a b, String)] 236 | -> [Either Feedback (Source' a b, String)] 237 | stub (Definition (Def (nm, _) _ _), src) msg rst 238 | = Right (Definition (Stub nm msg), src) : rst 239 | stub _ msg rst = map Left msg ++ rst 240 | 241 | check :: Scope 242 | -> [Either Feedback (Source' a b, String)] 243 | -> [Either Feedback (Source' a b, String)] 244 | check ga [] = [] 245 | check ga (Left err : ds) = Left err : check ga ds 246 | check ga (Right (d , src) : ds) = do 247 | let (errs, e) = runScopeM (scopecheck ga d) 248 | let ga' = ga `extend` e 249 | 250 | let status = foldMap categorise errs 251 | let msg = AScopeError <$> errs 252 | case isErroring status of 253 | True -> stub (d, src) msg (check ga' ds) 254 | False -> map Left msg ++ Right (d, src) : check ga' ds 255 | -------------------------------------------------------------------------------- /lib/Language/Syrup/DNF.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- DNF: Disjunctive Normal Forms ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | 9 | module Language.Syrup.DNF where 10 | 11 | import Control.Applicative (liftA2) -- for compatibility 12 | import Control.Monad (guard, join) 13 | import Control.Monad.Reader (MonadReader, runReader) 14 | 15 | import Data.Bifunctor (bimap) 16 | import Data.List (intercalate) 17 | import Data.Maybe (fromMaybe, isJust, fromJust) 18 | import Data.Map (Map) 19 | import qualified Data.Map as Map 20 | import Data.Set (Set) 21 | import qualified Data.Set as Set 22 | 23 | import Language.Syrup.Syn 24 | import Language.Syrup.Ty 25 | 26 | import Utilities.Bwd 27 | 28 | ------------------------------------------------------------------------ 29 | -- Reducing a circuit to Disjunctive Normal Form 30 | ------------------------------------------------------------------------ 31 | 32 | data Occurrence 33 | = Asserted 34 | | Negated 35 | deriving (Eq, Ord) 36 | 37 | negOcc :: Occurrence -> Occurrence 38 | negOcc Asserted = Negated 39 | negOcc Negated = Asserted 40 | 41 | applyOcc :: Occurrence -> DNF -> DNF 42 | applyOcc Asserted e = e 43 | applyOcc Negated e = nae e 44 | 45 | mergeOcc :: Maybe Occurrence -> Maybe Occurrence -> Maybe Occurrence 46 | mergeOcc Nothing b = b 47 | mergeOcc a Nothing = a 48 | mergeOcc (Just a) (Just b) = a <$ guard (a == b) 49 | 50 | type AndClause = Map String Occurrence 51 | newtype DNF = DNF { getDNF :: Set AndClause } 52 | deriving (Eq, Ord) 53 | 54 | instance Show DNF where 55 | show x@(DNF e) 56 | | x == tt = "True" 57 | | x == ff = "False" 58 | | otherwise = unions (Set.toList e) 59 | 60 | where 61 | 62 | unions = intercalate " | " . map (prods . Map.toList) 63 | prods = intercalate " & " . map prod 64 | prod (k, occ) = occurrence occ ++ k 65 | occurrence Asserted = "" 66 | occurrence Negated = "!" 67 | 68 | atom :: String -> Occurrence -> DNF 69 | atom k occ = DNF $ Set.singleton $ Map.singleton k occ 70 | 71 | pos :: String -> DNF 72 | pos k = atom k Asserted 73 | 74 | neg :: String -> DNF 75 | neg k = atom k Negated 76 | 77 | ff :: DNF 78 | ff = DNF Set.empty 79 | 80 | tt :: DNF 81 | tt = DNF $ Set.singleton Map.empty 82 | 83 | (|||) :: DNF -> DNF -> DNF 84 | x@(DNF e) ||| y@(DNF f) 85 | | x == tt = tt 86 | | y == tt = tt 87 | | otherwise = DNF (Set.union e f) 88 | 89 | setMapMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b 90 | setMapMaybe f as 91 | = Set.map fromJust 92 | $ Set.filter isJust 93 | $ Set.map f as 94 | 95 | simpleAnd :: DNF -> DNF -> DNF 96 | simpleAnd (DNF e) (DNF f) = DNF $ 97 | let unions = Set.cartesianProduct e f in 98 | flip setMapMaybe unions $ \ (a, b) -> do 99 | let mprods = Map.unionWith mergeOcc (Just <$> a) (Just <$> b) 100 | let (absurd, prods) = Map.mapEither (maybe (Left ()) Right) mprods 101 | guard (null absurd) 102 | pure $ prods 103 | 104 | (&&&) :: DNF -> DNF -> DNF 105 | e &&& f = noIndependent (simpleAnd e f) 106 | 107 | nae :: DNF -> DNF 108 | nae (DNF e) 109 | = noIndependent 110 | $ Set.foldr simpleAnd tt 111 | $ Set.map (Map.foldr (|||) ff . Map.mapWithKey (\ k -> atom k . negOcc)) e 112 | 113 | noIndependent :: DNF -> DNF 114 | noIndependent x@(DNF e) = fixpoint False (Map.toList <$> Set.toList e) 115 | 116 | where 117 | 118 | -- We are assuming these are sorted, and entries are using distinct 119 | -- strings. Weare looking for something of the shape 120 | -- [X, Y, !Z, !A, S, T] 121 | -- [X, Y, !Z, A, S, T] 122 | -- ^^^ 123 | -- in which case the value of A is independent and we can return the 124 | -- simplified conjunction [X, Y, !Z, S, T] 125 | hasIndependent 126 | :: [(String, Occurrence)] 127 | -> [(String, Occurrence)] 128 | -> Maybe [(String, Occurrence)] 129 | hasIndependent [] [] = Nothing 130 | hasIndependent ((k, occk) : es) ((l, occl) : fs) = do 131 | guard (k == l) 132 | if occk == occl 133 | then ((k, occk) :) <$> hasIndependent es fs 134 | else es <$ guard (es == fs) 135 | hasIndependent _ _ = Nothing 136 | 137 | go :: [[(String, Occurrence)]] -> Either Bool [[(String, Occurrence)]] 138 | go [] = Left False 139 | go ([] : es) = Left True 140 | go (e : es) = case findJust (hasIndependent e) es of 141 | Nothing -> (e:) <$> go es 142 | Just (e', es') -> pure (e' : es') 143 | 144 | fixpoint b es = case go es of 145 | Right forms -> fixpoint True forms 146 | Left True -> tt 147 | Left False | b -> DNF (Set.fromList $ map Map.fromList es) 148 | _ -> x 149 | 150 | -- | Locates the first value that satisfies the predicate 151 | -- and removes it from the list 152 | findJust :: (a -> Maybe b) -> [a] -> Maybe (b, [a]) 153 | findJust p [] = Nothing 154 | findJust p (x : xs) 155 | | Just a <- p x = pure (a, xs) 156 | | otherwise = fmap (x:) <$> findJust p xs 157 | 158 | fromDNF :: forall ty. AllRemarkables ty -> DNF -> Exp' Name ty 159 | fromDNF d 160 | = orClauses 161 | . map andClauses 162 | . Set.toList 163 | . Set.map Map.toList 164 | . getDNF 165 | 166 | where 167 | ty :: ty 168 | ty = bitTypeName d 169 | 170 | orClauses :: [Exp' Name ty] -> Exp' Name ty 171 | orClauses [] = App [ty] (zeroGateName d) [] 172 | orClauses [e] = e 173 | orClauses (e:es) = App [ty] (orGateName d) [e, orClauses es] 174 | 175 | notGate :: Occurrence -> Exp' Name ty -> Exp' Name ty 176 | notGate Asserted e = e 177 | notGate Negated e = App [ty] (notGateName d) [e] 178 | 179 | andClauses :: [(String, Occurrence)] -> Exp' Name ty 180 | andClauses [] = App [ty] (notGateName d) [App [ty] (zeroGateName d) []] 181 | andClauses [(k, occ)] = notGate occ (Var ty k) 182 | andClauses ((k, occ) : es) 183 | = App [ty] (andGateName d) 184 | [notGate occ (Var ty k), andClauses es] 185 | 186 | eval :: (String -> Maybe DNF) -> DNF -> DNF 187 | eval rho 188 | = Set.foldr (|||) ff 189 | . Set.map (flip Map.foldrWithKey tt $ \ k occ -> (&&&) $ case rho k of 190 | Nothing -> atom k occ 191 | Just dnf -> applyOcc occ dnf) 192 | . getDNF 193 | 194 | test :: DNF 195 | test = flip eval (nae (pos "X" &&& neg "Y" ||| pos "Z")) $ \case 196 | "X" -> pure (pos "S" ||| pos "T") 197 | "Z" -> pure (nae (pos "A" &&& neg "B")) 198 | _ -> Nothing 199 | 200 | dnf :: CoEnv -> Def' Name ty -> Def' Name ty 201 | dnf env d@(Def lhs rhs meqns) = fromMaybe d $ do 202 | (ty : _, rhs') <- fmap unzip $ sequence $ runReader (traverse toDNF rhs) env 203 | let sub' = maybe id eval $ toAssignment env =<< meqns 204 | d <- allRemarkables env ty 205 | let rhs'' = fromDNF d <$> (sub' <$> rhs') 206 | pure (Def lhs rhs'' Nothing) 207 | dnf env d = d 208 | 209 | toAssignment :: CoEnv -> [Eqn' Name ty] -> Maybe (String -> Maybe DNF) 210 | toAssignment env eqns = do 211 | kvs <- flip traverse eqns $ \case 212 | ([PVar _ x] :=: [b]) -> pure (x, fmap snd $ runReader (toDNF b) env) 213 | _ -> Nothing 214 | pure (join . flip lookup kvs) 215 | 216 | toDNF :: MonadReader CoEnv m => Exp' Name ty -> m (Maybe (ty, DNF)) 217 | toDNF (Var ty x) = pure (Just (ty, pos x)) 218 | toDNF Cab{} = pure Nothing 219 | toDNF Hol{} = pure Nothing 220 | toDNF (App [ty] fn [e]) = isRemarkable fn >>= \case 221 | Just IsNotGate -> do 222 | ce <- fmap snd <$> toDNF e 223 | pure $ (ty,) . nae <$> ce 224 | _ -> pure Nothing 225 | toDNF (App [ty] fn [e,f]) = isRemarkable fn >>= \case 226 | Just IsOrGate -> do 227 | ce <- fmap snd <$> toDNF e 228 | cf <- fmap snd <$> toDNF f 229 | pure $ (ty,) <$> liftA2 (|||) ce cf 230 | Just IsAndGate -> do 231 | ce <- fmap snd <$> toDNF e 232 | cf <- fmap snd <$> toDNF f 233 | pure $ (ty,) <$> liftA2 (&&&) ce cf 234 | _ -> pure Nothing 235 | toDNF App{} = pure Nothing 236 | 237 | ------------------------------------------------------------------------ 238 | -- Producing a DNF circuit from a truth table 239 | ------------------------------------------------------------------------ 240 | 241 | -- The output of a truth table can be understood like 242 | -- a decision tree 243 | data Decision 244 | = Always Bool 245 | | Inspect String Decision Decision 246 | deriving Show 247 | 248 | evaluate :: (String -> Bool) -- a meaning for variable names 249 | -> Decision -- a decision tree 250 | -> Bool -- the associated output 251 | evaluate env = \case 252 | Always b -> b 253 | Inspect x false true 254 | | env x -> evaluate env true 255 | | otherwise -> evaluate env false 256 | 257 | unriffle :: [a] -> Maybe ([a], [a]) 258 | unriffle [] = pure ([], []) 259 | unriffle (l : r : xs) = bimap (l :) (r :) <$> unriffle xs 260 | unriffle _ = Nothing 261 | 262 | ttToDecision :: [String] -> [Bool] -> Maybe Decision 263 | ttToDecision xs = go (Lin <>< xs) . map Always where 264 | 265 | go :: Bwd String -> [Decision] 266 | -> Maybe Decision 267 | go Lin [d] = pure d 268 | go (sx :< x) ds = do 269 | (dsxF, dsxT) <- unriffle ds 270 | go sx (zipWith (Inspect x) dsxF dsxT) 271 | go _ _ = Nothing 272 | 273 | decisionToDNF :: Decision -> DNF 274 | decisionToDNF (Always b) = if b then tt else ff 275 | decisionToDNF (Inspect x dxF dxT) 276 | = (neg x &&& decisionToDNF dxF) 277 | ||| (pos x &&& decisionToDNF dxT) 278 | 279 | ttToDef :: CoEnv -> Name -> [String] -> [Bool] -> Maybe TypedDef 280 | ttToDef env f xs bs = do 281 | dnf <- decisionToDNF <$> ttToDecision xs bs 282 | let bit = Bit Unit 283 | rmk <- allRemarkables env bit 284 | let exp = fromDNF rmk dnf 285 | pure (Def (f, map (PVar bit) xs) [exp] Nothing) 286 | -------------------------------------------------------------------------------- /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' '--no-cabal-check' '--no-benchmarks' '--no-haddock' 'syrup.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250917 12 | # 13 | # REGENDATA ("0.19.20250917",["github","--no-cabal-check","--no-benchmarks","--no-haddock","syrup.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | concurrency: 19 | group: ${{ github.workflow }}-${{ github.ref }} 20 | cancel-in-progress: true 21 | env: 22 | ACTIONS_ALLOW_USE_UNSECURE_NODE_VERSION: true 23 | jobs: 24 | linux: 25 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 26 | runs-on: ubuntu-24.04 27 | timeout-minutes: 28 | 60 29 | container: 30 | image: buildpack-deps:jammy 31 | continue-on-error: ${{ matrix.allow-failure }} 32 | strategy: 33 | matrix: 34 | include: 35 | - compiler: ghc-9.12.2 36 | compilerKind: ghc 37 | compilerVersion: 9.12.2 38 | setup-method: ghcup 39 | allow-failure: false 40 | - compiler: ghc-9.10.2 41 | compilerKind: ghc 42 | compilerVersion: 9.10.2 43 | setup-method: ghcup 44 | allow-failure: false 45 | - compiler: ghc-9.8.2 46 | compilerKind: ghc 47 | compilerVersion: 9.8.2 48 | setup-method: ghcup 49 | allow-failure: false 50 | - compiler: ghc-9.6.4 51 | compilerKind: ghc 52 | compilerVersion: 9.6.4 53 | setup-method: ghcup 54 | allow-failure: false 55 | - compiler: ghc-9.4.8 56 | compilerKind: ghc 57 | compilerVersion: 9.4.8 58 | setup-method: ghcup 59 | allow-failure: false 60 | - compiler: ghc-9.2.8 61 | compilerKind: ghc 62 | compilerVersion: 9.2.8 63 | setup-method: ghcup 64 | allow-failure: false 65 | fail-fast: false 66 | steps: 67 | - name: apt-get install 68 | run: | 69 | apt-get update 70 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 71 | apt-get install -y graphviz 72 | - name: Install GHCup 73 | run: | 74 | mkdir -p "$HOME/.ghcup/bin" 75 | curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup" 76 | chmod a+x "$HOME/.ghcup/bin/ghcup" 77 | - name: Install cabal-install 78 | run: | 79 | "$HOME/.ghcup/bin/ghcup" install cabal 3.16.0.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 80 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.16.0.0 -vnormal+nowrap" >> "$GITHUB_ENV" 81 | - name: Install GHC (GHCup) 82 | if: matrix.setup-method == 'ghcup' 83 | run: | 84 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 85 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 86 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 87 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 88 | echo "HC=$HC" >> "$GITHUB_ENV" 89 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 90 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 91 | env: 92 | HCKIND: ${{ matrix.compilerKind }} 93 | HCNAME: ${{ matrix.compiler }} 94 | HCVER: ${{ matrix.compilerVersion }} 95 | - name: Set PATH and environment variables 96 | run: | 97 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 98 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 99 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 100 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 101 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 102 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 103 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 104 | echo "ARG_BENCH=--disable-benchmarks" >> "$GITHUB_ENV" 105 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 106 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 107 | env: 108 | HCKIND: ${{ matrix.compilerKind }} 109 | HCNAME: ${{ matrix.compiler }} 110 | HCVER: ${{ matrix.compilerVersion }} 111 | - name: env 112 | run: | 113 | env 114 | - name: write cabal config 115 | run: | 116 | mkdir -p $CABAL_DIR 117 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 150 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 151 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 152 | rm -f cabal-plan.xz 153 | chmod a+x $HOME/.cabal/bin/cabal-plan 154 | cabal-plan --version 155 | - name: checkout 156 | uses: actions/checkout@v5 157 | with: 158 | path: source 159 | - name: initial cabal.project for sdist 160 | run: | 161 | touch cabal.project 162 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 163 | cat cabal.project 164 | - name: sdist 165 | run: | 166 | mkdir -p sdist 167 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 168 | - name: unpack 169 | run: | 170 | mkdir -p unpacked 171 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 172 | - name: generate cabal.project 173 | run: | 174 | PKGDIR_syrup="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/syrup-[0-9.]*')" 175 | echo "PKGDIR_syrup=${PKGDIR_syrup}" >> "$GITHUB_ENV" 176 | rm -f cabal.project cabal.project.local 177 | touch cabal.project 178 | touch cabal.project.local 179 | echo "packages: ${PKGDIR_syrup}" >> cabal.project 180 | echo "package syrup" >> cabal.project 181 | echo " ghc-options: -Werror=missing-methods -Werror=missing-fields" >> cabal.project 182 | if [ $((HCNUMVER >= 90400)) -ne 0 ] ; then echo "package syrup" >> cabal.project ; fi 183 | if [ $((HCNUMVER >= 90400)) -ne 0 ] ; then echo " ghc-options: -Werror=unused-packages" >> cabal.project ; fi 184 | echo "package syrup" >> cabal.project 185 | # echo " ghc-options: -Werror=incomplete-patterns -Werror=incomplete-uni-patterns" >> cabal.project 186 | cat >> cabal.project <> cabal.project.local 189 | cat cabal.project 190 | cat cabal.project.local 191 | - name: dump install plan 192 | run: | 193 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 194 | cabal-plan 195 | - name: restore cache 196 | uses: actions/cache/restore@v4 197 | with: 198 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 199 | path: ~/.cabal/store 200 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 201 | - name: install dependencies 202 | run: | 203 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 204 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 205 | - name: build w/o tests 206 | run: | 207 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 208 | - name: build 209 | run: | 210 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 211 | - name: tests 212 | run: | 213 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 214 | - name: unconstrained build 215 | run: | 216 | rm -f cabal.project.local 217 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 218 | - name: save cache 219 | if: always() 220 | uses: actions/cache/save@v4 221 | with: 222 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 223 | path: ~/.cabal/store 224 | -------------------------------------------------------------------------------- /lib/Language/Syrup/BigArray.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | 6 | module Language.Syrup.BigArray where 7 | 8 | import Control.Applicative ((<|>), Const(Const, getConst)) 9 | 10 | import Data.Functor.Identity (Identity(Identity, runIdentity)) 11 | import Data.Monoid (All(All, getAll), Endo(Endo, appEndo), Sum(Sum, getSum)) 12 | import Data.Traversable (foldMapDefault, fmapDefault) 13 | import Data.Kind (Type) 14 | 15 | import Utilities.Nat 16 | import Utilities.Lens (Has(..)) 17 | 18 | 19 | data Bnd k = Bot | Key k | Top deriving (Ord, Eq, Show) 20 | 21 | data T23 (n :: Nat) (k :: Type) (v :: Type) where 22 | Leaf :: T23 Ze k v 23 | Node2 :: T23 n k v -> (k, v) -> T23 n k v -> T23 (Su n) k v 24 | Node3 :: T23 n k v -> (k, v) -> T23 n k v -> (k, v) -> T23 n k v -> T23 (Su n) k v 25 | deriving instance (Show k, Show v) => Show (T23 n k v) 26 | 27 | instance Functor (T23 n k) where 28 | fmap f Leaf = Leaf 29 | fmap f (Node2 l (k, v) r) = Node2 (fmap f l) (k, f v) (fmap f r) 30 | fmap f (Node3 l (j, u) m (k, v) r) = 31 | Node3 (fmap f l) (j, f u) (fmap f m) (k, f v) (fmap f r) 32 | 33 | data I23 n k v where 34 | Level :: T23 n k v -> I23 n k v 35 | Grow2 :: T23 n k v -> (k, v) -> T23 n k v -> I23 n k v 36 | 37 | find23 :: Ord k => k -> T23 n k v -> Maybe v 38 | find23 k Leaf = Nothing 39 | find23 k (Node2 lj (j, jv) ju) = case compare k j of 40 | LT -> find23 k lj 41 | EQ -> Just jv 42 | GT -> find23 k ju 43 | find23 k (Node3 li (i, iv) ij (j, jv) ju) = case (compare k i, compare k j) of 44 | (LT, _) -> find23 k li 45 | (EQ, _) -> Just iv 46 | (_, LT) -> find23 k ij 47 | (_, EQ) -> Just jv 48 | (_, GT) -> find23 k ju 49 | 50 | insert23 :: Ord k => (k, v) -> T23 n k v -> I23 n k v 51 | insert23 iv Leaf = Grow2 Leaf iv Leaf 52 | insert23 iv@(i, _) (Node2 lj jv@(j, _) ju) = 53 | case compare i j of 54 | LT -> case insert23 iv lj of 55 | Grow2 lh hv hj -> Level (Node3 lh hv hj jv ju) 56 | Level lj -> Level (Node2 lj jv ju) 57 | EQ -> Level (Node2 lj iv ju) 58 | GT -> case insert23 iv ju of 59 | Grow2 jk kv ku -> Level (Node3 lj jv jk kv ku) 60 | Level ju -> Level (Node2 lj jv ju) 61 | insert23 iv@(i, _) (Node3 lj jv@(j, _) jk kv@(k, _) ku) = 62 | case (compare i j, compare i k) of 63 | (LT, _) -> case insert23 iv lj of 64 | Grow2 lh hv hj -> Grow2 (Node2 lh hv hj) jv (Node2 jk kv ku) 65 | Level lj -> Level (Node3 lj jv jk kv ku) 66 | (EQ, _) -> Level (Node3 lj iv jk kv ku) 67 | (_, LT) -> case insert23 iv jk of 68 | Grow2 jh hv hk -> Grow2 (Node2 lj jv jh) hv (Node2 hk kv ku) 69 | Level jk -> Level (Node3 lj jv jk kv ku) 70 | (_, EQ) -> Level (Node3 lj jv jk iv ku) 71 | (_, GT) -> case insert23 iv ku of 72 | Grow2 kh hv hu -> Grow2 (Node2 lj jv jk) kv (Node2 kh hv hu) 73 | Level ku -> Level (Node3 lj jv jk kv ku) 74 | 75 | anoin23 :: Ord k => T23 n k v -> T23 n k v -> I23 n k v 76 | anoin23 Leaf Leaf = Level Leaf 77 | anoin23 (Node2 ai i' im) (Node2 mr r' rz) = case anoin23 im mr of 78 | Level ir -> Level (Node3 ai i' ir r' rz) 79 | Grow2 im m' mr -> Grow2 (Node2 ai i' im) m' (Node2 mr r' rz) 80 | anoin23 (Node2 ai i' im) (Node3 mp p' pu u' uz) = case anoin23 im mp of 81 | Level ip -> Grow2 (Node2 ai i' ip) p' (Node2 pu u' uz) 82 | Grow2 im m' mp -> Grow2 (Node2 ai i' im) m' (Node3 mp p' pu u' uz) 83 | anoin23 (Node3 ag g' gj j' jm) (Node2 mr r' rz) = case anoin23 jm mr of 84 | Level jr -> Grow2 (Node2 ag g' gj) j' (Node2 jr r' rz) 85 | Grow2 jm m' mr -> Grow2 (Node3 ag g' gj j' jm) m' (Node2 mr r' rz) 86 | anoin23 (Node3 ag g' gj j' jm) (Node3 mp p' pu u' uz) = case anoin23 jm mp of 87 | Level jp -> Grow2 (Node2 ag g' gj) j' (Node3 jp p' pu u' uz) 88 | Grow2 jm m' mp -> Grow2 (Node3 ag g' gj j' jm) m' (Node3 mp p' pu u' uz) 89 | 90 | data D23 n k v where 91 | DSame :: T23 n k v -> D23 n k v 92 | DDrop :: T23 n k v -> D23 (Su n) k v 93 | 94 | i2dSu :: I23 n k v -> D23 (Su n) k v 95 | i2dSu (Level t) = DDrop t 96 | i2dSu (Grow2 li i' iu) = DSame (Node2 li i' iu) 97 | 98 | dtNode :: D23 n k v -> (k, v) -> T23 n k v -> D23 (Su n) k v 99 | dtNode (DSame am) m' mz = DSame (Node2 am m' mz) 100 | dtNode (DDrop am) m' (Node2 mr r' rz) = DDrop (Node3 am m' mr r' rz) 101 | dtNode (DDrop am) m' (Node3 mp p' ps s' sz) = 102 | DSame (Node2 (Node2 am m' mp) p' (Node2 ps s' sz)) 103 | 104 | tdNode :: T23 n k v -> (k, v) -> D23 n k v -> D23 (Su n) k v 105 | tdNode am m' (DSame mz) = DSame (Node2 am m' mz) 106 | tdNode (Node2 af f' fm) m' (DDrop mz) = DDrop (Node3 af f' fm m' mz) 107 | tdNode (Node3 ad d' dh h' hm) m' (DDrop mz) = 108 | DSame (Node2 (Node2 ad d' dh) h' (Node2 hm m' mz)) 109 | 110 | delete23 :: Ord k => k -> T23 n k v -> D23 n k v 111 | delete23 k Leaf = DSame Leaf 112 | delete23 k (Node2 ai i' iz) = case compare k (fst i') of 113 | LT -> dtNode (delete23 k ai) i' iz 114 | EQ -> i2dSu (anoin23 ai iz) 115 | GT -> tdNode ai i' (delete23 k iz) 116 | delete23 k (Node3 ai i' ip p' pz) = case (compare k (fst i'), compare k (fst p')) of 117 | (LT, _) -> case delete23 k ai of 118 | DSame ai -> DSame (Node3 ai i' ip p' pz) 119 | DDrop ai -> case ip of 120 | Node2 im m' mp -> 121 | DSame (Node2 (Node3 ai i' im m' mp) p' pz) 122 | Node3 il l' ln n' np -> 123 | DSame (Node3 (Node2 ai i' il) l' (Node2 ln n' np) p' pz) 124 | (EQ, _) -> case anoin23 ai ip of 125 | Level ap -> DSame (Node2 ap p' pz) 126 | Grow2 ai i' ip -> DSame (Node3 ai i' ip p' pz) 127 | (_, LT) -> case delete23 k ip of 128 | DSame ip -> DSame (Node3 ai i' ip p' pz) 129 | DDrop ip -> case pz of 130 | Node2 pt t' tz -> DSame (Node2 ai i' (Node3 ip p' pt t' tz)) 131 | Node3 pr r' ru u' uz -> 132 | DSame (Node3 ai i' (Node2 ip p' pr) r' (Node2 ru u' uz)) 133 | (_, EQ) -> case anoin23 ip pz of 134 | Level iz -> DSame (Node2 ai i' iz) 135 | Grow2 ip p' pz -> DSame (Node3 ai i' ip p' pz) 136 | (_, GT) -> case delete23 k pz of 137 | DSame pz -> DSame (Node3 ai i' ip p' pz) 138 | DDrop pz -> case ip of 139 | Node2 im m' mp -> 140 | DSame (Node2 ai i' (Node3 im m' mp p' pz)) 141 | Node3 il l' ln n' np -> 142 | DSame (Node3 ai i' (Node2 il l' ln) n' (Node2 np p' pz)) 143 | 144 | data Arr (k :: Type)(v :: Type) where 145 | Arr :: T23 n k v -> Arr k v 146 | deriving instance (Show k, Show v) => Show (Arr k v) 147 | 148 | emptyArr :: Arr k v 149 | emptyArr = Arr Leaf 150 | 151 | sizeArr :: Arr k v -> Int 152 | sizeArr = getSum . foldMapArr (const (Sum 1)) 153 | 154 | insertArr :: Ord k => (k, v) -> Arr k v -> Arr k v 155 | insertArr iv (Arr lu) = case insert23 iv lu of 156 | Level lu -> Arr lu 157 | Grow2 lj jv ju -> Arr (Node2 lj jv ju) 158 | 159 | findArr :: Ord k => k -> Arr k v -> Maybe v 160 | findArr k (Arr lu) = find23 k lu 161 | 162 | deleteArr :: Ord k => k -> Arr k v -> Arr k v 163 | deleteArr k (Arr lu) = case delete23 k lu of 164 | DSame lu -> Arr lu 165 | DDrop lu -> Arr lu 166 | 167 | single :: Ord k => (k, v) -> Arr k v 168 | single x = insertArr x emptyArr 169 | 170 | isEmptyArr :: Arr k v -> Bool 171 | isEmptyArr (Arr Leaf) = True 172 | isEmptyArr _ = False 173 | 174 | travT23 :: Applicative f => ((k, v) -> f w) -> T23 n k v -> f (T23 n k w) 175 | travT23 f Leaf = pure Leaf 176 | travT23 f (Node2 l x@(k, _) r) = Node2 <$> travT23 f l <*> ((,) k <$> f x) <*> travT23 f r 177 | travT23 f (Node3 l x@(j, _) m y@(k, _) r) = 178 | Node3 <$> travT23 f l <*> ((,) j <$> f x) <*> travT23 f m <*> ((,) k <$> f y) <*> travT23 f r 179 | 180 | travArr :: Applicative f => ((k, v) -> f w) -> Arr k v -> f (Arr k w) 181 | travArr f (Arr t) = Arr <$> travT23 f t 182 | 183 | imapArr :: ((k, v) -> w) -> Arr k v -> Arr k w 184 | imapArr f = runIdentity . travArr (Identity . f) 185 | 186 | foldMapArr :: Monoid x => ((k, v) -> x) -> Arr k v -> x 187 | foldMapArr f = getConst . travArr (Const . f) 188 | 189 | foldMapSet :: Monoid y => (x -> y) -> Set x -> y 190 | foldMapSet f = foldMapArr (f . fst) 191 | 192 | instance (Ord k, Semigroup v) => Semigroup (Arr k v) where (<>) = mappend 193 | instance (Ord k, Semigroup v) => Monoid (Arr k v) where 194 | mempty = emptyArr 195 | mappend l r = appEndo (foldMapArr up l) r where 196 | up (k, v) = Endo $ \ r -> case findArr k r of 197 | Just w -> insertArr (k, v <> w) r 198 | Nothing -> insertArr (k, v) r 199 | 200 | type Set x = Arr x () 201 | 202 | mapSet :: Ord y => (x -> y) -> Set x -> Set y 203 | mapSet f = foldMapSet (singleton . f) 204 | 205 | domain :: Ord k => Arr k v -> Set k 206 | domain = runIdentity . travArr (\ (k, _) -> Identity ()) 207 | 208 | inSet :: Ord x => x -> Set x -> Bool 209 | inSet x s = case findArr x s of 210 | Just _ -> True 211 | _ -> False 212 | 213 | singleton :: Ord x => x -> Set x 214 | singleton = single . flip (,) () 215 | 216 | leftmostArr :: Arr k v -> Maybe k 217 | leftmostArr (Arr t) = go t where 218 | go :: T23 n k v -> Maybe k 219 | go Leaf = Nothing 220 | go (Node2 l (k, _) _) = go l <|> Just k 221 | go (Node3 l (k, _) _ _ _) = go l <|> Just k 222 | 223 | rightmostArr :: Arr k v -> Maybe k 224 | rightmostArr (Arr t) = go t where 225 | go :: T23 n k v -> Maybe k 226 | go Leaf = Nothing 227 | go (Node2 _ (k, _) r) = go r <|> Just k 228 | go (Node3 _ _ _ (k, _) r) = go r <|> Just k 229 | 230 | popArr :: Ord k => Arr k v -> Maybe ((k, v), Arr k v) 231 | popArr arr@(Arr t23) = case t23 of 232 | Leaf -> Nothing 233 | Node2 _ kv@(k, _) _ -> Just (kv, deleteArr k arr) 234 | Node3 _ kv@(k, _) _ _ _ -> Just (kv, deleteArr k arr) 235 | 236 | intersectSet :: Ord x => Set x -> Set x -> Set x 237 | intersectSet xs = 238 | foldMapArr (\ (y, ()) -> if inSet y xs then singleton y else mempty) 239 | 240 | subSet :: Ord x => Set x -> Set x -> Bool 241 | subSet xs ys = getAll (foldMapSet (All . (`inSet` ys)) xs) 242 | 243 | diffSet :: Ord x => Set x -> Set x -> Set x 244 | diffSet xs ys = 245 | foldMapSet (\ x -> if x `inSet` ys then mempty else singleton x) xs 246 | 247 | setElt :: Set x -> Maybe x 248 | setElt (Arr Leaf) = Nothing 249 | setElt (Arr (Node2 _ (k, _) _)) = Just k 250 | setElt (Arr (Node3 _ (k, _) _ _ _)) = Just k 251 | 252 | instance Traversable (Arr k) where traverse f = travArr (f . snd) 253 | instance Foldable (Arr k) where foldMap = foldMapDefault 254 | instance Functor (Arr k) where fmap = fmapDefault 255 | instance Has (Arr a b) (Arr a b) where hasLens = id 256 | -------------------------------------------------------------------------------- /lib/Language/Syrup/Fdk.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- Fdk: Feedback for Syrup ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | {-# LANGUAGE OverloadedStrings #-} 8 | 9 | module Language.Syrup.Fdk 10 | ( module Language.Syrup.Fdk 11 | , module Language.Syrup.Fdk.Base 12 | ) where 13 | 14 | import Prelude hiding (div, id, unwords) 15 | 16 | import Control.Monad.Writer (MonadWriter, tell) 17 | 18 | import Data.Foldable (fold) 19 | import Data.List (intercalate, intersperse) 20 | import Data.Sequence (Seq) 21 | import qualified Data.Sequence as Seq 22 | import Data.Void (Void, absurd) 23 | 24 | import Language.Syrup.BigArray (isEmptyArr, foldMapSet) 25 | import Language.Syrup.Doc 26 | import Language.Syrup.Fdk.Base 27 | import Language.Syrup.Opt (Options(..), quiet) 28 | import Language.Syrup.Pretty 29 | import Language.Syrup.Syn.Base 30 | 31 | import Language.Syrup.Utils (($$), be, plural, oxfordList) 32 | 33 | import Text.Blaze.Html5 (Html) 34 | import qualified Text.Blaze.Html5 as Html 35 | 36 | instance Pretty ScopeError where 37 | type PrettyDoc ScopeError = Doc 38 | prettyPrec _ e = case e of 39 | OutOfScope l n ns -> 40 | let names = foldMapSet pure ns in 41 | aLine $$ 42 | [ "You tried to use ", pretty n 43 | , " but it is not in scope." ] 44 | <> if isEmptyArr ns then mempty else aLine $$ 45 | [ plural names "Did you mean" " one of these" 46 | , ": " 47 | , csep $ map pretty names 48 | , "?" 49 | ] 50 | Shadowing l ns -> 51 | let names = foldMapSet pure ns in 52 | aLine $$ 53 | [ "You are redefining the " 54 | , pretty (levelMsg l) 55 | , " ", plural names "variable" "s" 56 | , " ", csep $ map pretty names 57 | , "." 58 | ] 59 | 60 | anExperiment :: MonadWriter (Seq Feedback) m => LineDoc -> [Name] -> Doc -> m () 61 | anExperiment str xs ls = tell $ Seq.singleton $ AnExperiment str xs ls 62 | 63 | keep :: Options -> Feedback -> Bool 64 | keep opts fdk 65 | = not (quiet opts) 66 | || (categorise fdk /= Comment 67 | && case fdk of { AStubbedOut{} -> False; _ -> True }) 68 | 69 | groupFeedback :: [Feedback] -> [Feedback] 70 | groupFeedback (ACircuitDefined cs : ACircuitDefined es : rest) = 71 | groupFeedback (ACircuitDefined (cs ++ es) : rest) 72 | groupFeedback (ATypeDefined cs : ATypeDefined es : rest) = 73 | groupFeedback (ATypeDefined (cs ++ es) : rest) 74 | groupFeedback (fdk : rest) = fdk : groupFeedback rest 75 | groupFeedback [] = [] 76 | 77 | instance Pretty [Feedback] where 78 | type PrettyDoc [Feedback] = Doc 79 | prettyPrec _ = foldMap pretty . groupFeedback 80 | 81 | identifier :: Name -> LineDoc 82 | identifier = isCode . pretty 83 | 84 | tyIdentifier :: TyName -> LineDoc 85 | tyIdentifier = isCode . pretty 86 | 87 | instance Pretty Feedback where 88 | type PrettyDoc Feedback = Doc 89 | prettyPrec _ e = structure (StatusBlock $ categorise e) $ go e 90 | 91 | where 92 | 93 | go :: Feedback -> Doc 94 | go = \case 95 | AnImpossibleError str -> prettyBlock $$ 96 | ["The IMPOSSIBLE has happened: ", str, "."] 97 | ACouldntFindCircuitDiagram nm -> aLine $$ 98 | ["Could not find the diagram for the circuit ", identifier nm, "."] 99 | ACannotDisplayStub nm -> aLine $$ 100 | ["Cannot display a diagram for the stubbed out circuit ", identifier nm, "."] 101 | 102 | AnExperiment d x ls -> 103 | aLine (fold [d, " ", punctuate ", " (identifier <$> x), ":"]) 104 | <> nest 2 ls 105 | 106 | ADotGraph xs x ls -> 107 | aLine $$ ["Displaying ", identifier x, extra, ":"] 108 | <> structure (GraphBlock ls) [] 109 | where extra = case xs of 110 | [] -> "" 111 | _ -> fold [" (with ", punctuate ", " (map identifier xs), " unfolded)"] 112 | 113 | AFoundHoles f ls -> 114 | aLine $$ ["Found holes in circuit ", identifier f, ":"] 115 | <> nest 2 (foldMap pretty ls) 116 | ALint ls -> ls 117 | 118 | ANoExecutable exe -> aLine $$ 119 | [ "Could not find the ", isCode (pretty exe), " executable." ] 120 | AnSVGGraph xs x ls -> 121 | aLine $$ ["Displaying ", identifier x, extra, ":"] 122 | <> foldMap prettyBlock ls 123 | where extra = case xs of 124 | [] -> "" 125 | _ -> fold [" (with ", csep (map identifier xs), " unfolded)"] 126 | ASuccessfulUnitTest -> aLine "Success!" 127 | ARawCode str x ls -> 128 | aLine $$ [ str, " ", identifier x, ":" ] 129 | <> nest 2 (structure RawCodeBlock ls) 130 | ATruthTable x ls -> 131 | aLine $$ ["Truth table for ", identifier x, ":" ] 132 | <> nest 2 (structure PreBlock $ foldMap prettyBlock ls) 133 | AnUnreasonablyLargeExperiment lim size x -> aLine $$ 134 | [ "Gave up on experimenting on ", identifier x 135 | , " due to its size (", pretty size 136 | , " but the limit is ", pretty lim,")." 137 | ] 138 | ASyntaxError ls -> ls 139 | AScopeError ls -> pretty ls 140 | ACircuitDefined cs -> aLine $ punctuate " " 141 | [ plural cs "Circuit" "s" 142 | , oxfordList (map identifier cs) 143 | , be cs 144 | , "defined." 145 | ] 146 | ATypeDefined ts -> aLine $ punctuate " " 147 | [ plural ts "Type" "s" 148 | , oxfordList (map tyIdentifier ts) 149 | , be ts 150 | , "defined." 151 | ] 152 | AStubbedOut nm -> aLine $$ 153 | [ "Circuit ", identifier nm, " has been stubbed out." ] 154 | ATypeError ls -> ls 155 | AnUnknownIdentifier x -> aLine $$ 156 | [ "I don't know what ", identifier x, " is." ] 157 | AMissingImplementation x -> aLine $$ 158 | [ "I don't have an implementation for ", identifier x, "." ] 159 | AnAmbiguousDefinition f zs -> 160 | aLine $$ [ "I don't know which of the following is your preferred ", identifier f, ":" ] 161 | <> nest 2 (foldMap (structure PreBlock . foldMap prettyBlock) zs) 162 | AnUndefinedCircuit f -> aLine $$ 163 | [ "You haven't defined the circuit ", identifier f, " just now." ] 164 | AnUndeclaredCircuit f -> aLine $$ 165 | [ "You haven't declared the circuit ", identifier f, " just now." ] 166 | AnUndefinedType x -> aLine $$ 167 | [ "You haven't defined the type ", tyIdentifier x, " just now." ] 168 | AnInvalidTruthTableOutput f -> aLine $$ 169 | [ "Invalid truth table output for ", identifier f, "." ] 170 | AnIllTypedInputs x iTys is -> 171 | aLine $$ 172 | [ "Inputs for ", identifier x, " are typed " 173 | , isCode (pretty $ ATuple iTys), "." 174 | ] 175 | <> aLine $$ 176 | [ "That can't accept ", isCode (parens $$ map pretty is), "." 177 | ] 178 | AnIllTypedMemory x mTys m0 -> 179 | aLine $$ 180 | [ "Memory for ", identifier x, " has type " 181 | , isCode (pretty $ ASet mTys), "." 182 | ] 183 | <> aLine $$ 184 | [ "That can't store ", braces $$ (map pretty m0) ,"." 185 | ] 186 | AnIllTypedOutputs x oTys os -> 187 | aLine $$ 188 | [ "Outputs for ", identifier x, " are typed " 189 | , isCode (csep $ map pretty oTys), "." 190 | ] 191 | <> aLine $$ 192 | [ "That can't accept " 193 | , isCode (csep $ map pretty os), "." 194 | ] 195 | AWrongFinalMemory mo mo' -> 196 | aLine $$ 197 | [ "Wrong final memory: expected " 198 | , isCode (braces $$ map pretty mo) 199 | , " but got " 200 | , isCode (braces $$ map pretty mo') 201 | , "." ] 202 | AWrongOutputSignals os os' -> 203 | aLine $$ 204 | [ "Wrong output signals: expected " 205 | , isCode (parens $$ map pretty os) 206 | , " but got " 207 | , isCode (parens $$ map pretty os') 208 | , "." ] 209 | 210 | WhenUnitTesting x is os fdks -> 211 | aLine $$ 212 | [ "When unit testing " 213 | , isCode $$ 214 | [ pretty x 215 | , pretty (circuitConfig True is), " = " 216 | , pretty (circuitConfig False os)] 217 | , ":"] 218 | <> nest 2 (foldMap go fdks) 219 | WhenDisplaying f fdks -> 220 | aLine $$ 221 | [ "When displaying ", identifier f, ":" ] 222 | <> nest 2 (foldMap go fdks) 223 | 224 | feedbackText :: [Feedback] -> [String] 225 | feedbackText 226 | = renderToString 227 | . fold 228 | . intersperse (aLine "") 229 | . map pretty 230 | . groupFeedback 231 | 232 | feedbackHtml :: [Feedback] -> Html 233 | feedbackHtml = (headerHtml <>) . renderToHtml . pretty 234 | 235 | where 236 | headerHtml :: Html 237 | headerHtml = (<> "\n") $ Html.style $ Html.toHtml $ unlines 238 | [ "" 239 | , " .syrup-code {" 240 | , " display: block;" 241 | , " font-family: monospace;" 242 | , " font-size: 17px;" 243 | , " white-space: pre;" 244 | , " margin: 1em 0;" 245 | , " }" 246 | , " .syrup-happy:before {" 247 | , " content: \"\\2705\";" 248 | , " padding: 0 6px 0 0;" 249 | , " }" 250 | , " .syrup-comment:before {" 251 | , " content: \"\\2705\";" 252 | , " padding: 0 6px 0 0;" 253 | , " }" 254 | , " .syrup-warning:before {" 255 | , " content: \"\\26A0\\FE0F\";" 256 | , " padding: 0 6px 0 0;" 257 | , " }" 258 | , " .syrup-error:before {" 259 | , " content: \"\\274C\";" 260 | , " padding: 0 6px 0 0;" 261 | , " }" 262 | , " .syrup-internal:before {" 263 | , " content: \"\\1F480\";" 264 | , " padding: 0 6px 0 0;" 265 | , " }" 266 | , " .syrup-function {" 267 | , " color: light-dark(blue, #66d9ef);" 268 | , " }" 269 | , " .syrup-variable {" 270 | , " color: light-dark(purple, #fc929e);" 271 | , " }" 272 | , " .syrup-type {" 273 | , " color: light-dark(green, #a6e22e);" 274 | , " }" 275 | , " .syrup-keyword {" 276 | , " font-weight: bold;" 277 | , " }" 278 | , "" 279 | ] 280 | -------------------------------------------------------------------------------- /lib/Language/Syrup/Anf.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- Anf: Elaboration to A normal forms ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | module Language.Syrup.Anf where 8 | 9 | import Control.Monad.State 10 | 11 | import Data.Maybe (fromMaybe) 12 | import Data.Monoid (First(..), Sum(..)) 13 | import Data.Traversable (for) 14 | 15 | import Language.Syrup.BigArray 16 | import Language.Syrup.Fsh 17 | import Language.Syrup.Pretty (basicShow) 18 | import Language.Syrup.Smp 19 | import Language.Syrup.Syn 20 | import Language.Syrup.Ty 21 | 22 | getTyp :: TypedExp -> Typ 23 | getTyp = \case 24 | Var ty _ -> ty 25 | Cab ty _ -> ty 26 | App [ty] _ _ -> ty 27 | e -> Bit Unit -- default value :( 28 | 29 | ------------------------------------------------------------------------------ 30 | -- Syntax of A normal forms 31 | -- Outputs may be virtual i.e. introduced by the machine but not 32 | -- present in the source code. 33 | -- For instance when we elaborate "f ([X,Y,Z]) = rhs" 34 | -- we obtain "f A = rhs where [X,Y,Z] = A". 35 | -- Here A is a virtual wire and we should not display this name back 36 | -- to users (e.g. if we produce a circuit diagram for their source code). 37 | 38 | data Input' nm = Input 39 | { isVirtualInput :: Bool 40 | , inputType :: Typ 41 | , inputDisplayName :: Maybe String 42 | , inputName :: nm } 43 | deriving (Functor, Foldable, Traversable) 44 | 45 | -- Outputs may be virtual i.e. introduced by the machine but not 46 | -- present in the source code. 47 | -- For instance when we elaborate "A&B&C" we obtain "A&Z where Z = B&C". 48 | -- Here Z is a virtual wire and we should not display this name back 49 | -- to users (e.g. if we produce a circuit diagram for their source code). 50 | 51 | data Output' nm = Output 52 | { isVirtualOutput :: Bool 53 | , outputType :: Typ 54 | , outputDisplayName :: Maybe String 55 | , outputName :: nm 56 | } deriving (Functor, Foldable, Traversable) 57 | 58 | wire :: Input' nm -> Output' nm 59 | wire (Input v ty dn x) = Output v ty dn x 60 | 61 | cowire :: Output' nm -> Input' nm 62 | cowire (Output v ty dn x) = Input v ty dn x 63 | 64 | -- Expressions in A normal form: either a variable or a function applied 65 | -- to a bunch of variables. Nothing more complex than that. 66 | 67 | data Expr' nm 68 | = Alias Typ nm 69 | | Call [Typ] nm [Input' nm] 70 | | Copy Typ (Input' nm) 71 | | FanIn [Input' nm] 72 | | FanOut (Input' nm) 73 | deriving (Functor, Foldable, Traversable) 74 | 75 | type Input = Input' String 76 | type Output = Output' String 77 | type Expr = Expr' String 78 | 79 | type LetBinding = ([Output], Expr) 80 | 81 | data Gate = Gate 82 | { inputs :: [Input] 83 | , outputs :: [Output] 84 | , letBindings :: [LetBinding] 85 | } 86 | 87 | -- Needed to merge the successive results. 88 | -- In practice we should *not* have clashing names! 89 | instance Semigroup Gate where 90 | a <> b = a 91 | 92 | ------------------------------------------------------------------------------ 93 | -- ANF: the Fresh monad to generate fresh names for virtual wires 94 | 95 | type ANF = StateT (Arr String [Output]) (Fresh Int) 96 | 97 | -- This should return a name not valid in the surface syntax. 98 | freshVirtualName :: ANF String 99 | freshVirtualName = do 100 | i <- fresh 101 | pure $ concat ["__VIRTUAL__", show i] 102 | 103 | ------------------------------------------------------------------------------ 104 | -- Elaboration 105 | -- 106 | -- If the Exp is already a variable name then we can simply return it. 107 | -- Otherwise we have an arbitrary expression so we introduce a virtual 108 | -- name for it and return a delayed "equation" connecting this virtual 109 | -- name to the expression. We do not reuse the type Eqn because we want 110 | -- to remember that the name on the LHS is virtual. 111 | 112 | type Assignment = ([Output], TypedExp) 113 | 114 | -- Return an input name for the pattern, a list of inputs 115 | -- corresponding to the names bound in the pattern, and 116 | -- a list of assignments in A-normal form representing 117 | -- the successive fan-outs 118 | elabPat :: TypedPat -> ANF (Input, [Input], [LetBinding]) 119 | elabPat p = case p of 120 | PVar ty x -> let vx = Input False ty Nothing x in pure (vx, [vx], []) 121 | PCab ty ps -> do 122 | x <- Input True ty (Just $ basicShow p) <$> freshVirtualName 123 | ias <- mapM elabPat ps 124 | let (is, iss, eqnss) = unzip3 ias 125 | pure (x, concat iss, (wire <$> is, FanOut x) : concat eqnss) 126 | 127 | declareAlias :: TypedExp -> ANF (Output, [Assignment]) 128 | declareAlias e = do 129 | vn <- freshVirtualName 130 | let ty = getTyp e 131 | let out = Output True ty (basicShow <$> exPat e) vn 132 | pure (out, [([out], e)]) 133 | 134 | elabExp :: TypedExp -> ANF (Output, [Assignment]) 135 | elabExp = \case 136 | Var ty x -> do 137 | x' <- elabVar x 138 | let isVirtual = x /= x' -- we got a name from a copy box back! 139 | pure (Output isVirtual ty (Just x) x', []) 140 | e -> declareAlias e 141 | 142 | -- If an expression on the RHS is a variable corresponding to an input 143 | -- wire, we introduce a virtual name for it an do aliasing. This allows 144 | -- us to assume that the named inputs & outputs are always distinct 145 | -- which is a really useful invariant when producing a diagram. 146 | 147 | elabRHS :: [Input] -> TypedExp -> ANF (Output, [Assignment]) 148 | elabRHS inputs e = 149 | let dflt = elabExp e 150 | ins = map inputName inputs 151 | in case e of 152 | Var _ x 153 | -- | x `elem` ins -> declareAlias e 154 | | otherwise -> dflt 155 | _ -> dflt 156 | 157 | 158 | -- If a wire has more than 2 ends (1 input as enforced by 159 | -- scope checking and 2+ outputs), then introduce one virtual 160 | -- name for each output and add a copy box taking the input 161 | -- and producing all the virtual outputs. 162 | -- When we will elaborate a (Var ty x), we will check whether 163 | -- we need to use one of the virtual names thus introduced. 164 | declareCopies :: (String, (First Typ, Sum Int)) -> ANF [LetBinding] 165 | declareCopies (x, (First (Nothing), Sum n)) = error "The IMPOSSIBLE has happened: wire with no ends" 166 | declareCopies (x, (First (Just ty), Sum n)) 167 | | n <= 2 = pure [] -- there are two ends to each cable 168 | | otherwise = do 169 | os <- for [2..n] $ const $ do 170 | nm <- freshVirtualName 171 | pure (Output True ty (Just x) nm) 172 | -- we store these names in the ANF monad for use in elabVar 173 | modify (insertArr (x, os)) 174 | pure [(os, Copy ty (Input False ty Nothing x))] 175 | 176 | -- Not much work done here: elaborate the LHS, elaborate the RHS and 177 | -- collect the additional equations added by doing so and finally 178 | -- elaborate all of the equations. 179 | elabDef :: TypedDef -> ANF (Maybe (String, Gate)) 180 | elabDef Stub{} = pure Nothing 181 | elabDef def@(Def (nm, ps) rhs eqns) = do 182 | lcsA <- foldMapArr snd <$> travArr declareCopies (allVars def) 183 | -- obtain 184 | -- ins: the definition's inputs 185 | -- inss: the definition's bound names on the LHS 186 | -- lcs0: the fanouts turning ins into inss 187 | (ins, inss, lcs0) <- unzip3 <$> mapM elabPat ps 188 | -- obtain 189 | -- ous: the right hand side's outputs 190 | -- oeqns: the equations defining the outputs 191 | (ous, oeqns) <- unzip <$> mapM (elabRHS (concat inss)) rhs 192 | -- Elaborate the `where`-bound equations 193 | lcs1 <- mapM elabEqn (fromMaybe [] eqns) 194 | -- Elaborate the assignments 195 | lcs2 <- mapM elabAss (concat oeqns) 196 | let gate = Gate 197 | { inputs = ins 198 | , outputs = ous 199 | , letBindings = concat (lcsA : lcs0 ++ lcs1 ++ lcs2) 200 | } 201 | pure (Just (getName nm, gate)) 202 | 203 | -- When elaborating an equations we have two situations: 204 | -- A,B,C = e 205 | -- or A,B,C = d,e,f 206 | -- The first case can be reduced to the notion of assignment we introduced earlier 207 | -- The second case can be reduced to solving (A = d, B = e, C = f) 208 | elabEqn :: TypedEqn -> ANF [LetBinding] 209 | elabEqn (ps :=: [rhs]) = do 210 | (is, iss, fanouts) <- unzip3 <$> mapM elabPat ps 211 | defs <- elabAss (wire <$> is, rhs) 212 | pure (concat fanouts ++ defs) 213 | elabEqn (ps :=: rhs) = do 214 | eqns <- mapM elabEqn (zipWith (\ p e -> [p] :=: [e]) ps rhs) 215 | pure $ concat eqns 216 | 217 | -- If that end of the wire is used more than once, we 218 | -- need to use one of the virtual names coming out of 219 | -- the associated copy box instead. This is what this 220 | -- does, being careful to *not* put the consumed name 221 | -- back in the state. 222 | elabVar :: String -> ANF String 223 | elabVar x = gets (findArr x) >>= \case 224 | Nothing -> pure x 225 | Just [] -> error "The IMPOSSIBLE has happened: ran out of virtual names" 226 | Just (n : ns) -> do 227 | modify (insertArr (x, ns)) 228 | pure (outputName n) 229 | 230 | -- The assignment A,B,C = e case is bit more complex: 231 | -- - If e is a variable then we're done. 232 | -- - If e is an application then we recursively elaborate all of the 233 | -- expression it has as arguments i.e. we want variable names for them 234 | -- and we are ready to pay for it by generating additional assignments. 235 | -- Finally we elaborate these additional assignments 236 | elabAss :: Assignment -> ANF [LetBinding] 237 | elabAss (ous, e) = case e of 238 | Var ty x -> pure . (ous,) . Alias ty <$> elabVar x 239 | App tys f es -> do 240 | (args, eqs) <- unzip <$> mapM elabExp es 241 | ih <- mapM elabAss $ concat eqs 242 | pure $ (ous, Call tys (getName f) (cowire <$> args)) : concat ih 243 | Cab ty es -> do 244 | (args, eqs) <- unzip <$> mapM elabExp es 245 | ih <- mapM elabAss $ concat eqs 246 | pure $ (ous, FanIn (cowire <$> args)) : concat ih 247 | Hol _ _ -> pure [] -- error: elaborating a hole?! 248 | 249 | toGate :: TypedDef -> Maybe (String, Gate) 250 | toGate = evalFresh . (`evalStateT` emptyArr) . elabDef 251 | 252 | ------------------------------------------------------------------------------ 253 | -- Back to Def 254 | 255 | -- Erase a Gate back to a Def for pretty-printing purposes. 256 | -- Note that we could also use this function to check that 257 | -- `d` and `toANF d` are bisimilar! 258 | fromGate :: String -> Gate -> TypedDef 259 | fromGate nm g = 260 | Def (Name nm, map (\ i -> PVar (inputType i) (inputName i)) (inputs g)) 261 | (map (\ o -> Var (outputType o) (outputName o)) (outputs g)) 262 | $ case letBindings g of 263 | [] -> Nothing 264 | eqns -> Just $ map (\ (os, rhs) -> 265 | (map (\ o -> PVar (outputType o) (outputName o)) os) 266 | :=: 267 | [case rhs of 268 | Alias ty x -> Var ty x 269 | Copy ty x -> let n = length os in Cab (Cable (replicate n ty)) (replicate n (Var ty (inputName x))) 270 | Call tys f es -> App tys (Name f) (map (\ i -> Var (inputType i) (inputName i)) es) 271 | FanIn os -> let ty = Cable (map inputType os) in 272 | Cab ty (map (\ i -> Var (inputType i) (inputName i)) os) 273 | FanOut i -> Var (inputType i) (inputName i) 274 | ]) 275 | eqns 276 | 277 | toANF :: TypedDef -> TypedDef 278 | toANF d = fromMaybe d $ uncurry fromGate <$> toGate d 279 | 280 | ------------------------------------------------------------------------------ 281 | -- Tests 282 | 283 | test :: IO () 284 | test = do 285 | let runner = putStrLn . basicShow . toANF 286 | runner foo 287 | runner and4 288 | runner and4' 289 | -------------------------------------------------------------------------------- /lib/Language/Syrup/Doc.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- Doc: Documents for Syrup ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | module Language.Syrup.Doc 11 | -- Doc stuff 12 | ( LineDoc 13 | , Doc 14 | , Render(..) 15 | , AnnHighlight(..) 16 | , AnnStructure(..) 17 | , FeedbackStatus(..) 18 | , isErroring 19 | , aLine 20 | , highlight 21 | , isCode 22 | , structure 23 | , nest 24 | , between 25 | , braces 26 | , brackets 27 | , csep 28 | , list 29 | , parens 30 | , parensIf 31 | , punctuate 32 | , set 33 | , tuple 34 | , unwords 35 | -- Pretty stuff 36 | , Pretty(..) 37 | , prettyBlock 38 | , PrecedenceLevel(..) 39 | , AList(..) 40 | , ATuple(..) 41 | , ASet(..) 42 | ) where 43 | 44 | import Prelude hiding (unwords) 45 | 46 | import Control.Monad.State (MonadState, get, put, evalState) 47 | 48 | import Data.Foldable (fold) 49 | import Data.Kind (Type) 50 | import Data.List (intersperse) 51 | import Data.String (IsString, fromString) 52 | import Data.Void (Void, absurd) 53 | 54 | import Text.Blaze.Html5 (Html, AttributeValue, (!), toHtml, toValue) 55 | import qualified Text.Blaze.Html5 as Html 56 | import Text.Blaze.Html5.Attributes (class_, style, type_) 57 | import qualified Text.Blaze.Html5.Attributes as Attr 58 | 59 | import Language.Syrup.Syn.Base 60 | import Language.Syrup.Utils (plural) 61 | 62 | ------------------------------------------------------------------------------ 63 | -- Feedback status 64 | 65 | data FeedbackStatus 66 | = Success 67 | | Comment 68 | | Warning 69 | | Error 70 | | Internal 71 | deriving Eq 72 | 73 | isErroring :: FeedbackStatus -> Bool 74 | isErroring = \case 75 | Success -> False 76 | Comment -> False 77 | Warning -> False 78 | Error -> True 79 | Internal -> True 80 | 81 | instance Semigroup FeedbackStatus where 82 | Success <> f = f 83 | e <> Success = e 84 | Comment <> f = f 85 | e <> Comment = e 86 | Warning <> f = f 87 | e <> Warning = e 88 | Error <> f = f 89 | e <> Error = e 90 | _ <> _ = Internal 91 | 92 | instance Monoid FeedbackStatus where 93 | mempty = Success 94 | mappend = (<>) 95 | 96 | feedbackStatus :: FeedbackStatus -> String 97 | feedbackStatus = \case 98 | Success -> "" 99 | Comment -> "" 100 | Warning -> "Warning" 101 | Error -> "Error" 102 | Internal -> "Internal error" 103 | 104 | toCSSClass :: FeedbackStatus -> AttributeValue 105 | toCSSClass st = toValue $ ("syrup-" ++) $ case st of 106 | Success -> "happy" 107 | Comment -> "comment" 108 | Warning -> "warning" 109 | Error -> "error" 110 | Internal -> "internal" 111 | 112 | ------------------------------------------------------------------------ 113 | -- Doc type and renderers 114 | 115 | data AnnHighlight 116 | = AFunction 117 | | AVariable 118 | | AKeyword 119 | | AType 120 | 121 | data AnnLine 122 | = IsCode 123 | | HasStyle AnnHighlight 124 | 125 | data AnnStructure 126 | = NestBlock Int 127 | | PreBlock 128 | | RawCodeBlock 129 | | GraphBlock [String] 130 | | StatusBlock FeedbackStatus 131 | | DetailsBlock LineDoc 132 | 133 | data LineDoc 134 | = AString String 135 | | AnAnnot AnnLine LineDoc 136 | | AConcat [LineDoc] 137 | 138 | highlight :: AnnHighlight -> LineDoc -> LineDoc 139 | highlight = AnAnnot . HasStyle 140 | 141 | isCode :: LineDoc -> LineDoc 142 | isCode = AnAnnot IsCode 143 | 144 | structure :: AnnStructure -> Doc -> Doc 145 | structure ann d = [ABlock (Just ann) d] 146 | 147 | nest :: Int -> Doc -> Doc 148 | nest i d | i <= 0 || null d = d 149 | nest i d = structure (NestBlock i) d 150 | 151 | aLine :: LineDoc -> Doc 152 | aLine = pure . ALine 153 | 154 | instance Semigroup LineDoc where 155 | AString "" <> d = d 156 | d <> AString "" = d 157 | d@(AString{}) <> AConcat ds = AConcat (d : ds) 158 | d1 <> d2 = AConcat [d1, d2] 159 | 160 | instance Monoid LineDoc where 161 | mempty = AString "" 162 | 163 | data BlockDoc 164 | = ALine LineDoc 165 | | ABlock (Maybe AnnStructure) Doc 166 | 167 | instance Semigroup BlockDoc where 168 | d <> ABlock Nothing [] = d 169 | ABlock Nothing d1 <> ABlock Nothing d2 = ABlock Nothing (d1 ++ d2) 170 | d1 <> d2 = ABlock Nothing [d1, d2] 171 | 172 | type Doc = [BlockDoc] 173 | 174 | instance IsString LineDoc where 175 | fromString = AString 176 | 177 | class Render d where 178 | renderToString :: d -> [String] 179 | renderToHtml :: d -> Html 180 | 181 | instance Render LineDoc where 182 | 183 | renderToString = pure . go where 184 | 185 | go :: LineDoc -> String 186 | go (AString str) = str 187 | go (AnAnnot IsCode d) = "`" ++ go d ++ "`" 188 | go (AnAnnot (HasStyle _) d) = go d 189 | go (AConcat ds) = foldMap go ds 190 | 191 | renderToHtml (AConcat ds) = foldMap renderToHtml ds 192 | renderToHtml (AString str) = toHtml str 193 | renderToHtml (AnAnnot ann d) = applyHighlight ann (renderToHtml d) 194 | 195 | where 196 | applyHighlight :: AnnLine -> Html -> Html 197 | applyHighlight IsCode = Html.code 198 | applyHighlight (HasStyle sty) = Html.span ! class_ (asAttribute sty) 199 | 200 | asAttribute :: AnnHighlight -> AttributeValue 201 | asAttribute AFunction = "syrup-function" 202 | asAttribute AVariable = "syrup-variable" 203 | asAttribute AKeyword = "syrup-keyword" 204 | asAttribute AType = "syrup-type" 205 | 206 | 207 | instance Render Doc where 208 | 209 | renderToString = foldMap renderBlock where 210 | 211 | renderBlock :: BlockDoc -> [String] 212 | renderBlock (ALine d) = [concat $ renderToString d] 213 | renderBlock (ABlock ann ds) 214 | = maybe id applyStructure ann 215 | $ foldMap renderBlock ds 216 | 217 | applyStructure :: AnnStructure -> [String] -> [String] 218 | applyStructure (NestBlock i) ls 219 | | i > 0 = map (replicate i ' ' ++) ls 220 | | otherwise = ls 221 | applyStructure (StatusBlock cat) [] = [] 222 | applyStructure (StatusBlock cat) (l : ls) = 223 | let status = feedbackStatus cat in 224 | (plural status status ": " <> l) : ls 225 | applyStructure PreBlock ls = ls 226 | applyStructure RawCodeBlock ls = ls 227 | applyStructure (GraphBlock ls) _ = ls 228 | applyStructure (DetailsBlock s) ls = 229 | concat (renderToString s) : ls 230 | 231 | 232 | renderToHtml = flip evalState 0 . go False where 233 | 234 | -- The Bool is True if we are in pre mode, in which case we do: 235 | -- 1. newlines as "\n" alone rather than (br <> "\n") 236 | 237 | newline :: Bool -> Html 238 | newline b = (if b then id else (("\n" <> Html.br) <>)) "\n" 239 | 240 | go :: MonadState Int m => Bool -> Doc -> m Html 241 | go b = fmap (fold . intersperse (newline b)) 242 | . renderBlocks b 243 | 244 | renderBlocks :: MonadState Int m => Bool -> Doc -> m [Html] 245 | renderBlocks b = fmap fold . traverse (renderBlock b) 246 | 247 | renderBlock :: MonadState Int m => Bool -> BlockDoc -> m [Html] 248 | renderBlock b (ALine d) = pure [renderToHtml d] 249 | renderBlock b (ABlock Nothing ds) = renderBlocks b ds 250 | renderBlock b (ABlock (Just ann) ds) = case ann of 251 | NestBlock i -> 252 | if i <= 0 then renderBlocks b ds else do 253 | html <- go b ds 254 | pure $ pure $ Html.div 255 | ! style (toValue $ "padding-left: " ++ show i ++ "ch") 256 | $ html 257 | PreBlock -> (pure . Html.pre) <$> go True ds 258 | RawCodeBlock -> do 259 | html <- go True ds 260 | pure $ [Html.div ! class_ "syrup-code" $ html] 261 | GraphBlock ls -> do 262 | n <- show <$> fresh 263 | pure $ let graphName = "GRAPH" ++ n in 264 | [ Html.script ! type_ "module" $ fold $ intersperse "\n" $ 265 | let dotName = "dot" <> toHtml n in 266 | let svgName = "svg" <> toHtml n in 267 | [ "" 268 | , " import { Graphviz } from \"https://cdn.jsdelivr.net/npm/@hpcc-js/wasm/dist/index.js\";" 269 | , " if (Graphviz) {" 270 | , " const graphviz = await Graphviz.load();" 271 | , " const " <> dotName <> " = " <> Html.preEscapedString (show (unlines ls)) <> ";" 272 | , " const " <> svgName <> " = graphviz.dot(" <> dotName <> ");" 273 | , " document.getElementById(\"" <> toHtml graphName <> "\").innerHTML = " <> svgName <> ";" 274 | , " }" 275 | , "" 276 | ] 277 | , Html.div ! Attr.id (toValue graphName) $ "" 278 | ] 279 | StatusBlock cat -> do 280 | html <- go False ds 281 | pure [Html.div ! class_ (toCSSClass cat) $ html] 282 | DetailsBlock s -> do 283 | html <- go b ds 284 | pure $ pure $ Html.details $ do 285 | Html.summary $ renderToHtml s 286 | html 287 | 288 | fresh :: MonadState Int m => m Int 289 | fresh = do 290 | n <- get 291 | let sn = n + 1 292 | put sn 293 | pure sn 294 | 295 | ------------------------------------------------------------------------ 296 | -- Basic combinators 297 | 298 | between :: Monoid d => d -> d -> (d -> d) 299 | between left right middle = fold [left, middle, right] 300 | 301 | parens :: LineDoc -> LineDoc 302 | parens = between "(" ")" 303 | 304 | brackets :: LineDoc -> LineDoc 305 | brackets = between "[" "]" 306 | 307 | braces :: LineDoc -> LineDoc 308 | braces = between "{" "}" 309 | 310 | parensIf :: Bool -> LineDoc -> LineDoc 311 | parensIf True = parens 312 | parensIf False = id 313 | 314 | punctuate :: LineDoc -> [LineDoc] -> LineDoc 315 | punctuate _ [] = "" 316 | punctuate sep ds = AConcat (intersperse sep ds) 317 | 318 | unwords :: [LineDoc] -> LineDoc 319 | unwords = punctuate " " 320 | 321 | csep :: [LineDoc] -> LineDoc 322 | csep = punctuate ", " 323 | 324 | list :: [LineDoc] -> LineDoc 325 | list = brackets . csep 326 | 327 | tuple :: [LineDoc] -> LineDoc 328 | tuple = parens . csep 329 | 330 | set :: [LineDoc] -> LineDoc 331 | set = braces . csep 332 | 333 | ------------------------------------------------------------------------ 334 | -- Pretty infrastructure 335 | 336 | data PrecedenceLevel 337 | = OrClause 338 | | AndClause 339 | | NegatedClause 340 | deriving (Eq, Ord, Enum, Bounded) 341 | 342 | newtype AList a = AList [a] 343 | newtype ATuple a = ATuple [a] 344 | newtype ASet a = ASet [a] 345 | 346 | class Pretty t where 347 | type PrettyDoc t :: Type 348 | pretty :: t -> PrettyDoc t 349 | pretty = prettyPrec minBound 350 | 351 | prettyPrec :: PrecedenceLevel -> t -> PrettyDoc t 352 | 353 | instance Pretty String where 354 | type PrettyDoc String = LineDoc 355 | prettyPrec _ = fromString 356 | 357 | instance Pretty Name where 358 | type PrettyDoc Name = LineDoc 359 | prettyPrec _ = highlight AFunction . pretty . getName 360 | 361 | instance Pretty TyName where 362 | type PrettyDoc TyName = LineDoc 363 | prettyPrec _ = highlight AType . pretty . between "<" ">" . getTyName 364 | 365 | instance Pretty Integer where 366 | type PrettyDoc Integer = LineDoc 367 | prettyPrec _ = pretty . show 368 | 369 | instance Pretty Int where 370 | type PrettyDoc Int = LineDoc 371 | prettyPrec _ = pretty . show 372 | 373 | instance Pretty Void where 374 | type PrettyDoc Void = LineDoc 375 | prettyPrec _ = absurd 376 | 377 | instance Pretty () where 378 | type PrettyDoc () = LineDoc 379 | prettyPrec _ _ = "()" 380 | 381 | instance Pretty Unit where 382 | type PrettyDoc Unit = LineDoc 383 | prettyPrec _ _ = "" 384 | 385 | instance (Pretty a, PrettyDoc a ~ LineDoc) => Pretty (AList a) where 386 | type PrettyDoc (AList a) = LineDoc 387 | prettyPrec _ (AList xs) = list $ map pretty xs 388 | 389 | instance (Pretty a, PrettyDoc a ~ LineDoc) => Pretty (ATuple a) where 390 | type PrettyDoc (ATuple a) = LineDoc 391 | prettyPrec _ (ATuple xs) = tuple $ map pretty xs 392 | 393 | instance (Pretty a, PrettyDoc a ~ LineDoc) => Pretty (ASet a) where 394 | type PrettyDoc (ASet a) = LineDoc 395 | prettyPrec _ (ASet xs) = set $ map pretty xs 396 | 397 | instance Pretty LineDoc where 398 | type PrettyDoc LineDoc = Doc 399 | prettyPrec _ l = [ALine l] 400 | 401 | prettyBlock :: (Pretty a, PrettyDoc a ~ LineDoc) => a -> Doc 402 | prettyBlock = aLine . pretty 403 | --------------------------------------------------------------------------------