aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--example.txt74
-rw-r--r--snug-clean/.gitignore5
-rw-r--r--snug-clean/nitrile-lock.json20
-rw-r--r--snug-clean/nitrile.yml22
-rw-r--r--snug-clean/src/Snug/Parse.dcl7
-rw-r--r--snug-clean/src/Snug/Parse.icl243
-rw-r--r--snug-clean/src/Snug/Syntax.dcl39
-rw-r--r--snug-clean/src/Snug/Syntax.icl1
-rw-r--r--snug-clean/src/snug.icl31
9 files changed, 405 insertions, 37 deletions
diff --git a/example.txt b/example.txt
index b83c606..b36c823 100644
--- a/example.txt
+++ b/example.txt
@@ -1,60 +1,60 @@
-(data (Tuple a b)
- (Tuple a b))
-(data (List a)
+(data Tuple (a b) (
+ (Tuple a b)))
+(data List (a) (
Nil
- (Cons a (List a)))
+ (Cons a (List a))))
(type String (List Char))
-(fun readline : (List Char)
- (case getc
- '\n' -> Nil
- c -> c : readline))
-
-(fun length (xs : (List a)) : Int
+(fun length ((xs : List a)) : Int
(length_acc 0 xs))
-(fun length_acc (n : Int) (xs : (List a)) : Int
- (case xs
- Nil -> n
- Cons _ xs -> length_acc (+ n 1) xs))
+(fun length_acc ((n : Int) (xs : List a)) : Int
+ (case xs (
+ (Nil -> n)
+ (Cons _ xs -> length_acc (+ n 1) xs))))
+
+(data TypeIdent ((TI String)))
+(data TypeVarIdent ((TVI String)))
+(data ConstructorIdent ((CI String)))
+(data SymbolIdent ((SI String)))
-(data Type
- (Type String)
- (TypeVar String)
- (TypeApp Type Type))
+(data Type (
+ (Type TypeIdent)
+ (TypeVar TypeVarIdent)
+ (TypeApp Type Type)))
-(data ConstructorDef
- (ConstructorDef String (List Type)))
+(data ConstructorDef (
+ (ConstructorDef ConstructorIdent (List Type))))
-(data BasicValue
+(data BasicValue (
(BVInt Int)
- (BVChar Char))
+ (BVChar Char)))
-(data Pattern
- WildCard
+(data Pattern (
+ Wildcard
(BasicValuePattern BasicValue)
- (IdentPattern String)
- (ConstructorPattern String (List Pattern)))
+ (IdentPattern SymbolIdent)
+ (ConstructorPattern ConstructorIdent (List Pattern))))
-(data CaseAlternative
- (CaseAlternative Pattern Expression))
+(data CaseAlternative (
+ (CaseAlternative Pattern Expression)))
-(data Expression
- (Ident String)
+(data Expression (
+ (Ident SymbolIdent)
(Case Expression (List CaseAlternative))
- (ExpApp Expression Expression))
+ (ExpApp Expression Expression)))
-(data Definition
- (DataDef String (List String) (List ConstructorDef))
- (FunDef String (List (Tuple String Type)) Type Expression))
+(data Definition (
+ (DataDef TypeIdent (List TypeVarIdent) (List ConstructorDef))
+ (FunDef SymbolIdent (List (Tuple SymbolIdent Type)) Type Expression)))
-(fun list_ast : Definition
+(fun list_ast () : Definition
(DataDef
(Cons 'L' (Cons 'i' (Cons 's' (Cons 't' Nil))))
(Cons (Cons 'a' Nil) Nil)
(Cons (ConstructorDef (Cons 'N' (Cons 'i' (Cons 'l' Nil))) Nil)
(Cons (ConstructorDef (Cons 'C' (Cons 'o' (Cons 'n' (Cons 's' Nil)))) (Cons (TypeVar (Cons 'a' Nil)) (Cons (TypeApp (Type (Cons 'L' (Cons 'i' (Cons 's' (Cons 't' Nil))))) (TypeVar (Cons 'a' Nil))) Nil)))
Nil))))
-(fun length_acc_ast : Definition
+(fun length_acc_ast () : Definition
(FunDef
(Cons 'l' (Cons 'e' (Cons 'n' (Cons 'g' (Cons 't' (Cons 'h' (Cons '_' (Cons 'a' (Cons 'c' (Cons 'c' Nil))))))))))
(Cons (Tuple (Cons 'n' Nil) (Type (Cons 'I' (Cons 'n' (Cons 't' Nil)))))
@@ -62,5 +62,5 @@
Nil))
(Case (Ident (Cons 'x' (Cons 's' Nil)))
(Cons (CaseAlternative (ConstructorPattern (Cons 'N' (Cons 'i' (Cons 'l' Nil))) Nil) (Ident (Cons 'n' Nil)))
- (Cons (CaseAlternative (ConstructorPattern (Cons 'C' (Cons 'o' (Cons 'n' (Cons 's' Nil)))) (Cons WildCard (Cons (IdentPattern (Cons 'x' (Cons 's' Nil))) Nil))) ())
+ (Cons (CaseAlternative (ConstructorPattern (Cons 'C' (Cons 'o' (Cons 'n' (Cons 's' Nil)))) (Cons Wildcard (Cons (IdentPattern (Cons 'x' (Cons 's' Nil))) Nil))))
Nil)))))
diff --git a/snug-clean/.gitignore b/snug-clean/.gitignore
new file mode 100644
index 0000000..fbde75a
--- /dev/null
+++ b/snug-clean/.gitignore
@@ -0,0 +1,5 @@
+*.abc
+*.o
+nitrile-packages/
+
+snug
diff --git a/snug-clean/nitrile-lock.json b/snug-clean/nitrile-lock.json
new file mode 100644
index 0000000..e1524c4
--- /dev/null
+++ b/snug-clean/nitrile-lock.json
@@ -0,0 +1,20 @@
+{"packages":{"linux-x64":[{"name":"argenv"
+ ,"version":"1.0.1"}
+ ,{"name":"base"
+ ,"version":"1.0.1"}
+ ,{"name":"base-clm"
+ ,"version":"1.4.2"}
+ ,{"name":"base-code-generator"
+ ,"version":"2.2.0"}
+ ,{"name":"base-compiler"
+ ,"version":"2.0.1"}
+ ,{"name":"base-rts"
+ ,"version":"2.1.1"}
+ ,{"name":"base-stdenv"
+ ,"version":"2.1.0"}
+ ,{"name":"clean-platform"
+ ,"version":"0.3.21"}
+ ,{"name":"lib-compiler"
+ ,"version":"3.0.2"}
+ ,{"name":"tcpip"
+ ,"version":"2.1.1"}]}}
diff --git a/snug-clean/nitrile.yml b/snug-clean/nitrile.yml
new file mode 100644
index 0000000..6f05a65
--- /dev/null
+++ b/snug-clean/nitrile.yml
@@ -0,0 +1,22 @@
+format_version: 0.4.5
+name: snug-clean
+type: Application
+version: 0.1.0
+maintainer: Camil Staps
+contact_email: clean@camilstaps.nl
+
+dependencies:
+ base: ^1.0
+ clean-platform: ^0.3
+
+src:
+ - src
+
+build:
+ compile:
+ script:
+ - clm:
+ main: snug
+ target: snug
+ #print_result: false
+ print_time: false
diff --git a/snug-clean/src/Snug/Parse.dcl b/snug-clean/src/Snug/Parse.dcl
new file mode 100644
index 0000000..edea809
--- /dev/null
+++ b/snug-clean/src/Snug/Parse.dcl
@@ -0,0 +1,7 @@
+definition module Snug.Parse
+
+from Data.Error import :: MaybeError
+
+from Snug.Syntax import :: Definition
+
+parseSnug :: ![Char] -> MaybeError String [Definition]
diff --git a/snug-clean/src/Snug/Parse.icl b/snug-clean/src/Snug/Parse.icl
new file mode 100644
index 0000000..63a9fda
--- /dev/null
+++ b/snug-clean/src/Snug/Parse.icl
@@ -0,0 +1,243 @@
+implementation module Snug.Parse
+
+import StdEnv
+
+import Control.Applicative
+import Control.Monad
+import Data.Either
+import Data.Error
+import Data.Functor
+import Data.Maybe
+import Data.Tuple
+import qualified Text
+from Text import class Text, instance Text String
+import Text.Parsers.Simple.Core
+
+import Snug.Syntax
+
+parseSnug :: ![Char] -> MaybeError String [Definition]
+parseSnug cs = case parse (many definition`) (lex cs) of
+ Left errors -> Error ('Text'.join "; " errors)
+ Right defs -> Ok defs
+
+definition` :: Parser Token Definition
+definition` = parenthesized def
+where
+ def
+ = liftM3 DataDef
+ (pToken (TIdent "data") *> typeIdent)
+ (fromMaybe [] <$> optional (simpleList typeVarIdent))
+ (list simpleConstructorDef constructorDef)
+ <|> liftM2 TypeDef
+ (pToken (TIdent "type") *> typeIdent)
+ simpleOrParenthesizedType
+ <|> liftM4 FunDef
+ (pToken (TIdent "fun") *> symbolIdent)
+ (simpleList (parenthesized typedArgument))
+ (pToken TColon *> type)
+ simpleOrParenthesizedExpression
+
+ simpleConstructorDef = liftM2 ConstructorDef constructorIdent (pure [])
+ constructorDef = liftM2 ConstructorDef constructorIdent (many simpleOrParenthesizedType)
+
+ typedArgument = liftM2 tuple symbolIdent (pToken TColon *> type)
+
+complexType :: Parser Token Type
+complexType = liftM2 (foldl TyApp) simpleType (some simpleOrParenthesizedType)
+
+simpleType :: Parser Token Type
+simpleType
+ = Type <$> typeIdent
+ <|> TyVar <$> typeVarIdent
+
+type :: Parser Token Type
+type = complexType <|> simpleType
+
+simpleOrParenthesizedType :: Parser Token Type
+simpleOrParenthesizedType = simpleType <|> parenthesized complexType
+
+complexExpression :: Parser Token Expression
+complexExpression
+ = liftM2 Case
+ (pToken (TIdent "case") *> simpleOrParenthesizedExpression)
+ (nonEmpty (simpleList (parenthesized caseAlternative)))
+ <|> liftM2 (foldl ExpApp)
+ simpleExpression
+ (some simpleOrParenthesizedExpression)
+where
+ caseAlternative = liftM2 CaseAlternative pattern (pToken TArrow *> expression)
+
+ complexPattern
+ = liftM2 ConstructorPattern constructorIdent (many simpleOrParenthesizedPattern)
+ simplePattern
+ = pToken TUnderscore $> Wildcard
+ <|> BasicValuePattern <$> basicValue
+ <|> IdentPattern <$> symbolIdent
+ <|> liftM2 ConstructorPattern constructorIdent (pure [])
+ simpleOrParenthesizedPattern = simplePattern <|> parenthesized complexPattern
+ pattern = complexPattern <|> simplePattern
+
+simpleExpression :: Parser Token Expression
+simpleExpression
+ = BasicValue <$> basicValue
+ <|> Symbol <$> symbolIdent
+ <|> Constructor <$> constructorIdent
+
+simpleOrParenthesizedExpression :: Parser Token Expression
+simpleOrParenthesizedExpression = simpleExpression <|> parenthesized expression
+
+expression :: Parser Token Expression
+expression = complexExpression <|> simpleExpression
+
+basicValue :: Parser Token BasicValue
+basicValue
+ = (\(TInt i) -> BVInt i) <$> pSatisfy (\t -> t=:(TInt _))
+ <|> (\(TChar c) -> BVChar c) <$> pSatisfy (\t -> t=:(TChar _))
+
+typeIdent :: Parser Token TypeIdent
+typeIdent = fromIdent <$> pSatisfy isUpperCaseIdent
+
+constructorIdent :: Parser Token ConstructorIdent
+constructorIdent = fromIdent <$> pSatisfy isUpperCaseIdent
+
+typeVarIdent :: Parser Token TypeVarIdent
+typeVarIdent = fromIdent <$> pSatisfy isLowerCaseIdent
+
+symbolIdent :: Parser Token SymbolIdent
+symbolIdent
+ = fromIdent <$> pSatisfy isLowerCaseIdent
+ <|> fromIdent <$> pSatisfy isFunnyIdent
+
+fromIdent (TIdent id) :== id
+
+isUpperCaseIdent :: !Token -> Bool
+isUpperCaseIdent (TIdent s) = size s > 0 && isUpper s.[0]
+isUpperCaseIdent _ = False
+
+isLowerCaseIdent :: !Token -> Bool
+isLowerCaseIdent (TIdent s) = size s > 0 && isLower s.[0]
+isLowerCaseIdent _ = False
+
+isFunnyIdent :: !Token -> Bool
+isFunnyIdent (TIdent s) = size s > 0 && isFunnySymbol s.[0]
+isFunnyIdent _ = False
+
+parenthesized :: !(Parser Token a) -> Parser Token a
+parenthesized p = pToken TParenOpen *> p <* pToken TParenClose
+
+list :: !(Parser Token a) !(Parser Token a) -> Parser Token [a]
+list simpleElem elem = simpleList (simpleElem <|> parenthesized elem)
+
+simpleList :: !(Parser Token a) -> Parser Token [a]
+simpleList simpleElem = parenthesized (many simpleElem)
+
+nonEmpty :: !(Parser Token [a]) -> Parser Token [a]
+nonEmpty p = p >>= \xs -> if (isEmpty xs) pFail (pure xs)
+
+:: Token
+ = TParenOpen //* (
+ | TParenClose //* )
+
+ | TColon //* :
+ | TUnderscore //* _
+ | TArrow //* ->
+
+ | TIdent !String
+ | TInt !Int
+ | TChar !Char
+
+ | TError !Int !Int !String
+
+instance == Token
+where
+ (==) TParenOpen y = y=:TParenOpen
+ (==) TParenClose y = y=:TParenClose
+ (==) TColon y = y=:TColon
+ (==) TUnderscore y = y=:TUnderscore
+ (==) TArrow y = y=:TArrow
+ (==) (TIdent x) (TIdent y) = x == y
+ (==) (TIdent _) _ = False
+ (==) (TInt x) (TInt y) = x == y
+ (==) (TInt _) _ = False
+ (==) (TChar x) (TChar y) = x == y
+ (==) (TChar _) _ = False
+ (==) (TError _ _ _) _ = False
+
+lex :: ![Char] -> [Token]
+lex cs = lex` 0 0 cs
+
+lex` :: !Int !Int ![Char] -> [Token]
+lex` _ _ []
+ = []
+/* This alternative is for characters that can never be part of identifiers: */
+lex` line col [c:cs]
+ | isJust mbToken
+ = [fromJust mbToken : lex` line (col+1) cs]
+where
+ mbToken = case c of
+ '(' -> ?Just TParenOpen
+ ')' -> ?Just TParenClose
+ _ -> ?None
+/* This alternative is for characters that can be part of identifiers consisting of symbols: */
+lex` line col [c:cs]
+ | isJust mbToken && (isEmpty cs || not (isFunnySymbol (hd cs)))
+ = [fromJust mbToken : lex` line (col+1) cs]
+where
+ mbToken = case c of
+ ':' -> ?Just TColon
+ _ -> ?None
+/* This alternative is for characters that can be part of regular identifiers: */
+lex` line col [c:cs]
+ | isJust mbToken && (isEmpty cs || not (isIdentChar (hd cs)))
+ = [fromJust mbToken : lex` line (col+1) cs]
+where
+ mbToken = case c of
+ '_' -> ?Just TUnderscore
+ _ -> ?None
+lex` line col ['-','>':cs]
+ | isEmpty cs || not (isFunnySymbol (hd cs))
+ = [TArrow : lex` line (col+2) cs]
+
+/* Whitespace */
+lex` line col ['\r','\n':cs]
+ = lex` (line+1) 0 cs
+lex` line col ['\n','\r':cs]
+ = lex` (line+1) 0 cs
+lex` line col ['\n':cs]
+ = lex` (line+1) 0 cs
+lex` line col ['\r':cs]
+ = lex` (line+1) 0 cs
+lex` line col [c:cs]
+ | isSpace c
+ = lex` line (col+1) cs
+
+/* Identifiers*/
+lex` line col cs=:[c:_]
+ | isAlpha c
+ # (name,cs) = span isIdentChar cs
+ = [TIdent (toString name) : lex` line (col + length name) cs]
+ | isFunnySymbol c
+ # (name,cs) = span isFunnySymbol cs
+ = [TIdent (toString name) : lex` line (col + length name) cs]
+
+/* Basic values */
+lex` line col cs=:[c:_]
+ | isDigit c
+ # (i,cs) = span isDigit cs
+ = [TInt (toInt (toString i)) : lex` line (col + length i) cs]
+lex` line col [c:cs]
+ | c == '-' && not (isEmpty cs) && isDigit (hd cs)
+ # (i,cs) = span isDigit cs
+ = [TInt (0 - toInt (toString i)) : lex` line (col + 1 + length i) cs]
+lex` line col ['\'',c,'\'':cs] // TODO: escape sequences
+ = [TChar c : lex` line (col+3) cs]
+
+/* Unparseable input */
+lex` line col cs
+ = [TError line col ("failed to lex '" +++ toString (takeWhile (not o isControl) (take 10 cs)) +++ "...'")]
+
+isFunnySymbol :: !Char -> Bool
+isFunnySymbol c = isMember c ['!#$%&*+-/:;<=>?@\\^|~']
+
+isIdentChar :: !Char -> Bool
+isIdentChar c = isAlphanum c || c == '_' || c == '\''
diff --git a/snug-clean/src/Snug/Syntax.dcl b/snug-clean/src/Snug/Syntax.dcl
new file mode 100644
index 0000000..d030df6
--- /dev/null
+++ b/snug-clean/src/Snug/Syntax.dcl
@@ -0,0 +1,39 @@
+definition module Snug.Syntax
+
+:: TypeIdent :== String
+:: TypeVarIdent :== String
+:: ConstructorIdent :== String
+:: SymbolIdent :== String
+
+:: Type
+ = Type !TypeIdent
+ | TyVar !TypeVarIdent
+ | TyApp !Type !Type
+
+:: ConstructorDef
+ = ConstructorDef !ConstructorIdent ![Type]
+
+:: BasicValue
+ = BVInt !Int
+ | BVChar !Char
+
+:: Pattern
+ = Wildcard
+ | BasicValuePattern !BasicValue
+ | IdentPattern !SymbolIdent
+ | ConstructorPattern !ConstructorIdent ![Pattern]
+
+:: CaseAlternative
+ = CaseAlternative !Pattern !Expression
+
+:: Expression
+ = BasicValue !BasicValue
+ | Symbol !SymbolIdent
+ | Constructor !ConstructorIdent
+ | Case !Expression ![CaseAlternative]
+ | ExpApp !Expression !Expression
+
+:: Definition
+ = DataDef !TypeIdent ![TypeVarIdent] ![ConstructorDef]
+ | TypeDef !TypeIdent !Type
+ | FunDef !SymbolIdent ![(SymbolIdent, Type)] !Type !Expression
diff --git a/snug-clean/src/Snug/Syntax.icl b/snug-clean/src/Snug/Syntax.icl
new file mode 100644
index 0000000..f886750
--- /dev/null
+++ b/snug-clean/src/Snug/Syntax.icl
@@ -0,0 +1 @@
+implementation module Snug.Syntax
diff --git a/snug-clean/src/snug.icl b/snug-clean/src/snug.icl
new file mode 100644
index 0000000..1cdfcf6
--- /dev/null
+++ b/snug-clean/src/snug.icl
@@ -0,0 +1,31 @@
+module snug
+
+import StdEnv
+import StdMaybe
+
+import System.CommandLine
+
+import Snug.Parse
+
+Start w
+ # ([prog:args],w) = getCommandLine w
+ | length args <> 1 = abort ("Usage: " +++ prog +++ " INPUT\n")
+ # input = hd args
+ # (mbInput,w) = readFile input w
+ input = fromJust mbInput
+ | isNone mbInput = abort "Failed to read input\n"
+ | otherwise = parseSnug input
+
+readFile :: !String !*World -> (!?[Char], !*World)
+readFile path w
+ # (ok,f,w) = fopen path FReadData w
+ | not ok = (?None, w)
+ # (contents,f) = read [] f
+ # (_,w) = fclose f w
+ = (?Just contents, w)
+where
+ read :: ![Char] !*File -> (![Char], !*File)
+ read acc f
+ # (ok,c,f) = freadc f
+ | not ok = (reverse acc, f)
+ | otherwise = read [c:acc] f
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-12 20:39:27 +0000