├── .gitignore ├── HelloWorld.hs ├── HelloWorld2.hs ├── LICENSE ├── Makefile ├── Ontology.html ├── Ontology.md ├── README.html ├── README.md ├── Setup.hs ├── bin └── opl ├── old └── Lang │ └── OPL │ ├── Calculus │ ├── Lang.hs │ └── Parser.hs │ ├── Categorical │ └── Lang.hs │ ├── Combinator.hs │ └── CombinatorMorphism.hs ├── opl.cabal ├── opl_source ├── comments.opl ├── prog1.opl └── sample.opl ├── src ├── Lang │ └── OPL │ │ ├── Annotated.hs │ │ ├── Check.hs │ │ ├── CheckMonad.hs │ │ ├── Common.hs │ │ ├── Lexer.hs │ │ ├── Main.hs │ │ ├── Message.hs │ │ ├── Parser.hs │ │ ├── Semantics.hs │ │ └── Syntax.hs └── Util │ ├── Either.hs │ └── Parsec.hs ├── todo.md └── vim_syntax └── operad.vim /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | *.o 3 | *.hi 4 | .DS_Store 5 | -------------------------------------------------------------------------------- /HelloWorld.hs: -------------------------------------------------------------------------------- 1 | {-------------------------------------------------------------------------------- 2 | The 'hello world' demo from the wxWindows site. 3 | --------------------------------------------------------------------------------} 4 | module Main where 5 | 6 | import Graphics.UI.WXCore 7 | 8 | main :: IO () 9 | main = run helloWorld 10 | 11 | helloWorld = do -- create file menu 12 | fm <- menuCreate "" 0 13 | menuAppend fm wxID_ABOUT "&About.." "About wxHaskell" False {- not checkable -} 14 | menuAppendSeparator fm 15 | menuAppend fm wxID_EXIT "&Quit\tCtrl-Q" "Quit the demo" False 16 | 17 | -- create menu bar 18 | m <- menuBarCreate 0 19 | menuBarAppend m fm "&File" 20 | 21 | -- create top frame 22 | f <- frameCreate objectNull idAny "Hello world" rectZero frameDefaultStyle 23 | windowSetBackgroundColour f white 24 | windowSetClientSize f (sz 600 250) 25 | 26 | -- set status bar with 1 field 27 | frameCreateStatusBar f 1 0 28 | frameSetStatusText f "Welcome to wxHaskell" 0 29 | 30 | -- connect menu 31 | frameSetMenuBar f m 32 | evtHandlerOnMenuCommand f wxID_ABOUT (onAbout f) 33 | evtHandlerOnMenuCommand f wxID_EXIT (onQuit f) 34 | 35 | -- show it 36 | windowShow f 37 | windowRaise f 38 | return () 39 | where 40 | onAbout f = do 41 | version <- versionNumber 42 | messageDialog f "About 'Hello World'" ("This is a wxHaskell " ++ show version ++ " sample") (wxOK + wxICON_INFORMATION) 43 | return () 44 | 45 | onQuit f = do 46 | windowClose f True {- force close -} 47 | return () 48 | -------------------------------------------------------------------------------- /HelloWorld2.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import Graphics.UI.WX 3 | 4 | main :: IO () 5 | main 6 | = start hello 7 | 8 | hello :: IO () 9 | hello 10 | = do f <- frame [text := "Hello!"] 11 | quit <- button f [text := "Quit", on command := close f] 12 | set f [layout := widget quit] 13 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | LICENSE 2 | 3 | THE WORK (AS DEFINED BELOW) IS PROVIDED UNDER THE TERMS OF THIS CREATIVE COMMONS PUBLIC LICENSE ("CCPL" OR "LICENSE"). THE WORK IS PROTECTED BY COPYRIGHT AND/OR OTHER APPLICABLE LAW. ANY USE OF THE WORK OTHER THAN AS AUTHORIZED UNDER THIS LICENSE OR COPYRIGHT LAW IS PROHIBITED. 4 | 5 | BY EXERCISING ANY RIGHTS TO THE WORK PROVIDED HERE, YOU ACCEPT AND AGREE TO BE BOUND BY THE TERMS OF THIS LICENSE. TO THE EXTENT THIS LICENSE MAY BE CONSIDERED TO BE A CONTRACT, THE LICENSOR GRANTS YOU THE RIGHTS CONTAINED HERE IN CONSIDERATION OF YOUR ACCEPTANCE OF SUCH TERMS AND CONDITIONS. 6 | 7 | 1. Definitions 8 | 9 | "Collective Work" means a work, such as a periodical issue, anthology or encyclopedia, in which the Work in its entirety in unmodified form, along with one or more other contributions, constituting separate and independent works in themselves, are assembled into a collective whole. A work that constitutes a Collective Work will not be considered a Derivative Work (as defined below) for the purposes of this License. 10 | "Derivative Work" means a work based upon the Work or upon the Work and other pre-existing works, such as a translation, musical arrangement, dramatization, fictionalization, motion picture version, sound recording, art reproduction, abridgment, condensation, or any other form in which the Work may be recast, transformed, or adapted, except that a work that constitutes a Collective Work will not be considered a Derivative Work for the purpose of this License. For the avoidance of doubt, where the Work is a musical composition or sound recording, the synchronization of the Work in timed-relation with a moving image ("synching") will be considered a Derivative Work for the purpose of this License. 11 | "Licensor" means the individual, individuals, entity or entities that offers the Work under the terms of this License. 12 | "Original Author" means the individual, individuals, entity or entities who created the Work. 13 | "Work" means the copyrightable work of authorship offered under the terms of this License. 14 | "You" means an individual or entity exercising rights under this License who has not previously violated the terms of this License with respect to the Work, or who has received express permission from the Licensor to exercise rights under this License despite a previous violation. 15 | 2. Fair Use Rights. Nothing in this license is intended to reduce, limit, or restrict any rights arising from fair use, first sale or other limitations on the exclusive rights of the copyright owner under copyright law or other applicable laws. 16 | 17 | 3. License Grant. Subject to the terms and conditions of this License, Licensor hereby grants You a worldwide, royalty-free, non-exclusive, perpetual (for the duration of the applicable copyright) license to exercise the rights in the Work as stated below: 18 | 19 | to reproduce the Work, to incorporate the Work into one or more Collective Works, and to reproduce the Work as incorporated in the Collective Works; and, 20 | to distribute copies or phonorecords of, display publicly, perform publicly, and perform publicly by means of a digital audio transmission the Work including as incorporated in Collective Works. 21 | The above rights may be exercised in all media and formats whether now known or hereafter devised. The above rights include the right to make such modifications as are technically necessary to exercise the rights in other media and formats, but otherwise you have no rights to make Derivative Works. All rights not expressly granted by Licensor are hereby reserved, including but not limited to the rights set forth in Sections 4(d) and 4(e). 22 | 23 | 4. Restrictions.The license granted in Section 3 above is expressly made subject to and limited by the following restrictions: 24 | 25 | You may distribute, publicly display, publicly perform, or publicly digitally perform the Work only under the terms of this License, and You must include a copy of, or the Uniform Resource Identifier for, this License with every copy or phonorecord of the Work You distribute, publicly display, publicly perform, or publicly digitally perform. You may not offer or impose any terms on the Work that restrict the terms of this License or the ability of a recipient of the Work to exercise the rights granted to that recipient under the terms of the License. You may not sublicense the Work. You must keep intact all notices that refer to this License and to the disclaimer of warranties. When You distribute, publicly display, publicly perform, or publicly digitally perform the Work, You may not impose any technological measures on the Work that restrict the ability of a recipient of the Work from You to exercise the rights granted to that recipient under the terms of the License. This Section 4(a) applies to the Work as incorporated in a Collective Work, but this does not require the Collective Work apart from the Work itself to be made subject to the terms of this License. If You create a Collective Work, upon notice from any Licensor You must, to the extent practicable, remove from the Collective Work any credit as required by Section 4(c), as requested. 26 | You may not exercise any of the rights granted to You in Section 3 above in any manner that is primarily intended for or directed toward commercial advantage or private monetary compensation. The exchange of the Work for other copyrighted works by means of digital file-sharing or otherwise shall not be considered to be intended for or directed toward commercial advantage or private monetary compensation, provided there is no payment of any monetary compensation in connection with the exchange of copyrighted works. 27 | If You distribute, publicly display, publicly perform, or publicly digitally perform the Work (as defined in Section 1 above) or Collective Works (as defined in Section 1 above), You must, unless a request has been made pursuant to Section 4(a), keep intact all copyright notices for the Work and provide, reasonable to the medium or means You are utilizing: (i) the name of the Original Author (or pseudonym, if applicable) if supplied, and/or (ii) if the Original Author and/or Licensor designate another party or parties (e.g. a sponsor institute, publishing entity, journal) for attribution ("Attribution Parties") in Licensor's copyright notice, terms of service or by other reasonable means, the name of such party or parties; the title of the Work if supplied; to the extent reasonably practicable, the Uniform Resource Identifier, if any, that Licensor specifies to be associated with the Work, unless such URI does not refer to the copyright notice or licensing information for the Work. The credit required by this Section 4(c) may be implemented in any reasonable manner; provided, however, that in the case of a Collective Work, at a minimum such credit will appear, if a credit for all contributing authors of the Collective Work appears, then as part of these credits and in a manner at least as prominent as the credits for the other contributing authors. For the avoidance of doubt, You may only use the credit required by this clause for the purpose of attribution in the manner set out above and, by exercising Your rights under this License, You may not implicitly or explicitly assert or imply any connection with, sponsorship or endorsement by the Original Author, Licensor and/or Attribution Parties, as appropriate, of You or Your use of the Work, without the separate, express prior written permission of the Original Author, Licensor and/or Attribution Parties. 28 | For the avoidance of doubt, where the Work is a musical composition: 29 | 30 | Performance Royalties Under Blanket Licenses. Licensor reserves the exclusive right to collect whether individually or, in the event that Licensor is a member of a performance rights society (e.g. ASCAP, BMI, SESAC), via that society, royalties for the public performance or public digital performance (e.g. webcast) of the Work if that performance is primarily intended for or directed toward commercial advantage or private monetary compensation. 31 | Mechanical Rights and Statutory Royalties. Licensor reserves the exclusive right to collect, whether individually or via a music rights agency or designated agent (e.g. Harry Fox Agency), royalties for any phonorecord You create from the Work ("cover version") and distribute, subject to the compulsory license created by 17 USC Section 115 of the US Copyright Act (or the equivalent in other jurisdictions), if Your distribution of such cover version is primarily intended for or directed toward commercial advantage or private monetary compensation. 32 | Webcasting Rights and Statutory Royalties. For the avoidance of doubt, where the Work is a sound recording, Licensor reserves the exclusive right to collect, whether individually or via a performance-rights society (e.g. SoundExchange), royalties for the public digital performance (e.g. webcast) of the Work, subject to the compulsory license created by 17 USC Section 114 of the US Copyright Act (or the equivalent in other jurisdictions), if Your public digital performance is primarily intended for or directed toward commercial advantage or private monetary compensation. 33 | 5. Representations, Warranties and Disclaimer 34 | 35 | UNLESS OTHERWISE MUTUALLY AGREED TO BY THE PARTIES IN WRITING, LICENSOR OFFERS THE WORK AS-IS AND ONLY TO THE EXTENT OF ANY RIGHTS HELD IN THE LICENSED WORK BY THE LICENSOR. THE LICENSOR MAKES NO REPRESENTATIONS OR WARRANTIES OF ANY KIND CONCERNING THE WORK, EXPRESS, IMPLIED, STATUTORY OR OTHERWISE, INCLUDING, WITHOUT LIMITATION, WARRANTIES OF TITLE, MARKETABILITY, MERCHANTIBILITY, FITNESS FOR A PARTICULAR PURPOSE, NONINFRINGEMENT, OR THE ABSENCE OF LATENT OR OTHER DEFECTS, ACCURACY, OR THE PRESENCE OF ABSENCE OF ERRORS, WHETHER OR NOT DISCOVERABLE. SOME JURISDICTIONS DO NOT ALLOW THE EXCLUSION OF IMPLIED WARRANTIES, SO SUCH EXCLUSION MAY NOT APPLY TO YOU. 36 | 37 | 6. Limitation on Liability. EXCEPT TO THE EXTENT REQUIRED BY APPLICABLE LAW, IN NO EVENT WILL LICENSOR BE LIABLE TO YOU ON ANY LEGAL THEORY FOR ANY SPECIAL, INCIDENTAL, CONSEQUENTIAL, PUNITIVE OR EXEMPLARY DAMAGES ARISING OUT OF THIS LICENSE OR THE USE OF THE WORK, EVEN IF LICENSOR HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 38 | 39 | 7. Termination 40 | 41 | This License and the rights granted hereunder will terminate automatically upon any breach by You of the terms of this License. Individuals or entities who have received Collective Works (as defined in Section 1 above) from You under this License, however, will not have their licenses terminated provided such individuals or entities remain in full compliance with those licenses. Sections 1, 2, 5, 6, 7, and 8 will survive any termination of this License. 42 | Subject to the above terms and conditions, the license granted here is perpetual (for the duration of the applicable copyright in the Work). Notwithstanding the above, Licensor reserves the right to release the Work under different license terms or to stop distributing the Work at any time; provided, however that any such election will not serve to withdraw this License (or any other license that has been, or is required to be, granted under the terms of this License), and this License will continue in full force and effect unless terminated as stated above. 43 | 8. Miscellaneous 44 | 45 | Each time You distribute or publicly digitally perform the Work (as defined in Section 1 above) or a Collective Work (as defined in Section 1 above), the Licensor offers to the recipient a license to the Work on the same terms and conditions as the license granted to You under this License. 46 | If any provision of this License is invalid or unenforceable under applicable law, it shall not affect the validity or enforceability of the remainder of the terms of this License, and without further action by the parties to this agreement, such provision shall be reformed to the minimum extent necessary to make such provision valid and enforceable. 47 | No term or provision of this License shall be deemed waived and no breach consented to unless such waiver or consent shall be in writing and signed by the party to be charged with such waiver or consent. 48 | This License constitutes the entire agreement between the parties with respect to the Work licensed here. There are no understandings, agreements or representations with respect to the Work not specified here. Licensor shall not be bound by any additional provisions that may appear in any communication from You. This License may not be modified without the mutual written agreement of the Licensor and You. 49 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | build: 2 | cabal build 3 | clean: 4 | cabal clean 5 | configure: 6 | cabal configure 7 | run: dist/build/opl/opl 8 | ./dist/build/opl/opl opl_source/prog1.opl 9 | dist/build/opl/opl: build 10 | interact: 11 | ghci -isrc src/Lang/OPL/Main.hs 12 | -------------------------------------------------------------------------------- /Ontology.html: -------------------------------------------------------------------------------- 1 |

