├── .dir-locals.el ├── .gitignore ├── Dockerfile ├── Inflex.pdf ├── LICENSE ├── README.md ├── Screenshot from 2023-05-02 17-18-26.png ├── inflex-lang ├── .gitignore ├── app │ └── Main.hs ├── bench │ └── Time.hs ├── package.yaml ├── src │ ├── Data │ │ ├── Decimal.hs │ │ └── List │ │ │ └── Extra.hs │ └── Inflex │ │ ├── Decimal.hs │ │ ├── Defaulter.hs │ │ ├── Defaulter │ │ └── Suggest.hs │ │ ├── Derived.hs │ │ ├── Derived │ │ └── TH.hs │ │ ├── Document.hs │ │ ├── Eval.hs │ │ ├── Filler.hs │ │ ├── Generaliser.hs │ │ ├── Generator.hs │ │ ├── Instances.hs │ │ ├── Kind.hs │ │ ├── Lexer.hs │ │ ├── Location.hs │ │ ├── NormalFormCheck.hs │ │ ├── Optics.hs │ │ ├── Parser.hs │ │ ├── Parser2.hs │ │ ├── Pretty.hs │ │ ├── Printer.hs │ │ ├── Renamer.hs │ │ ├── Resolver.hs │ │ ├── Rows.hs │ │ ├── Solver.hs │ │ ├── Type.hs │ │ ├── Types.hs │ │ ├── Types │ │ ├── Defaulter.hs │ │ ├── Eval.hs │ │ ├── Filler.hs │ │ ├── Generator.hs │ │ ├── Optics.hs │ │ ├── Renamer.hs │ │ ├── Resolver.hs │ │ ├── SHA512.hs │ │ └── Solver.hs │ │ └── Variants.hs └── test │ ├── DefaultSpec.hs │ ├── DocumentSpec.hs │ ├── GeneraliserSpec.hs │ ├── GenerateSpec.hs │ ├── LexSpec.hs │ ├── Match.hs │ ├── NormalFormSpec.hs │ ├── ParseSpec.hs │ ├── RenameSpec.hs │ ├── ResolveSpec.hs │ ├── SolverSpec.hs │ ├── Spec.hs │ └── StepSpec.hs ├── screenshots ├── E9nc_HkWQAMA95c.png ├── E_D_vWoX0AEHr0M.png ├── EpnDWJ9XIAQ8Ej7.jpeg ├── Esl-GBGXMAIPPgr.png ├── Eus43sKWgAcUMrL.jpeg ├── Eus5qBTXIAI_eVp.jpeg ├── Eus6K9pXAAIHPrV.jpeg ├── FLXp2BxX0AAn5R9.jpeg └── inflex-screenie.jpeg ├── stack.yaml └── stack.yaml.lock /.dir-locals.el: -------------------------------------------------------------------------------- 1 | ;;; Directory Local Variables 2 | ;;; For more information see (info "(emacs) Directory Variables") 3 | 4 | ((haskell-mode 5 | (intero-targets "inflex-lang:lib" "inflex-lang:test:inflex-lang-test" "inflex-server:lib" "inflex-server:exe:inflex-server" "inflex-server:test:inflex-types"))) 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | inflex-server/client_session_key.aes 2 | .backup-psc-package 3 | .psc-package 4 | .stack-work 5 | app.js 6 | output 7 | client_session_key.aes 8 | inflex-lang/*.cabal 9 | inflex-client/*.cabal 10 | inflex-pgmf/*.cabal 11 | inflex-shared/*.cabal 12 | inflex-client/src/Inflex/Shared.purs 13 | inflex-server/src/Inflex/Shared.hs 14 | fly/inflex-server 15 | dist-newstyle 16 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM fpco/alpine-haskell-stack:8.6.5 2 | 3 | RUN adduser -u 1000 chris --disabled-password && \ 4 | install -d -m 0755 -o chris -g chris /home/chris 5 | 6 | ARG USER_ID=1000 7 | ARG GROUP_ID=1000 8 | 9 | RUN apk update && apk add sdl2 sqlite sdl2-dev sqlite-dev ncurses-dev ncurses-static 10 | 11 | USER chris 12 | -------------------------------------------------------------------------------- /Inflex.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisdone-archive/inflex/1361479368d21ccdb6e481a3394a4bf22776e1e0/Inflex.pdf -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # inflex 2 | 3 | The Inflex language's source code. This language is no longer under development, but its source is made available in case it is useful for educational purposes. 4 | 5 | See the file Inflex.pdf in this repo for some slides about the language and some architectural decisions made. 6 | 7 | [Page about Inflex here](https://chrisdone.com/posts/inflex/). 8 | 9 | Published with an Affero GPL license. 10 | 11 | Copyright ©️ Chris Done 2020-2022 12 | 13 | ![screenie](https://raw.githubusercontent.com/chrisdone/inflex/master/Screenshot%20from%202023-05-02%2017-18-26.png) 14 | -------------------------------------------------------------------------------- /Screenshot from 2023-05-02 17-18-26.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisdone-archive/inflex/1361479368d21ccdb6e481a3394a4bf22776e1e0/Screenshot from 2023-05-02 17-18-26.png -------------------------------------------------------------------------------- /inflex-lang/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ -------------------------------------------------------------------------------- /inflex-lang/app/Main.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | 3 | module Main where 4 | 5 | main :: IO () 6 | main = pure () 7 | -------------------------------------------------------------------------------- /inflex-lang/bench/Time.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# LANGUAGE DuplicateRecordFields, OverloadedStrings #-} 5 | 6 | import Control.DeepSeq 7 | import Control.Monad 8 | import Criterion.Main 9 | import Data.Bifunctor 10 | import Data.ByteString (ByteString) 11 | import qualified Data.ByteString as S 12 | import Data.ByteUnits 13 | import Data.Text (Text) 14 | import qualified Data.Text as T 15 | import qualified Data.Text.Encoding as T 16 | import Inflex.Generator 17 | import Inflex.Instances () 18 | import Inflex.Lexer 19 | import Inflex.NormalFormCheck as NF 20 | import Inflex.Parser 21 | import qualified Inflex.Parser2 as Parser2 22 | import Inflex.Resolver 23 | import Inflex.Solver 24 | import qualified RIO 25 | import RIO (newSomeRef, RIO) 26 | 27 | main :: IO () 28 | main = do 29 | let !array1000 = 30 | T.concat ["[", T.intercalate "," (replicate 1000 "1234"), "]"] 31 | !array2000 = 32 | T.concat ["[", T.intercalate "," (replicate 2000 "1234"), "]"] 33 | !array4000 = 34 | T.concat ["[", T.intercalate "," (replicate 4000 "1234"), "]"] 35 | !array1000' = 36 | S.concat ["[", S.intercalate "," (replicate 1000 "1234"), "]"] 37 | !array2000' = 38 | S.concat ["[", S.intercalate "," (replicate 2000 "1234"), "]"] 39 | !array4000' = 40 | S.concat ["[", S.intercalate "," (replicate 4000 "1234"), "]"] 41 | !array1000Sig = 42 | T.concat ["[", T.intercalate "," (replicate 1000 "1234"), "]::[Integer]"] 43 | !array4000Sig = 44 | T.concat ["[", T.intercalate "," (replicate 4000 "1234"), "]::[Integer]"] 45 | when 46 | True 47 | (defaultMain 48 | [ bgroup 49 | "encodeUtf8" 50 | [ env 51 | (pure (T.replicate i sampleUnicode)) 52 | (\t -> 53 | bench 54 | ("T.encodeUtf8: " ++ 55 | show (i * T.length sampleUnicode) ++ " chars") 56 | (whnf T.encodeUtf8 t)) 57 | | i <- [1, 10, 100] 58 | ] 59 | , bgroup 60 | "lexText" 61 | [ bgroup 62 | (show (size :: Int)) 63 | [ bench "whnf" (whnf lexTextUpToErrorSuccess arr) 64 | , bench "nf" (nf lexTextUpToErrorSuccess arr) 65 | ] 66 | | (size, arr) <- 67 | [(1000, array1000), (2000, array2000), (4000, array4000)] 68 | ] 69 | , bgroup 70 | "parseText" 71 | [ bgroup 72 | "Parser1" 73 | [ bench "array[1000]" (nf parseTextUpToErrorSuccess array1000) 74 | , bench "array[2000]" (nf parseTextUpToErrorSuccess array2000) 75 | , bench "array[4000]" (nf parseTextUpToErrorSuccess array4000) 76 | ] 77 | , bgroup 78 | "Parser2" 79 | [ bgroup 80 | "Text" 81 | [ bench 82 | "array[1000]" 83 | (nf parseTextUpToErrorSuccess2 array1000) 84 | , bench 85 | "array[2000]" 86 | (nf parseTextUpToErrorSuccess2 array2000) 87 | , bench 88 | "array[4000]" 89 | (nf parseTextUpToErrorSuccess2 array4000) 90 | ] 91 | , bgroup 92 | "BS" 93 | [ bench 94 | "array[1000]" 95 | (nf parseTextUpToErrorSuccess2' array1000') 96 | , bench 97 | "array[2000]" 98 | (nf parseTextUpToErrorSuccess2' array2000') 99 | , bench 100 | "array[4000]" 101 | (nf parseTextUpToErrorSuccess2' array4000') 102 | ] 103 | , bgroup 104 | "Records" 105 | [ env 106 | (pure array) 107 | (\arr -> 108 | bench 109 | (show rows ++ 110 | " rows, " ++ 111 | show cols ++ 112 | " columns, " ++ 113 | getShortHand 114 | (getAppropriateUnits 115 | (ByteValue (fromIntegral (S.length array)) Bytes))) 116 | (nf parseTextUpToErrorSuccess2' arr)) 117 | | (cols :: Int, rows :: Int) <- 118 | [ (10, 1000) 119 | , (10, 2000) 120 | , (10, 10000) 121 | , (5, 10000) 122 | , (5, 20000) 123 | ] 124 | , let !record = 125 | "{" <> 126 | S.intercalate 127 | "," 128 | (replicate cols "aaaaaaaaaaaaaaaaaa: 12345678910") <> 129 | "}" 130 | , let !array = 131 | S.concat 132 | [ "[" 133 | , S.intercalate "," (replicate rows record) 134 | , "]" 135 | ] 136 | ] 137 | ] 138 | ] 139 | , bgroup 140 | "generateText" 141 | [ bench "array[1000]" (nf generateTextUpToErrorSuccess array1000) 142 | , bench "array[2000]" (nf generateTextUpToErrorSuccess array2000) 143 | , bench "array[4000]" (nf generateTextUpToErrorSuccess array4000) 144 | ] 145 | , bgroup 146 | "solveText" 147 | [ bench 148 | ("array[" <> show n <> "] SIG") 149 | (nfIO 150 | (do ref <- newSomeRef 0 151 | binds <- newSomeRef mempty 152 | RIO.runRIO 153 | (SolveReader {glogfunc = mempty, counter = ref, binds}) 154 | (solveTextUpToErrorSuccess array))) 155 | | (n, array) <- [(1000 :: Int, array1000), (1000 :: Int, array4000)] 156 | ] 157 | {-bgroup 158 | "normalFormCheck" 159 | [ env 160 | (case parseText "" array1000 of 161 | Left {} -> error "parse failed" 162 | Right ast -> pure $! (EqNF ast)) 163 | (bench "array[1000]" . nf NF.expressionGenerate . unNF) 164 | , env 165 | (case parseText "" array2000 of 166 | Left {} -> error "parse failed" 167 | Right ast -> pure $! (EqNF ast)) 168 | (bench "array[2000]" . nf NF.expressionGenerate . unNF) 169 | , env 170 | (case parseText "" array4000 of 171 | Left {} -> error "parse failed" 172 | Right ast -> pure $! (EqNF ast)) 173 | (bench "array[4000]" . nf NF.expressionGenerate . unNF) 174 | ]-} 175 | , bgroup 176 | "resolve" 177 | [ bgroup 178 | "resolveText" 179 | [ bench 180 | ("array[" <> show n <> "] SIG") 181 | (nfIO 182 | (do RIO.runRIO 183 | ResolveReader 184 | (resolveTextUpToErrorSuccess array))) 185 | | (n, array) <- 186 | [(1000 :: Int, array1000Sig), (4000 :: Int, array4000Sig)] 187 | ] 188 | , bgroup 189 | "resolveParsed" 190 | [ bench 191 | ("array[" <> show n <> "] SIG") 192 | (nf parseAndResolve array) 193 | | (n, array) <- 194 | [(1000 :: Int, array1000Sig), (4000 :: Int, array4000Sig)] 195 | ] 196 | ] 197 | ]) 198 | 199 | newtype EqNF a = EqNF { unNF :: a } 200 | instance Eq a => NFData (EqNF a) where 201 | rnf (EqNF a) = 202 | let !_ = a == a 203 | in () 204 | 205 | parseAndResolve :: Text -> Either () () 206 | parseAndResolve t = 207 | case Parser2.parseText "repl" t of 208 | Left e -> error (show e) 209 | Right e -> 210 | case resolveParsed e of 211 | Left e' -> error (show e') 212 | Right !_ -> Right () 213 | 214 | lexTextUpToErrorSuccess :: Text -> Either () () 215 | lexTextUpToErrorSuccess = first (const ()) . second (const ()) . lexText "" 216 | 217 | parseTextUpToErrorSuccess :: Text -> Either () () 218 | parseTextUpToErrorSuccess = first (const ()) . second (const ()) . parseText "" 219 | 220 | parseTextUpToErrorSuccess2 :: Text -> Either () () 221 | parseTextUpToErrorSuccess2 = first (const ()) . second (const ()) . Parser2.parseText "" 222 | 223 | parseTextUpToErrorSuccess2' :: ByteString -> Either () () 224 | parseTextUpToErrorSuccess2' = first (const ()) . second (const ()) . Parser2.parseBytes 225 | 226 | solveTextUpToErrorSuccess :: Text -> RIO SolveReader (Either () ()) 227 | solveTextUpToErrorSuccess = fmap (bimap (const ()) (const ())) . solveText mempty "" 228 | 229 | resolveTextUpToErrorSuccess :: 230 | Text 231 | -> RIO ResolveReader (Either () ()) 232 | resolveTextUpToErrorSuccess = 233 | fmap (bimap (const ()) (const ())) . resolveText mempty "" 234 | 235 | generateTextUpToErrorSuccess :: Text -> Either () () 236 | generateTextUpToErrorSuccess = bimap (const ()) (const ()) . generateText mempty "" 237 | 238 | sampleUnicode :: Text 239 | sampleUnicode = "! \" # $ % & ' ( ) * + , - . / 0 1 2 3 4 5 6 7 8 9 : ; < = > ? @ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z [ \\ ] ^ _ ` a b c d e f g h i j k l m n o p q r s t u v w x y z { | } ~ ¡ ¢ £ ¤ ¥ ¦ § ¨ © ª « ¬ ® ¯ ° ± ² ³ ´ µ ¶ · ¸ ¹ º » ¼ ½ ¾ ¿ À Á Â Ã Ä Å Æ Ç È É Ê Ë Ì Í Î Ï Ð Ñ Ò Ó Ô Õ Ö × Ø Ù Ú Û Ü Ý Þ ß à á â ã ä å æ ç è é ê ë ì í î ï ð ñ ò ó ô õ ö ÷ ø ù ú û ü ý þ ÿ Ā ā Ă ă Ą ą Ć ć Ĉ ĉ Ċ ċ Č č Ď ď Đ đ Ē ē Ĕ ĕ Ė ė Ę ę Ě ě Ĝ ĝ Ğ ğ Ġ ġ Ģ ģ Ĥ ĥ Ħ ħ Ĩ ĩ Ī ī Ĭ ĭ Į į İ ı IJ ij Ĵ ĵ Ķ ķ ĸ Ĺ ĺ Ļ ļ Ľ ľ Ŀ ŀ Ł ł Ń ń Ņ ņ Ň ň ʼn Ŋ ŋ Ō ō Ŏ ŏ Ő ő Œ œ Ŕ ŕ Ŗ ŗ Ř ř Ś ś Ŝ ŝ Ş ş Š š Ţ ţ Ť ť Ŧ ŧ Ũ ũ Ū ū Ŭ ŭ Ů ů Ű ű Ų ų Ŵ ŵ Ŷ ŷ Ÿ Ź ź Ż ż Ž ž ſ ƀ Ɓ Ƃ ƃ Ƅ ƅ Ɔ Ƈ ƈ Ɖ Ɗ Ƌ ƌ ƍ Ǝ Ə Ɛ Ƒ ƒ Ɠ Ɣ ƕ Ɩ Ɨ Ƙ ƙ ƚ ƛ Ɯ Ɲ ƞ Ɵ Ơ ơ Ƣ ƣ Ƥ ƥ Ʀ Ƨ ƨ Ʃ ƪ ƫ Ƭ ƭ Ʈ Ư ư Ʊ Ʋ Ƴ ƴ Ƶ ƶ Ʒ Ƹ ƹ ƺ ƻ Ƽ ƽ ƾ ƿ ǀ ǁ ǂ ǃ DŽ Dž dž LJ Lj lj NJ Nj nj Ǎ ǎ Ǐ ǐ Ǒ ǒ Ǔ ǔ Ǖ ǖ Ǘ ǘ Ǚ ǚ Ǜ ǜ ǝ Ǟ ǟ Ǡ ǡ Ǣ ǣ Ǥ ǥ Ǧ ǧ Ǩ ǩ Ǫ ǫ Ǭ ǭ Ǯ ǯ ǰ DZ Dz dz Ǵ ǵ Ǻ ǻ Ǽ ǽ Ǿ ǿ Ȁ ȁ Ȃ ȃ ɐ ɑ ɒ ɓ ɔ ɕ ɖ ɗ ɘ ə ɚ ɛ ɜ ɝ ɞ ɟ ɠ ɡ ɢ ɣ ɤ ɥ ɦ ɧ ɨ ɩ ɪ ɫ ɬ ɭ ɮ ɯ ɰ ɱ ɲ ɳ ɴ ɵ ɶ ɷ ɸ ɹ ɺ ɻ ɼ ɽ ɾ ɿ ʀ ʁ ʂ ʃ ʄ ʅ ʆ ʇ ʈ ʉ ʊ ʋ ʌ ʍ ʎ ʏ ʐ ʑ ʒ ʓ ʔ ʕ ʖ ʗ ʘ ʙ ʚ ʛ ʜ ʝ ʞ ʟ ʠ ʡ ʢ ʣ ʤ ʥ ʦ ʧ ʨ" 240 | -------------------------------------------------------------------------------- /inflex-lang/package.yaml: -------------------------------------------------------------------------------- 1 | name: inflex-lang 2 | version: 0 3 | 4 | dependencies: 5 | - hspec-expectations 6 | - syb 7 | - lexx 8 | - persistent 9 | - insert-ordered-containers 10 | - base >= 4.7 && < 5 11 | - genvalidity 12 | - QuickCheck 13 | - mutable-containers 14 | - unordered-containers 15 | - hashable 16 | - hspec 17 | - validity 18 | - cryptonite 19 | - genvalidity-property 20 | - genvalidity-hspec 21 | - text 22 | - megaparsec 23 | - reparsec 24 | - validation 25 | - mtl 26 | - transformers 27 | - semigroupoids 28 | - monad-validate 29 | - containers 30 | - optics 31 | - optics-core 32 | - template-haskell 33 | - bytestring 34 | - split 35 | - semigroupoids 36 | - aeson 37 | - memory 38 | - base16-bytestring 39 | - early 40 | - th-orphans 41 | - attoparsec 42 | - rio 43 | - uuid 44 | - parallel 45 | - vector 46 | - deepseq 47 | - th-lift 48 | - flatparse 49 | - byteunits 50 | - sdl2 51 | - persistent-sqlite 52 | 53 | ghc-options: -Wall 54 | 55 | library: 56 | source-dirs: src 57 | 58 | executables: 59 | inflex: 60 | main: Main.hs 61 | source-dirs: app 62 | ghc-options: 63 | - -threaded 64 | - -static 65 | cc-options: -static 66 | ld-options: -static -pthread 67 | dependencies: inflex-lang 68 | 69 | tests: 70 | inflex-lang-test: 71 | main: Spec.hs 72 | source-dirs: test 73 | ghc-options: 74 | - -threaded 75 | - -rtsopts 76 | - -with-rtsopts=-N 77 | dependencies: 78 | - inflex-lang 79 | 80 | benchmarks: 81 | inflex-lang-time: 82 | main: Time.hs 83 | source-dirs: bench 84 | ghc-options: 85 | - -O2 86 | - -threaded 87 | dependencies: 88 | - criterion 89 | - inflex-lang 90 | -------------------------------------------------------------------------------- /inflex-lang/src/Data/Decimal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | {-# LANGUAGE GADTs, PolyKinds #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE Rank2Types #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | {-# LANGUAGE PartialTypeSignatures #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE DataKinds, PolyKinds #-} 12 | {-# LANGUAGE KindSignatures #-} 13 | {-# LANGUAGE NamedFieldPuns #-} 14 | {-# LANGUAGE ExistentialQuantification #-} 15 | {-# LANGUAGE RecordWildCards #-} 16 | {-# LANGUAGE NamedFieldPuns #-} 17 | {-# LANGUAGE DeriveLift #-} 18 | 19 | -- | A dynamic-precision decimal type. The precision is fixed, but 20 | -- only known at runtime, making it easier to work with them. 21 | -- 22 | -- Highly inefficient, but easy to make efficient later. 23 | 24 | module Data.Decimal 25 | ( Decimal(..) 26 | , plus 27 | , minus 28 | , multiply 29 | , divide 30 | , decimalFromInteger 31 | , expandDecimalPrecision 32 | , someNaturalVal 33 | , showDecimal 34 | ) where 35 | 36 | import Data.Fixed 37 | import Data.Maybe 38 | import Data.Proxy 39 | import Data.String 40 | import GHC.Natural 41 | import GHC.TypeLits 42 | import Language.Haskell.TH.Syntax 43 | import qualified RIO 44 | 45 | -------------------------------------------------------------------------------- 46 | -- Types 47 | 48 | -- | Decimal backed by an Integer with N decimal places. Precision is 49 | -- determined at runtime. 50 | data Decimal = Decimal 51 | { places :: !Natural 52 | , integer :: !Integer 53 | } deriving (Show, Lift, Eq, Ord) 54 | 55 | instance RIO.Display Decimal where 56 | display = fromString . showDecimal 57 | 58 | -------------------------------------------------------------------------------- 59 | -- Operations 60 | 61 | plus :: Decimal -> Decimal -> Decimal 62 | plus Decimal {integer = a} Decimal {integer = b, ..} = 63 | Decimal {integer = a + b, ..} 64 | 65 | minus :: Decimal -> Decimal -> Decimal 66 | minus Decimal {integer = a} Decimal {integer = b, ..} = 67 | Decimal {integer = a - b, ..} 68 | 69 | multiply :: Decimal -> Decimal -> Decimal 70 | multiply Decimal {integer = a} Decimal {integer = b, ..} = 71 | Decimal {integer = div (a * b) (fromIntegral (placesToResolution places)), ..} 72 | 73 | divide :: Decimal -> Decimal -> Decimal 74 | divide Decimal {integer = a} Decimal {integer = b, ..} = 75 | Decimal {integer = div (a * (fromIntegral (placesToResolution places))) b, ..} 76 | 77 | -- | Convert an integer to a decimal of @places@. 78 | decimalFromInteger :: Integer -> Natural -> Decimal 79 | decimalFromInteger integer places = 80 | Decimal {integer = integer * (10 ^ places), places} 81 | 82 | -- | Set the decimal precision to larger @p@. 83 | expandDecimalPrecision :: Natural -> Decimal -> Decimal 84 | expandDecimalPrecision new Decimal {integer, places = old} = 85 | Decimal {places = new, integer = integer * (10 ^ (new - old))} 86 | 87 | -- | All naturals have a total conversion to SomeNat. 88 | someNaturalVal :: Natural -> SomeNat 89 | someNaturalVal = 90 | fromMaybe (error "someNaturalVal: impossible occurred. Report as bug.") . 91 | someNatVal . fromIntegral 92 | 93 | -------------------------------------------------------------------------------- 94 | -- Printing 95 | 96 | -- Helper type, only needed for showDecimal 97 | data Places (n :: Nat) 98 | instance KnownNat n => HasResolution (Places n) where 99 | resolution _ = natVal (Proxy @n) 100 | 101 | -- > showDecimal Decimal{integer=1250, places = 2} 102 | -- => 12.50 103 | showDecimal :: Decimal -> String 104 | showDecimal Decimal {places, integer} = 105 | case someNaturalVal (placesToResolution places) of 106 | SomeNat (_ :: Proxy p) -> 107 | showFixed False (MkFixed integer :: Fixed (Places p)) 108 | 109 | -------------------------------------------------------------------------------- 110 | -- Helpers 111 | 112 | placesToResolution :: Natural -> Natural 113 | placesToResolution n = 10 ^ n 114 | -------------------------------------------------------------------------------- /inflex-lang/src/Data/List/Extra.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | 4 | 5 | module Data.List.Extra where 6 | 7 | -- Like StateT but with return tuple swapped 8 | newtype StateM s m a = StateM { runStateM :: s -> m (s, a) } 9 | 10 | instance Functor m => Functor (StateM s m) where 11 | fmap f (StateM x) = StateM $ \s -> fmap (\(s', a) -> (s', f a)) (x s) 12 | 13 | instance 14 | #if __GLASGOW_HASKELL__ < 709 15 | (Functor m, Monad m) 16 | #else 17 | Monad m 18 | #endif 19 | => Applicative (StateM s m) where 20 | pure x = StateM $ \s -> return (s, x) 21 | StateM f <*> StateM x = StateM $ \s -> do (s', f') <- f s 22 | (s'', x') <- x s' 23 | return (s'', f' x') 24 | 25 | -- | Monadic variant of 'mapAccumL'. 26 | mapAccumM :: 27 | #if __GLASGOW_HASKELL__ < 709 28 | (Functor m, Monad m, Traversable t) 29 | #else 30 | (Monad m, Traversable t) 31 | #endif 32 | => (a -> b -> m (a, c)) -> a -> t b -> m (a, t c) 33 | mapAccumM f s t = runStateM (traverse (\x -> StateM (\s' -> f s' x)) t) s 34 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Decimal.hs: -------------------------------------------------------------------------------- 1 | -- | Handling of decimals. Now simply re-exports Data.Decimal. 2 | 3 | module Inflex.Decimal (module Data.Decimal) where 4 | 5 | import Data.Decimal 6 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Defaulter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TupleSections #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE NamedFieldPuns #-} 9 | {-# LANGUAGE DuplicateRecordFields #-} 10 | 11 | -- | Defaulting class instances that are ambiguous. 12 | 13 | module Inflex.Defaulter 14 | ( defaultText 15 | , defaultResolvedExpression 16 | , DefaulterError(..) 17 | , DefaulterReader(..) 18 | , ResolverDefaulterError(..) 19 | , cellInstances 20 | ) where 21 | 22 | import Control.Monad 23 | import Control.Monad.Trans 24 | import Control.Monad.Trans.Writer 25 | import Data.Bifunctor 26 | import Data.Foldable 27 | import Data.Functor.Identity 28 | import qualified Data.List.NonEmpty as NE 29 | import Data.Map.Strict (Map) 30 | import qualified Data.Map.Strict as M 31 | import Data.Sequence (Seq) 32 | import qualified Data.Sequence as Seq 33 | import Data.Set (Set) 34 | import qualified Data.Set as Set 35 | import Data.Text (Text) 36 | import Data.Void 37 | import Inflex.Defaulter.Suggest 38 | import Inflex.Resolver 39 | import Inflex.Type 40 | import Inflex.Types 41 | import Inflex.Types.Defaulter 42 | import RIO 43 | 44 | -------------------------------------------------------------------------------- 45 | -- Top-level entry points 46 | 47 | data DefaulterReader = DefaulterReader 48 | 49 | defaultText :: 50 | Map Hash (Either e (Scheme Polymorphic)) 51 | -> FilePath 52 | -> Text 53 | -> RIO DefaulterReader (Either (ResolverDefaulterError e) Cell) 54 | defaultText globals fp text = do 55 | resolved <- 56 | fmap 57 | (first GeneraliseResolverError) 58 | (runRIO ResolveReader (resolveText globals fp text)) 59 | case resolved of 60 | Left err -> pure (Left err) 61 | Right resolved' -> 62 | fmap (first DefaulterError) (defaultResolvedExpression resolved') 63 | 64 | defaultResolvedExpression :: 65 | IsResolved (Expression Resolved) 66 | -> RIO DefaulterReader (Either DefaulterError Cell) 67 | defaultResolvedExpression IsResolved {scheme = scheme0, thing = expression} = pure (do 68 | classConstraintReplacements <- generateReplacements scheme0 69 | (scheme', defaults) <- 70 | runWriterT 71 | (foldM 72 | (\scheme@Scheme {constraints = acc, typ} classConstraint -> 73 | case M.lookup classConstraint classConstraintReplacements of 74 | Nothing -> pure scheme {constraints = acc ++ [classConstraint]} 75 | Just replacements -> do 76 | let substitutions = Seq.fromList (toList replacements) 77 | classConstraint' = 78 | substituteClassConstraint substitutions classConstraint 79 | typ' = substituteType substitutions typ 80 | default' <- 81 | lift (makeValidDefault classConstraint classConstraint') 82 | tell (pure default') 83 | pure (scheme {constraints = acc, typ = typ'})) 84 | scheme0 {constraints = mempty} 85 | originalConstraints) 86 | pure 87 | Cell 88 | { location 89 | , scheme = scheme' 90 | , defaultedClassConstraints = defaults 91 | , ambiguousClassConstraints = mempty -- TODO: Provide this info. 92 | , defaulted = applyDefaults originalConstraints defaults expression 93 | }) 94 | where 95 | Scheme {constraints = originalConstraints, location} = scheme0 96 | 97 | -- | Generate replacements for each class constraint that can be generated. 98 | generateReplacements :: 99 | Scheme Polymorphic 100 | -> Either DefaulterError (Map (ClassConstraint Polymorphic) (Set Substitution)) 101 | generateReplacements scheme0 = do 102 | let typeVariableReplacements = 103 | M.mapMaybeWithKey 104 | (\_key constraints' -> 105 | runIdentity 106 | (fmap (fmap (constraints', )) (suggestTypeConstant constraints'))) 107 | constrainedDefaultableTypeVariables 108 | let classConstraintReplacements = 109 | M.fromListWith 110 | (<>) 111 | (concatMap 112 | (\(typeVariable, (constraints', typ)) -> 113 | map 114 | (\constraint -> 115 | ( constraint 116 | , Set.singleton 117 | (Substitution {before = typeVariable, after = typ}))) 118 | (toList constraints')) 119 | (M.toList typeVariableReplacements)) 120 | pure classConstraintReplacements 121 | where 122 | constrainedDefaultableTypeVariables = 123 | M.mapMaybe 124 | (NE.nonEmpty . toList) 125 | (M.intersectionWith 126 | (<>) 127 | (constraintedTypeVariables scheme0) 128 | (M.fromList 129 | (map (, mempty) (toList (defaultableTypeVariables scheme0))))) 130 | 131 | -------------------------------------------------------------------------------- 132 | -- Applying defaults 133 | 134 | -- | Traverse down the expression for each class constraint, and if 135 | -- there is a default for that class constraint, apply a dictionary 136 | -- argument to the lambda. If there's no default for that class 137 | -- constraint, we step down into the lambda and continue. 138 | applyDefaults :: 139 | [ClassConstraint Polymorphic] 140 | -> Seq (Default Polymorphic) 141 | -> Expression Resolved 142 | -> Expression Resolved 143 | applyDefaults [] _ = id 144 | applyDefaults (classConstraint:originalClassConstraints) defaults = 145 | \case 146 | LambdaExpression lambda@Lambda {body} -> 147 | immediatelyApplied 148 | (LambdaExpression 149 | (lambda {body = applyDefaults originalClassConstraints defaults body})) 150 | e -> error ("Unexpected expr: " ++ show e) -- TODO: Eliminate. 151 | where 152 | immediatelyApplied :: Expression Resolved -> Expression Resolved 153 | immediatelyApplied = 154 | case find 155 | (\Default {classConstraintOriginal} -> 156 | classConstraintOriginal == classConstraint) 157 | defaults of 158 | Nothing -> id 159 | Just Default {instanceName} -> 160 | \function -> 161 | ApplyExpression 162 | Apply 163 | { location = AutoInsertedForDefaulterCursor 164 | , typ = typeOutput (expressionType function) 165 | , function 166 | , argument = 167 | GlobalExpression 168 | Global 169 | { location = AutoInsertedForDefaulterCursor 170 | , scheme = 171 | ResolvedScheme (instanceNameType instanceName) 172 | , name = InstanceGlobal instanceName 173 | } 174 | , style = DefaulterApply 175 | } 176 | 177 | -------------------------------------------------------------------------------- 178 | -- Generating a default from a class constraint 179 | 180 | -- Uses Inflex.Resolver.resolveConstraint to check that the suggested 181 | -- types correctly produce an instance for the class constraint. 182 | -- 183 | -- If it produces a ResolutionError, that's a hard fail. If no instance 184 | -- is found, that's a hard fail. 185 | 186 | -- | We check to see whether the defaulted class constraint is valid. 187 | makeValidDefault :: 188 | ClassConstraint Polymorphic 189 | -> ClassConstraint Polymorphic 190 | -> Either DefaulterError (Default Polymorphic) 191 | makeValidDefault classConstraintOriginal classConstraintDefaulted = do 192 | resolutionSuccess <- 193 | first ResolutionError (resolvePolyConstraint classConstraintDefaulted) 194 | case resolutionSuccess of 195 | InstanceFound instanceName -> 196 | pure 197 | Default 198 | {classConstraintOriginal, classConstraintDefaulted, instanceName} 199 | NoInstanceButPoly noInstanceConstraint -> 200 | Left (DefaultingNoInstanceFound noInstanceConstraint) 201 | 202 | -------------------------------------------------------------------------------- 203 | -- Type variables mentioned in the class constraints 204 | 205 | -- | Access type variables via @constraintsTypeVariables@. 206 | constraintedTypeVariables :: 207 | Scheme Polymorphic 208 | -> Map (TypeVariable Polymorphic) (Set (ClassConstraint Polymorphic)) 209 | constraintedTypeVariables Scheme {constraints} = 210 | constraintsTypeVariablesPolymorphic constraints 211 | 212 | -------------------------------------------------------------------------------- 213 | -- Find type variables which can be defaulted 214 | 215 | -- | Produce the unique set of variables that may meaningfully be 216 | -- defaulted for a cell. 217 | -- 218 | -- I'm 90% sure that this is the right way to attack the problem of 219 | -- defaulting cells. But I don't know of a precedent in the 220 | -- literature/implementation world. 221 | -- 222 | -- Examples: 223 | -- 224 | -- (FromInteger a, FromDecimal b) => (a -> b) => {} 225 | -- (FromInteger a, FromDecimal b) => {x: a, y: b} => {a,b} 226 | -- (FromInteger a, FromDecimal b, FromDecimal c) => {x: a, y: c -> b} => {a} 227 | -- (FromDecimal b, FromDecimal c) => {x: c, y: c -> b} => {c} 228 | -- 229 | defaultableTypeVariables :: Scheme Polymorphic -> Set (TypeVariable Polymorphic) 230 | defaultableTypeVariables Scheme {typ} = typeVariables typ 231 | where 232 | typeVariables = 233 | \case 234 | FreshType v -> absurd v 235 | RecordType t -> typeVariables t 236 | VariantType t -> typeVariables t 237 | ArrayType t -> typeVariables t 238 | VariableType typeVariable -> Set.singleton typeVariable 239 | ApplyType TypeApplication {function, argument} -> 240 | case function of 241 | ConstantType TypeConstant {name = FunctionTypeName} -> 242 | mempty -- We ignore the whole function. 243 | _ -> typeVariables function <> typeVariables argument 244 | ConstantType {} -> mempty 245 | -- Below: we don't default row types. 246 | RowType TypeRow {typeVariable = _, fields} -> 247 | foldMap (\Field {typ=t} -> typeVariables t) fields 248 | 249 | -------------------------------------------------------------------------------- 250 | -- Substitution 251 | 252 | data Substitution = Substitution 253 | { before :: !(TypeVariable Polymorphic) 254 | , after :: !(Type Polymorphic) 255 | } deriving (Show, Eq, Ord) 256 | 257 | substituteClassConstraint :: 258 | Seq Substitution 259 | -> ClassConstraint Polymorphic 260 | -> ClassConstraint Polymorphic 261 | substituteClassConstraint substitutions ClassConstraint {..} = 262 | ClassConstraint {typ = fmap (substituteType substitutions) typ, ..} 263 | 264 | -- | TODO: This Seq is slow. Fix it! 265 | substituteType :: Seq Substitution -> Type Polymorphic -> Type Polymorphic 266 | substituteType substitutions = go 267 | where 268 | go = 269 | \case 270 | FreshType v -> absurd v 271 | RecordType t -> RecordType (go t) 272 | VariantType t -> VariantType (go t) 273 | ArrayType t -> ArrayType (go t) 274 | typ@ConstantType {} -> typ 275 | ApplyType TypeApplication {function, argument, ..} -> 276 | ApplyType 277 | TypeApplication {function = go function, argument = go argument, ..} 278 | RowType TypeRow {..} -> 279 | RowType TypeRow {fields = map fieldSub fields, ..} 280 | typ@(VariableType typeVariable :: Type Polymorphic) -> 281 | case find 282 | (\Substitution {before} -> before == typeVariable) 283 | substitutions of 284 | Just Substitution {after} -> after 285 | Nothing -> typ 286 | fieldSub Field {..} = Field {typ = substituteType substitutions typ, ..} 287 | 288 | defaultedInstance :: Default Polymorphic -> InstanceName 289 | defaultedInstance Default{instanceName} = instanceName 290 | 291 | cellInstances :: Cell1 -> Set InstanceName 292 | cellInstances Cell1 {defaultedClassConstraints} = 293 | Set.fromList (toList (fmap defaultedInstance defaultedClassConstraints)) 294 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Defaulter/Suggest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TupleSections #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE NamedFieldPuns #-} 9 | {-# LANGUAGE DuplicateRecordFields #-} 10 | 11 | -- | Suggest types for the defaulter. 12 | 13 | module Inflex.Defaulter.Suggest 14 | ( suggestTypeConstant 15 | , constraintsTypeVariablesGeneralised 16 | , constraintsTypeVariablesPolymorphic 17 | ) where 18 | 19 | import Data.Foldable 20 | import Data.Functor.Identity 21 | import Data.List 22 | import Data.List.NonEmpty (NonEmpty(..)) 23 | import Data.Map.Strict (Map) 24 | import qualified Data.Map.Strict as M 25 | import Data.Maybe 26 | import Data.Ord 27 | import Data.Set (Set) 28 | import qualified Data.Set as Set 29 | import Inflex.Types 30 | import Inflex.Types.Defaulter () 31 | import Numeric.Natural 32 | 33 | -------------------------------------------------------------------------------- 34 | -- Infer an appropriate defaulted type for a set of constraints 35 | 36 | -- | Given a set of constraints that are for a SINGLE type variable 37 | -- (and @FromDecimal 2 n@ counts, or @FromInteger n@), produce an 38 | -- appropriate constant type, for each, if possible. So we will have a 39 | -- set of type constants. At the end, choose the most appropriate type 40 | -- based on priority (see below). 41 | -- 42 | -- It's not the responsibility of this function to determine validity 43 | -- of instances. Just to produce a type @Integer@ or @Decimal n@. 44 | -- 45 | -- Order of priority: FromDecimal x > FromDecimal y > FromInteger, 46 | -- such that x > y. 47 | suggestTypeConstant :: 48 | forall s. (StagedLocation s ~ Cursor) 49 | => NonEmpty (ClassConstraint s) 50 | -- ^ All of them must only refer to THE SAME, SINGLE type 51 | -- variable. 52 | -> Identity (Maybe (Type Polymorphic)) 53 | suggestTypeConstant = 54 | fmap (listToMaybe . map snd . sortBy (flip (comparing fst)) . catMaybes) . 55 | traverse suggestedConstant . toList 56 | where 57 | suggestedConstant :: 58 | ClassConstraint s -> Identity (Maybe (Natural, Type Polymorphic)) 59 | suggestedConstant 60 | -- TODO: Reconsider this. Perhaps assume unit? {} 61 | = 62 | \case 63 | ClassConstraint {className = CompareClassName} -> 64 | pure 65 | (pure 66 | ( 0 -- Lowest priority. 67 | , ConstantType 68 | TypeConstant 69 | {location = DefaultedCursor, name = IntegerTypeName})) 70 | ClassConstraint {className = FromIntegerClassName} -> 71 | pure 72 | (pure 73 | ( 1 -- Second to lowest priority. 74 | , ConstantType 75 | TypeConstant 76 | {location = DefaultedCursor, name = IntegerTypeName})) 77 | ClassConstraint {className = FromDecimalClassName, typ = params} -> 78 | case params of 79 | ConstantType TypeConstant {name = NatTypeName places, location} :| [_] -> 80 | pure 81 | (pure 82 | ( 1 + places -- The +1 is due the Compare bumping everything up. 83 | , ApplyType 84 | TypeApplication 85 | { location = DefaultedCursor 86 | , kind = TypeKind 87 | , function = 88 | ConstantType 89 | TypeConstant 90 | { location = DefaultedCursor 91 | , name = DecimalTypeName 92 | } 93 | , argument = 94 | ConstantType 95 | TypeConstant 96 | {location, name = NatTypeName places} 97 | })) 98 | _ -> pure Nothing 99 | _ -> pure Nothing 100 | 101 | -- | Get type variables and each constraint that they're mentioned in, 102 | -- for a generalised type. 103 | constraintsTypeVariablesGeneralised :: 104 | Foldable t 105 | => t (ClassConstraint Generalised) 106 | -> Map (TypeVariable Generalised) (Set (ClassConstraint Generalised)) 107 | constraintsTypeVariablesGeneralised = constraintsTypeVariablesGeneric 108 | 109 | -- | Get type variables and each constraint that they're mentioned in, 110 | -- for a polymorphic type. 111 | constraintsTypeVariablesPolymorphic :: 112 | Foldable t 113 | => t (ClassConstraint Polymorphic) 114 | -> Map (TypeVariable Polymorphic) (Set (ClassConstraint Polymorphic)) 115 | constraintsTypeVariablesPolymorphic = constraintsTypeVariablesGeneric 116 | 117 | -- | Obtain the type variables mentioned in class constraints. 118 | -- 119 | -- Example: 120 | -- 121 | -- f(C a => C b => a -> b -> c) => {a,b} 122 | constraintsTypeVariablesGeneric :: 123 | forall s t. (Foldable t, Ord (TypeVariable s), Ord (ClassConstraint s)) 124 | => t (ClassConstraint s) 125 | -> Map (TypeVariable s) (Set (ClassConstraint s)) 126 | constraintsTypeVariablesGeneric constraints = 127 | M.fromListWith 128 | (<>) 129 | (concatMap 130 | (\classConstraint@ClassConstraint {typ = types} -> 131 | [ (typeVariable, Set.singleton classConstraint) 132 | | typeVariable <- toList (foldMap typeVariables types) 133 | ]) 134 | constraints) 135 | where 136 | typeVariables :: Type s -> Set (TypeVariable s) 137 | typeVariables = 138 | \case 139 | FreshType {} -> mempty 140 | RecordType t -> typeVariables t 141 | VariantType t -> typeVariables t 142 | ArrayType t -> typeVariables t 143 | -- For s=Polymorphic, this is not possible. For s=Generalised, 144 | -- this is not relevant. In both cases we only want 145 | -- VariableType, below. 146 | PolyType {} -> mempty 147 | VariableType typeVariable -> Set.singleton typeVariable 148 | ApplyType TypeApplication {function, argument} -> 149 | typeVariables function <> typeVariables argument 150 | ConstantType {} -> mempty 151 | RowType TypeRow {typeVariable = _, fields} 152 | -- maybe mempty Set.singleton typeVariable <> -- TODO: Check this is fine. 153 | -> foldMap (\Field {typ} -> typeVariables typ) fields 154 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Derived.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | Functions easily derived from primitive functions. 5 | 6 | module Inflex.Derived where 7 | 8 | import Inflex.Derived.TH 9 | import Inflex.Types 10 | 11 | nullFunction :: Expression Resolved 12 | nullFunction = $(compile "list: @prim:array_length(list) = (0::Integer)") 13 | 14 | from_okFunction :: Expression Resolved 15 | from_okFunction = $(compile "def: v: if (v) { #ok(a): a, _: def }") 16 | 17 | anyFunction :: Expression Resolved 18 | anyFunction = 19 | $(compile 20 | "pred: list: \ 21 | \ if (list.@prim:array_find(pred)) { \ 22 | \ #find_empty: #any_empty, \ 23 | \ #find_failed: #ok(#false), \ 24 | \ #ok(v): #ok(#true) \ 25 | \ }") 26 | 27 | notFunction :: Expression Resolved 28 | notFunction = $(compile "bool: if (bool) { #true: #false, #false: #true }") 29 | 30 | allFunction :: Expression Resolved 31 | allFunction = 32 | $(compile 33 | "pred: list: \ 34 | \ if (list.@prim:array_find(x: pred(x).@prim:not())) { \ 35 | \ #find_empty: #all_empty, \ 36 | \ #find_failed: #ok(#true), \ 37 | \ #ok(v): #ok(#false) \ 38 | \ }") 39 | 40 | scanFunction :: Expression Resolved 41 | scanFunction = 42 | $(compile 43 | "nil: cons: list: \ 44 | \ list.@prim:array_accum(\ 45 | \ nil, \ 46 | \ step: { item: cons(step.state,step.item), state: cons(step.state,step.item) }\ 47 | \ ).items") 48 | 49 | reduceFunction :: Expression Resolved 50 | reduceFunction = 51 | $(compile 52 | "nil: cons: list: \ 53 | \ list.@prim:array_accum(\ 54 | \ nil, \ 55 | \ step: { item: cons(step.state,step.item), state: cons(step.state,step.item) }\ 56 | \ ).state") 57 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Derived/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | -- | Helper to easily compile Inflex code at compile-time. 6 | 7 | module Inflex.Derived.TH where 8 | 9 | import Data.Text (Text) 10 | import Inflex.Printer 11 | import Inflex.Resolver 12 | import Language.Haskell.TH.Syntax 13 | import qualified RIO 14 | 15 | compile :: Text -> Q Exp 16 | compile src = do 17 | result <- runIO (RIO.runRIO ResolveReader (resolveText mempty "Derived" src)) 18 | case result of 19 | Left (err :: GeneraliseResolveError ()) -> error (show err) 20 | Right IsResolved {thing} -> tracePrinter emptyPrinterConfig thing (lift thing) 21 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Filler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE ApplicativeDo #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE LambdaCase #-} 9 | 10 | -- | Fill in globals. 11 | 12 | module Inflex.Filler where 13 | 14 | import qualified Data.Map.Strict as M 15 | import Data.Validation 16 | import Inflex.Types 17 | import Inflex.Types.Filler 18 | 19 | -------------------------------------------------------------------------------- 20 | -- Top-level entry points 21 | 22 | expressionFill :: 23 | FillerEnv e 24 | -> Expression Renamed 25 | -> Filler e (Expression Filled) 26 | expressionFill globals = 27 | \case 28 | RecordExpression record -> fmap RecordExpression (recordFill globals record) 29 | CaseExpression case' -> fmap CaseExpression (caseFill globals case') 30 | PropExpression prop -> fmap PropExpression (propFill globals prop) 31 | HoleExpression hole -> pure (HoleExpression (holeFill hole)) 32 | CellRefExpression cellRef -> fmap CellRefExpression (cellRefFill globals cellRef) 33 | ArrayExpression array -> fmap ArrayExpression (arrayFill globals array) 34 | VariantExpression variant -> fmap VariantExpression (variantFill globals variant) 35 | LiteralExpression literal -> pure (LiteralExpression (literalFill literal)) 36 | LambdaExpression lambda -> fmap LambdaExpression (lambdaFill globals lambda) 37 | InfixExpression infix' -> fmap InfixExpression (infixFill globals infix') 38 | ApplyExpression apply -> fmap ApplyExpression (applyFill globals apply) 39 | VariableExpression variable -> 40 | pure (VariableExpression (variableFill variable)) 41 | GlobalExpression global -> fmap GlobalExpression (globalFill globals global) 42 | 43 | -------------------------------------------------------------------------------- 44 | -- Fillers 45 | 46 | propFill :: FillerEnv e -> Prop Renamed -> Filler e (Prop Filled) 47 | propFill globals Prop {..} = do 48 | expression' <- expressionFill globals expression 49 | pure Prop {expression = expression', ..} 50 | 51 | arrayFill :: FillerEnv e -> Array Renamed -> Filler e (Array Filled) 52 | arrayFill globals Array {..} = do 53 | expressions' <- traverse (expressionFill globals) expressions 54 | pure Array {expressions = expressions', ..} 55 | 56 | variantFill :: FillerEnv e -> Variant Renamed -> Filler e (Variant Filled) 57 | variantFill globals Variant {..} = do 58 | argument' <- traverse (expressionFill globals) argument 59 | pure Variant {argument = argument', ..} 60 | 61 | recordFill :: FillerEnv e -> Record Renamed -> Filler e (Record Filled) 62 | recordFill globals Record {..} = do 63 | fields' <- traverse fieldFill fields 64 | pure Record {fields = fields', ..} 65 | where 66 | fieldFill FieldE {location = l, ..} = do 67 | expression' <- expressionFill globals expression 68 | pure FieldE {expression = expression', location = l, ..} 69 | 70 | caseFill :: FillerEnv e -> Case Renamed -> Filler e (Case Filled) 71 | caseFill globals Case {..} = do 72 | scrutinee' <- expressionFill globals scrutinee 73 | alternatives' <- traverse (alternativeFill globals) alternatives 74 | pure Case {alternatives = alternatives', scrutinee = scrutinee', ..} 75 | 76 | alternativeFill :: 77 | FillerEnv e 78 | -> Alternative Renamed 79 | -> Filler e (Alternative Filled) 80 | alternativeFill globals Alternative {location = l, ..} = do 81 | let pattern'' = patternFill pattern' 82 | expression' <- expressionFill globals expression 83 | pure 84 | Alternative 85 | {expression = expression', location = l, pattern' = pattern'', ..} 86 | where 87 | patternFill :: Pattern Renamed -> Pattern Filled 88 | patternFill = 89 | \case 90 | WildPattern Hole {..} -> WildPattern Hole {..} 91 | ParamPattern Param {..} -> ParamPattern Param {..} 92 | VariantPattern VariantP {argument, ..} -> 93 | VariantPattern VariantP {argument = fmap paramFill argument, ..} 94 | 95 | globalFill :: FillerEnv e -> Global Renamed -> Filler e (Global Filled) 96 | globalFill env@FillerEnv {namesTohash, uuidsToHash} Global {..} = do 97 | case name of 98 | ExactGlobalRef globalRef -> 99 | pure Global {scheme = FilledScheme, name = globalRef, ..} 100 | -- 101 | -- TODO: This is also old school, because the renamer could 102 | -- resolve this instead. Delete the UnresolvedUuid constructor, and 103 | -- then delete the WHOLE Filler module. All killer no filler. 104 | UnresolvedUuid uuid -> 105 | case M.lookup uuid uuidsToHash of 106 | Nothing -> Filler (Failure (pure (MissingGlobalUuid env uuid))) 107 | Just result -> do 108 | case result of 109 | Left e -> Filler (Failure (pure (OtherCellUuidError uuid e))) 110 | Right globalRef -> 111 | pure 112 | Global {name = HashGlobal globalRef, scheme = FilledScheme, ..} 113 | -- TODO: This is old school and can probably be removed, and make the 114 | -- renamer complain instead. 115 | UnresolvedGlobalText textName -> 116 | Filler (Failure (pure (MissingGlobal env textName))) 117 | -- TODO: This is old school too, because we only ever have exact UUIDs 118 | -- in scope for globals. So this can be removed too, we should delete the 119 | -- ResolvedGlobalRef constructor. 120 | ResolvedGlobalRef textName globalRef -> 121 | case M.lookup textName namesTohash of 122 | Nothing -> pure Global {scheme = FilledScheme, name = globalRef, ..} 123 | Just result -> do 124 | case result of 125 | Left e -> Filler (Failure (pure (OtherCellError textName e))) 126 | Right globalRef' -> 127 | pure 128 | Global {name = HashGlobal globalRef', scheme = FilledScheme, ..} 129 | 130 | cellRefFill :: FillerEnv e -> CellRef Renamed -> Filler e (CellRef Filled) 131 | cellRefFill env@FillerEnv {uuidsToHash} CellRef {..} = do 132 | case address of 133 | -- 134 | -- TODO: This is also old school, because the renamer could 135 | -- resolve this instead. Delete the UnresolvedUuid constructor, and 136 | -- then delete the WHOLE Filler module. All killer no filler. 137 | RefUuid uuid -> 138 | case M.lookup uuid uuidsToHash of 139 | Nothing -> Filler (Failure (pure (MissingGlobalUuid env uuid))) 140 | Just result -> do 141 | case result of 142 | Left e -> Filler (Failure (pure (OtherCellUuidError uuid e))) 143 | Right {} -> pure CellRef {..} 144 | 145 | lambdaFill :: 146 | FillerEnv e 147 | -> Lambda Renamed 148 | -> Filler e (Lambda Filled) 149 | lambdaFill globals Lambda {..} = do 150 | body' <- expressionFill globals body 151 | pure Lambda {body = body', param = paramFill param, ..} 152 | 153 | infixFill :: 154 | FillerEnv e 155 | -> Infix Renamed 156 | -> Filler e (Infix Filled) 157 | infixFill globals Infix {..} = do 158 | left' <- expressionFill globals left 159 | right' <- expressionFill globals right 160 | global' <- globalFill globals global 161 | pure Infix {left = left', right = right', global = global', ..} 162 | 163 | applyFill :: 164 | FillerEnv e 165 | -> Apply Renamed 166 | -> Filler e (Apply Filled) 167 | applyFill globals Apply {..} = do 168 | function' <- expressionFill globals function 169 | argument' <- expressionFill globals argument 170 | pure Apply 171 | { function = function' 172 | , argument = argument' 173 | , .. 174 | } 175 | 176 | variableFill :: 177 | Variable Renamed 178 | -> Variable Filled 179 | variableFill Variable {..} = Variable {..} 180 | 181 | literalFill :: 182 | Literal Renamed 183 | -> Literal Filled 184 | literalFill = 185 | \case 186 | NumberLiteral number -> 187 | NumberLiteral (numberFill number) 188 | TextLiteral LiteralText {..} -> 189 | TextLiteral LiteralText {..} 190 | 191 | numberFill :: 192 | Number Renamed 193 | -> Number Filled 194 | numberFill Number {..} = Number {..} 195 | 196 | paramFill :: 197 | Param Renamed 198 | -> Param Filled 199 | paramFill Param {..} = Param {..} 200 | 201 | holeFill :: 202 | Hole Renamed 203 | -> Hole Filled 204 | holeFill Hole {..} = Hole {..} 205 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Generaliser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE NamedFieldPuns #-} 7 | {-# LANGUAGE DuplicateRecordFields #-} 8 | 9 | -- | Generalise monomorphic types to poly types. 10 | 11 | module Inflex.Generaliser 12 | ( generaliseText 13 | , generaliseSolved 14 | , toPolymorphic 15 | , GeneraliseError(..) 16 | , SolveGeneraliseError(..) 17 | , IsGeneralised(..) 18 | , GeneraliseReader(..) 19 | ) where 20 | 21 | import Control.Monad.State 22 | import Data.Bifunctor 23 | import Data.List.NonEmpty (NonEmpty(..)) 24 | import Data.Map.Strict (Map) 25 | import qualified Data.Map.Strict as M 26 | import Data.Text (Text) 27 | import Data.Void 28 | import Inflex.Solver 29 | import Inflex.Type 30 | import Inflex.Types 31 | import Numeric.Natural 32 | import qualified RIO 33 | import RIO (RIO) 34 | 35 | -------------------------------------------------------------------------------- 36 | -- Generalizer types 37 | 38 | data GeneraliseError 39 | = OccursCheckFail (TypeVariable Generated) (Type Generated) 40 | | KindMismatch (TypeVariable Generated) (Type Generated) 41 | | TypeMismatch EqualityConstraint 42 | deriving (Show, Eq) 43 | 44 | data SolveGeneraliseError e 45 | = GeneraliserErrors (NonEmpty GeneraliseError) 46 | | SolverErrored (GenerateSolveError e) 47 | deriving (Show, Eq) 48 | 49 | data IsGeneralised a = IsGeneralised 50 | { thing :: !a 51 | , polytype :: !(Type Polymorphic) 52 | , mappings :: !(Map Cursor SourceLocation) 53 | } deriving (Show, Eq) 54 | 55 | data Substitution = Substitution 56 | { before :: !(TypeVariable Generated) 57 | , after :: !(Type Generated) 58 | } deriving (Show, Eq) 59 | 60 | data GeneraliseState = GeneraliseState 61 | { counter :: !Natural 62 | , replacements :: !(Map (TypeVariable Solved) (TypeVariable Polymorphic)) 63 | } 64 | 65 | data GeneraliseReader = 66 | GeneraliseReader 67 | 68 | -------------------------------------------------------------------------------- 69 | -- Top-level 70 | 71 | generaliseText :: 72 | Map Hash (Either e (Scheme Polymorphic)) 73 | -> FilePath 74 | -> Text 75 | -> RIO GeneraliseReader (Either (SolveGeneraliseError e) (IsGeneralised (Expression Generalised))) 76 | generaliseText globals fp text = do 77 | ref <- RIO.newSomeRef 0 78 | binds <- RIO.newSomeRef mempty 79 | solved <- 80 | fmap 81 | (first SolverErrored) 82 | (RIO.runRIO SolveReader {glogfunc = mempty {-TODO:-}, counter = ref, binds} (solveText globals fp text)) 83 | case solved of 84 | Left e -> pure (Left e) 85 | Right r -> generaliseSolved r 86 | 87 | generaliseSolved :: 88 | IsSolved (Expression Solved) 89 | -> RIO GeneraliseReader (Either (SolveGeneraliseError e) (IsGeneralised (Expression Generalised))) 90 | generaliseSolved IsSolved {thing, mappings} = do 91 | let (polytype, substitions) = toPolymorphic (expressionType thing) 92 | pure 93 | (pure 94 | IsGeneralised 95 | {mappings, thing = expressionGeneralise substitions thing, polytype}) 96 | 97 | -------------------------------------------------------------------------------- 98 | -- Polymorphise a type 99 | 100 | toPolymorphic :: Type Solved -> (Type Polymorphic, Map (TypeVariable Solved) (TypeVariable Polymorphic)) 101 | toPolymorphic = 102 | second replacements . 103 | flip runState GeneraliseState {counter = 0, replacements = mempty} . go 104 | where 105 | go = 106 | \case 107 | FreshType v -> absurd v 108 | RecordType t -> fmap RecordType (go t) 109 | VariantType t -> fmap VariantType (go t) 110 | ArrayType t -> fmap ArrayType (go t) 111 | RowType TypeRow {..} -> do 112 | fields' <- traverse rewriteField fields 113 | typeVariable' <- traverse polymorphizeTypeVar typeVariable 114 | pure 115 | (RowType 116 | TypeRow {fields = fields', typeVariable = typeVariable', ..}) 117 | VariableType typeVariable -> 118 | fmap VariableType (polymorphizeTypeVar typeVariable) 119 | ApplyType TypeApplication {function, argument, location, kind} -> do 120 | function' <- go function 121 | argument' <- go argument 122 | pure 123 | (ApplyType 124 | TypeApplication 125 | {function = function', argument = argument', location, kind}) 126 | ConstantType TypeConstant {..} -> pure (ConstantType TypeConstant {..}) 127 | rewriteField Field {..} = do 128 | typ' <- go typ 129 | pure Field {typ = typ', ..} 130 | polymorphizeTypeVar typeVariable@TypeVariable {kind} = do 131 | replacements <- gets replacements 132 | case M.lookup typeVariable replacements of 133 | Nothing -> do 134 | index <- gets Inflex.Generaliser.counter 135 | let typeVariable' = 136 | TypeVariable {index, prefix = (), location = (), kind} 137 | put 138 | (GeneraliseState 139 | { counter = index + 1 140 | , replacements = M.insert typeVariable typeVariable' replacements 141 | }) 142 | pure (typeVariable') 143 | Just replacement -> pure (replacement) 144 | 145 | -------------------------------------------------------------------------------- 146 | -- Generalising (i.e. substitution, but we also change the type from 147 | -- Solved to Generalised) 148 | 149 | generaliseType :: 150 | Map (TypeVariable Solved) (TypeVariable Polymorphic) 151 | -> Type Solved 152 | -> Type Generalised 153 | generaliseType substitutions = go 154 | where 155 | go = 156 | \case 157 | FreshType v -> absurd v 158 | RecordType t -> RecordType (go t) 159 | VariantType t -> VariantType (go t) 160 | ArrayType t -> ArrayType (go t) 161 | VariableType typeVariable@TypeVariable {..} -> 162 | case M.lookup typeVariable substitutions of 163 | Nothing -> VariableType TypeVariable {..} 164 | Just replacement -> PolyType replacement 165 | ApplyType TypeApplication {function, argument, ..} -> 166 | ApplyType 167 | TypeApplication {function = go function, argument = go argument, ..} 168 | ConstantType TypeConstant {..} -> ConstantType TypeConstant {..} 169 | RowType TypeRow {..} -> 170 | RowType 171 | TypeRow 172 | { fields = fmap fieldSolve fields 173 | , typeVariable = fmap typeVarSolve typeVariable 174 | , .. 175 | } 176 | fieldSolve Field {..} = Field {typ = generaliseType substitutions typ, ..} 177 | typeVarSolve TypeVariable {..} = TypeVariable {..} 178 | 179 | expressionGeneralise :: 180 | Map (TypeVariable Solved) (TypeVariable Polymorphic) 181 | -> Expression Solved 182 | -> Expression Generalised 183 | expressionGeneralise substitutions = 184 | \case 185 | LiteralExpression literal -> 186 | LiteralExpression (literalGeneralise substitutions literal) 187 | PropExpression prop -> 188 | PropExpression (propGeneralise substitutions prop) 189 | HoleExpression hole -> 190 | HoleExpression (holeGeneralise substitutions hole) 191 | CellRefExpression cellRef -> 192 | CellRefExpression (cellRefGeneralise substitutions cellRef) 193 | ArrayExpression array -> 194 | ArrayExpression (arrayGeneralise substitutions array) 195 | VariantExpression variant -> 196 | VariantExpression (variantGeneralise substitutions variant) 197 | RecordExpression record -> 198 | RecordExpression (recordGeneralise substitutions record) 199 | LambdaExpression lambda -> 200 | LambdaExpression (lambdaGeneralise substitutions lambda) 201 | CaseExpression case' -> 202 | CaseExpression (caseGeneralise substitutions case') 203 | InfixExpression infix' -> 204 | InfixExpression (infixGeneralise substitutions infix') 205 | ApplyExpression apply -> 206 | ApplyExpression (applyGeneralise substitutions apply) 207 | VariableExpression variable -> 208 | VariableExpression (variableGeneralise substitutions variable) 209 | GlobalExpression global -> 210 | GlobalExpression (globalGeneralise substitutions global) 211 | 212 | globalGeneralise :: Map (TypeVariable Solved) (TypeVariable Polymorphic) -> Global Solved -> Global Generalised 213 | globalGeneralise substitutions Global {scheme = SolvedScheme scheme, ..} = 214 | Global 215 | { scheme = GeneralisedScheme (generaliseScheme substitutions scheme) 216 | , name = refl 217 | , .. 218 | } 219 | where 220 | refl = 221 | case name of 222 | FunctionGlobal f -> FunctionGlobal f 223 | FromIntegerGlobal -> FromIntegerGlobal 224 | EqualGlobal e -> EqualGlobal e 225 | CompareGlobal e -> CompareGlobal e 226 | FromDecimalGlobal -> FromDecimalGlobal 227 | NumericBinOpGlobal n -> NumericBinOpGlobal n 228 | HashGlobal x -> HashGlobal x 229 | 230 | generaliseScheme :: Map (TypeVariable Solved) (TypeVariable Polymorphic) -> Scheme Solved -> Scheme Generalised 231 | generaliseScheme substitutions Scheme {..} = 232 | Scheme 233 | { typ = generaliseType substitutions typ 234 | , constraints = fmap (generaliseClassConstraint substitutions) constraints 235 | , .. 236 | } 237 | 238 | generaliseClassConstraint :: 239 | Map (TypeVariable Solved) (TypeVariable Polymorphic) 240 | -> ClassConstraint Solved 241 | -> ClassConstraint Generalised 242 | generaliseClassConstraint substitutions ClassConstraint {..} = 243 | ClassConstraint {typ = fmap (generaliseType substitutions) typ, ..} 244 | 245 | recordGeneralise :: 246 | Map (TypeVariable Solved) (TypeVariable Polymorphic) 247 | -> Record Solved 248 | -> Record Generalised 249 | recordGeneralise substitutions Record {..} = 250 | Record 251 | { fields = 252 | map 253 | (\FieldE {location = l, ..} -> 254 | FieldE 255 | { expression = expressionGeneralise substitutions expression 256 | , location = l 257 | , .. 258 | }) 259 | fields 260 | , typ = generaliseType substitutions typ 261 | , .. 262 | } 263 | 264 | propGeneralise :: 265 | Map (TypeVariable Solved) (TypeVariable Polymorphic) 266 | -> Prop Solved 267 | -> Prop Generalised 268 | propGeneralise substitutions Prop {..} = 269 | Prop 270 | { expression = expressionGeneralise substitutions expression 271 | , typ = generaliseType substitutions typ 272 | , .. 273 | } 274 | 275 | holeGeneralise :: 276 | Map (TypeVariable Solved) (TypeVariable Polymorphic) 277 | -> Hole Solved 278 | -> Hole Generalised 279 | holeGeneralise substitutions Hole {..} = 280 | Hole 281 | { typ = generaliseType substitutions typ 282 | , .. 283 | } 284 | 285 | cellRefGeneralise :: 286 | Map (TypeVariable Solved) (TypeVariable Polymorphic) 287 | -> CellRef Solved 288 | -> CellRef Generalised 289 | cellRefGeneralise substitutions CellRef {..} = 290 | CellRef 291 | { typ = generaliseType substitutions typ 292 | , .. 293 | } 294 | 295 | arrayGeneralise :: 296 | Map (TypeVariable Solved) (TypeVariable Polymorphic) 297 | -> Array Solved 298 | -> Array Generalised 299 | arrayGeneralise substitutions Array {..} = 300 | Array 301 | { expressions = fmap (expressionGeneralise substitutions) expressions 302 | , typ = generaliseType substitutions typ 303 | , .. 304 | } 305 | 306 | variantGeneralise :: 307 | Map (TypeVariable Solved) (TypeVariable Polymorphic) 308 | -> Variant Solved 309 | -> Variant Generalised 310 | variantGeneralise substitutions Variant {..} = 311 | Variant 312 | { argument = fmap (expressionGeneralise substitutions) argument 313 | , typ = generaliseType substitutions typ 314 | , .. 315 | } 316 | 317 | lambdaGeneralise :: 318 | Map (TypeVariable Solved) (TypeVariable Polymorphic) 319 | -> Lambda Solved 320 | -> Lambda Generalised 321 | lambdaGeneralise substitutions Lambda {..} = 322 | Lambda 323 | { param = paramGeneralise substitutions param 324 | , body = expressionGeneralise substitutions body 325 | , typ = generaliseType substitutions typ 326 | , .. 327 | } 328 | 329 | infixGeneralise :: 330 | Map (TypeVariable Solved) (TypeVariable Polymorphic) 331 | -> Infix Solved 332 | -> Infix Generalised 333 | infixGeneralise substitutions Infix {..} = 334 | Infix 335 | { left = expressionGeneralise substitutions left 336 | , right = expressionGeneralise substitutions right 337 | , global = globalGeneralise substitutions global 338 | , typ = generaliseType substitutions typ 339 | , .. 340 | } 341 | 342 | applyGeneralise :: 343 | Map (TypeVariable Solved) (TypeVariable Polymorphic) 344 | -> Apply Solved 345 | -> Apply Generalised 346 | applyGeneralise substitutions Apply {..} = 347 | Apply 348 | { function = expressionGeneralise substitutions function 349 | , argument = expressionGeneralise substitutions argument 350 | , typ = generaliseType substitutions typ 351 | , .. 352 | } 353 | 354 | caseGeneralise :: 355 | Map (TypeVariable Solved) (TypeVariable Polymorphic) 356 | -> Case Solved 357 | -> Case Generalised 358 | caseGeneralise substitutions Case {..} = 359 | Case 360 | { location 361 | , scrutinee = expressionGeneralise substitutions scrutinee 362 | , typ = generaliseType substitutions typ 363 | , alternatives = 364 | fmap 365 | (\Alternative {location = loc, ..} -> 366 | Alternative 367 | { pattern' = 368 | case pattern' of 369 | WildPattern hole -> 370 | WildPattern (holeGeneralise substitutions hole) 371 | ParamPattern param -> 372 | ParamPattern (paramGeneralise substitutions param) 373 | VariantPattern VariantP {location = locp, ..} -> 374 | VariantPattern 375 | VariantP 376 | { location = locp 377 | , tag 378 | , argument = fmap (paramGeneralise substitutions) argument 379 | } 380 | , expression = expressionGeneralise substitutions expression 381 | , location = loc 382 | , .. 383 | }) 384 | alternatives 385 | } 386 | 387 | variableGeneralise :: 388 | Map (TypeVariable Solved) (TypeVariable Polymorphic) 389 | -> Variable Solved 390 | -> Variable Generalised 391 | variableGeneralise substitutions Variable {..} = 392 | Variable {typ = generaliseType substitutions typ, ..} 393 | 394 | literalGeneralise :: 395 | Map (TypeVariable Solved) (TypeVariable Polymorphic) 396 | -> Literal Solved 397 | -> Literal Generalised 398 | literalGeneralise substitutions = 399 | \case 400 | TextLiteral LiteralText {..} -> 401 | TextLiteral LiteralText {typ = generaliseType substitutions typ, ..} 402 | NumberLiteral number -> 403 | NumberLiteral (numberGeneralise substitutions number) 404 | 405 | numberGeneralise :: 406 | Map (TypeVariable Solved) (TypeVariable Polymorphic) 407 | -> Number Solved 408 | -> Number Generalised 409 | numberGeneralise substitutions Number {..} = 410 | Number {typ = generaliseType substitutions typ, ..} 411 | 412 | paramGeneralise :: 413 | Map (TypeVariable Solved) (TypeVariable Polymorphic) 414 | -> Param Solved 415 | -> Param Generalised 416 | paramGeneralise substitutions Param {..} = 417 | Param {typ = generaliseType substitutions typ, ..} 418 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Kind.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# LANGUAGE DuplicateRecordFields #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | 7 | -- | Kind of a type. 8 | 9 | module Inflex.Kind where 10 | 11 | import Inflex.Types 12 | 13 | typeKind :: Type s -> Kind 14 | typeKind = 15 | \case 16 | VariableType typeVariable -> typeVariableKind typeVariable 17 | ApplyType typeApplication -> typeApplicationKind typeApplication 18 | ConstantType typeConstant -> typeConstantKind typeConstant 19 | PolyType typePoly -> typeVariableKind typePoly 20 | RowType {} -> RowKind 21 | RecordType {} -> TypeKind 22 | VariantType {} -> TypeKind 23 | ArrayType {} -> TypeKind 24 | FreshType{} -> TypeKind 25 | 26 | typeVariableKind :: TypeVariable s -> Kind 27 | typeVariableKind TypeVariable {kind} = kind 28 | 29 | typeApplicationKind :: TypeApplication s -> Kind 30 | typeApplicationKind TypeApplication {kind} = kind 31 | 32 | typeConstantKind :: TypeConstant s -> Kind 33 | typeConstantKind TypeConstant {name} = typeNameKind name 34 | 35 | typeNameKind :: TypeName -> Kind 36 | typeNameKind = 37 | \case 38 | IntegerTypeName -> TypeKind 39 | DecimalTypeName -> FunKind NatKind TypeKind 40 | TextTypeName -> TypeKind 41 | OptionTypeName -> FunKind TypeKind TypeKind 42 | FunctionTypeName -> FunKind TypeKind (FunKind TypeKind TypeKind) 43 | NatTypeName{} -> NatKind 44 | VegaTypeName -> TypeKind 45 | TupleTypeName -> FunKind RowKind TypeKind 46 | -- Rich 47 | RichDocTypeName -> TypeKind 48 | RichBlockTypeName -> TypeKind 49 | RichInlineTypeName -> TypeKind 50 | -- 51 | CellTypeName -> TypeKind 52 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Lexer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE OverloadedLabels #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE NamedFieldPuns #-} 9 | {-# LANGUAGE DeriveGeneric #-} 10 | {-# LANGUAGE DeriveTraversable #-} 11 | {-# LANGUAGE DeriveFoldable #-} 12 | {-# LANGUAGE DeriveFunctor #-} 13 | {-# LANGUAGE OverloadedStrings #-} 14 | 15 | -- | Lexer for Inflex language. 16 | 17 | module Inflex.Lexer 18 | ( Located(..) 19 | , Token(..) 20 | , SourcePos(..) 21 | , SourceLocation(..) 22 | , lexText 23 | , LexError 24 | , lexTextSingleton 25 | , _CellAddressToken 26 | , _NaturalToken 27 | , _DecimalToken 28 | , _BackslashToken 29 | , _RightArrowToken 30 | , _CamelCaseToken 31 | , _QuestionToken 32 | , _AnyWordToken 33 | , _OpenRoundToken 34 | , _CloseRoundToken 35 | , _OpenSquareToken 36 | , _CloseSquareToken 37 | , _OpenCurlyToken 38 | , _CloseCurlyToken 39 | , _LetToken 40 | , _InToken 41 | , _DoubleColonToken 42 | , _ColonToken 43 | , _SemiColonToken 44 | , _OperatorToken 45 | , _PeriodToken 46 | , _CommaToken 47 | , _StringToken 48 | , _HoleToken 49 | , _HashToken 50 | , _GlobalToken 51 | , _BarToken 52 | , _UnfoldToken 53 | , _FoldToken 54 | , lexTextPlusUUIDs 55 | ) where 56 | 57 | import Control.Monad 58 | import Data.Bifunctor 59 | import Data.Char 60 | import Data.Decimal 61 | import Data.Foldable 62 | import Data.Map.Strict (Map) 63 | import qualified Data.Map.Strict as M 64 | import Data.Maybe 65 | import Data.Sequence (Seq) 66 | import qualified Data.Sequence as Seq 67 | import Data.Set (Set) 68 | import qualified Data.Set as Set 69 | import Data.Text (Text) 70 | import qualified Data.Text as T 71 | import qualified Data.Text.Read as T 72 | import qualified Data.UUID as UUID 73 | import Data.Void 74 | import GHC.Generics 75 | import Inflex.Instances () 76 | import Inflex.Types 77 | import Inflex.Types.SHA512 78 | import Numeric.Natural 79 | import Optics 80 | import qualified Text.Megaparsec as Mega 81 | import qualified Text.Megaparsec.Char as Mega 82 | import qualified Text.Megaparsec.Char.Lexer as Lexer 83 | import Text.Megaparsec.Error 84 | 85 | -------------------------------------------------------------------------------- 86 | -- Types 87 | 88 | -- | Lex text into a series of Tokens. 89 | type Lexer = Mega.Parsec Void Text 90 | 91 | -- | Lexical tokens for the Inflex language. 92 | data Token 93 | = CamelCaseToken !Text 94 | | AnyWordToken !Text 95 | | OpenSquareToken 96 | | CloseSquareToken 97 | | OpenRoundToken 98 | | CloseRoundToken 99 | | NaturalToken !Natural 100 | | DecimalToken !Decimal 101 | | BackslashToken 102 | | RightArrowToken 103 | | DoubleColonToken 104 | | ColonToken 105 | | SemiColonToken 106 | | CommaToken 107 | | PeriodToken 108 | | LetToken 109 | | InToken 110 | | OpenCurlyToken 111 | | CloseCurlyToken 112 | | OperatorToken !Text 113 | | StringToken !Text 114 | | HoleToken 115 | | HashToken 116 | | QuestionToken 117 | | GlobalToken !ParsedGlobal 118 | | BarToken 119 | | FoldToken 120 | | UnfoldToken 121 | | CellAddressToken !CellAddress 122 | deriving (Show, Eq, Ord, Generic) 123 | 124 | -- | A located token. 125 | data Located l = Located 126 | { location :: SourceLocation 127 | , thing :: !l 128 | } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) 129 | 130 | data LexError = 131 | LexError (ParseErrorBundle Text Void) 132 | deriving (Show, Eq) 133 | 134 | -------------------------------------------------------------------------------- 135 | -- Entry points 136 | 137 | -- | Lex a given block of text. 138 | lexText :: FilePath -> Text -> Either LexError (Seq (Located Token)) 139 | lexText fp bs = 140 | first LexError (Mega.runParser (Mega.space *> tokensLexer <* Mega.eof) fp bs) 141 | 142 | -- | Lex a given block of text. 143 | lexTextSingleton :: Text -> Either LexError (Located Token) 144 | lexTextSingleton bs = 145 | first 146 | LexError 147 | (Mega.runParser (Mega.space *> tokenLexer <* Mega.eof) "single-token" bs) 148 | 149 | -- | Find UUIDs in a source text, so that we can find any 150 | -- dependencies. 151 | lexTextPlusUUIDs :: Text -> Either LexError (Seq (Located Token), Set Uuid) 152 | lexTextPlusUUIDs text = 153 | case lexText "" text of 154 | Left err -> Left err 155 | Right toks -> 156 | pure 157 | ( toks 158 | , Set.fromList 159 | (mapMaybe 160 | (\case 161 | Located {thing = GlobalToken (ParsedUuid uuid)} -> pure uuid 162 | Located {thing = CellAddressToken (RefUuid uuid)} -> pure uuid 163 | _ -> Nothing) 164 | (toList toks))) 165 | 166 | -------------------------------------------------------------------------------- 167 | -- Lexer 168 | 169 | -- | Lex unquoted regular code e.g. @let x = 1@. 170 | tokensLexer :: Lexer (Seq (Located Token)) 171 | tokensLexer = fmap Seq.fromList (Mega.many tokenLexer) 172 | 173 | -- | Lex a single token. 174 | tokenLexer :: Lexer (Located Token) 175 | tokenLexer = 176 | Mega.choice [ref, string, camelWord, anyWord, symbol, integer, decimal] <* 177 | Mega.space 178 | where 179 | ref = 180 | located 181 | (do void (Mega.char '@') 182 | cellRefParser Mega.<|> uuidRef Mega.<|> primRef Mega.<|> sha512Ref) 183 | where 184 | primRef = do 185 | void (Mega.string "prim:") 186 | txt <- 187 | Mega.takeWhile1P Nothing ((||) <$> isAlphaNum <*> flip elem ['_']) 188 | case M.lookup txt prims of 189 | Nothing -> 190 | case txt of 191 | "from_integer" -> pure (GlobalToken ParsedFromInteger) 192 | "from_decimal" -> pure (GlobalToken ParsedFromDecimal) 193 | _ -> fail ("Invalid primitive: " <> T.unpack txt) 194 | Just fun -> pure (GlobalToken (ParsedPrim fun)) 195 | -- E.g. @cell:uuid:1ea653f3-67f7-4fad-9892-85ce6cbf10a7 196 | cellRefParser = do 197 | void (Mega.string "cell:") 198 | ref' <- fmap RefUuid uuidParser 199 | pure (CellAddressToken ref') 200 | -- TODO: When this is supported in the UI: 201 | -- 202 | -- Mega.<|> fmap CellHash hashParser 203 | uuidRef = do 204 | txt <- uuidParser 205 | pure (GlobalToken (ParsedUuid txt)) 206 | uuidParser = do 207 | void (Mega.string "uuid:") 208 | uuidLexer 209 | hashParser = do 210 | void (Mega.string "sha512:") 211 | txt <- Mega.takeWhile1P Nothing isAlphaNum 212 | case sha512HexParser txt of 213 | Left e -> fail ("Invalid SHA512 hash: " ++ e) 214 | Right sha -> pure (Hash sha) 215 | sha512Ref = do 216 | hash <- hashParser 217 | pure (GlobalToken (ParsedHash hash)) 218 | string = 219 | located 220 | (do void (Mega.char '"') 221 | contents <- Mega.manyTill Mega.anySingle (Mega.char '"') 222 | pure (StringToken (T.pack contents))) 223 | camelWord = 224 | located 225 | (do c <- Mega.takeWhile1P Nothing ((&&) <$> isAlpha <*> isLower) 226 | cs <- 227 | Mega.takeWhileP Nothing ((||) <$> isAlphaNum <*> flip elem ['_']) 228 | let text = (c <> cs) 229 | case text of 230 | "let" -> pure LetToken 231 | "in" -> pure InToken 232 | _ -> pure (CamelCaseToken text)) 233 | anyWord = 234 | located 235 | (do c <- Mega.takeWhile1P Nothing isAlpha 236 | cs <- 237 | Mega.takeWhileP Nothing ((||) <$> isAlphaNum <*> flip elem ['_']) 238 | pure (AnyWordToken (c <> cs))) 239 | integer = 240 | Mega.try 241 | (located (NaturalToken <$> Lexer.decimal) <* 242 | Mega.notFollowedBy (void (Mega.char '.'))) 243 | decimal = 244 | located 245 | (do num <- Mega.takeWhile1P (pure "digit") isDigit 246 | void (Mega.char '.') 247 | denom <- Mega.takeWhile1P (pure "digit") isDigit 248 | case T.decimal (num <> denom) of 249 | Right (i, "") -> 250 | pure 251 | (DecimalToken 252 | Decimal 253 | {places = fromIntegral (T.length denom), integer = i}) 254 | _ -> fail "Invalid decimal.") 255 | symbol = 256 | located 257 | (Mega.choice 258 | [ HoleToken <$ Mega.char '_' 259 | , BarToken <$ Mega.char '|' 260 | , HashToken <$ Mega.char '#' 261 | , QuestionToken <$ Mega.char '?' 262 | , OpenSquareToken <$ Mega.char '[' 263 | , CloseSquareToken <$ Mega.char ']' 264 | , OpenCurlyToken <$ Mega.char '{' 265 | , CloseCurlyToken <$ Mega.char '}' 266 | , OpenRoundToken <$ Mega.char '(' 267 | , CloseRoundToken <$ Mega.char ')' 268 | , RightArrowToken <$ Mega.try (Mega.string "->") 269 | , OperatorToken <$> Mega.string "*" 270 | , OperatorToken <$> Mega.string "+" 271 | , OperatorToken <$> Mega.string "-" 272 | , OperatorToken <$> Mega.string ">=" 273 | , OperatorToken <$> Mega.string "<=" 274 | , OperatorToken <$> Mega.string "/=" 275 | , OperatorToken <$> Mega.string "<" 276 | , OperatorToken <$> Mega.string ">" 277 | , OperatorToken <$> Mega.string "=" 278 | , OperatorToken <$> Mega.string "/" 279 | , BackslashToken <$ Mega.char '\\' 280 | , DoubleColonToken <$ Mega.try (Mega.string "::") 281 | , SemiColonToken <$ Mega.try (Mega.string ";") 282 | , ColonToken <$ Mega.try (Mega.string ":") 283 | , CommaToken <$ Mega.try (Mega.char ',') 284 | , PeriodToken <$ Mega.try (Mega.char '.') 285 | ]) 286 | 287 | -- UUID consists of: 8-4-4-4-12 hexadecimal 288 | uuidLexer :: Lexer Uuid 289 | uuidLexer = do 290 | p1 <- Mega.takeP (Just "UUID component") 8 291 | dash_ 292 | p2 <- Mega.takeP (Just "UUID component") 4 293 | dash_ 294 | p3 <- Mega.takeP (Just "UUID component") 4 295 | dash_ 296 | p4 <- Mega.takeP (Just "UUID component") 4 297 | dash_ 298 | p5 <- Mega.takeP (Just "UUID component") 12 299 | let txt = T.concat [p1, "-", p2, "-", p3, "-", p4, "-", p5] 300 | case UUID.fromText txt of 301 | Nothing -> fail ("Invalid UUID: " <> T.unpack txt) 302 | Just uuid' -> pure (Uuid (UUID.toText uuid')) 303 | where 304 | dash_ = Mega.token (\char -> guard (char == '-')) mempty 305 | 306 | -- | Retain location information for a token. 307 | located :: Mega.MonadParsec e s m => m Token -> m (Located Token) 308 | located m = do 309 | start <- Mega.getSourcePos 310 | thing <- m 311 | end <- Mega.getSourcePos 312 | pure 313 | (Located 314 | { location = 315 | SourceLocation 316 | { end = 317 | SourcePos 318 | { line = Mega.unPos (Mega.sourceLine end) 319 | , column = Mega.unPos (Mega.sourceColumn end) 320 | , name = Mega.sourceName end 321 | } 322 | , start = 323 | SourcePos 324 | { line = Mega.unPos (Mega.sourceLine start) 325 | , column = Mega.unPos (Mega.sourceColumn start) 326 | , name = Mega.sourceName start 327 | } 328 | } 329 | , thing 330 | }) 331 | 332 | prims :: Map Text Function 333 | prims = 334 | M.fromList 335 | [ ("array_map", MapFunction) 336 | , ("array_filter", FilterFunction) 337 | , ("array_length", LengthFunction) 338 | , ("array_null", NullFunction) 339 | , ("vega_raw", VegaFunction) 340 | , ("array_sum", SumFunction) 341 | , ("array_average", AverageFunction) 342 | , ("array_distinct", DistinctFunction) 343 | , ("array_minimum", MinimumFunction) 344 | , ("array_maximum", MaximumFunction) 345 | , ("array_sort", SortFunction) 346 | , ("array_concat", ConcatFunction) 347 | , ("array_find", FindFunction) 348 | , ("array_any", AnyFunction) 349 | , ("array_all", AllFunction) 350 | , ("array_accum", AccumFunction) 351 | , ("array_scan", ScanFunction) 352 | , ("array_reduce", ReduceFunction) 353 | , ("from_ok", FromOkFunction) 354 | , ("not", NotFunction) 355 | 356 | -- Rich text 357 | , ( "rich_doc", RichDoc) 358 | , ( "rich_paragraph", RichParagraph) 359 | , ( "rich_text", RichText) 360 | , ( "rich_bold", RichBold) 361 | , ( "rich_italic", RichItalic) 362 | , ( "rich_link", RichLink) 363 | , ( "rich_cell", RichCell) 364 | ] 365 | 366 | $(makePrisms ''Token) 367 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Location.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | 5 | -- | 6 | 7 | module Inflex.Location where 8 | 9 | import Inflex.Types 10 | 11 | expressionLocation :: Expression s -> StagedLocation s 12 | expressionLocation = 13 | \case 14 | LiteralExpression literal -> literalLocation literal 15 | RecordExpression record -> recordLocation record 16 | PropExpression prop -> propLocation prop 17 | HoleExpression hole -> holeLocation hole 18 | VariantExpression variant -> variantLocation variant 19 | ArrayExpression array -> arrayLocation array 20 | LambdaExpression lambda -> lambdaLocation lambda 21 | CaseExpression case' -> caseLocation case' 22 | InfixExpression infix' -> infixLocation infix' 23 | GlobalExpression global -> globalLocation global 24 | ApplyExpression apply -> applyLocation apply 25 | VariableExpression variable -> variableLocation variable 26 | CellRefExpression ref -> cellRefLocation ref 27 | 28 | cellRefLocation :: CellRef s -> StagedLocation s 29 | cellRefLocation CellRef {location} = location 30 | 31 | lambdaLocation :: Lambda s -> StagedLocation s 32 | lambdaLocation Lambda {location} = location 33 | 34 | recordLocation :: Record s -> StagedLocation s 35 | recordLocation Record {location} = location 36 | 37 | propLocation :: Prop s -> StagedLocation s 38 | propLocation Prop {location} = location 39 | 40 | holeLocation :: Hole s -> StagedLocation s 41 | holeLocation Hole {location} = location 42 | 43 | variantLocation :: Variant s -> StagedLocation s 44 | variantLocation Variant {location} = location 45 | 46 | arrayLocation :: Array s -> StagedLocation s 47 | arrayLocation Array {location} = location 48 | 49 | paramLocation :: Param s -> StagedLocation s 50 | paramLocation Param {location} = location 51 | 52 | caseLocation :: Case s -> StagedLocation s 53 | caseLocation Case {location} = location 54 | 55 | infixLocation :: Infix s -> StagedLocation s 56 | infixLocation Infix {location} = location 57 | 58 | globalLocation :: Global s -> StagedLocation s 59 | globalLocation Global {location} = location 60 | 61 | applyLocation :: Apply s -> StagedLocation s 62 | applyLocation Apply {location} = location 63 | 64 | variableLocation :: Variable s -> StagedLocation s 65 | variableLocation Variable {location} = location 66 | 67 | literalLocation :: Literal s -> StagedLocation s 68 | literalLocation = 69 | \case 70 | NumberLiteral number -> numberLocation number 71 | TextLiteral LiteralText{location} -> location 72 | 73 | numberLocation :: Number s -> StagedLocation s 74 | numberLocation Number {location} = location 75 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/NormalFormCheck.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE DeriveGeneric, ScopedTypeVariables #-} 4 | {-# LANGUAGE BangPatterns #-} 5 | {-# LANGUAGE NamedFieldPuns, DuplicateRecordFields #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | 9 | -- | Type checker for normal form code. 10 | -- 11 | -- The idea being that checking code that is in normal form has a much 12 | -- faster algorithm for large arrays. 13 | -- 14 | -- We should be able to jump from Renamed straight to Resolved in one 15 | -- jump, with trivial unification. 16 | -- 17 | -- The type given is polymorphic (i.e. has polytypes). 18 | -- 19 | -- Normal form means: no if, no case, no globals (but that could 20 | -- change, e.g. if globals are normal form), no lambdas, no 21 | -- variables. Just atomics and lists, basically. 22 | -- 23 | -- Because we need proper Cursor info, we do cursor generation here 24 | -- rather than using the renamer. 25 | -- 26 | -- We perform in two stages. 27 | -- 28 | -- 1. Generate a type (elaboration) for the expression. 29 | -- 2. Apply the type to the expression. 30 | -- 31 | -- We have to do two steps because we don't know the full type until 32 | -- the end (due to numbers). 33 | 34 | module Inflex.NormalFormCheck 35 | ( resolveParsed 36 | , resolveParsedT 37 | , resolveParsedResolved 38 | , expressionGenerate 39 | , NormalFormCheckProblem(..) 40 | , T(..) 41 | ) where 42 | 43 | import Control.Monad 44 | import Control.Monad.State.Strict 45 | import Data.Coerce 46 | import qualified Data.HashMap.Strict as HM 47 | import Data.HashMap.Strict.InsOrd (InsOrdHashMap) 48 | import qualified Data.HashMap.Strict.InsOrd as OM 49 | import qualified Data.List as List 50 | import Data.Map.Strict (Map) 51 | import qualified Data.Map.Strict as M 52 | import Data.Maybe 53 | import Data.Text (Text) 54 | import Data.Traversable 55 | import GHC.Generics 56 | import GHC.Natural 57 | import Inflex.Decimal 58 | import Inflex.Generator 59 | import Inflex.Location 60 | import Inflex.Parser2 61 | import Inflex.Type 62 | import Inflex.Types 63 | import Inflex.Types.Generator 64 | import Inflex.Types.Resolver 65 | 66 | -------------------------------------------------------------------------------- 67 | -- Types 68 | 69 | data NormalFormCheckProblem 70 | = NotNormalForm 71 | | TypeMismatch !T !T 72 | | RecordFieldsMismatch [FieldName] [FieldName] 73 | | NoTypeSig 74 | | CouldntInternType (Type Parsed) 75 | deriving (Show, Eq, Generic) 76 | 77 | data T 78 | = ArrayT !(Maybe T) 79 | | RecordT !(InsOrdHashMap FieldName T) 80 | | VariantT !(InsOrdHashMap TagName T) 81 | | IntegerT 82 | | DecimalT !Natural 83 | | TextT 84 | deriving (Show, Eq, Generic) 85 | 86 | -------------------------------------------------------------------------------- 87 | -- REPL testing 88 | 89 | _replText :: Text -> IO () 90 | _replText t = 91 | case parseText "repl" t of 92 | Left e -> error (show e) 93 | Right e -> 94 | case resolveParsed e of 95 | Left e' -> error (show e') 96 | Right a -> print a 97 | 98 | -------------------------------------------------------------------------------- 99 | -- Top-level interface 100 | 101 | -- | This function only works when an expression has an explicit type 102 | -- signature, which has only monomorphic types. Also ensures that the 103 | -- type sig matches the inferred type. 104 | resolveParsed :: 105 | Expression Parsed -> Either NormalFormCheckProblem (Expression Resolved) 106 | resolveParsed expression = 107 | case expressionType expression of 108 | Nothing -> Left NoTypeSig 109 | Just typ -> 110 | case toT typ of 111 | Nothing -> Left (CouldntInternType typ) 112 | Just sigT -> do 113 | inferredT <- expressionGenerate expression 114 | finalT <- oneWayUnifyT sigT inferredT 115 | evalStateT (apply expression (toTypeMono finalT)) mempty 116 | 117 | -- | This function only works when an expression has an explicit type 118 | -- signature, which has only monomorphic types. Also ensures that the 119 | -- type sig matches the inferred type. 120 | resolveParsedResolved :: 121 | Expression Parsed 122 | -> Either NormalFormCheckProblem (IsResolved (Expression Resolved)) 123 | resolveParsedResolved expression = 124 | case expressionType expression of 125 | Nothing -> Left NoTypeSig 126 | Just typ -> 127 | case toT typ of 128 | Nothing -> Left (CouldntInternType typ) 129 | Just sigT -> do 130 | inferredT <- expressionGenerate expression 131 | finalT <- oneWayUnifyT sigT inferredT 132 | (thing, mappings) <- runStateT (apply expression (toTypeMono finalT)) mempty 133 | pure 134 | IsResolved 135 | { thing 136 | , scheme = 137 | Scheme 138 | { location = BuiltIn 139 | , constraints = [] 140 | , typ = toTypePoly finalT 141 | } 142 | , mappings 143 | } 144 | 145 | -- | Same as 'resolveParsed', but returns the T. 146 | resolveParsedT :: 147 | Expression Parsed -> Either NormalFormCheckProblem T 148 | resolveParsedT expression = 149 | case expressionType expression of 150 | Nothing -> Left NoTypeSig 151 | Just typ -> 152 | case toT typ of 153 | Nothing -> Left (CouldntInternType typ) 154 | Just sigT -> do 155 | inferredT <- expressionGenerate expression 156 | finalT <- oneWayUnifyT sigT inferredT 157 | pure finalT 158 | 159 | -------------------------------------------------------------------------------- 160 | -- Generation 161 | 162 | expressionGenerate :: Expression Parsed -> Either NormalFormCheckProblem T 163 | expressionGenerate = 164 | \case 165 | LiteralExpression literal -> pure $! (literalGenerator literal) 166 | ArrayExpression array -> arrayGenerate array 167 | RecordExpression record -> fmap RecordT (recordGenerate record) 168 | VariantExpression variant -> variantGenerate variant 169 | -- The rest of these are not normal form. We only consider the above cases. 170 | LambdaExpression {} -> Left NotNormalForm 171 | CellRefExpression {} -> Left NotNormalForm 172 | ApplyExpression {} -> Left NotNormalForm 173 | VariableExpression {} -> Left NotNormalForm 174 | GlobalExpression {} -> Left NotNormalForm 175 | InfixExpression {} -> Left NotNormalForm 176 | PropExpression {} -> Left NotNormalForm 177 | HoleExpression {} -> Left NotNormalForm 178 | CaseExpression {} -> Left NotNormalForm 179 | 180 | recordGenerate :: 181 | Record Parsed -> Either NormalFormCheckProblem (InsOrdHashMap FieldName T) 182 | recordGenerate Record {fields} = 183 | fmap 184 | OM.fromList 185 | (traverse 186 | (\FieldE {name, expression} -> do 187 | t <- expressionGenerate expression 188 | pure (name, t)) 189 | fields) 190 | 191 | variantGenerate :: 192 | Variant Parsed -> Either NormalFormCheckProblem T 193 | variantGenerate Variant {tag, argument} = do 194 | mtyp <- for argument expressionGenerate 195 | pure (VariantT (OM.singleton tag (fromMaybe nullT mtyp))) 196 | 197 | -- TODO: Parallelism? 198 | arrayGenerate :: Array Parsed -> Either NormalFormCheckProblem T 199 | arrayGenerate Array {expressions} = 200 | foldM 201 | (\prev expression -> do 202 | next <- fmap (ArrayT . pure) (expressionGenerate expression) 203 | unifyT prev next) 204 | (ArrayT Nothing) 205 | expressions 206 | 207 | literalGenerator :: Literal Parsed -> T 208 | literalGenerator = 209 | \case 210 | NumberLiteral Number {number} -> someNumberType number 211 | TextLiteral {} -> TextT 212 | 213 | someNumberType :: SomeNumber -> T 214 | someNumberType = 215 | \case 216 | IntegerNumber {} -> IntegerT 217 | DecimalNumber Decimal {places} -> DecimalT places 218 | 219 | nullT :: T 220 | nullT = RecordT mempty 221 | 222 | -------------------------------------------------------------------------------- 223 | -- Fast unification 224 | 225 | unifyT :: T -> T -> Either NormalFormCheckProblem T 226 | unifyT TextT TextT = pure TextT 227 | unifyT IntegerT IntegerT = pure IntegerT 228 | -- Arrays might be empty, and therefore without a type. Just take 229 | -- whatever side has something. 230 | unifyT (ArrayT Nothing) (ArrayT y) = pure (ArrayT y) 231 | unifyT (ArrayT x) (ArrayT Nothing) = pure (ArrayT x) 232 | unifyT (ArrayT (Just x)) (ArrayT (Just y)) = fmap (ArrayT . pure) (unifyT x y) 233 | -- Records: 234 | unifyT (RecordT x) (RecordT y) = 235 | if HM.keys (OM.toHashMap x) == HM.keys (OM.toHashMap y) 236 | then do 237 | !m <- 238 | fmap 239 | OM.fromList 240 | (traverse 241 | (\((k1, v1), v2) -> do 242 | t <- unifyT v1 v2 243 | pure (k1, t)) 244 | (zip (HM.toList (OM.toHashMap x)) (HM.elems (OM.toHashMap y)))) 245 | pure (RecordT m) 246 | else Left (RecordFieldsMismatch (OM.keys x) (OM.keys y)) 247 | -- Variants: 248 | unifyT (VariantT x) (VariantT y) = do 249 | z <- 250 | sequence 251 | (OM.unionWith 252 | (\x' y' -> join (unifyT <$> x' <*> y')) 253 | (fmap pure x) 254 | (fmap pure y)) 255 | pure (VariantT z) 256 | -- Promotion of integer to decimal: 257 | unifyT IntegerT (DecimalT n) = pure (DecimalT n) 258 | unifyT (DecimalT n) IntegerT = pure (DecimalT n) 259 | -- Promotion of smaller decimal to larger decimal: 260 | unifyT (DecimalT x) (DecimalT y) = pure (DecimalT n) 261 | where !n = max x y 262 | unifyT x y = Left (TypeMismatch x y) 263 | 264 | -------------------------------------------------------------------------------- 265 | -- One-way unification 266 | 267 | -- Left side is rigid. 268 | oneWayUnifyT :: T -> T -> Either NormalFormCheckProblem T 269 | oneWayUnifyT TextT TextT = pure TextT 270 | oneWayUnifyT IntegerT IntegerT = pure IntegerT 271 | -- Arrays might be empty, and therefore without a type. Just take 272 | -- whatever side has something. 273 | oneWayUnifyT (ArrayT Nothing) (ArrayT y) = pure (ArrayT y) 274 | oneWayUnifyT (ArrayT x) (ArrayT Nothing) = pure (ArrayT x) 275 | oneWayUnifyT (ArrayT (Just x)) (ArrayT (Just y)) = fmap (ArrayT . pure) (oneWayUnifyT x y) 276 | -- Records: 277 | oneWayUnifyT (RecordT x) (RecordT y) = 278 | if HM.keys (OM.toHashMap x) == HM.keys (OM.toHashMap y) 279 | then do 280 | !m <- 281 | fmap 282 | OM.fromList 283 | (traverse 284 | (\((k1, v1), v2) -> do 285 | t <- oneWayUnifyT v1 v2 286 | pure (k1, t)) 287 | (zip (HM.toList (OM.toHashMap x)) (HM.elems (OM.toHashMap y)))) 288 | pure (RecordT m) 289 | else Left (RecordFieldsMismatch (OM.keys x) (OM.keys y)) 290 | -- Variants: 291 | oneWayUnifyT (VariantT x) (VariantT y) = do 292 | z <- 293 | sequence 294 | (OM.unionWith 295 | (\x' y' -> join (oneWayUnifyT <$> x' <*> y')) 296 | (fmap pure x) 297 | (fmap pure y)) 298 | pure (VariantT z) 299 | -- Promotion of integer to decimal: 300 | oneWayUnifyT (DecimalT n) IntegerT = pure (DecimalT n) 301 | -- Promotion of smaller decimal to larger decimal: 302 | oneWayUnifyT (DecimalT x) (DecimalT y) | x >= y = pure (DecimalT x) 303 | oneWayUnifyT x y = Left (TypeMismatch x y) 304 | 305 | -------------------------------------------------------------------------------- 306 | -- Conversion to Real(tm) types 307 | 308 | toTypeMono :: T -> Type Generalised 309 | toTypeMono = 310 | flip evalState (GenerateState {counter = 0, equalityConstraints = mempty}) . 311 | go 312 | where 313 | go :: T -> State GenerateState (Type Generalised) 314 | go = 315 | \case 316 | IntegerT -> pure integerT 317 | DecimalT n -> pure (decimalT n) 318 | TextT -> pure textT 319 | ArrayT (Just t) -> fmap ArrayType (go t) 320 | ArrayT Nothing -> 321 | fmap 322 | ArrayType 323 | (generateVariableType BuiltIn ArrayElementPrefix TypeKind) 324 | VariantT fs -> do 325 | fs' <- 326 | traverse 327 | (\(TagName name, typ) -> do 328 | typ' <- go typ 329 | pure 330 | Field 331 | { location = BuiltIn 332 | , name = FieldName name 333 | , typ = typ' 334 | }) 335 | (OM.toList fs) 336 | var <- generateTypeVariable BuiltIn VariantRowVarPrefix RowKind 337 | pure 338 | (VariantType 339 | (RowType 340 | TypeRow 341 | {location = BuiltIn, typeVariable = Just var, fields = fs'})) 342 | RecordT fs -> do 343 | fs' <- 344 | traverse 345 | (\(name, typ) -> do 346 | typ' <- go typ 347 | pure Field {location = BuiltIn, name, typ = typ'}) 348 | (OM.toList fs) 349 | pure 350 | (RecordType 351 | (RowType 352 | TypeRow 353 | {location = BuiltIn, typeVariable = Nothing, fields = fs'})) 354 | 355 | toTypePoly :: T -> Type Polymorphic 356 | toTypePoly = 357 | flip evalState (GenerateState {counter = 0, equalityConstraints = mempty}) . 358 | go 359 | where 360 | go :: T -> State GenerateState (Type Polymorphic) 361 | go = 362 | \case 363 | IntegerT -> pure integerT 364 | DecimalT n -> pure (decimalT n) 365 | TextT -> pure textT 366 | ArrayT (Just t) -> fmap ArrayType (go t) 367 | ArrayT Nothing -> 368 | fmap 369 | ArrayType 370 | (generateVariableType () () TypeKind) 371 | VariantT fs -> do 372 | fs' <- 373 | traverse 374 | (\(TagName name, typ) -> do 375 | typ' <- go typ 376 | pure 377 | Field 378 | { location = BuiltIn 379 | , name = FieldName name 380 | , typ = typ' 381 | }) 382 | (OM.toList fs) 383 | var <- generateTypeVariable () () RowKind 384 | pure 385 | (VariantType 386 | (RowType 387 | TypeRow 388 | {location = BuiltIn, typeVariable = Just var, fields = fs'})) 389 | RecordT fs -> do 390 | fs' <- 391 | traverse 392 | (\(name, typ) -> do 393 | typ' <- go typ 394 | pure Field {location = BuiltIn, name, typ = typ'}) 395 | (OM.toList fs) 396 | pure 397 | (RecordType 398 | (RowType 399 | TypeRow 400 | {location = BuiltIn, typeVariable = Nothing, fields = fs'})) 401 | 402 | -------------------------------------------------------------------------------- 403 | -- Application 404 | 405 | -- 406 | -- Consideration: let's handle polymorphism LATER. Make monomorphic 407 | -- types work first with a type sig. Then worry about generalization 408 | -- later. 409 | -- 410 | apply :: 411 | Expression Parsed 412 | -> Type Generalised 413 | -> StateT (Map Cursor SourceLocation) (Either NormalFormCheckProblem) (Expression Resolved) 414 | apply e@(LiteralExpression literal) typ = do 415 | location <- generateCursor e 416 | pure 417 | (LiteralExpression 418 | (case literal of 419 | NumberLiteral number -> 420 | NumberLiteral (increasePrecisionNumber location number typ) 421 | TextLiteral text -> TextLiteral text {typ, location})) 422 | -- TODO: Parallelism? 423 | apply e@(ArrayExpression array@Array {expressions}) (ArrayType typ) = do 424 | location <- generateCursor e 425 | expressions' <- traverse (flip apply typ) expressions 426 | pure 427 | (ArrayExpression 428 | array 429 | { expressions = expressions' 430 | , location 431 | , typ = ArrayType typ 432 | , form = Evaluated 433 | }) 434 | -- TODO: Parallelism? 435 | apply e@(RecordExpression record@Record {fields}) typ@(RecordType (RowType TypeRow {fields = types})) = do 436 | location <- generateCursor e 437 | fields' <- 438 | traverse 439 | (\FieldE {expression, name, location = location', ..} -> do 440 | case List.find (\Field{name = name'} -> name == name') types of 441 | Nothing -> error "TODO: This is a bug." 442 | Just Field{typ=typ'} -> do 443 | location'' <- generateCursorFromLocation location' 444 | expression' <- apply expression typ' 445 | pure FieldE {expression = expression', location = location'', ..}) 446 | fields 447 | pure 448 | (RecordExpression 449 | record {fields = fields', typ, location}) 450 | apply e@(VariantExpression variant@Variant {argument, tag}) typ@(VariantType (RowType TypeRow {fields = types})) = do 451 | location <- generateCursor e 452 | argument' <- 453 | traverse 454 | (\expression -> do 455 | case List.find (\Field {name} -> tag == coerce name) types of 456 | Nothing -> error "TODO: This is a bug. [variant]" 457 | Just Field {typ = typ'} -> do 458 | expression' <- apply expression typ' 459 | pure expression') 460 | argument 461 | pure 462 | (VariantExpression variant {argument = argument', location, typ}) 463 | apply _ _ = lift $ Left NotNormalForm 464 | 465 | increasePrecisionNumber :: Cursor -> Number s -> Type Generalised -> Number Resolved 466 | increasePrecisionNumber location number@Number {number = someNumber} typ = 467 | number 468 | { typ 469 | , location 470 | , number = 471 | case someNumber of 472 | IntegerNumber i 473 | | ApplyType TypeApplication { function = ConstantType TypeConstant {name = DecimalTypeName} 474 | , argument = ConstantType (TypeConstant {name = NatTypeName nat}) 475 | } <- typ -> 476 | DecimalNumber (decimalFromInteger i nat) 477 | DecimalNumber d@Decimal {places} 478 | | ApplyType TypeApplication { function = ConstantType TypeConstant {name = DecimalTypeName} 479 | , argument = ConstantType (TypeConstant {name = NatTypeName nat}) 480 | } <- typ 481 | , nat /= places -> DecimalNumber (expandDecimalPrecision nat d) 482 | _ -> someNumber 483 | } 484 | 485 | -------------------------------------------------------------------------------- 486 | -- Get NF type from general type 487 | 488 | toT :: Type Parsed -> Maybe T 489 | toT = 490 | \case 491 | ConstantType TypeConstant {name = IntegerTypeName} -> pure IntegerT 492 | ConstantType TypeConstant {name = TextTypeName} -> pure TextT 493 | ApplyType TypeApplication { function = ConstantType TypeConstant {name = DecimalTypeName} 494 | , argument = ConstantType (TypeConstant {name = NatTypeName nat}) 495 | } -> pure (DecimalT nat) 496 | ArrayType t -> do 497 | a <- toT t 498 | pure (ArrayT (pure a)) 499 | -- TODO: Examine whether to preserve the row variable for variants. 500 | VariantType (RowType (TypeRow {typeVariable = _, fields = fs})) -> do 501 | fs' <- 502 | traverse 503 | (\Field{typ, name = FieldName name} -> do 504 | t' <- toT typ 505 | pure (TagName name, t')) 506 | fs 507 | pure (VariantT (OM.fromList fs')) 508 | RecordType (RowType (TypeRow {typeVariable = Nothing, fields = fs})) -> do 509 | fs' <- 510 | traverse 511 | (\Field{typ, name} -> do 512 | t' <- toT typ 513 | pure (name, t')) 514 | fs 515 | pure (RecordT (OM.fromList fs')) 516 | _ -> Nothing 517 | 518 | -------------------------------------------------------------------------------- 519 | -- Generating cursors 520 | 521 | generateCursor :: 522 | Monad m => Expression Parsed -> StateT (Map Cursor SourceLocation) m Cursor 523 | generateCursor = generateCursorFromLocation . expressionLocation 524 | 525 | generateCursorFromLocation :: 526 | Monad m => SourceLocation -> StateT (Map Cursor SourceLocation) m Cursor 527 | generateCursorFromLocation loc = do 528 | size <- gets M.size 529 | let key = NFCursor size 530 | modify' (M.insert key loc) 531 | pure key 532 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Optics.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | 3 | module Inflex.Optics where 4 | 5 | import Data.Char 6 | import Data.List 7 | import Language.Haskell.TH.Syntax 8 | import Optics 9 | 10 | inflexRules :: [Name] -> LensRules 11 | inflexRules names = 12 | set 13 | lensField 14 | (\tyname _ name -> 15 | [ (let Name (OccName tn) _ = tyname 16 | in TopName 17 | (Name 18 | (OccName 19 | (downcaseFst tn <> upcaseFst (nameBase' name) <> "L")) 20 | NameS)) 21 | | elem (nameBase' name) (map nameBase' names) || null names 22 | ]) 23 | lensRules 24 | where 25 | upcaseFst (x:xs) = toUpper x : xs 26 | upcaseFst xs = xs 27 | downcaseFst (x:xs) = toLower x : xs 28 | downcaseFst xs = xs 29 | nameBase' = 30 | (\name -> maybe name (takeWhile (/= ':')) (stripPrefix "$sel:" name)) . 31 | nameBase 32 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Parser2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, OverloadedStrings #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE BangPatterns #-} 5 | {-# LANGUAGE TemplateHaskell, DuplicateRecordFields #-} 6 | 7 | -- | A very fast parser based on FlatParse. 8 | 9 | module Inflex.Parser2 10 | ( parseText 11 | , ParseError(..) 12 | , Env(..) 13 | ) where 14 | 15 | import Data.ByteString (ByteString) 16 | import qualified Data.ByteString as S 17 | import Data.Char (isAlphaNum) 18 | import Data.Coerce 19 | import Data.Decimal 20 | import Data.Maybe 21 | import Data.Text (Text) 22 | import qualified Data.Text.Encoding as T 23 | import qualified Data.Vector as V 24 | import qualified FlatParse.Basic as F 25 | import Inflex.Instances () 26 | import qualified Inflex.Parser as Parser 27 | import Inflex.Types 28 | 29 | -------------------------------------------------------------------------------- 30 | -- Types 31 | 32 | data ParseError = Failed deriving (Eq, Show) 33 | 34 | newtype Env = Env {original :: ByteString} 35 | 36 | -------------------------------------------------------------------------------- 37 | -- Top-level parsers 38 | 39 | parseText :: FilePath -> Text -> Either ParseError (Expression Parsed) 40 | parseText _fp txt = parseBytes (T.encodeUtf8 txt) 41 | 42 | parseBytes :: ByteString -> Either ParseError (Expression Parsed) 43 | parseBytes bs = 44 | case F.runParser (sourceParser (Env bs)) bs of 45 | F.OK a remaining -> 46 | case Parser.parseTextWith 47 | Parser.optionalSignatureParser 48 | -- Didn't feel like re-implementing this parser. 49 | (T.decodeUtf8 remaining) of 50 | Left {} -> Left Failed 51 | Right msig 52 | | Just {} <- msig 53 | , ArrayExpression array <- a -> 54 | Right (ArrayExpression array {typ = msig}) 55 | -- Above: We only parse arrays with the fast parser, 56 | -- and the signature is required. 57 | | otherwise -> pure a 58 | F.Fail -> Left Failed 59 | F.Err e -> Left e 60 | 61 | -------------------------------------------------------------------------------- 62 | -- Basic array parser 63 | 64 | sourceParser :: Env -> F.Parser ParseError (Expression Parsed) 65 | sourceParser env = whitespace *> expressionParser env 66 | 67 | expressionParser :: Env -> F.Parser ParseError (Expression Parsed) 68 | expressionParser = arrayParser 69 | 70 | arrayParser :: Env -> F.Parser ParseError (Expression Parsed) 71 | arrayParser env = F.branch openBracket elements (recordParser env) 72 | where 73 | elements = do 74 | start <- getSourcePosPrev env 75 | es <- 76 | F.many 77 | (do e <- expressionParser env 78 | F.optional_ comma 79 | pure e) 80 | closeBracket 81 | end <- getSourcePos env 82 | pure 83 | (ArrayExpression 84 | Array 85 | { typ = Nothing 86 | , location = SourceLocation {start = start, end = end} 87 | , expressions = V.fromList es 88 | , form = () 89 | }) 90 | 91 | recordParser :: Env -> F.Parser ParseError (Expression Parsed) 92 | recordParser env = F.branch openCurly elements (variantParser env) 93 | where 94 | elements = do 95 | start <- getSourcePosPrev env 96 | fields <- 97 | F.many 98 | (do name <- keyParserQuoted F.<|> keyParser 99 | start' <- getSourcePos env 100 | colon 101 | end' <- getSourcePos env 102 | expression <- expressionParser env 103 | F.optional_ comma 104 | pure 105 | FieldE 106 | { name 107 | , expression 108 | , location = SourceLocation {start = start', end = end'} 109 | }) 110 | closeCurly 111 | end <- getSourcePos env 112 | pure 113 | (RecordExpression 114 | Record 115 | { typ = Nothing 116 | , location = SourceLocation {start = start, end = end} 117 | , fields = fields 118 | }) 119 | 120 | stringParser :: Env -> F.Parser ParseError (Expression Parsed) 121 | stringParser env = F.branch (F.lookahead speech) rest (holeParser env) 122 | where 123 | rest = do 124 | start' <- getSourcePos env 125 | strings <- F.many stringLexer 126 | end' <- getSourcePos env 127 | pure 128 | (LiteralExpression 129 | (TextLiteral 130 | (LiteralText 131 | { location = SourceLocation {start = start', end = end'} 132 | , typ = Nothing 133 | , text = T.decodeUtf8 (S.intercalate "\"" strings) 134 | , .. 135 | }))) 136 | 137 | stringLexer :: F.Parser ParseError ByteString 138 | stringLexer = do 139 | speech 140 | inner <- F.byteStringOf (F.many_ (F.satisfy (\char -> char /= '"'))) 141 | speech 142 | pure inner 143 | 144 | holeParser :: Env -> F.Parser ParseError (Expression Parsed) 145 | holeParser env = 146 | F.branch 147 | hole 148 | (do start' <- getSourcePosPrev env 149 | end' <- getSourcePos env 150 | pure 151 | (HoleExpression 152 | Hole 153 | { location = SourceLocation {start = start', end = end'} 154 | , typ = Nothing 155 | })) 156 | (numberParser env) 157 | 158 | variantParser :: Env -> F.Parser ParseError (Expression Parsed) 159 | variantParser env = F.branch hash rest (stringParser env) 160 | where 161 | rest = do 162 | start' <- getSourcePos env 163 | name <- keyParserQuoted F.<|> keyParser 164 | end' <- getSourcePos env 165 | argument <- 166 | F.branch 167 | openRound 168 | (fmap Just (expressionParser env) <* closeRound) 169 | (pure Nothing) 170 | pure 171 | (VariantExpression 172 | Variant 173 | { location = SourceLocation {start = start', end = end'} 174 | , typ = Nothing 175 | , tag = TagName (coerce name) 176 | , argument 177 | }) 178 | 179 | numberParser :: Env -> F.Parser ParseError (Expression Parsed) 180 | numberParser env = do 181 | sign <- F.optional $(F.char '-') 182 | start <- getSourcePos env 183 | !number <- 184 | do i0 <- F.integer 185 | i <- 186 | F.optioned 187 | $(F.char '.') 188 | (\() -> do 189 | F.spanned 190 | F.integer 191 | (\j (F.Span start' end') -> do 192 | let len = fromIntegral (coerce start' - coerce end' :: Int) 193 | pure 194 | (DecimalNumber 195 | (Decimal 196 | { places = len 197 | , integer = 198 | let i = (i0 * (10 ^ len)) + j 199 | in if isJust sign 200 | then -i 201 | else i 202 | })))) 203 | (pure 204 | (IntegerNumber 205 | (if isJust sign 206 | then -i0 207 | else i0))) 208 | whitespace 209 | pure i 210 | end <- getSourcePos env 211 | pure 212 | (LiteralExpression 213 | (NumberLiteral 214 | Number 215 | { location = SourceLocation {start = start, end = end} 216 | , number 217 | , typ = Nothing 218 | })) 219 | 220 | -------------------------------------------------------------------------------- 221 | -- General tokens 222 | 223 | -- > Note: it's more efficient to use spanOf and spanned instead. 224 | keyParser :: F.Parser e FieldName 225 | keyParser = 226 | fmap 227 | (FieldName . T.decodeUtf8) 228 | (F.byteStringOf 229 | (F.some_ (F.satisfy (\char -> isAlphaNum char || char == '_')))) 230 | 231 | keyParserQuoted :: F.Parser ParseError FieldName 232 | keyParserQuoted = do 233 | speech 234 | inner <- F.byteStringOf (F.some_ (F.satisfy (\char -> char /= '"'))) 235 | speech 236 | pure (FieldName (T.decodeUtf8 inner)) 237 | 238 | comma :: F.Parser e () 239 | comma = $(F.char ',') *> whitespace 240 | 241 | hash :: F.Parser e () 242 | hash = $(F.char '#') 243 | 244 | hole :: F.Parser e () 245 | hole = $(F.char '_') 246 | 247 | speech :: F.Parser e () 248 | speech = $(F.char '"') 249 | 250 | colon :: F.Parser e () 251 | colon = $(F.char ':') *> whitespace 252 | 253 | openBracket :: F.Parser e () 254 | openBracket = $(F.char '[') *> whitespace 255 | 256 | closeBracket :: F.Parser e () 257 | closeBracket = $(F.char ']') *> whitespace 258 | 259 | openRound :: F.Parser e () 260 | openRound = $(F.char '(') *> whitespace 261 | 262 | closeRound :: F.Parser e () 263 | closeRound = $(F.char ')') *> whitespace 264 | 265 | openCurly :: F.Parser e () 266 | openCurly = $(F.char '{') *> whitespace 267 | 268 | closeCurly :: F.Parser e () 269 | closeCurly = $(F.char '}') *> whitespace 270 | 271 | whitespace :: F.Parser e () 272 | whitespace = 273 | F.many_ 274 | $(F.switch 275 | [|case _ of 276 | " " -> pure () 277 | "\n" -> pure ()|]) 278 | 279 | -------------------------------------------------------------------------------- 280 | -- Location getting 281 | 282 | getSourcePos :: Env -> F.Parser e SourcePos 283 | getSourcePos Env{original} = do 284 | pos@(F.Pos offset) <- F.getPos 285 | let ~(line, column) = 286 | case F.posLineCols original [pos] of 287 | [(line', col)] -> (line'+1, col+1) 288 | _ -> (0, 0) 289 | in pure SourcePosWithOffset {name = "", line, column,offset} 290 | 291 | getSourcePosPrev :: Env -> F.Parser e SourcePos 292 | getSourcePosPrev Env{original} = do 293 | pos@(F.Pos offset) <- F.getPos 294 | let ~(line, column) = 295 | case F.posLineCols original [pos] of 296 | [(line', col)] -> (line'+1, col) 297 | _ -> (0, 0) 298 | in pure SourcePosWithOffset {name = "", line, column,offset} 299 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | -- | 5 | 6 | module Inflex.Pretty where 7 | 8 | import Data.Char 9 | import Inflex.Types 10 | 11 | prettyEquality :: EqualityConstraint -> String 12 | prettyEquality EqualityConstraint {type1,type2} = 13 | prettyType type1 <> " ~ " <> prettyType type2 14 | 15 | prettyType :: Type Generated -> String 16 | prettyType = 17 | \case 18 | VariableType TypeVariable {prefix, index} -> map toLower (show prefix) ++ show index 19 | ArrayType t -> "[" ++ prettyType t ++ "]" 20 | 21 | ApplyType TypeApplication { function = ApplyType TypeApplication { function = ConstantType (TypeConstant {name = FunctionTypeName}) 22 | , argument = i 23 | } 24 | , argument = o 25 | } -> 26 | "(" ++ prettyType i ++ " -> " ++ prettyType o ++ ")" 27 | ApplyType TypeApplication {function = f, argument = x} -> 28 | "(" ++ prettyType f ++ " " ++ prettyType x ++ ")" 29 | ConstantType TypeConstant {name} -> show name 30 | _ -> "?" 31 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Printer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, TypeApplications, ScopedTypeVariables #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# OPTIONS -fno-warn-orphans #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE NamedFieldPuns #-} 8 | {-# LANGUAGE DuplicateRecordFields #-} 9 | {-# LANGUAGE LambdaCase #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | 12 | -- | The printer of code. 13 | 14 | module Inflex.Printer 15 | ( tracePrinter 16 | , Printer 17 | , PrinterConfig(..) 18 | , emptyPrinterConfig 19 | , printer 20 | , printerText 21 | , runPrinter 22 | ) where 23 | 24 | import Control.Monad.Reader 25 | import Data.Aeson (encode) 26 | import qualified Data.ByteString.Builder as SB 27 | import qualified Data.ByteString.Lazy as L 28 | import qualified Data.ByteString.Lazy.Char8 as L8 29 | import Data.Char (isAlphaNum) 30 | import Data.Coerce 31 | import Data.Foldable 32 | import Data.List 33 | import Data.Map.Strict (Map) 34 | import qualified Data.Map.Strict as M 35 | import Data.String 36 | import Data.Text (Text) 37 | import qualified Data.Text as T 38 | import qualified Data.Text.Encoding as T 39 | import Data.Vector (Vector) 40 | import qualified Data.Vector as V 41 | import Debug.Trace 42 | import Inflex.Instances () 43 | import Inflex.Location 44 | import Inflex.Types 45 | import Inflex.Types.SHA512 46 | import qualified RIO 47 | 48 | emptyPrinterConfig :: PrinterConfig 49 | emptyPrinterConfig = PrinterConfig {nameMappings = mempty} 50 | 51 | {-# INLINE tracePrinter #-} 52 | tracePrinter :: Printer a1 => PrinterConfig -> a1 -> a2 -> a2 53 | tracePrinter cfg e = 54 | trace 55 | (L8.unpack 56 | (SB.toLazyByteString (RIO.getUtf8Builder (runPrinter cfg (printer e))))) 57 | 58 | printerText :: Printer a => PrinterConfig -> a -> Text 59 | printerText cfg = 60 | T.decodeUtf8 . 61 | L.toStrict . 62 | SB.toLazyByteString . RIO.getUtf8Builder . runPrinter cfg . printer 63 | 64 | instance Semigroup Print where 65 | (<>) x y = Print ((<>) <$> runPrint x <*> runPrint y) 66 | 67 | instance Monoid Print where 68 | mempty = Print (pure mempty) 69 | mappend = (<>) 70 | 71 | instance IsString Print where 72 | fromString = Print . pure . fromString 73 | 74 | data PrinterConfig = PrinterConfig 75 | { nameMappings :: Map Cursor Text 76 | -- TODO: Add whether parens are needed, then add two combinators: 77 | -- 1. A `parens' combinator that'll add parens if needed, where the default is true. 78 | -- 2. A `naked` combinator that'll say that parens aren't needed in certain cases. 79 | } 80 | 81 | data Print = Print 82 | { runPrint :: Reader PrinterConfig RIO.Utf8Builder 83 | } 84 | 85 | runPrinter :: PrinterConfig -> Print -> RIO.Utf8Builder 86 | runPrinter cf (Print x) = runReader x cf 87 | 88 | printShow :: Show a => a -> Print 89 | printShow = Print . pure . RIO.displayShow 90 | 91 | class Printer a where 92 | printer :: a -> Print 93 | 94 | instance Printer Text where 95 | printer = Print . pure . RIO.display 96 | 97 | instance Printer Integer where 98 | printer = Print . pure . RIO.display 99 | 100 | -- TODO: Handle scope and retain original names, if provided. 101 | -- TODO: Avoid unneeded parens. 102 | 103 | instance Stage s => Printer (Expression s) where 104 | printer = 105 | \case 106 | RecordExpression record -> printer record 107 | PropExpression prop -> printer prop 108 | HoleExpression hole -> printer hole 109 | CellRefExpression cellRef -> printer cellRef 110 | ArrayExpression array -> printer array 111 | VariantExpression variant -> printer variant 112 | LiteralExpression literal -> printer literal 113 | LambdaExpression lambda -> printer lambda 114 | ApplyExpression apply -> printer apply 115 | VariableExpression variable -> printer variable 116 | GlobalExpression global -> printer global 117 | CaseExpression case' -> printer case' 118 | InfixExpression infix' -> printer infix' 119 | 120 | instance Stage s => Printer (Case s) where 121 | printer Case {..} = 122 | "if(" <> printer scrutinee <> "){" <> 123 | (mconcat . intersperse ", ") (map printer (toList alternatives)) <> 124 | "}" 125 | 126 | instance Stage s => Printer (Alternative s) where 127 | printer Alternative {..} = 128 | case reflectStage @s of 129 | StageResolved -> 130 | case pattern' of 131 | WildPattern {} -> "_: " <> printer expression 132 | ParamPattern param -> printer param <> ": " <> printer expression 133 | VariantPattern variant -> 134 | printer variant <> ": " <> printer expression 135 | StageParsed -> 136 | case pattern' of 137 | WildPattern {} -> "_: " <> printer expression 138 | ParamPattern param -> printer param <> ": " <> printer expression 139 | VariantPattern variant -> 140 | printer variant <> ": " <> printer expression 141 | 142 | instance Stage s => Printer (VariantP s) where 143 | printer VariantP {..} = 144 | case reflectStage @s of 145 | StageResolved -> 146 | printer tag <> 147 | (case argument of 148 | Nothing -> mempty 149 | Just param -> "(" <> printer param <> ")" 150 | ) 151 | StageParsed -> 152 | printer tag <> 153 | (case argument of 154 | Nothing -> mempty 155 | Just param -> "(" <> printer param <> ")") 156 | 157 | instance Stage s => Printer (Hole s) where 158 | printer (Hole{}) = "_" 159 | 160 | instance Stage s => Printer (CellRef s) where 161 | printer (CellRef{address=RefUuid (Uuid uuid)}) = 162 | "@cell:uuid:" <> printer uuid 163 | 164 | instance Stage s => Printer (Prop s) where 165 | printer (Prop {expression, name}) = 166 | printer expression <> "." <> printer name -- TODO: Manage parens. 167 | 168 | instance Stage s => Printer (Array s) where 169 | printer (Array {expressions, typ}) = 170 | case reflectStage @s of 171 | StageResolved -> 172 | "[" <> mconcat (intersperse ", " (map printer (toList expressions))) <> 173 | "]" 174 | StageParsed -> 175 | addColumnsIfNeeded 176 | expressions 177 | typ 178 | ("[" <> mconcat (intersperse ", " (map printer (toList expressions))) <> 179 | "]") 180 | 181 | instance Stage s => Printer (Variant s) where 182 | printer (Variant {tag, argument}) = 183 | printer tag <> (if not (null argument) 184 | then "(" <> mconcat (intersperse ", " (map printer (toList argument))) <> ")" 185 | else mempty) 186 | 187 | instance Printer TagName where 188 | printer (TagName s) ="#" <> printer s 189 | 190 | instance Stage s => Printer (Record s) where 191 | printer (Record {fields}) = 192 | "{" <> 193 | mconcat 194 | (intersperse 195 | ", " 196 | (map 197 | (\FieldE {name, expression} -> 198 | printer name <> ": " <> printer expression) 199 | fields)) <> 200 | "}" 201 | 202 | instance Stage s => Printer (Infix s) where 203 | printer (Infix {left, global, right}) = 204 | "(" <> printer left <> " " <> 205 | (case reflectStage @s of 206 | StageResolved -> printer global 207 | StageParsed -> printer global) <> 208 | " " <> 209 | printer right <> 210 | ")" 211 | 212 | instance Stage s => Printer (Literal s) where 213 | printer = \case 214 | NumberLiteral number -> printer number 215 | TextLiteral LiteralText{text} -> printText text 216 | 217 | instance Stage s => Printer (Number s) where 218 | printer (Number {number}) = printer number 219 | 220 | instance Stage s => Printer (Lambda s) where 221 | printer Lambda {location, param, body} = 222 | case reflectStage @s of 223 | StageResolved -> 224 | case location of 225 | ImplicitArgumentFor {} -> printer body 226 | _ -> "(" <> printer param <> ":" <> printer body <> ")" 227 | StageParsed -> "(" <> printer param <> ":" <> printer body <> ")" 228 | 229 | instance Printer (Param Parsed) where 230 | printer Param{name} = printer name 231 | 232 | instance Printer (Param Resolved) where 233 | printer Param {location} = 234 | Print $ do 235 | PrinterConfig {nameMappings} <- ask 236 | case M.lookup location nameMappings of 237 | Nothing -> pure "$" 238 | Just text -> runPrint (printer text) 239 | 240 | instance Stage s => Printer (Variable s) where 241 | printer Variable {name, location} = 242 | case reflectStage @s of 243 | StageResolved -> 244 | Print $ do 245 | PrinterConfig {nameMappings} <- ask 246 | case M.lookup location nameMappings of 247 | Nothing -> 248 | runPrint 249 | ("$" <> printShow (coerce (deBrujinIndexNesting name) :: Int)) 250 | Just text -> runPrint (printer text) 251 | StageParsed -> printer name 252 | 253 | instance Stage s => Printer (Global s) where 254 | printer Global{name} = 255 | case reflectStage @s of 256 | StageResolved -> printer name 257 | StageParsed -> printer name 258 | 259 | instance Printer (GlobalRef s) where 260 | printer = 261 | \case 262 | HashGlobal (Hash hash) -> "#" <> printShow hash 263 | FromIntegerGlobal -> "@prim:from_integer" 264 | FromDecimalGlobal -> "fromDecimal" 265 | EqualGlobal equality -> 266 | case equality of 267 | Equal -> "=" 268 | NotEqual -> "/=" 269 | CompareGlobal compareity -> 270 | case compareity of 271 | LessThan -> "<" 272 | GreaterThan -> ">" 273 | GreaterEqualTo -> ">=" 274 | LessEqualTo -> "=" 275 | NumericBinOpGlobal op -> printer op 276 | InstanceGlobal r -> printer r 277 | FunctionGlobal function -> "@prim:" <> printer function 278 | 279 | instance Stage s => Printer (Apply s) where 280 | printer apply@Apply {function, argument, style} = 281 | case reflectStage @s of 282 | StageResolved -> 283 | case style of 284 | OverloadedApply -> printer argument 285 | _ -> 286 | case expressionLocation argument of 287 | ImplicitArgumentFor {} -> printer function 288 | AutoInsertedForDefaulterCursor {} -> printer function 289 | -- TODO: Hides the implicit function applications generated by the 290 | -- renamer. This isn't very clean. But it requires more thought to 291 | -- handle this. 292 | _ -> 293 | case apply of 294 | Apply { function = GlobalExpression Global {name = FromDecimalGlobal} 295 | , argument = LiteralExpression {} 296 | } -> printer argument 297 | Apply { function = GlobalExpression Global {name = FromIntegerGlobal} 298 | , argument = LiteralExpression {} 299 | } -> printer argument 300 | _ -> printerApplyResolved apply 301 | StageParsed -> printerApply printer apply 302 | 303 | printText :: Text -> Print 304 | printText t = 305 | Print 306 | (pure 307 | (RIO.displayBytesUtf8 308 | (T.encodeUtf8 ("\"" <> T.replace "\"" "\"\"" t <> "\"")))) 309 | 310 | instance Printer InstanceName where 311 | printer = 312 | \case 313 | EqualIntegerInstance -> "" 314 | EqualTextInstance -> "" 315 | EqualDecimalInstance n -> " printShow n <> ")>" 316 | CompareIntegerInstance -> "" 317 | CompareTextInstance -> "" 318 | CompareDecimalInstance n -> " printShow n <> ")>" 319 | FromIntegerIntegerInstance -> "" 320 | FromIntegerDecimalInstance {} -> "" 321 | FromDecimalDecimalInstance FromDecimalInstance { supersetPlaces 322 | , subsetPlaces 323 | } -> 324 | " printShow supersetPlaces <> " (Decimal " <> 325 | printShow subsetPlaces <> 326 | ")>" 327 | IntegerOpInstance op -> "<(" <> printer op <> ") @ Integer>" 328 | DecimalOpInstance nat op -> 329 | "<(" <> printer op <> ") @(Decimal " <> 330 | printer (fromIntegral nat :: Integer) <> 331 | ")>" 332 | 333 | addColumnsIfNeeded :: Printer a => Vector e -> Maybe a -> Print -> Print 334 | addColumnsIfNeeded expressions typ inner = 335 | case typ of 336 | Just t | V.null expressions -> inner <> " :: " <> printer t 337 | Just t -> inner <> " :: " <> printer t 338 | _ -> inner 339 | 340 | -- TODO: Re-think this printer? 341 | instance Printer (Type Parsed) where 342 | printer = 343 | \case 344 | ArrayType t -> "[" <> printer t <> "]" 345 | RecordType (RowType (TypeRow {fields})) -> 346 | "{" <> 347 | mconcat 348 | (intersperse 349 | ", " 350 | (map 351 | (\Field {name, typ} -> printer name <> ":" <> printer typ) 352 | fields)) <> 353 | "}" 354 | VariantType (RowType (TypeRow {fields})) -> 355 | "<" <> 356 | mconcat 357 | (intersperse 358 | ", " 359 | (map 360 | (\Field {name, typ} -> printer name <> ":" <> printer typ) 361 | fields)) <> 362 | "|_>" -- This is correct; a parsed type can't include variables at the moment. 363 | FreshType {} -> "_" 364 | ConstantType TypeConstant {name = IntegerTypeName} -> 365 | "Integer" -- TODO: change to @prim:integer-type) 366 | ConstantType TypeConstant {name = TextTypeName} -> 367 | "Text" -- TODO: change to @prim:text-type) 368 | ApplyType TypeApplication { function = ConstantType TypeConstant {name = DecimalTypeName} 369 | , argument = ConstantType TypeConstant {name = NatTypeName n} 370 | } -> "Decimal " <> printShow n 371 | _ -> "_" 372 | 373 | -- TODO: Make much more robust. 374 | instance Printer FieldName where 375 | printer (FieldName t) = 376 | if True -- Applying this for graph support. TODO: remove it. 377 | || T.any (not . printableNameChar) t 378 | then Print (pure (RIO.displayBytesUtf8 (L.toStrict (encode t)))) 379 | else printer t 380 | 381 | printableNameChar :: Char -> Bool 382 | printableNameChar '_' = True 383 | printableNameChar c = isAlphaNum c 384 | 385 | instance Printer SomeNumber where 386 | printer = \case 387 | IntegerNumber i -> printer i 388 | DecimalNumber decimal -> Print (pure (RIO.display decimal)) 389 | 390 | instance Printer IncompleteGlobalRef where 391 | printer = 392 | \case 393 | UnresolvedGlobalText text -> printer text 394 | UnresolvedUuid (Uuid uuid) -> "@uuid:" <> printer uuid 395 | ExactGlobalRef ref -> printer ref 396 | ResolvedGlobalRef text _ -> printer text 397 | 398 | instance Printer ParsedGlobal where 399 | printer = \case 400 | ParsedTextName name -> printer name 401 | ParsedHash (Hash hash) -> "#" <> printer (sha512AsHexText hash) 402 | ParsedUuid (Uuid uuid) -> "@uuid:" <> printer uuid 403 | ParsedPrim fun -> "@prim:" <> printer fun 404 | ParsedFromInteger -> "@prim:from_integer" 405 | ParsedFromDecimal -> "@prim:from_decimal" 406 | 407 | instance Printer Function where 408 | printer = 409 | \case 410 | MapFunction -> "array_map" 411 | FromOkFunction -> "from_ok" 412 | VegaFunction -> "vega" 413 | NotFunction -> "not" 414 | FilterFunction -> "array_filter" 415 | DistinctFunction -> "array_distinct" 416 | SortFunction -> "array_sort" 417 | ConcatFunction -> "array_concat" 418 | AndFunction -> "array_and" 419 | OrFunction -> "array_or" 420 | SumFunction -> "array_sum" 421 | AccumFunction -> "array_accum" 422 | ScanFunction -> "array_scan" 423 | ReduceFunction -> "array_reduce" 424 | MinimumFunction -> "array_minimum" 425 | MaximumFunction -> "array_maximum" 426 | AverageFunction -> "array_average" 427 | LengthFunction -> "array_length" 428 | FindFunction -> "array_find" 429 | AllFunction -> "array_all" 430 | AnyFunction -> "array_any" 431 | NullFunction -> "array_null" 432 | RichDoc -> "rich_doc" 433 | RichParagraph -> "rich_paragraph" 434 | RichText -> "rich_text" 435 | RichBold -> "rich_bold" 436 | RichItalic -> "rich_italic" 437 | RichLink -> "rich_link" 438 | RichCell -> "rich_cell" 439 | 440 | instance Printer NumericBinOp where 441 | printer = 442 | \case 443 | MulitplyOp -> "*" 444 | AddOp -> "+" 445 | SubtractOp -> "-" 446 | DivideOp -> "/" 447 | 448 | printerApply :: (Expression s -> Print) -> Apply s -> Print 449 | printerApply printer' apply = 450 | printer' function <> "(" <> 451 | mconcat (intersperse ", " (map printer' arguments)) <> 452 | ")" 453 | where (function, arguments) = uncurryApplies apply 454 | 455 | printerApplyResolved :: Apply Resolved -> Print 456 | printerApplyResolved apply = 457 | printer function <> "(" <> 458 | mconcat (intersperse ", " (map printer arguments)) <> 459 | ")" 460 | where (function, arguments0) = uncurryApplies apply 461 | arguments = filter (\e -> case expressionLocation e of 462 | ImplicitArgumentFor{} -> False 463 | _ -> True) arguments0 464 | 465 | uncurryApplies :: Apply s -> (Expression s, [Expression s]) 466 | uncurryApplies Apply {function, argument} = 467 | case function of 468 | ApplyExpression apply -> 469 | let !(!actualFunction, !arguments) = uncurryApplies apply 470 | in (actualFunction, arguments <> [argument]) 471 | actualFunction -> (actualFunction, [argument]) 472 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Renamer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE ApplicativeDo #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE DuplicateRecordFields #-} 9 | {-# LANGUAGE NamedFieldPuns #-} 10 | 11 | -- | Renamer for Inflex language. 12 | 13 | module Inflex.Renamer 14 | ( renameText 15 | , renameParsed 16 | , IsRenamed(..) 17 | , RenameError(..) 18 | , ParseRenameError(..) 19 | , patternParam 20 | ) where 21 | 22 | import Control.Monad.State 23 | import Control.Monad.Validate 24 | import Data.Bifunctor 25 | import Data.Decimal 26 | import Data.Foldable 27 | import Data.List 28 | import Data.List.NonEmpty (NonEmpty(..)) 29 | import qualified Data.Map.Strict as M 30 | import qualified Data.Set as Set 31 | import Data.Text (Text) 32 | import qualified Data.Vector as V 33 | import Inflex.Instances () 34 | import Inflex.Parser 35 | import Inflex.Type 36 | import Inflex.Types 37 | import Inflex.Types as Alternative (Alternative(..)) 38 | import Inflex.Types as Field (FieldE(..)) 39 | import Inflex.Types.Renamer 40 | import Optics hiding (Fold) 41 | 42 | -------------------------------------------------------------------------------- 43 | -- Top-level 44 | 45 | renameText :: 46 | FilePath 47 | -> Text 48 | -> Either ParseRenameError (IsRenamed (Expression Renamed)) 49 | renameText fp text = do 50 | expression <- first ParserErrored (parseText fp text) 51 | first RenamerErrors (renameParsed expression) 52 | 53 | renameParsed :: 54 | Expression Parsed 55 | -> Either (NonEmpty RenameError) (IsRenamed (Expression Renamed)) 56 | renameParsed expression = 57 | let (result, (mappings, unresolvedGlobals, unresolvedUuids, nameMappings)) = 58 | runState 59 | (runValidateT 60 | (runRenamer 61 | (renameExpression 62 | (Env {globals = mempty, cursor = id, scope = mempty}) 63 | expression))) 64 | mempty 65 | in fmap 66 | (\thing -> 67 | IsRenamed 68 | { thing 69 | , mappings 70 | , unresolvedGlobals 71 | , unresolvedUuids 72 | , nameMappings 73 | }) result 74 | 75 | -------------------------------------------------------------------------------- 76 | -- Renamers 77 | 78 | renameExpression :: Env -> Expression Parsed -> Renamer (Expression Renamed) 79 | renameExpression env = 80 | \case 81 | LiteralExpression literal -> renameLiteral env literal 82 | LambdaExpression lambda -> fmap LambdaExpression (renameLambda env lambda) 83 | RecordExpression record -> fmap RecordExpression (renameRecord env record) 84 | PropExpression prop -> fmap PropExpression (renameProp env prop) 85 | ArrayExpression array -> fmap ArrayExpression (renameArray env array) 86 | VariantExpression variant -> fmap VariantExpression (renameVariant env variant) 87 | CaseExpression case' -> fmap CaseExpression (renameCase env case') 88 | InfixExpression infix' -> fmap InfixExpression (renameInfix env infix') 89 | ApplyExpression apply -> fmap ApplyExpression (renameApply env apply) 90 | VariableExpression variable -> renameVariable env variable 91 | HoleExpression hole -> fmap HoleExpression (renameHole env hole) 92 | GlobalExpression global -> fmap GlobalExpression (renameGlobal env global) 93 | CellRefExpression cellRef -> fmap CellRefExpression (renameCellRef env cellRef) 94 | 95 | renameCellRef :: Env -> CellRef Parsed -> Renamer (CellRef Renamed) 96 | renameCellRef env CellRef{..} = do 97 | final <- finalizeCursor (cursor env) TypeCursor location 98 | -- Make sure we add the UUID address as a dependency. 99 | case address of 100 | RefUuid uuid -> modify (over _3 (Set.insert uuid)) 101 | pure (CellRef {location = final, typ = Nothing, ..}) 102 | 103 | renameHole :: Env -> Hole Parsed -> Renamer (Hole Renamed) 104 | renameHole env Hole{..} = do 105 | final <- finalizeCursor (cursor env) TypeCursor location 106 | pure (Hole {location = final, typ = Nothing}) 107 | 108 | renameLiteral :: Env -> Literal Parsed -> Renamer (Expression Renamed) 109 | renameLiteral env@Env {cursor} = 110 | \case 111 | TextLiteral LiteralText {..} -> do 112 | final <- finalizeCursor cursor TypeCursor location 113 | pure 114 | (LiteralExpression 115 | (TextLiteral LiteralText {location = final, typ = Nothing, ..})) 116 | NumberLiteral number -> do 117 | number' <- renameNumber env number 118 | pure 119 | (case numberType number' of 120 | Just typ 121 | | sigMatchesNumber typ number' -> 122 | LiteralExpression (NumberLiteral number') 123 | -- Purely an optimization to avoid a no-op. We could go 124 | -- further and grow ints/decs to more places if we 125 | -- wanted. 126 | _ -> 127 | ApplyExpression 128 | Apply 129 | { location = BuiltIn 130 | , typ = numberType number' 131 | , argument = LiteralExpression (NumberLiteral number') 132 | , function = 133 | GlobalExpression 134 | Global 135 | { location = BuiltIn 136 | , name = 137 | let Number {number = someNumber} = number' 138 | in case someNumber of 139 | IntegerNumber {} -> 140 | ExactGlobalRef FromIntegerGlobal 141 | DecimalNumber {} -> 142 | ExactGlobalRef FromDecimalGlobal 143 | , scheme = RenamedScheme 144 | } 145 | , style = OverloadedApply 146 | }) 147 | where 148 | sigMatchesNumber typ Number {number} = 149 | case number of 150 | IntegerNumber {} 151 | | ConstantType TypeConstant {name = IntegerTypeName} <- typ -> True 152 | DecimalNumber Decimal {places} 153 | | ApplyType TypeApplication { function = ConstantType TypeConstant {name = DecimalTypeName} 154 | , argument = ConstantType TypeConstant {name = NatTypeName n} 155 | } <- typ -> n == places 156 | _ -> False 157 | 158 | renameNumber :: Env -> Number Parsed -> Renamer (Number Renamed) 159 | renameNumber env@Env {cursor} Number {..} = do 160 | final <- finalizeCursor cursor ExpressionCursor location 161 | typ' <- renameSignature env typ 162 | pure Number {location = final, typ = typ', ..} 163 | 164 | renameLambda :: Env -> Lambda Parsed -> Renamer (Lambda Renamed) 165 | renameLambda env@Env {cursor} Lambda {..} = do 166 | final <- finalizeCursor cursor ExpressionCursor location 167 | param' <- renameParam env param 168 | body' <- 169 | renameExpression 170 | (over 171 | envScopeL 172 | (LambdaBinding param :) 173 | (over envCursorL (. LambdaBodyCursor) env)) 174 | body 175 | typ' <- renameSignature env typ 176 | pure 177 | Lambda 178 | { body = body' 179 | , location = final 180 | , param = param' 181 | , typ = typ' 182 | , .. 183 | } 184 | 185 | renameRecord :: Env -> Record Parsed -> Renamer (Record Renamed) 186 | renameRecord env@Env {cursor} Record {..} = do 187 | final <- finalizeCursor cursor ExpressionCursor location 188 | fields' <- 189 | traverse 190 | (\field@FieldE {name} -> 191 | renameFieldE (over envCursorL (. RecordFieldCursor name) env) field) 192 | fields 193 | typ' <- renameSignature env typ 194 | pure Record {fields = fields', location = final, typ = typ'} 195 | 196 | renameProp :: Env -> Prop Parsed -> Renamer (Prop Renamed) 197 | renameProp env@Env {cursor} Prop {..} = do 198 | final <- finalizeCursor cursor ExpressionCursor location 199 | expression' <- renameExpression (over envCursorL (. PropExpressionCursor) env) expression 200 | typ' <- renameSignature env typ 201 | pure 202 | Prop 203 | { expression = expression' 204 | , location = final 205 | , typ = typ' 206 | , .. 207 | } 208 | 209 | renameArray :: Env -> Array Parsed -> Renamer (Array Renamed) 210 | renameArray env@Env {cursor} Array {..} = do 211 | final <- finalizeCursor cursor ExpressionCursor location 212 | expressions' <- 213 | V.imapM 214 | (\i -> renameExpression (over envCursorL (. ArrayElementCursor i) env)) 215 | expressions 216 | typ' <- renameSignature env typ 217 | pure Array {expressions = expressions', location = final, typ = typ', ..} 218 | 219 | renameVariant :: Env -> Variant Parsed -> Renamer (Variant Renamed) 220 | renameVariant env@Env {cursor} Variant {..} = do 221 | final <- finalizeCursor cursor ExpressionCursor location 222 | argument' <- 223 | traverse 224 | (renameExpression (over envCursorL (. VariantElementCursor) env)) 225 | argument 226 | typ' <- renameSignature env typ 227 | pure Variant {argument = argument', location = final, typ = typ', ..} 228 | 229 | renameFieldE :: Env -> FieldE Parsed -> Renamer (FieldE Renamed) 230 | renameFieldE env@Env {cursor} FieldE {..} = do 231 | final <- finalizeCursor cursor TypeCursor location 232 | expression' <- 233 | renameExpression (over envCursorL (. RowFieldExpression) env) expression 234 | pure FieldE {location = final, expression = expression', ..} 235 | 236 | renameCase :: Env -> Case Parsed -> Renamer (Case Renamed) 237 | renameCase env@Env {cursor} Case {..} = do 238 | final <- finalizeCursor cursor ExpressionCursor location 239 | typ' <- renameSignature env typ 240 | scrutinee' <- renameExpression env scrutinee 241 | alternatives' <- traverse (renameAlternative env) alternatives 242 | pure 243 | Case 244 | { location = final 245 | , typ = typ' 246 | , alternatives = alternatives' 247 | , scrutinee = scrutinee' 248 | , .. 249 | } 250 | 251 | renameAlternative :: Env -> Alternative Parsed -> Renamer (Alternative Renamed) 252 | renameAlternative env@Env {cursor} Alternative {..} = do 253 | final <- finalizeCursor cursor ExpressionCursor location 254 | pattern'' <- renamePattern env pattern' 255 | let addParam = 256 | case patternParam pattern' of 257 | Nothing -> id 258 | Just param -> over envScopeL (CaseBinding param :) 259 | expression' <- renameExpression (addParam env) expression 260 | pure 261 | Alternative 262 | {pattern' = pattern'', expression = expression', location = final, ..} 263 | 264 | renamePattern :: Env -> Pattern Parsed -> Renamer (Pattern Renamed) 265 | renamePattern env = 266 | \case 267 | ParamPattern param -> fmap ParamPattern (renameParam env param) 268 | VariantPattern variant -> fmap VariantPattern (renameVariantP env variant) 269 | WildPattern hole -> fmap WildPattern (renameHole env hole) 270 | 271 | bindingParam :: Binding s -> NonEmpty (Param s) 272 | bindingParam = 273 | \case 274 | LambdaBinding p -> pure p 275 | LetBinding p -> p 276 | CaseBinding p -> pure p 277 | 278 | patternParam :: Pattern s -> Maybe (Param s) 279 | patternParam = 280 | \case 281 | ParamPattern param -> pure param 282 | VariantPattern VariantP {argument} -> argument 283 | WildPattern {} -> Nothing 284 | 285 | renameVariantP :: Env -> VariantP Parsed -> Renamer (VariantP Renamed) 286 | renameVariantP env@Env {cursor} VariantP {..} = do 287 | final <- finalizeCursor cursor ExpressionCursor location 288 | argument' <- traverse (renameParam env) argument 289 | pure VariantP {location = final, argument = argument', ..} 290 | 291 | renameInfix :: Env -> Infix Parsed -> Renamer (Infix Renamed) 292 | renameInfix env@Env {cursor} Infix {..} = do 293 | final <- finalizeCursor cursor ExpressionCursor location 294 | global' <- renameGlobal (over envCursorL (. InfixOpCursor) env) global 295 | left' <- renameExpression (over envCursorL (. InfixLeftCursor) env) left 296 | right' <- renameExpression (over envCursorL (. InfixRightCursor) env) right 297 | typ' <- renameSignature env typ 298 | pure 299 | Infix 300 | { left = left' 301 | , global = global' 302 | , right = right' 303 | , location = final 304 | , typ = typ' 305 | , .. 306 | } 307 | 308 | renameGlobal :: Env -> Global Parsed -> Renamer (Global Renamed) 309 | renameGlobal Env {cursor} Global {..} = do 310 | final <- finalizeCursor cursor ExpressionCursor location 311 | let exact name' = 312 | pure 313 | Global 314 | { location = final 315 | , scheme = RenamedScheme 316 | , name = ExactGlobalRef name' 317 | } 318 | op = NumericBinOpGlobal 319 | case name of 320 | ParsedTextName "*" -> exact $ op MulitplyOp 321 | ParsedTextName "+" -> exact $ op AddOp 322 | ParsedTextName "-" -> exact $ op SubtractOp 323 | ParsedTextName "/" -> exact $ op DivideOp 324 | ParsedTextName "=" -> exact $ (EqualGlobal Equal) 325 | ParsedTextName "/=" -> exact $ (EqualGlobal NotEqual) 326 | ParsedTextName ">" -> exact $ (CompareGlobal GreaterThan) 327 | ParsedTextName "<" -> exact $ (CompareGlobal LessThan) 328 | ParsedTextName "<=" -> exact $ (CompareGlobal LessEqualTo) 329 | ParsedTextName ">=" -> exact $ (CompareGlobal GreaterEqualTo) 330 | ParsedUuid uuid -> do 331 | modify (over _3 (Set.insert uuid)) 332 | pure 333 | Global 334 | { location = final 335 | , scheme = RenamedScheme 336 | , name = UnresolvedUuid uuid 337 | } 338 | ParsedHash sha512 -> 339 | pure 340 | Global 341 | { location = final 342 | , scheme = RenamedScheme 343 | , name = ExactGlobalRef (HashGlobal sha512) 344 | } 345 | ParsedPrim fun -> 346 | pure 347 | Global 348 | { location = final 349 | , scheme = RenamedScheme 350 | , name = ExactGlobalRef (FunctionGlobal fun) 351 | } 352 | ParsedFromDecimal -> 353 | pure 354 | Global 355 | { location = final 356 | , scheme = RenamedScheme 357 | , name = ExactGlobalRef FromDecimalGlobal 358 | } 359 | ParsedFromInteger -> 360 | pure 361 | Global 362 | { location = final 363 | , scheme = RenamedScheme 364 | , name = ExactGlobalRef FromIntegerGlobal 365 | } 366 | _ -> Renamer (refute (pure (NotInScope name))) 367 | 368 | renameApply :: Env -> Apply Parsed -> Renamer (Apply Renamed) 369 | renameApply env@Env {cursor} Apply {..} = do 370 | function' <- 371 | renameExpression (over envCursorL (. ApplyFuncCursor) env) function 372 | argument' <- 373 | renameExpression (over envCursorL (. ApplyArgCursor) env) argument 374 | final <- finalizeCursor cursor ExpressionCursor location 375 | typ' <- renameSignature env typ 376 | pure 377 | Apply 378 | { function = function' 379 | , argument = argument' 380 | , location = final 381 | , typ = typ' 382 | , style 383 | } 384 | 385 | renameVariable :: 386 | Env 387 | -> Variable Parsed 388 | -> Renamer (Expression Renamed) 389 | renameVariable env@Env {scope, cursor, globals} variable@Variable { name 390 | , location 391 | , typ 392 | } = 393 | case find 394 | (any (\Param {name = name'} -> name' == name) . bindingParam . snd) 395 | (zip [0 ..] scope) of 396 | Nothing 397 | | False -> Renamer (refute (pure (NotInScopeLocal name))) 398 | | True -> do 399 | final <- finalizeCursor cursor ExpressionCursor location 400 | case M.lookup name globals of 401 | Nothing -> do 402 | modify (over _2 (Set.insert name)) 403 | pure 404 | (GlobalExpression 405 | (Global 406 | { location = final 407 | , name = UnresolvedGlobalText name 408 | , scheme = RenamedScheme 409 | })) 410 | Just globalRef -> do 411 | pure 412 | (GlobalExpression 413 | (Global 414 | { location = final 415 | , name = ResolvedGlobalRef name globalRef 416 | , scheme = RenamedScheme 417 | })) 418 | Just (index, binding) -> do 419 | final <- finalizeCursor cursor ExpressionCursor location 420 | typ' <- renameSignature env typ 421 | finalizeCursorForName final name 422 | deBrujinIndex <- 423 | case binding of 424 | LambdaBinding {} -> pure (DeBrujinIndex (DeBrujinNesting index)) 425 | CaseBinding {} -> pure (DeBrujinIndex (DeBrujinNesting index)) 426 | LetBinding params -> 427 | case findIndex 428 | (\Param {name = name'} -> name' == name) 429 | (toList params) of 430 | Nothing -> 431 | Renamer 432 | (refute (pure (BUG_MissingVariable scope globals variable))) 433 | Just subIndex -> 434 | pure 435 | (DeBrujinIndexOfLet 436 | (DeBrujinNesting index) 437 | (IndexInLet subIndex)) 438 | pure 439 | (VariableExpression 440 | (Variable {location = final, name = deBrujinIndex, typ = typ'})) 441 | 442 | renameParam :: Env -> Param Parsed -> Renamer (Param Renamed) 443 | renameParam env@Env{cursor} Param {..} = do 444 | final <- finalizeCursor cursor LambdaParamCursor location 445 | finalizeCursorForName final name 446 | typ' <- renameSignature env typ 447 | 448 | pure Param {name = (), location = final, typ = typ'} 449 | 450 | renameSignature :: Env -> Maybe (Type Parsed) -> Renamer (Maybe (Type Renamed)) 451 | renameSignature env = 452 | maybe 453 | (pure Nothing) 454 | (fmap Just . renameType (over envCursorL (. SignatureCursor) env)) 455 | 456 | renameType :: Env -> Type Parsed -> Renamer (Type Renamed) 457 | renameType env@Env {cursor} = 458 | \case 459 | FreshType location -> do 460 | final <- finalizeCursor cursor LambdaParamCursor location 461 | pure (FreshType final) 462 | VariableType typeVariable -> 463 | fmap VariableType (renameTypeVariable env typeVariable) 464 | ApplyType typeApplication -> 465 | fmap ApplyType (renameTypeApplication env typeApplication) 466 | ConstantType typeConstant -> 467 | fmap ConstantType (renameTypeConstant env typeConstant) 468 | RowType typeRow -> fmap RowType (renameTypeRow env typeRow) 469 | RecordType typeRow -> fmap RecordType (renameType env typeRow) 470 | VariantType typeRow -> fmap VariantType (renameType env typeRow) 471 | ArrayType typ -> fmap ArrayType (renameType env typ) 472 | 473 | renameTypeConstant :: Env -> TypeConstant Parsed -> Renamer (TypeConstant Renamed) 474 | renameTypeConstant Env{cursor} TypeConstant {..} = do 475 | final <- finalizeCursor cursor TypeCursor location 476 | pure TypeConstant {location = final, ..} 477 | 478 | renameTypeRow :: Env -> TypeRow Parsed -> Renamer (TypeRow Renamed) 479 | renameTypeRow env@Env {cursor} TypeRow {..} = do 480 | final <- finalizeCursor cursor TypeCursor location 481 | fields' <- 482 | traverse (renameField (over envCursorL (. RowFieldCursor) env)) fields 483 | pure TypeRow {location = final, fields = fields', typeVariable} 484 | 485 | renameField :: Env -> Field Parsed -> Renamer (Field Renamed) 486 | renameField env@Env{cursor} Field {..} = do 487 | final <- finalizeCursor cursor TypeCursor location 488 | typ' <- renameType (over envCursorL (. RowFieldType) env) typ 489 | pure Field {location = final, typ = typ', ..} 490 | 491 | renameTypeApplication :: Env -> TypeApplication Parsed -> Renamer (TypeApplication Renamed) 492 | renameTypeApplication env@Env {cursor} TypeApplication {function, argument, ..} = do 493 | function' <- renameType (over envCursorL (. TypeApplyCursor) env) function 494 | argument' <- renameType (over envCursorL (. TypeApplyCursor) env) argument 495 | final <- finalizeCursor cursor TypeCursor location 496 | pure 497 | TypeApplication 498 | {function = function', argument = argument', location = final, ..} 499 | 500 | renameTypeVariable :: Env -> TypeVariable Parsed -> Renamer (TypeVariable Renamed) 501 | renameTypeVariable Env{cursor} TypeVariable {..} = do 502 | final <- finalizeCursor cursor TypeCursor location 503 | pure TypeVariable {location = final, ..} 504 | 505 | -------------------------------------------------------------------------------- 506 | -- Cursor operations 507 | 508 | finalizeCursor :: CursorBuilder -> Cursor -> StagedLocation Parsed -> Renamer Cursor 509 | finalizeCursor cursor finalCursor loc = do 510 | modify (over _1 (M.insert final loc)) 511 | pure final 512 | where final = cursor finalCursor 513 | 514 | finalizeCursorForName :: Cursor -> Text -> Renamer () 515 | finalizeCursorForName final text = do 516 | modify (over _4 (M.insert final text)) 517 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Rows.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | -- | Functions pertaining to row types. 3 | 4 | module Inflex.Rows where 5 | 6 | import Inflex.Types 7 | 8 | -- | Make a polymorphic row type. 9 | polymorphicTypeRow :: StagedLocation s -> StagedRowVariable s -> [Field s] -> TypeRow s 10 | polymorphicTypeRow location var fs = TypeRow {typeVariable = Just var, fields = fs, ..} 11 | 12 | -- | Make a monomorphic row type. 13 | monomorphicTypeRow :: StagedLocation s -> [Field s] -> TypeRow s 14 | monomorphicTypeRow location fs = TypeRow {typeVariable = Nothing, fields = fs, ..} 15 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE NamedFieldPuns #-} 7 | {-# LANGUAGE DuplicateRecordFields #-} 8 | {-# LANGUAGE LambdaCase #-} 9 | 10 | -- | Types of AST nodes. 11 | 12 | module Inflex.Type where 13 | 14 | import Data.Text (Text) 15 | import Inflex.Types 16 | import Numeric.Natural 17 | 18 | -- | Return the final output type. 19 | -- 20 | -- typeOutput(x -> t) = typeOutput(t), or else typeOutput(y)=y. 21 | typeOutput :: Type s -> Type s 22 | typeOutput = 23 | \case 24 | ApplyType TypeApplication { function = ApplyType TypeApplication {function = ConstantType TypeConstant {name = FunctionTypeName}} 25 | , argument = output 26 | } -> typeOutput output 27 | t -> t 28 | 29 | -- One layer function output. 30 | funOutput1 :: Type s -> Type s 31 | funOutput1 = 32 | \case 33 | ApplyType TypeApplication { function = ApplyType TypeApplication {function = ConstantType TypeConstant {name = FunctionTypeName}} 34 | , argument = output 35 | } -> output 36 | t -> t 37 | 38 | typeInput :: Type s -> Type s 39 | typeInput = 40 | \case 41 | ApplyType TypeApplication {function = ApplyType TypeApplication { function = ConstantType TypeConstant {name = FunctionTypeName} 42 | , argument = input 43 | }} -> input 44 | t -> t 45 | 46 | expressionType :: Expression s -> StagedType s 47 | expressionType = 48 | \case 49 | CaseExpression case' -> caseType case' 50 | LiteralExpression literal -> literalType literal 51 | ArrayExpression array -> arrayType array 52 | LambdaExpression lambda -> lambdaType lambda 53 | InfixExpression infix' -> infixType infix' 54 | ApplyExpression apply -> applyType apply 55 | VariableExpression variable -> variableType variable 56 | GlobalExpression global -> globalType global 57 | RecordExpression record -> recordType record 58 | PropExpression prop -> propType prop 59 | HoleExpression hole -> holeType hole 60 | VariantExpression variant -> variantType variant 61 | CellRefExpression cellRef -> cellRefType cellRef 62 | 63 | recordType :: Record s -> StagedType s 64 | recordType Record {typ} = typ 65 | 66 | caseType :: Case s -> StagedType s 67 | caseType Case {typ} = typ 68 | 69 | arrayType :: Array s -> StagedType s 70 | arrayType Array {typ} = typ 71 | 72 | propType :: Prop s -> StagedType s 73 | propType Prop {typ} = typ 74 | 75 | holeType :: Hole s -> StagedType s 76 | holeType Hole {typ} = typ 77 | 78 | cellRefType :: CellRef s -> StagedType s 79 | cellRefType CellRef {typ} = typ 80 | 81 | variantType :: Variant s -> StagedType s 82 | variantType Variant {typ} = typ 83 | 84 | globalType :: Global s -> StagedType s 85 | globalType Global {scheme} = 86 | case scheme of 87 | ParsedScheme -> Nothing 88 | RenamedScheme -> Nothing 89 | FilledScheme -> Nothing 90 | GeneratedScheme scheme' -> schemeType scheme' 91 | SolvedScheme scheme' -> schemeType scheme' 92 | GeneralisedScheme scheme' -> schemeType scheme' 93 | ResolvedScheme typ -> typ 94 | 95 | schemeType :: Scheme s -> StagedType s 96 | schemeType Scheme{typ} = typ 97 | 98 | lambdaType :: Lambda s -> StagedType s 99 | lambdaType Lambda {typ} = typ 100 | 101 | infixType :: Infix s -> StagedType s 102 | infixType Infix {typ} = typ 103 | 104 | applyType :: Apply s -> StagedType s 105 | applyType Apply {typ} = typ 106 | 107 | variableType :: Variable s -> StagedType s 108 | variableType Variable {typ} = typ 109 | 110 | literalType :: Literal s -> StagedType s 111 | literalType = 112 | \case 113 | NumberLiteral number -> numberType number 114 | TextLiteral LiteralText{typ} -> typ 115 | 116 | numberType :: Number s -> StagedType s 117 | numberType Number {typ} = typ 118 | 119 | paramType :: Param s -> StagedType s 120 | paramType Param {typ} = typ 121 | 122 | instanceNameType :: (StagedLocation s ~ Cursor) => InstanceName -> Type s 123 | instanceNameType = 124 | \case 125 | FromIntegerIntegerInstance -> integerT .-> integerT 126 | FromIntegerDecimalInstance nat -> integerT .-> decimalT nat 127 | FromDecimalDecimalInstance FromDecimalInstance { supersetPlaces 128 | , subsetPlaces 129 | } -> 130 | decimalT subsetPlaces .-> decimalT supersetPlaces 131 | IntegerOpInstance (_op :: NumericBinOp) -> 132 | integerT .-> integerT .-> integerT 133 | DecimalOpInstance n (_op :: NumericBinOp) -> 134 | decimalT n .-> decimalT n .-> decimalT n 135 | EqualIntegerInstance -> integerT .-> integerT .-> boolType BuiltIn 136 | EqualTextInstance -> textT .-> textT .-> boolType BuiltIn 137 | EqualDecimalInstance nat -> 138 | decimalT nat .-> decimalT nat .-> boolType BuiltIn 139 | CompareIntegerInstance -> integerT .-> integerT .-> boolType BuiltIn 140 | CompareTextInstance -> textT .-> textT .-> boolType BuiltIn 141 | CompareDecimalInstance nat -> 142 | decimalT nat .-> decimalT nat .-> boolType BuiltIn 143 | 144 | -------------------------------------------------------------------------------- 145 | -- Convenience DSL for built-in types 146 | 147 | nullType :: StagedLocation s -> Type s 148 | nullType location = 149 | RecordType (RowType TypeRow {location, typeVariable = Nothing, fields = []}) 150 | 151 | boolType :: StagedLocation s -> Type s 152 | boolType location = 153 | VariantType 154 | (RowType 155 | (TypeRow 156 | { location 157 | , typeVariable = Nothing 158 | , fields = 159 | [ Field {location, name = "true", typ = nullType location} 160 | , Field {location, name = "false", typ = nullType location} 161 | ] 162 | })) 163 | 164 | boolT :: Type Polymorphic 165 | boolT = boolType BuiltIn 166 | 167 | maybeType :: [Text] -> StagedLocation s -> Type s -> Type s 168 | maybeType alts location a = 169 | VariantType 170 | (RowType 171 | (TypeRow 172 | { location 173 | , typeVariable = Nothing 174 | , fields = 175 | (Field {location, name = "ok", typ = a} : 176 | [ Field {location, name = FieldName name, typ = nullType location} 177 | | name <- alts 178 | ]) 179 | })) 180 | 181 | okishType :: StagedLocation s -> StagedRowVariable s -> Type s -> Type s 182 | okishType location variable a = 183 | VariantType 184 | (RowType 185 | (TypeRow 186 | { location 187 | , typeVariable = Just variable 188 | , fields = 189 | [ Field {location, name = "ok", typ = a} 190 | ] 191 | })) 192 | 193 | integerT :: (StagedLocation s ~ Cursor) => Type s 194 | integerT = 195 | ConstantType 196 | TypeConstant {location = BuiltIn, name = IntegerTypeName} 197 | 198 | textT :: (StagedLocation s ~ Cursor) => Type s 199 | textT = 200 | ConstantType 201 | TypeConstant {location = BuiltIn, name = TextTypeName} 202 | 203 | vegaT :: (StagedLocation s ~ Cursor) => Type s 204 | vegaT = 205 | ConstantType 206 | TypeConstant {location = BuiltIn, name = VegaTypeName} 207 | 208 | decimalT :: (StagedLocation s ~ Cursor) => Natural -> Type s 209 | decimalT nat = 210 | ApplyType 211 | TypeApplication 212 | { function = 213 | ConstantType TypeConstant {location = BuiltIn, name = DecimalTypeName} 214 | , argument = 215 | ConstantType TypeConstant {location = BuiltIn, name = NatTypeName nat} 216 | , location = BuiltIn 217 | , kind = TypeKind 218 | } 219 | 220 | decimalTVar :: (StagedLocation s ~ Cursor) => Type s -> Type s 221 | decimalTVar nat = 222 | ApplyType 223 | TypeApplication 224 | { function = 225 | ConstantType TypeConstant {location = BuiltIn, name = DecimalTypeName} 226 | , argument = nat 227 | , location = BuiltIn 228 | , kind = TypeKind 229 | } 230 | 231 | 232 | infixr .-> 233 | (.->) :: (StagedLocation s ~ Cursor) => Type s -> Type s -> Type s 234 | (.->) i o = 235 | ApplyType 236 | TypeApplication 237 | { function = 238 | ApplyType 239 | TypeApplication 240 | { function = 241 | ConstantType 242 | TypeConstant {location = BuiltIn, name = FunctionTypeName} 243 | , argument = i 244 | , location = BuiltIn 245 | , kind = FunKind TypeKind TypeKind 246 | } 247 | , argument = o 248 | , location = BuiltIn 249 | , kind = TypeKind 250 | } 251 | 252 | -------------------------------------------------------------------------------- 253 | -- Schemes 254 | 255 | functionOutput :: Function -> Type Polymorphic 256 | functionOutput func = 257 | let Scheme {typ} = functionScheme BuiltIn func 258 | in typeOutput typ 259 | 260 | functionScheme :: Cursor -> Function -> Scheme Polymorphic 261 | functionScheme location = 262 | \case 263 | VegaFunction -> mono (a .-> vegaT) 264 | MapFunction -> mono ((a .-> b) .-> ArrayType a .-> ArrayType b) 265 | FilterFunction -> mono ((a .-> boolT) .-> ArrayType a .-> ArrayType a) 266 | SumFunction -> 267 | poly 268 | [addable a, frominteger a] 269 | (ArrayType a .-> maybeType ["sum_empty"] location a) 270 | LengthFunction -> poly [frominteger b] (ArrayType a .-> b) 271 | NullFunction -> mono (ArrayType a .-> boolT) 272 | NotFunction -> mono (boolT .-> boolT) 273 | AverageFunction -> 274 | poly 275 | [addable a, divisible a, frominteger a] 276 | (ArrayType a .-> maybeType ["average_empty"] location a) 277 | DistinctFunction -> poly [comparable a] (ArrayType a .-> ArrayType a) 278 | SortFunction -> poly [comparable a] (ArrayType a .-> ArrayType a) 279 | ConcatFunction -> poly [] (ArrayType (ArrayType a) .-> ArrayType a) 280 | AndFunction -> mono (ArrayType boolT .-> boolT) 281 | OrFunction -> mono (ArrayType boolT .-> boolT) 282 | MinimumFunction -> 283 | poly 284 | [comparable a] 285 | (ArrayType a .-> maybeType ["minimum_empty"] location a) 286 | MaximumFunction -> 287 | poly 288 | [comparable a] 289 | (ArrayType a .-> maybeType ["maximum_empty"] location a) 290 | FindFunction -> 291 | mono 292 | ((a .-> boolT) .-> ArrayType a .-> 293 | maybeType ["find_empty", "find_failed"] location a) 294 | AllFunction -> 295 | mono 296 | ((a .-> boolT) .-> ArrayType a .-> 297 | maybeType ["all_empty"] location boolT) 298 | AnyFunction -> 299 | mono 300 | ((a .-> boolT) .-> ArrayType a .-> 301 | maybeType ["any_empty"] location boolT) 302 | FromOkFunction -> mono (b .-> okishType BuiltIn c b .-> b) 303 | ScanFunction -> mono (a .-> (a .-> e .-> a) .-> ArrayType e .-> ArrayType a) 304 | ReduceFunction -> mono (a .-> (a .-> e .-> a) .-> ArrayType e .-> a) 305 | AccumFunction -> 306 | mono 307 | (a .-> 308 | (record [("state", a), ("item", e)] .-> 309 | record [("state", a), ("item", d)]) .-> 310 | ArrayType e .-> 311 | record [("state", a), ("items", ArrayType d)]) 312 | 313 | -- Rich text types 314 | -- 315 | -- We take a very simple type structure, copied from 316 | -- ProseMirror. The explicit sum type approach just adds more 317 | -- work. 318 | -- 319 | -- Produce a doc 320 | RichDoc -> mono (ArrayType (constant RichBlockTypeName) .-> constant RichDocTypeName) 321 | -- Produce blocks 322 | RichParagraph -> mono (ArrayType (constant RichInlineTypeName) .-> constant RichBlockTypeName) 323 | -- Produce inlines 324 | RichCell -> mono (constant CellTypeName .-> constant RichInlineTypeName) 325 | RichText -> mono (constant TextTypeName .-> constant RichInlineTypeName) 326 | -- Marks, can apply to any inline anywhere (even cell) 327 | RichBold -> mono (constant RichInlineTypeName .-> constant RichInlineTypeName) 328 | RichItalic -> mono (constant RichInlineTypeName .-> constant RichInlineTypeName) 329 | RichLink -> mono (constant TextTypeName .-> constant RichInlineTypeName .-> constant RichInlineTypeName) 330 | 331 | where 332 | constant nam = ConstantType TypeConstant { location, name = nam } 333 | mono t = Scheme {location, constraints = [], typ = t} 334 | poly p t = Scheme {location, constraints = p, typ = t} 335 | comparable t = 336 | ClassConstraint {className = CompareClassName, typ = pure t, location} 337 | addable t = 338 | ClassConstraint {className = AddOpClassName, typ = pure t, location} 339 | divisible t = 340 | ClassConstraint {className = DivideOpClassName, typ = pure t, location} 341 | frominteger t = 342 | ClassConstraint {className = FromIntegerClassName, typ = pure t, location} 343 | c = typeVariable' 2 RowKind 344 | a = typeVariable 0 345 | b = typeVariable 1 346 | d = typeVariable 3 347 | e = typeVariable 4 348 | record fs = 349 | RecordType 350 | (RowType 351 | TypeRow 352 | { location = BuiltIn 353 | , fields = 354 | map 355 | (\(name, typ) -> 356 | Field {name = FieldName name, typ, location = BuiltIn}) 357 | fs 358 | , typeVariable = Nothing 359 | }) 360 | typeVariable index = VariableType (typeVariable' index TypeKind) 361 | typeVariable' index k = 362 | TypeVariable {location = (), prefix = (), index = index, kind = k} 363 | 364 | -- TODO: implement properly 365 | binOpType :: NumericBinOp -> Type Generalised 366 | binOpType _ = nullType BuiltIn 367 | 368 | -------------------------------------------------------------------------------- 369 | -- Patterns 370 | 371 | pattern IntegerType :: Type Generalised 372 | pattern IntegerType <- ConstantType TypeConstant{name=IntegerTypeName} 373 | 374 | pattern DecimalType :: Natural -> Type Generalised 375 | pattern DecimalType nat <- 376 | ApplyType 377 | TypeApplication 378 | { function = 379 | ConstantType TypeConstant {location = BuiltIn, name = DecimalTypeName} 380 | , argument = 381 | ConstantType TypeConstant {location = BuiltIn, name = NatTypeName nat} 382 | , location = BuiltIn 383 | , kind = TypeKind 384 | } 385 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Types/Defaulter.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | 3 | module Inflex.Types.Defaulter where 4 | 5 | import Inflex.Types 6 | import Inflex.Types.Resolver 7 | 8 | -------------------------------------------------------------------------------- 9 | -- Types 10 | 11 | data DefaulterError 12 | = ResolutionError ResolutionError 13 | | DefaultingNoInstanceFound (ClassConstraint Polymorphic) 14 | deriving (Eq, Show) 15 | 16 | data ResolverDefaulterError e 17 | = DefaulterError DefaulterError 18 | | GeneraliseResolverError (GeneraliseResolveError e) 19 | deriving (Eq, Show) 20 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Types/Eval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE NamedFieldPuns, DuplicateRecordFields #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell #-} 5 | 6 | -- | 7 | 8 | module Inflex.Types.Eval where 9 | 10 | import Data.IORef 11 | import Data.Map.Strict (Map) 12 | import Data.Set (Set) 13 | import GHC.Natural 14 | import Inflex.Defaulter 15 | import Inflex.Optics 16 | import Inflex.Types 17 | import Optics 18 | import RIO (GLogFunc, HasGLogFunc(..)) 19 | 20 | data DefaultEvalError e 21 | = DefaulterErrored (ResolverDefaulterError e) 22 | deriving (Show, Eq) 23 | 24 | data Eval = Eval 25 | { glogfunc :: GLogFunc EvalMsg 26 | , globals :: Map Hash (Expression Resolved) 27 | , genericGlobalCache :: IORef (Map (Hash, Set InstanceName) (Expression Resolved)) 28 | } 29 | 30 | data EvalMsg 31 | = EvalStep (Expression Resolved) 32 | | GlobalMissing (Global Resolved) 33 | | CannotShrinkADecimalFromTo Natural Natural 34 | | MismatchingPrecisionsInFromDecimal Natural Natural 35 | | FoundGenericGlobalInCache Hash (Set InstanceName) 36 | | FoundMonoGlobalInCache Hash (Set InstanceName) 37 | | AddingGenericGlobalToCache Hash (Set InstanceName) 38 | | AddingGenericGlobalToCacheFromCell1 Hash (Set InstanceName) 39 | | EncounteredGenericGlobal Hash (Set InstanceName) 40 | deriving (Show) 41 | 42 | $(makeLensesWith (inflexRules ['glogfunc]) ''Eval) 43 | 44 | instance HasGLogFunc Eval where 45 | type GMsg Eval = EvalMsg 46 | gLogFuncL = toLensVL evalGlogfuncL 47 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Types/Filler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | 5 | -- | 6 | 7 | module Inflex.Types.Filler where 8 | 9 | import Data.List.NonEmpty (NonEmpty(..)) 10 | import Data.Map.Strict (Map) 11 | import qualified Data.Map.Strict as M 12 | import Data.Text (Text) 13 | import Data.Validation 14 | import Inflex.Types 15 | 16 | data FillerError e 17 | = MissingGlobal (FillerEnv e) 18 | Text 19 | | MissingGlobalUuid (FillerEnv e) 20 | Uuid 21 | | OtherCellError Text 22 | e 23 | | OtherCellUuidError Uuid 24 | e 25 | deriving (Eq, Show) 26 | 27 | newtype Filler e a = Filler 28 | { runFiller :: Validation (NonEmpty (FillerError e)) a 29 | } deriving (Functor, Applicative) 30 | 31 | data FillerEnv e = FillerEnv 32 | { namesTohash :: !(Map Text (Either e Hash)) 33 | , uuidsToHash :: !(Map Uuid (Either e Hash)) 34 | } deriving (Show, Eq) 35 | 36 | emptyFillerEnv :: FillerEnv e 37 | emptyFillerEnv = FillerEnv {namesTohash = mempty, uuidsToHash = mempty} 38 | 39 | insertNameAndUuid :: Text -> Uuid -> Either e Hash -> FillerEnv e -> FillerEnv e 40 | insertNameAndUuid name uuid result FillerEnv {namesTohash, uuidsToHash} = 41 | FillerEnv 42 | { namesTohash = M.insert name result namesTohash 43 | , uuidsToHash = M.insert uuid result uuidsToHash 44 | } 45 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Types/Generator.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE ApplicativeDo #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE DeriveFunctor #-} 8 | 9 | -- | Type generator for Inflex. 10 | 11 | module Inflex.Types.Generator 12 | where 13 | 14 | import Control.Monad.Reader 15 | import Control.Monad.State 16 | import Control.Monad.Validate 17 | import Data.List.NonEmpty (NonEmpty(..)) 18 | import Data.Map.Strict (Map) 19 | import Data.Sequence (Seq) 20 | import Inflex.Instances () 21 | import Inflex.Optics 22 | import qualified Inflex.Renamer as Renamer 23 | import Inflex.Types 24 | import Inflex.Types.Filler 25 | import Numeric.Natural 26 | import Optics 27 | 28 | -------------------------------------------------------------------------------- 29 | -- Types 30 | 31 | data GenerateError e 32 | = MissingVariableG (Variable Filled) 33 | | MissingHashG Hash 34 | | OtherCellErrorG (GlobalRef Renamed) e 35 | deriving (Show, Eq) 36 | 37 | data GenerateState = GenerateState 38 | { counter :: !Natural 39 | , equalityConstraints :: !(Seq EqualityConstraint) 40 | } deriving (Show) 41 | 42 | newtype Generate e a = Generate 43 | { runGenerator :: ValidateT (NonEmpty (GenerateError e)) (ReaderT (Env e) (State GenerateState)) a 44 | } deriving ( Functor 45 | , Applicative 46 | , Monad 47 | , MonadState GenerateState 48 | , MonadReader (Env e) 49 | ) 50 | 51 | data Env e = Env 52 | { scope :: ![Binding Generated] 53 | , globals :: Map Hash (Either e (Scheme Polymorphic)) 54 | } 55 | 56 | data RenameGenerateError e 57 | = RenameGenerateError Renamer.ParseRenameError 58 | | GeneratorErrors (NonEmpty (GenerateError e)) 59 | | FillErrors (NonEmpty (FillerError e)) 60 | deriving (Show, Eq) 61 | 62 | data HasConstraints a = HasConstraints 63 | { equalities :: !(Seq EqualityConstraint) 64 | , thing :: !a 65 | , mappings :: !(Map Cursor SourceLocation) 66 | } deriving (Show, Functor, Eq, Ord) 67 | 68 | $(makeLensesWith 69 | (inflexRules ['counter, 'equalityConstraints]) 70 | ''GenerateState) 71 | $(makeLensesWith (inflexRules ['scope]) ''Env) 72 | $(makeLensesWith (inflexRules ['Inflex.Types.Generator.mappings]) ''HasConstraints) 73 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Types/Optics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | 4 | 5 | module Inflex.Types.Optics where 6 | 7 | import Inflex.Optics 8 | import Inflex.Types 9 | import Optics 10 | 11 | $(do fmap 12 | concat 13 | (traverse 14 | (makeLensesWith (inflexRules [])) 15 | [ ''Apply 16 | , ''Infix 17 | , ''Record 18 | , ''Prop 19 | , ''Array 20 | , ''Variant 21 | , ''Case 22 | , ''Alternative 23 | , ''FieldE 24 | ])) 25 | $(makePrisms ''Expression) 26 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Types/Renamer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE TupleSections #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE ApplicativeDo #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE LambdaCase #-} 9 | {-# LANGUAGE DuplicateRecordFields #-} 10 | {-# LANGUAGE NamedFieldPuns #-} 11 | 12 | -- | Renamer types for Inflex language. 13 | 14 | module Inflex.Types.Renamer where 15 | 16 | import Control.Monad.State 17 | import Control.Monad.Validate 18 | import Data.List.NonEmpty (NonEmpty(..)) 19 | import Data.Map.Strict (Map) 20 | import Data.Set (Set) 21 | import Data.Text (Text) 22 | import Inflex.Instances () 23 | import Inflex.Optics 24 | import Inflex.Parser 25 | import Inflex.Types 26 | import Optics 27 | 28 | data RenameError 29 | = BUG_MissingVariable [Binding Parsed] 30 | (Map Text (GlobalRef Renamed)) 31 | (Variable Parsed) 32 | | NotInScope ParsedGlobal 33 | | NotInScopeLocal Text 34 | deriving (Show, Eq) 35 | 36 | newtype Renamer a = Renamer 37 | { runRenamer :: ValidateT (NonEmpty RenameError) (State ( Map Cursor SourceLocation 38 | , Set Text 39 | , Set Uuid 40 | , Map Cursor Text)) a 41 | } deriving ( Functor 42 | , Applicative 43 | , MonadState (Map Cursor SourceLocation, Set Text, Set Uuid, Map Cursor Text) 44 | , Monad 45 | ) 46 | 47 | data ParseRenameError 48 | = RenamerErrors (NonEmpty RenameError) 49 | | ParserErrored LexParseError 50 | deriving (Show, Eq) 51 | 52 | type CursorBuilder = Cursor -> Cursor 53 | 54 | data Env = Env 55 | { cursor :: !CursorBuilder 56 | , scope :: ![Binding Parsed] 57 | , globals :: !(Map Text (GlobalRef Renamed)) 58 | } 59 | 60 | data IsRenamed a = IsRenamed 61 | { thing :: a 62 | , mappings :: Map Cursor SourceLocation 63 | , nameMappings :: Map Cursor Text 64 | -- ^ Mappings, subset of `mappings', just for names. 65 | , unresolvedGlobals :: Set Text 66 | , unresolvedUuids :: Set Uuid 67 | } deriving (Show, Eq) 68 | 69 | $(makeLensesWith (inflexRules ['cursor, 'scope]) ''Env) 70 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Types/Resolver.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE NamedFieldPuns #-} 9 | {-# LANGUAGE DuplicateRecordFields #-} 10 | 11 | -- | 12 | 13 | module Inflex.Types.Resolver where 14 | 15 | import Control.Monad.State 16 | import Control.Monad.Validate 17 | import Data.List.NonEmpty (NonEmpty(..)) 18 | import Data.Map.Strict (Map) 19 | import Data.Sequence (Seq(..)) 20 | import Inflex.Generaliser 21 | import Inflex.Types 22 | import Numeric.Natural 23 | 24 | -------------------------------------------------------------------------------- 25 | -- Types 26 | 27 | -- Result of resolving. 28 | -- 29 | -- 1. An instance was found and inserted inline. 30 | -- 2. No instance was found with polytypes. 31 | data ResolutionSuccess 32 | = InstanceFound InstanceName 33 | | NoInstanceButPoly (ClassConstraint Polymorphic) 34 | deriving (Show, Eq) 35 | 36 | -- 1. The user put 2.52 when accuracy was 0.0. 37 | -- 2. Unsupported instance head. 38 | -- 3. No instance was found with monotypes. 39 | -- 4. Invalid type for class instance heads. 40 | data ResolutionError 41 | = LiteralDecimalPrecisionMismatch PrecisionMismatch 42 | | UnsupportedInstanceHead (ClassConstraint Polymorphic) 43 | | NoInstanceAndMono ClassName (TypeVariable Generalised) 44 | | NoInstanceForType ClassName (Type Polymorphic) 45 | deriving (Show, Eq) 46 | 47 | -- An implicit argument. 48 | data ImplicitArgument 49 | = ExactInstance InstanceName 50 | | DeferredDeBrujin DeBrujinOffset 51 | deriving (Show, Eq) 52 | 53 | newtype DeBrujinOffset = DeBrujinOffset 54 | { unDeBrujinOffset :: Int 55 | } deriving (Show, Eq, Ord) 56 | 57 | data PrecisionMismatch = PrecisionMismatch 58 | { supersetPlaces :: !Natural 59 | , subsetPlaces :: !Natural 60 | , constraint :: !(ClassConstraint Polymorphic) 61 | } deriving (Show, Eq) 62 | 63 | data GeneraliseResolveError e 64 | = ResolverErrors (NonEmpty ResolutionError) 65 | | GeneraliserErrored (SolveGeneraliseError e) 66 | deriving (Show, Eq) 67 | 68 | data IsResolved a = IsResolved 69 | { thing :: !a 70 | , scheme :: !(Scheme Polymorphic) 71 | , mappings :: !(Map Cursor SourceLocation) 72 | } deriving (Show, Eq) 73 | 74 | data ResolveState = ResolveState 75 | { implicits :: !(Seq (ClassConstraint Polymorphic)) 76 | -- ^ Each implicit constraint is added to the end of the sequence. 77 | 78 | -- The de Brujin index is calculated as current_deBurjin_index + 1 79 | -- + offset. Where offset = index (zero-based, left to right) 80 | -- from this implicits list. 81 | 82 | -- The same implicit argument may be used more than once, so a 83 | -- lookup is performed first. 84 | -- 85 | -- Finally, these are added -- in the same order! -- as class 86 | -- constraints to the top-level scheme class constraints. 87 | -- 88 | -- Nesting is 89 | -- 90 | -- f c1 c2 91 | -- is 92 | -- \-> \_ -> .. f (idx+1+0) (idx+1+1) .. 93 | -- ^-------| c1 c2 94 | -- ^-------------| 95 | -- has REVERSED order! 96 | -- :: C2, C1 => .. 97 | , defaulteds :: !(Map (TypeVariable Generalised) (Type Polymorphic)) 98 | } 99 | 100 | newtype Resolve a = Resolve 101 | { runResolve :: ValidateT (NonEmpty ResolutionError) (State ResolveState) a 102 | } deriving (Functor, Applicative, Monad, MonadState ResolveState) 103 | 104 | data ResolveReader = ResolveReader 105 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Types/SHA512.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE DeriveLift #-} 6 | {-# LANGUAGE DeriveGeneric #-} 7 | 8 | -- | SHA512 digest/hashing. 9 | 10 | module Inflex.Types.SHA512 11 | ( sha512 12 | , sha512HexParser 13 | , sha512ByteString 14 | , sha512String 15 | , sha512AsHexText 16 | , sha512AsHexBS 17 | , checkSha512Of 18 | , valueToSha512 19 | , sha512Text 20 | , SHA512(..) 21 | , Sha512Digest 22 | , sha512DigestBS 23 | , sha512DigestText 24 | , digestToSha512 25 | , concatDigests 26 | ) where 27 | 28 | import Control.DeepSeq 29 | import qualified Crypto.Hash as Hash (Digest, SHA512, hash, hashInit, hashUpdates, hashFinalize) 30 | import Data.Aeson 31 | import qualified Data.Attoparsec.Text as Atto.T 32 | import Data.ByteArray 33 | import Data.ByteString (ByteString) 34 | import qualified Data.ByteString as S 35 | import qualified Data.ByteString.Base16 as Hex 36 | import Data.ByteString.Lazy (toStrict) 37 | import Data.Hashable (Hashable) 38 | import Data.String 39 | import Data.Text (Text) 40 | import qualified Data.Text as T 41 | import Data.Text.Encoding (decodeUtf8, encodeUtf8) 42 | import qualified Data.Text.Encoding as T 43 | import Database.Persist.Sql 44 | import GHC.Generics 45 | import Language.Haskell.TH 46 | import Language.Haskell.TH.Instances () 47 | import Language.Haskell.TH.Syntax (Lift(..), Q, TExp(..)) 48 | 49 | -------------------------------------------------------------------------------- 50 | -- Type 51 | 52 | -- | A SHA512 key to address blobs. 53 | newtype SHA512 = 54 | SHA512 ByteString 55 | deriving (Eq, Ord, Lift, Generic, PersistFieldSql, PersistField, Hashable, NFData) 56 | 57 | -------------------------------------------------------------------------------- 58 | -- Instances 59 | 60 | instance Show SHA512 where 61 | show (SHA512 key) = "$$(" ++ show (Hex.encode key) ++ ")" 62 | 63 | -------------------------------------------------------------------------------- 64 | -- JSON 65 | 66 | instance ToJSON SHA512 where 67 | toJSON sha = String (sha512AsHexText sha) 68 | 69 | instance ToJSONKey SHA512 70 | 71 | instance FromJSON SHA512 where 72 | parseJSON (String val) = pure $ SHA512 $ fst $ Hex.decode $ T.encodeUtf8 val 73 | parseJSON value = 74 | fail $ "Expected JSON value of String, but instead got " <> show value 75 | 76 | instance FromJSONKey SHA512 77 | 78 | -------------------------------------------------------------------------------- 79 | -- Parsing 80 | 81 | -- | Parse a blob key in hex format. 82 | sha512HexParser :: Text -> Either String SHA512 83 | sha512HexParser = 84 | Atto.T.parseOnly 85 | (fmap 86 | SHA512 87 | (do bytes <- Atto.T.take 128 88 | case Hex.decode (T.encodeUtf8 bytes) of 89 | (result, wrong) 90 | | S.null wrong -> pure result 91 | _ -> fail "Invalid hex key.")) 92 | 93 | -------------------------------------------------------------------------------- 94 | -- Template Haskell 95 | 96 | sha512 :: Text -> Q Exp 97 | sha512 i = 98 | case sha512HexParser i of 99 | Left e -> error e 100 | Right v -> lift v 101 | 102 | instance IsString (Q (TExp SHA512)) where 103 | fromString i = 104 | if Prelude.length i == 128 105 | then case Hex.decode (fromString i) of 106 | (result, wrong) 107 | | S.null wrong -> fmap TExp (lift (SHA512 result)) 108 | _ -> fail "Invalid SHA512 format." 109 | else fail "Incorrect length for SHA512." 110 | 111 | -------------------------------------------------------------------------------- 112 | -- Representations 113 | 114 | sha512AsHexText :: SHA512 -> Text 115 | sha512AsHexText = decodeUtf8 . sha512AsHexBS 116 | 117 | sha512AsHexBS :: SHA512 -> ByteString 118 | sha512AsHexBS (SHA512 key) = Hex.encode key 119 | 120 | -------------------------------------------------------------------------------- 121 | -- Hasing things 122 | 123 | valueToSha512 :: Value -> SHA512 124 | valueToSha512 value = sha512ByteString $ toStrict $ encode value 125 | 126 | sha512ByteString :: ByteString -> SHA512 127 | sha512ByteString = 128 | SHA512 . convert . (Hash.hash :: ByteString -> Hash.Digest Hash.SHA512) 129 | 130 | checkSha512Of :: SHA512 -> ByteString -> Bool 131 | checkSha512Of hash bs = hash == sha512ByteString bs 132 | 133 | sha512String :: String -> SHA512 134 | sha512String str = sha512ByteString $ encodeUtf8 $ T.pack str 135 | 136 | sha512Text :: Text -> SHA512 137 | sha512Text = sha512ByteString . encodeUtf8 138 | 139 | -------------------------------------------------------------------------------- 140 | -- Digests 141 | 142 | newtype Sha512Digest = Sha512Digest 143 | { unSha512Digest :: Hash.Digest Hash.SHA512 144 | } deriving (Show, Eq, Ord) 145 | 146 | sha512DigestBS :: ByteString -> Sha512Digest 147 | sha512DigestBS = 148 | Sha512Digest . (Hash.hash :: ByteString -> Hash.Digest Hash.SHA512) 149 | 150 | sha512DigestText :: Text -> Sha512Digest 151 | sha512DigestText = sha512DigestBS . encodeUtf8 152 | 153 | concatDigests :: [Sha512Digest] -> Sha512Digest 154 | concatDigests = 155 | Sha512Digest . 156 | Hash.hashFinalize . 157 | Hash.hashUpdates (Hash.hashInit @Hash.SHA512) . fmap unSha512Digest 158 | 159 | digestToSha512 :: Sha512Digest -> SHA512 160 | digestToSha512 = 161 | SHA512 . 162 | convert . 163 | Hash.hashFinalize . 164 | Hash.hashUpdates (Hash.hashInit @Hash.SHA512) . pure . unSha512Digest 165 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Types/Solver.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE DataKinds #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE RecordWildCards #-} 9 | {-# LANGUAGE LambdaCase #-} 10 | {-# LANGUAGE NamedFieldPuns #-} 11 | {-# LANGUAGE DuplicateRecordFields #-} 12 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 13 | {-# LANGUAGE DeriveFunctor #-} 14 | 15 | -- | Solve equality constraints. 16 | 17 | module Inflex.Types.Solver 18 | ( Substitution(..) 19 | , SolveError(..) 20 | , IsSolved(..) 21 | , GenerateSolveError(..) 22 | , SolveReader(..) 23 | , SolveMsg(..) 24 | , Solve(..) 25 | ) where 26 | 27 | import Control.Monad.Except 28 | import Control.Monad.Reader 29 | import Control.Monad.State.Strict 30 | import Data.HashMap.Strict (HashMap) 31 | 32 | import Data.Map.Strict (Map) 33 | import Inflex.Generator 34 | import Inflex.Optics 35 | import Inflex.Types 36 | import Numeric.Natural 37 | import Optics.Lens 38 | import Optics.TH 39 | import RIO (HasStateRef(..), RIO, GLogFunc, HasGLogFunc(..), SomeRef) 40 | 41 | data SolveError 42 | = OccursCheckFail (TypeVariable Generated) (Type Generated) 43 | | KindMismatch (TypeVariable Generated) (Type Generated) 44 | | TypeMismatch EqualityConstraint 45 | | RowMismatch (TypeRow Generated) (TypeRow Generated) 46 | | NotRowTypes 47 | deriving (Show, Eq) 48 | 49 | data GenerateSolveError e 50 | = SolverError SolveError 51 | | GeneratorErrored (RenameGenerateError e) 52 | deriving (Show, Eq) 53 | 54 | data IsSolved a = IsSolved 55 | { thing :: !a 56 | , mappings :: !(Map Cursor SourceLocation) 57 | } deriving (Show, Eq) 58 | 59 | data Substitution = Substitution 60 | { before :: !(TypeVariable Generated) 61 | , after :: !(Type Generated) 62 | } deriving (Show, Eq) 63 | 64 | data SolveReader = SolveReader 65 | { glogfunc :: GLogFunc SolveMsg 66 | , counter :: SomeRef Natural 67 | , binds :: SomeRef (HashMap (TypeVariable Generated) (SomeRef (Type Generated))) 68 | } 69 | 70 | data SolveMsg 71 | = UnifyConstraints Int 72 | | UnifyConstraintsComplete Int 73 | | UnifyConstraintsIterate Int 74 | | UnifyEqualityConstraint EqualityConstraint 75 | | UnifyTypeApplications 76 | | UnifyRows (TypeRow Generated) (TypeRow Generated) 77 | | SuccessfulBindTypeVariable Substitution 78 | | GeneratedTypeVariable TypeVariablePrefix Kind Natural 79 | deriving (Show) 80 | 81 | $(makeLensesWith (inflexRules ['glogfunc, 'counter]) ''SolveReader) 82 | 83 | instance HasGLogFunc SolveReader where 84 | type GMsg SolveReader = SolveMsg 85 | gLogFuncL = toLensVL solveReaderGlogfuncL 86 | 87 | instance HasStateRef Natural SolveReader where 88 | stateRefL = toLensVL solveReaderCounterL 89 | 90 | newtype Solve a = Solve 91 | { runSolve :: RIO SolveReader a 92 | } deriving ( MonadState Natural 93 | , Monad 94 | , Functor 95 | , Applicative 96 | , MonadIO 97 | , MonadReader SolveReader 98 | ) 99 | -------------------------------------------------------------------------------- /inflex-lang/src/Inflex/Variants.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE NamedFieldPuns #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE DuplicateRecordFields #-} 7 | 8 | -- | 9 | 10 | module Inflex.Variants where 11 | 12 | import Inflex.Type 13 | import Inflex.Types 14 | 15 | -------------------------------------------------------------------------------- 16 | -- Bool 17 | 18 | reifyBool :: Expression Resolved -> Maybe Bool 19 | reifyBool = 20 | \case 21 | VariantExpression Variant {tag = TagName "true", argument = Nothing} -> 22 | Just True 23 | VariantExpression Variant {tag = TagName "false", argument = Nothing} -> 24 | Just False 25 | _ -> Nothing 26 | 27 | trueVariant :: StagedLocation Resolved -> Expression Resolved 28 | trueVariant location = 29 | VariantExpression 30 | Variant {location, typ = boolType location, tag = TagName "true", argument = Nothing} 31 | 32 | falseVariant :: StagedLocation Resolved -> Expression Resolved 33 | falseVariant location = 34 | VariantExpression 35 | Variant {location, typ = boolType location, tag = TagName "false", argument = Nothing} 36 | 37 | -------------------------------------------------------------------------------- 38 | -- Ordering 39 | 40 | equalVariant :: StagedLocation Resolved -> Expression Resolved 41 | equalVariant location = 42 | VariantExpression 43 | Variant {location, typ = boolType location, tag = TagName "=", argument = Nothing} 44 | 45 | lessVariant :: StagedLocation Resolved -> Expression Resolved 46 | lessVariant location = 47 | VariantExpression 48 | Variant {location, typ = boolType location, tag = TagName "<", argument = Nothing} 49 | 50 | moreVariant :: StagedLocation Resolved -> Expression Resolved 51 | moreVariant location = 52 | VariantExpression 53 | Variant {location, typ = boolType location, tag = TagName ">", argument = Nothing} 54 | 55 | -------------------------------------------------------------------------------- 56 | -- Option 57 | 58 | -- | Variant given a complete type signature. 59 | variantSigged :: 60 | TagName 61 | -> StagedType Resolved 62 | -> Maybe (Expression Resolved) 63 | -> Expression Resolved 64 | variantSigged tag typ argument = 65 | VariantExpression 66 | Variant 67 | { location = BuiltIn 68 | , typ 69 | , tag 70 | , argument 71 | } 72 | 73 | okTagName :: TagName 74 | okTagName = TagName "ok" 75 | -------------------------------------------------------------------------------- /inflex-lang/test/LexSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE DuplicateRecordFields #-} 4 | 5 | -- | Test the lexer. 6 | 7 | module LexSpec where 8 | 9 | import Data.Decimal 10 | import qualified Data.Sequence as Seq 11 | import Inflex.Lexer 12 | import Inflex.Types 13 | import Test.Hspec 14 | 15 | spec :: Spec 16 | spec = 17 | it 18 | "Tokens" 19 | (shouldBe 20 | (lexText 21 | "" 22 | "@uuid:1ea653f3-67f7-4fad-9892-85ce6cbf10a7 \ 23 | \AB ab d_ex_f 123 456.1 123.456 12.000 ( )[] {:,} \ 24 | \@sha512:3ba402f10ef7807ab8767a44d57ed1b6dcfc84d629219a0603535993c93b6279ecb4aab48763b5b84b8c45d9ea2b90bf7356e06b063cc4478f2b817d66f449ad @prim:array_map @uuid:1ea653f3-67f7-4fad-9892-85ce6cbf10a7-@uuid:1ea653f3-67f7-4fad-9892-85ce6cbf10a7\ 25 | \ \"foo\"\"bar\"\ 26 | \ @prim:rich_doc @prim:rich_paragraph @prim:rich_bold @prim:rich_italic @prim:rich_link \ 27 | \ @prim:rich_text @prim:rich_cell \ 28 | \ @cell:uuid:1ea653f3-67f7-4fad-9892-85ce6cbf10a7") 29 | (Right 30 | (Seq.fromList 31 | [ Located 32 | { location = 33 | SourceLocation 34 | { start = SourcePos {line = 1, column = 1, name = ""} 35 | , end = SourcePos {line = 1, column = 43, name = ""} 36 | } 37 | , thing = 38 | GlobalToken 39 | (ParsedUuid (Uuid "1ea653f3-67f7-4fad-9892-85ce6cbf10a7")) 40 | } 41 | , Located 42 | { location = 43 | SourceLocation 44 | { start = SourcePos {line = 1, column = 44, name = ""} 45 | , end = SourcePos {line = 1, column = 46, name = ""} 46 | } 47 | , thing = AnyWordToken "AB" 48 | } 49 | , Located 50 | { location = 51 | SourceLocation 52 | { start = SourcePos {line = 1, column = 47, name = ""} 53 | , end = SourcePos {line = 1, column = 49, name = ""} 54 | } 55 | , thing = CamelCaseToken "ab" 56 | } 57 | , Located 58 | { location = 59 | SourceLocation 60 | { start = SourcePos {line = 1, column = 50, name = ""} 61 | , end = SourcePos {line = 1, column = 56, name = ""} 62 | } 63 | , thing = CamelCaseToken "d_ex_f" 64 | } 65 | , Located 66 | { location = 67 | SourceLocation 68 | { start = SourcePos {line = 1, column = 57, name = ""} 69 | , end = SourcePos {line = 1, column = 60, name = ""} 70 | } 71 | , thing = NaturalToken 123 72 | } 73 | , Located 74 | { location = 75 | SourceLocation 76 | { start = SourcePos {line = 1, column = 61, name = ""} 77 | , end = SourcePos {line = 1, column = 66, name = ""} 78 | } 79 | , thing = DecimalToken (Decimal {places = 1, integer = 4561}) 80 | } 81 | , Located 82 | { location = 83 | SourceLocation 84 | { start = SourcePos {line = 1, column = 67, name = ""} 85 | , end = SourcePos {line = 1, column = 74, name = ""} 86 | } 87 | , thing = DecimalToken (Decimal {places = 3, integer = 123456}) 88 | } 89 | , Located 90 | { location = 91 | SourceLocation 92 | { start = SourcePos {line = 1, column = 75, name = ""} 93 | , end = SourcePos {line = 1, column = 81, name = ""} 94 | } 95 | , thing = DecimalToken (Decimal {places = 3, integer = 12000}) 96 | } 97 | , Located 98 | { location = 99 | SourceLocation 100 | { start = SourcePos {line = 1, column = 82, name = ""} 101 | , end = SourcePos {line = 1, column = 83, name = ""} 102 | } 103 | , thing = OpenRoundToken 104 | } 105 | , Located 106 | { location = 107 | SourceLocation 108 | { start = SourcePos {line = 1, column = 84, name = ""} 109 | , end = SourcePos {line = 1, column = 85, name = ""} 110 | } 111 | , thing = CloseRoundToken 112 | } 113 | , Located 114 | { location = 115 | SourceLocation 116 | { start = SourcePos {line = 1, column = 85, name = ""} 117 | , end = SourcePos {line = 1, column = 86, name = ""} 118 | } 119 | , thing = OpenSquareToken 120 | } 121 | , Located 122 | { location = 123 | SourceLocation 124 | { start = SourcePos {line = 1, column = 86, name = ""} 125 | , end = SourcePos {line = 1, column = 87, name = ""} 126 | } 127 | , thing = CloseSquareToken 128 | } 129 | , Located 130 | { location = 131 | SourceLocation 132 | { start = SourcePos {line = 1, column = 88, name = ""} 133 | , end = SourcePos {line = 1, column = 89, name = ""} 134 | } 135 | , thing = OpenCurlyToken 136 | } 137 | , Located 138 | { location = 139 | SourceLocation 140 | { start = SourcePos {line = 1, column = 89, name = ""} 141 | , end = SourcePos {line = 1, column = 90, name = ""} 142 | } 143 | , thing = ColonToken 144 | } 145 | , Located 146 | { location = 147 | SourceLocation 148 | { start = SourcePos {line = 1, column = 90, name = ""} 149 | , end = SourcePos {line = 1, column = 91, name = ""} 150 | } 151 | , thing = CommaToken 152 | } 153 | , Located 154 | { location = 155 | SourceLocation 156 | { start = SourcePos {line = 1, column = 91, name = ""} 157 | , end = SourcePos {line = 1, column = 92, name = ""} 158 | } 159 | , thing = CloseCurlyToken 160 | } 161 | , Located 162 | { location = 163 | SourceLocation 164 | { start = SourcePos {line = 1, column = 93, name = ""} 165 | , end = SourcePos {line = 1, column = 229, name = ""} 166 | } 167 | , thing = 168 | GlobalToken 169 | (ParsedHash 170 | (Hash $$("3ba402f10ef7807ab8767a44d57ed1b6dcfc84d629219a0603535993c93b6279ecb4aab48763b5b84b8c45d9ea2b90bf7356e06b063cc4478f2b817d66f449ad"))) 171 | } 172 | , Located 173 | { location = 174 | SourceLocation 175 | { start = SourcePos {line = 1, column = 230, name = ""} 176 | , end = SourcePos {line = 1, column = 245, name = ""} 177 | } 178 | , thing = GlobalToken (ParsedPrim MapFunction) 179 | } 180 | , Located 181 | { location = 182 | SourceLocation 183 | { start = SourcePos {line = 1, column = 246, name = ""} 184 | , end = SourcePos {line = 1, column = 288, name = ""} 185 | } 186 | , thing = 187 | GlobalToken 188 | (ParsedUuid (Uuid "1ea653f3-67f7-4fad-9892-85ce6cbf10a7")) 189 | } 190 | , Located 191 | { location = 192 | SourceLocation 193 | { start = SourcePos {line = 1, column = 288, name = ""} 194 | , end = SourcePos {line = 1, column = 289, name = ""} 195 | } 196 | , thing = OperatorToken "-" 197 | } 198 | , Located 199 | { location = 200 | SourceLocation 201 | { start = SourcePos {line = 1, column = 289, name = ""} 202 | , end = SourcePos {line = 1, column = 331, name = ""} 203 | } 204 | , thing = 205 | GlobalToken 206 | (ParsedUuid (Uuid "1ea653f3-67f7-4fad-9892-85ce6cbf10a7")) 207 | } 208 | , Located 209 | { location = 210 | SourceLocation 211 | { start = SourcePos {line = 1, column = 332, name = ""} 212 | , end = SourcePos {line = 1, column = 337, name = ""} 213 | } 214 | , thing = StringToken "foo" 215 | } 216 | , Located 217 | { location = 218 | SourceLocation 219 | { start = SourcePos {line = 1, column = 337, name = ""} 220 | , end = SourcePos {line = 1, column = 342, name = ""} 221 | } 222 | , thing = StringToken "bar" 223 | }, 224 | 225 | -- Rich text 226 | Located {location = SourceLocation {start = SourcePos {line = 1, column = 343, name = ""}, end = SourcePos {line = 1, column = 357, name = ""}}, thing = GlobalToken (ParsedPrim RichDoc)},Located {location = SourceLocation {start = SourcePos {line = 1, column = 358, name = ""}, end = SourcePos {line = 1, column = 378, name = ""}}, thing = GlobalToken (ParsedPrim RichParagraph)},Located {location = SourceLocation {start = SourcePos {line = 1, column = 379, name = ""}, end = SourcePos {line = 1, column = 394, name = ""}}, thing = GlobalToken (ParsedPrim RichBold)},Located {location = SourceLocation {start = SourcePos {line = 1, column = 395, name = ""}, end = SourcePos {line = 1, column = 412, name = ""}}, thing = GlobalToken (ParsedPrim RichItalic)},Located {location = SourceLocation {start = SourcePos {line = 1, column = 413, name = ""}, end = SourcePos {line = 1, column = 428, name = ""}}, thing = GlobalToken (ParsedPrim RichLink)},Located {location = SourceLocation {start = SourcePos {line = 1, column = 430, name = ""}, end = SourcePos {line = 1, column = 445, name = ""}}, thing = GlobalToken (ParsedPrim RichText)}, 227 | -- Rich cell references 228 | Located {location = SourceLocation {start = SourcePos {line = 1, column = 446, name = ""}, end = SourcePos {line = 1, column = 461, name = ""}}, thing = GlobalToken (ParsedPrim RichCell)},Located {location = SourceLocation {start = SourcePos {line = 1, column = 463, name = ""}, end = SourcePos {line = 1, column = 510, name = ""}}, thing = CellAddressToken (RefUuid (Uuid "1ea653f3-67f7-4fad-9892-85ce6cbf10a7"))} 229 | ]))) 230 | -------------------------------------------------------------------------------- /inflex-lang/test/Match.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE TemplateHaskellQuotes #-} 3 | 4 | -- | A simple way to match a pattern on an expression. 5 | 6 | module Match where 7 | 8 | import Data.Generics 9 | import qualified Data.List as List 10 | import Data.Maybe 11 | import Language.Haskell.TH (Q, Pat, Exp) 12 | import qualified Language.Haskell.TH as TH 13 | import Test.Hspec.Expectations 14 | 15 | shouldReturnSatisfy :: (HasCallStack, Show a, Eq a) => IO a -> (a -> Bool) -> Expectation 16 | action `shouldReturnSatisfy` expected = action >>= (`shouldSatisfy` expected) 17 | 18 | -- | Take a pattern and see whether it matches. 19 | match :: Q Exp -> Q Exp 20 | match pat = 21 | TH.lamCaseE 22 | [ TH.match (expToPat pat) (TH.normalB (TH.conE 'True)) [] 23 | , TH.match TH.wildP (TH.normalB (TH.conE 'False)) [] 24 | ] 25 | 26 | -- | Why from Exp instead of Pat? Because hindent and 27 | -- structured-haskell-mode handle it better. 28 | expToPat :: Q Exp -> Q Pat 29 | expToPat e0 = do 30 | e <- e0 31 | pure (go (everywhere (mkT cleanName) e)) 32 | where 33 | go = 34 | \case 35 | TH.AppE f arg 36 | | (TH.ConE name, args) <- unfold f [arg] -> 37 | TH.ConP name (map go args) 38 | TH.ConE name -> TH.ConP name [] 39 | TH.RecConE name fields -> 40 | TH.RecP name (map (\(k, v) -> (k, go v)) fields) 41 | TH.LitE lit -> TH.LitP lit 42 | TH.ParensE e -> TH.ParensP (go e) 43 | TH.TupE es -> TH.TupP (map go es) 44 | TH.ListE es -> TH.ListP (map go es) 45 | TH.SigE e t -> TH.SigP (go e) t 46 | TH.UnboundVarE {} -> TH.WildP 47 | e -> 48 | TH.ViewP 49 | (TH.InfixE Nothing (TH.VarE '(==)) (pure e)) 50 | (TH.ConP 'True []) 51 | unfold e args = 52 | case e of 53 | TH.AppE f a -> unfold f (a : args) 54 | _ -> (e, args) 55 | -- Clean disambiguated record fields: $sel:file:CsvImportSpec => file 56 | -- If we don't clean these up, TH complains about it being an invalid name: 57 | -- Illegal variable name: ‘$sel:file:CsvImportSpec’ 58 | cleanName n = fromMaybe n (fmap TH.mkName . clean . TH.nameBase $ n) 59 | where 60 | clean s = 61 | case List.stripPrefix "$sel:" s of 62 | Just rest -> pure (takeWhile (/= ':') rest) 63 | Nothing -> Nothing 64 | -------------------------------------------------------------------------------- /inflex-lang/test/NormalFormSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, TemplateHaskell #-} 2 | -- | 3 | 4 | module NormalFormSpec where 5 | 6 | import qualified Data.HashMap.Strict.InsOrd as OM 7 | import Inflex.NormalFormCheck 8 | import Inflex.Parser 9 | import Inflex.Types 10 | import Match 11 | import Test.Hspec 12 | 13 | spec :: Spec 14 | spec = do 15 | describe 16 | "Succeeding" 17 | (do describe "One-way" oneway 18 | describe "Inferred" inferred) 19 | describe "Erroring" erroring 20 | 21 | inferred :: Spec 22 | inferred = do 23 | it 24 | "array a vs array Nothing" 25 | (shouldBe 26 | (fmap expressionGenerate (parseText "" "[[1],[]]")) 27 | (Right (Right (ArrayT (Just (ArrayT (Just IntegerT))))))) 28 | it 29 | "[\"foo\",\"bar\"]" 30 | (shouldBe 31 | (fmap expressionGenerate (parseText "" "[\"foo\",\"bar\"]")) 32 | (Right (Right (ArrayT (Just TextT))))) 33 | it 34 | "[1,2,3]" 35 | (shouldBe 36 | (fmap expressionGenerate (parseText "" "[1,2,3]")) 37 | (Right (Right (ArrayT (Just IntegerT))))) 38 | it 39 | "[1.0,2,3.000]" 40 | (shouldBe 41 | (fmap expressionGenerate (parseText "" "[1.0,2,3.000]")) 42 | (Right (Right (ArrayT (Just (DecimalT 3)))))) 43 | it 44 | "[[1],[2],[3]]" 45 | (shouldBe 46 | (fmap expressionGenerate (parseText "" "[[1],[2],[3]]")) 47 | (Right (Right (ArrayT (Just (ArrayT (Just IntegerT))))))) 48 | it 49 | "{x:1,y:\"a\",z:[],q:1.2}" 50 | (shouldBe 51 | (fmap expressionGenerate (parseText "" "{x:1,y:\"a\",z:[],q:1.2}")) 52 | (Right 53 | (Right 54 | (RecordT 55 | (OM.fromList 56 | [ (FieldName {unFieldName = "z"}, ArrayT Nothing) 57 | , (FieldName {unFieldName = "q"}, DecimalT 1) 58 | , (FieldName {unFieldName = "x"}, IntegerT) 59 | , (FieldName {unFieldName = "y"}, TextT) 60 | ]))))) 61 | it 62 | "[{x:1,y:\"a\",z:[],q:1.2},{q:1.2,z:[],x:1,y:\"a\"}]" 63 | (shouldBe 64 | (fmap 65 | expressionGenerate 66 | (parseText "" "[{x:1,y:\"a\",z:[],q:1.2},{q:1.2,z:[],x:1,y:\"a\"}]")) 67 | (Right 68 | (Right 69 | (ArrayT 70 | (Just 71 | (RecordT 72 | (OM.fromList 73 | [ (FieldName {unFieldName = "z"}, ArrayT Nothing) 74 | , (FieldName {unFieldName = "q"}, DecimalT 1) 75 | , (FieldName {unFieldName = "x"}, IntegerT) 76 | , (FieldName {unFieldName = "y"}, TextT) 77 | ]))))))) 78 | it 79 | "[{x:1,y:\"a\",z:[],q:1.2},{q:1.2,z:[],x:1.00,y:\"a\"}]" 80 | (shouldBe 81 | (fmap 82 | expressionGenerate 83 | (parseText "" "[{x:1,y:\"a\",z:[],q:1.2},{q:1.2,z:[],x:1.00,y:\"a\"}]")) 84 | (Right 85 | (Right 86 | (ArrayT 87 | (Just 88 | (RecordT 89 | (OM.fromList 90 | [ (FieldName {unFieldName = "z"}, ArrayT Nothing) 91 | , (FieldName {unFieldName = "q"}, DecimalT 1) 92 | , (FieldName {unFieldName = "x"}, DecimalT 2) 93 | , (FieldName {unFieldName = "y"}, TextT) 94 | ]))))))) 95 | 96 | oneway :: Spec 97 | oneway = do 98 | it 99 | "promotion of integer to decimal" 100 | (shouldBe 101 | (fmap resolveParsedT (parseText "" "[1] :: [Decimal 2]")) 102 | (Right (Right (ArrayT (Just (DecimalT 2)))))) 103 | it 104 | "check wider signature is fine" 105 | (shouldBe 106 | (fmap resolveParsedT (parseText "" "[1.23, 1.23] :: [Decimal 3]")) 107 | (Right (Right (ArrayT (Just (DecimalT 3)))))) 108 | it 109 | "check varying precisions is fine" 110 | (shouldBe 111 | (fmap resolveParsedT (parseText "" "[1.23, 1.2] :: [Decimal 2]")) 112 | (Right (Right (ArrayT (Just (DecimalT 2)))))) 113 | it 114 | "[\"foo\",\"bar\"] :: [Text]" 115 | (shouldBe 116 | (fmap resolveParsedT (parseText "" "[\"foo\",\"bar\"] :: [Text]")) 117 | (Right (Right (ArrayT (Just TextT))))) 118 | it 119 | "[#ok(1)] :: []" 120 | (do shouldBe 121 | (fmap resolveParsedT (parseText "" "[#ok(1)] :: []")) 122 | (Right 123 | (Right 124 | (ArrayT 125 | (pure 126 | (VariantT 127 | (OM.singleton (TagName {unTagName = "ok"}) IntegerT))))))) 128 | it 129 | "variants varying" 130 | (shouldBe 131 | (fmap 132 | resolveParsedT 133 | (parseText "" "[#ok(1.1),#none] :: []")) 134 | (Right 135 | (Right 136 | (ArrayT 137 | (Just 138 | (VariantT 139 | (OM.fromList 140 | [ (TagName {unTagName = "ok"}, DecimalT 2) 141 | , (TagName {unTagName = "none"}, RecordT mempty) 142 | ]))))))) 143 | it 144 | "variants and records combined" 145 | (shouldBe 146 | (fmap 147 | resolveParsedT 148 | (parseText "" "[{x:#ok(1)},{x:#ok(4)}] :: [{x:}]")) 149 | (Right 150 | (Right 151 | (ArrayT 152 | (Just 153 | (RecordT 154 | (OM.fromList 155 | [ ( FieldName {unFieldName = "x"} 156 | , VariantT 157 | (OM.fromList 158 | [(TagName {unTagName = "ok"}, IntegerT)])) 159 | ]))))))) 160 | it 161 | "signature for list of records" 162 | (shouldBe 163 | (fmap 164 | resolveParsedT 165 | (parseText 166 | "" 167 | "[{x:1,y:\"a\",q:1.2}] :: [{x:Integer,y:Text,q:Decimal 2}]")) 168 | (Right 169 | (Right 170 | (ArrayT 171 | (Just 172 | (RecordT 173 | (OM.fromList 174 | [ (FieldName {unFieldName = "q"}, DecimalT 2) 175 | , (FieldName {unFieldName = "x"}, IntegerT) 176 | , (FieldName {unFieldName = "y"}, TextT) 177 | ]))))))) 178 | 179 | erroring :: Spec 180 | erroring = do 181 | it 182 | "couldn't intern type" 183 | (shouldSatisfy 184 | (fmap resolveParsedT (parseText "" "[1.23, 1.203] :: _")) 185 | $(match [|Right (Left (CouldntInternType _))|])) 186 | it 187 | "no type sig" 188 | (shouldBe 189 | (fmap resolveParsedT (parseText "" "[1.23, 1.203]")) 190 | (Right (Left NoTypeSig))) 191 | it 192 | "[1.23, 1.203] :: [Decimal 2]" 193 | (shouldBe 194 | (fmap resolveParsedT (parseText "" "[1.23, 1.203] :: [Decimal 2]")) 195 | (Right (Left (TypeMismatch (DecimalT 2) (DecimalT 3))))) 196 | it 197 | "[1.1] :: [Integer]" 198 | (shouldBe 199 | (fmap resolveParsedT (parseText "" "[1.1] :: [Integer]")) 200 | (Right (Left (TypeMismatch IntegerT (DecimalT 1))))) 201 | it 202 | "[#ok(1.1)] :: []" 203 | (shouldBe 204 | (fmap resolveParsedT (parseText "" "[#ok(1.1)] :: []")) 205 | (Right (Left (TypeMismatch IntegerT (DecimalT 1))))) 206 | it 207 | "differing labels of same name" 208 | (shouldBe 209 | (fmap 210 | resolveParsedT 211 | (parseText 212 | "" 213 | "[{x:#ok(1)},{x:#ok(\"wibble\")}] :: [{x:}]")) 214 | (Right (Left (TypeMismatch IntegerT TextT)))) 215 | it 216 | "[1,\"woo\",3]" 217 | (shouldBe 218 | (fmap expressionGenerate (parseText "" "[1,\"woo\",3]")) 219 | (Right (Left (TypeMismatch IntegerT TextT)))) 220 | it 221 | "[{y:1,x:\"a\",q:[],z:1.2},{q:1.2,z:[],x:1,y:\"a\"}]" 222 | (shouldBe 223 | (fmap 224 | expressionGenerate 225 | (parseText "" "[{y:1,x:\"a\",q:[],z:1.2},{q:1.2,z:[],x:1,y:\"a\"}]")) 226 | (Right (Left (TypeMismatch (DecimalT 1) (ArrayT Nothing))))) 227 | it 228 | "[{y:1,x:\"a\",q:[],z:1.2},{q:1.2,z:[],x:1,y:\"a\"}]" 229 | (shouldBe 230 | (fmap 231 | resolveParsedT 232 | (parseText "" "[{y:1,x:\"a\"},{y:1,k:\"a\"}]::[{y:Integer,x:Text}]")) 233 | (Right 234 | (Left 235 | (RecordFieldsMismatch 236 | [FieldName {unFieldName = "y"}, FieldName {unFieldName = "x"}] 237 | [FieldName {unFieldName = "y"}, FieldName {unFieldName = "k"}])))) 238 | it 239 | "fields mismatch for unifyT" 240 | (shouldBe 241 | (fmap 242 | expressionGenerate 243 | (parseText "" "[{x:1,y:\"a\",z:[],q:1.2},{q:1.2,z:[],x:1,k:\"a\"}]")) 244 | (Right 245 | (Left 246 | (RecordFieldsMismatch 247 | [ FieldName {unFieldName = "x"} 248 | , FieldName {unFieldName = "y"} 249 | , FieldName {unFieldName = "z"} 250 | , FieldName {unFieldName = "q"} 251 | ] 252 | [ FieldName {unFieldName = "q"} 253 | , FieldName {unFieldName = "z"} 254 | , FieldName {unFieldName = "x"} 255 | , FieldName {unFieldName = "k"} 256 | ])))) 257 | -------------------------------------------------------------------------------- /inflex-lang/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /screenshots/E9nc_HkWQAMA95c.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisdone-archive/inflex/1361479368d21ccdb6e481a3394a4bf22776e1e0/screenshots/E9nc_HkWQAMA95c.png -------------------------------------------------------------------------------- /screenshots/E_D_vWoX0AEHr0M.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisdone-archive/inflex/1361479368d21ccdb6e481a3394a4bf22776e1e0/screenshots/E_D_vWoX0AEHr0M.png -------------------------------------------------------------------------------- /screenshots/EpnDWJ9XIAQ8Ej7.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisdone-archive/inflex/1361479368d21ccdb6e481a3394a4bf22776e1e0/screenshots/EpnDWJ9XIAQ8Ej7.jpeg -------------------------------------------------------------------------------- /screenshots/Esl-GBGXMAIPPgr.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisdone-archive/inflex/1361479368d21ccdb6e481a3394a4bf22776e1e0/screenshots/Esl-GBGXMAIPPgr.png -------------------------------------------------------------------------------- /screenshots/Eus43sKWgAcUMrL.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisdone-archive/inflex/1361479368d21ccdb6e481a3394a4bf22776e1e0/screenshots/Eus43sKWgAcUMrL.jpeg -------------------------------------------------------------------------------- /screenshots/Eus5qBTXIAI_eVp.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisdone-archive/inflex/1361479368d21ccdb6e481a3394a4bf22776e1e0/screenshots/Eus5qBTXIAI_eVp.jpeg -------------------------------------------------------------------------------- /screenshots/Eus6K9pXAAIHPrV.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisdone-archive/inflex/1361479368d21ccdb6e481a3394a4bf22776e1e0/screenshots/Eus6K9pXAAIHPrV.jpeg -------------------------------------------------------------------------------- /screenshots/FLXp2BxX0AAn5R9.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisdone-archive/inflex/1361479368d21ccdb6e481a3394a4bf22776e1e0/screenshots/FLXp2BxX0AAn5R9.jpeg -------------------------------------------------------------------------------- /screenshots/inflex-screenie.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chrisdone-archive/inflex/1361479368d21ccdb6e481a3394a4bf22776e1e0/screenshots/inflex-screenie.jpeg -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.20 2 | system-ghc: true 3 | allow-newer: true 4 | ghc-options: 5 | inflex-lang: '-j4 -dppr-user-length=0 -dppr-cols=10000' 6 | 7 | packages: 8 | - inflex-lang 9 | 10 | extra-deps: 11 | 12 | # chrisdone forks 13 | - github: chrisdone/flatparse 14 | commit: 3213749f811fbfa5983563f26989ac43d13cf499 15 | - github: chrisdone/streaming-parsers 16 | commit: 955675a074e8443ab9a65cc1bcb7abd7e49e188f 17 | subdirs: 18 | - reparsec 19 | 20 | # Pinned github versions 21 | - github: commercialhaskell/rio 22 | commit: 91c379f29b158dc91e7bea059fe7874d9a16973c 23 | subdirs: 24 | - rio 25 | - rio-orphans 26 | - github: inflex-io/early 27 | commit: a642cea8d33bd5475fe56c0d31ff51287692789d 28 | - github: chrisdone/lexx 29 | commit: 1d57bf997666d35cf4304418b22d6c08ede41dcc 30 | 31 | # Specific hackage versions 32 | - byteunits-0.4.0.2@sha256:659e242f8051436582bfb748d857134b2fb7da80f33d31df6a22431cc77878db,1387 33 | - monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 34 | - happy-1.19.9@sha256:f8c774230735a390c287b2980cfcd2703d24d8dde85a01ea721b7b4b4c82944f,4667 35 | - megaparsec-8.0.0@sha256:362f85e243ecbcb550e1de6e5c74ba5a50c09edaa1208c99bc5b9fd242227fc6,3808 36 | - optics-0.2@sha256:813ef6cc4d2e2b5ee00435831031f38917ba01d1e56dcb62dc18cd0315a9ccb7,6296 37 | - optics-core-0.2@sha256:6966f4f8cc9163b63d87dcca2d2617684b4ac8a80c5e50c69e9f3adf4dcdf0e9,4409 38 | - optics-extra-0.2@sha256:211ce1dfd1b3ffd95c1158d8c8beb53cbd17c4d477169e226b1831607f6789eb,3370 39 | - optics-th-0.2@sha256:b4f6c5a3f134c697837190ed6da969dd284aefe79e43c3ef793093b607bb83b9,1929 40 | - indexed-profunctors-0.1@sha256:ddf618d0d4c58319c1e735e746bc69a1021f13b6f475dc9614b80af03432e6d4,1016 41 | - string-quote-0.0.1@sha256:7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3,758 42 | - rainbow-0.34.2.2@sha256:522458692f361d86fa0dbc5085f96511138959dd664c8828c3672032ae558b67,2111 43 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | size: 32855 9 | url: https://github.com/chrisdone/flatparse/archive/3213749f811fbfa5983563f26989ac43d13cf499.tar.gz 10 | cabal-file: 11 | size: 2523 12 | sha256: 391e4b1af4edd33d53e9e8920de7a6325b1730316732f2e811192883b8504b70 13 | name: flatparse 14 | version: 0.2.0.1 15 | sha256: eff7eaef5dc8006b06151fdee9c15aca15f90f1463451abfdcfc0d8db4183923 16 | pantry-tree: 17 | size: 1132 18 | sha256: 109b0c6f4a2736596d7177e2ecfac29b586d9d61802df7514dd525a15263e20e 19 | original: 20 | url: https://github.com/chrisdone/flatparse/archive/3213749f811fbfa5983563f26989ac43d13cf499.tar.gz 21 | - completed: 22 | size: 92392 23 | subdir: reparsec 24 | url: https://github.com/chrisdone/streaming-parsers/archive/955675a074e8443ab9a65cc1bcb7abd7e49e188f.tar.gz 25 | cabal-file: 26 | size: 995 27 | sha256: a9e91c09182c8573fdde919bb1e6e117fa5b373543aa6fcf58075dafff3b754f 28 | name: reparsec 29 | version: 0.0.0 30 | sha256: ce83c812a53d3b32c5b163b6aa23ce7e3766ec1942c6cc66f4598a8ce6a47ac3 31 | pantry-tree: 32 | size: 474 33 | sha256: c724eed5d0077071c5199dd020b79945cf83d3a0cd677dfb611cca0c7c8d77ee 34 | original: 35 | subdir: reparsec 36 | url: https://github.com/chrisdone/streaming-parsers/archive/955675a074e8443ab9a65cc1bcb7abd7e49e188f.tar.gz 37 | - completed: 38 | size: 67654 39 | subdir: rio 40 | url: https://github.com/commercialhaskell/rio/archive/91c379f29b158dc91e7bea059fe7874d9a16973c.tar.gz 41 | cabal-file: 42 | size: 3688 43 | sha256: 13e9ce4561a87ae49d7600b0dd63482dd98d285147ce431a52bccbe73e3031df 44 | name: rio 45 | version: 0.1.19.0 46 | sha256: f6a5ed84d8582968acfe25ea9eccea96361b3304f8463098793b05b873ee5681 47 | pantry-tree: 48 | size: 4854 49 | sha256: a0b17853ca21584119764a182dfba8c7a273180cda2ec63191fec7e2ad45f066 50 | original: 51 | subdir: rio 52 | url: https://github.com/commercialhaskell/rio/archive/91c379f29b158dc91e7bea059fe7874d9a16973c.tar.gz 53 | - completed: 54 | size: 67654 55 | subdir: rio-orphans 56 | url: https://github.com/commercialhaskell/rio/archive/91c379f29b158dc91e7bea059fe7874d9a16973c.tar.gz 57 | cabal-file: 58 | size: 1611 59 | sha256: d0d958340e7100e636419b143f27f2deaabdae4e26305410a221399d92b0c503 60 | name: rio-orphans 61 | version: 0.1.1.0 62 | sha256: f6a5ed84d8582968acfe25ea9eccea96361b3304f8463098793b05b873ee5681 63 | pantry-tree: 64 | size: 480 65 | sha256: 0ea2b455f8d51d1740b914e42b4c7b2f6d94af12ac7488944fe84887b4787916 66 | original: 67 | subdir: rio-orphans 68 | url: https://github.com/commercialhaskell/rio/archive/91c379f29b158dc91e7bea059fe7874d9a16973c.tar.gz 69 | - completed: 70 | size: 10278 71 | url: https://github.com/inflex-io/early/archive/a642cea8d33bd5475fe56c0d31ff51287692789d.tar.gz 72 | cabal-file: 73 | size: 1727 74 | sha256: 588c22caebfaf5f4d268bef30f131eb1ce8c602ee9eb5d92489a5d8243738efa 75 | name: early 76 | version: 0.0.0 77 | sha256: 475fbcf07e5c11df7c010cbf0099da1c8b6bf5a0e08ca6570dcb69c409f2b4d8 78 | pantry-tree: 79 | size: 642 80 | sha256: 82b3ffde31544c78bafa0ffedcd4285a320342fcd0b56a7d37d7660edc3030db 81 | original: 82 | url: https://github.com/inflex-io/early/archive/a642cea8d33bd5475fe56c0d31ff51287692789d.tar.gz 83 | - completed: 84 | size: 4288 85 | url: https://github.com/chrisdone/lexx/archive/1d57bf997666d35cf4304418b22d6c08ede41dcc.tar.gz 86 | cabal-file: 87 | size: 933 88 | sha256: 43afc7ae793eb724819ddcee3ebfe560d0e316da1c4f3f5a16e0afbbea05495b 89 | name: lexx 90 | version: 0.1.0.0 91 | sha256: 6daad6926a8ce7e6838c95372cfb22ee2080909d6a84c2ecb6fcd8e9d0aa570c 92 | pantry-tree: 93 | size: 451 94 | sha256: 59d87ed7eff3de2df1d1ad290ef32ede0b28d9aa01ae73aee6580a5500f0cfe1 95 | original: 96 | url: https://github.com/chrisdone/lexx/archive/1d57bf997666d35cf4304418b22d6c08ede41dcc.tar.gz 97 | - completed: 98 | hackage: byteunits-0.4.0.2@sha256:659e242f8051436582bfb748d857134b2fb7da80f33d31df6a22431cc77878db,1387 99 | pantry-tree: 100 | size: 322 101 | sha256: 98431cf111d5d0f22b93b2c6275d80261288d84189dcd72179c9d95c747eaa19 102 | original: 103 | hackage: byteunits-0.4.0.2@sha256:659e242f8051436582bfb748d857134b2fb7da80f33d31df6a22431cc77878db,1387 104 | - completed: 105 | hackage: monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 106 | pantry-tree: 107 | size: 713 108 | sha256: 8e049bd12ce2bd470909578f2ee8eb80b89d5ff88860afa30e29dd4eafecfa3e 109 | original: 110 | hackage: monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 111 | - completed: 112 | hackage: happy-1.19.9@sha256:f8c774230735a390c287b2980cfcd2703d24d8dde85a01ea721b7b4b4c82944f,4667 113 | pantry-tree: 114 | size: 7980 115 | sha256: 1f1d622f6e773e7a674da6364b755714c76c3fbb3c7a4e65deaf07242fc15211 116 | original: 117 | hackage: happy-1.19.9@sha256:f8c774230735a390c287b2980cfcd2703d24d8dde85a01ea721b7b4b4c82944f,4667 118 | - completed: 119 | hackage: megaparsec-8.0.0@sha256:362f85e243ecbcb550e1de6e5c74ba5a50c09edaa1208c99bc5b9fd242227fc6,3808 120 | pantry-tree: 121 | size: 1446 122 | sha256: 955117c00a86970f2d0c215f33cf5293b16589c04678a0a790c03368ab6fd0aa 123 | original: 124 | hackage: megaparsec-8.0.0@sha256:362f85e243ecbcb550e1de6e5c74ba5a50c09edaa1208c99bc5b9fd242227fc6,3808 125 | - completed: 126 | hackage: optics-0.2@sha256:813ef6cc4d2e2b5ee00435831031f38917ba01d1e56dcb62dc18cd0315a9ccb7,6296 127 | pantry-tree: 128 | size: 1003 129 | sha256: 8a74dbcd983fcc96b7b6c5c9fc6da7240dd2e5bdab7caa4927b8287a4cbe5c0f 130 | original: 131 | hackage: optics-0.2@sha256:813ef6cc4d2e2b5ee00435831031f38917ba01d1e56dcb62dc18cd0315a9ccb7,6296 132 | - completed: 133 | hackage: optics-core-0.2@sha256:6966f4f8cc9163b63d87dcca2d2617684b4ac8a80c5e50c69e9f3adf4dcdf0e9,4409 134 | pantry-tree: 135 | size: 4818 136 | sha256: 4797bbb8dad9a21ed5d10fd6436a9114df19ebf742a69e9c2a0cd4fceab41a93 137 | original: 138 | hackage: optics-core-0.2@sha256:6966f4f8cc9163b63d87dcca2d2617684b4ac8a80c5e50c69e9f3adf4dcdf0e9,4409 139 | - completed: 140 | hackage: optics-extra-0.2@sha256:211ce1dfd1b3ffd95c1158d8c8beb53cbd17c4d477169e226b1831607f6789eb,3370 141 | pantry-tree: 142 | size: 1809 143 | sha256: cce8df05ef2e673461efa35734e072c54b78c73a17ee4a1e59c94252a3d53788 144 | original: 145 | hackage: optics-extra-0.2@sha256:211ce1dfd1b3ffd95c1158d8c8beb53cbd17c4d477169e226b1831607f6789eb,3370 146 | - completed: 147 | hackage: optics-th-0.2@sha256:b4f6c5a3f134c697837190ed6da969dd284aefe79e43c3ef793093b607bb83b9,1929 148 | pantry-tree: 149 | size: 653 150 | sha256: f6b5caed956d3761b35769ac518d3f0f407449dafe33154992386f02d9489bad 151 | original: 152 | hackage: optics-th-0.2@sha256:b4f6c5a3f134c697837190ed6da969dd284aefe79e43c3ef793093b607bb83b9,1929 153 | - completed: 154 | hackage: indexed-profunctors-0.1@sha256:ddf618d0d4c58319c1e735e746bc69a1021f13b6f475dc9614b80af03432e6d4,1016 155 | pantry-tree: 156 | size: 235 157 | sha256: cfd66c0a53be1b45eae72df112ea1158614458bb7b1c9cbbe3410b04ab011ec6 158 | original: 159 | hackage: indexed-profunctors-0.1@sha256:ddf618d0d4c58319c1e735e746bc69a1021f13b6f475dc9614b80af03432e6d4,1016 160 | - completed: 161 | hackage: string-quote-0.0.1@sha256:7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3,758 162 | pantry-tree: 163 | size: 273 164 | sha256: d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f 165 | original: 166 | hackage: string-quote-0.0.1@sha256:7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3,758 167 | - completed: 168 | hackage: rainbow-0.34.2.2@sha256:522458692f361d86fa0dbc5085f96511138959dd664c8828c3672032ae558b67,2111 169 | pantry-tree: 170 | size: 630 171 | sha256: 1d73c5c6181919ea860b9d14421d48464266b5dbf4f7884f2e6b1b407632b6eb 172 | original: 173 | hackage: rainbow-0.34.2.2@sha256:522458692f361d86fa0dbc5085f96511138959dd664c8828c3672032ae558b67,2111 174 | snapshots: 175 | - completed: 176 | size: 524154 177 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/20.yaml 178 | sha256: 2f5099f69ddb6abfe64400fe1e6a604e8e628f55e6837211cd70a81eb0a8fa4d 179 | original: lts-14.20 180 | --------------------------------------------------------------------------------