├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── doc └── snowflake_bytecode_format.md ├── examples ├── ackermann.sf ├── ackermann.sfc ├── factorial.sf ├── fibonacci.sf ├── fibonacci.sfc ├── hello.sf ├── hello.sfc ├── pom.sf ├── speed_test.sf ├── speed_test.sfc └── test.sf ├── snowflake.cabal ├── src ├── Data │ ├── AST.hs │ └── ChainMap.hs ├── Language │ ├── Snowflake.hs │ └── Snowflake │ │ ├── Builtins.hs │ │ ├── Compiler.hs │ │ ├── Compiler │ │ ├── CodeGen.hs │ │ ├── Decoder.hs │ │ ├── Encoder.hs │ │ └── Types.hs │ │ ├── Optimizer.hs │ │ ├── Optimizer │ │ └── Rule.hs │ │ ├── Options.hs │ │ ├── Options │ │ ├── Command.hs │ │ ├── Parser.hs │ │ └── Types.hs │ │ ├── Parser.hs │ │ ├── Parser │ │ ├── AST.hs │ │ ├── Lexer.hs │ │ └── Rules.hs │ │ ├── REPL.hs │ │ ├── REPL │ │ ├── Parser.hs │ │ └── Types.hs │ │ ├── Typing.hs │ │ ├── Typing │ │ ├── TypeCheck.hs │ │ └── Types.hs │ │ ├── VM.hs │ │ └── VM │ │ ├── Operators.hs │ │ └── Types.hs ├── Main.hs └── snowflake_ascii.txt └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | sf 3 | ign 4 | .DS_Store 5 | .stack-work/ 6 | dist-newstyle/ 7 | src/.DS_Store 8 | src/Language/Snowflake/.DS_Store 9 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, felko 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of felko nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # snowflake 2 | An imperative, statically-typed toy language 3 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /doc/snowflake_bytecode_format.md: -------------------------------------------------------------------------------- 1 | ``` 2 | File: 3 | Header: 4 | magic "snowflake" encoded in ASCII ( 9 bytes) 5 | Version: 6 | major ( 1 byte ) 7 | minor ( 1 byte ) 8 | patch ( 1 byte ) 9 | fix ( 1 byte ) 10 | timestamp POSIX timestamp ( 4 bytes) 11 | hash MD5-hashed body (16 bytes) 12 | Body: 13 | Segment Top level segment 14 | Segment* Other segments 15 | 16 | Segment: 17 | ConstantTable 18 | SymbolTable 19 | Code 20 | 21 | ConstantTable: 22 | size ( 4 bytes) 23 | Constant* 24 | 25 | Constant: 26 | type ( 4 bytes) 27 | value 28 | 29 | SymbolTable: 30 | size ( 4 bytes) 31 | Symbol* 32 | 33 | Symbol: 34 | size ( 4 bytes) 35 | value 36 | 37 | Code: 38 | size ( 4 bytes) 39 | Instr* 40 | 41 | Instr: 42 | code ( 4 bytes) 43 | arg? ( 4 bytes) 44 | ``` 45 | -------------------------------------------------------------------------------- /examples/ackermann.sf: -------------------------------------------------------------------------------- 1 | fn ackermann(int m, int n) -> int { 2 | if (m == 0) { 3 | return n + 1; 4 | } else if (m > 0 and n == 0) { 5 | return ackermann(m - 1, 1); 6 | } else { 7 | return ackermann(m - 1, ackermann(m, n - 1)); 8 | } 9 | } 10 | 11 | print(ackermann(3, 6)); 12 | -------------------------------------------------------------------------------- /examples/ackermann.sfc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/felko/snowflake/af8d9b18fee7e5d89c9065308c958804af222dec/examples/ackermann.sfc -------------------------------------------------------------------------------- /examples/factorial.sf: -------------------------------------------------------------------------------- 1 | fn fact(int n) -> int { 2 | int f = 1; 3 | int k = 1; 4 | while (k <= n) { 5 | f = f * k; 6 | k = k + 1; 7 | } 8 | return f; 9 | } 10 | 11 | print(fact(15)); 12 | -------------------------------------------------------------------------------- /examples/fibonacci.sf: -------------------------------------------------------------------------------- 1 | fn fibonacci(int n) -> int { 2 | int u = 1; 3 | int v = 1; 4 | int k = 0; 5 | while (k <= n - 3) { 6 | int w = u + v; 7 | u = v; 8 | v = w; 9 | k = k + 1; 10 | } 11 | return w; 12 | } 13 | 14 | print(fibonacci(40)); 15 | -------------------------------------------------------------------------------- /examples/fibonacci.sfc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/felko/snowflake/af8d9b18fee7e5d89c9065308c958804af222dec/examples/fibonacci.sfc -------------------------------------------------------------------------------- /examples/hello.sf: -------------------------------------------------------------------------------- 1 | print("Hello World"); 2 | -------------------------------------------------------------------------------- /examples/hello.sfc: -------------------------------------------------------------------------------- 1 | snowflake[t9cad03aa03725e7d5b08c6ff8fb3b1f39 Hello WorldprintPQ -------------------------------------------------------------------------------- /examples/pom.sf: -------------------------------------------------------------------------------- 1 | int mystere = 56; 2 | int essai = 509; 3 | while (essai != mystere) { 4 | essai = parseInt(input("> ")); 5 | if (essai < mystere) 6 | print("+"); 7 | else if (essai > mystere) 8 | print("-"); 9 | else 10 | print("gagné"); 11 | } 12 | -------------------------------------------------------------------------------- /examples/speed_test.sf: -------------------------------------------------------------------------------- 1 | int i1 = 1; 2 | int i2 = 2; 3 | int i3 = 3; 4 | int i4 = 4; 5 | int i5 = 5; 6 | int i6 = 6; 7 | int i7 = 7; 8 | int i8 = 8; 9 | int i9 = 9; 10 | int i10 = 10; 11 | int i11 = 11; 12 | int i12 = 12; 13 | int i13 = 13; 14 | int i14 = 14; 15 | int i15 = 15; 16 | int i16 = 16; 17 | int i17 = 17; 18 | int i18 = 18; 19 | int i19 = 19; 20 | int i20 = 20; 21 | int i21 = 21; 22 | int i22 = 22; 23 | int i23 = 23; 24 | int i24 = 24; 25 | int i25 = 25; 26 | int i26 = 26; 27 | int i27 = 27; 28 | int i28 = 28; 29 | int i29 = 29; 30 | int i30 = 30; 31 | int i31 = 31; 32 | int i32 = 32; 33 | int i33 = 33; 34 | int i34 = 34; 35 | int i35 = 35; 36 | int i36 = 36; 37 | int i37 = 37; 38 | int i38 = 38; 39 | int i39 = 39; 40 | int i40 = 40; 41 | int i41 = 41; 42 | int i42 = 42; 43 | int i43 = 43; 44 | int i44 = 44; 45 | int i45 = 45; 46 | int i46 = 46; 47 | int i47 = 47; 48 | int i48 = 48; 49 | int i49 = 49; 50 | int i50 = 50; 51 | int i51 = 51; 52 | int i52 = 52; 53 | int i53 = 53; 54 | int i54 = 54; 55 | int i55 = 55; 56 | int i56 = 56; 57 | int i57 = 57; 58 | int i58 = 58; 59 | int i59 = 59; 60 | int i60 = 60; 61 | int i61 = 61; 62 | int i62 = 62; 63 | int i63 = 63; 64 | int i64 = 64; 65 | int i65 = 65; 66 | int i66 = 66; 67 | int i67 = 67; 68 | int i68 = 68; 69 | int i69 = 69; 70 | int i70 = 70; 71 | int i71 = 71; 72 | int i72 = 72; 73 | int i73 = 73; 74 | int i74 = 74; 75 | int i75 = 75; 76 | int i76 = 76; 77 | int i77 = 77; 78 | int i78 = 78; 79 | int i79 = 79; 80 | int i80 = 80; 81 | int i81 = 81; 82 | int i82 = 82; 83 | int i83 = 83; 84 | int i84 = 84; 85 | int i85 = 85; 86 | int i86 = 86; 87 | int i87 = 87; 88 | int i88 = 88; 89 | int i89 = 89; 90 | int i90 = 90; 91 | int i91 = 91; 92 | int i92 = 92; 93 | int i93 = 93; 94 | int i94 = 94; 95 | int i95 = 95; 96 | int i96 = 96; 97 | int i97 = 97; 98 | int i98 = 98; 99 | int i99 = 99; 100 | int i100 = 100; 101 | int i101 = 101; 102 | int i102 = 102; 103 | int i103 = 103; 104 | int i104 = 104; 105 | int i105 = 105; 106 | int i106 = 106; 107 | int i107 = 107; 108 | int i108 = 108; 109 | int i109 = 109; 110 | int i110 = 110; 111 | int i111 = 111; 112 | int i112 = 112; 113 | int i113 = 113; 114 | int i114 = 114; 115 | int i115 = 115; 116 | int i116 = 116; 117 | int i117 = 117; 118 | int i118 = 118; 119 | int i119 = 119; 120 | int i120 = 120; 121 | int i121 = 121; 122 | int i122 = 122; 123 | int i123 = 123; 124 | int i124 = 124; 125 | int i125 = 125; 126 | int i126 = 126; 127 | int i127 = 127; 128 | int i128 = 128; 129 | int i129 = 129; 130 | int i130 = 130; 131 | int i131 = 131; 132 | int i132 = 132; 133 | int i133 = 133; 134 | int i134 = 134; 135 | int i135 = 135; 136 | int i136 = 136; 137 | int i137 = 137; 138 | int i138 = 138; 139 | int i139 = 139; 140 | int i140 = 140; 141 | int i141 = 141; 142 | int i142 = 142; 143 | int i143 = 143; 144 | int i144 = 144; 145 | int i145 = 145; 146 | int i146 = 146; 147 | int i147 = 147; 148 | int i148 = 148; 149 | int i149 = 149; 150 | int i150 = 150; 151 | int i151 = 151; 152 | int i152 = 152; 153 | int i153 = 153; 154 | int i154 = 154; 155 | int i155 = 155; 156 | int i156 = 156; 157 | int i157 = 157; 158 | int i158 = 158; 159 | int i159 = 159; 160 | int i160 = 160; 161 | int i161 = 161; 162 | int i162 = 162; 163 | int i163 = 163; 164 | int i164 = 164; 165 | int i165 = 165; 166 | int i166 = 166; 167 | int i167 = 167; 168 | int i168 = 168; 169 | int i169 = 169; 170 | int i170 = 170; 171 | int i171 = 171; 172 | int i172 = 172; 173 | int i173 = 173; 174 | int i174 = 174; 175 | int i175 = 175; 176 | int i176 = 176; 177 | int i177 = 177; 178 | int i178 = 178; 179 | int i179 = 179; 180 | int i180 = 180; 181 | int i181 = 181; 182 | int i182 = 182; 183 | int i183 = 183; 184 | int i184 = 184; 185 | int i185 = 185; 186 | int i186 = 186; 187 | int i187 = 187; 188 | int i188 = 188; 189 | int i189 = 189; 190 | int i190 = 190; 191 | int i191 = 191; 192 | int i192 = 192; 193 | int i193 = 193; 194 | int i194 = 194; 195 | int i195 = 195; 196 | int i196 = 196; 197 | int i197 = 197; 198 | int i198 = 198; 199 | int i199 = 199; 200 | int i200 = 200; 201 | int i201 = 201; 202 | int i202 = 202; 203 | int i203 = 203; 204 | int i204 = 204; 205 | int i205 = 205; 206 | int i206 = 206; 207 | int i207 = 207; 208 | int i208 = 208; 209 | int i209 = 209; 210 | int i210 = 210; 211 | int i211 = 211; 212 | int i212 = 212; 213 | int i213 = 213; 214 | int i214 = 214; 215 | int i215 = 215; 216 | int i216 = 216; 217 | int i217 = 217; 218 | int i218 = 218; 219 | int i219 = 219; 220 | int i220 = 220; 221 | int i221 = 221; 222 | int i222 = 222; 223 | int i223 = 223; 224 | int i224 = 224; 225 | int i225 = 225; 226 | int i226 = 226; 227 | int i227 = 227; 228 | int i228 = 228; 229 | int i229 = 229; 230 | int i230 = 230; 231 | int i231 = 231; 232 | int i232 = 232; 233 | int i233 = 233; 234 | int i234 = 234; 235 | int i235 = 235; 236 | int i236 = 236; 237 | int i237 = 237; 238 | int i238 = 238; 239 | int i239 = 239; 240 | int i240 = 240; 241 | int i241 = 241; 242 | int i242 = 242; 243 | int i243 = 243; 244 | int i244 = 244; 245 | int i245 = 245; 246 | int i246 = 246; 247 | int i247 = 247; 248 | int i248 = 248; 249 | int i249 = 249; 250 | int i250 = 250; 251 | int i251 = 251; 252 | int i252 = 252; 253 | int i253 = 253; 254 | int i254 = 254; 255 | int i255 = 255; 256 | int i256 = 256; 257 | int i257 = 257; 258 | int i258 = 258; 259 | int i259 = 259; 260 | int i260 = 260; 261 | int i261 = 261; 262 | int i262 = 262; 263 | int i263 = 263; 264 | int i264 = 264; 265 | int i265 = 265; 266 | int i266 = 266; 267 | int i267 = 267; 268 | int i268 = 268; 269 | int i269 = 269; 270 | int i270 = 270; 271 | int i271 = 271; 272 | int i272 = 272; 273 | int i273 = 273; 274 | int i274 = 274; 275 | int i275 = 275; 276 | int i276 = 276; 277 | int i277 = 277; 278 | int i278 = 278; 279 | int i279 = 279; 280 | int i280 = 280; 281 | int i281 = 281; 282 | int i282 = 282; 283 | int i283 = 283; 284 | int i284 = 284; 285 | int i285 = 285; 286 | int i286 = 286; 287 | int i287 = 287; 288 | int i288 = 288; 289 | int i289 = 289; 290 | int i290 = 290; 291 | int i291 = 291; 292 | int i292 = 292; 293 | int i293 = 293; 294 | int i294 = 294; 295 | int i295 = 295; 296 | int i296 = 296; 297 | int i297 = 297; 298 | int i298 = 298; 299 | int i299 = 299; 300 | int i300 = 300; 301 | -------------------------------------------------------------------------------- /examples/speed_test.sfc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/felko/snowflake/af8d9b18fee7e5d89c9065308c958804af222dec/examples/speed_test.sfc -------------------------------------------------------------------------------- /examples/test.sf: -------------------------------------------------------------------------------- 1 | type Position { 2 | float x; 3 | float y; 4 | } 5 | 6 | Position p = { x = 0.0, y = 0.0 }; 7 | 8 | print(p); 9 | 10 | print(p.x); 11 | 12 | { float a; float b; } x = { a = 0.0, b = 1.0 }; 13 | print(x); 14 | 15 | fn id(T x) -> T { 16 | return x; 17 | } 18 | 19 | print(id(0)); 20 | 21 | fn printPair(T x, T y) { 22 | print(x, y); 23 | } 24 | 25 | printPair(3, "test"); 26 | -------------------------------------------------------------------------------- /snowflake.cabal: -------------------------------------------------------------------------------- 1 | -- Initial snowflake.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: snowflake 5 | version: 0.1.0.0 6 | synopsis: An imperative, statically-typed toy language 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: felko 11 | maintainer: alpha.zeta546@gmail.com 12 | -- copyright: 13 | category: Language 14 | build-type: Simple 15 | extra-source-files: README.md, src/snowflake_ascii.txt 16 | cabal-version: >=1.10 17 | 18 | executable snowflake 19 | main-is: Main.hs 20 | ghc-options: -O2 21 | other-modules: Data.ChainMap 22 | , Data.AST 23 | , Language.Snowflake 24 | , Language.Snowflake.Parser 25 | , Language.Snowflake.Parser.AST 26 | , Language.Snowflake.Parser.Lexer 27 | , Language.Snowflake.Parser.Rules 28 | , Language.Snowflake.Compiler 29 | , Language.Snowflake.Compiler.CodeGen 30 | , Language.Snowflake.Compiler.Decoder 31 | , Language.Snowflake.Compiler.Encoder 32 | , Language.Snowflake.Compiler.Types 33 | , Language.Snowflake.Typing 34 | , Language.Snowflake.Typing.TypeCheck 35 | , Language.Snowflake.Typing.Types 36 | , Language.Snowflake.Optimizer 37 | , Language.Snowflake.VM 38 | , Language.Snowflake.VM.Operators 39 | , Language.Snowflake.VM.Types 40 | , Language.Snowflake.REPL 41 | , Language.Snowflake.REPL.Parser 42 | , Language.Snowflake.REPL.Types 43 | , Language.Snowflake.Options 44 | , Language.Snowflake.Options.Command 45 | , Language.Snowflake.Options.Parser 46 | , Language.Snowflake.Options.Types 47 | , Language.Snowflake.Builtins 48 | , Paths_snowflake 49 | other-extensions: LambdaCase, TupleSections, TemplateHaskell, DeriveFunctor 50 | build-depends: base >=4.10 && <4.11 51 | , mtl >=2.2 && <2.3 52 | , containers >=0.5 && <0.6 53 | , time >=1.8 && <1.9 54 | , bytestring ==0.10.* 55 | , filepath ==1.4.* 56 | , lens >=4.15 57 | , parsec >=3.1 && <3.2 58 | , optparse-applicative ==0.14.2.0 59 | , binary ==0.8.* 60 | , utf8-string ==1.0.* 61 | , cryptonite ==0.25.* 62 | , haskeline ==0.7.4.* 63 | , ansi-terminal ==0.8.* 64 | , recursion-schemes 65 | , comonad 66 | , free >=5 67 | hs-source-dirs: src 68 | default-language: Haskell2010 69 | -------------------------------------------------------------------------------- /src/Data/AST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | FlexibleContexts 3 | , PatternSynonyms 4 | , ViewPatterns 5 | #-} 6 | 7 | -- Inspired from https://github.com/romac/lfc-haskell 8 | 9 | module Data.AST 10 | ( AST 11 | , module Control.Comonad 12 | , module Control.Comonad.Cofree 13 | --, annotate, annotateM, annotateM_ 14 | , pattern (:>) 15 | ) where 16 | 17 | import Data.Bifunctor 18 | import Data.Functor.Foldable 19 | 20 | import Control.Comonad 21 | import Control.Comonad.Cofree 22 | 23 | newtype AST f a = AST { unAST :: Cofree (f a) a } 24 | 25 | instance Bifunctor f => Functor (AST f) where 26 | fmap f (s :> n) = f s :> bimap f (fmap f) n 27 | 28 | instance Bifunctor f => Comonad (AST f) where 29 | extract (s :> _) = s 30 | duplicate n@(_ :> c) = n :> first (const n) (second duplicate c) 31 | --where n = _ --extend (f . AST) _ 32 | 33 | pattern (:>) :: Bifunctor f => a -> f a (AST f a) -> AST f a 34 | pattern s :> n <- AST (s :< (second AST -> n)) where 35 | s :> n = AST (s :< (second unAST n)) 36 | 37 | -- cofree f a = a :< f (cofree f a) 38 | -- cofree (f a) a = a :< f a (cofree (f a) a) 39 | 40 | -- annotate :: Recursive t => (t -> a) -> t -> AST (Base t) a 41 | -- annotate alg t = alg t :< fmap (annotate alg) (project t) 42 | -- 43 | -- annotateM :: (Recursive t, Monad m, Traversable (Base t)) => (Base t (m a) -> m a) -> t -> m (AST (Base t) a) 44 | -- annotateM f x = sequence (annotate (cata f) x) 45 | -- 46 | -- annotateM_ :: (Recursive t, Traversable (Base t), Monad m) => (Cofree (Base t) () -> m a) -> t -> m (Cofree (Base t) a) 47 | -- annotateM_ f x = sequence (extend f (annotate (const ()) x)) 48 | -------------------------------------------------------------------------------- /src/Data/ChainMap.hs: -------------------------------------------------------------------------------- 1 | module Data.ChainMap where 2 | 3 | import Prelude hiding (lookup) 4 | 5 | import Control.Lens 6 | import Control.Applicative ((<|>)) 7 | 8 | import Data.Map (Map) 9 | import qualified Data.Map as Map 10 | import Data.List (intercalate, findIndex) 11 | import Data.Maybe (maybe) 12 | 13 | newtype ChainMap k a = ChainMap [Map k a] 14 | deriving Eq 15 | 16 | instance (Show k, Show a) => Show (ChainMap k a) where 17 | show (ChainMap ms) = '[' : intercalate "," (map showScope ms) ++ "]" 18 | where showScope scope = '{' : intercalate "," (map showAssoc (Map.toList scope)) ++ "}" 19 | showAssoc (k, v) = show k ++ ": " ++ show v 20 | 21 | instance Ord k => Functor (ChainMap k) where 22 | fmap f (ChainMap ms) = ChainMap (fmap (fmap f) ms) 23 | 24 | instance Ord k => Foldable (ChainMap k) where 25 | foldr f d (ChainMap ms) = foldr f d (mconcat ms) 26 | 27 | -- instance Ord k => Traversable (Env k) where 28 | -- traverse f e = 29 | 30 | instance Ord k => Monoid (ChainMap k a) where 31 | mempty = ChainMap [] 32 | mappend (ChainMap ms) (ChainMap ms') = undefined 33 | 34 | lookup :: Ord k => k -> ChainMap k a -> Maybe a 35 | lookup _ (ChainMap []) = Nothing 36 | lookup k (ChainMap (m:ms)) = Map.lookup k m <|> lookup k (ChainMap ms) 37 | 38 | findWithDefault :: Ord k => a -> k -> ChainMap k a -> a 39 | findWithDefault d k cm = maybe d id (lookup k cm) 40 | 41 | update :: Ord k => k -> a -> ChainMap k a -> ChainMap k a 42 | update k v (ChainMap []) = ChainMap [Map.singleton k v] 43 | update k v cm@(ChainMap ms) = case mapIndex k cm of 44 | Just i -> ChainMap (ms & ix i %~ Map.insert k v) 45 | Nothing -> ChainMap (ms & ix 0 %~ Map.insert k v) 46 | 47 | insert :: Ord k => k -> a -> ChainMap k a -> ChainMap k a 48 | insert k v (ChainMap []) = ChainMap [Map.singleton k v] 49 | insert k v (ChainMap (m:ms)) = ChainMap (Map.insert k v m : ms) 50 | 51 | member :: Ord k => k -> ChainMap k a -> Bool 52 | member k (ChainMap ms) = any (Map.member k) ms 53 | 54 | mapIndex :: Ord k => k -> ChainMap k a -> Maybe Int 55 | mapIndex k (ChainMap ms) = findIndex (Map.member k) ms 56 | 57 | newChild :: Ord k => Map k a -> ChainMap k a -> ChainMap k a 58 | newChild m (ChainMap ms) = ChainMap (m:ms) 59 | 60 | empty :: Ord k => ChainMap k a 61 | empty = ChainMap [] 62 | 63 | singleMap :: Ord k => Map k a -> ChainMap k a 64 | singleMap m = ChainMap [m] 65 | 66 | fromMaps :: Ord k => [Map k a] -> ChainMap k a 67 | fromMaps = ChainMap 68 | 69 | fromLists :: Ord k => [[(k, a)]] -> ChainMap k a 70 | fromLists l = ChainMap (map Map.fromList l) 71 | 72 | 73 | m :: ChainMap Char Int 74 | m = ChainMap [ Map.fromList [('a', 1), ('b', 2), ('c', 3)] 75 | , Map.fromList [('x', 3), ('b', 8), ('z', 9)] 76 | , Map.fromList [] ] 77 | -------------------------------------------------------------------------------- /src/Language/Snowflake.hs: -------------------------------------------------------------------------------- 1 | module Language.Snowflake (module Exports) where 2 | 3 | import Language.Snowflake.Parser as Exports 4 | import Language.Snowflake.Compiler as Exports 5 | import Language.Snowflake.Typing as Exports 6 | import Language.Snowflake.Optimizer as Exports 7 | import Language.Snowflake.VM as Exports 8 | import Language.Snowflake.REPL as Exports 9 | import Language.Snowflake.Options as Exports 10 | -------------------------------------------------------------------------------- /src/Language/Snowflake/Builtins.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Language.Snowflake.Builtins (defaultEnv, defaultTypeEnv, defaultBindings) where 4 | 5 | import Language.Snowflake.Typing 6 | import Language.Snowflake.VM 7 | 8 | import qualified Data.Map as Map 9 | 10 | import Text.Read (readMaybe) 11 | 12 | import Control.Monad (forM_) 13 | import Control.Monad.Trans (lift) 14 | 15 | import System.IO 16 | 17 | defaultEnv = Map.fromList 18 | [ ("print", printSF) 19 | , ("input", inputSF) 20 | , ("appendInt", appendSF) 21 | , ("parseInt", parseIntSF) ] 22 | 23 | defaultTypeEnv = Map.fromList 24 | [ ("int", IntT) 25 | , ("float", FloatT) 26 | , ("bool", BoolT) 27 | , ("str", StrT) ] 28 | 29 | defaultBindings = Map.fromList 30 | [ ("print", FuncT [] [AnyT] NoneT) 31 | , ("input", FuncT [] [StrT] StrT) 32 | , ("appendInt", FuncT [] [ListT IntT, IntT] (ListT IntT)) 33 | , ("parseInt", FuncT [] [StrT] IntT) ] 34 | 35 | printSF :: Value 36 | printSF = BuiltinVal $ \ xs -> lift . lift $ do 37 | forM_ xs $ \case 38 | StrVal s -> putStrLn s 39 | v -> print v 40 | hFlush stdout 41 | return NoneVal 42 | 43 | inputSF :: Value 44 | inputSF = BuiltinVal $ \case 45 | [StrVal prompt] -> lift . lift $ do 46 | putStr prompt 47 | hFlush stdout 48 | input <- StrVal <$> getLine 49 | return input 50 | args -> raise TypeError ("input: expected prompt of type string, got" ++ show args) 51 | 52 | appendSF :: Value 53 | appendSF = BuiltinVal $ \case 54 | [ListVal xs, x] -> return $ ListVal (xs ++ [x]) 55 | args -> raise TypeError ("append: expected list and value, got" ++ show args) 56 | 57 | parseIntSF :: Value 58 | parseIntSF = BuiltinVal $ \case 59 | [StrVal s] -> case readMaybe s of 60 | Just i -> return (IntVal i) 61 | Nothing -> raise ValueError ("parseInt: unable to parse " ++ show s ++ " as an integer") 62 | args -> raise TypeError ("parseInt: expected string, got" ++ show args) 63 | -------------------------------------------------------------------------------- /src/Language/Snowflake/Compiler.hs: -------------------------------------------------------------------------------- 1 | module Language.Snowflake.Compiler (module Exports) where 2 | 3 | import Language.Snowflake.Compiler.CodeGen as Exports 4 | import Language.Snowflake.Compiler.Encoder as Exports 5 | import Language.Snowflake.Compiler.Decoder as Exports 6 | import Language.Snowflake.Compiler.Types as Exports 7 | -------------------------------------------------------------------------------- /src/Language/Snowflake/Compiler/CodeGen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types, LambdaCase, TemplateHaskell #-} 2 | 3 | module Language.Snowflake.Compiler.CodeGen 4 | ( Compiler 5 | , compileExpr, compileInstr, compileProgram 6 | , execCompiler 7 | ) where 8 | 9 | import Prelude hiding (Ordering(..)) 10 | 11 | import Language.Snowflake.Parser.AST 12 | import Language.Snowflake.Compiler.Types 13 | import Language.Snowflake.Typing.Types 14 | 15 | import Control.Lens 16 | import Control.Applicative ((<|>)) 17 | import Control.Monad.State 18 | import Control.Monad.Except 19 | import Control.Arrow ((&&&)) 20 | 21 | import qualified Data.Map as Map 22 | import Data.Maybe (fromMaybe) 23 | import Data.Word 24 | import Data.List 25 | import Data.Version 26 | import Data.Time.Clock.POSIX (getPOSIXTime) 27 | 28 | import Paths_snowflake (version) 29 | 30 | type Compiler s a = State s a 31 | 32 | nodeLoc :: Node (Loc, Type) s -> Loc 33 | nodeLoc (Node _ (loc, _)) = loc 34 | 35 | nodeType :: Node (Loc, Type) s -> Type 36 | nodeType (Node _ (_, typ)) = typ 37 | 38 | liftTopLevel :: Compiler Segment a -> Compiler Bytecode a 39 | liftTopLevel sc = do 40 | (res, newSeg) <- runState sc <$> gets _bcTopLevel 41 | bcTopLevel .= newSeg 42 | return res 43 | 44 | sandboxBytecode :: Compiler Bytecode a -> Compiler Bytecode [Instr] 45 | sandboxBytecode compiler = do 46 | bytecode <- get 47 | let sandboxed = execState compiler (bytecode & bcTopLevel . segInstrs .~ []) 48 | instrs = sandboxed ^. bcTopLevel . segInstrs 49 | put (sandboxed & bcTopLevel . segInstrs .~ (bytecode ^. bcTopLevel . segInstrs)) 50 | return instrs 51 | 52 | sandboxSegment :: Compiler Segment a -> Compiler Bytecode [Instr] 53 | sandboxSegment compiler = do 54 | topLevel <- use bcTopLevel 55 | let sandboxed = execState compiler (topLevel & segInstrs .~ []) 56 | instrs = sandboxed ^. segInstrs 57 | bcTopLevel .= (sandboxed & segInstrs .~ (topLevel ^. segInstrs)) 58 | return instrs 59 | -- sandboxSegment = sandboxBytecode . liftTopLevel ? 60 | 61 | literalToConstant :: Literal -> Constant 62 | literalToConstant (IntLit n) = IntConst n 63 | literalToConstant (FloatLit x) = FloatConst x 64 | literalToConstant (BoolLit b) = BoolConst b 65 | literalToConstant (StrLit s) = StrConst s 66 | literalToConstant NoneLit = NoneConst 67 | 68 | newSegment :: Segment -> Compiler Bytecode Word32 69 | newSegment seg = do 70 | bcSegments %= (++ [seg]) 71 | gets (subtract 1 . genericLength . _bcSegments) 72 | 73 | defaultSegment = Segment 74 | { _segConstants = [] 75 | , _segSymbols = [] 76 | , _segStructs = [] 77 | , _segInstrs = [] } 78 | 79 | execCompiler :: Compiler Bytecode a -> IO Bytecode 80 | execCompiler c = do 81 | timestamp <- round <$> getPOSIXTime 82 | return $ execState c (Bytecode [] defaultSegment timestamp version) 83 | 84 | addInstr :: Instr -> Compiler Segment () 85 | addInstr instr = addInstrs [instr] 86 | 87 | addInstrs :: [Instr] -> Compiler Segment () 88 | addInstrs instrs = segInstrs %= (++ instrs) 89 | 90 | newID :: Eq a => Lens' Segment [a] -> a -> Compiler Segment Word32 91 | newID lst x = do 92 | xs <- use lst 93 | case elemIndex x xs of 94 | Just i -> return (fromIntegral i) 95 | Nothing -> do 96 | lst %= (++ [x]) 97 | return (genericLength xs) 98 | 99 | newConstant :: Constant -> Compiler Segment Word32 100 | newConstant = newID segConstants 101 | 102 | newSymbol :: Name -> Compiler Segment Word32 103 | newSymbol = newID segSymbols 104 | 105 | newStruct :: [Name] -> Compiler Segment Word32 106 | newStruct = newID segStructs 107 | 108 | instantiateVariable :: Name -> Compiler Segment () 109 | instantiateVariable var = elemIndex var <$> gets _segSymbols >>= \case 110 | Just i -> addInstr $ LOAD (fromIntegral i) 111 | Nothing -> addInstr =<< LOAD <$> newSymbol var 112 | 113 | binOp :: BinOp -> Expr (Loc, Type) -> Expr (Loc, Type) -> Compiler Segment () 114 | binOp op a b = do 115 | compileExpr a 116 | compileExpr b 117 | addInstr $ case op of 118 | AddOp -> ADD 119 | SubOp -> SUB 120 | MulOp -> MUL 121 | DivOp -> DIV 122 | PowOp -> POW 123 | AndOp -> AND 124 | OrOp -> OR 125 | LTOp -> LT 126 | LEOp -> LE 127 | EQOp -> EQ 128 | NEQOp -> NEQ 129 | GEOp -> GE 130 | GTOp -> GT 131 | 132 | unOp :: UnOp -> Expr (Loc, Type) -> Compiler Segment () 133 | unOp op x = do 134 | compileExpr x 135 | addInstr $ case op of 136 | PosOp -> POS 137 | NegOp -> NEG 138 | NotOp -> NOT 139 | 140 | compileExpr :: Expr (Loc, Type) -> Compiler Segment () 141 | compileExpr (VarExpr name) = instantiateVariable name 142 | compileExpr (AttrExpr owner attr) = do 143 | i <- newSymbol attr 144 | compileExpr owner 145 | addInstr $ LOAD_ATTR i 146 | compileExpr (LitExpr lit) = addInstr =<< (LOAD_CONST <$> newConstant (literalToConstant lit)) 147 | compileExpr (BinOpExpr op a b) = binOp op a b 148 | compileExpr (UnOpExpr op x) = unOp op x 149 | compileExpr (CallExpr fn _ args) = do 150 | compileExpr fn 151 | mapM_ compileExpr args 152 | addInstr $ CALL (genericLength args) 153 | compileExpr (ListExpr lst) = do 154 | mapM_ compileExpr lst 155 | addInstr $ BUILD_LIST (genericLength lst) 156 | compileExpr (TupleExpr t) = do 157 | mapM_ compileExpr t 158 | addInstr $ BUILD_TUPLE (genericLength t) 159 | compileExpr (StructExpr assocs) = do 160 | i <- newStruct (Map.keys assocs) 161 | mapM_ compileExpr (Map.elems assocs) 162 | addInstr $ BUILD_STRUCT i 163 | 164 | compileBlock :: Decl Block (Loc, Type) -> Compiler Bytecode () 165 | compileBlock (Decl (Node (Block block) _)) = mapM_ compileInstr block 166 | 167 | compileInstr :: Decl Instruction (Loc, Type) -> Compiler Bytecode () 168 | compileInstr (Decl (Node (DeclareInstr _ name val) _)) = liftTopLevel $ do 169 | i <- newSymbol name 170 | compileExpr val 171 | addInstr (STORE i) 172 | compileInstr (Decl (Node (AssignInstr name val) _)) = liftTopLevel $ do 173 | i <- newSymbol name 174 | compileExpr val 175 | addInstr (STORE i) 176 | compileInstr (Decl (Node (ReturnInstr val) _)) = liftTopLevel $ compileExpr val >> addInstr RETURN 177 | compileInstr (Decl (Node (ExprInstr expr) _)) = liftTopLevel $ compileExpr expr >> addInstr POP 178 | compileInstr (Decl (Node (CondInstr cond tr fl) _)) = do 179 | condInstrs <- sandboxSegment (compileExpr cond) 180 | trInstrs <- sandboxBytecode (compileBlock tr) 181 | flInstrs <- sandboxBytecode (compileBlock fl) 182 | let trOffset = genericLength trInstrs 183 | flOffset = genericLength flInstrs 184 | liftTopLevel $ do 185 | addInstrs condInstrs 186 | addInstr NOT 187 | addInstr IF 188 | addInstr $ JUMP trOffset 189 | addInstrs trInstrs 190 | addInstr $ JUMP flOffset 191 | addInstrs flInstrs 192 | compileInstr (Decl (Node (ForInstr var iter loop) _)) = do 193 | loopInstrs <- sandboxBytecode (compileBlock loop) 194 | let loopOffset = genericLength loopInstrs 195 | liftTopLevel $ do 196 | compileExpr iter 197 | iVar <- newSymbol var 198 | addInstr $ ITER (loopOffset+2) 199 | addInstr $ STORE iVar 200 | addInstrs loopInstrs 201 | addInstr $ JUMP (-loopOffset-3) 202 | compileInstr (Decl (Node (WhileInstr cond loop) _)) = do 203 | condInstrs <- sandboxSegment (compileExpr cond) 204 | loopInstrs <- sandboxBytecode (compileBlock loop) 205 | let condOffset = genericLength condInstrs 206 | loopOffset = genericLength loopInstrs 207 | offset = condOffset + loopOffset 208 | liftTopLevel $ do 209 | addInstrs condInstrs 210 | addInstr NOT 211 | addInstr IF 212 | addInstr $ JUMP loopOffset 213 | addInstrs loopInstrs 214 | addInstr $ JUMP (-offset-4) 215 | compileInstr (Decl (Node (FnInstr (FnDecl name _ params _ body)) _)) = do 216 | bytecode <- get 217 | let paramSymbols = map _paramName params 218 | initSegment = defaultSegment & segSymbols .~ paramSymbols 219 | initState = bytecode & bcTopLevel .~ initSegment 220 | funcBytecode = execState (compileBlock body) initState 221 | bcSegments .= (funcBytecode ^. bcSegments) 222 | segIndex <- newSegment (funcBytecode ^. bcTopLevel) 223 | liftTopLevel $ do 224 | iSymbol <- newSymbol name 225 | iConst <- newConstant (FuncConst segIndex) 226 | addInstr $ LOAD_CONST iConst 227 | addInstr $ STORE iSymbol 228 | compileInstr (Decl (Node (TypeInstr (TypeDecl name fields)) loc)) = return () 229 | 230 | compileProgram :: Program (Loc, Type) -> Compiler Bytecode () 231 | compileProgram (Program instrs) = compileBlock instrs 232 | -------------------------------------------------------------------------------- /src/Language/Snowflake/Compiler/Decoder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Language.Snowflake.Compiler.Decoder where 4 | 5 | import Prelude hiding (Ordering(..)) 6 | 7 | import Language.Snowflake.Compiler.Types 8 | 9 | import Control.Monad.RWS 10 | import Control.Applicative (many) 11 | 12 | import Data.Char 13 | import Data.Word 14 | import Data.List (genericLength) 15 | import Data.Version 16 | 17 | import Data.ByteString.Lazy (ByteString) 18 | import qualified Data.ByteString.Lazy as BS 19 | import Data.Binary.Get hiding (Decoder) 20 | 21 | import Data.Time.Clock.POSIX 22 | 23 | import Paths_snowflake (version) 24 | 25 | type Decoder a = Get a 26 | 27 | checkMagic :: Decoder () 28 | checkMagic = do 29 | magic <- replicateM (length "snowflake") (fromIntegral <$> getWord8) 30 | if magic == map ord "snowflake" then 31 | return () 32 | else 33 | fail "Magic string \"snowflake\" undetected" 34 | 35 | decodeVersion :: Decoder Version 36 | decodeVersion = do 37 | v <- replicateM 4 (fromIntegral <$> getWord8) 38 | if v == versionBranch version then 39 | return version 40 | else 41 | fail "Wrong version branch" 42 | 43 | decodeTimestamp :: Decoder Word32 44 | decodeTimestamp = getWord32be 45 | 46 | decodeSegment :: Decoder Segment 47 | decodeSegment = Segment <$> decodeConstantTable <*> decodeSymbolTable <*> decodeStructTable <*> decodeInstructions 48 | 49 | decodeConstantTable :: Decoder [Constant] 50 | decodeConstantTable = do 51 | n <- fromIntegral <$> getWord32be 52 | replicateM n decodeConstant 53 | 54 | decodeSymbolTable :: Decoder [Name] 55 | decodeSymbolTable = do 56 | n <- fromIntegral <$> getWord32be 57 | replicateM n decodeSymbol 58 | 59 | decodeStructTable :: Decoder [[Name]] 60 | decodeStructTable = do 61 | n <- fromIntegral <$> getWord32be 62 | replicateM n decodeStruct 63 | 64 | decodeConstant :: Decoder Constant 65 | decodeConstant = getWord8 >>= \case 66 | 0x00 -> return NoneConst 67 | 0x01 -> IntConst <$> getInt64be 68 | 0x02 -> FloatConst <$> getFloatbe 69 | 0x03 -> getWord8 >>= \case 70 | 0x00 -> return (BoolConst False) 71 | 0x01 -> return (BoolConst True) 72 | 0x04 -> do 73 | size <- fromIntegral <$> getWord32be 74 | val <- unpackUTF8 <$> getLazyByteString size 75 | return (StrConst val) 76 | 0x05 -> FuncConst <$> getWord32be 77 | b -> fail $ "Unknown constant " ++ show b 78 | 79 | decodeSymbol :: Decoder Name 80 | decodeSymbol = do 81 | size <- fromIntegral <$> getWord32be 82 | unpackUTF8 <$> getLazyByteString size 83 | 84 | decodeStruct :: Decoder [Name] 85 | decodeStruct = do 86 | size <- fromIntegral <$> getWord32be 87 | replicateM size $ (fromIntegral <$> getWord32be) >>= fmap unpackUTF8 . getLazyByteString 88 | 89 | decodeInstructions :: Decoder [Instr] 90 | decodeInstructions = do 91 | opcount <- fromIntegral <$> getWord32be 92 | replicateM opcount decodeInstr 93 | 94 | decodeInstr :: Decoder Instr 95 | decodeInstr = getWord32be >>= \case 96 | 0x00 -> return NOP 97 | 0x01 -> return POP 98 | 0x10 -> return NOT 99 | 0x11 -> return AND 100 | 0x12 -> return OR 101 | 0x20 -> return ADD 102 | 0x21 -> return SUB 103 | 0x22 -> return MUL 104 | 0x23 -> return DIV 105 | 0x24 -> return POW 106 | 0x25 -> return POS 107 | 0x26 -> return NEG 108 | 0x30 -> return LT 109 | 0x31 -> return LE 110 | 0x32 -> return EQ 111 | 0x33 -> return NEQ 112 | 0x34 -> return GE 113 | 0x35 -> return GT 114 | 0x02 -> return RETURN 115 | 0x03 -> return IF 116 | 0x04 -> CALL <$> getWord32be 117 | 0x40 -> BUILD_LIST <$> getWord32be 118 | 0x41 -> BUILD_TUPLE <$> getWord32be 119 | 0x42 -> BUILD_STRUCT <$> getWord32be 120 | 0x05 -> STORE <$> getWord32be 121 | 0x50 -> LOAD <$> getWord32be 122 | 0x51 -> LOAD_CONST <$> getWord32be 123 | 0x52 -> LOAD_ATTR <$> getWord32be 124 | 0x06 -> JUMP <$> getInt32be 125 | 0x07 -> ITER <$> getInt32be 126 | b -> fail $ "Unable to decode instruction " ++ show b 127 | 128 | decodeHeader :: Decoder (Version, Word32, ByteString) 129 | decodeHeader = do 130 | checkMagic 131 | v <- decodeVersion 132 | t <- decodeTimestamp 133 | h <- getLazyByteString 32 134 | return (v, t, h) 135 | 136 | decodeBody :: Decoder (Segment, [Segment]) 137 | decodeBody = do 138 | tl <- decodeSegment 139 | ss <- many decodeSegment 140 | return (tl, ss) 141 | 142 | decodeBytecode :: Decoder Bytecode 143 | decodeBytecode = do 144 | (v, t, h) <- decodeHeader 145 | remaining <- lookAhead getRemainingLazyByteString 146 | if hashMD5 remaining == h then do 147 | (tl, ss) <- decodeBody 148 | return (Bytecode ss tl t v) 149 | else 150 | fail "File corrupted: failed to match MD5 hash" 151 | 152 | decodeFromFile :: FilePath -> IO Bytecode 153 | decodeFromFile path = do 154 | bs <- BS.readFile path 155 | case runGetOrFail decodeBytecode bs of 156 | Right (_, _, bc) -> return bc 157 | Left (_, _, err) -> fail err 158 | -------------------------------------------------------------------------------- /src/Language/Snowflake/Compiler/Encoder.hs: -------------------------------------------------------------------------------- 1 | module Language.Snowflake.Compiler.Encoder where 2 | 3 | import Prelude hiding (Ordering(..)) 4 | 5 | import Language.Snowflake.Compiler.Types 6 | 7 | import Control.Monad.RWS 8 | 9 | import Data.Char 10 | import Data.Word 11 | import Data.List (genericLength) 12 | import Data.Version 13 | import Data.ByteString.Lazy (ByteString) 14 | import qualified Data.ByteString.Lazy as BS 15 | import Data.Binary.Put 16 | 17 | import Data.Time.Clock.POSIX 18 | 19 | import Crypto.Hash 20 | 21 | type Encoder a = a -> Put 22 | 23 | encodeMagic :: Encoder () 24 | encodeMagic () = mapM_ (putWord8 . fromIntegral) (map ord "snowflake") 25 | 26 | encodeVersion :: Encoder Version 27 | encodeVersion v = mapM_ (putWord8 . fromIntegral) (versionBranch v) 28 | 29 | encodeTimestamp :: Encoder Word32 30 | encodeTimestamp = putWord32be 31 | 32 | encodeSegment :: Encoder Segment 33 | encodeSegment (Segment c s ss i) = do 34 | encodeConstantTable c 35 | encodeSymbolTable s 36 | encodeStructTable ss 37 | encodeInstructions i 38 | 39 | encodeConstantTable :: Encoder [Constant] 40 | encodeConstantTable c = do 41 | putWord32be (genericLength c) 42 | mapM_ encodeConstant c 43 | 44 | encodeSymbolTable :: Encoder [Name] 45 | encodeSymbolTable s = do 46 | putWord32be (genericLength s) 47 | mapM_ encodeSymbol s 48 | 49 | encodeStructTable :: Encoder [[Name]] 50 | encodeStructTable ss = do 51 | putWord32be (genericLength ss) 52 | mapM_ encodeStruct ss 53 | 54 | encodeConstant :: Encoder Constant 55 | encodeConstant NoneConst = putWord8 0x00 56 | encodeConstant (IntConst n) = putWord8 0x01 >> putInt64be n 57 | encodeConstant (FloatConst x) = putWord8 0x02 >> putFloatbe x 58 | encodeConstant (BoolConst False) = putWord8 0x03 >> putWord8 0x00 59 | encodeConstant (BoolConst True) = putWord8 0x03 >> putWord8 0x01 60 | encodeConstant (StrConst s) = putWord8 0x04 >> putWord32be (fromIntegral $ BS.length bs) >> putLazyByteString bs 61 | where bs = packUTF8 s 62 | encodeConstant (FuncConst i) = putWord8 0x05 >> putWord32be i 63 | 64 | encodeSymbol :: Encoder Name 65 | encodeSymbol sym = putWord32be (fromIntegral $ BS.length bsym) >> putLazyByteString bsym 66 | where bsym = packUTF8 sym 67 | 68 | encodeStruct :: Encoder [Name] 69 | encodeStruct fieldNames = do 70 | putWord32be (genericLength fieldNames) 71 | forM_ fieldNames $ \ fieldName -> do 72 | let bFieldName = packUTF8 fieldName 73 | putWord32be (fromIntegral $ BS.length bFieldName) 74 | putLazyByteString bFieldName 75 | 76 | encodeInstructions :: Encoder [Instr] 77 | encodeInstructions is = putWord32be (genericLength is) >> mapM_ encodeInstr is 78 | 79 | encodeInstr :: Encoder Instr 80 | encodeInstr NOP = putWord32be 0x00 81 | encodeInstr POP = putWord32be 0x01 82 | encodeInstr NOT = putWord32be 0x10 83 | encodeInstr AND = putWord32be 0x11 84 | encodeInstr OR = putWord32be 0x12 85 | encodeInstr ADD = putWord32be 0x20 86 | encodeInstr SUB = putWord32be 0x21 87 | encodeInstr MUL = putWord32be 0x22 88 | encodeInstr DIV = putWord32be 0x23 89 | encodeInstr POW = putWord32be 0x24 90 | encodeInstr POS = putWord32be 0x25 91 | encodeInstr NEG = putWord32be 0x26 92 | encodeInstr LT = putWord32be 0x30 93 | encodeInstr LE = putWord32be 0x31 94 | encodeInstr EQ = putWord32be 0x32 95 | encodeInstr NEQ = putWord32be 0x33 96 | encodeInstr GE = putWord32be 0x34 97 | encodeInstr GT = putWord32be 0x35 98 | encodeInstr RETURN = putWord32be 0x02 99 | encodeInstr IF = putWord32be 0x03 100 | encodeInstr (CALL n) = putWord32be 0x04 >> putWord32be n 101 | encodeInstr (BUILD_LIST n) = putWord32be 0x40 >> putWord32be n 102 | encodeInstr (BUILD_TUPLE n) = putWord32be 0x41 >> putWord32be n 103 | encodeInstr (BUILD_STRUCT n) = putWord32be 0x42 >> putWord32be n 104 | encodeInstr (STORE n) = putWord32be 0x05 >> putWord32be n 105 | encodeInstr (LOAD n) = putWord32be 0x50 >> putWord32be n 106 | encodeInstr (LOAD_CONST n) = putWord32be 0x51 >> putWord32be n 107 | encodeInstr (LOAD_ATTR n) = putWord32be 0x52 >> putWord32be n 108 | encodeInstr (JUMP n) = putWord32be 0x06 >> putInt32be n 109 | encodeInstr (ITER n) = putWord32be 0x07 >> putInt32be n 110 | 111 | encodeHeader :: Encoder (ByteString, Bytecode) 112 | encodeHeader (hash, (Bytecode _ _ ts v)) = do 113 | encodeMagic () 114 | encodeVersion v 115 | encodeTimestamp ts 116 | putLazyByteString hash 117 | 118 | encodeBody :: Encoder Bytecode 119 | encodeBody (Bytecode ss tl _ _) = do 120 | encodeSegment tl 121 | mapM_ encodeSegment ss 122 | 123 | encodeBytecode :: Encoder Bytecode 124 | encodeBytecode bc = do 125 | let bs = runPut (encodeBody bc) 126 | let hash = hashMD5 bs 127 | encodeHeader (hash, bc) 128 | putLazyByteString bs 129 | 130 | encodeToFile :: FilePath -> Bytecode -> IO () 131 | encodeToFile path bytecode = do 132 | let encoded = runPut (encodeBytecode bytecode) 133 | BS.writeFile path encoded 134 | -------------------------------------------------------------------------------- /src/Language/Snowflake/Compiler/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Language.Snowflake.Compiler.Types 4 | ( Instr(..) 5 | , Bytecode(..), bcSegments, bcTopLevel, bcTimestamp, bcVersion 6 | , Segment(..), segConstants, segSymbols, segStructs, segInstrs 7 | , Constant(..) 8 | , Name 9 | , Message 10 | , showBytecode 11 | , hashMD5, packUTF8, unpackUTF8 12 | , prettyPrintCode 13 | ) where 14 | 15 | import Language.Snowflake.Parser.AST 16 | 17 | import Control.Lens 18 | import Control.Monad (forM_) 19 | 20 | import Data.Word 21 | import Data.Int 22 | import Data.Char 23 | import Data.List 24 | import Data.Version (Version, showVersion) 25 | 26 | import qualified Data.ByteString.Char8 as C8 27 | import Data.ByteString.Lazy (ByteString) 28 | import qualified Data.ByteString.Lazy as BS 29 | import qualified Codec.Binary.UTF8.String as UTF8 30 | 31 | import Crypto.Hash 32 | 33 | type Message = String 34 | 35 | data Instr 36 | = NOP 37 | | POP 38 | | NOT | AND | OR 39 | | ADD | SUB | MUL | DIV | POW 40 | | POS | NEG 41 | | LT | LE | EQ | NEQ | GE | GT 42 | | RETURN 43 | | IF 44 | | CALL Word32 45 | | BUILD_LIST Word32 46 | | BUILD_TUPLE Word32 47 | | BUILD_STRUCT Word32 48 | | STORE Word32 49 | | LOAD Word32 50 | | LOAD_CONST Word32 51 | | LOAD_ATTR Word32 52 | | JUMP Int32 53 | | ITER Int32 54 | deriving (Eq, Show) 55 | 56 | data Constant 57 | = IntConst Int64 58 | | FloatConst Float 59 | | BoolConst Bool 60 | | StrConst String 61 | | FuncConst Word32 62 | | NoneConst 63 | deriving Eq 64 | 65 | instance Show Constant where 66 | show (IntConst n) = show n 67 | show (FloatConst x) = show x 68 | show (BoolConst b) = show b 69 | show (StrConst s) = show s 70 | show (FuncConst segIndex) = "<>" 71 | show NoneConst = "None" 72 | 73 | data Segment = Segment 74 | { _segConstants :: [Constant] 75 | , _segSymbols :: [Name] 76 | , _segStructs :: [[Name]] 77 | , _segInstrs :: [Instr] } 78 | deriving (Eq, Show) 79 | makeLenses ''Segment 80 | 81 | data Bytecode = Bytecode 82 | { _bcSegments :: [Segment] 83 | , _bcTopLevel :: Segment 84 | , _bcTimestamp :: Word32 85 | , _bcVersion :: Version } 86 | deriving (Eq, Show) 87 | makeLenses ''Bytecode 88 | 89 | showBytecode :: Bytecode -> String 90 | showBytecode (Bytecode ss (Segment c s s' i) t v) = intercalate "\n" $ 91 | [ "top level: " 92 | , "\tconstants: " ++ show c 93 | , "\tsymbols: " ++ show s 94 | ] ++ map (('\t':) . showInstr) (zip [0..] i) ++ 95 | [ "\tstructs: " ++ show s' 96 | , "segments: " 97 | ] ++ map (('\t':) . showSeg) (zip [0..] ss) ++ 98 | [ "version: " ++ showVersion v 99 | , "timestamp: " ++ show t 100 | ] 101 | where showInstr (i, instr) = '\t' : show i ++ (replicate (4 - length (show i)) ' ') ++ show instr 102 | showSeg (i, (Segment constants symbols structs instrs)) = 103 | intercalate "\n" $ ["segment " ++ show i] ++ map ("\t\t" ++) 104 | [ "constants: " ++ show constants 105 | , "symbols: " ++ show symbols 106 | , "structs: " ++ show structs 107 | ] ++ map (("\t\t" ++) . showInstr) (zip [0..] instrs) 108 | 109 | hashMD5 :: ByteString -> ByteString 110 | hashMD5 = packUTF8 . show . go . C8.pack . map (chr . fromIntegral) . BS.unpack 111 | where go = hash :: C8.ByteString -> Digest MD5 112 | 113 | packUTF8 :: String -> ByteString 114 | packUTF8 = BS.pack . UTF8.encode 115 | 116 | unpackUTF8 :: ByteString -> String 117 | unpackUTF8 = UTF8.decode . BS.unpack 118 | 119 | prettyPrintCode :: Segment -> IO () 120 | prettyPrintCode (Segment constants symbols structs instrs) = 121 | forM_ (zip [0..] instrs) $ \ (idx, instr) -> do 122 | putStr (show idx ++ " ") 123 | putStr $ replicate (4 - length (show idx)) ' ' ++ (show instr) 124 | case instr of 125 | STORE addr -> putStr (" (" ++ genericIndex symbols addr ++ ")") 126 | LOAD addr -> putStr (" (" ++ genericIndex symbols addr ++ ")") 127 | LOAD_CONST addr -> putStr (" (" ++ show (genericIndex constants addr) ++ ")") 128 | BUILD_STRUCT addr -> putStr (" (" ++ show (genericIndex structs addr) ++ ")") 129 | _ -> return () 130 | putStrLn "" 131 | -------------------------------------------------------------------------------- /src/Language/Snowflake/Optimizer.hs: -------------------------------------------------------------------------------- 1 | module Language.Snowflake.Optimizer where 2 | 3 | -- import Language.Snowflake.Optimizer.Types 4 | -------------------------------------------------------------------------------- /src/Language/Snowflake/Optimizer/Rule.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | 3 | module Language.Snowflake.Optimizer.Rule where 4 | 5 | import Control.Applicative 6 | 7 | import Data.List 8 | 9 | data Rule a = Rule 10 | { _rulePattern :: Pattern a 11 | , _ruleResult :: [a] } 12 | 13 | type ID = Int 14 | 15 | data InstrPattern 16 | = P_NOP 17 | | P_POP 18 | | P_NOT | P_AND | P_OR 19 | | P_ADD | P_SUB | P_MUL | P_DIV | P_POW 20 | | P_POS | P_NEG 21 | | P_LT | P_LE | P_EQ | P_NEQ | P_GE | P_GT 22 | | P_RETURN 23 | | P_IF 24 | | P_CALL ID 25 | | P_BUILD_LIST ID 26 | | P_STORE ID 27 | | P_LOAD ID 28 | | P_LOAD_CONST ID 29 | | P_JUMP ID 30 | | P_ITER ID 31 | deriving (Eq, Show) 32 | 33 | -- class Match p r | p -> r where 34 | -- match :: p a -> [a] -> r a 35 | 36 | data Pattern a 37 | = PureP a 38 | | ManyP (Pattern a) 39 | | OptionalP (Pattern a) 40 | | AlternativeP (Pattern a) (Pattern a) 41 | | SequenceP (Pattern a) (Pattern a) 42 | | NoneP 43 | deriving Functor 44 | 45 | instance Applicative Pattern where 46 | pure = PureP 47 | NoneP <*> px = NoneP 48 | fx <*> NoneP = NoneP 49 | (PureP f) <*> (PureP x) = PureP (f x) 50 | (PureP f) <*> (ManyP x) = ManyP (fmap f x) 51 | (PureP f) <*> (OptionalP x) = OptionalP (fmap f x) 52 | (PureP f) <*> (AlternativeP l r) = AlternativeP (fmap f l) (fmap f r) 53 | (PureP f) <*> (SequenceP x y) = SequenceP (fmap f x) (fmap f y) 54 | (ManyP f) <*> px = ManyP (f <*> px) 55 | (OptionalP f) <*> px = OptionalP (f <*> px) 56 | (AlternativeP f g) <*> px = AlternativeP (f <*> px) (g <*> px) 57 | (SequenceP f g) <*> px = SequenceP (f <*> px) (g <*> px) 58 | 59 | instance Alternative Pattern where 60 | empty = NoneP 61 | (<|>) = AlternativeP 62 | 63 | optional :: Pattern a -> Pattern a 64 | optional = OptionalP 65 | 66 | data Result a 67 | = PureR a 68 | | ManyR [Result a] 69 | | OptionalR (Maybe (Result a)) 70 | | AlternativeR (Either (Result a) (Result a)) 71 | | SequenceR (Result a) (Result a) 72 | | NoneR 73 | 74 | instance Functor Result where 75 | fmap f (PureR x) = PureR (f x) 76 | fmap f (ManyR xs) = ManyR (fmap (fmap f) xs) 77 | fmap f (AlternativeR (Left x)) = AlternativeR (Left $ fmap f x) 78 | fmap f (AlternativeR (Right x)) = AlternativeR (Right $ fmap f x) 79 | fmap f (SequenceR b a) = SequenceR (fmap f b) (fmap f a) 80 | fmap f NoneR = NoneR 81 | 82 | instance Applicative Result where 83 | pure = PureR 84 | NoneR <*> rx = NoneR 85 | fx <*> NoneR = NoneR 86 | (PureR f) <*> (PureR x) = PureR (f x) 87 | (PureR f) <*> (ManyR xs) = ManyR (fmap (fmap f) xs) 88 | (PureR f) <*> (OptionalR Nothing) = OptionalR Nothing 89 | (PureR f) <*> (OptionalR (Just x)) = OptionalR (Just $ fmap f x) 90 | (PureR f) <*> (AlternativeR (Left x)) = AlternativeR (Left $ fmap f x) 91 | (PureR f) <*> (AlternativeR (Right x)) = AlternativeR (Right $ fmap f x) 92 | (PureR f) <*> (SequenceR x y) = SequenceR (fmap f x) (fmap f y) 93 | (ManyR f) <*> rx = ManyR (fmap (<*> rx) f) 94 | (AlternativeR (Left f)) <*> rx = AlternativeR (Left $ f <*> rx) 95 | (AlternativeR (Right f)) <*> rx = AlternativeR (Right $ f <*> rx) 96 | (SequenceR f g) <*> rx = SequenceR (f <*> rx) (g <*> rx) 97 | 98 | match :: Eq a => Pattern a -> [a] -> (Result a, [a]) 99 | match (PureP x) 100 | match (PureP x) (y:ys) 101 | | x == y = (PureR y, ys) 102 | | otherwise = NoneR 103 | match (ManyP p) xs = ManyR (foldr ) 104 | match NoneP xs = NoneR 105 | -------------------------------------------------------------------------------- /src/Language/Snowflake/Options.hs: -------------------------------------------------------------------------------- 1 | module Language.Snowflake.Options 2 | ( runSnowflake 3 | , module Exports 4 | ) where 5 | 6 | import Language.Snowflake.Options.Parser as Exports 7 | import Language.Snowflake.Options.Command as Exports 8 | import Language.Snowflake.Options.Types as Exports 9 | 10 | import Options.Applicative 11 | 12 | runSnowflake :: IO () 13 | runSnowflake = execParser (info snowflakeOptions fullDesc) >>= runCommand 14 | -------------------------------------------------------------------------------- /src/Language/Snowflake/Options/Command.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, RecordWildCards #-} 2 | 3 | module Language.Snowflake.Options.Command 4 | ( runCommand 5 | , compile 6 | , execute 7 | ) where 8 | 9 | import Language.Snowflake.Parser 10 | import Language.Snowflake.Typing 11 | import Language.Snowflake.Compiler 12 | import Language.Snowflake.VM 13 | import Language.Snowflake.REPL 14 | import Language.Snowflake.Options.Types 15 | import Language.Snowflake.Builtins 16 | 17 | import Control.Monad (when) 18 | 19 | import qualified Data.ChainMap as Env 20 | 21 | import Data.Time (getCurrentTime, diffUTCTime) 22 | import Data.Version (showVersion) 23 | 24 | import System.FilePath.Posix 25 | 26 | import Text.Parsec 27 | 28 | import Paths_snowflake (version) 29 | 30 | runCommand :: Command -> IO () 31 | runCommand (Compile opts) = compile opts 32 | runCommand (Execute opts) = execute opts 33 | runCommand (String opts) = executeString opts 34 | runCommand (REPL opts) = runREPL (_roFile opts) (_roDebug opts) 35 | runCommand Version = putStrLn (showVersion version) 36 | 37 | execute :: ExecuteOptions -> IO () 38 | execute opts 39 | | takeExtension (_eoFilepath opts) == ".sfc" = executeBytecode opts 40 | | otherwise = executeFile opts 41 | 42 | executeBytecode :: ExecuteOptions -> IO () 43 | executeBytecode ExecuteOptions{..} = do 44 | bytecode <- decodeFromFile _eoFilepath 45 | when _eoShowBytecode (putStrLn $ showBytecode bytecode) 46 | start <- getCurrentTime 47 | runBytecode bytecode (Env.singleMap defaultEnv) (Env.singleMap defaultTypeEnv) _eoDebug 48 | stop <- getCurrentTime 49 | when _eoShowExecTime $ putStrLn ("Execution time: " ++ show (diffUTCTime stop start)) 50 | 51 | executeFile :: ExecuteOptions -> IO () 52 | executeFile ExecuteOptions{..} = do 53 | code <- readFile _eoFilepath 54 | let modInfo = ModuleInfo code _eoFilepath 55 | let mst = parse (program <* eof) _eoFilepath code 56 | case mst of 57 | Right ast -> do 58 | when _eoShowAST (putStrLn $ showAST ast) 59 | case evalTypeCheck ast modInfo (Env.singleMap defaultBindings) (Env.singleMap defaultTypeEnv) of 60 | Left errs -> printErrors modInfo _eoErrorOffset errs 61 | Right cast -> do 62 | bytecode <- execCompiler (compileProgram cast) 63 | when _eoShowBytecode (putStrLn $ showBytecode bytecode) 64 | start <- getCurrentTime 65 | runBytecode bytecode (Env.singleMap defaultEnv) (Env.singleMap defaultTypeEnv) _eoDebug 66 | stop <- getCurrentTime 67 | when _eoShowExecTime $ putStrLn ("Execution time: " ++ show (diffUTCTime stop start)) 68 | return () 69 | Left err -> print err 70 | 71 | executeString :: StringOptions -> IO () 72 | executeString StringOptions{..} = do 73 | let modInfo = ModuleInfo _soString "<>" 74 | case parse (program <* eof) "<>" _soString of 75 | Right ast -> do 76 | when _soShowAST (putStrLn $ showAST ast) 77 | case evalTypeCheck ast modInfo (Env.singleMap defaultBindings) (Env.singleMap defaultTypeEnv) of 78 | Left errs -> printErrors modInfo _soErrorOffset errs 79 | Right cast -> do 80 | bytecode <- execCompiler (compileProgram cast) 81 | when _soShowBytecode (putStrLn $ showBytecode bytecode) 82 | start <- getCurrentTime 83 | runBytecode bytecode (Env.singleMap defaultEnv) (Env.singleMap defaultTypeEnv) _soDebug 84 | stop <- getCurrentTime 85 | when _soShowExecTime $ putStrLn ("Execution time: " ++ show (diffUTCTime stop start)) 86 | return () 87 | Left err -> print err 88 | 89 | compile :: CompileOptions -> IO () 90 | compile CompileOptions{..} = do 91 | src <- readFile _coFilepath 92 | let modInfo = ModuleInfo src _coFilepath 93 | mast = parse (program <* eof) _coFilepath src 94 | case mast of 95 | Right ast -> do 96 | when _coShowAST (putStrLn $ showAST ast) 97 | case evalTypeCheck ast modInfo (Env.singleMap defaultBindings) (Env.singleMap defaultTypeEnv) of 98 | Left errs -> printErrors modInfo _coErrorOffset errs 99 | Right cast -> do 100 | bytecode <- execCompiler (compileProgram cast) 101 | when _coShowBytecode (putStrLn $ showBytecode bytecode) 102 | let outputPath = case _coOutput of 103 | Just p -> p 104 | Nothing -> getDefaultOutputPath _coFilepath 105 | encodeToFile outputPath bytecode 106 | return () 107 | Left err -> print err 108 | 109 | getDefaultOutputPath :: FilePath -> FilePath 110 | getDefaultOutputPath = flip replaceExtension "sfc" 111 | -------------------------------------------------------------------------------- /src/Language/Snowflake/Options/Parser.hs: -------------------------------------------------------------------------------- 1 | module Language.Snowflake.Options.Parser (snowflakeOptions) where 2 | 3 | import Language.Snowflake.Options.Types 4 | 5 | import Options.Applicative 6 | import Data.Semigroup ((<>)) 7 | import Data.Maybe (fromMaybe) 8 | import Text.Read (readMaybe) 9 | 10 | file :: Parser FilePath 11 | file = argument str (metavar "FILE") 12 | 13 | output :: Parser (Maybe FilePath) 14 | output = optional . strOption $ long "output" 15 | <> short 'o' 16 | <> metavar "FILE" 17 | <> help "Write output to FILE" 18 | 19 | string :: Parser String 20 | string = argument str (metavar "STRING") 21 | 22 | optimize :: Parser Bool 23 | optimize = switch $ long "optimize" 24 | <> short 'O' 25 | <> help "Optimize the output bytecode" 26 | 27 | showAST, showBytecode, time, debug :: Parser Bool 28 | showAST = switch $ long "show-ast" 29 | <> help "Show resulting AST" 30 | showBytecode = switch $ long "show-bytecode" 31 | <> help "Show resulting bytecode" 32 | debug = switch $ long "debug" 33 | <> short 'd' 34 | <> help "Enable debug mode" 35 | time = switch $ long "time" 36 | <> short 't' 37 | <> help "Show execution time" 38 | 39 | errorOffset :: Parser Int 40 | errorOffset = opt 41 | where readMaybeInt = maybeReader readMaybe 42 | opt = option readMaybeInt $ long "error-offset" 43 | <> value 2 44 | <> help "Sets the number of displayed lines before and after an erroneous code" 45 | 46 | compileOptions :: Parser CompileOptions 47 | compileOptions = CompileOptions 48 | <$> file 49 | <*> output 50 | <*> showAST 51 | <*> showBytecode 52 | <*> errorOffset 53 | <*> debug 54 | 55 | executeOptions :: Parser ExecuteOptions 56 | executeOptions = ExecuteOptions 57 | <$> file 58 | <*> showAST 59 | <*> showBytecode 60 | <*> time 61 | <*> errorOffset 62 | <*> debug 63 | 64 | stringOptions :: Parser StringOptions 65 | stringOptions = StringOptions 66 | <$> string 67 | <*> showAST 68 | <*> showBytecode 69 | <*> time 70 | <*> errorOffset 71 | <*> debug 72 | 73 | replOptions :: Parser REPLOptions 74 | replOptions = REPLOptions 75 | <$> optional file 76 | <*> debug 77 | 78 | snowflakeOptions :: Parser Command 79 | snowflakeOptions = subparser $ command "compile" (info (Compile <$> compileOptions) (progDesc "Compiles the given file")) 80 | <> command "execute" (info (Execute <$> executeOptions) (progDesc "Executes a Snowflake file")) 81 | <> command "string" (info (String <$> stringOptions) (progDesc "Executes a piece of Snowflake code")) 82 | <> command "repl" (info (REPL <$> replOptions) (progDesc "Starts an interactive REPL session")) 83 | <> command "version" (info (pure Version) (progDesc "Show Snowflake version")) 84 | -------------------------------------------------------------------------------- /src/Language/Snowflake/Options/Types.hs: -------------------------------------------------------------------------------- 1 | module Language.Snowflake.Options.Types where 2 | 3 | data Command 4 | = Compile CompileOptions 5 | | Execute ExecuteOptions 6 | | String StringOptions 7 | | REPL REPLOptions 8 | | Version 9 | 10 | data CompileOptions = CompileOptions 11 | { _coFilepath :: FilePath 12 | , _coOutput :: Maybe FilePath 13 | , _coShowAST :: Bool 14 | , _coShowBytecode :: Bool 15 | , _coErrorOffset :: Int 16 | , _coDebug :: Bool } 17 | 18 | data ExecuteOptions = ExecuteOptions 19 | { _eoFilepath :: FilePath 20 | , _eoShowAST :: Bool 21 | , _eoShowBytecode :: Bool 22 | , _eoShowExecTime :: Bool 23 | , _eoErrorOffset :: Int 24 | , _eoDebug :: Bool } 25 | 26 | data StringOptions = StringOptions 27 | { _soString :: FilePath 28 | , _soShowAST :: Bool 29 | , _soShowBytecode :: Bool 30 | , _soShowExecTime :: Bool 31 | , _soErrorOffset :: Int 32 | , _soDebug :: Bool } 33 | 34 | data REPLOptions = REPLOptions 35 | { _roFile :: Maybe FilePath 36 | , _roDebug :: Bool } 37 | -------------------------------------------------------------------------------- /src/Language/Snowflake/Parser.hs: -------------------------------------------------------------------------------- 1 | module Language.Snowflake.Parser 2 | ( module Exports 3 | , parseString 4 | , parseExpr 5 | , parseRule 6 | , parseFile 7 | , forceRight ) where 8 | 9 | import Language.Snowflake.Parser.AST as Exports 10 | import Language.Snowflake.Parser.Lexer as Exports 11 | import Language.Snowflake.Parser.Rules as Exports 12 | 13 | import Text.Parsec 14 | import Text.Parsec.String 15 | import Text.Parsec.Error 16 | 17 | parseString :: String -> Either ParseError (Program Loc) 18 | parseString = parseRule (program <* eof) 19 | 20 | parseExpr :: String -> Either ParseError (Expr Loc) 21 | parseExpr = parseRule (expr <* eof) 22 | 23 | parseRule :: Parser a -> String -> Either ParseError a 24 | parseRule = flip parse "(string)" . (<* eof) 25 | 26 | parseFile :: String -> IO (Either ParseError (Program Loc)) 27 | parseFile path = parse (program <* eof) path <$> readFile path 28 | 29 | forceRight :: Show a => Either a b -> b 30 | forceRight x = case x of 31 | Right res -> res 32 | Left err -> error (show err) 33 | -------------------------------------------------------------------------------- /src/Language/Snowflake/Parser/AST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | DeriveFunctor 3 | , DeriveFoldable 4 | , DeriveTraversable 5 | , StandaloneDeriving 6 | , TypeFamilies 7 | , TypeSynonymInstances 8 | , PatternSynonyms 9 | , ViewPatterns 10 | , Rank2Types 11 | , TemplateHaskell 12 | , FlexibleInstances 13 | #-} 14 | 15 | module Language.Snowflake.Parser.AST 16 | ( AST(..) 17 | , Name 18 | , IsNode(..), nodeUpdate 19 | , Node(..) 20 | , Decl(..) 21 | , Loc(..) 22 | , ModuleInfo(..) 23 | , Program(..) 24 | , Block(..) 25 | , Instruction(..) 26 | , FnDecl(..) 27 | , TypeDecl(..) 28 | , Param(..) 29 | , TypeParam(..) 30 | , Expr_(..) 31 | , Expr 32 | , TypeExpr_(..) 33 | , TypeExpr 34 | , TypeLiteral(..) 35 | , KindExpr_(..) 36 | , KindExpr 37 | , BinOp(..) 38 | , UnOp(..) 39 | , Literal(..) 40 | , showAST 41 | , terminal, terminalVoid, fromNode 42 | , pattern VarExpr', pattern AttrExpr', pattern BinOpExpr', pattern UnOpExpr', pattern CallExpr', pattern ListExpr', pattern TupleExpr', pattern LitExpr', pattern StructExpr' 43 | , pattern VarExpr, pattern AttrExpr, pattern BinOpExpr, pattern UnOpExpr, pattern CallExpr, pattern ListExpr, pattern TupleExpr, pattern LitExpr, pattern StructExpr 44 | , pattern VarTExpr', pattern ListTExpr', pattern TupleTExpr', pattern FnTExpr', pattern LitTExpr', pattern StructTExpr' 45 | , pattern VarTExpr, pattern ListTExpr, pattern TupleTExpr, pattern FnTExpr, pattern LitTExpr, pattern StructTExpr 46 | , pattern TypeKExpr' 47 | , pattern TypeKExpr 48 | ) where 49 | 50 | import Data.AST 51 | 52 | import Data.Bifunctor 53 | import Data.Functor.Foldable 54 | import Data.Functor.Compose 55 | import Data.Functor.Classes 56 | 57 | import Data.Semigroup 58 | import Data.Int 59 | import Data.List (intercalate) 60 | import qualified Data.Map as Map 61 | 62 | import Text.Parsec (SourcePos) 63 | 64 | type Name = String 65 | 66 | data Loc 67 | = Loc !SourcePos !SourcePos 68 | | VoidLoc 69 | deriving Show 70 | 71 | instance Monoid Loc where 72 | mempty = VoidLoc 73 | VoidLoc `mappend` loc = loc 74 | loc `mappend` VoidLoc = loc 75 | Loc b e `mappend` Loc b' e' = Loc b'' e'' 76 | where b'' = min b b' 77 | e'' = max e e' 78 | 79 | instance Semigroup Loc where 80 | (<>) = mappend 81 | 82 | class IsNode n where 83 | nodeData :: n s -> s 84 | nodeSet :: n s -> s -> n s 85 | 86 | nodeUpdate :: IsNode n => n s -> (s -> s) -> n s 87 | nodeUpdate node f = nodeSet node (f (nodeData node)) 88 | 89 | instance Bifunctor f => IsNode (AST f) where 90 | nodeData = extract 91 | nodeSet (_ :> t) s = s :> t 92 | 93 | instance IsNode (Decl n) where 94 | nodeData (Decl (Node _ s)) = s 95 | nodeSet (Decl (Node n _)) s = Decl (Node n s) 96 | 97 | instance IsNode Program where 98 | nodeData (Program d) = nodeData d 99 | nodeSet (Program d) s = Program (nodeSet d s) 100 | 101 | instance IsNode Param where 102 | nodeData (Param t n) = nodeData t 103 | nodeSet (Param t n) s = Param (nodeSet t s) n 104 | 105 | data Node a n = Node 106 | { _nodeValue :: n 107 | , _nodeData :: a } 108 | deriving (Show, Eq, Functor) 109 | -- 110 | -- newtype AST n s = AST { unAST :: Fix (Compose (Node s) n) } 111 | -- 112 | -- type instance Base (AST n s) = n 113 | -- 114 | -- instance Functor n => Recursive (AST n s) where 115 | -- project (AST t) = AST <$> n 116 | -- where Compose (Node n s) = project t 117 | -- 118 | -- instance Functor n => Functor (AST n) where 119 | -- fmap f (AST (Fix (Compose (Node n s)))) = AST (Fix (Compose (Node n' (f s)))) 120 | -- where n' = fmap (unAST . fmap f . AST) n 121 | 122 | terminal :: Bifunctor n => (forall b. a -> n Loc b) -> Node Loc a -> AST n Loc 123 | terminal constr x = fromNode (constr <$> x) 124 | 125 | terminalVoid :: Bifunctor n => (forall b. a -> n Loc b) -> a -> AST n Loc 126 | terminalVoid constr x = fromNode (Node (constr x) VoidLoc) 127 | 128 | fromNode :: Bifunctor f => Node a (f a (AST f a)) -> AST f a 129 | fromNode (Node n s) = s :> n --AST . Fix . Compose $ Node (fmap unAST n) s 130 | 131 | data ModuleInfo = ModuleInfo 132 | { _modSource :: String 133 | , _modPath :: FilePath } 134 | deriving Show 135 | 136 | newtype Program a = Program (Decl Block a) 137 | 138 | deriving instance Functor Program 139 | 140 | newtype Block a = Block [Decl Instruction a] 141 | 142 | deriving instance Functor Block 143 | 144 | newtype Decl f a = Decl { unDecl :: Node a (f a) } 145 | 146 | instance Functor f => Functor (Decl f) where 147 | fmap f (Decl (Node n s)) = Decl (Node (fmap f n) (f s)) 148 | 149 | data Instruction a 150 | = DeclareInstr (TypeExpr a) Name (Expr a) 151 | | AssignInstr Name (Expr a) 152 | | ReturnInstr (Expr a) 153 | | ExprInstr (Expr a) 154 | | CondInstr (Expr a) (Decl Block a) (Decl Block a) 155 | | WhileInstr (Expr a) (Decl Block a) 156 | | ForInstr Name (Expr a) (Decl Block a) 157 | | FnInstr (FnDecl a) 158 | | TypeInstr (TypeDecl a) 159 | 160 | instance Functor Instruction where 161 | fmap f (DeclareInstr t n v) = DeclareInstr (fmap f t) n (fmap f v) 162 | fmap f (AssignInstr n v) = AssignInstr n (fmap f v) 163 | fmap f (ReturnInstr v) = ReturnInstr (fmap f v) 164 | fmap f (ExprInstr e) = ExprInstr (fmap f e) 165 | fmap f (CondInstr c tr fl) = CondInstr (fmap f c) (fmap f tr) (fmap f fl) 166 | fmap f (WhileInstr c l) = WhileInstr (fmap f c) (fmap f l) 167 | fmap f (ForInstr n i l) = ForInstr n (fmap f i) (fmap f l) 168 | fmap f (FnInstr d) = FnInstr (fmap f d) 169 | fmap f (TypeInstr d) = TypeInstr (fmap f d) 170 | 171 | data FnDecl a = FnDecl Name [TypeParam Loc] [Param a] (TypeExpr a) (Decl Block a) 172 | 173 | instance Functor FnDecl where 174 | fmap f (FnDecl n gs ps r b) = FnDecl n gs (fmap (fmap f) ps) (fmap f r) (fmap f b) 175 | 176 | data TypeDecl a = TypeDecl Name (Map.Map Name (TypeExpr a)) 177 | 178 | instance Functor TypeDecl where 179 | fmap f (TypeDecl n fs) = TypeDecl n (fmap (fmap f) fs) 180 | 181 | data Param a = Param 182 | { _paramType :: TypeExpr a 183 | , _paramName :: Name } 184 | 185 | instance Functor Param where 186 | fmap f (Param t n) = Param (fmap f t) n 187 | 188 | data TypeParam a = TypeParam 189 | { _typeParamKind :: KindExpr a 190 | , _typeParamName :: Name } 191 | 192 | instance Functor TypeParam where 193 | fmap f (TypeParam k n) = TypeParam (fmap f k) n 194 | 195 | instance Show (Param a) where 196 | show (Param t n) = "Param " ++ paren (show t) ++ " " ++ show n 197 | 198 | instance Show (TypeParam a) where 199 | show (TypeParam k n) = "TypeParam " ++ paren (show k) ++ " " ++ show n 200 | 201 | data Expr_ a expr 202 | = VarExpr_ Name 203 | | AttrExpr_ expr Name 204 | | BinOpExpr_ BinOp expr expr 205 | | UnOpExpr_ UnOp expr 206 | | CallExpr_ expr [TypeExpr a] [expr] 207 | | ListExpr_ [expr] 208 | | TupleExpr_ [expr] 209 | | LitExpr_ Literal 210 | | StructExpr_ (Map.Map Name expr) 211 | --deriving (Functor, Foldable, Traversable) 212 | 213 | instance Bifunctor Expr_ where 214 | bimap f g (VarExpr_ n) = VarExpr_ n 215 | bimap f g (AttrExpr_ x a) = AttrExpr_ (g x) a 216 | bimap f g (BinOpExpr_ op x y) = BinOpExpr_ op (g x) (g y) 217 | bimap f g (UnOpExpr_ op x) = UnOpExpr_ op (g x) 218 | bimap f g (CallExpr_ fx gs xs) = CallExpr_ (g fx) (fmap (fmap f) gs) (fmap g xs) 219 | bimap f g (ListExpr_ xs) = ListExpr_ (fmap g xs) 220 | bimap f g (TupleExpr_ xs) = TupleExpr_ (fmap g xs) 221 | bimap f g (LitExpr_ lit) = LitExpr_ lit 222 | bimap f g (StructExpr_ as) = StructExpr_ (fmap g as) 223 | 224 | type Expr a = AST Expr_ a 225 | 226 | -- State patterns 227 | pattern VarExpr' :: Name -> a -> Expr a 228 | pattern VarExpr' v s <- s :> VarExpr_ v 229 | 230 | pattern AttrExpr' :: Expr a -> Name -> a -> Expr a 231 | pattern AttrExpr' x a s <- s :> AttrExpr_ x a 232 | 233 | pattern BinOpExpr' :: BinOp -> Expr a -> Expr a -> a -> Expr a 234 | pattern BinOpExpr' op x y s <- s :> BinOpExpr_ op x y 235 | 236 | pattern UnOpExpr' :: UnOp -> Expr a -> a -> Expr a 237 | pattern UnOpExpr' op x s <- s :> UnOpExpr_ op x 238 | 239 | pattern CallExpr' :: Expr a -> [TypeExpr a] -> [Expr a] -> a -> Expr a 240 | pattern CallExpr' f gs xs s <- s :> CallExpr_ f gs xs 241 | 242 | pattern ListExpr' :: [Expr a] -> a -> Expr a 243 | pattern ListExpr' xs s <- s :> ListExpr_ xs 244 | 245 | pattern TupleExpr' :: [Expr a] -> a -> Expr a 246 | pattern TupleExpr' xs s <- s :> TupleExpr_ xs 247 | 248 | pattern LitExpr' :: Literal -> a -> Expr a 249 | pattern LitExpr' lit s <- s :> LitExpr_ lit 250 | 251 | pattern StructExpr' :: Map.Map Name (Expr a) -> a -> Expr a 252 | pattern StructExpr' assocs s <- s :> StructExpr_ assocs 253 | 254 | -- Pure patterns 255 | pattern VarExpr :: Name -> Expr a 256 | pattern VarExpr v <- VarExpr' v _ 257 | 258 | pattern AttrExpr :: Expr a -> Name -> Expr a 259 | pattern AttrExpr x a <- AttrExpr' x a _ 260 | 261 | pattern BinOpExpr :: BinOp -> Expr a -> Expr a -> Expr a 262 | pattern BinOpExpr op x y <- BinOpExpr' op x y _ 263 | 264 | pattern UnOpExpr :: UnOp -> Expr a -> Expr a 265 | pattern UnOpExpr op x <- UnOpExpr' op x _ 266 | 267 | pattern CallExpr :: Expr a -> [TypeExpr a] -> [Expr a] -> Expr a 268 | pattern CallExpr f gs xs <- CallExpr' f gs xs _ 269 | 270 | pattern ListExpr :: [Expr a] -> Expr a 271 | pattern ListExpr xs <- ListExpr' xs _ 272 | 273 | pattern TupleExpr :: [Expr a] -> Expr a 274 | pattern TupleExpr xs <- TupleExpr' xs _ 275 | 276 | pattern LitExpr :: Literal -> Expr a 277 | pattern LitExpr lit <- LitExpr' lit _ 278 | 279 | pattern StructExpr :: Map.Map Name (Expr a) -> Expr a 280 | pattern StructExpr assocs <- StructExpr' assocs _ 281 | 282 | instance {-# OVERLAPS #-} Show (Expr a) where 283 | show = showExpr 284 | 285 | data TypeExpr_ a expr 286 | = VarTExpr_ Name 287 | | ListTExpr_ expr 288 | | TupleTExpr_ [expr] 289 | | FnTExpr_ [TypeParam Loc] [expr] expr 290 | | LitTExpr_ TypeLiteral 291 | | StructTExpr_ (Map.Map Name expr) 292 | --deriving (Functor, Foldable, Traversable) 293 | 294 | instance Bifunctor TypeExpr_ where 295 | bimap f g (VarTExpr_ v) = VarTExpr_ v 296 | bimap f g (ListTExpr_ t) = ListTExpr_ (g t) 297 | bimap f g (TupleTExpr_ ts) = TupleTExpr_ (fmap g ts) 298 | bimap f g (FnTExpr_ gs ps r) = FnTExpr_ gs (fmap g ps) (g r) 299 | bimap f g (LitTExpr_ l) = LitTExpr_ l 300 | bimap f g (StructTExpr_ fs) = StructTExpr_ (fmap g fs) 301 | 302 | type TypeExpr a = AST TypeExpr_ a 303 | 304 | -- State patterns 305 | pattern VarTExpr' :: Name -> a -> TypeExpr a 306 | pattern VarTExpr' v s <- s :> VarTExpr_ v 307 | 308 | pattern ListTExpr' :: TypeExpr a -> a -> TypeExpr a 309 | pattern ListTExpr' x s <- s :> ListTExpr_ x 310 | 311 | pattern TupleTExpr' :: [TypeExpr a] -> a -> TypeExpr a 312 | pattern TupleTExpr' xs s <- s :> TupleTExpr_ xs 313 | 314 | pattern FnTExpr' :: [TypeParam Loc] -> [TypeExpr a] -> TypeExpr a -> a -> TypeExpr a 315 | pattern FnTExpr' tps xs ret s <- s :> FnTExpr_ tps xs ret 316 | 317 | pattern LitTExpr' :: TypeLiteral -> a -> TypeExpr a 318 | pattern LitTExpr' lit s <- s :> LitTExpr_ lit 319 | 320 | pattern StructTExpr' :: Map.Map Name (TypeExpr a) -> a -> TypeExpr a 321 | pattern StructTExpr' fields s <- s :> StructTExpr_ fields 322 | 323 | -- Pure patterns 324 | pattern VarTExpr :: Name -> TypeExpr a 325 | pattern VarTExpr v <- VarTExpr' v _ 326 | 327 | pattern ListTExpr :: TypeExpr a -> TypeExpr a 328 | pattern ListTExpr x <- ListTExpr' x _ 329 | 330 | pattern TupleTExpr :: [TypeExpr a] -> TypeExpr a 331 | pattern TupleTExpr xs <- TupleTExpr' xs _ 332 | 333 | pattern FnTExpr :: [TypeParam Loc] -> [TypeExpr a] -> TypeExpr a -> TypeExpr a 334 | pattern FnTExpr tps xs ret <- FnTExpr' tps xs ret _ 335 | 336 | pattern LitTExpr :: TypeLiteral -> TypeExpr a 337 | pattern LitTExpr lit <- LitTExpr' lit _ 338 | 339 | pattern StructTExpr :: Map.Map Name (TypeExpr a) -> TypeExpr a 340 | pattern StructTExpr fields <- StructTExpr' fields _ 341 | 342 | instance {-# OVERLAPS #-} Show (TypeExpr a) where 343 | show = showTypeExpr 344 | 345 | data KindExpr_ a expr 346 | = TypeKExpr_ 347 | 348 | instance Bifunctor KindExpr_ where 349 | bimap f g TypeKExpr_ = TypeKExpr_ 350 | 351 | type KindExpr a = AST KindExpr_ a 352 | 353 | pattern TypeKExpr' :: a -> KindExpr a 354 | pattern TypeKExpr' s <- s :> TypeKExpr_ 355 | 356 | pattern TypeKExpr :: KindExpr a 357 | pattern TypeKExpr <- TypeKExpr' _ 358 | 359 | instance {-# OVERLAPS #-} Show (KindExpr a) where 360 | show = showKindExpr 361 | 362 | data TypeLiteral 363 | = IntTLit 364 | | FloatTLit 365 | | BoolTLit 366 | | StrTLit 367 | | NoneTLit 368 | deriving (Eq, Show) 369 | 370 | data BinOp 371 | = PowOp 372 | | MulOp 373 | | DivOp 374 | | AddOp 375 | | SubOp 376 | | AndOp 377 | | OrOp 378 | | EQOp | NEQOp 379 | | GTOp | GEOp 380 | | LTOp | LEOp 381 | deriving (Eq, Show) 382 | 383 | data UnOp 384 | = PosOp 385 | | NegOp 386 | | NotOp 387 | deriving (Eq, Show) 388 | 389 | data Literal 390 | = IntLit Int64 391 | | FloatLit Float 392 | | BoolLit Bool 393 | | StrLit String 394 | | NoneLit 395 | deriving (Eq, Show) 396 | 397 | indent :: Int -> String -> String 398 | indent n s = concat (replicate n " ") ++ s 399 | 400 | surround :: String -> String -> String -> String 401 | surround b a s = b ++ s ++ a 402 | 403 | paren :: String -> String 404 | paren = surround "(" ")" 405 | 406 | brack :: String -> String 407 | brack = surround "[" "]" 408 | 409 | angle :: String -> String 410 | angle = surround "<" ">" 411 | 412 | showAST :: Program a -> String 413 | showAST (Program instrs) = showBlock instrs 414 | 415 | showBlock :: Decl Block a -> String 416 | showBlock block = showBlockWithIndent block 0 417 | 418 | showBlockWithIndent :: Decl Block a -> Int -> String 419 | showBlockWithIndent (Decl (Node (Block block) _)) n = intercalate "\n" $ map (indent n . flip showInstrWithIndent n . _nodeValue . unDecl) block 420 | 421 | showInstrWithIndent :: Instruction a -> Int -> String 422 | showInstrWithIndent i n = indent n $ case i of 423 | (DeclareInstr typ name val) -> "Declare " ++ paren (show typ) ++ " " ++ show name ++ " " ++ paren (show val) 424 | (AssignInstr name val) -> "Assign " ++ show name ++ " " ++ paren (show val) 425 | (ReturnInstr val) -> "Return " ++ paren (show val) 426 | (ExprInstr expr) -> "Expr " ++ paren (show expr) 427 | (CondInstr cond tr fl) -> "Cond " ++ paren (show cond) 428 | `endl` indent (n+1) "true:" 429 | `endl` showBlockWithIndent tr (n+2) 430 | `endl` indent (n+1) "false:" 431 | `endl` showBlockWithIndent fl (n+2) 432 | (WhileInstr cond loop) -> "While " ++ paren (show cond) 433 | `endl` showBlockWithIndent loop (n+1) 434 | (ForInstr var iter loop) -> "For " ++ show var ++ " in " ++ paren (show iter) 435 | `endl` showBlockWithIndent loop (n+1) 436 | (FnInstr (FnDecl name tparams params ret body)) -> "Function " ++ show name 437 | `endl` indent 1 ("type params: " ++ show tparams) 438 | `endl` indent 1 ("params: " ++ paren (intercalate ", " (map show params))) 439 | `endl` indent 1 ("returns: " ++ show ret) 440 | `endl` indent 1 "body:" 441 | `endl` showBlockWithIndent body 1 442 | (TypeInstr (TypeDecl name fields)) -> "Type " ++ show name 443 | `endl` indent 1 ("fields: " ++ paren (show fields)) 444 | 445 | showExpr :: Expr a -> String 446 | showExpr (VarExpr n) = "Var " ++ show n 447 | showExpr (AttrExpr x a) = "Attr " ++ show x ++ " " ++ show a 448 | showExpr (BinOpExpr op x y) = "BinOp " ++ show op ++ " " ++ paren (show x) ++ " " ++ paren (show y) 449 | showExpr (UnOpExpr op x) = "UnOp " ++ show op ++ " " ++ paren (show x) 450 | showExpr (CallExpr f [] args) = "Call " ++ paren (show f) ++ " " ++ brack (intercalate ", " (map show args)) 451 | showExpr (CallExpr f gs args) = "Call " ++ paren (show f) ++ angle (intercalate ", " (map showTypeExpr gs)) ++ " " ++ brack (intercalate ", " (map show args)) 452 | showExpr (ListExpr xs) = "List " ++ brack (intercalate ", " (map show xs)) 453 | showExpr (TupleExpr xs) = "Tuple " ++ paren (intercalate ", " (map show xs)) 454 | showExpr (LitExpr l) = "Lit " ++ paren (show l) 455 | showExpr (StructExpr assocs) = "Struct " ++ paren (show assocs) 456 | 457 | showTypeExpr :: TypeExpr a -> String 458 | showTypeExpr (VarTExpr v) = "Var " ++ show v 459 | showTypeExpr (ListTExpr t) = "List " ++ brack (show t) 460 | showTypeExpr (TupleTExpr ts) = "Tuple " ++ paren (intercalate ", " (map show ts)) 461 | showTypeExpr (FnTExpr [] ps r) = "Fn " ++ paren (intercalate ", " (map show ps)) ++ " " ++ show r 462 | showTypeExpr (FnTExpr tps ps r) = "Fn " ++ angle (intercalate ", " (map showTypeParam tps)) ++ paren (intercalate ", " (map show ps)) ++ " " ++ show r 463 | where showTypeParam (TypeParam k n) = show k ++ " " ++ n 464 | showTypeExpr (LitTExpr l) = "Lit " ++ show l 465 | showTypeExpr (StructTExpr fields) = "Struct " ++ paren (show fields) 466 | 467 | showKindExpr :: KindExpr a -> String 468 | showKindExpr TypeKExpr = "Type" 469 | 470 | infixl 2 `endl` 471 | 472 | endl :: String -> String -> String 473 | s1 `endl` s2 = s1 ++ "\n" ++ s2 474 | -------------------------------------------------------------------------------- /src/Language/Snowflake/Parser/Lexer.hs: -------------------------------------------------------------------------------- 1 | module Language.Snowflake.Parser.Lexer where 2 | 3 | import Text.Parsec 4 | import Text.Parsec.String (Parser) 5 | import Text.Parsec.Language (emptyDef, LanguageDef) 6 | import Text.Parsec.Token (makeTokenParser, TokenParser, GenLanguageDef(..)) 7 | import qualified Text.Parsec.Token as Token 8 | 9 | language :: LanguageDef () 10 | language = emptyDef 11 | { commentStart = "/*" 12 | , commentEnd = "*/" 13 | , commentLine = "//" 14 | , nestedComments = True 15 | , identStart = letter 16 | , identLetter = alphaNum 17 | , reservedNames = 18 | [ "fn", "type", "return" 19 | , "if", "else", "while", "for", "in" 20 | , "true", "false", "none" 21 | , "int", "float", "bool", "str" 22 | , "not", "and", "or" ] 23 | , reservedOpNames = 24 | [ "->" 25 | , "=", ";" 26 | , "+", "-", "*", "/", "^" 27 | , "<", "<=", "==", "!=", ">=", ">" ] 28 | , caseSensitive = True } 29 | 30 | lexer :: TokenParser () 31 | lexer = makeTokenParser language 32 | 33 | 34 | integer :: Parser Integer 35 | integer = Token.integer lexer 36 | 37 | float :: Parser Double 38 | float = Token.float lexer 39 | 40 | stringLiteral :: Parser String 41 | stringLiteral = Token.stringLiteral lexer 42 | 43 | parens :: Parser a -> Parser a 44 | parens = Token.parens lexer 45 | 46 | angles :: Parser a -> Parser a 47 | angles = Token.angles lexer 48 | 49 | braces :: Parser a -> Parser a 50 | braces = Token.braces lexer 51 | 52 | brackets :: Parser a -> Parser a 53 | brackets = Token.brackets lexer 54 | 55 | commaSep :: Parser a -> Parser [a] 56 | commaSep = Token.commaSep lexer 57 | 58 | commaSep1 :: Parser a -> Parser [a] 59 | commaSep1 = Token.commaSep lexer 60 | 61 | semi :: Parser () 62 | semi = Token.semi lexer >> return () 63 | 64 | identifier :: Parser String 65 | identifier = Token.identifier lexer "identifier" 66 | 67 | operator :: Parser String 68 | operator = Token.operator lexer "operator" 69 | 70 | reserved :: String -> Parser () 71 | reserved = Token.reserved lexer 72 | 73 | reservedOp :: String -> Parser () 74 | reservedOp = Token.reservedOp lexer 75 | 76 | lexeme :: Parser a -> Parser a 77 | lexeme = Token.lexeme lexer 78 | 79 | symbol :: String -> Parser String 80 | symbol = Token.symbol lexer 81 | -------------------------------------------------------------------------------- /src/Language/Snowflake/Parser/Rules.hs: -------------------------------------------------------------------------------- 1 | module Language.Snowflake.Parser.Rules 2 | ( loc 3 | , program 4 | , block 5 | , fnDecl 6 | , instruction, assignInstr, returnInstr, exprInstr, condInstr, whileInstr, forInstr, fnInstr 7 | , expr, term, varExpr, callExpr, listExpr, tupleExpr, litExpr 8 | , typeExpr, varTExpr, listTExpr, tupleTExpr, fnTExpr, litTExpr 9 | , typeLiteral 10 | , literal, intLit, boolLit 11 | , kindExpr, typeKExpr) where 12 | 13 | import Language.Snowflake.Parser.AST 14 | import Language.Snowflake.Parser.Lexer 15 | 16 | import Data.AST 17 | import Data.Bifunctor 18 | 19 | import Control.Applicative ((<$>), (<*>)) 20 | import Data.Functor.Foldable 21 | import Data.Functor.Compose 22 | import Data.Functor.Identity (Identity) 23 | 24 | import qualified Data.Map as Map 25 | 26 | import Text.Parsec as P 27 | import Text.Parsec.Expr 28 | import Text.Parsec.String 29 | 30 | import Data.Semigroup ((<>)) 31 | 32 | loc :: Parser a -> Parser (Node Loc a) 33 | loc p = do 34 | start <- getPosition 35 | x <- p 36 | stop <- getPosition 37 | return $ Node x (Loc start stop) 38 | 39 | decl :: Parser (n Loc) -> Parser (Decl n Loc) 40 | decl p = Decl <$> loc p 41 | 42 | ast :: Bifunctor n => Parser (Node s (n s (AST n s))) -> Parser (AST n s) 43 | ast = fmap fromNode 44 | 45 | program :: Parser (Program Loc) 46 | program = Program <$> decl (Block <$> many instruction) 47 | 48 | block :: Parser (Decl Block Loc) 49 | block = decl $ (Block <$> (try (fmap return instruction) 50 | <|> braces (many instruction) 51 | "block")) 52 | 53 | fnDecl :: Parser (FnDecl Loc) 54 | fnDecl = do 55 | reserved "fn" 56 | fnName <- identifier 57 | fnTParams <- angles (commaSep1 typeParam) <|> pure [] 58 | fnParams <- parens (commaSep param) 59 | pos <- getPosition 60 | fnRetType <- try (reservedOp "->" >> typeExpr) <|> pure (terminalVoid LitTExpr_ NoneTLit) 61 | fnBlock <- block 62 | return (FnDecl fnName fnTParams fnParams fnRetType fnBlock) 63 | 64 | typeDecl :: Parser (TypeDecl Loc) 65 | typeDecl = do 66 | reserved "type" 67 | typeName <- identifier 68 | typeFields <- braces (Map.fromList <$> many1 field) 69 | return (TypeDecl typeName typeFields) 70 | 71 | field :: Parser (Name, TypeExpr Loc) 72 | field = do 73 | t <- typeExpr 74 | n <- identifier 75 | semi 76 | return (n, t) 77 | 78 | 79 | param :: Parser (Param Loc) 80 | param = Param <$> lexeme typeExpr <*> identifier 81 | 82 | typeParam :: Parser (TypeParam Loc) 83 | typeParam = TypeParam <$> lexeme kindExpr <*> identifier 84 | 85 | instruction, declareInstr, assignInstr, returnInstr, exprInstr, condInstr, whileInstr, forInstr, fnInstr, typeInstr :: Parser (Decl Instruction Loc) 86 | instruction = try fnInstr 87 | <|> try typeInstr 88 | <|> try declareInstr 89 | <|> try assignInstr 90 | <|> try returnInstr 91 | <|> try condInstr 92 | <|> try whileInstr 93 | <|> try forInstr 94 | <|> exprInstr 95 | "instruction" 96 | 97 | declareInstr = decl $ do 98 | typ <- typeExpr 99 | name <- identifier 100 | reservedOp "=" 101 | value <- lexeme expr 102 | semi 103 | return $ DeclareInstr typ name value 104 | 105 | assignInstr = decl $ do 106 | name <- identifier 107 | reservedOp "=" 108 | value <- lexeme expr 109 | semi 110 | return $ AssignInstr name value 111 | 112 | returnInstr = decl $ reserved "return" >> ReturnInstr <$> (expr <* semi) 113 | 114 | exprInstr = decl $ ExprInstr <$> (expr <* semi) 115 | 116 | condInstr = decl $ do 117 | reserved "if" 118 | cond <- parens expr 119 | tr <- block 120 | fl <- try (reserved "else" >> block) <|> pure (Decl (Node (Block []) VoidLoc)) 121 | return $ CondInstr cond tr fl 122 | 123 | whileInstr = decl $ reserved "while" >> WhileInstr <$> parens expr <*> block 124 | 125 | forInstr = decl $ do 126 | reserved "for" 127 | var <- identifier 128 | reserved "in" 129 | iter <- lexeme expr 130 | loop <- block 131 | return $ ForInstr var iter loop 132 | 133 | fnInstr = decl $ FnInstr <$> fnDecl 134 | 135 | typeInstr = decl $ TypeInstr <$> typeDecl 136 | 137 | unary :: String -> UnOp -> Operator String () Identity (Expr Loc) 138 | binary s op assoc = flip Infix assoc $ do 139 | reservedOp s 140 | return $ \ x y -> fromNode $ Node (BinOpExpr_ op x y) (extract x <> extract y) 141 | --unary s op = Prefix (loc (reservedOp s) >>= \ (Loc _ sp) -> return (\ x -> Loc (UnOpExpr op (Loc x sp)) sp)) -- (loc (reservedOp s) >>= return . Loc (UnOpExpr op) . _locSpan) 142 | unary s op = Prefix $ do 143 | Node _ l <- loc (reservedOp s) 144 | return $ \ x -> fromNode $ Node (UnOpExpr_ op x) (l <> extract x) 145 | 146 | attrOp :: Operator String () Identity (Expr Loc) 147 | attrOp = Postfix $ do 148 | reservedOp "." 149 | Node attr l <- loc identifier 150 | return $ \ x -> fromNode $ Node (AttrExpr_ x attr) (l <> extract x) 151 | 152 | opTable = [ [ attrOp ] 153 | , [ binary "^" PowOp AssocRight ] 154 | , [ binary "*" MulOp AssocLeft 155 | , binary "/" DivOp AssocLeft ] 156 | , [ binary "+" AddOp AssocLeft 157 | , binary "-" SubOp AssocLeft ] 158 | , [ unary "+" PosOp 159 | , unary "-" NegOp ] 160 | , [ binary "<" LTOp AssocNone 161 | , binary "<=" LEOp AssocNone 162 | , binary ">" GTOp AssocNone 163 | , binary ">=" GEOp AssocNone 164 | , binary "==" EQOp AssocNone 165 | , binary "!=" NEQOp AssocNone ] 166 | , [ binary "and" AndOp AssocRight ] 167 | , [ binary "or" OrOp AssocRight ] 168 | , [ unary "not" NotOp ] 169 | ] 170 | 171 | expr :: Parser (Expr Loc) 172 | term, varExpr, callExpr, listExpr, tupleExpr, structExpr, litExpr :: Parser (Expr Loc) 173 | expr = buildExpressionParser opTable term 174 | 175 | term = try callExpr 176 | <|> try litExpr 177 | <|> try listExpr 178 | <|> try tupleExpr 179 | <|> try structExpr 180 | <|> try (parens expr) 181 | <|> varExpr 182 | "expression" 183 | 184 | varExpr = terminal VarExpr_ <$> loc identifier 185 | callExpr = do 186 | Node fn l <- loc identifier 187 | generics <- angles (commaSep1 typeExpr) <|> pure [] 188 | Node args l' <- loc $ parens (commaSep expr) 189 | return . fromNode $ Node (CallExpr_ (terminal VarExpr_ (Node fn l)) generics args) (l <> l') 190 | listExpr = fromNode . fmap ListExpr_ <$> loc (brackets (commaSep expr)) 191 | tupleExpr = fromNode . fmap TupleExpr_ <$> loc (parens (commaSep expr)) 192 | litExpr = terminal LitExpr_ <$> loc literal 193 | structExpr = do 194 | Node assocs l <- loc $ braces (Map.fromList <$> commaSep1 assoc) 195 | return . fromNode $ Node (StructExpr_ assocs) l 196 | 197 | assoc :: Parser (Name, Expr Loc) 198 | assoc = do 199 | n <- identifier 200 | reservedOp "=" 201 | v <- expr 202 | return (n, v) 203 | 204 | literal, intLit, floatLit, boolLit, strLit, noneLit :: Parser Literal 205 | literal = try floatLit 206 | <|> try intLit 207 | <|> try strLit 208 | <|> boolLit 209 | <|> noneLit 210 | "literal" 211 | 212 | intLit = IntLit . fromInteger <$> integer 213 | floatLit = FloatLit . realToFrac <$> float 214 | boolLit = BoolLit <$> ((reserved "true" >> return True) <|> (reserved "false" >> return False)) 215 | strLit = StrLit <$> stringLiteral 216 | noneLit = reserved "none" >> return NoneLit 217 | 218 | typeExpr, varTExpr, listTExpr, tupleTExpr, fnTExpr, structTExpr, litTExpr :: Parser (TypeExpr Loc) 219 | typeExpr = try fnTExpr 220 | <|> try litTExpr 221 | <|> try listTExpr 222 | <|> try tupleTExpr 223 | <|> try structTExpr 224 | <|> parens typeExpr 225 | <|> varTExpr 226 | "type expression" 227 | 228 | varTExpr = terminal VarTExpr_ <$> loc identifier 229 | listTExpr = fromNode . fmap ListTExpr_ <$> loc (brackets typeExpr) 230 | tupleTExpr = fromNode . fmap TupleTExpr_ <$> loc (parens (commaSep typeExpr)) 231 | fnTExpr = do 232 | Node _ l <- loc $ reserved "fn" 233 | typeParams <- angles (commaSep1 typeParam) <|> pure [] 234 | paramTypes <- parens (many typeExpr) 235 | reservedOp "->" 236 | retType <- typeExpr 237 | return . fromNode $ Node (FnTExpr_ typeParams paramTypes retType) (l <> extract retType) 238 | litTExpr = terminal LitTExpr_ <$> loc typeLiteral 239 | structTExpr = do 240 | Node fields l <- loc $ Map.fromList <$> braces (many1 field) 241 | return . fromNode $ Node (StructTExpr_ fields) l 242 | 243 | typeLiteral :: Parser TypeLiteral 244 | typeLiteral = try (reserved "int" >> return IntTLit) 245 | <|> try (reserved "float" >> return FloatTLit) 246 | <|> try (reserved "bool" >> return BoolTLit) 247 | <|> try (reserved "str" >> return StrTLit) 248 | <|> try (reserved "none" >> return NoneTLit) 249 | "type literal" 250 | 251 | kindExpr, typeKExpr :: Parser (KindExpr Loc) 252 | kindExpr = typeKExpr 253 | "kind expression" 254 | 255 | typeKExpr = do 256 | Node _ l <- loc (reserved "Type") 257 | return . fromNode $ Node TypeKExpr_ l 258 | -------------------------------------------------------------------------------- /src/Language/Snowflake/REPL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | RecordWildCards 3 | , LambdaCase 4 | #-} 5 | 6 | module Language.Snowflake.REPL where 7 | 8 | import Language.Snowflake.Parser 9 | import Language.Snowflake.Typing 10 | import Language.Snowflake.Compiler 11 | import Language.Snowflake.REPL.Parser 12 | import Language.Snowflake.REPL.Types 13 | import Language.Snowflake.VM 14 | import Language.Snowflake.Builtins 15 | 16 | import qualified Data.ChainMap as Env 17 | 18 | import Control.Lens 19 | import Control.Arrow ((&&&)) 20 | import Control.Monad.State 21 | import Control.Monad.Except 22 | 23 | import Text.Parsec 24 | 25 | import Data.Version 26 | 27 | import System.Console.Haskeline 28 | 29 | import Paths_snowflake (version) 30 | 31 | loopREPL :: REPL () 32 | loopREPL = do 33 | fmap parseREPLInput <$> getInputLine "> " >>= \case 34 | Just (Right input) -> runREPLInput input `catchError` (outputStrLn . show) 35 | Just (Left err) -> outputStrLn (show err) 36 | Nothing -> outputStrLn "Unable to parse REPL input" 37 | continue <- lift $ gets _replRunning 38 | lift $ replLine += 1 39 | if continue then 40 | loopREPL 41 | else 42 | return () 43 | 44 | incNodeLocLines :: IsNode n => n Loc -> Line -> n Loc 45 | incNodeLocLines node offset = nodeUpdate node incLocLines 46 | where incLocLines VoidLoc = VoidLoc 47 | incLocLines (Loc start stop) = Loc (incSourceLine start offset) (incSourceLine stop offset) 48 | 49 | updateNodeLineNo :: IsNode n => n Loc -> REPL (n Loc) 50 | updateNodeLineNo node = do 51 | offset <- lift $ gets _replLine 52 | return (incNodeLocLines node 0) 53 | 54 | bindVar :: Name -> Type -> REPL () 55 | bindVar name typ = lift $ replBindings %= Env.insert name typ 56 | 57 | runREPLInput :: REPLInput -> REPL () 58 | runREPLInput (Instr (instr', src)) = do 59 | instr <- updateNodeLineNo instr' 60 | let modInfo = ModuleInfo src "<>" 61 | typeEnv <- lift . lift $ gets _vmTypeEnv 62 | bindings <- lift (gets _replBindings) 63 | case runTypeCheck instr modInfo bindings typeEnv of 64 | Right (cinstr, tc) -> do 65 | VMState{..} <- lift (lift get) 66 | let bc = Bytecode _vmSegments (Segment _vmConstants _vmSymbols _vmStructs []) 0 version 67 | Bytecode ss seg' _ _ = execState (compileInstr cinstr) bc 68 | lift . lift $ applySegment seg' 69 | lift . lift $ vmSegments .= ss 70 | lift $ replBindings .= _tcBindings tc 71 | Left errs -> printTypeCheckErrors modInfo errs 72 | runREPLInput (Expr (expr, src)) = do 73 | let modInfo = ModuleInfo src "<>" 74 | typeEnv <- lift . lift $ gets _vmTypeEnv 75 | bindings <- lift (gets _replBindings) 76 | case runTypeCheck expr modInfo bindings typeEnv of 77 | Right (cexpr, tc) -> do 78 | VMState{..} <- lift (lift get) 79 | let seg = Segment _vmConstants _vmSymbols _vmStructs [] 80 | Segment c s ss i = execState (compileExpr cexpr) seg 81 | seg' = Segment c s ss (i ++ [RETURN]) 82 | val <- lift . lift $ applySegment seg' 83 | outputStrLn (show val) 84 | Left errs -> printTypeCheckErrors modInfo errs 85 | runREPLInput (Command c) = runREPLCommand c 86 | runREPLInput NoInput = return () 87 | 88 | applySegment :: Segment -> VM Value 89 | applySegment (Segment c s ss i) = do 90 | vmConstants .= c 91 | vmSymbols .= s 92 | vmStructs .= ss 93 | vmInstrs .= i 94 | vmInstrIndex .= 0 95 | r <- runVM 96 | vmInstrs .= [] 97 | vmInstrIndex .= 0 98 | return r 99 | 100 | printTypeCheckErrors :: ModuleInfo -> [TypeCheckError] -> REPL () 101 | printTypeCheckErrors modInfo errs = do 102 | offset <- lift (gets _replErrorOffset) 103 | liftIO $ printErrors modInfo offset errs 104 | 105 | runREPLCommand :: REPLCommand -> REPL () 106 | runREPLCommand (Type (expr, src)) = do 107 | let modInfo = ModuleInfo src "<>" 108 | typeEnv <- lift . lift $ gets _vmTypeEnv 109 | bindings <- lift (gets _replBindings) 110 | case evalTypeCheck expr modInfo bindings typeEnv of 111 | Right cexpr -> outputStrLn (showType (eval cexpr)) 112 | Left errs -> printTypeCheckErrors modInfo errs 113 | runREPLCommand (Load path) = do 114 | outputStrLn $ "Loading " ++ path ++ "..." 115 | code <- liftIO (readFile path) 116 | let modInfo = ModuleInfo code path 117 | let mst = parse (program <* eof) path code 118 | st@VMState{..} <- lift (lift get) 119 | bindings <- lift (gets _replBindings) 120 | case mst of 121 | Right ast -> case runTypeCheck ast modInfo bindings _vmTypeEnv of 122 | Left errs -> printTypeCheckErrors modInfo errs 123 | Right (cast, tc) -> do 124 | let initCompilerState = Bytecode 125 | { _bcSegments = _vmSegments 126 | , _bcTopLevel = Segment _vmConstants _vmSymbols _vmStructs [] 127 | , _bcTimestamp = 0 128 | , _bcVersion = _vmVersion } 129 | let Bytecode segments (Segment c s ss i) _ _ = execState (compileProgram cast) initCompilerState 130 | let initState = st 131 | { _vmStack = [] 132 | , _vmConstants = c 133 | , _vmSymbols = s 134 | , _vmStructs = ss 135 | , _vmSegments = segments 136 | , _vmDepth = 0 137 | , _vmInstrs = i 138 | , _vmInstrIndex = 0 } 139 | eExec <- liftIO (runExceptT (runStateT runVM initState)) 140 | case eExec of 141 | Right (val, st) -> do 142 | -- outputStrLn (show val) 143 | lift . lift $ put st { _vmInstrs = [] 144 | , _vmInstrIndex = 0 } 145 | lift $ replBindings .= _tcBindings tc 146 | Left err -> outputStrLn (show err) 147 | Left err -> outputStrLn "Runtime error:" >> outputStrLn (show err) 148 | runREPLCommand Reload = lift (gets _replFile) >>= \case 149 | Just f -> runREPLCommand (Load f) 150 | Nothing -> outputStrLn "reload: no module loaded" 151 | runREPLCommand Quit = lift $ replRunning .= False 152 | 153 | runREPL :: Maybe FilePath -> Bool -> IO () 154 | runREPL file debug = do 155 | art <- readFile "src/snowflake_ascii.txt" 156 | putStrLn (init art ++ showVersion version) 157 | let loadAndLoop = case file of 158 | Just f -> runREPLCommand (Load f) >> loopREPL 159 | Nothing -> loopREPL 160 | let vm = evalStateT (runInputT defaultSettings loadAndLoop) (defaultREPLState file) 161 | runExceptT (execStateT vm (defaultVMState debug)) >>= \case 162 | Right _ -> return () 163 | Left err -> print err 164 | 165 | defaultREPLState :: Maybe FilePath -> REPLState 166 | defaultREPLState file = REPLState 167 | { _replFile = file 168 | , _replSettings = defaultSettings 169 | , _replBindings = Env.singleMap defaultBindings 170 | , _replErrorOffset = 2 171 | , _replLine = 0 172 | , _replRunning = True } 173 | 174 | defaultVMState :: Bool -> VMState 175 | defaultVMState debug = VMState 176 | { _vmStack = [] 177 | , _vmEnv = Env.singleMap defaultEnv 178 | , _vmTypeEnv = Env.singleMap defaultTypeEnv 179 | , _vmConstants = [] 180 | , _vmSymbols = [] 181 | , _vmStructs = [] 182 | , _vmSegments = [] 183 | , _vmDepth = 0 184 | , _vmInstrs = [] 185 | , _vmInstrIndex = 0 186 | , _vmDebug = debug 187 | , _vmVersion = version } 188 | -------------------------------------------------------------------------------- /src/Language/Snowflake/REPL/Parser.hs: -------------------------------------------------------------------------------- 1 | module Language.Snowflake.REPL.Parser (parseREPLInput) where 2 | 3 | import Language.Snowflake.Parser 4 | import Language.Snowflake.REPL.Types 5 | 6 | import Text.Parsec 7 | import Text.Parsec.String 8 | 9 | import Data.Tuple (swap) 10 | 11 | replInput :: Parser REPLInput 12 | replInput = try (char ':' >> Command <$> replCommand <* eof) 13 | <|> try (Instr <$> (raw $ instruction) <* (spaces >> eof)) 14 | <|> try (Expr <$> raw expr <* (spaces >> eof)) 15 | <|> ((spaces <* eof) >> return NoInput) 16 | 17 | replCommand :: Parser REPLCommand 18 | replCommand = type' <|> load <|> reload <|> quit 19 | 20 | type', load, reload, quit :: Parser REPLCommand 21 | type' = (try (string "type") <|> string "t") <* spaces >> Type <$> raw expr 22 | load = (try (string "load") <|> string "l") <* spaces >> Load <$> many anyChar 23 | reload = (try (string "reload") <|> string "r") <* spaces >> return Reload 24 | quit = (try (string "quit") <|> string "q") <* spaces >> return Quit 25 | 26 | parseREPLInput :: String -> Either ParseError REPLInput 27 | parseREPLInput = parse (replInput <* eof) "(input)" 28 | 29 | raw :: Parser a -> Parser (a, String) 30 | raw p = fmap swap $ (,) <$> lookAhead (many anyChar) <*> p 31 | -------------------------------------------------------------------------------- /src/Language/Snowflake/REPL/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | MultiParamTypeClasses 3 | , FlexibleInstances 4 | , TemplateHaskell 5 | #-} 6 | 7 | module Language.Snowflake.REPL.Types 8 | ( REPL 9 | , REPLState(..), replFile, replSettings, replBindings, replLine, replErrorOffset, replRunning 10 | , REPLInput(..) 11 | , REPLCommand(..) 12 | ) where 13 | 14 | import Language.Snowflake.Parser.AST 15 | import Language.Snowflake.Typing.Types 16 | import Language.Snowflake.VM 17 | 18 | import Control.Lens 19 | import Control.Monad.State 20 | import Control.Monad.Except 21 | 22 | import System.Console.Haskeline 23 | 24 | data REPLState = REPLState 25 | { _replFile :: Maybe FilePath 26 | , _replSettings :: Settings (StateT REPLState (StateT VMState (ExceptT VMException IO))) 27 | , _replBindings :: Bindings Type 28 | , _replLine :: Int 29 | , _replErrorOffset :: Int 30 | , _replRunning :: Bool } 31 | makeLenses ''REPLState 32 | 33 | type REPL a = InputT (StateT REPLState (StateT VMState (ExceptT VMException IO))) a 34 | 35 | data REPLInput 36 | = Instr (Decl Instruction Loc, String) 37 | | Expr (Expr Loc, String) 38 | | Command REPLCommand 39 | | NoInput 40 | 41 | data REPLCommand 42 | = Type (Expr Loc, String) 43 | | Load FilePath 44 | | Reload 45 | | Quit 46 | deriving Show 47 | 48 | instance MonadException m => MonadException (ExceptT e m) where 49 | controlIO f = ExceptT $ controlIO $ \(RunIO run) -> let 50 | run' = RunIO (fmap ExceptT . run . runExceptT) 51 | in fmap runExceptT $ f run' 52 | 53 | instance MonadException m => MonadException (StateT s m) where 54 | controlIO f = StateT $ \s -> controlIO $ \(RunIO run) -> let 55 | run' = RunIO (fmap (StateT . const) . run . flip runStateT s) 56 | in fmap (flip runStateT s) $ f run' 57 | 58 | instance MonadError VMException (InputT (StateT REPLState (StateT VMState (ExceptT VMException IO)))) where 59 | throwError = lift . lift . throwError 60 | m `catchError` h = do 61 | settings <- lift $ gets _replSettings 62 | let s = runInputT settings m 63 | lift $ s `catchError` (runInputT settings . h) 64 | -------------------------------------------------------------------------------- /src/Language/Snowflake/Typing.hs: -------------------------------------------------------------------------------- 1 | module Language.Snowflake.Typing 2 | ( module Exports 3 | , runTypeCheck 4 | , evalTypeCheck 5 | , execTypeCheck 6 | ) where 7 | 8 | import Language.Snowflake.Typing.TypeCheck as Exports 9 | import Language.Snowflake.Typing.Types as Exports 10 | 11 | import Language.Snowflake.Parser.AST 12 | 13 | import Control.Monad.Reader 14 | import Control.Monad.State 15 | import Control.Monad.Except 16 | 17 | import qualified Data.Map as Map 18 | import qualified Data.ChainMap as Env 19 | 20 | -- typeCheckProgram :: Program Loc -> ModuleInfo -> Bindings -> TypeEnv -> Either [TypeCheckError] (Program (Loc, Type)) 21 | -- typeCheckProgram (Program is) modInfo bs ts = runReader (runExceptT (evalStateT (check is) (defaultTCState bs ts))) modInfo 22 | -- 23 | -- typeCheckInstr :: Instruction Loc -> ModuleInfo -> Bindings -> TypeEnv -> Either [TypeCheckError] (Instruction (Loc, Type)) 24 | -- typeCheckInstr instr modInfo bs ts = runReader (runExceptT (evalStateT (checkInstr instr) (defaultTCState bs ts))) modInfo 25 | -- 26 | -- typeCheckExpr :: Expr Loc -> ModuleInfo -> Bindings -> TypeEnv -> Either [TypeCheckError] (Expr (Loc, Type)) 27 | -- typeCheckExpr expr modInfo bs ts = runReader (runExceptT (evalStateT (typeOfExpr expr) (defaultTCState bs ts))) modInfo 28 | -- 29 | -- typeCheckTypeExpr :: TypeExpr Loc -> ModuleInfo -> TypeEnv -> Either [TypeCheckError] (TypeExpr (Loc, Type)) 30 | -- typeCheckTypeExpr tExpr modInfo ts = runReader (runExceptT (evalStateT (evaluateTypeExpr tExpr) (defaultTCState Env.empty ts))) modInfo 31 | 32 | runTypeCheck :: TypeCheckable n => n Loc -> ModuleInfo -> Bindings Type -> TypeEnv -> Either [TypeCheckError] (n (Loc, Type), TypeCheckState) 33 | runTypeCheck n modInfo bs ts = runReader (runExceptT (runStateT (check n) (defaultTCState bs ts))) modInfo 34 | 35 | evalTypeCheck :: TypeCheckable n => n Loc -> ModuleInfo -> Bindings Type -> TypeEnv -> Either [TypeCheckError] (n (Loc, Type)) 36 | evalTypeCheck n modInfo bs ts = fst <$> runTypeCheck n modInfo bs ts 37 | 38 | execTypeCheck :: TypeCheckable n => n Loc -> ModuleInfo -> Bindings Type -> TypeEnv -> Either [TypeCheckError] TypeCheckState 39 | execTypeCheck n modInfo bs ts = snd <$> runTypeCheck n modInfo bs ts 40 | 41 | defaultTCState :: Bindings Type -> TypeEnv -> TypeCheckState 42 | defaultTCState bs ts = TypeCheckState 43 | { _tcBindings = bs 44 | , _tcTypeBindings = Env.empty 45 | , _tcTypeEnv = ts 46 | , _tcExpected = NoneT } 47 | -------------------------------------------------------------------------------- /src/Language/Snowflake/Typing/TypeCheck.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | MultiParamTypeClasses 3 | , TypeSynonymInstances 4 | , FlexibleInstances 5 | , LambdaCase 6 | , TupleSections 7 | #-} 8 | 9 | module Language.Snowflake.Typing.TypeCheck 10 | ( evalLiteral 11 | , evalTypeLiteral 12 | ) where 13 | 14 | import Language.Snowflake.Typing.Types 15 | 16 | import Language.Snowflake.Parser.AST 17 | import Language.Snowflake.VM.Types 18 | 19 | import qualified Data.ChainMap as Env 20 | import Data.AST 21 | 22 | import Prelude hiding (Ordering(..)) 23 | 24 | import Control.Lens 25 | import Control.Applicative 26 | import Control.Monad 27 | import Control.Monad.State 28 | import Control.Monad.Except 29 | 30 | import Data.Functor.Foldable 31 | import Data.Functor.Compose 32 | import Data.Foldable (foldrM) 33 | import qualified Data.Map as Map 34 | import Data.List (intercalate) 35 | import Data.Tuple (swap) 36 | 37 | import Debug.Trace 38 | 39 | instance TypeCheckable Program where 40 | check (Program instrs) = Program <$> check instrs 41 | 42 | instance TypeCheckable (Decl Block) where 43 | check (Decl (Node (Block instrs) loc)) = do 44 | cinstrs <- mapM check instrs 45 | return . Decl $ Node (Block cinstrs) (loc, NoneT) 46 | 47 | instance TypeCheckable (Decl Instruction) where 48 | check (Decl (Node (DeclareInstr te v e) loc)) = do 49 | b <- gets _tcBindings 50 | if Env.member v b then 51 | raiseTC TCScopeError ("Name " ++ show v ++ " was already declared") loc 52 | else do 53 | (cte, t) <- checkEval te 54 | (ce, t') <- checkEval e 55 | t'' <- intersect t t' <|> raiseTC TCMismatchError ("Couldn't declare value of expected type " ++ showType t ++ " with actual type " ++ showType t') loc 56 | tcBindings %= Env.insert v t'' 57 | return . Decl $ Node (DeclareInstr cte v ce) (loc, NoneT) 58 | check (Decl (Node (AssignInstr v e) loc)) = do 59 | (_, t) <- checkEval (fromNode (Node (VarExpr_ v) loc)) 60 | (ce, t') <- checkEval e 61 | intersect t t' <|> raiseTC TCMismatchError ("Couldn't assign value of expected type " ++ showType t ++ " with actual type " ++ showType t') loc 62 | return . Decl $ Node (AssignInstr v ce) (loc, NoneT) 63 | check (Decl (Node (ReturnInstr e) loc)) = do 64 | t <- gets _tcExpected 65 | (ce, t') <- checkEval e 66 | intersect t t' <|> raiseTC TCMismatchError ("Couldn't return value of expected type " ++ showType t ++ " with actual type " ++ showType t') loc 67 | return . Decl $ Node (ReturnInstr ce) (loc, NoneT) 68 | check (Decl (Node (ExprInstr e) loc)) = do 69 | ce <- check e 70 | return . Decl $ Node (ExprInstr ce) (loc, NoneT) 71 | check (Decl (Node (CondInstr cond tr fl) loc)) = do 72 | (ccond, condT) <- checkEval cond 73 | intersect condT BoolT <|> raiseTC TCMismatchError ("Expected value of type bool, got " ++ showType condT) (extract cond) 74 | ctr <- check tr 75 | cfl <- check fl 76 | return . Decl $ Node (CondInstr ccond ctr cfl) (loc, NoneT) 77 | check (Decl (Node (WhileInstr cond loop) loc)) = do 78 | (ccond, condT) <- checkEval cond 79 | intersect condT BoolT <|> raiseTC TCMismatchError ("Expected value of type bool, got " ++ showType condT) (extract cond) 80 | cloop <- check loop 81 | return . Decl $ Node (WhileInstr ccond cloop) (loc, NoneT) 82 | check (Decl (Node (ForInstr var iter loop) loc)) = checkEval iter >>= \case 83 | (citer, ListT t) -> do 84 | tcs <- get 85 | cloop <- sandboxCheck loop $ tcs & tcBindings %~ Env.newChild (Map.singleton var t) 86 | return . Decl $ Node (ForInstr var citer cloop) (loc, NoneT) 87 | (citer, t) -> raiseTC TCMismatchError ("Expected iterable, got " ++ showType t) (extract iter) 88 | check (Decl (Node (FnInstr (FnDecl name tparams params ret body)) loc)) = do 89 | tcs <- get 90 | let tpt = [ (evalKind k, n) | TypeParam k n <- tparams] 91 | genericBindings = Map.fromList (map swap tpt) 92 | genericEnv = Map.fromList [ (n, GenericT n) | (_, n) <- tpt ] 93 | genState = tcs & tcTypeBindings %~ Env.newChild genericBindings 94 | & tcTypeEnv %~ Env.newChild genericEnv 95 | cparams <- mapM (flip sandboxCheck genState) params 96 | cret <- sandboxCheck ret genState 97 | let ps = Map.fromList $ zip (map _paramName params) (map eval cparams) 98 | tret = eval cret 99 | pt = map eval cparams 100 | bodyState = genState & tcBindings %~ Env.insert name (FuncT tpt pt tret) . Env.newChild ps 101 | & tcExpected .~ tret 102 | cbody <- sandboxCheck body bodyState 103 | tcBindings %= Env.insert name (FuncT tpt pt tret) 104 | return . Decl $ Node (FnInstr (FnDecl name tparams cparams cret cbody)) (loc, NoneT) 105 | -- (cret, tret) <- checkEval ret 106 | -- 107 | -- (cparams, pt) <- unzip <$> mapM checkEval params 108 | -- let tps = Map.fromList $ zip (map _typeParamName tparams) tpt 109 | -- ps = Map.fromList $ zip (map _paramName params) pt 110 | -- cbody <- sandboxCheck body $ tcs & tcBindings %~ Env.newChild ps 111 | -- & tcTypeEnv %~ Env.newChild tps 112 | -- & tcExpected .~ tret 113 | -- tcBindings %= Env.insert name (FuncT tpt pt tret) 114 | -- return . Decl $ Node (FnInstr (FnDecl name ctparams cparams cret cbody)) (loc, NoneT) 115 | check (Decl (Node (TypeInstr (TypeDecl name fields)) loc)) = do 116 | (cfields, tfields) <- unzipMap <$> mapM checkEval fields 117 | tcTypeEnv %= Env.insert name (StructT tfields) 118 | return . Decl $ Node (TypeInstr (TypeDecl name cfields)) (loc, NoneT) 119 | 120 | instance TypeCheckable Param where 121 | check (Param t n) = Param <$> check t <*> pure n 122 | 123 | instance TypeCheckable (AST TypeExpr_) where 124 | check (VarTExpr' var loc) = gets (Env.lookup var . _tcTypeEnv) >>= \case 125 | Just t -> return $ fromNode (Node (VarTExpr_ var) (loc, t)) 126 | Nothing -> raiseTC TCUndefinedTypeError ("Type " ++ show var ++ " is undefined") loc 127 | check (ListTExpr' t loc) = do 128 | (ct, t') <- checkEval t 129 | return $ fromNode (Node (ListTExpr_ ct) (loc, ListT t')) 130 | check (TupleTExpr' ts loc) = do 131 | (cts, ts') <- unzip <$> mapM checkEval ts 132 | return . fromNode $ Node (TupleTExpr_ cts) (loc, TupleT ts') 133 | check (FnTExpr' tps ps ret loc) = do 134 | tcs <- get 135 | let tps' = [(evalKind k, n) | TypeParam k n <- tps ] 136 | let argState = tcs & tcTypeEnv %~ Env.newChild (Map.fromList [ (n, GenericT n) | (_, n) <- tps' ]) 137 | cps <- forM ps $ \ p -> 138 | sandboxCheck p argState 139 | let ps' = map eval cps 140 | cret <- sandboxCheck ret argState 141 | let ret' = eval cret 142 | return . fromNode $ Node (FnTExpr_ tps cps cret) (loc, FuncT tps' ps' ret') 143 | check (LitTExpr' lit loc) = return . fromNode $ Node (LitTExpr_ lit) (loc, evalTypeLiteral lit) 144 | check (StructTExpr' fields loc) = do 145 | (cfields, tfields) <- unzipMap <$> mapM checkEval fields 146 | return . fromNode $ Node (StructTExpr_ cfields) (loc, StructT tfields) 147 | 148 | unzipMap :: Ord k => Map.Map k (v, v') -> (Map.Map k v, Map.Map k v') 149 | unzipMap m = (fst <$> m, snd <$> m) 150 | 151 | evalTypeLiteral :: TypeLiteral -> Type 152 | evalTypeLiteral IntTLit = IntT 153 | evalTypeLiteral FloatTLit = FloatT 154 | evalTypeLiteral BoolTLit = BoolT 155 | evalTypeLiteral StrTLit = StrT 156 | evalTypeLiteral NoneTLit = NoneT 157 | 158 | evalKind :: KindExpr a -> Kind 159 | evalKind TypeKExpr = TypeK 160 | 161 | instance TypeCheckable (AST Expr_) where 162 | check (VarExpr' var loc) = gets (Env.lookup var . _tcBindings) >>= \case 163 | Just typ -> return . fromNode $ Node (VarExpr_ var) (loc, typ) 164 | Nothing -> raiseTC TCScopeError ("Name " ++ show var ++ " is undefined") loc 165 | check (AttrExpr' owner attr loc) = checkEval owner >>= \case 166 | (cowner, StructT fields) -> 167 | if Map.member attr fields then 168 | return . fromNode $ Node (AttrExpr_ cowner attr) (loc, (Map.!) fields attr) 169 | else 170 | raiseTC TCAttrError (show cowner ++ " has no attribute " ++ show attr) loc 171 | (_, t) -> raiseTC TCMismatchError ("Expected struct, got " ++ show t) loc 172 | check (BinOpExpr' AddOp x y loc) = (,) <$> checkEval x <*> checkEval y >>= \case 173 | ((cx, AnyT), (cy, t)) -> return . fromNode $ Node (BinOpExpr_ AddOp cx cy) (loc, t) 174 | ((cx, t), (cy, AnyT)) -> return . fromNode $ Node (BinOpExpr_ AddOp cx cy) (loc, t) 175 | ((cx, IntT), (cy, IntT)) -> return . fromNode $ Node (BinOpExpr_ AddOp cx cy) (loc, IntT) 176 | ((cx, IntT), (cy, FloatT)) -> return . fromNode $ Node (BinOpExpr_ AddOp cx cy) (loc, FloatT) 177 | ((cx, FloatT), (cy, IntT)) -> return . fromNode $ Node (BinOpExpr_ AddOp cx cy) (loc, FloatT) 178 | ((cx, FloatT), (cy, FloatT)) -> return . fromNode $ Node (BinOpExpr_ AddOp cx cy) (loc, FloatT) 179 | ((cx, StrT), (cy, StrT)) -> return . fromNode $ Node (BinOpExpr_ AddOp cx cy) (loc, StrT) 180 | ((cx, tx), (cy, ty)) -> raiseTC TCMismatchError ("Cannot add value of type " ++ showType ty ++ " to value of type " ++ showType tx) loc 181 | check (BinOpExpr' SubOp x y loc) = (,) <$> checkEval x <*> checkEval y >>= \case 182 | ((cx, AnyT), (cy, t)) -> return . fromNode $ Node (BinOpExpr_ SubOp cx cy) (loc, t) 183 | ((cx, t), (cy, AnyT)) -> return . fromNode $ Node (BinOpExpr_ SubOp cx cy) (loc, t) 184 | ((cx, IntT), (cy, IntT)) -> return . fromNode $ Node (BinOpExpr_ SubOp cx cy) (loc, IntT) 185 | ((cx, IntT), (cy, FloatT)) -> return . fromNode $ Node (BinOpExpr_ SubOp cx cy) (loc, FloatT) 186 | ((cx, FloatT), (cy, IntT)) -> return . fromNode $ Node (BinOpExpr_ SubOp cx cy) (loc, FloatT) 187 | ((cx, FloatT), (cy, FloatT)) -> return . fromNode $ Node (BinOpExpr_ SubOp cx cy) (loc, FloatT) 188 | ((cx, tx), (cy, ty)) -> raiseTC TCMismatchError ("Cannot subtract value of type " ++ showType ty ++ " from value of type " ++ showType tx) loc 189 | check (BinOpExpr' MulOp x y loc) = (,) <$> checkEval x <*> checkEval y >>= \case 190 | ((cx, AnyT), (cy, t)) -> return . fromNode $ Node (BinOpExpr_ MulOp cx cy) (loc, t) 191 | ((cx, t), (cy, AnyT)) -> return . fromNode $ Node (BinOpExpr_ MulOp cx cy) (loc, t) 192 | ((cx, IntT), (cy, IntT)) -> return . fromNode $ Node (BinOpExpr_ MulOp cx cy) (loc, IntT) 193 | ((cx, IntT), (cy, FloatT)) -> return . fromNode $ Node (BinOpExpr_ MulOp cx cy) (loc, FloatT) 194 | ((cx, FloatT), (cy, IntT)) -> return . fromNode $ Node (BinOpExpr_ MulOp cx cy) (loc, FloatT) 195 | ((cx, FloatT), (cy, FloatT)) -> return . fromNode $ Node (BinOpExpr_ MulOp cx cy) (loc, FloatT) 196 | ((cx, IntT), (cy, StrT)) -> return . fromNode $ Node (BinOpExpr_ MulOp cx cy) (loc, StrT) 197 | ((cx, StrT), (cy, IntT)) -> return . fromNode $ Node (BinOpExpr_ MulOp cx cy) (loc, StrT) 198 | ((cx, IntT), (cy, ListT t)) -> return . fromNode $ Node (BinOpExpr_ MulOp cx cy) (loc, ListT t) 199 | ((cx, ListT t), (cy, IntT)) -> return . fromNode $ Node (BinOpExpr_ MulOp cx cy) (loc, ListT t) 200 | ((cx, tx), (cy, ty)) -> raiseTC TCMismatchError ("Cannot multiply value of type " ++ showType ty ++ " with value of type " ++ showType tx) loc 201 | check (BinOpExpr' DivOp x y loc) = (,) <$> checkEval x <*> checkEval y >>= \case 202 | ((cx, AnyT), (cy, t)) -> return . fromNode $ Node (BinOpExpr_ DivOp cx cy) (loc, t) 203 | ((cx, t), (cy, AnyT)) -> return . fromNode $ Node (BinOpExpr_ DivOp cx cy) (loc, t) 204 | ((cx, IntT), (cy, IntT)) -> return . fromNode $ Node (BinOpExpr_ DivOp cx cy) (loc, FloatT) 205 | ((cx, IntT), (cy, FloatT)) -> return . fromNode $ Node (BinOpExpr_ DivOp cx cy) (loc, FloatT) 206 | ((cx, FloatT), (cy, IntT)) -> return . fromNode $ Node (BinOpExpr_ DivOp cx cy) (loc, FloatT) 207 | ((cx, FloatT), (cy, FloatT)) -> return . fromNode $ Node (BinOpExpr_ DivOp cx cy) (loc, FloatT) 208 | ((cx, tx), (cy, ty)) -> raiseTC TCMismatchError ("Cannot divide value of type " ++ showType ty ++ " by value of type " ++ showType tx) loc 209 | check (BinOpExpr' PowOp x y loc) = (,) <$> checkEval x <*> checkEval y >>= \case 210 | ((cx, AnyT), (cy, t)) -> return . fromNode $ Node (BinOpExpr_ PowOp cx cy) (loc, t) 211 | ((cx, t), (cy, AnyT)) -> return . fromNode $ Node (BinOpExpr_ PowOp cx cy) (loc, t) 212 | ((cx, IntT), (cy, IntT)) -> return . fromNode $ Node (BinOpExpr_ PowOp cx cy) (loc, FloatT) 213 | ((cx, IntT), (cy, FloatT)) -> return . fromNode $ Node (BinOpExpr_ PowOp cx cy) (loc, FloatT) 214 | ((cx, FloatT), (cy, IntT)) -> return . fromNode $ Node (BinOpExpr_ PowOp cx cy) (loc, FloatT) 215 | ((cx, FloatT), (cy, FloatT)) -> return . fromNode $ Node (BinOpExpr_ PowOp cx cy) (loc, FloatT) 216 | ((cx, tx), (cy, ty)) -> raiseTC TCMismatchError ("Cannot exponentiate value of type " ++ showType tx ++ " to value of type " ++ showType ty) loc 217 | check (BinOpExpr' op x y loc) 218 | | op `elem` [AndOp, OrOp] = (,) <$> checkEval x <*> checkEval y >>= \case 219 | ((cx, BoolT), (cy, BoolT)) -> return . fromNode $ Node (BinOpExpr_ op cx cy) (loc, BoolT) 220 | ((cx, tx), (cy, ty)) -> raiseTC TCMismatchError ("Excpected boolean values, got" ++ show tx ++ " and " ++ showType ty) loc 221 | | op `elem` [GTOp, GEOp, LEOp, LTOp] = (,) <$> checkEval x <*> checkEval y >>= \case 222 | ((cx, AnyT), (cy, t)) -> return . fromNode $ Node (BinOpExpr_ op cx cy) (loc, BoolT) 223 | ((cx, t), (cy, AnyT)) -> return . fromNode $ Node (BinOpExpr_ op cx cy) (loc, BoolT) 224 | ((cx, IntT), (cy, IntT)) -> return . fromNode $ Node (BinOpExpr_ op cx cy) (loc, BoolT) 225 | ((cx, IntT), (cy, FloatT)) -> return . fromNode $ Node (BinOpExpr_ op cx cy) (loc, BoolT) 226 | ((cx, FloatT), (cy, IntT)) -> return . fromNode $ Node (BinOpExpr_ op cx cy) (loc, BoolT) 227 | ((cx, FloatT), (cy, FloatT)) -> return . fromNode $ Node (BinOpExpr_ op cx cy) (loc, BoolT) 228 | ((cx, tx), (cy, ty)) -> raiseTC TCMismatchError ("Cannot compare value of type " ++ showType tx ++ " to value of type " ++ showType ty) loc 229 | | op `elem` [EQOp, NEQOp] = (,) <$> checkEval x <*> checkEval y >>= \case 230 | ((cx, AnyT), (cy, t)) -> return . fromNode $ Node (BinOpExpr_ op cx cy) (loc, BoolT) 231 | ((cx, t), (cy, AnyT)) -> return . fromNode $ Node (BinOpExpr_ op cx cy) (loc, BoolT) 232 | ((cx, IntT), (cy, IntT)) -> return . fromNode $ Node (BinOpExpr_ op cx cy) (loc, BoolT) 233 | ((cx, IntT), (cy, FloatT)) -> return . fromNode $ Node (BinOpExpr_ op cx cy) (loc, BoolT) 234 | ((cx, FloatT), (cy, IntT)) -> return . fromNode $ Node (BinOpExpr_ op cx cy) (loc, BoolT) 235 | ((cx, FloatT), (cy, FloatT)) -> return . fromNode $ Node (BinOpExpr_ op cx cy) (loc, BoolT) 236 | ((cx, StrT), (cy, StrT)) -> return . fromNode $ Node (BinOpExpr_ op cx cy) (loc, BoolT) 237 | ((cx, ListT t), (cy, ListT t')) -> 238 | if t == t' then 239 | return . fromNode $ Node (BinOpExpr_ op cx cy) (loc, BoolT) 240 | else 241 | raiseTC TCMismatchError "Cannot compare lists of different component types" loc 242 | ((cx, TupleT ts), (cy, TupleT ts')) -> do 243 | sequence_ (zipWith intersect ts ts') <|> raiseTC TCMismatchError "Cannot compare tuples of different component types" loc 244 | return . fromNode $ Node (BinOpExpr_ op cx cy) (loc, BoolT) 245 | ((cx, NoneT), (cy, NoneT)) -> return . fromNode $ Node (BinOpExpr_ op cx cy) (loc, BoolT) 246 | | otherwise = raiseTC TCMismatchError "Cannot compare" loc 247 | check (UnOpExpr' PosOp x loc) = checkEval x >>= \case 248 | (cx, AnyT) -> return . fromNode $ Node (UnOpExpr_ PosOp cx) (loc, AnyT) 249 | (cx, IntT) -> return . fromNode $ Node (UnOpExpr_ PosOp cx) (loc, IntT) 250 | (cx, FloatT) -> return . fromNode $ Node (UnOpExpr_ PosOp cx) (loc, FloatT) 251 | (cx, tx) -> raiseTC TCMismatchError ("Cannot posate value of type " ++ showType tx) loc 252 | check (UnOpExpr' NegOp x loc) = checkEval x >>= \case 253 | (cx, AnyT) -> return . fromNode $ Node (UnOpExpr_ NegOp cx) (loc, AnyT) 254 | (cx, IntT) -> return . fromNode $ Node (UnOpExpr_ NegOp cx) (loc, IntT) 255 | (cx, FloatT) -> return . fromNode $ Node (UnOpExpr_ NegOp cx) (loc, FloatT) 256 | (cx, tx) -> raiseTC TCMismatchError ("Cannot negate value of type " ++ showType tx) loc 257 | check (CallExpr' f targs args loc) = checkEval f >>= \case 258 | (cf, t@(FuncT tps ts r)) -> do 259 | tcs <- get 260 | (ctargs, tts') <- unzip <$> mapM checkEval targs 261 | -- todo: add kind checking 262 | -- sequence_ (zipWith intersect tts tts') <|> raiseTC TCMismatchError ("Couldn't call function of type " ++ showType t ++ " with arguments (" ++ intercalate ", " (map showType ts') ++ ")") loc 263 | let argState = tcs & tcTypeEnv %~ Env.newChild (Map.fromList $ zip (map snd tps) tts') 264 | cargs <- mapM (flip sandboxCheck argState) args -- & tcExpected .~ t' 265 | let ts' = map eval cargs 266 | --(cargs, ts') <- unzip <$> mapM checkEval args 267 | sandbox argState $ sequence_ (zipWith intersect ts ts') <|> raiseTC TCMismatchError ("Couldn't call function of type " ++ showType t ++ " with arguments (" ++ intercalate ", " (map showType ts') ++ ")") loc 268 | return . fromNode $ Node (CallExpr_ cf ctargs cargs) (loc, r) 269 | (cf, t) -> raiseTC TCMismatchError ("Expected function, got " ++ show t) loc 270 | check (ListExpr' xs loc) = do 271 | (cxs, ts) <- unzip <$> mapM checkEval xs 272 | t <- foldrM intersect AnyT ts <|> raiseTC TCMismatchError "Expected list to be homogenous" loc 273 | return . fromNode $ Node (ListExpr_ cxs) (loc, ListT t) 274 | check (TupleExpr' xs loc) = do 275 | (cxs, ts) <- unzip <$> mapM checkEval xs 276 | return . fromNode $ Node (TupleExpr_ cxs) (loc, TupleT ts) 277 | check (LitExpr' lit loc) = return . fromNode $ Node (LitExpr_ lit) (loc, evalLiteral lit) 278 | check (StructExpr' assocs loc) = do 279 | (cassocs, fields) <- unzipMap <$> mapM checkEval assocs 280 | return . fromNode $ Node (StructExpr_ cassocs) (loc, StructT fields) 281 | 282 | evalLiteral :: Literal -> Type 283 | evalLiteral (IntLit _) = IntT 284 | evalLiteral (FloatLit _) = FloatT 285 | evalLiteral (BoolLit _) = BoolT 286 | evalLiteral (StrLit _) = StrT 287 | evalLiteral NoneLit = NoneT 288 | -------------------------------------------------------------------------------- /src/Language/Snowflake/Typing/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | LambdaCase 3 | , TemplateHaskell 4 | , MultiParamTypeClasses 5 | , FunctionalDependencies 6 | #-} 7 | 8 | module Language.Snowflake.Typing.Types 9 | ( Kind(..) 10 | , Type(..) 11 | , showKind, showType 12 | , Bindings 13 | , TypeEnv 14 | , TypeCheckState(..), tcBindings, tcTypeBindings, tcTypeEnv, tcExpected 15 | , TypeCheckErrorType(..) 16 | , TypeCheckError(..) 17 | , TypeCheck 18 | , eval, checkEval 19 | , TypeCheckable(..) 20 | , sandboxCheck 21 | , sandbox 22 | , intersect 23 | , raiseTC 24 | , printError, printErrors 25 | ) where 26 | 27 | import Language.Snowflake.Parser.AST 28 | 29 | import qualified Data.ChainMap as Env 30 | 31 | import Control.Lens 32 | import Control.Monad.Reader 33 | import Control.Monad.State 34 | import Control.Monad.Except 35 | 36 | import Data.Function (on) 37 | import Data.Semigroup ((<>)) 38 | import Data.List (intercalate, groupBy) 39 | import qualified Data.Map as Map 40 | 41 | import Text.Parsec.Pos 42 | import Debug.Trace 43 | import System.Console.ANSI 44 | 45 | data Type 46 | = IntT 47 | | FloatT 48 | | BoolT 49 | | StrT 50 | | FuncT [(Kind, Name)] [Type] Type 51 | | ListT Type 52 | | TupleT [Type] 53 | | StructT (Map.Map Name Type) 54 | | GenericT Name 55 | | NoneT 56 | | AnyT 57 | deriving (Eq, Show) 58 | 59 | data Kind 60 | = TypeK 61 | deriving (Eq, Show) 62 | 63 | showType :: Type -> String 64 | showType IntT = "int" 65 | showType FloatT = "float" 66 | showType BoolT = "bool" 67 | showType StrT = "str" 68 | showType (FuncT [] ps r) = "fn(" ++ intercalate ", " (map showType ps) ++ ") -> " ++ showType r 69 | showType (FuncT tps ps r) = "fn<" ++ intercalate ", " (map showTypeParam tps) ++ ">(" ++ intercalate ", " (map showType ps) ++ ") -> " ++ showType r 70 | where showTypeParam (k, n) = showKind k ++ " " ++ n 71 | showType (ListT t) = "[" ++ showType t ++ "]" 72 | showType (TupleT ts) = "(" ++ intercalate ", " (map showType ts) ++ ")" 73 | showType (StructT fields) = "{" ++ intercalate ", " (map showField (Map.assocs fields)) ++ "}" 74 | where showField (n, t) = show t ++ " " ++ n 75 | showType (GenericT v) = v 76 | showType NoneT = "None" 77 | showType AnyT = "*" 78 | 79 | showKind :: Kind -> String 80 | showKind TypeK = "Type" 81 | 82 | type Bindings a = Env.ChainMap Name a 83 | type TypeEnv = Env.ChainMap Name Type 84 | 85 | data TypeCheckState = TypeCheckState 86 | { _tcBindings :: Bindings Type 87 | , _tcTypeBindings :: Bindings Kind 88 | , _tcTypeEnv :: TypeEnv 89 | , _tcExpected :: Type } 90 | deriving Show 91 | makeLenses ''TypeCheckState 92 | 93 | data TypeCheckErrorType 94 | = TCScopeError 95 | | TCAttrError 96 | | TCMismatchError 97 | | TCUndefinedTypeError 98 | 99 | instance Show TypeCheckErrorType where 100 | show TCScopeError = "Scope error" 101 | show TCAttrError = "Attribute error" 102 | show TCMismatchError = "Mismatch error" 103 | show TCUndefinedTypeError = "Undefined type error" 104 | 105 | data TypeCheckError = TypeCheckError TypeCheckErrorType String Loc 106 | deriving Show 107 | 108 | type TypeCheckM a = StateT TypeCheckState (ExceptT [TypeCheckError] (Reader ModuleInfo)) a 109 | type TypeCheck n = n Loc -> TypeCheckM (n (Loc, Type)) 110 | 111 | class IsNode n => TypeCheckable n where 112 | check :: TypeCheck n 113 | 114 | intersect :: Type -> Type -> TypeCheckM Type 115 | intersect AnyT t = return t 116 | intersect t AnyT = return t 117 | intersect (GenericT n) (GenericT m) 118 | | n == m = return (GenericT n) 119 | | otherwise = throwError [] 120 | intersect (GenericT n) t' = gets (Env.lookup n . _tcTypeEnv) >>= \case 121 | Just (GenericT _) -> throwError [] 122 | Just t -> intersect t t' 123 | Nothing -> throwError [] 124 | intersect t (GenericT n) = intersect (GenericT n) t 125 | intersect t t' 126 | | t == t' = return t 127 | | otherwise = throwError [] -- raiseTC TCMismatchError ("Failed to intersect " ++ showType t ++ " and " ++ showType t') (sp <> sp') 128 | 129 | sandboxCheck :: TypeCheckable n => n Loc -> TypeCheckState -> TypeCheckM (n (Loc, Type)) 130 | sandboxCheck n tcs = lift $ evalStateT (check n) tcs 131 | 132 | sandbox :: TypeCheckState -> TypeCheckM a -> TypeCheckM a 133 | sandbox s m = do 134 | s' <- get 135 | put s 136 | r <- m 137 | put s' 138 | return r 139 | 140 | eval :: TypeCheckable n => n (Loc, Type) -> Type 141 | eval = snd . nodeData 142 | 143 | checkEval :: TypeCheckable n => n Loc -> TypeCheckM (n (Loc, Type), Type) 144 | checkEval n = do 145 | cn <- check n 146 | return (cn, eval cn) 147 | 148 | raiseTC :: TypeCheckErrorType -> String -> Loc -> TypeCheckM a 149 | raiseTC t s loc = throwError [TypeCheckError t s loc] 150 | 151 | putChunk :: Chunk -> IO () 152 | putChunk (ContextChunk s) = setSGR [SetUnderlining NoUnderline] >> putStr s 153 | putChunk (ErrorChunk s) = setSGR [SetUnderlining SingleUnderline] >> putStr s 154 | 155 | data Chunk = ContextChunk String | ErrorChunk String deriving Show 156 | type ErrorOutput = [Chunk] 157 | 158 | inLoc :: (Line, Column) -> Loc -> Bool 159 | _ `inLoc` VoidLoc = False 160 | (i, j) `inLoc` (Loc start stop) 161 | | sourceLine start == sourceLine stop = (i == sourceLine start) && (j >= sourceColumn start) && (j <= sourceColumn stop) 162 | | (i > sourceLine start) && (i < sourceLine stop) = True 163 | | i == sourceLine start = j >= sourceColumn start 164 | | i == sourceLine stop = j <= sourceColumn stop 165 | | otherwise = False 166 | 167 | -- splitSource :: String -> Line -> Loc -> ErrorOutput 168 | -- splitSource src offset (Loc f l) 169 | -- | sourceLine f == sourceLine l = [ beforeOffset 170 | -- , [ErrorChunk $ map ((srcLines !! (sourceLine f - 1)) !!) [sourceColumn f-1..sourceColumn l-1]] 171 | -- , afterOffset ] 172 | -- | otherwise = let (before, startLine) = splitAt (sourceColumn f) (srcLines !! sourceLine f) 173 | -- bodyLines = map (return . ErrorChunk . (srcLines !!)) [sourceLine f+1..sourceLine l-1] 174 | -- (stopLine, after) = splitAt (sourceColumn l) (srcLines !! sourceLine l) 175 | -- in [ beforeOffset 176 | -- , [ContextChunk before, ErrorChunk startLine] 177 | -- ] ++ bodyLines ++ 178 | -- [ [ErrorChunk stopLine, ContextChunk after] 179 | -- , afterOffset ] 180 | -- where lineCount = length (lines src) 181 | -- srcLines = lines src 182 | -- startLineIdx = if sourceLine f - offset > 0 then sourceLine f - offset else 1 183 | -- stopLineIdx = if sourceLine l + offset <= lineCount then sourceLine l + offset else lineCount 184 | -- beforeOffset = map (ContextChunk . (srcLines !!)) [startLineIdx..sourceLine f-1] 185 | -- afterOffset = map (ContextChunk . (srcLines !!)) [sourceLine l+1..stopLineIdx] 186 | 187 | sliceLoc :: String -> Loc -> String 188 | sliceLoc src VoidLoc = "" 189 | sliceLoc src (Loc f l) 190 | | f > l = "" 191 | | sourceLine f == sourceLine l = let line = srcLines !! (sourceLine f - 1) 192 | in drop (sourceColumn f - 1) $ take (sourceColumn l) line 193 | | f < l = let line = srcLines !! (sourceLine f - 1) 194 | nextLoc = Loc (setSourceColumn (incSourceLine f 1) 0) l 195 | in drop (sourceColumn f - 1) line ++ "\n" ++ sliceLoc src nextLoc 196 | where srcLines = lines src 197 | 198 | splitSource :: String -> Line -> Loc -> ErrorOutput 199 | splitSource src offset loc@(Loc f l) = [ ContextChunk (sliceLoc src offsetToChunk) 200 | , ErrorChunk (sliceLoc src (Loc f (incSourceColumn l (-1)))) 201 | , ContextChunk (sliceLoc src chunkToOffset) ] 202 | where lineCount = length (lines src) 203 | startLine = if sourceLine f - offset > 0 then sourceLine f - offset else 1 204 | stopLine = if sourceLine l + offset <= lineCount then sourceLine l + offset else lineCount 205 | offsetToChunk = Loc (setSourceColumn (setSourceLine f startLine) 0) (incSourceColumn f (-1)) 206 | chunkToOffset = Loc l (setSourceColumn (setSourceLine l (stopLine+1)) 0) 207 | 208 | -- splitSource' :: String -> Line -> [Loc] -> ErrorOutput 209 | -- splitSource' src offset locs = output 210 | -- where lineCount = length (lines src) 211 | -- startLine = if sourceLine f - offset > 0 then sourceLine f - offset else 1 212 | -- stopLine = if sourceLine l + offset <= lineCount then sourceLine l + offset else lineCount 213 | -- idm = length (show stopLine) + 1 214 | -- ls = drop (startLine - 1) . take (sourceLine l + offset) $ lines src 215 | -- indexed = map (\ (i, l) -> (i, map (\ (j, c) -> (i, j, c)) $ zip [1..] l)) . zip [startLine..] $ map (++ "\n") ls 216 | -- groups = map (fmap (groupBy groupF)) indexed 217 | -- groupF (i, j, _) (i', j', _) = (i, j) `inLoc` loc == (i', j') `inLoc` loc 218 | -- output = map toLine groups 219 | -- toLine (i, l) = let lineno = show i ++ replicate (idm - length (show i)) ' ' ++ "| " 220 | -- in ContextChunk lineno : map toChunk l 221 | -- toChunk [] = ContextChunk "" 222 | -- toChunk g@((i, j, _):_) 223 | -- | (i, j) `inLoc` loc = ErrorChunk (map (\ (_, _, c) -> c) g) 224 | -- | otherwise = ContextChunk (map (\ (_, _, c) -> c) g) 225 | 226 | printErrorSource :: ModuleInfo -> Line -> Loc -> IO () 227 | printErrorSource (ModuleInfo src path) offset loc = mapM_ putChunk (splitSource src offset loc) 228 | 229 | printError :: ModuleInfo -> Line -> TypeCheckError -> IO () 230 | printError modInfo@(ModuleInfo src path) offset (TypeCheckError typ msg loc@(Loc f l)) = do 231 | setSGR [SetColor Foreground Dull Red] 232 | let ls = sourceLine f 233 | lf = sourceLine l 234 | if ls == lf 235 | then putStrLn $ "File " ++ show path ++ ", line " ++ show ls ++ ":" 236 | else putStrLn $ "File " ++ show path ++ ", lines " ++ show ls ++ " to " ++ show lf ++ ":" 237 | -- setSGR [Reset] 238 | printErrorSource modInfo offset loc 239 | setSGR [SetUnderlining NoUnderline] 240 | putStrLn $ show typ ++ ": " ++ msg 241 | setSGR [Reset] 242 | 243 | printErrors :: ModuleInfo -> Line -> [TypeCheckError] -> IO () 244 | printErrors modInfo offset errs = mapM_ (printError modInfo offset) errs 245 | -------------------------------------------------------------------------------- /src/Language/Snowflake/VM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | RecordWildCards 3 | , LambdaCase 4 | , TupleSections 5 | , TemplateHaskell 6 | #-} 7 | 8 | module Language.Snowflake.VM 9 | ( module Language.Snowflake.VM.Types 10 | , runInstr 11 | , runVM 12 | , runCurrentInstr 13 | , runBytecode 14 | , bytecodeToVMState 15 | ) where 16 | 17 | import Language.Snowflake.VM.Operators 18 | import Language.Snowflake.VM.Types 19 | 20 | import Prelude hiding (Ordering(..)) 21 | 22 | import Language.Snowflake.Parser.AST (Name) 23 | import Language.Snowflake.Compiler.Types 24 | import Language.Snowflake.Typing.Types 25 | 26 | import Control.Lens hiding (uncons) 27 | import Control.Arrow ((&&&)) 28 | import Control.Applicative ((<|>)) 29 | import Control.Monad.State 30 | import Control.Monad.Except 31 | 32 | import Data.Maybe (catMaybes) 33 | import Data.Word 34 | import Data.List 35 | import qualified Data.Map as Map 36 | import qualified Data.ChainMap as Env 37 | 38 | import System.IO 39 | 40 | debugVM :: VM () 41 | debugVM = get >>= \ st -> lift . lift $ do 42 | putStr (replicate (_vmDepth st) '\t') 43 | putStr $ show $ genericIndex (_vmInstrs st) (_vmInstrIndex st) 44 | putStr $ " | " ++ show (_vmStack st, _vmEnv st, _vmConstants st) 45 | getChar 46 | return () 47 | 48 | showCurrentInstr :: VM () 49 | showCurrentInstr = use vmDebug >>= \ dbg -> if not dbg then return () else do 50 | stack <- use vmStack 51 | constants <- use vmConstants 52 | symbols <- use vmSymbols 53 | structs <- use vmStructs 54 | env <- use vmEnv 55 | depth <- use vmDepth 56 | idx <- use vmInstrIndex 57 | instrs <- use vmInstrs 58 | segments <- use vmSegments 59 | state <- get 60 | lift . lift $ do 61 | putStrLn $ '\n' : replicate 60 '-' 62 | putStr (replicate depth '\t') 63 | putStr (show idx) 64 | putStr (replicate (4 - length (show idx)) ' ') 65 | putStr $ show (genericIndex instrs idx) 66 | case genericIndex instrs idx of 67 | STORE addr -> putStrLn (" (" ++ show (genericIndex symbols addr) ++ ")") 68 | LOAD addr -> putStrLn (" (" ++ show (genericIndex symbols addr) ++ ")") 69 | LOAD_CONST addr -> putStrLn (" (" ++ show (genericIndex constants addr) ++ ")") 70 | BUILD_STRUCT addr -> putStrLn (" (" ++ show (genericIndex structs addr) ++ ")") 71 | _ -> putStrLn "" 72 | putStr (showState state) 73 | hFlush stdout 74 | 75 | pauseVM :: VM () 76 | pauseVM = lift . lift $ getChar >> return () 77 | 78 | applyArgs :: Segment -> [Value] -> VM Value 79 | applyArgs (Segment c s ss i) args = do 80 | st@VMState{..} <- get 81 | let locals = Map.fromList $ catMaybes [(, val) <$> (s ^? ix i) | (i, val) <- zip [0..] args] 82 | state = st { _vmStack = [] 83 | , _vmEnv = Env.newChild locals _vmEnv 84 | , _vmConstants = c 85 | , _vmSymbols = s 86 | , _vmStructs = ss 87 | , _vmDepth = _vmDepth + 1 88 | , _vmInstrs = i 89 | , _vmInstrIndex = 0 } 90 | lift (lift $ runExceptT (evalStateT runVM state)) >>= \case 91 | Right val -> return val 92 | Left exc -> throwError exc 93 | 94 | pop :: Word32 -> VM [Value] 95 | pop n = do 96 | stack <- use vmStack 97 | if genericLength stack >= n then do 98 | (popped, rest) <- gets (splitAt (fromIntegral n) . _vmStack) 99 | vmStack .= rest 100 | return popped 101 | else raise StackError "pop: stack exhausted" 102 | 103 | append :: Value -> VM () 104 | append val = vmStack %= (val :) 105 | 106 | runCurrentInstr :: VM () 107 | runCurrentInstr = do 108 | instrs <- gets _vmInstrs 109 | debug <- gets _vmDebug 110 | instrIndex <- gets (fromIntegral . _vmInstrIndex) 111 | case instrs ^? ix instrIndex of 112 | Just instr -> do 113 | when debug (showCurrentInstr >> pauseVM) 114 | runInstr instr 115 | vmInstrIndex += 1 116 | Nothing -> raise Executed "" 117 | 118 | binOp :: (Value -> Value -> VM Value) -> VM () 119 | binOp op = do 120 | [y, x] <- pop 2 121 | append =<< x `op` y 122 | 123 | unOp :: (Value -> VM Value) -> VM () 124 | unOp op = do 125 | [x] <- pop 1 126 | append =<< op x 127 | 128 | runInstr :: Instr -> VM () 129 | 130 | runInstr NOP = return () 131 | runInstr POP = pop 1 >> return () 132 | runInstr ADD = binOp addOp 133 | runInstr SUB = binOp subOp 134 | runInstr MUL = binOp mulOp 135 | runInstr DIV = binOp divOp 136 | runInstr POW = binOp powOp 137 | runInstr AND = binOp andOp 138 | runInstr OR = binOp orOp 139 | runInstr POS = return () 140 | runInstr NEG = unOp negOp 141 | runInstr NOT = unOp notOp 142 | runInstr LT = binOp ltOp 143 | runInstr LE = binOp leOp 144 | runInstr EQ = binOp eqOp 145 | runInstr NEQ = binOp neqOp 146 | runInstr GE = binOp geOp 147 | runInstr GT = binOp gtOp 148 | 149 | runInstr (CALL n) = uncons . reverse <$> pop (n + 1) >>= \case 150 | Just (FuncVal segIndex, args) -> do 151 | segments <- gets _vmSegments 152 | case segments ^? ix (fromIntegral segIndex) of 153 | Just seg -> applyArgs seg args >>= append 154 | Nothing -> raise SegmentError "CALL: segment not found" 155 | Just (BuiltinVal f, args) -> f args >>= append 156 | Just (_, _) -> raise TypeError "CALL: object is not callable" 157 | Nothing -> raise StackError "CALL: stack exhausted" 158 | 159 | runInstr (BUILD_LIST n) = pop n >>= append . ListVal . reverse 160 | 161 | runInstr (BUILD_TUPLE n) = pop n >>= append . TupleVal . reverse 162 | 163 | runInstr (BUILD_STRUCT n) = do 164 | structs <- gets _vmStructs 165 | case structs ^? ix (fromIntegral n) of 166 | Just fields -> append =<< (StructVal . Map.fromList . zip fields . reverse <$> pop (genericLength fields)) 167 | Nothing -> raise StructError "BUILD_STRUCT: struct prototype not found" 168 | 169 | runInstr (ITER n) = head <$> pop 1 >>= \case 170 | ListVal [] -> runInstr (JUMP n) 171 | ListVal (next:rest) -> append (ListVal rest) >> append next 172 | _ -> raise TypeError "POP_NEXT_ITER_OR_JUMP: expected iterator" 173 | 174 | runInstr (STORE n) = do 175 | symbols <- gets _vmSymbols 176 | case symbols ^? ix (fromIntegral n) of 177 | Just sym -> do 178 | [val] <- pop 1 179 | vmEnv %= Env.update sym val 180 | Nothing -> raise ScopeError "STORE: symbol not found" 181 | 182 | runInstr (LOAD n) = do 183 | (symbols, env) <- gets (_vmSymbols &&& _vmEnv) 184 | case symbols ^? ix (fromIntegral n) of 185 | Just sym -> case Env.lookup sym env of 186 | Just val -> append val 187 | Nothing -> raise ScopeError "LOAD: value not found" 188 | Nothing -> raise ScopeError "LOAD: symbol not found" 189 | 190 | runInstr (LOAD_CONST n) = gets ((^? ix (fromIntegral n)) . _vmConstants) >>= \case 191 | Just cst -> append (constantToValue cst) 192 | Nothing -> raise SegmentError "LOAD_CONST: constant not found" 193 | 194 | runInstr (LOAD_ATTR n) = do 195 | [StructVal assocs] <- pop 1 196 | (symbols, env) <- gets (_vmSymbols &&& _vmEnv) 197 | case symbols ^? ix (fromIntegral n) of 198 | Just sym -> append ((Map.!) assocs sym) 199 | Nothing -> raise AttrError "LOAD_ATTR: attribute symbol not found" 200 | 201 | runInstr RETURN = do 202 | [val] <- pop 1 203 | raise (Returned val) "" 204 | 205 | runInstr IF = head <$> pop 1 >>= \case 206 | BoolVal True -> vmInstrIndex += 1 >> runCurrentInstr 207 | BoolVal False -> vmInstrIndex += 1 208 | _ -> raise TypeError "IF: expected boolean" 209 | 210 | runInstr (JUMP n) = vmInstrIndex += fromIntegral n 211 | 212 | runVM :: VM Value 213 | runVM = (runCurrentInstr >> runVM) `catchError` \case 214 | VMException Executed _ _ -> vmDepth -= 1 >> return NoneVal 215 | VMException (Returned x) _ _ -> vmDepth -= 1 >> return x 216 | err -> throwError err 217 | 218 | runBytecode :: Bytecode -> Env -> TypeEnv -> Bool -> IO (Either VMException VMState) 219 | runBytecode bytecode env typeEnv debug = runExceptT (execStateT runVM (bytecodeToVMState bytecode env typeEnv debug)) 220 | 221 | bytecodeToVMState :: Bytecode -> Env -> TypeEnv -> Bool -> VMState 222 | bytecodeToVMState (Bytecode segments (Segment c s ss i) _ version) env typeEnv debug = VMState 223 | { _vmStack = [] 224 | , _vmEnv = env 225 | , _vmTypeEnv = typeEnv 226 | , _vmSymbols = s 227 | , _vmConstants = c 228 | , _vmStructs = ss 229 | , _vmSegments = segments 230 | , _vmDepth = 0 231 | , _vmInstrs = i 232 | , _vmInstrIndex = 0 233 | , _vmDebug = debug 234 | , _vmVersion = version } 235 | -- where globals = Map.fromList $ catMaybes 236 | -- [ (name,) <$> Env.lookup name env | (i, name) <- zip [0..] s ] 237 | -------------------------------------------------------------------------------- /src/Language/Snowflake/VM/Operators.hs: -------------------------------------------------------------------------------- 1 | module Language.Snowflake.VM.Operators where 2 | 3 | import Language.Snowflake.VM.Types 4 | 5 | -- Numerical operators 6 | addOp, subOp, mulOp, divOp, powOp :: Value -> Value -> VM Value 7 | negOp :: Value -> VM Value 8 | 9 | -- Boolean operators 10 | andOp, orOp :: Value -> Value -> VM Value 11 | notOp :: Value -> VM Value 12 | 13 | -- Comparison operators 14 | ltOp, leOp, eqOp, neqOp, geOp, gtOp :: Value -> Value -> VM Value 15 | 16 | addOp (IntVal a) (IntVal b) = return $ IntVal (a + b) 17 | addOp (IntVal a) (FloatVal b) = return $ FloatVal (realToFrac a + b) 18 | addOp (FloatVal a) (IntVal b) = return $ FloatVal (a + realToFrac b) 19 | addOp (FloatVal a) (FloatVal b) = return $ FloatVal (a + b) 20 | addOp (StrVal a) (StrVal b) = return $ StrVal (a ++ b) 21 | addOp _ _ = raise TypeError "ADD: wrong type" 22 | 23 | subOp (IntVal a) (IntVal b) = return $ IntVal (a - b) 24 | subOp (IntVal a) (FloatVal b) = return $ FloatVal (realToFrac a - b) 25 | subOp (FloatVal a) (IntVal b) = return $ FloatVal (a - realToFrac b) 26 | subOp (FloatVal a) (FloatVal b) = return $ FloatVal (a - b) 27 | subOp _ _ = raise TypeError "SUB: wrong type" 28 | 29 | mulOp (IntVal a) (IntVal b) = return $ IntVal (a * b) 30 | mulOp (IntVal a) (FloatVal b) = return $ FloatVal (realToFrac a * b) 31 | mulOp (FloatVal a) (IntVal b) = return $ FloatVal (a * realToFrac b) 32 | mulOp (FloatVal a) (FloatVal b) = return $ FloatVal (a * b) 33 | mulOp (IntVal n) (StrVal s) = return $ StrVal (mconcat $ replicate (fromIntegral n) s) 34 | mulOp (StrVal s) (IntVal n) = return $ StrVal (mconcat $ replicate (fromIntegral n) s) 35 | mulOp _ _ = raise TypeError "MUL: wrong type" 36 | 37 | divOp (IntVal _) (IntVal 0) = raise ZeroDivisionError "DIV: divide by 0" 38 | divOp (IntVal _) (FloatVal 0) = raise ZeroDivisionError "DIV: divide by 0" 39 | divOp (FloatVal _) (IntVal 0) = raise ZeroDivisionError "DIV: divide by 0" 40 | divOp (FloatVal _) (FloatVal 0) = raise ZeroDivisionError "DIV: divide by 0" 41 | divOp (IntVal a) (IntVal b) = return $ FloatVal (realToFrac a / realToFrac b) 42 | divOp (IntVal a) (FloatVal b) = return $ FloatVal (realToFrac a / b) 43 | divOp (FloatVal a) (IntVal b) = return $ FloatVal (a / realToFrac b) 44 | divOp (FloatVal a) (FloatVal b) = return $ FloatVal (a / b) 45 | divOp _ _ = raise TypeError "DIV: wrong type" 46 | 47 | powOp (IntVal a) (IntVal b) = return $ IntVal (a ^ b) 48 | powOp (IntVal a) (FloatVal b) = return $ FloatVal (realToFrac a ** b) 49 | powOp (FloatVal a) (IntVal b) = return $ FloatVal (a ^ b) 50 | powOp (FloatVal a) (FloatVal b) = return $ FloatVal (a ** b) 51 | powOp _ _ = raise TypeError "POW: wrong type" 52 | 53 | negOp (IntVal x) = return $ IntVal (negate x) 54 | negOp (FloatVal x) = return $ FloatVal (negate x) 55 | 56 | andOp (BoolVal a) (BoolVal b) = return $ BoolVal (a && b) 57 | andOp _ _ = raise TypeError "AND: wrong type" 58 | 59 | orOp (BoolVal a) (BoolVal b) = return $ BoolVal (a || b) 60 | orOp _ _ = raise TypeError "OR: wrong type" 61 | 62 | notOp (BoolVal b) = return $ BoolVal (not b) 63 | 64 | ltOp (IntVal a) (IntVal b) = return $ BoolVal (a < b) 65 | ltOp (IntVal a) (FloatVal b) = return $ BoolVal (realToFrac a < b) 66 | ltOp (FloatVal a) (IntVal b) = return $ BoolVal (a < realToFrac b) 67 | ltOp (FloatVal a) (FloatVal b) = return $ BoolVal (a < b) 68 | ltOp _ _ = raise TypeError "LT: wrong type" 69 | 70 | leOp (IntVal a) (IntVal b) = return $ BoolVal (a <= b) 71 | leOp (IntVal a) (FloatVal b) = return $ BoolVal (realToFrac a <= b) 72 | leOp (FloatVal a) (IntVal b) = return $ BoolVal (a <= realToFrac b) 73 | leOp (FloatVal a) (FloatVal b) = return $ BoolVal (a <= b) 74 | leOp _ _ = raise TypeError "LE: wrong type" 75 | 76 | eqOp (IntVal a) (IntVal b) = return $ BoolVal (a == b) 77 | eqOp (IntVal a) (FloatVal b) = return $ BoolVal (realToFrac a == b) 78 | eqOp (FloatVal a) (IntVal b) = return $ BoolVal (a == realToFrac b) 79 | eqOp (FloatVal a) (FloatVal b) = return $ BoolVal (a == b) 80 | eqOp _ _ = raise TypeError "EQ: wrong type" 81 | 82 | neqOp (IntVal a) (IntVal b) = return $ BoolVal (a /= b) 83 | neqOp (IntVal a) (FloatVal b) = return $ BoolVal (realToFrac a /= b) 84 | neqOp (FloatVal a) (IntVal b) = return $ BoolVal (a /= realToFrac b) 85 | neqOp (FloatVal a) (FloatVal b) = return $ BoolVal (a /= b) 86 | neqOp _ _ = raise TypeError "NEQ: wrong type" 87 | 88 | geOp (IntVal a) (IntVal b) = return $ BoolVal (a >= b) 89 | geOp (IntVal a) (FloatVal b) = return $ BoolVal (realToFrac a >= b) 90 | geOp (FloatVal a) (IntVal b) = return $ BoolVal (a >= realToFrac b) 91 | geOp (FloatVal a) (FloatVal b) = return $ BoolVal (a >= b) 92 | geOp _ _ = raise TypeError "GE: wrong type" 93 | 94 | gtOp (IntVal a) (IntVal b) = return $ BoolVal (a > b) 95 | gtOp (IntVal a) (FloatVal b) = return $ BoolVal (realToFrac a > b) 96 | gtOp (FloatVal a) (IntVal b) = return $ BoolVal (a > realToFrac b) 97 | gtOp (FloatVal a) (FloatVal b) = return $ BoolVal (a > b) 98 | gtOp _ _ = raise TypeError "GT: wrong type" 99 | -------------------------------------------------------------------------------- /src/Language/Snowflake/VM/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | RecordWildCards 3 | , TemplateHaskell 4 | #-} 5 | 6 | module Language.Snowflake.VM.Types 7 | ( Scope, Env 8 | , Value(..) 9 | , VM 10 | , VMState(..), vmStack, vmEnv, vmTypeEnv, vmConstants, vmSymbols, vmStructs, vmSegments, vmDepth, vmInstrs, vmInstrIndex, vmDebug, vmVersion 11 | , VMExceptionType(..) 12 | , VMException(..) 13 | , raise 14 | , constantToValue 15 | , showState 16 | ) where 17 | 18 | import Language.Snowflake.Parser (Name) 19 | import Language.Snowflake.Compiler.Types 20 | import Language.Snowflake.Typing.Types 21 | 22 | import Control.Lens 23 | import Control.Monad.State 24 | import Control.Monad.Except 25 | 26 | import qualified Data.Map as Map 27 | import qualified Data.ChainMap as Env 28 | 29 | import Data.Word 30 | import Data.Int 31 | import Data.List (intercalate) 32 | import Data.Version (Version) 33 | 34 | type Scope = Map.Map Name Value 35 | type Env = Env.ChainMap Name Value 36 | 37 | data Value 38 | = IntVal Int64 39 | | FloatVal Float 40 | | BoolVal Bool 41 | | StrVal String 42 | | ListVal [Value] 43 | | TupleVal [Value] 44 | | StructVal (Map.Map Name Value) 45 | | FuncVal Word32 46 | | NoneVal 47 | | BuiltinVal ([Value] -> VM Value) 48 | 49 | instance Show Value where 50 | show (IntVal n) = show n 51 | show (FloatVal x) = show x 52 | show (BoolVal b) = show b 53 | show (StrVal s) = show s 54 | show (ListVal l) = '[' : intercalate ", " (map show l) ++ "]" 55 | show (TupleVal t) = '(' : intercalate ", " (map show t) ++ ")" 56 | show (StructVal s) = '{' : intercalate ", " (map showAssoc $ Map.assocs s) ++ "}" 57 | where showAssoc (n, v) = n ++ " = " ++ show v 58 | show (FuncVal segIndex) = "<>" 59 | show NoneVal = "None" 60 | show (BuiltinVal _) = "<>" 61 | 62 | type VM a = StateT VMState (ExceptT VMException IO) a 63 | 64 | data VMException = VMException VMExceptionType Message VMState 65 | 66 | instance Show VMException where 67 | show (VMException t msg s) = show t ++ ": " ++ msg ++ " (" ++ show s ++ ")" 68 | 69 | data VMExceptionType 70 | = TypeError 71 | | StructError 72 | | IndexError 73 | | ValueError 74 | | StackError 75 | | ScopeError 76 | | AttrError 77 | | SegmentError 78 | | ZeroDivisionError 79 | | NoEntry 80 | | Returned Value 81 | | Executed 82 | | KeyboardInterrupt 83 | deriving Show 84 | 85 | data VMState = VMState 86 | { _vmStack :: [Value] 87 | , _vmEnv :: Env 88 | , _vmTypeEnv :: TypeEnv 89 | , _vmConstants :: [Constant] 90 | , _vmSymbols :: [Name] 91 | , _vmStructs :: [[Name]] 92 | , _vmSegments :: [Segment] 93 | , _vmDepth :: Int 94 | , _vmInstrs :: [Instr] 95 | , _vmInstrIndex :: Word32 96 | , _vmDebug :: Bool 97 | , _vmVersion :: Version } 98 | deriving Show 99 | makeLenses ''VMState 100 | 101 | showState :: VMState -> String 102 | showState VMState{..} = 103 | intercalate "\n" . map (replicate _vmDepth '\t' ++) $ 104 | [ "stack: " ++ show _vmStack 105 | , "env: " ++ show _vmEnv 106 | , "constants: " ++ show _vmConstants 107 | , "symbols: " ++ show _vmSymbols 108 | , "structs: " ++ show _vmStructs 109 | , "instrs: " 110 | ] ++ map showInstr (zip [0..] _vmInstrs) 111 | where showInstr (i, instr) 112 | | i == _vmInstrIndex = " > " ++ show i ++ (replicate (4 - length (show i)) ' ') ++ show instr 113 | | otherwise = '\t' : show i ++ (replicate (4 - length (show i)) ' ') ++ show instr 114 | showSeg (i, (Segment constants symbols structs instrs)) = 115 | intercalate "\n" $ ['\t' : "segment " ++ show i] ++ map ("\t\t" ++) 116 | [ "constants: " ++ show constants 117 | , "symbols: " ++ show symbols 118 | , "structs: " ++ show structs 119 | ] ++ map showInstr (zip [0..] instrs) 120 | 121 | raise :: VMExceptionType -> Message -> VM a 122 | raise t msg = throwError . VMException t msg =<< get 123 | 124 | constantToValue :: Constant -> Value 125 | constantToValue (IntConst n) = IntVal n 126 | constantToValue (FloatConst x) = FloatVal x 127 | constantToValue (BoolConst b) = BoolVal b 128 | constantToValue (StrConst s) = StrVal s 129 | constantToValue (FuncConst segIndex) = FuncVal segIndex 130 | constantToValue NoneConst = NoneVal 131 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Language.Snowflake (runSnowflake) 4 | 5 | main :: IO () 6 | main = runSnowflake 7 | -------------------------------------------------------------------------------- /src/snowflake_ascii.txt: -------------------------------------------------------------------------------- 1 | \__ __/ 2 | /_/ \_\ __ _ _ 3 | _\/\/_ / _| | | | 4 | __/\_\_\/_/_/\__ ___ _ __ _____ _| |_| | __ _| | _____ 5 | \/ /_/\_\ \/ / __| '_ \ / _ \ \ /\ / / _| |/ _` | |/ / _ \ 6 | __/\/\__ \__ \ | | | (_) \ V V /| | | | (_| | < __/ 7 | \_\ /_/ |___/_| |_|\___/ \_/\_/ |_| |_|\__,_|_|\_\___| 8 | / \ v 9 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-11.22 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # - location: 29 | # git: https://github.com/commercialhaskell/stack.git 30 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 31 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # subdirs: 33 | # - auto-update 34 | # - wai 35 | packages: 36 | - . 37 | # Dependency packages to be pulled from upstream that are not in the resolver 38 | # using the same syntax as the packages field. 39 | # (e.g., acme-missiles-0.3) 40 | # extra-deps: [] 41 | 42 | # Override default flag values for local packages and extra-deps 43 | # flags: {} 44 | 45 | # Extra package databases containing global packages 46 | # extra-package-dbs: [] 47 | 48 | # Control whether we use the GHC we find on the path 49 | # system-ghc: true 50 | # 51 | # Require a specific version of stack, using version ranges 52 | # require-stack-version: -any # Default 53 | # require-stack-version: ">=1.9" 54 | # 55 | # Override the architecture used by stack, especially useful on Windows 56 | # arch: i386 57 | # arch: x86_64 58 | # 59 | # Extra directories used by stack for building 60 | # extra-include-dirs: [/path/to/dir] 61 | # extra-lib-dirs: [/path/to/dir] 62 | # 63 | # Allow a newer minor version of GHC than the snapshot specifies 64 | # compiler-check: newer-minor 65 | --------------------------------------------------------------------------------