"
195 | showsPrec d (VFold t) = showParen (d > appPrec) $
196 | showString "fold " . showsPrec (appPrec + 1) t
197 | showsPrec d (VNext t) = showParen (d > appPrec) $
198 | showString "next " . showsPrec (appPrec + 1) t
199 | showsPrec d (VBox t) = showParen (d > appPrec) $
200 | showString "box " . showsPrec (appPrec + 1) t
201 |
202 | -- * Parsing
203 |
204 | variable :: Parser Var
205 | variable = mkIdentifier
206 | ["intrec", "fst", "snd", "left", "right", "case", "of", "let", "fold", "unfold",
207 | "fix", "next", "prev", "box", "unbox", "in", "type"]
208 |
209 | term :: Parser Term
210 | term = choice [abs_, fix_, case_, letIn, makeExprParser base ops] "term"
211 | where
212 | abs_ = flip (foldr Abs) <$ lambda <*> some variable <* dot <*> term
213 | fix_ = Fix <$> (flip (foldr Abs) <$ "fix" <*> some variable <* dot <*> term)
214 | case_ = do
215 | "case"; t <- term; "of"
216 | braces do
217 | "left"; x1 <- variable; dot; t1 <- term
218 | semicolon
219 | "right"; x2 <- variable; dot; t2 <- term
220 | pure $ Case t (Abs x1 t1) (Abs x2 t2)
221 | letIn = Let <$ "let" <*> braces subst <* "in" <*> term
222 | base = Var <$> variable
223 | <|> Int <$> number
224 | <|> IntRec <$ "intrec"
225 | <|> parens (tuple <$> term `sepBy` comma)
226 | tuple [] = Unit
227 | tuple [t] = t
228 | tuple (t : ts) = Pair t (tuple ts)
229 | unaries = [("fst", Fst), ("snd", Snd), ("abort", Abort), ("left", InL), ("right", InR),
230 | ("fold", Fold), ("unfold", Unfold), ("next", Next), ("prev", Prev),
231 | ("box", Box), ("unbox", Unbox)]
232 | unary = choice [f <$ hidden (keyword w) | (w, f) <- unaries]
233 | ops = [ [ InfixL (pure (:$:))
234 | , Prefix (foldr1 (.) <$> some unary) ]
235 | , [ InfixL (Plus <$ symbol "+"), InfixL (Minus <$ symbol "-")
236 | , InfixL (Times <$ symbol "*"), InfixL (Divide <$ symbol "/") ]
237 | , [ InfixL ((:<*>:) <$ (symbol "<*>" <|> symbol "⊛"))
238 | , InfixL ((:<*>:) . Next <$ symbol "<$>") ] ]
239 |
240 | binding :: Parser (Var, Term)
241 | binding = try (mkBinding <$> variable <*> many variable <* equal) <*> term
242 | where
243 | mkBinding x ys t = (x, autoFix x (foldr Abs t ys))
244 | autoFix x t | x `freeIn` t = Fix (Abs x t)
245 | | otherwise = t
246 |
247 | subst :: Parser Subst
248 | subst = Map.fromList <$> binding `sepBy` semicolon
249 |
--------------------------------------------------------------------------------
/glam/Glam/Type.hs:
--------------------------------------------------------------------------------
1 | -- | The basic syntax and operations on types.
2 | module Glam.Type where
3 |
4 | import Control.Monad
5 | import Data.List
6 | import Data.String
7 | import Data.Set (Set)
8 | import Data.Set qualified as Set
9 | import Data.Map (Map)
10 | import Data.Map qualified as Map
11 | import Text.Megaparsec
12 | import Control.Monad.Combinators.Expr
13 |
14 | import Glam.Utils
15 |
16 | -- | Type variables
17 | type TVar = String
18 |
19 | -- | Type substitutions
20 | type TSubst = Map TVar Type
21 |
22 | -- | Whether a type, or term, is constant. Note that 'False' means "we don't know".
23 | type Constancy = Bool
24 |
25 | -- | A fixed point variable can only be used when it is /guarded/ by a @▸@ modality.
26 | data Guardedness = Unguarded -- ^ Can't use it yet
27 | | Guarded -- ^ OK, under @▸@
28 | | Forbidden -- ^ No way, we're under @■@
29 | deriving Eq
30 |
31 | infixr 7 :*:
32 | infixr 6 :+:
33 | infixr 5 :->:
34 |
35 | -- | Monomorphic types of the guarded λ-calculus
36 | data Type = TVar TVar -- ^ Variables
37 | | TInt -- ^ Integers
38 | | TApp Type Type -- ^ Applications
39 | | One | Type :*: Type -- ^ Products
40 | | Zero | Type :+: Type -- ^ Sums
41 | | Type :->: Type -- ^ Functions
42 | | Later Type -- ^ @▸@ modality
43 | | Constant Type -- ^ @■@ modality
44 | | TFix TVar Type -- ^ Fixed points
45 | deriving Eq
46 |
47 | -- | Polymorphic type schemes
48 | data Polytype = Forall [(TVar, Constancy)] Type
49 | deriving Eq
50 |
51 | pattern Monotype ty = Forall [] ty
52 |
53 | instance IsString Type where
54 | fromString = TVar
55 |
56 | -- * Variables and substitution
57 |
58 | class HasTVars t where
59 | freeTVars :: t -> Set TVar
60 | allTVars :: t -> Set TVar
61 |
62 | instance HasTVars Type where
63 | freeTVars (TVar x) = Set.singleton x
64 | freeTVars (t1 :*: t2) = freeTVars t1 <> freeTVars t2
65 | freeTVars (t1 :+: t2) = freeTVars t1 <> freeTVars t2
66 | freeTVars (t1 :->: t2) = freeTVars t1 <> freeTVars t2
67 | freeTVars (Later t) = freeTVars t
68 | freeTVars (Constant t) = freeTVars t
69 | freeTVars (TFix x t) = Set.delete x (freeTVars t)
70 | freeTVars _ = mempty
71 | allTVars (TVar x) = Set.singleton x
72 | allTVars (t1 :*: t2) = allTVars t1 <> allTVars t2
73 | allTVars (t1 :+: t2) = allTVars t1 <> allTVars t2
74 | allTVars (t1 :->: t2) = allTVars t1 <> allTVars t2
75 | allTVars (Later t) = allTVars t
76 | allTVars (Constant t) = allTVars t
77 | allTVars (TFix x t) = Set.insert x (allTVars t)
78 | allTVars _ = mempty
79 |
80 | instance HasTVars Polytype where
81 | freeTVars (Forall (map fst -> xs) ty) = freeTVars ty Set.\\ Set.fromList xs
82 | allTVars (Forall (map fst -> xs) ty) = allTVars ty <> Set.fromList xs
83 |
84 | x `freeInType` t = x `Set.member` freeTVars t
85 |
86 | freshTVarsFor :: Set TVar -> [TVar]
87 | freshTVarsFor xs = [x | n <- [1..]
88 | , x <- replicateM n ['a'..'z']
89 | , x `Set.notMember` xs]
90 |
91 | avoidCaptureType vs (x, ty)
92 | | x `Set.member` vs = (y, substituteType1 x (TVar y) ty)
93 | | otherwise = (x, ty)
94 | where y:_ = freshTVarsFor (vs <> Set.delete x (freeTVars ty))
95 |
96 | substituteType :: TSubst -> Type -> Type
97 | substituteType s (TVar x) = Map.findWithDefault (TVar x) x s
98 | substituteType s (t1 :*: t2) = substituteType s t1 :*: substituteType s t2
99 | substituteType s (t1 :+: t2) = substituteType s t1 :+: substituteType s t2
100 | substituteType s (t1 :->: t2) = substituteType s t1 :->: substituteType s t2
101 | substituteType s (Later t1) = Later (substituteType s t1)
102 | substituteType s (Constant t1) = Constant (substituteType s t1)
103 | substituteType s (TFix x tf) = TFix x' (substituteType (Map.delete x' s) tf')
104 | where (x', tf') = avoidCaptureType (foldMap freeTVars s) (x, tf)
105 | substituteType _ ty = ty
106 |
107 | substituteType1 x s = substituteType (Map.singleton x s)
108 |
109 | alphaNormalise :: Polytype -> Polytype
110 | alphaNormalise pty@(Forall as ty) = Forall [(b, c) | ((_, c), b) <- s] ty' where
111 | s = zip as (freshTVarsFor (freeTVars pty))
112 | ty' = substituteType (Map.fromList [(a, TVar b) | ((a, _), b) <- s]) ty
113 |
114 | -- * Printing
115 |
116 | prodPrec = 6
117 | sumPrec = 4
118 | funPrec = 0
119 | modPrec = 8
120 | appPrec = 10
121 |
122 | instance Show Type where
123 | showsPrec _ (TVar x) = showString x
124 | showsPrec _ TInt = showString "Int"
125 | showsPrec d (TApp t1 t2) = showParen (d > appPrec) $
126 | showsPrec appPrec t1 . showChar ' ' . showsPrec (appPrec + 1) t2
127 | showsPrec _ One = showString "1"
128 | showsPrec d (t1 :*: t2) = showParen (d > prodPrec) $
129 | showsPrec (prodPrec + 1) t1 . showString " * " . showsPrec prodPrec t2
130 | showsPrec _ Zero = showString "0"
131 | showsPrec d (t1 :+: t2) = showParen (d > sumPrec) $
132 | showsPrec (sumPrec + 1) t1 . showString " + " . showsPrec sumPrec t2
133 | showsPrec d (t1 :->: t2) = showParen (d > funPrec) $
134 | showsPrec (funPrec + 1) t1 . showString " -> " . showsPrec funPrec t2
135 | showsPrec d (Later ty) = showParen (d > modPrec) $
136 | showString ">" . showsPrec modPrec ty
137 | showsPrec d (Constant ty) = showParen (d > modPrec) $
138 | showString "#" . showsPrec modPrec ty
139 | showsPrec _ (TFix x tf) = showParen True $
140 | showString "Fix " . showString x . showString ". " . shows tf
141 |
142 | instance Show Polytype where
143 | showsPrec _ (Forall [] ty) = shows ty
144 | showsPrec _ (Forall xs ty) = showString "forall " . showString (intercalate " " [(if c then "#" else "") ++ x | (x, c) <- xs]) . showString ". " . shows ty
145 |
146 | -- * Parsing
147 |
148 | tVar :: Parser TVar
149 | tVar = mkIdentifier ["type", "Fix", "μ", "Int", "ℤ", "forall"]
150 |
151 | tConstant = symbol "#" <|> symbol "■"
152 |
153 | type_ :: Parser Type
154 | type_ = tfix <|> makeExprParser base ops "type"
155 | where
156 | tfix = TFix <$ ("Fix" <|> "μ") <*> tVar <* dot <*> type_
157 | base = TInt <$ ("Int" <|> "ℤ")
158 | <|> TVar <$> tVar
159 | <|> One <$ (symbol "1" <|> symbol "⊤")
160 | <|> Zero <$ (symbol "0" <|> symbol "⊥")
161 | <|> parens type_
162 | modality = Later <$ (symbol ">" <|> symbol "▸")
163 | <|> Constant <$ tConstant
164 | ops = [ [InfixL (pure TApp)]
165 | , [Prefix (foldr1 (.) <$> some modality)]
166 | , [binary ["*", "×"] (:*:)]
167 | , [binary ["+"] (:+:)]
168 | , [binary ["->", "→"] (:->:)] ]
169 | binary s f = InfixR (f <$ choice (map symbol s))
170 |
171 | quantifiedTVar :: Parser (TVar, Constancy)
172 | quantifiedTVar = flip (,) <$> option False (True <$ tConstant) <*> tVar
173 |
174 | polytype :: Parser Polytype
175 | polytype = Forall <$> option [] (("forall" <|> symbol "∀") *> some quantifiedTVar <* dot) <*> type_
176 |
--------------------------------------------------------------------------------
/glam/Glam/Utils.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE TypeOperators #-}
2 | {-# LANGUAGE TypeFamilies #-}
3 | {-# LANGUAGE FlexibleInstances #-}
4 | module Glam.Utils where
5 |
6 | import Control.Monad.Reader
7 | import Data.Bifunctor (first)
8 | import Data.Char
9 | import Data.String
10 | import Data.Void
11 | import Text.Megaparsec hiding (State, parse)
12 | import Text.Megaparsec.Char
13 | import Text.Megaparsec.Char.Lexer qualified as L
14 |
15 | -- * Parsing
16 |
17 | type IndentRef = Maybe SourcePos
18 |
19 | type Parser = ReaderT IndentRef (Parsec Void String)
20 |
21 | parse :: Parser a -> String -> String -> Either String a
22 | parse p f s = first (init . errorBundlePretty) $ runParser (runReaderT p Nothing) f s
23 |
24 | whitespace :: Parser ()
25 | whitespace = L.space space1 (L.skipLineComment "--") (L.skipBlockComment "{-" "-}")
26 |
27 | alpha :: Parser Char
28 | alpha = letterChar <|> char '_'
29 |
30 | isRest :: Char -> Bool
31 | isRest c = c == '\'' || c == '_' || isDigit c || isAlpha c
32 |
33 | lexeme :: Parser a -> Parser a
34 | lexeme p = do
35 | SourcePos { sourceLine = curLine, sourceColumn = curColumn } <- getSourcePos
36 | ref <- ask
37 | case ref of
38 | Just SourcePos { sourceLine = refLine, sourceColumn = refColumn }
39 | | curLine > refLine, curColumn <= refColumn ->
40 | L.incorrectIndent GT refColumn curColumn
41 | _ -> pure ()
42 | p <* whitespace
43 |
44 | symbol, keyword :: String -> Parser String
45 | symbol s = lexeme (string s)
46 | keyword s = label (show s) $ try $ lexeme $ string s <* notFollowedBy (satisfy isRest)
47 |
48 | instance {-# OVERLAPPING #-} a ~ String => IsString (Parser a) where
49 | fromString = keyword
50 |
51 | colon, semicolon, comma, equal, dot, lambda :: Parser String
52 | colon = symbol ":"
53 | semicolon = symbol ";"
54 | comma = symbol ","
55 | equal = symbol "="
56 | dot = symbol "."
57 | lambda = symbol "λ" <|> symbol "\\"
58 |
59 | parens, braces, lineFolded :: Parser a -> Parser a
60 | parens = between (symbol "(") (symbol ")")
61 | braces = between (symbol "{") (symbol "}")
62 | lineFolded p = do
63 | pos <- getSourcePos
64 | local (\_ -> Just pos) p
65 |
66 | word :: Parser String
67 | word = (:) <$> alpha <*> takeWhileP Nothing isRest "word"
68 |
69 | number :: Parser Integer
70 | number = lexeme L.decimal
71 |
72 | mkIdentifier :: [String] -> Parser String
73 | mkIdentifier reserved = label "identifier" $ try $ lexeme do
74 | w <- word
75 | if w `elem` reserved
76 | then fail $ "unexpected keyword " ++ w
77 | else pure w
78 |
79 | -- * Type checking
80 |
81 | infix 1 |-
82 | (|-) = local
83 |
84 | -- | Like 'lookup', but also returns the de Bruijn /level/ of the variable.
85 | lookupLevel :: Eq a => a -> [(a, b)] -> Maybe (b, Int)
86 | lookupLevel _ [] = Nothing
87 | lookupLevel x ((y, c):ys)
88 | | x == y = Just (c, length ys)
89 | | otherwise = lookupLevel x ys
90 |
--------------------------------------------------------------------------------
/glam/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2020 Naïm Favier
2 |
3 | Permission to use, copy, modify, and/or distribute this software for any purpose
4 | with or without fee is hereby granted, provided that the above copyright notice
5 | and this permission notice appear in all copies.
6 |
7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
8 | REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND
9 | FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
10 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
11 | OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
12 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF
13 | THIS SOFTWARE.
14 |
--------------------------------------------------------------------------------
/glam/Main.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE FlexibleInstances #-}
2 | {-# LANGUAGE MultiParamTypeClasses #-}
3 | {-# LANGUAGE UndecidableInstances #-}
4 | import Data.Char
5 | import Data.List
6 | import Control.Monad
7 | import Control.Monad.Loops
8 | import Control.Monad.State
9 | import System.Console.GetOpt
10 | import System.Console.Haskeline
11 | import System.Environment
12 | import System.Exit
13 | import System.IO
14 |
15 | import Glam.Run
16 |
17 | instance MonadState s m => MonadState s (InputT m) where
18 | get = lift get
19 | put = lift . put
20 |
21 | err = liftIO . hPutStrLn stderr
22 |
23 | usage = "usage: glam [options...] files..."
24 |
25 | options = [Option ['i'] ["interactive"] (NoArg ()) "run in interactive mode (default if no files are provided)"]
26 |
27 | parseArgs = do
28 | args <- getArgs
29 | (i, fs) <- case getOpt Permute options args of
30 | (o, fs, []) -> pure (not (null o), fs)
31 | (_, _, errs) -> die $ concat errs ++ usageInfo usage options
32 | let interactive = i || null fs
33 | pure (interactive, fs)
34 |
35 | comp = completeWord Nothing " \t" \p -> do
36 | defined <- getWords
37 | let words = defined ++ ["fst", "snd", "abort", "left", "right", "fold", "unfold", "box", "unbox", "next", "prev"]
38 | pure [simpleCompletion w | w <- words, p `isPrefixOf` w]
39 |
40 | settings = Settings { complete = comp
41 | , historyFile = Just ".glam_history"
42 | , autoAddHistory = True }
43 |
44 | prompt = "> "
45 |
46 | main = runGlamT do
47 | (interactive, fs) <- liftIO parseArgs
48 | liftIO $ hSetBuffering stdout NoBuffering
49 | forM_ fs \f -> do
50 | let (name, contents) | f == "-" = ("", getContents)
51 | | otherwise = (f, readFile f)
52 | contents <- liftIO contents
53 | liftIO . either die (mapM_ putStrLn) =<< runFile name contents
54 | when interactive do
55 | runInputT settings repl
56 |
57 | commands =
58 | [ "type" ==> \s -> do
59 | ty <- getType s
60 | liftIO case ty of
61 | Right ty -> putStrLn $ s ++ " : " ++ show ty
62 | Left e -> err e
63 | , "quit" ==> \_ -> liftIO exitSuccess
64 | ] where (==>) = (,)
65 |
66 | repl = handleInterrupt repl $ withInterrupt $
67 | whileJust_ (getInputLine prompt) \(dropWhile isSpace -> line) -> case line of
68 | ':':(break isSpace -> (cmd, dropWhile isSpace -> args)) ->
69 | case [c | c@(name, _) <- commands, cmd `isPrefixOf` name] of
70 | [(_, action)] -> action args
71 | [] -> err $ "unknown command :" ++ cmd
72 | cs -> err $ "ambiguous command :" ++ cmd ++ " could refer to: " ++ intercalate " " (map fst cs)
73 | _ -> liftIO . either err (mapM_ putStrLn) =<< runFile "" line
74 |
--------------------------------------------------------------------------------
/glam/MainJS.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE ViewPatterns #-}
2 | import GHCJS.Marshal
3 | import GHCJS.Foreign.Callback
4 |
5 | import Glam.Run
6 |
7 | foreign import javascript unsafe "glam = $1"
8 | setGlam :: Callback a -> IO ()
9 |
10 | main = do
11 | setGlam =<< syncCallback1' \v -> do
12 | Just input <- fromJSVal v
13 | toJSVal $ either id unlines
14 | $ runGlam
15 | $ runFile "" input
16 |
--------------------------------------------------------------------------------
/glam/glam.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 2.4
2 |
3 | name: glam
4 | version: 0.0
5 | synopsis: Polymorphic guarded λ-calculus
6 | description:
7 | An implementation of Clouston, Bizjak, Bugge and Birkedal's guarded λ-calculus with rank-1 polymorphism and automatic boxing.
8 | homepage: https://github.com/ncfavier/glam
9 | license: ISC
10 | license-file: LICENSE
11 | author: Naïm Favier
12 | maintainer: n@monade.li
13 | category: Compilers/Interpreters
14 |
15 | source-repository head
16 | type: git
17 | location: https://github.com/ncfavier/glam
18 |
19 | executable glam
20 | build-depends:
21 | base >= 4.12.0.0 && < 5,
22 | containers,
23 | transformers,
24 | mtl,
25 | megaparsec,
26 | parser-combinators,
27 | lens
28 | other-modules:
29 | Glam.Utils
30 | Glam.Term
31 | Glam.Type
32 | Glam.Rules.Term
33 | Glam.Rules.Type
34 | Glam.Run
35 | default-language: Haskell2010
36 | default-extensions:
37 | NamedFieldPuns
38 | BlockArguments
39 | LambdaCase
40 | MultiWayIf
41 | ViewPatterns
42 | PatternSynonyms
43 | ApplicativeDo
44 | OverloadedStrings
45 | PostfixOperators
46 | FlexibleContexts
47 | ConstraintKinds
48 | NoMonomorphismRestriction
49 | ImportQualifiedPost
50 | TupleSections
51 | ghc-options: -W
52 | ghcjs-options: -dedupe
53 |
54 | if impl(ghcjs)
55 | main-is: MainJS.hs
56 | cpp-options: -DGHCJS_BROWSER
57 | build-depends:
58 | ghcjs-base
59 | else
60 | main-is: Main.hs
61 | build-depends:
62 | haskeline,
63 | monad-loops
64 |
--------------------------------------------------------------------------------
/web/favicon.ico:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/ncfavier/glam/4dc41ca2c77e4cc0d0178cf5b455f19ca4e62e41/web/favicon.ico
--------------------------------------------------------------------------------
/web/glam_syntax.js:
--------------------------------------------------------------------------------
1 | // CodeMirror, copyright (c) by Marijn Haverbeke and others
2 | // Distributed under an MIT license: https://codemirror.net/LICENSE
3 |
4 | (function(mod) {
5 | if (typeof exports == "object" && typeof module == "object") // CommonJS
6 | mod(require("../../lib/codemirror"));
7 | else if (typeof define == "function" && define.amd) // AMD
8 | define(["../../lib/codemirror"], mod);
9 | else // Plain browser env
10 | mod(CodeMirror);
11 | })(function(CodeMirror) {
12 | "use strict";
13 |
14 | CodeMirror.defineMode("glam", function(_config, modeConfig) {
15 |
16 | function switchState(source, setState, f) {
17 | setState(f);
18 | return f(source, setState);
19 | }
20 |
21 | // These should all be Unicode extended, as per the Haskell 2010 report
22 | var smallRE = /[a-z_]/;
23 | var largeRE = /[A-Z]/;
24 | var digitRE = /\d/;
25 | var hexitRE = /[0-9A-Fa-f]/;
26 | var octitRE = /[0-7]/;
27 | var idRE = /[a-z_A-Z0-9'\xa1-\uffff]/;
28 | var symbolRE = /[-!#$%&*+.\/<=>?@\\^|~:]/;
29 | var specialRE = /[(),;[\]`{}]/;
30 | var whiteCharRE = /[ \t\v\f]/; // newlines are handled in tokenizer
31 |
32 | function normal(source, setState) {
33 | if (source.eatWhile(whiteCharRE)) {
34 | return null;
35 | }
36 |
37 | var ch = source.next();
38 | if (specialRE.test(ch)) {
39 | if (ch == '{' && source.eat('-')) {
40 | var t = "comment";
41 | return switchState(source, setState, ncomment(t, 1));
42 | }
43 | return null;
44 | }
45 |
46 | if (ch == '\'') {
47 | if (source.eat('\\')) {
48 | source.next(); // should handle other escapes here
49 | }
50 | else {
51 | source.next();
52 | }
53 | if (source.eat('\'')) {
54 | return "string";
55 | }
56 | return "string error";
57 | }
58 |
59 | if (ch == '"') {
60 | return switchState(source, setState, stringLiteral);
61 | }
62 |
63 | if (largeRE.test(ch)) {
64 | source.eatWhile(idRE);
65 | return "variable-2";
66 | }
67 |
68 | if (smallRE.test(ch)) {
69 | source.eatWhile(idRE);
70 | return "variable";
71 | }
72 |
73 | if (digitRE.test(ch)) {
74 | if (ch == '0') {
75 | if (source.eat(/[xX]/)) {
76 | source.eatWhile(hexitRE); // should require at least 1
77 | return "integer";
78 | }
79 | if (source.eat(/[oO]/)) {
80 | source.eatWhile(octitRE); // should require at least 1
81 | return "number";
82 | }
83 | }
84 | source.eatWhile(digitRE);
85 | var t = "number";
86 | if (source.match(/^\.\d+/)) {
87 | t = "number";
88 | }
89 | if (source.eat(/[eE]/)) {
90 | t = "number";
91 | source.eat(/[-+]/);
92 | source.eatWhile(digitRE); // should require at least 1
93 | }
94 | return t;
95 | }
96 |
97 | if (ch == "." && source.eat("."))
98 | return "keyword";
99 |
100 | if (symbolRE.test(ch)) {
101 | if (ch == '-' && source.eat(/-/)) {
102 | source.eatWhile(/-/);
103 | if (!source.eat(symbolRE)) {
104 | source.skipToEnd();
105 | return "comment";
106 | }
107 | }
108 | var t = "variable";
109 | if (ch == ':') {
110 | t = "variable-2";
111 | }
112 | source.eatWhile(symbolRE);
113 | return t;
114 | }
115 |
116 | return "error";
117 | }
118 |
119 | function ncomment(type, nest) {
120 | if (nest == 0) {
121 | return normal;
122 | }
123 | return function(source, setState) {
124 | var currNest = nest;
125 | while (!source.eol()) {
126 | var ch = source.next();
127 | if (ch == '{' && source.eat('-')) {
128 | ++currNest;
129 | }
130 | else if (ch == '-' && source.eat('}')) {
131 | --currNest;
132 | if (currNest == 0) {
133 | setState(normal);
134 | return type;
135 | }
136 | }
137 | }
138 | setState(ncomment(type, currNest));
139 | return type;
140 | };
141 | }
142 |
143 | function stringLiteral(source, setState) {
144 | while (!source.eol()) {
145 | var ch = source.next();
146 | if (ch == '"') {
147 | setState(normal);
148 | return "string";
149 | }
150 | if (ch == '\\') {
151 | if (source.eol() || source.eat(whiteCharRE)) {
152 | setState(stringGap);
153 | return "string";
154 | }
155 | if (source.eat('&')) {
156 | }
157 | else {
158 | source.next(); // should handle other escapes here
159 | }
160 | }
161 | }
162 | setState(normal);
163 | return "string error";
164 | }
165 |
166 | function stringGap(source, setState) {
167 | if (source.eat('\\')) {
168 | return switchState(source, setState, stringLiteral);
169 | }
170 | source.next();
171 | setState(normal);
172 | return "error";
173 | }
174 |
175 |
176 | var wellKnownWords = (function() {
177 | var wkw = {};
178 | function setType(t) {
179 | return function () {
180 | for (var i = 0; i < arguments.length; i++)
181 | wkw[arguments[i]] = t;
182 | };
183 | }
184 |
185 | setType("keyword")(
186 | "case", "of", "let", "in", "fix", "Fix", "type", "forall");
187 |
188 | setType("keyword")(
189 | "=", "\\", "λ", ".", ":", "μ", "∀", "->", "→", ">", "▸", "#", "■", "+", "*", "×");
190 |
191 | setType("builtin")(
192 | "intrec", "next", "prev", "box", "unbox", "fold", "unfold", "fst", "snd", "abort", "left", "right", "Int");
193 |
194 | setType("builtin")(
195 | "<*>", "⊛", "<$>", "+", "-", "⊤", "⊥", "ℤ");
196 |
197 | var override = modeConfig.overrideKeywords;
198 | if (override) for (var word in override) if (override.hasOwnProperty(word))
199 | wkw[word] = override[word];
200 |
201 | return wkw;
202 | })();
203 |
204 |
205 |
206 | return {
207 | startState: function () { return { f: normal }; },
208 | copyState: function (s) { return { f: s.f }; },
209 |
210 | token: function(stream, state) {
211 | var t = state.f(stream, function(s) { state.f = s; });
212 | var w = stream.current();
213 | return wellKnownWords.hasOwnProperty(w) ? wellKnownWords[w] : t;
214 | },
215 |
216 | blockCommentStart: "{-",
217 | blockCommentEnd: "-}",
218 | lineComment: "--"
219 | };
220 |
221 | });
222 |
223 | });
224 |
--------------------------------------------------------------------------------
/web/index.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 | glam — Polymorphic guarded λ-calculus
8 |
9 |
10 |
11 |
12 |
50 |
51 |
52 | @scripts@
53 |
54 |
55 | glam. Polymorphic guarded λ-calculus
56 |
57 | Based on Ranald Clouston, Aleš Bizjak, Hans Bugge Grathwohl and Lars Birkedal's paper.
58 |
59 |
60 | Also see my internship report and the source code (or generated documentation) for details. If you find a bug, please report it!
61 |
62 |
63 | Examples:
64 | @examples@
65 |
66 |
67 |
68 |
69 |
98 |
99 |
100 |
--------------------------------------------------------------------------------