Definitions

2 |

Generic Terms

3 | 21 |

Specific Terms

22 | 67 |

Languages

68 |

The following are described in an untyped setting for now.

69 |

[x ...] is meta-syntax for a sequence of x 'things'.

70 | 130 | -------------------------------------------------------------------------------- /Ontology.md: -------------------------------------------------------------------------------- 1 | Definitions 2 | ==================== 3 | 4 | Generic Terms 5 | -------------------- 6 | 7 | * Operad 8 | - Something that classifies a self-similarity situation. 9 | - For example, an operad of boxes and wiring diagrams. 10 | * Operad-algebra 11 | - Something of the shape classified by the operad. 12 | - For example, propagators have the shape of boxes and wiring diagrams. 13 | * Calculus 14 | - Something with binders 15 | * Combinator 16 | - Something without binders 17 | * Inductive 18 | - A set of things defined by (finite) recursive applications of a set of 19 | introduction rules. 20 | - For example, lists of numbers are defined inductively as: 21 | 22 | n := *numbers* 23 | list l := nil 24 | | cons n l 25 | 26 | Specific Terms 27 | -------------------- 28 | 29 | * Box 30 | - A box is a tuple (in,out) where 'in' and 'out' are unordered lists of types 31 | - Boxes look like this: 32 | 33 | ____ 34 | A->| |->C 35 | | |->D 36 | B->|____|->E 37 | 38 | - Boxes are types in a sense, in that they classify machines which compute 39 | over the inputs, providing values over the outputs. 40 | * Wiring Diagram 41 | - A mapping between boxes. 42 | - If wiring from box X to box Y, a wiring diagram is represented as a surjective 43 | function phi: (Y-Out + X-In) -> (Y-In + X-Out), such that Y-out->X-Out. 44 | * Operad 45 | - The mathematical system of self-similarity. 46 | - Our operad W of wiring diagrams: 47 | + Objects: boxes (X-In, X-Out) 48 | + Morphisms ϕ:X(1),X(2),...,X(n) -> Y are wiring diagrams, (in+out->out+in). 49 | + Composition (boxes inside of boxes inside of boxes). 50 | - The operad of Sets 51 | + Objects: Sets S 52 | + Morphisms ϕ:S(1),S(2),...,S(n) -> T are functions S(1)xS(2)x...xS(n) -> T. 53 | + Composition (usual). 54 | 55 | * Operad functor 56 | - Given two operads, say L and M, we can speak of a functor P:L -> M. 57 | + It sends objects in L to objects in M, 58 | + it sends n-ary morphisms in L to n-ary morphisms in M, and 59 | + it respects composition. 60 | - When M is Set, we call P an algebra. 61 | - Let L=W (wiring diagrams) and M=Sets. Then an operad functor P:W->Sets includes 62 | + A mapping that sends each box X∈W to a set S∈Set. 63 | + A mapping that sends each wiring diagram ϕ to a function. 64 | 65 | * Machine/Propagator 66 | - This is the algebra part. We have a functor Propagators: WiringDiagrams -> Set. 67 | - Machines describe some sort of computation in a specific domain. 68 | - Machines are classified by boxes (in other words, if X is a box, M is a machine to fill in that box iff M is an element of the set Propagators(X). 69 | - Boxes and wiring diagrams can be described and have semantics independent 70 | of an algebra of machines; that is, the machines are dependently typed by the operad. 71 | 72 | Languages 73 | -------------------- 74 | 75 | The following are described in an untyped setting for now. 76 | 77 | [x ...] is meta-syntax for a sequence of x 'things'. 78 | 79 | * Operad Combinators 80 | - Language syntax consists of the following terms e: 81 | 82 | e := id 83 | | split 84 | | sink 85 | | swap 86 | | assoc 87 | | loop e 88 | | e ∘ e 89 | | e ⊗ e 90 | - Terms are classified (typed) by boxes. 91 | - Terms are denoted by wiring diagrams which have been applied to a machine. 92 | - Morphisms between terms take place in the host language/logic, or a 93 | first-order lambda could be added for abstraction. 94 | - Suitable for a shallow embedding 95 | * Operad Morphism Combinators 96 | - Language consists of the following terms e: 97 | 98 | e := id 99 | | split 100 | | sink 101 | | swap 102 | | assoc 103 | | loop 104 | | e ∘ e 105 | | e ⊗ e 106 | - Terms are classified (typed) by mappings (morphism) between boxes. 107 | - Terms are denoted directly by wiring diagrams. 108 | - No host language/logic needed to express morphisms/abstraction. 109 | - Suitable for a shallow embedding 110 | * Operad Calculus 111 | - Language syntax consists of variables x, terms e and statements s: 112 | 113 | x := *variable-name* 114 | e := λ x. e 115 | | e e 116 | | wire [s ...] 117 | s := [x ...] <- e -< [x ...] 118 | | loop [s ...] 119 | - Terms are classified (typed) by both boxes and box morphisms (similar to 120 | lambda calculus). 121 | - wire [s ...] is denoted by applied wiring diagrams, and (λ x. e) is denoted 122 | by a wiring diagram. 123 | - No host language/logic needed to express morphisms/abstraction. 124 | - Not suitable for a shallow embedding (because of binders) 125 | * Operad Category 126 | - (presented with types) 127 | - Other possible names: 128 | + Operad internal language 129 | + Operad core language 130 | - Language syntax consists of variables x, types t, boxes b, and wirings w: 131 | 132 | x := *variable-name* 133 | t := Int | Bool | ... 134 | b := box {in=[(x:t) ...], out=[(x:t) ...]} 135 | w := wiring {in=[(x, x) ...], out=[(x, x) ...]} : [b ...] -> b 136 | - Wirings are classified (typed) by box morphisms 137 | - Wirings are denoted by wiring diagrams 138 | - No host language/logic needed to express morphisms/abstraction. 139 | - Not suitable for a shallow embedding (because of binders) 140 | - Tensor may be problematic with naming, so for now use the operad model which allows multiple inputs. 141 | - (the version with tensor and a single input is called symmetric monoidal category.) 142 | -------------------------------------------------------------------------------- /README.html: -------------------------------------------------------------------------------- 1 |

OPL

2 |

Operad Programming Language (OPL) is the language of wiring.

3 |

Current Status

4 | 27 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | OPL 2 | ==================== 3 | 4 | Operad Programming Language (OPL) is the language of wiring. 5 | 6 | Current Status 7 | -------------------- 8 | 9 | * OPL is a simple language which includes 10 | - boxes 11 | - wiring diagrams 12 | - wiring compositions 13 | * Parser: implemented 14 | * Typechecker: implemented 15 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bin/opl: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CategoricalData/opl/5364cea0ada4483df68d378f7635ffd2c1729c01/bin/opl -------------------------------------------------------------------------------- /old/Lang/OPL/Calculus/Lang.hs: -------------------------------------------------------------------------------- 1 | module Lang.OPL.Calculus.Lang where 2 | 3 | -- NOTATION: 4 | -- -- types A and B are abstract 5 | -- -- _______________________ 6 | -- -- foo = | _____ | 7 | -- -- | >-A -> | | -> A >-| -> A 8 | -- -- A -> |/ | | | 9 | -- -- |\ B -> |_____| -> B | 10 | -- -- | \ \-<-<-<-<-<-<-/ | 11 | -- -- | \ (^delay False) | 12 | -- -- | \ | 13 | -- -- | \>->->->->->->->->-| -> A 14 | -- -- |_______________________| 15 | -- -- 16 | -- -- type declaration 17 | -- foo : forall {A B}. (A B >-> A B) -> (A >-> A A) 18 | -- -- infered types 19 | -- foo = tfun {A B}. fun F. wire. 20 | -- IN x 21 | -- loop z. 22 | -- z' <- delay False -< z 23 | -- y z <- F -< x z' 24 | -- OUT y x 25 | -- -- explicit types 26 | -- foo = tfun {A B}. fun (F:A B >-> A B). wire (A >-> A A). 27 | -- IN x 28 | -- loop z. 29 | -- z' <- delay False -< z 30 | -- y z <- F -< x z' 31 | -- OUT y x 32 | -- -- unicode abreviations 33 | -- foo = Λ {A B}. λ (F:A B >-> A B). γ (A >-> A A). 34 | -- IN x 35 | -- loop z. 36 | -- z' <- delay False -< z 37 | -- y z <- F -< x z' 38 | -- OUT y x 39 | 40 | -------------------- Core -------------------- 41 | type Name = String 42 | 43 | data Prog = [Def] 44 | data Def = Def 45 | { defName :: Name 46 | , defTerm :: Term 47 | } 48 | 49 | data Exp = 50 | Var_E Name 51 | | Function_E [(Name,Type)] Term 52 | TFunction_E [Name] Term 53 | | Wire_E Type [Name] [Statement] [Name] 54 | | App_T Term Term 55 | 56 | data Type = 57 | Var_T Name 58 | | Function_T Type Type 59 | | TFunction_T Name Type Type 60 | | Wire_T [Type] [Type] 61 | 62 | data Statement = Statement 63 | { statementInputs :: [Name] 64 | , statementAction :: Exp 65 | , statementOutputs :: [Name] 66 | } 67 | -------------------------------------------------------------------------------- /old/Lang/OPL/Calculus/Parser.hs: -------------------------------------------------------------------------------- 1 | module Lang.OPL.Calculus.Parser where 2 | 3 | data Token = 4 | Keyword String 5 | | Indent 6 | | Unindent 7 | | Whitespace 8 | | Newline 9 | | Comment String 10 | | Symbol String 11 | 12 | keywords :: [String] 13 | keywords = 14 | [ "=" 15 | , "." 16 | , "->" 17 | , "<-" 18 | , "-<" 19 | , ">->" 20 | , "forall" 21 | , "fun" 22 | , "tfun" 23 | , "wire" 24 | ] 25 | 26 | keywordsLongestFirst :: [String] 27 | keywordsLongestFirst = sortBy ((>=) `on` length) keywords 28 | 29 | tokenKeyword :: Parser String 30 | tokenKeyword = msum $ each keywordsLongestFirst $ string 31 | 32 | tokenWhitespace :: Parser String 33 | tokenWhitespace = seq1 $ any " " 34 | 35 | tokenNewline :: Parser String 36 | tokenNewline = string "\n" <|> string "\n\r" 37 | 38 | tokenComment :: Parser String 39 | tokenComment = undefined 40 | 41 | tokenSymbol :: Parser String 42 | tokenSymbol = do 43 | x <- alpha <|> any "_" 44 | xs <- seq $ alphaNumeric <|> punctuation 45 | return $ x:xs 46 | 47 | tokenComment :: Parser String 48 | tokenComment = msum 49 | [ do 50 | string "--" 51 | endBy tokenNewline 52 | , tokenNestedComment 53 | ] 54 | 55 | tokenNestedComment :: Parser String 56 | tokenNestedComment = msum 57 | [ string "{-" 58 | tokenNestedComment 59 | string "-}" 60 | , char $ alpha <|> num <|> punctuation <|> space <|> newline 61 | ] 62 | 63 | token :: Parser Token 64 | token = msum 65 | [ liftM Keyword tokenKeyword 66 | , liftM Whitespace tokenWhitespace 67 | , liftM Comment tokenComment 68 | , liftM Symbol tokenSymbol 69 | ] 70 | 71 | def :: Parser Def 72 | def = 73 | -------------------------------------------------------------------------------- /old/Lang/OPL/Categorical/Lang.hs: -------------------------------------------------------------------------------- 1 | module Lang.OPL.Denotation.Lang where 2 | 3 | -- NOTATION: 4 | -- 5 | -- -- I is short for 'Int' and B is short for 'Bool' 6 | -- -- _______________________ 7 | -- -- foo = | _____ | 8 | -- -- | >-I -> | | -> I >-| -> I 9 | -- -- I -> |/ | | | 10 | -- -- |\ B -> |_____| -> B | 11 | -- -- | \ \-<-<-<-<-<-<-/ | 12 | -- -- | \ (^delay False) | 13 | -- -- | \ | 14 | -- -- | \>->->->->->->->->-| -> I 15 | -- -- |_______________________| 16 | -- -- 17 | -- -- the (^delay False) delays the looped wire, using False as the initial 18 | -- -- value 19 | -- 20 | -- operad t1 = Int Bool >-> Int Bool 21 | -- operad t2 = Int >-> Int Int 22 | -- 23 | -- -- direct specification 24 | -- foo : [(W:Int) (X:Bool) >-> (Y:Int) (Z:Bool)] -> [(A:Int) >-> (B:Int) (C:Int)] 25 | -- -- using an operad with local names 26 | -- foo : t1 with [W X >-> Y Z] -> t2 with [A >-> B C] 27 | -- foo = 28 | -- W <- A 29 | -- X <- Z delay False 30 | -- B <- Y 31 | -- C <- A 32 | 33 | data Type = Int_T | Bool_T 34 | 35 | data Operad = Operad 36 | { objIn :: [Type] 37 | , objOut :: [Type] 38 | } 39 | 40 | data Tag = AIn | AOut | BIn | BOut 41 | newtype TName (t::Tag) = TName Name 42 | 43 | data Hom = Hom 44 | { homAIn :: [TName AIn] 45 | , homAOut :: [TName AOut] 46 | , homBIn :: [TName BIn] 47 | , homBOut :: [TName BOut] 48 | , homMap :: Either (TName BOut) (TName AIn) -> Either (TName BIn) (TName AOut) 49 | } 50 | -------------------------------------------------------------------------------- /old/Lang/OPL/Combinator.hs: -------------------------------------------------------------------------------- 1 | module Lang.OPL.Algebra where 2 | 3 | data Term a b where 4 | Id :: Term a a 5 | Split :: Term a (a,a) 6 | Sink :: Term (a,b) a 7 | Swap :: Term (a,b) (b,a) 8 | Assoc :: Term ((a,b),c) (a,(b,c)) 9 | Loop :: Term (a,c) (b,c) -> Term a b 10 | (:∘:) :: Term b c -> Term a b -> Term a c 11 | (:⊗:) :: Term a b -> Term a' b' -> Term (a,a') (b,b') 12 | 13 | -------------------------------------------------------------------------------- /old/Lang/OPL/CombinatorMorphism.hs: -------------------------------------------------------------------------------- 1 | module Lang.OPL.AlgebraMorphism where 2 | 3 | data Term a b c d where 4 | Id :: Term a b a b 5 | Spilt :: Term a b a (b,b) 6 | Sink :: Term a b (a,c) b 7 | Swap :: Term a (b,c) a (c,b) 8 | Assoc :: Term a ((b,c),d) a (b,(c,d)) 9 | Loop :: Term (a,c) (b,c) a b 10 | (:∘:) :: Term a b c d -> Term c d e f -> Term a b e f 11 | (:⊗:) :: Term a b c d -> Term a' b' c' d' -> Term (a,a') (b,b') (c,c') (d,d') 12 | -------------------------------------------------------------------------------- /opl.cabal: -------------------------------------------------------------------------------- 1 | author: David Darais 2 | build-type: Simple 3 | cabal-version: >= 1.10 4 | category: Language 5 | extra-source-files: README.md 6 | license-file: LICENSE 7 | license: CCPL 8 | maintainer: david.darais@gmail.com 9 | name: opl 10 | synopsis: Operad Programming Language 11 | version: 0.1.0.0 12 | 13 | library 14 | build-depends: base == 4.6.* 15 | , parsec == 3.1.* 16 | , text == 1.1.* 17 | , data-lens-template == 2.1.* 18 | , darais-fp == 0.1.* 19 | , mtl == 2.1.* 20 | , ansi-terminal == 0.6.* 21 | , containers == 0.5.* 22 | default-extensions: FlexibleContexts 23 | , StandaloneDeriving 24 | , TemplateHaskell 25 | , ConstraintKinds 26 | , TupleSections 27 | , GeneralizedNewtypeDeriving 28 | , TypeFamilies 29 | , OverloadedStrings 30 | , InstanceSigs 31 | , ScopedTypeVariables 32 | , MultiParamTypeClasses 33 | , FunctionalDependencies 34 | default-language: Haskell2010 35 | exposed-modules: Lang.OPL.Lexer 36 | Lang.OPL.Parser 37 | , Lang.OPL.Syntax 38 | , Lang.OPL.Semantics 39 | , Lang.OPL.Common 40 | , Lang.OPL.Check 41 | , Lang.OPL.CheckMonad 42 | , Lang.OPL.Message 43 | , Lang.OPL.Annotated 44 | other-modules: Util.Parsec 45 | , Util.Either 46 | hs-source-dirs: src 47 | 48 | executable opl 49 | build-depends: base == 4.6.* 50 | , opl == 0.1.* 51 | , parsec == 3.1.* 52 | , text == 1.1.* 53 | , data-lens-template == 2.1.* 54 | , darais-fp == 0.1.* 55 | , mtl == 2.1.* 56 | , ansi-terminal == 0.6.* 57 | , containers == 0.5.* 58 | default-extensions: FlexibleContexts 59 | , StandaloneDeriving 60 | , TemplateHaskell 61 | , ConstraintKinds 62 | , TupleSections 63 | , GeneralizedNewtypeDeriving 64 | , TypeFamilies 65 | , OverloadedStrings 66 | , InstanceSigs 67 | , ScopedTypeVariables 68 | , MultiParamTypeClasses 69 | , FunctionalDependencies 70 | default-language: Haskell2010 71 | hs-source-dirs: src 72 | main-is: Lang/OPL/Main.hs 73 | -------------------------------------------------------------------------------- /opl_source/comments.opl: -------------------------------------------------------------------------------- 1 | # comment 2 | #| 3 | ##|| 4 | nested 5 | ||## 6 | comment 7 | |# 8 | -------------------------------------------------------------------------------- /opl_source/prog1.opl: -------------------------------------------------------------------------------- 1 | box A := int bool =[]= int bool 2 | 3 | define W : A A -> A 4 | define W := wiring 5 | internal 6 | i1 : A[a b =[]= x y] plug a <- i1.x, b <- o.b 7 | i2 : A[a b =[]= x y] plug a <- o.a, b <- i2.y 8 | external 9 | o : A[a b =[]= x y] plug x <- i2.x, y <- i1.y 10 | end 11 | 12 | define X1 : A A A A -> A 13 | define X1 := W[a b => b a] <- W W 14 | 15 | define X2 : A A A -> A 16 | define X2 := W <- W _ 17 | 18 | define X3 : A A A -> A 19 | define X3 := W <- _ W 20 | 21 | define L : prop @ A A -> A 22 | define L := prop W 23 | 24 | define L1 : prop @ A A A A -> A 25 | define L1 := L[x y => y x] <- L L 26 | 27 | define L2 : prop @ A A A -> A 28 | define L2 := L <- _ L 29 | 30 | define L3 : prop @ A A A -> A 31 | define L3 := L <- L _ 32 | -------------------------------------------------------------------------------- /opl_source/sample.opl: -------------------------------------------------------------------------------- 1 | require 2 | algebra prop 3 | define foo : prop @ A 4 | import lib1 only box A 5 | import lib2 6 | apply box boxy := A 7 | only box B 8 | import lib3 qualified apply 9 | algebra X := prop 10 | provide 11 | define P : prop @ A 12 | where 13 | 14 | module X := 15 | import lib3 16 | apply define foo := A 17 | only box B 18 | where 19 | box Foo 20 | box Foo := int =[]= bool 21 | end 22 | 23 | module Y := 24 | box Bar 25 | box Bar := bool bool =[]= bool bool 26 | end 27 | 28 | box A := int bool =[]= int bool 29 | 30 | define W : A A -> int bool =[]= int bool 31 | define W := wiring 32 | internal 33 | i1 : (int bool =[]= int bool)[x y =[]= a b] plug x <- i2.a, y <- e.y 34 | i2 : A[x y =[]= a b] plug x <- e.x, y <- i2.b 35 | external 36 | e : A[x y =[]= a b] plug a <- i1.a, b <- i2.b 37 | end 38 | 39 | define C : A A A A -> A 40 | define C := W[l r => r l] <- W W 41 | 42 | define P : prop @ A 43 | define P := prop C <- foo foo foo foo 44 | 45 | define UP := prop C <- foo _ foo _ 46 | define P' := prop C <- foo _ foo _ <- foo foo 47 | -------------------------------------------------------------------------------- /src/Lang/OPL/Annotated.hs: -------------------------------------------------------------------------------- 1 | module Lang.OPL.Annotated where 2 | 3 | import Prelude () 4 | import FP 5 | import Text.Parsec (ParsecT, SourcePos) 6 | import qualified Text.Parsec as P 7 | 8 | data Annotated a t = Annotated 9 | { annotation :: a 10 | , stripAnnotation :: t 11 | } deriving (Show) 12 | 13 | instance (Eq t) => Eq (Annotated a t) where 14 | (==) = (==) `on` stripAnnotation 15 | instance (Ord t) => Ord (Annotated a t) where 16 | compare = compare `on` stripAnnotation 17 | instance (Pretty t) => Pretty (Annotated a t) where 18 | pretty = pretty . stripAnnotation 19 | 20 | annotate :: (P.Stream s m t) => ParsecT s u m a -> ParsecT s u m (Annotated SourcePos a) 21 | annotate p = do 22 | l <- P.getPosition 23 | liftM (Annotated l) p 24 | 25 | -------------------------------------------------------------------------------- /src/Lang/OPL/Check.hs: -------------------------------------------------------------------------------- 1 | module Lang.OPL.Check where 2 | 3 | import Prelude() 4 | import FP 5 | 6 | import Data.Lens.Template 7 | import Data.Map (Map) 8 | import Data.Set (Set) 9 | import Lang.OPL.Common 10 | import Lang.OPL.Annotated 11 | import Lang.OPL.Message 12 | import qualified Data.List as List 13 | import qualified Data.Map as Map 14 | import qualified Data.Set as Set 15 | import qualified FP.Pretty as P 16 | import qualified Lang.OPL.Semantics as Sem 17 | import qualified Lang.OPL.Syntax as Syn 18 | 19 | data CheckEnv = CheckEnv 20 | { _phaseL :: String 21 | , _contextL :: Context 22 | } deriving (Eq, Ord, Show) 23 | makeLens ''CheckEnv 24 | 25 | checkEnv0 :: CheckEnv 26 | checkEnv0 = CheckEnv 27 | { _phaseL = "
" 28 | , _contextL = [] 29 | } 30 | 31 | data Registered a t = 32 | Declared t 33 | | Defined a t 34 | deriving (Eq, Ord, Show) 35 | data CheckState = CheckState 36 | { _boxesL :: Map AName (Registered Sem.Box ()) 37 | , _wiringExpsL :: Map AName (Registered Sem.WiringExp Sem.WiringType) 38 | , _warningsL :: [Message] 39 | } deriving (Eq, Ord, Show) 40 | makeLens ''CheckState 41 | 42 | checkState0 :: CheckState 43 | checkState0 = CheckState 44 | { _boxesL = Map.empty 45 | , _wiringExpsL = Map.empty 46 | , _warningsL = [] 47 | } 48 | 49 | type Check m = 50 | ( MonadError Message m 51 | , MonadReaderView CheckEnv m 52 | , MonadStateView CheckState m 53 | ) 54 | 55 | isCheck :: (Check m) => m a 56 | isCheck = error "why would you evaluate this?!?!" 57 | 58 | -------------------- generic helpers -------------------- 59 | 60 | simpleContext :: (Check m) => String -> m a -> m a 61 | simpleContext s = 62 | localViewMod contextL $ (:) (Nothing, PrettyString $ P.string s) 63 | 64 | inContext :: (Check m) => String -> AName -> m a -> m a 65 | inContext s (Annotated l n) = 66 | localViewMod contextL $ (:) (Just l, PrettyString $ P.hsep [P.string s, pretty n]) 67 | 68 | inPathContext :: (Check m) => String -> APath -> m a -> m a 69 | inPathContext s (Annotated l p) = 70 | localViewMod contextL $ (:) (Just l, PrettyString $ P.hsep [P.string s, pretty p]) 71 | 72 | withPhase :: (Check m) => String -> m () -> m () 73 | withPhase = localViewSet phaseL 74 | 75 | checkError :: (Check m) => String -> Maybe PrettyString -> m a 76 | checkError name description = do 77 | p <- askView phaseL 78 | c <- askView contextL 79 | throwError $ Message (PrettyString $ P.string p) c (PrettyString $ P.string name) description 80 | 81 | checkWarning :: (Check m) => String -> Maybe PrettyString -> m () 82 | checkWarning name description = do 83 | p <- askView phaseL 84 | c <- askView contextL 85 | modifyView warningsL $ (:) $ Message (PrettyString $ P.string p) c (PrettyString $ P.string name) description 86 | 87 | checkNoDup :: (Check m, Ord a, Pretty a) => [a] -> m (Set a) 88 | checkNoDup xs = do 89 | let xset = Set.fromList xs 90 | when (List.length xs /= Set.size xset) $ 91 | checkError "duplicate" $ Just $ PrettyString $ P.hsep 92 | [ P.string "found in" 93 | , pretty xs 94 | ] 95 | return xset 96 | 97 | checkExactZip :: (Check m, Pretty a, Pretty b) => [a] -> [b] -> m [(a, b)] 98 | checkExactZip xs ys = do 99 | when (List.length xs /= List.length ys) $ 100 | checkError "lists not of same length" $ Just $ PrettyString $ P.vsep 101 | [ pretty xs 102 | , P.string "<>" 103 | , pretty ys 104 | ] 105 | return $ zip xs ys 106 | 107 | checkEqual :: (Check m, Pretty a, Eq a) => a -> a -> m () 108 | checkEqual x y = 109 | when (not $ x == y) $ 110 | checkError "not equal" $ Just $ PrettyString $ P.vsep 111 | [ pretty x 112 | , P.string "<>" 113 | , pretty y 114 | ] 115 | 116 | checkNotEqual :: (Check m, Pretty a, Eq a) => a -> a -> m () 117 | checkNotEqual x y = 118 | when (x == y) $ 119 | checkError "equal" $ Just $ PrettyString $ P.vsep 120 | [ pretty x 121 | , P.string "==" 122 | , pretty y 123 | ] 124 | 125 | ---------- registering checked defs ---------- 126 | 127 | declareBox :: (Check m) => AName -> m () 128 | declareBox n = do 129 | bs <- getView boxesL 130 | let action = putView boxesL $ Map.insert n (Declared ()) bs 131 | case Map.lookup n bs of 132 | Nothing -> action 133 | Just (Declared ()) -> checkError "repeat declaration" Nothing 134 | Just (Defined _ _) -> checkError "already defined" Nothing 135 | 136 | defineBox :: (Check m) => AName -> Sem.Box -> m () 137 | defineBox n b = do 138 | bs <- getView boxesL 139 | let action = putView boxesL $ Map.insert n (Defined b ()) bs 140 | case Map.lookup n bs of 141 | Nothing -> action 142 | Just (Declared ()) -> action 143 | Just (Defined _ _) -> checkError "repeat definition" Nothing 144 | 145 | lookupBox :: (Check m) => AName -> m Sem.Box 146 | lookupBox n = do 147 | e <- getView boxesL 148 | case Map.lookup n e of 149 | Nothing -> checkError "not defined" Nothing 150 | Just (Declared _) -> checkError "declared but not defined" Nothing 151 | Just (Defined b ()) -> return b 152 | 153 | declareWiring :: (Check m) => AName -> Sem.WiringType -> m () 154 | declareWiring n wdt = do 155 | ws <- getView wiringExpsL 156 | let action = putView wiringExpsL $ Map.insert n (Declared wdt) ws 157 | case Map.lookup n ws of 158 | Nothing -> action 159 | Just (Declared _) -> checkError "repeat declaration" Nothing 160 | Just (Defined _ _) -> checkError "already defined" Nothing 161 | 162 | registerWiring :: (Check m) => AName -> Sem.WiringExp -> Sem.WiringType -> m () 163 | registerWiring n wd wdt = do 164 | ws <- getView wiringExpsL 165 | let action = putView wiringExpsL $ Map.insert n (Defined wd wdt) ws 166 | case Map.lookup n ws of 167 | Nothing -> action 168 | Just (Declared wdt') -> do 169 | checkEqual wdt wdt' 170 | action 171 | Just (Defined _ _) -> checkError "repeat definition" Nothing 172 | 173 | lookupWiringExp :: (Check m) => AName -> m (Sem.WiringExp, Sem.WiringType) 174 | lookupWiringExp n = do 175 | ws <- getView wiringExpsL 176 | case Map.lookup n ws of 177 | Nothing -> checkError "not defined" Nothing 178 | Just (Declared _) -> checkError "declared but not defined" Nothing 179 | Just (Defined we wt) -> return (we, wt) 180 | 181 | -------------------- type checker -------------------- 182 | 183 | check :: (Check m) => Syn.TLModule -> m () 184 | check (Syn.TLModule m) = withPhase "typechecking" $ checkModule m 185 | 186 | checkModule :: (Check m) => Syn.Module -> m () 187 | checkModule (Syn.Module _ _ _ ss) = mapM_ checkStatement ss 188 | 189 | checkStatement :: (Check m) => Syn.Statement -> m () 190 | checkStatement (Syn.DeclStatement decl) = checkDecl decl 191 | checkStatement (Syn.DefStatement def) = checkDef def 192 | 193 | checkDecl :: (Check m) => Syn.Decl -> m () 194 | checkDecl (Syn.AlgebraDecl n) = inContext "algebra" n $ checkWarning "not supported" Nothing 195 | checkDecl (Syn.ModuleDecl n) = inContext "module" n $ checkWarning "not supported" Nothing 196 | checkDecl (Syn.BoxDecl n) = inContext "box" n $ declareBox n 197 | checkDecl (Syn.WiringDecl n wte) = inContext "define" n $ do 198 | wt <- checkWiringType wte 199 | declareWiring n wt 200 | 201 | checkDef :: (Check m) => Syn.Def -> m () 202 | checkDef (Syn.AlgebraDef n _) = inContext "algebra" n $ checkWarning "not supported" Nothing 203 | checkDef (Syn.ModuleDef n _) = inContext "module" n $ checkWarning "not supported" Nothing 204 | checkDef (Syn.BoxDef n be) = inContext "box" n $ do 205 | b <- checkBox be 206 | defineBox n b 207 | checkDef (Syn.WiringDef n we) = inContext "define" n $ do 208 | (w, wt) <- checkWiringExp we 209 | registerWiring n w wt 210 | 211 | ---------- boxes ---------- 212 | 213 | validPlugTypes :: [Name] 214 | validPlugTypes = map Name 215 | [ "int" 216 | , "float" 217 | , "bool" 218 | ] 219 | 220 | checkPlugType :: (Check m) => PlugType -> m () 221 | checkPlugType t = do 222 | inContext "plug type" (getPlugType t) $ 223 | when (not $ stripAnnotation (getPlugType t) `elem` validPlugTypes) $ 224 | checkError "invalid" $ Just $ PrettyString $ P.hsep 225 | [ P.string "must be an element of" 226 | , pretty validPlugTypes 227 | ] 228 | 229 | checkBox :: (Check m) => Syn.Box -> m Sem.Box 230 | checkBox (Syn.VarBox n) = inContext "var" n $ lookupBox n 231 | checkBox (Syn.ArrowBox ab) = checkBoxArrow ab 232 | 233 | checkBoxArrow :: (Check m) => BoxArrow -> m Sem.Box 234 | checkBoxArrow (BoxArrow inputs outputs) = do 235 | forM_ (inputs ++ outputs) checkPlugType 236 | return $ Sem.Box inputs outputs 237 | 238 | ---------- wiring diagrams ---------- 239 | 240 | checkWiringArrow :: (Check m) => Syn.WiringArrow -> m Sem.WiringArrow 241 | checkWiringArrow (Syn.WiringArrow ins out) = do 242 | ins' <- mapM checkBox ins 243 | out' <- checkBox out 244 | return $ Sem.WiringArrow ins' out' 245 | 246 | checkWiringType :: (Check m) => Syn.WiringType -> m Sem.WiringType 247 | checkWiringType (Syn.VarWiringType _) = checkError "wiring type variables not supported" Nothing 248 | checkWiringType (Syn.LiftWiringType n wt) = liftM (Sem.LiftWiringType n) $ checkWiringType wt 249 | checkWiringType (Syn.BoxWiringType b) = liftM Sem.BoxWiringType $ checkBox b 250 | checkWiringType (Syn.ArrowWiringType a) = liftM Sem.ArrowWiringType $ checkWiringArrow a 251 | 252 | data Tag = Internal | External 253 | deriving (Eq, Ord, Show) 254 | data BoundBox = BoundBox 255 | { boundBoxInputs :: Map Name PlugType 256 | , boundBoxOutputs :: Map Name PlugType 257 | } deriving (Eq, Ord, Show) 258 | 259 | -- a valid source for a path is either an output of an internal box or an 260 | -- input of an external box 261 | checkValidSource :: (Check m) => Map Name (Map Name PlugType) -> APath -> m PlugType 262 | checkValidSource validSources apath = do 263 | inPathContext "path" apath $ do 264 | -- check that path has exactly two levels 265 | (root, nodeName) <- case stripAnnotation apath of 266 | root :.: SingletonPath nodeName -> return (root, nodeName) 267 | _ -> checkError "invalid" $ Just $ PrettyString $ P.string "must be a two-level path" 268 | -- check that the root exists in existing definitions of wirings 269 | nodes <- case Map.lookup root $ validSources of 270 | Nothing -> checkError "invalid" $ Just $ PrettyString $ P.string "root must exist as an internal or external box" 271 | Just w -> return w 272 | -- return the type of the node, checking first that it exists 273 | case Map.lookup nodeName $ nodes of 274 | Nothing -> do 275 | let d = concat 276 | [ "name must exist as either " 277 | , "an output of an internal box " 278 | , "or an input of the external box" 279 | ] 280 | checkError "invalid" $ Just $ PrettyString $ P.string d 281 | Just t -> return t 282 | 283 | checkWiringDiagram :: forall m. (Check m) => Syn.WiringDiagram -> m (Sem.WiringDiagram, Sem.WiringType) 284 | checkWiringDiagram (Syn.WiringDiagram internalWirings externalWiring) = do 285 | -- make sure there are no duplicates in binding names 286 | let names = Syn.wiringName externalWiring : map Syn.wiringName internalWirings 287 | _ <- checkNoDup names 288 | let extractData :: Syn.Wiring -> (AName, ((Syn.Box, BoxBinder), [Plug])) 289 | extractData = Syn.wiringName &&& (Syn.wiringBox &&& Syn.wiringBoxBinder) &&& Syn.wiringPlugs 290 | internalData = map extractData internalWirings 291 | externalData = extractData externalWiring 292 | applyTemplate :: (Check m) => (Sem.Box, BoxBinder) -> m (Sem.Box, BoxBinder, BoundBox) 293 | applyTemplate (box@(Sem.Box ins outs), boxbin@(BoxBinder bins bouts)) = do 294 | _ <- checkNoDup bins 295 | _ <- checkNoDup bouts 296 | insMap <- checkExactZip (map stripAnnotation bins) ins 297 | outsMap <- checkExactZip (map stripAnnotation bouts) outs 298 | let bobo = BoundBox (Map.fromList insMap) (Map.fromList outsMap) 299 | return (box, boxbin, bobo) 300 | doBinder :: (AName, ((Syn.Box, BoxBinder), [Plug])) -> m (AName, Sem.Box, BoxBinder, BoundBox, [Plug]) 301 | doBinder = 302 | return . (\ (n, ((b, bb, bobo), ps)) -> (n, b, bb, bobo, ps)) 303 | <=< simpleContext "box template" . (secondM $ firstM $ applyTemplate) 304 | <=< simpleContext "box" . (secondM $ firstM $ firstM checkBox) 305 | packData :: (AName, Sem.Box, BoxBinder, BoundBox, [Plug]) -> Sem.Wiring 306 | packData (n, b, bb, _, ps) = Sem.Wiring n b bb ps 307 | internalBound <- mapM doBinder internalData 308 | externalBound <- doBinder externalData 309 | let allTagged :: [(Tag, (AName, Sem.Box, BoxBinder, BoundBox, [Plug]))] 310 | allTagged = (External,) externalBound : map (Internal,) internalBound 311 | validSources :: Map Name (Map Name PlugType) 312 | validSources = (\ c f -> List.foldl' f Map.empty c) allTagged $ flip $ \ (tag, (name, _, _, bobo, _)) -> 313 | Map.insert (stripAnnotation name) $ case tag of 314 | Internal -> boundBoxOutputs bobo 315 | External -> boundBoxInputs bobo 316 | validSourcePaths :: Set Path 317 | validSourcePaths = Set.fromList $ do 318 | (root, nodes) <- Map.toList validSources 319 | flip map (Map.keys nodes) $ \ n -> 320 | root :.: SingletonPath n 321 | mappedSourcePaths :: Set Path 322 | mappedSourcePaths = (\ c f -> List.foldl' f Set.empty c) allTagged $ flip $ \ (_, (_, _, _, _, plugs)) -> 323 | Set.union $ Set.fromList $ map (stripAnnotation . plugPath) plugs 324 | -- check wirings 325 | forM_ allTagged $ \ (tag, (name, _, _, bobo, plugs)) -> do 326 | inContext "wiring" name $ do 327 | -- the nodes that plugs must map to are different for internal and 328 | -- external boxes 329 | let nodes = case tag of 330 | Internal -> boundBoxInputs bobo 331 | External -> boundBoxOutputs bobo 332 | -- make sure plugs correspond to nodes 333 | plugNames <- checkNoDup $ map (stripAnnotation . plugName) plugs 334 | checkEqual plugNames (Map.keysSet nodes) 335 | -- check individual plug integrity 336 | forM plugs $ \ (Plug name path) -> do 337 | -- get the type for the input node 338 | let plugType = fromJust $ Map.lookup (stripAnnotation name) nodes 339 | -- validate the path and return the type of the source 340 | sourcePlugType <- checkValidSource validSources path 341 | -- check that the input node type matches the source type 342 | checkEqual plugType sourcePlugType 343 | -- check surjectivity 344 | simpleContext "surjectivity check" $ 345 | checkEqual validSourcePaths mappedSourcePaths 346 | -- check no straight wires 347 | simpleContext "no straight wires check" $ do 348 | let (n, _, _, _, explugs) = externalBound 349 | forM_ (map plugPath explugs) $ \ ppath -> do 350 | let root :.: SingletonPath _ = stripAnnotation ppath 351 | checkNotEqual (stripAnnotation n) root 352 | let internalResults = map packData internalBound 353 | externalResult = packData externalBound 354 | return 355 | ( Sem.WiringDiagram internalResults externalResult 356 | , Sem.ArrowWiringType $ Sem.WiringArrow (map Sem.wiringBox internalResults) (Sem.wiringBox externalResult) 357 | ) 358 | 359 | checkLiftWiring :: (Check m) => AName -> Syn.WiringExp -> m (Sem.WiringExp, Sem.WiringType) 360 | checkLiftWiring n e = do 361 | (we, wt) <- checkWiringExp e 362 | return (Sem.LiftWiringExp n we, Sem.LiftWiringType n wt) 363 | 364 | permute :: (Check m, Pretty a) => Renaming -> [a] -> m [a] 365 | permute (Renaming from to) xs = do 366 | fromSet <- checkNoDup from 367 | toSet <- checkNoDup to 368 | checkEqual fromSet toSet 369 | namedXs <- checkExactZip from xs 370 | return $ flip map to $ \ n -> 371 | fromJust $ List.lookup n namedXs 372 | 373 | renameWiringArrow :: (Check m) => Renaming -> Sem.WiringArrow -> m Sem.WiringArrow 374 | renameWiringArrow r (Sem.WiringArrow ins out) = do 375 | pins <- permute r ins 376 | return $ Sem.WiringArrow pins out 377 | 378 | renameWiringType :: (Check m) => Renaming -> Sem.WiringType -> m Sem.WiringType 379 | renameWiringType r (Sem.LiftWiringType n wt) = liftM (Sem.LiftWiringType n) $ renameWiringType r wt 380 | renameWiringType r (Sem.BoxWiringType _) = checkError "cannot rename box type" Nothing 381 | renameWiringType r (Sem.ArrowWiringType a) = liftM Sem.ArrowWiringType $ renameWiringArrow r a 382 | 383 | checkRenamingWiring :: (Check m) => Renaming -> Syn.WiringExp -> m (Sem.WiringExp, Sem.WiringType) 384 | checkRenamingWiring r e = do 385 | (we, wt) <- checkWiringExp e 386 | pwt <- renameWiringType r wt 387 | return (Sem.RenamingWiringExp r we, pwt) 388 | 389 | checkApplyWiring :: (Check m) => Syn.WiringExp -> [Maybe Syn.WiringExp] -> m (Sem.WiringExp, Sem.WiringType) 390 | checkApplyWiring wf waMs = do 391 | (wfv, wft) <- checkWiringExp wf 392 | wavtMs <- mapM (mapM checkWiringExp) waMs 393 | checkSemApplyWiring wfv wft wavtMs 394 | 395 | checkSemApplyWiring :: forall m. (Check m) => 396 | Sem.WiringExp -> Sem.WiringType -> [Maybe (Sem.WiringExp, Sem.WiringType)] 397 | -> m (Sem.WiringExp, Sem.WiringType) 398 | checkSemApplyWiring wfv wft wavtMs = 399 | case wft of 400 | Sem.LiftWiringType n unWft -> do 401 | let Sem.LiftWiringExp _ unWfv = wfv 402 | unWavtMs <- mapM (mapM $ unliftArg n) wavtMs 403 | res <- checkSemApplyWiring unWfv unWft unWavtMs 404 | return $ liftResult n res 405 | Sem.BoxWiringType _ -> checkError "cannot apply a base box type" Nothing 406 | Sem.ArrowWiringType (Sem.WiringArrow ins out) -> do 407 | tapps <- 408 | liftM (map $ second Syn.unUnderscored) 409 | $ checkExactZip ins 410 | $ map (Syn.Underscored . map snd) wavtMs 411 | let eapps = map (map fst) wavtMs 412 | tMs <- (\ c f -> foldr f (return []) c) tapps $ \ (int, tM) rest -> do 413 | let k f = liftM f rest 414 | case tM of 415 | Nothing -> k (int:) 416 | Just t -> case t of 417 | Sem.LiftWiringType _ _ -> checkError "lifted types must not appear inside complex types" Nothing 418 | Sem.BoxWiringType b -> do 419 | checkEqual b int 420 | k id 421 | Sem.ArrowWiringType (Sem.WiringArrow ins out) -> do 422 | checkEqual out int 423 | k (ins++) 424 | let finalType = case tMs of 425 | [] -> Sem.BoxWiringType out 426 | ins -> Sem.ArrowWiringType $ Sem.WiringArrow ins out 427 | return (Sem.ApplyWiringExp wfv eapps, finalType) 428 | where 429 | unliftArg :: AName -> (Sem.WiringExp, Sem.WiringType) -> m (Sem.WiringExp, Sem.WiringType) 430 | unliftArg n (Sem.LiftWiringExp en e, Sem.LiftWiringType tn t) = do 431 | checkEqual n en 432 | checkEqual n tn 433 | return $ (e, t) 434 | unliftArg _ _ = checkError "cannot apply lifted to unlifted values" Nothing 435 | liftResult :: AName -> (Sem.WiringExp, Sem.WiringType) -> (Sem.WiringExp, Sem.WiringType) 436 | liftResult n (e, t) = (Sem.LiftWiringExp n e, Sem.LiftWiringType n t) 437 | 438 | checkWiringExp :: (Check m) => Syn.WiringExp -> m (Sem.WiringExp, Sem.WiringType) 439 | checkWiringExp (Syn.VarWiringExp n) = inContext "var" n $ lookupWiringExp n 440 | checkWiringExp (Syn.LiftWiringExp n we) = checkLiftWiring n we 441 | checkWiringExp (Syn.DiagramWiringExp wd) = do 442 | (swd, wt) <- checkWiringDiagram wd 443 | return (Sem.DiagramWiringExp swd, wt) 444 | checkWiringExp (Syn.RenamingWiringExp r we) = checkRenamingWiring r we 445 | checkWiringExp (Syn.ApplyWiringExp e eMs) = checkApplyWiring e eMs 446 | -------------------------------------------------------------------------------- /src/Lang/OPL/CheckMonad.hs: -------------------------------------------------------------------------------- 1 | module Lang.OPL.CheckMonad where 2 | 3 | import Prelude() 4 | import FP 5 | import Lang.OPL.Check 6 | import System.Exit 7 | import Lang.OPL.Message 8 | 9 | newtype CheckMonadT m a = CheckMonadT 10 | { unCheckMonadT :: ReaderT CheckEnv (StateT CheckState (EitherT Message m)) a } 11 | deriving 12 | ( Monad 13 | , MonadReader CheckEnv 14 | , MonadState CheckState 15 | , MonadError Message 16 | ) 17 | type instance (MEnv (CheckMonadT m)) = CheckEnv 18 | type instance (MState (CheckMonadT m)) = CheckState 19 | 20 | type CheckMonad = CheckMonadT Identity 21 | 22 | -------------------- CheckMonadT -------------------- 23 | 24 | isCheck_CheckMonadT :: (Monad m) => CheckMonadT m a 25 | isCheck_CheckMonadT = isCheck 26 | 27 | runCheckMonadT :: CheckEnv -> CheckState -> CheckMonadT m a -> m (Either Message (a, CheckState)) 28 | runCheckMonadT e s aM = 29 | runEitherT 30 | $ flip runStateT s 31 | $ flip runReaderT e 32 | $ unCheckMonadT aM 33 | 34 | -------------------- CheckMonad -------------------- 35 | 36 | runCheckMonad :: CheckEnv -> CheckState -> CheckMonad a -> Either Message (a, CheckState) 37 | runCheckMonad = runIdentity ..: runCheckMonadT 38 | 39 | execCheckMonad :: CheckEnv -> CheckState -> CheckMonad a -> Either Message CheckState 40 | execCheckMonad = liftM snd ..: runCheckMonad 41 | 42 | execCheckMonadIO :: CheckEnv -> CheckState -> CheckMonad a -> IO CheckState 43 | execCheckMonadIO e s aM = case execCheckMonad e s aM of 44 | Left m -> do 45 | pprintLn m 46 | exitFailure 47 | Right a -> return a 48 | 49 | execCheckMonadIO0 :: CheckMonad a -> IO CheckState 50 | execCheckMonadIO0 = execCheckMonadIO checkEnv0 checkState0 51 | -------------------------------------------------------------------------------- /src/Lang/OPL/Common.hs: -------------------------------------------------------------------------------- 1 | module Lang.OPL.Common where 2 | 3 | import Prelude () 4 | import FP 5 | import Text.Parsec (SourcePos) 6 | import qualified FP.Pretty as P 7 | import Lang.OPL.Annotated 8 | 9 | ---------- Names and Paths ---------- 10 | 11 | type NameAnn = SourcePos 12 | 13 | newtype Name = Name { nameVal :: String } 14 | deriving (Eq, Ord, Show) 15 | instance Pretty Name where 16 | pretty = P.string . nameVal 17 | 18 | type AName = Annotated NameAnn Name 19 | 20 | data Path = SingletonPath Name | Name :.: Path 21 | deriving (Eq, Ord, Show) 22 | instance Pretty Path where 23 | pretty (SingletonPath n) = pretty n 24 | pretty (n :.: p) = do 25 | pretty n 26 | P.punctuation $ P.string "." 27 | pretty p 28 | 29 | pathRoot :: Path -> Name 30 | pathRoot (SingletonPath n) = n 31 | pathRoot (n :.: _) = n 32 | 33 | type APath = Annotated NameAnn Path 34 | 35 | 36 | ---------- Boxes ---------- 37 | 38 | newtype PlugType = PlugType { getPlugType :: AName } 39 | deriving (Eq, Ord, Show) 40 | instance Pretty PlugType where 41 | pretty (PlugType n) = pretty n 42 | 43 | data BoxArrow = BoxArrow 44 | { boxArrowInputs :: [PlugType] 45 | , boxArrowOutputs :: [PlugType] 46 | } deriving (Eq, Ord, Show) 47 | instance Pretty BoxArrow where 48 | pretty (BoxArrow ins outs) = 49 | P.guardLevel (level "=[]=") 50 | $ P.hsep 51 | $ concat 52 | [ map pretty ins 53 | , return $ P.punctuation $ P.string "=[]=" 54 | , map pretty outs 55 | ] 56 | 57 | data BoxBinder = BoxBinder 58 | { boxBinderInputs :: [AName] 59 | , boxBinderOutputs :: [AName] 60 | } deriving (Eq, Ord, Show) 61 | instance Pretty BoxBinder where 62 | pretty (BoxBinder ins outs) = 63 | P.hsep $ concat 64 | [ map pretty ins 65 | , return $ P.punctuation $ P.string "=[]=" 66 | , map pretty outs 67 | ] 68 | 69 | ---------- Wiring ---------- 70 | 71 | data Plug = Plug 72 | { plugName :: AName 73 | , plugPath :: APath 74 | } deriving (Eq, Ord, Show) 75 | instance Pretty Plug where 76 | pretty (Plug n p) = 77 | P.hsep 78 | [ pretty n 79 | , P.punctuation $ P.string "<-" 80 | , pretty p 81 | ] 82 | 83 | data Renaming = Renaming 84 | { renamingFrom :: [AName] 85 | , renamingTo :: [AName] 86 | } deriving (Eq, Ord, Show) 87 | instance Pretty Renaming where 88 | pretty (Renaming from to) = P.hsep $ concat 89 | [ map pretty from 90 | , return $ P.punctuation $ P.string "=>" 91 | , map pretty to 92 | ] 93 | 94 | -------------------------------------------------------------------------------- /src/Lang/OPL/Lexer.hs: -------------------------------------------------------------------------------- 1 | module Lang.OPL.Lexer where 2 | 3 | import Lang.OPL.Annotated 4 | import Data.Text (Text) 5 | import Control.Monad 6 | import Control.Applicative 7 | import Data.Function 8 | import Data.List 9 | import Lang.OPL.Syntax 10 | import Lang.OPL.Common 11 | import Text.Parsec (SourcePos, ParseError) 12 | import Text.Parsec.Text (Parser) 13 | import qualified Text.Parsec as P 14 | 15 | -------------------- Specification -------------------- 16 | 17 | type AnnToken = Annotated SourcePos Token 18 | 19 | data Token = 20 | WhitespaceToken 21 | | CommentToken 22 | | PunctuationToken String 23 | | KeywordToken String 24 | | PathToken Path 25 | deriving (Eq, Ord, Show) 26 | 27 | punctuation :: [String] 28 | punctuation = 29 | [ "(" 30 | , ")" 31 | , "," 32 | , "->" 33 | , ":" 34 | , ":=" 35 | , "<-" 36 | , "=>" 37 | , "=[]=" 38 | , "@" 39 | , "[" 40 | , "]" 41 | , "_" 42 | ] 43 | 44 | keywords :: [String] 45 | keywords = 46 | [ "algebra" 47 | , "all" 48 | , "apply" 49 | , "box" 50 | , "define" 51 | , "end" 52 | , "external" 53 | , "import" 54 | , "internal" 55 | , "module" 56 | , "none" 57 | , "only" 58 | , "plug" 59 | , "provide" 60 | , "qualified" 61 | , "require" 62 | , "where" 63 | , "wiring" 64 | ] 65 | 66 | commentLeader :: String 67 | commentLeader = "#" 68 | 69 | nestedCommentOpen :: String 70 | nestedCommentOpen = "#|" 71 | 72 | nestedCommentClose :: String 73 | nestedCommentClose = "|#" 74 | 75 | -------------------- Whitespace -------------------- 76 | 77 | tokenizeWhitespace :: Parser String 78 | tokenizeWhitespace = P.many1 $ P.oneOf " \t\n\r" 79 | 80 | -------------------- Comments -------------------- 81 | 82 | tokenizeComment :: Parser () 83 | tokenizeComment = do 84 | m <- P.optionMaybe $ P.try $ P.string nestedCommentOpen 85 | case m of 86 | Just _ -> tokenizeNestedComment 1 87 | Nothing -> tokenizeFlatComment 88 | 89 | tokenizeFlatComment :: Parser () 90 | tokenizeFlatComment = do 91 | P.string commentLeader 92 | P.many $ P.noneOf "\n\r" 93 | P.newline 94 | return () 95 | 96 | tokenizeNestedComment :: Int -> Parser () 97 | tokenizeNestedComment 0 = return () 98 | tokenizeNestedComment n = msum 99 | [ do 100 | P.try $ P.string nestedCommentOpen 101 | tokenizeNestedComment (n+1) 102 | , do 103 | P.try $ P.string nestedCommentClose 104 | tokenizeNestedComment (n-1) 105 | , do 106 | P.anyChar 107 | tokenizeNestedComment n 108 | ] 109 | 110 | -------------------- Punctuation -------------------- 111 | 112 | punctuationLongestFirst :: [String] 113 | punctuationLongestFirst = sortBy (flipCompare `on` length) punctuation 114 | 115 | tokenizePunctuation :: Parser String 116 | tokenizePunctuation = msum $ map (P.try . P.string) punctuationLongestFirst 117 | 118 | -------------------- Keywords -------------------- 119 | 120 | keywordsLongestFirst :: [String] 121 | keywordsLongestFirst = sortBy (flipCompare `on` length) keywords 122 | 123 | tokenizeKeyword :: Parser String 124 | tokenizeKeyword = do 125 | kwd <- msum $ map (P.try . P.string) keywordsLongestFirst 126 | P.notFollowedBy tokenizePath 127 | return kwd 128 | 129 | -------------------- Symbols -------------------- 130 | 131 | tokenizeSymbol :: Parser String 132 | tokenizeSymbol = do 133 | x <- P.letter `mplus` P.oneOf "_" 134 | xs <- P.many $ P.alphaNum `mplus` P.oneOf "_'" 135 | return $ x:xs 136 | 137 | -------------------- Paths -------------------- 138 | 139 | tokenizePath :: Parser Path 140 | tokenizePath = do 141 | s <- tokenizeSymbol 142 | msum 143 | [ do 144 | P.char '.' 145 | p <- tokenizePath 146 | return $ Name s :.: p 147 | , return $ SingletonPath $ Name s 148 | ] 149 | 150 | -------------------- Main -------------------- 151 | 152 | preTokenize :: Parser [AnnToken] 153 | preTokenize = do 154 | ts <- P.many $ annotate $ msum 155 | [ liftM (const WhitespaceToken) tokenizeWhitespace 156 | , liftM (const CommentToken) tokenizeComment 157 | , liftM PunctuationToken tokenizePunctuation 158 | , P.try $ liftM KeywordToken tokenizeKeyword 159 | , liftM PathToken tokenizePath 160 | ] 161 | P.eof 162 | return ts 163 | 164 | tokenize :: Parser [AnnToken] 165 | tokenize = liftM (filter keeper) preTokenize 166 | where 167 | keeper x = and 168 | [ stripAnnotation x /= WhitespaceToken 169 | , stripAnnotation x /= CommentToken 170 | ] 171 | 172 | runTokenize :: String -> Text -> Either ParseError [AnnToken] 173 | runTokenize = P.parse tokenize 174 | 175 | -------------------- Punctuation -------------------- 176 | 177 | flipCompare :: (Ord a) => a -> a -> Ordering 178 | flipCompare x y = case compare x y of 179 | LT -> GT 180 | EQ -> EQ 181 | GT -> LT 182 | -------------------------------------------------------------------------------- /src/Lang/OPL/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Prelude () 4 | import FP 5 | import System.Environment 6 | import Data.Text (Text) 7 | import qualified Data.Text.IO as T 8 | import qualified Data.Text as T 9 | import qualified Text.Parsec as P 10 | import qualified FP.Pretty as P 11 | import Util.Parsec 12 | import Lang.OPL.Lexer 13 | import Lang.OPL.Parser 14 | import Lang.OPL.Check 15 | import Lang.OPL.CheckMonad 16 | import Control.Applicative 17 | 18 | mainTokenize :: FilePath -> IO () 19 | mainTokenize path = do 20 | input <- T.readFile path 21 | ts <- ioParser runTokenize path input 22 | putStrLn $ show ts 23 | 24 | mainParse :: FilePath -> IO () 25 | mainParse path = do 26 | input <- T.readFile path 27 | m <- ioParser runParse path input 28 | pprintLn m 29 | where 30 | runParse' name = P.parse tokenize name >=> parse pimport parseConstraints name 31 | 32 | mainTypeCheck :: FilePath -> IO () 33 | mainTypeCheck path = do 34 | input <- T.readFile path 35 | m <- ioParser runParse path input 36 | execCheckMonadIO0 $ check m 37 | putStrLn "SUCCESS" 38 | putStrLn "" 39 | pprintLn m 40 | 41 | main :: IO () 42 | main = do 43 | args <- getArgs 44 | case args of 45 | [path] -> mainTypeCheck path 46 | _ -> putStrLn "expecting: opl " 47 | -------------------------------------------------------------------------------- /src/Lang/OPL/Message.hs: -------------------------------------------------------------------------------- 1 | module Lang.OPL.Message where 2 | 3 | import Prelude() 4 | import FP 5 | import qualified Data.List as List 6 | import qualified FP.Pretty as P 7 | import Text.Parsec (SourcePos) 8 | import System.Console.ANSI 9 | 10 | type Context = [(Maybe SourcePos, PrettyString)] 11 | data Message = Message 12 | { messagePhase :: PrettyString 13 | , messageContext :: Context 14 | , messageTitle :: PrettyString 15 | , messageDescription :: Maybe PrettyString 16 | } deriving (Eq, Ord, Show) 17 | 18 | instance Pretty Message where 19 | pretty m = do 20 | P.text "error during phase: " 21 | P.localConsole (mappend $ setConsoleColor Dull Magenta) $ pretty $ messagePhase m 22 | P.hardLine 23 | let reason = do 24 | P.localConsole (mappend $ setConsoleColor Dull Red) $ pretty $ messageTitle m 25 | case messageDescription m of 26 | Nothing -> return () 27 | Just d -> do 28 | P.hardLine 29 | pretty d 30 | (\ f -> List.foldl' f reason $ messageContext m) $ \ i (lM, s) -> do 31 | P.text "in " 32 | P.localConsole (mappend $ setConsoleColor Dull Cyan) $ 33 | pretty s 34 | P.localConsole (mappend $ setConsoleColor Dull Yellow) $ 35 | case lM of 36 | Nothing -> return () 37 | Just l -> do 38 | P.text " [" 39 | P.string $ show l 40 | P.text "]" 41 | P.hardLine 42 | P.space 2 >> P.align i 43 | 44 | 45 | -------------------------------------------------------------------------------- /src/Lang/OPL/Parser.hs: -------------------------------------------------------------------------------- 1 | module Lang.OPL.Parser where 2 | 3 | import Prelude () 4 | import FP 5 | import Lang.OPL.Annotated 6 | import Control.Applicative 7 | import Control.Monad 8 | import Data.Text (Text) 9 | import Lang.OPL.Lexer 10 | import Lang.OPL.Syntax 11 | import Lang.OPL.Common 12 | import Text.Parsec (ParsecT, ParseError, SourcePos, SourceName) 13 | import qualified Text.Parsec as P 14 | 15 | data Env = Env 16 | { _precDLL :: DumbLattice 17 | , _precLevelL :: Level 18 | } deriving (Eq, Ord, Show) 19 | makeLens ''Env 20 | 21 | type Parser = ParsecT [AnnToken] () (Reader Env) 22 | type instance MEnv Parser = Env 23 | 24 | -------------------- Precedence -------------------- 25 | 26 | lteM :: Level -> Parser Bool 27 | lteM l = do 28 | dl <- askView precDLL 29 | cl <- askView precLevelL 30 | return $ dlLte dl l cl 31 | 32 | atLevel :: Level -> Parser a -> Parser a 33 | atLevel = localViewSet precLevelL 34 | 35 | guardLevel :: Level -> Parser a -> Parser a 36 | guardLevel l aM = do 37 | b <- lteM l 38 | when (not b) mzero 39 | atLevel l aM 40 | 41 | guardLevelParen :: Level -> Parser a -> Parser a 42 | guardLevelParen l aM = msum 43 | [ parens aM 44 | , guardLevel l aM 45 | ] 46 | 47 | parens :: Parser a -> Parser a 48 | parens p = pun "(" *> atLevel TopLevel p <* pun ")" 49 | 50 | -------------------- Primitives -------------------- 51 | 52 | token :: (Token -> Maybe a) -> Parser a 53 | token f = P.tokenPrim (show . stripAnnotation) (\ _ t _ -> annotation t) (f . stripAnnotation) 54 | 55 | tokenEqual :: Token -> Parser Token 56 | tokenEqual t = token satisfy 57 | where 58 | satisfy x = if x == t then Just x else Nothing 59 | 60 | pun :: String -> Parser () 61 | pun = void . tokenEqual . PunctuationToken 62 | 63 | key :: String -> Parser () 64 | key = void . tokenEqual . KeywordToken 65 | 66 | keys :: [String] -> Parser () 67 | keys = mapM_ key 68 | 69 | name :: Parser Name 70 | name = token $ \ t -> 71 | case t of 72 | PathToken (SingletonPath n) -> Just n 73 | _ -> Nothing 74 | 75 | aname :: Parser AName 76 | aname = annotate name 77 | 78 | path :: Parser Path 79 | path = token $ \ t -> 80 | case t of 81 | PathToken p -> Just p 82 | _ -> Nothing 83 | 84 | apath :: Parser APath 85 | apath = annotate path 86 | 87 | -------------------- Boxes -------------------- 88 | 89 | plugType :: Parser PlugType 90 | plugType = liftM PlugType aname 91 | 92 | boxArrow :: Parser BoxArrow 93 | boxArrow = guardLevelParen (level "=[]=") $ do 94 | ins <- P.many $ atLevel BotLevel plugType 95 | pun "=[]=" 96 | outs <- P.many $ atLevel BotLevel plugType 97 | return $ BoxArrow ins outs 98 | 99 | box :: Parser Box 100 | box = msum 101 | [ P.try $ liftM ArrowBox boxArrow 102 | , liftM VarBox aname 103 | ] 104 | 105 | -------------------- Wiring -------------------- 106 | 107 | wiringArrow :: Parser WiringArrow 108 | wiringArrow = guardLevelParen (level "->") $ do 109 | ins <- P.many $ atLevel BotLevel box 110 | pun "->" 111 | out <- box 112 | return $ WiringArrow ins out 113 | 114 | wiringType :: Parser WiringType 115 | wiringType = msum 116 | [ P.try $ do 117 | n <- aname 118 | pun "@" 119 | wt <- wiringType 120 | return $ LiftWiringType n wt 121 | , P.try $ liftM ArrowWiringType wiringArrow 122 | , P.try $ liftM BoxWiringType box 123 | , liftM VarWiringType aname 124 | ] 125 | 126 | boxBinder :: Parser BoxBinder 127 | boxBinder = guardLevelParen (level "=[]=") $ do 128 | ins <- P.many $ atLevel BotLevel aname 129 | pun "=[]=" 130 | outs <- P.many $ atLevel BotLevel aname 131 | return $ BoxBinder ins outs 132 | 133 | plug :: Parser Plug 134 | plug = do 135 | n <- aname 136 | pun "<-" 137 | p <- apath 138 | return $ Plug n p 139 | 140 | wiring :: Parser Wiring 141 | wiring = do 142 | n <- aname 143 | pun ":" 144 | b <- atLevel BotLevel box 145 | pun "[" 146 | bb <- boxBinder 147 | pun "]" 148 | key "plug" 149 | ps <- plug `P.sepBy` pun "," 150 | return $ Wiring n b bb ps 151 | 152 | wiringDiagram :: Parser WiringDiagram 153 | wiringDiagram = do 154 | key "wiring" 155 | key "internal" 156 | ins <- P.many wiring 157 | key "external" 158 | out <- wiring 159 | key "end" 160 | return $ WiringDiagram ins out 161 | 162 | renaming :: Parser Renaming 163 | renaming = do 164 | from <- P.many aname 165 | pun "=>" 166 | to <- P.many aname 167 | return $ Renaming from to 168 | 169 | wiringExpFlat :: Parser WiringExp 170 | wiringExpFlat = msum 171 | [ liftM DiagramWiringExp wiringDiagram 172 | , P.try $ guardLevelParen (level " ") $ do 173 | n <- aname 174 | e <- wiringExp 175 | return $ LiftWiringExp n e 176 | , liftM VarWiringExp aname 177 | ] 178 | 179 | wiringExpPost :: Parser WiringExp 180 | wiringExpPost = msum 181 | [ P.try $ do 182 | e <- atLevel BotLevel wiringExpFlat 183 | pun "[" 184 | r <- renaming 185 | pun "]" 186 | return $ RenamingWiringExp r e 187 | , wiringExpFlat 188 | ] 189 | 190 | maybeDefineExp :: Parser (Maybe WiringExp) 191 | maybeDefineExp = msum 192 | [ pun "_" >> return Nothing 193 | , liftM Just wiringExp 194 | ] 195 | 196 | wiringExpChain :: WiringExp -> Parser WiringExp 197 | wiringExpChain e = msum 198 | [ do 199 | pun "<-" 200 | es <- P.many $ atLevel BotLevel maybeDefineExp 201 | wiringExpChain $ ApplyWiringExp e es 202 | , return e 203 | ] 204 | 205 | wiringExp :: Parser WiringExp 206 | wiringExp = msum 207 | [ parens wiringExp 208 | , P.try $ guardLevelParen (level "<-") $ do 209 | e <- wiringExpPost 210 | wiringExpChain e 211 | , wiringExpPost 212 | ] 213 | 214 | -------------------- Statements -------------------- 215 | 216 | decl :: Parser Decl 217 | decl = msum 218 | [ do 219 | key "algebra" 220 | liftM AlgebraDecl aname 221 | , do 222 | key "box" 223 | liftM BoxDecl aname 224 | , do 225 | key "module" 226 | liftM ModuleDecl aname 227 | , do 228 | key "define" 229 | n <- aname 230 | pun ":" 231 | t <- wiringType 232 | return $ WiringDecl n t 233 | ] 234 | 235 | def :: Parser Def 236 | def = msum 237 | [ do 238 | key "algebra" 239 | n <- aname 240 | pun ":=" 241 | a <- aname 242 | return $ AlgebraDef n a 243 | , do 244 | key "box" 245 | n <- aname 246 | pun ":=" 247 | b <- box 248 | return $ BoxDef n b 249 | , do 250 | key "module" 251 | n <- aname 252 | pun ":=" 253 | m <- moduleGuts 254 | key "end" 255 | return $ ModuleDef n m 256 | , do 257 | key "define" 258 | n <- aname 259 | pun ":=" 260 | e <- wiringExp 261 | return $ WiringDef n e 262 | ] 263 | 264 | statement :: Parser Statement 265 | statement = msum 266 | [ P.try $ liftM DefStatement def 267 | , liftM DeclStatement decl 268 | ] 269 | 270 | -------------------- Modules -------------------- 271 | 272 | pimport :: Parser Import 273 | pimport = do 274 | key "import" 275 | p <- apath 276 | q <- P.option False $ key "qualified" >> return True 277 | aps <- P.option Nothing $ do 278 | key "apply" 279 | ss <- P.many statement 280 | return $ Just ss 281 | os <- P.option Nothing $ do 282 | key "only" 283 | ds <- P.many decl 284 | return $ Just ds 285 | return $ Import p q aps os 286 | 287 | provides :: Parser Provides 288 | provides = msum 289 | [ key "all" >> return AllProvides 290 | , key "none" >> return NoneProvides 291 | , liftM ExplicitProvides $ P.many decl 292 | ] 293 | 294 | moduleGuts :: Parser Module 295 | moduleGuts = do 296 | (ds, is, ps) <- P.option ([], [], Nothing) $ do 297 | ds <- P.option [] $ do 298 | key "require" 299 | P.many decl 300 | is <- P.many pimport 301 | ps <- P.option Nothing $ do 302 | key "provide" 303 | liftM Just provides 304 | key "where" 305 | return (ds, is, ps) 306 | ss <- P.many statement 307 | return $ Module ds is ps ss 308 | 309 | -------------------- Main -------------------- 310 | 311 | topLevel :: Parser TLModule 312 | topLevel = liftM TLModule moduleGuts <* P.eof 313 | 314 | parse :: Parser a -> DumbLattice -> SourceName -> [AnnToken] -> Either ParseError a 315 | parse p dl name = flip runReader (Env dl TopLevel) . P.runParserT p () name 316 | 317 | parseConstraints :: DumbLattice 318 | parseConstraints = compile [ (" ", "<-"), ("=[]=", "->") ] 319 | 320 | runParse :: String -> Text -> Either ParseError TLModule 321 | runParse name = P.parse tokenize name >=> parse topLevel parseConstraints name 322 | -------------------------------------------------------------------------------- /src/Lang/OPL/Semantics.hs: -------------------------------------------------------------------------------- 1 | module Lang.OPL.Semantics where 2 | 3 | import qualified Lang.OPL.Syntax as S 4 | import Prelude () 5 | import FP 6 | import Lang.OPL.Common 7 | 8 | class ToS a b | a -> b where 9 | toS :: a -> b 10 | prettyS :: (ToS a b, Pretty b, MonadPretty m) => a -> m () 11 | prettyS = pretty . toS 12 | 13 | ---------- Boxes ---------- 14 | 15 | data Box = Box 16 | { boxInputs :: [PlugType] 17 | , boxOutputs :: [PlugType] 18 | } deriving (Eq, Ord, Show) 19 | instance ToS Box S.Box where 20 | toS (Box ins outs) = S.ArrowBox $ BoxArrow ins outs 21 | instance Pretty Box where pretty = prettyS 22 | 23 | ---------- Wiring Diagrams ---------- 24 | 25 | data WiringArrow = WiringArrow 26 | { wiringArrowInputs :: [Box] 27 | , wiringArrowOutput :: Box 28 | } deriving (Eq, Ord, Show) 29 | instance ToS WiringArrow S.WiringArrow where 30 | toS (WiringArrow ins out) = S.WiringArrow (map toS ins) (toS out) 31 | instance Pretty WiringArrow where pretty = prettyS 32 | 33 | data WiringType = 34 | LiftWiringType AName WiringType 35 | | BoxWiringType Box 36 | | ArrowWiringType WiringArrow 37 | deriving (Eq, Ord, Show) 38 | instance ToS WiringType S.WiringType where 39 | toS (LiftWiringType n wt) = S.LiftWiringType n (toS wt) 40 | toS (BoxWiringType b) = S.BoxWiringType (toS b) 41 | toS (ArrowWiringType a) = S.ArrowWiringType (toS a) 42 | instance Pretty WiringType where pretty = prettyS 43 | 44 | data Wiring = Wiring 45 | { wiringName :: AName 46 | , wiringBox :: Box 47 | , wiringBoxBinder :: BoxBinder 48 | , wiringPlugs :: [Plug] 49 | } deriving (Eq, Ord, Show) 50 | instance ToS Wiring S.Wiring where 51 | toS (Wiring n b bb ps) = S.Wiring n (toS b) bb ps 52 | instance Pretty Wiring where pretty = prettyS 53 | 54 | data WiringDiagram = WiringDiagram 55 | { wiringDiagramInternalBoxes :: [Wiring] 56 | , wiringDiagramExternalBox :: Wiring 57 | } deriving (Eq, Ord, Show) 58 | instance ToS WiringDiagram S.WiringDiagram where 59 | toS (WiringDiagram ins out) = S.WiringDiagram (map toS ins) (toS out) 60 | instance Pretty WiringDiagram where pretty = prettyS 61 | 62 | data WiringExp = 63 | DiagramWiringExp WiringDiagram 64 | | LiftWiringExp AName WiringExp 65 | | RenamingWiringExp Renaming WiringExp 66 | | ApplyWiringExp WiringExp [Maybe WiringExp] 67 | deriving (Eq, Ord, Show) 68 | instance ToS WiringExp S.WiringExp where 69 | toS (DiagramWiringExp wd) = S.DiagramWiringExp (toS wd) 70 | toS (LiftWiringExp n wd) = S.LiftWiringExp n (toS wd) 71 | toS (RenamingWiringExp r wd) = S.RenamingWiringExp r (toS wd) 72 | toS (ApplyWiringExp wd wdMs) = S.ApplyWiringExp (toS wd) (fmap (fmap toS) wdMs) 73 | instance Pretty WiringExp where pretty = prettyS 74 | -------------------------------------------------------------------------------- /src/Lang/OPL/Syntax.hs: -------------------------------------------------------------------------------- 1 | module Lang.OPL.Syntax where 2 | 3 | import Prelude () 4 | import FP 5 | import qualified Data.Map as Map 6 | import qualified Data.Set as Set 7 | import qualified FP.Pretty as P 8 | import Lang.OPL.Common 9 | 10 | ---------- Boxes ---------- 11 | 12 | data Box = 13 | VarBox AName 14 | | ArrowBox BoxArrow 15 | deriving (Eq, Ord, Show) 16 | instance Pretty Box where 17 | pretty (VarBox n) = pretty n 18 | pretty (ArrowBox ab) = pretty ab 19 | 20 | ---------- Wiring Diagrams ---------- 21 | 22 | data WiringArrow = WiringArrow 23 | { wiringArrowInputs :: [Box] 24 | , wiringArrowOutputs :: Box 25 | } deriving (Eq, Ord, Show) 26 | instance Pretty WiringArrow where 27 | precLattice Proxy = compile [("=[]=", "->")] 28 | pretty (WiringArrow ins out) = 29 | P.guardLevel (level "->") 30 | $ P.hsep 31 | $ concat 32 | [ map (P.atLevel BotLevel . pretty) ins 33 | , return $ P.punctuation $ P.string "->" 34 | , return $ pretty out 35 | ] 36 | data WiringType = 37 | VarWiringType AName 38 | | LiftWiringType AName WiringType 39 | | BoxWiringType Box 40 | | ArrowWiringType WiringArrow 41 | deriving (Eq, Ord, Show) 42 | instance Pretty WiringType where 43 | pretty (VarWiringType n) = pretty n 44 | pretty (LiftWiringType n wt) = P.hsep 45 | [ pretty n 46 | , P.punctuation $ P.string "@" 47 | , pretty wt 48 | ] 49 | pretty (BoxWiringType b) = pretty b 50 | pretty (ArrowWiringType a) = pretty a 51 | 52 | data Wiring = Wiring 53 | { wiringName :: AName 54 | , wiringBox :: Box 55 | , wiringBoxBinder :: BoxBinder 56 | , wiringPlugs :: [Plug] 57 | } deriving (Eq, Ord, Show) 58 | instance Pretty Wiring where 59 | pretty (Wiring n b bb ps) = do 60 | P.hsep 61 | [ P.binder $ pretty n 62 | , P.punctuation $ P.string ":" 63 | , do 64 | P.atLevel BotLevel $ pretty b 65 | P.punctuation $ P.string "[" 66 | pretty bb 67 | P.punctuation $ P.string "]" 68 | , P.keyword $ P.string "plug" 69 | , do 70 | s <- askView P.styleOptionsL 71 | localViewSet P.styleOptionsL (P.StyleOptions P.PostStyle P.NoBuffer 2) $ 72 | P.encloseSepDropIndent "" "" ", " $ map (localViewSet P.styleOptionsL s . pretty) ps 73 | ] 74 | 75 | data WiringDiagram = WiringDiagram 76 | { wiringDiagramInternalBoxes :: [Wiring] 77 | , wiringDiagramExternalBox :: Wiring 78 | } deriving (Eq, Ord, Show) 79 | instance Pretty WiringDiagram where 80 | pretty (WiringDiagram ins out) = P.group $ do 81 | P.keyword $ P.string "wiring" 82 | P.vsep $ 83 | [ P.dropIndent $ 84 | P.vsep $ map P.group 85 | [ do 86 | P.keyword $ P.string "internal" 87 | P.dropIndent $ do 88 | P.vsep $ map pretty ins 89 | , do 90 | P.keyword $ P.string "external" 91 | P.dropIndent $ pretty out 92 | ] 93 | , P.keyword $ P.string "end" 94 | ] 95 | 96 | newtype Underscored a = Underscored { unUnderscored :: Maybe a } 97 | instance (Pretty a) => Pretty (Underscored a) where 98 | pretty (Underscored Nothing) = P.string "_" 99 | pretty (Underscored (Just x)) = pretty x 100 | 101 | data WiringExp = 102 | VarWiringExp AName 103 | | LiftWiringExp AName WiringExp 104 | | DiagramWiringExp WiringDiagram 105 | | RenamingWiringExp Renaming WiringExp 106 | | ApplyWiringExp WiringExp [Maybe WiringExp] 107 | deriving (Eq, Ord, Show) 108 | instance Pretty WiringExp where 109 | precLattice Proxy = compile [(" ", "<-")] 110 | pretty (VarWiringExp n) = pretty n 111 | pretty (DiagramWiringExp wd) = pretty wd 112 | pretty (LiftWiringExp n e) = P.guardLevel (level " ") $ P.hsep 113 | [ pretty n 114 | , pretty e 115 | ] 116 | pretty (RenamingWiringExp e r) = do 117 | pretty e 118 | P.punctuation $ P.string "[" 119 | pretty r 120 | P.punctuation $ P.string "]" 121 | pretty (ApplyWiringExp e eMs) = P.guardLevel (level "<-") $ P.hsep $ concat 122 | [ return $ pretty e 123 | , return $ P.punctuation $ P.string "<-" 124 | , map (P.atLevel BotLevel . pretty . Underscored) eMs 125 | ] 126 | 127 | ---------- Top Level Definitions ---------- 128 | 129 | data Decl = 130 | AlgebraDecl AName 131 | | ModuleDecl AName 132 | | BoxDecl AName 133 | | WiringDecl AName WiringType 134 | deriving (Eq, Ord, Show) 135 | instance Pretty Decl where 136 | pretty (AlgebraDecl n) = P.hsep 137 | [ P.keyword $ P.string "algebra" 138 | , pretty n 139 | ] 140 | pretty (ModuleDecl n) = P.hsep 141 | [ P.keyword $ P.string "module" 142 | , pretty n 143 | ] 144 | pretty (BoxDecl n) = P.hsep 145 | [ P.keyword $ P.string "box" 146 | , pretty n 147 | ] 148 | pretty (WiringDecl n t) = P.hsep 149 | [ P.keyword $ P.string "define" 150 | , pretty n 151 | , P.punctuation $ P.string ":" 152 | , pretty t 153 | ] 154 | 155 | data Def = 156 | AlgebraDef AName AName 157 | | ModuleDef AName Module 158 | | BoxDef AName Box 159 | | WiringDef AName WiringExp 160 | deriving (Eq, Ord, Show) 161 | instance Pretty Def where 162 | pretty (AlgebraDef n a) = P.hsep 163 | [ P.keyword $ P.string "algebra" 164 | , pretty n 165 | , P.punctuation $ P.string ":=" 166 | , pretty a 167 | ] 168 | pretty (ModuleDef n m) = do 169 | P.hsep 170 | [ P.keyword $ P.string "module" 171 | , pretty n 172 | , P.punctuation $ P.string ":=" 173 | , pretty m 174 | ] 175 | pretty (BoxDef n b) = P.hsep 176 | [ P.keyword $ P.string "box" 177 | , pretty n 178 | , P.punctuation $ P.string ":=" 179 | , pretty b 180 | ] 181 | pretty (WiringDef n e) = P.hsep 182 | [ P.keyword $ P.string "define" 183 | , pretty n 184 | , P.punctuation $ P.string ":=" 185 | , pretty e 186 | ] 187 | 188 | data Statement = 189 | DeclStatement Decl 190 | | DefStatement Def 191 | deriving (Eq, Ord, Show) 192 | instance Pretty Statement where 193 | pretty (DeclStatement d) = pretty d 194 | pretty (DefStatement d) = pretty d 195 | 196 | ---------- Modules ---------- 197 | 198 | data Import = Import 199 | { importPath :: APath 200 | , importQualified :: Bool 201 | , importApply :: Maybe [Statement] 202 | , importOnly :: Maybe [Decl] 203 | } deriving (Eq, Ord, Show) 204 | instance Pretty Import where 205 | pretty (Import p q apsM osM) = P.group $ do 206 | P.hsep $ concat 207 | [ return $ P.keyword $ P.string "import" 208 | , return $ pretty p 209 | , if not q then mzero else return $ P.keyword $ P.string "qualified" 210 | ] 211 | P.dropIndent $ 212 | P.vsep $ map P.group $ concat 213 | [ flip (maybe mzero) apsM $ \ aps -> return $ do 214 | P.keyword $ P.string "apply" 215 | P.dropIndent $ 216 | P.vsep $ map pretty aps 217 | , flip (maybe mzero) osM $ \ os -> return $ do 218 | P.keyword $ P.string "only" 219 | P.dropIndent $ 220 | P.vsep $ map pretty os 221 | ] 222 | 223 | data Provides = 224 | AllProvides 225 | | NoneProvides 226 | | ExplicitProvides [Decl] 227 | deriving (Eq, Ord, Show) 228 | instance Pretty Provides where 229 | pretty AllProvides = P.keyword $ P.string "all" 230 | pretty NoneProvides = P.keyword $ P.string "none" 231 | pretty (ExplicitProvides ds) = P.group $ P.dropIndent $ P.vsep $ map pretty ds 232 | 233 | data Module = Module 234 | { moduleRequires :: [Decl] 235 | , moduleImports :: [Import] 236 | , moduleProvides :: Maybe Provides 237 | , moduleStatements :: [Statement] 238 | } deriving (Eq, Ord, Show) 239 | instance Pretty Module where 240 | precLattice Proxy = 241 | Map.unionsWith Set.union 242 | [ precLattice (proxy :: Proxy WiringArrow) 243 | , precLattice (proxy :: Proxy WiringExp) 244 | ] 245 | pretty (Module rs is pM ss) = P.group $ do 246 | case (rs, is, pM) of 247 | ([], [], Nothing) -> 248 | P.dropIndent $ P.vsep $ map pretty ss 249 | _ -> do 250 | P.dropIndent $ P.vsep $ concat 251 | [ if null rs then mzero else 252 | return $ P.group $ do 253 | P.keyword $ P.string "require" 254 | P.dropIndent $ P.vsep $ map pretty rs 255 | , map pretty is 256 | , flip (maybe mzero) pM $ \ p -> return $ P.hsep 257 | [ P.keyword $ P.string "provide" 258 | , pretty p 259 | ] 260 | ] 261 | P.hardLine 262 | P.keyword $ P.string "where" 263 | P.dropIndent $ P.vsep $ map pretty ss 264 | P.hardLine 265 | P.keyword $ P.string "end" 266 | 267 | newtype TLModule = TLModule Module 268 | deriving (Eq, Ord, Show) 269 | instance (Pretty TLModule) where 270 | pretty (TLModule (Module rs is pM ss)) = P.vsep $ 271 | case (rs, is, pM) of 272 | ([], [], Nothing) -> map pretty ss 273 | _ -> concat 274 | [ if null rs then mzero else 275 | return $ P.group $ do 276 | P.keyword $ P.string "require" 277 | P.dropIndent $ P.vsep $ map pretty rs 278 | , map pretty is 279 | , flip (maybe mzero) pM $ \ p -> return $ P.hsep 280 | [ P.keyword $ P.string "provide" 281 | , pretty p 282 | ] 283 | , return $ P.keyword $ P.string "where" 284 | , map pretty ss 285 | ] 286 | 287 | -------------------------------------------------------------------------------- /src/Util/Either.hs: -------------------------------------------------------------------------------- 1 | module Util.Either where 2 | 3 | eitherToIO :: (Show e) => Either e a -> IO a 4 | eitherToIO aM = 5 | case aM of 6 | Left e -> fail $ show e 7 | Right a -> return a 8 | -------------------------------------------------------------------------------- /src/Util/Parsec.hs: -------------------------------------------------------------------------------- 1 | module Util.Parsec where 2 | 3 | import Text.Parsec (ParseError) 4 | import Util.Either 5 | 6 | ioParser :: (String -> a -> Either ParseError b) -> (String -> a -> IO b) 7 | ioParser p n i = eitherToIO $ p n i 8 | -------------------------------------------------------------------------------- /todo.md: -------------------------------------------------------------------------------- 1 | * add an ID* wiring diagram which is polymorphic in box shape 2 | * change input/output to inputs/outputs 3 | * check no straight across wires (outY <- outX) 4 | * mix w.d. and props in same file 5 | * external first always 6 | * unfinished propagators and propagators, similar syntax to wiring composition 7 | * module system which supports require plus which can be filled by either prim plus or derived plus (say, from nands) 8 | * change boxes to use boxy arrow [_:_, _:_, ... =[]= _:_] 9 | * box exponential [_=>_] 10 | * box tensor [_[+]_] 11 | * wiring diagram and propagator types use -> 12 | 13 | box A := x:int, y:bool =[]= a:int, b:bool 14 | 15 | wiring W := diagram with 16 | type i1:A, i2:A -> e:(x:int, y:bool =[]= a:int, b:bool) 17 | wire i1 inputs x <- i2.a , y <- e.y 18 | wire i2 inputs x <- e.x , y <- i2.b 19 | wire e outputs a <- i1.a , b <- i2.b 20 | end 21 | 22 | wiring C := compose W with 23 | type i11:A, i12:A, i21:A, i22:A -> A # optional 24 | i1 <- W rename i1 -> i11 , i2 -> i12 25 | i2 <- W rename i1 -> i21 , i2 -> i22 26 | end 27 | 28 | primitive propagator foo : A 29 | 30 | propagator P := apply C with 31 | type A # optional 32 | i11 <- foo 33 | i12 <- foo 34 | i21 <- foo 35 | i22 <- foo 36 | end 37 | 38 | unfinished propagator UP := partially apply C with 39 | type i11:A, i21:A -> A 40 | i12 <- foo 41 | i22 <- foo 42 | end 43 | 44 | --- 45 | 46 | box A with 47 | inputs x:int , y:bool 48 | outputs a:int , b:bool 49 | end 50 | 51 | wiring diagram W with 52 | external box e with outputs a <- i1.a , b <- i2.b 53 | internal box i1 with inputs x <- i2.a , y <- e.y 54 | internal box i2 with inputs x <- e.x , y <- i2.b 55 | end 56 | 57 | wiring composition C with 58 | external w.d. W 59 | internal w.d. i1 <- W export internals i1 as i11 , i2 as i12 60 | internal w.d. i2 <- W export internals i1 as i21 , i2 as i22 61 | end 62 | 63 | primitive propagator foo : A 64 | 65 | propagator P with 66 | external w.d. C 67 | internal box i11 <- foo 68 | internal box i22 <- foo 69 | internal box i21 <- foo 70 | internal box i22 <- foo 71 | end 72 | 73 | unfinished propagator UP with 74 | external w.d. C 75 | internal box i12 <- foo 76 | internal box i22 <- foo 77 | end 78 | 79 | -------------------------------------------------------------------------------- /vim_syntax/operad.vim: -------------------------------------------------------------------------------- 1 | " Vim syntax file 2 | " Language: Operad Programming Language (OPL) 3 | " Maintainer: David Darais (david.darais@gmail.com) 4 | " Latest Revision: Feb 4, 2014 5 | 6 | if exists("b:current_syntax") 7 | finish 8 | endif 9 | 10 | syntax clear 11 | 12 | highlight def link oplKeyword Keyword 13 | highlight oplPunctuation ctermfg=Gray guifg=Gray 14 | highlight def link oplSingleComment Comment 15 | highlight def link oplMultiComment Comment 16 | highlight def link oplBinderName Identifier 17 | highlight def link oplRenamingName Identifier 18 | highlight def link oplSpecial Special 19 | 20 | """"" keywords 21 | 22 | set iskeyword+=. 23 | syntax keyword oplKeyword as 24 | syntax keyword oplKeyword box 25 | syntax keyword oplKeyword composition 26 | syntax keyword oplKeyword diagram 27 | syntax keyword oplKeyword end 28 | syntax keyword oplKeyword export 29 | syntax keyword oplKeyword external 30 | syntax keyword oplKeyword input 31 | syntax keyword oplKeyword internal 32 | syntax keyword oplKeyword output 33 | syntax keyword oplKeyword w.d. 34 | syntax keyword oplKeyword wiring 35 | syntax keyword oplKeyword with 36 | 37 | """"" punctuation 38 | 39 | syntax match oplPunctuation "," 40 | syntax match oplPunctuation ";" 41 | syntax match oplPunctuation "\." 42 | syntax match oplPunctuation ":" 43 | syntax match oplPunctuation "<-" 44 | 45 | """"" comments 46 | 47 | syntax match oplSingleComment "#.*$" 48 | syntax region oplMultiComment start="#|" end="|#" contains=oplMultiComment 49 | 50 | """"" binders 51 | 52 | syntax match oplBinder "\(\w\|[_']\)\+\s*:\s*\(\w\|[_']\)\+" contains=oplBinderName 53 | syntax match oplBinderName contained "\(\w\|[_']\)\+\s*" nextgroup=oplBinderSeparator 54 | syntax match oplBinderSeparator contained ":\s*" contains=oplPunctuation nextgroup=oplBinderClassifier 55 | syntax match oplBinderClassifier contained "\(\w\|[_']\)\+\s*" 56 | 57 | syntax match oplRenaming "\(\w\|[_']\)\+\s*as\s*\(\w\|[_']\)\+" contains=oplRenamingName,oplRenamingSeparator 58 | syntax match oplRenamingName contained "\(\w\|[_']\)\+" 59 | syntax match oplRenamingSeparator contained "as" contains=oplKeyword 60 | 61 | """"" regions 62 | 63 | "syntax region oplBox keepend start="box" end="end" contains=oplKeyword,oplPunctuation,oplBoxCommand 64 | "syntax region oplBoxCommand keepend start="input" end=";" nextgroup=oplBinderList 65 | "syntax region oplBoxCommand keepend start="output" end=";" nextgroup=oplBinderList 66 | 67 | "syntax region oplWiringDiagram keepend start="wiring diagram" end="end" contains=oplKeyword,oplPunctuation 68 | "syntax match oplWiringDiagramCommand "internal" nextgroup=oplSpecial contained 69 | "syntax match oplWiringDiagramCommand "external\s\+box" nextgroup=oplClassifier contained 70 | 71 | "syntax region oplWiringComposition keepend start="wiring composition" end="end" contains=oplKeyword,oplPunctuation 72 | "syntax match oplWiringCompositionCommand "internal w.d." nextgroup=oplBinder contained 73 | 74 | "syntax match oplSpecial ".*" contained 75 | 76 | --------------------------------------------------------------------------------