~habibalamin/rumland

c78a6796447bb44feaf4cc446b7908ff046ff05e — حبيب الامين 6 months ago 528b608
Port Miranda codebase to Haskell
11 files changed, 201 insertions(+), 287 deletions(-)

M .gitignore
M Makefile
A Rumland.cabal
A Setup.hs
D main.m
D parsing/language.m
D parsing/primitives.m
D primitives.m
A src/app/Main.hs
A src/lib/Rumland/Parsing.hs
A src/lib/Rumland/Parsing/Primitives.hs
M .gitignore => .gitignore +1 -3
@@ 1,3 1,1 @@
*.x

.mirapack
dist-newstyle

M Makefile => Makefile +1 -1
@@ 2,4 2,4 @@
.SILENT: all

all:
	mirapack rumland
	cabal v2-build

A Rumland.cabal => Rumland.cabal +27 -0
@@ 0,0 1,27 @@
cabal-version:       3.0

name:                Rumland
version:             0.1.0.0
synopsis:            an ML-family programming language with easy Ruby interop
description:         Rumland is an ML-family programming language with fast compilation, do notation, and outputs binaries with fast startup times.
license:             MIT
license-file:        LICENSE
author:              حبيب الامين
maintainer:          ha.alamin@gmail.com
copyright:           © 2020 حبيب الامين
category:            Compiler
extra-source-files:  README.md

library librumland
  default-language:    Haskell2010
  hs-source-dirs:      src/lib
  exposed-modules:     Rumland.Parsing
  other-modules:       Rumland.Parsing.Primitives
  build-depends:       base ^>= 4.13.0.0

executable rumland
  default-language:    Haskell2010
  hs-source-dirs:      src/app
  main-is:             Main.hs
  build-depends:       base ^>= 4.13.0.0
                     , librumland

A Setup.hs => Setup.hs +2 -0
@@ 0,0 1,2 @@
import Distribution.Simple
main = defaultMain

D main.m => main.m +0 -19
@@ 1,19 0,0 @@
%include <primitives>
%include <parsing/primitives>
%include <parsing/language>

main = [ Stdout (show (runParser rumlandP $-) ++ "\n")
       ], if count $* == 1 || stdin; $0 is binary
     = [ Stdout (show (runParser rumlandP (read (last $*))) ++ "\n")
       ], if count $* == 2 || filename
     = [ print_error_with_usage "too many arguments"
       , Exit 1
       ], otherwise

print_error message =
  Stderr ((hd $*) ++ ": " ++ message ++ "\n")

print_error_with_usage message =
  print_error (message ++ "\n" ++ usage)

usage = "usage: " ++ (hd $*) ++ " [file]"

D parsing/language.m => parsing/language.m +0 -127
@@ 1,127 0,0 @@
%include <primitives>
%include <parsing/primitives>

rumlandValueExpression ::=
  RumlandInt num
  | RumlandFloat num
  | RumlandBool bool
  | RumlandList [rumlandValueExpression]
  | RumlandTerminator

rumlandTypeExpression ::=
  RumlandConcreteType
  | RumlandListType rumlandTypeExpression
  | RumlandFunctionType rumlandTypeExpression rumlandTypeExpression

rumlandAST ::=
  RumlandValueDefinition string rumlandValueExpression
  | RumlandTypeDefinition string rumlandTypeExpression

rumlandP :: parser rumlandAST
rumlandP =
  anyP
    [ valueDefinitionP
    || TODO: add `typeDefinitionP`
    || TODO: add `typeDeclarationP`
    ]

valueDefinitionP :: parser rumlandAST
valueDefinitionP =
  bindP valueIdentifierP valueDefinitionP_
    where
  valueDefinitionP_ identifier =
    mapP
      (RumlandValueDefinition identifier)
      (thenPA (thenPB equalsP valueLiteralP) endDefP)
  endDefP =
    anyP
      [ mapP (const RumlandTerminator) (charP '\n')
      , mapP (const RumlandTerminator) eofP
      ]
  valueLiteralP =
    anyP
      [ intP
      , floatP
      ]
  equalsP =
    thenPB (thenPB whitespaceOrVoidP (charP '=')) whitespaceOrVoidP
  whitespaceOrVoidP = manyP (charP ' ')

valueIdentifierP :: parser string
valueIdentifierP =
  bindP (satisfyP alpha) valueIdentifierP_
    where
  valueIdentifierP_ firstChar =
    mapP (firstChar :) (someP (satisfyP alphanumeric))
  alpha c = letter c \/ c == '_'
  alphanumeric c = alpha c \/ digit c

intP :: parser rumlandValueExpression
intP =
  mapP intStringToInt intP_
    where
  intStringToInt intString =
    RumlandInt (unmaybeInt (readNum ReadIntegral intString))
  unmaybeInt Nothing =
    error "unsafe internal `intP`/`unmaybeInt` called on `Nothing`"
  || Shouldn't ever be `Nothing`; parsed before `readNum`
  unmaybeInt (Just int) = int
  intP_ = someP digitP

floatP :: parser rumlandValueExpression
floatP =
  mapP floatStringPartsToFloat (choiceP integralP floatP_)
    where
  floatStringPartsToFloat floatParts =
    RumlandFloat
      (unmaybeFloatParts
        (readNum ReadIntegral ('0' : fst floatParts))
        (readNum ReadFractional (snd floatParts ++ "0")))
  unmaybeFloatParts Nothing fractional =
    error "unsafe internal `floatP`/`unmaybeFloatParts` called on `Nothing`"
  unmaybeFloatParts integral Nothing =
    error "unsafe internal `floatP`/`unmaybeFloatParts` called on `Nothing`"
  || Neither should ever be `Nothing`; parsed before `readNum`
  unmaybeFloatParts (Just integral) (Just fractional) =
    integral + fractional
  integralP =
    bindP
      (thenPA (someP digitP) dotP)
      (fractionalP manyP)
  floatP_ =
    bindP
      (thenPA (manyP digitP) dotP)
      (fractionalP someP)
  fractionalP quantityP integral =
    mapP (pair integral) (quantityP digitP)
  dotP = charP '.'

readNumComponent ::= ReadIntegral | ReadFractional

readNum :: readNumComponent -> string -> maybe num
readNum component s
  = Just (readNum_ s), if and (map digit s)
  = Nothing, otherwise
    where
    readNum_ =
      (cond (ReadIntegral == component) decimateeCount id)
      . (cond || mmm, lispy
          (ReadIntegral == component)
          (foldl (flip (accumulator (*))))
          (foldr (accumulator (div))))
        0
        where
      decimateeCount a = a div 10
      accumulator op digit_ memo = op (readDigit_ digit_ + memo) 10
      readDigit_ '0' = 0
      readDigit_ '1' = 1
      readDigit_ '2' = 2
      readDigit_ '3' = 3
      readDigit_ '4' = 4
      readDigit_ '5' = 5
      readDigit_ '6' = 6
      readDigit_ '7' = 7
      readDigit_ '8' = 8
      readDigit_ '9' = 9
      readDigit_ c =
        error "unsafe internal `readDigit_` called on non-digit"

D parsing/primitives.m => parsing/primitives.m +0 -111
@@ 1,111 0,0 @@
%include <primitives>

parser * ::= Parser (string -> [(*, string)])

runParser :: parser * -> string -> [(*, string)]
runParser (Parser p) = p

mapP :: (* -> **) -> parser * -> parser **
mapP f (Parser p) =
  Parser (mapP_ f p)
    where
  mapP_ f p = map (tmap f) . p

apP :: parser (* -> **) -> parser * -> parser **
apP (Parser pf) (Parser pa) =
  Parser pb
    where
  pb s = bindList (pf s) pg
  pg (parsedF, rest) = map (tmap parsedF) (pa rest)

bindP :: parser * -> (* -> parser **) -> parser **
bindP (Parser p) f =
  Parser p_
     where
   p_ s = bindList (p s) f_
   f_ (parsed, rest) = runParser (f parsed) rest

thenPA :: parser * -> parser ** -> parser *
thenPA (Parser p1) (Parser p2) =
  Parser p_
     where
   p_ s = bindList (p1 s) f_
   f_ (parsed, rest) = map (tmap (const parsed)) (p2 rest)

thenPB :: parser * -> parser ** -> parser **
thenPB p1 p2 =
  bindP p1 p2_
    where
  p2_ a = p2

choiceP :: parser * -> parser * -> parser *
choiceP (Parser p1) (Parser p2) =
  Parser p_
    where
  p_ s = p2 s, if p1 s == []
       = p1 s, otherwise

anyP :: [parser *] -> parser *
anyP =
  foldr choiceP empty
    where
  empty = Parser empty_
  empty_ s = []

someP :: parser * -> parser [*]
someP p =
  Parser p_
    where
  p_ s = bindList (runParser p s) f
  f (parsed, rest)
    = [([parsed], rest)] ++ map (prependParsed parsed) (recurse rest)
  recurse = runParser (someP p)
  prependParsed existingParsed (parsed, rest) =
    (existingParsed : parsed, rest)

manyP :: parser * -> parser [*]
manyP p =
  Parser p_
    where
  p_ s = [([], s)] ++ runParser (someP p) s

satisfyP :: (char -> bool) -> parser char
satisfyP f =
  Parser p_
    where
  p_ [] = []
  p_ (x:xs) = [(x, xs)], if f x
            = [], otherwise

eofP :: parser ()
eofP =
  Parser eofP_
    where
  eofP_ [] = [((), "")]
  eofP_ (c:rest) = []

charP :: char -> parser char
charP = satisfyP . (==)

stringP :: string -> parser string
stringP =
  foldr accumulator empty
    where
  empty = Parser empty_
  empty_ s = [("", s)]
  accumulator element = apP (mapP (:) (charP element))

digitP :: parser char
digitP =
  anyP
    [ charP '0'
    , charP '1'
    , charP '2'
    , charP '3'
    , charP '4'
    , charP '5'
    , charP '6'
    , charP '7'
    , charP '8'
    , charP '9'
    ]

D primitives.m => primitives.m +0 -26
@@ 1,26 0,0 @@
string == [char]

cond :: bool -> * -> * -> *
cond True a b = a
cond False a b = b

count :: [*] -> num
count [] = 0
count (x:xs) = 1 + count xs

maybe * ::= Just * | Nothing

pair :: * -> ** -> (*, **)
pair a b = (a, b)

tmap :: (* -> **) -> (*, ***) -> (**, ***)
tmap f (x, y) = (f x, y)

flip :: (* -> ** -> ***) -> ** -> * -> ***
flip f = g where g a b = f b a

bindList :: [*] -> (* -> [**]) -> [**]
bindList a f =
  foldr accumulator [] a
    where
  accumulator element memo = f element ++ memo

A src/app/Main.hs => src/app/Main.hs +27 -0
@@ 0,0 1,27 @@
module Main where

import System.Environment
import System.IO
import System.Exit

import Rumland.Parsing

main = do
  args <- getArgs

  case args of
    [] -> print . runParser rumlandP =<< hGetContents stdin
    [filename] ->
      print . runParser rumlandP =<< readFile filename
    _ -> do
      progName <- getExecutablePath
      printErrorWithUsage progName "too many arguments"
      exitWith $ ExitFailure 1

printError executable message =
  hPutStrLn stderr (executable ++ ": " ++ message ++ "\n")

printErrorWithUsage executable message =
  printError executable (message ++ "\n" ++ usage executable)

usage executable = "usage: " ++ executable ++ " [file]"

A src/lib/Rumland/Parsing.hs => src/lib/Rumland/Parsing.hs +135 -0
@@ 0,0 1,135 @@
{-# LANGUAGE TupleSections #-}

module Rumland.Parsing (runParser, rumlandP) where

-- TODO: parse `Text` instead of `String`

import Text.ParserCombinators.ReadP hiding (many)
import Control.Applicative
import Data.Char
import Data.Bool

import Rumland.Parsing.Primitives

type Parser = ReadP

runParser = readP_to_S

data RumlandValueExpression =
  RumlandInt Integer
  | RumlandFloat Float
  | RumlandBool Bool
  | RumlandList [RumlandValueExpression]
  | RumlandTerminator
  deriving Show

data RumlandTypeExpression =
  RumlandConcreteType
  | RumlandListType RumlandTypeExpression
  | RumlandFunctionType RumlandTypeExpression RumlandTypeExpression
  deriving Show

data RumlandAST =
  RumlandValueDefinition String RumlandValueExpression
  | RumlandTypeDefinition String RumlandTypeExpression
  deriving Show

rumlandP :: Parser RumlandAST
rumlandP =
  choice
    [ valueDefinitionP
    -- TODO: add `typeDefinitionP`
    -- TODO: add `typeDeclarationP`
    ]

valueDefinitionP :: Parser RumlandAST
valueDefinitionP =
  valueIdentifierP >>= valueDefinitionP_
    where
  valueDefinitionP_ identifier =
    fmap
      (RumlandValueDefinition identifier)
      (equalsP *> valueLiteralP <* endDefP)
  endDefP =
    choice
      [ const RumlandTerminator <$> char '\n'
      , const RumlandTerminator <$> eof
      ]
  valueLiteralP =
    choice
      [ intP
      , floatP
      ]
  equalsP = whitespaceOrVoidP *> char '=' <* whitespaceOrVoidP
  whitespaceOrVoidP = many (char ' ')

valueIdentifierP :: Parser String
valueIdentifierP =
  satisfy isAlpha >>= valueIdentifierP_
    where
  valueIdentifierP_ firstChar =
    (firstChar :) <$> some (satisfy alphanumeric)
  alphanumeric c = isAlphaNum c || c == '_'

intP :: Parser RumlandValueExpression
intP =
  intStringToInt <$> intP_
    where
  intStringToInt intString =
    RumlandInt (unmaybeInt (readNum ReadIntegral intString))
  unmaybeInt Nothing =
    error "unsafe internal `intP`/`unmaybeInt` called on `Nothing`"
  -- Shouldn't ever be `Nothing`; parsed before `readNum`
  unmaybeInt (Just int) = int
  intP_ = some digit

floatP :: Parser RumlandValueExpression
floatP =
  floatStringPartsToFloat <$> (integralP <|> floatP_)
    where
  floatStringPartsToFloat floatParts =
    RumlandFloat
      (unmaybeFloatParts
        (readNum ReadIntegral ('0' : fst floatParts))
        (readNum ReadFractional (snd floatParts ++ "0")))
  unmaybeFloatParts Nothing fractional =
    error "unsafe internal `floatP`/`unmaybeFloatParts` called on `Nothing`"
  unmaybeFloatParts integral Nothing =
    error "unsafe internal `floatP`/`unmaybeFloatParts` called on `Nothing`"
  -- Neither should ever be `Nothing`; parsed before `readNum`
  unmaybeFloatParts (Just integral) (Just fractional) =
    fromIntegral integral + fromIntegral fractional
  integralP = some digit <* dotP >>= fractionalP many
  floatP_ = many digit <*  dotP >>= fractionalP some
  fractionalP quantityP integral = (integral,) <$> quantityP digit
  dotP = char '.'

data ReadNumComponent = ReadIntegral | ReadFractional deriving Eq

readNum :: Integral a => ReadNumComponent -> String -> Maybe a
readNum component s
  | all isDigit s = Just (readNum_ s)
  | otherwise = Nothing
    where
  readNum_ =
    bool id decimateeCount (ReadIntegral == component)
    . bool -- mmm, lispy
        (foldr (accumulator div))
        (foldl (flip (accumulator (*))))
        (ReadIntegral == component)
      0
      where
    decimateeCount a = a `div` 10
    accumulator op digit_ memo = op (readDigit_ digit_ + memo) 10
    readDigit_ '0' = 0
    readDigit_ '1' = 1
    readDigit_ '2' = 2
    readDigit_ '3' = 3
    readDigit_ '4' = 4
    readDigit_ '5' = 5
    readDigit_ '6' = 6
    readDigit_ '7' = 7
    readDigit_ '8' = 8
    readDigit_ '9' = 9
    readDigit_ c =
      error "unsafe internal `readDigit_` called on non-digit"

A src/lib/Rumland/Parsing/Primitives.hs => src/lib/Rumland/Parsing/Primitives.hs +8 -0
@@ 0,0 1,8 @@
module Rumland.Parsing.Primitives where

import Text.ParserCombinators.ReadP

import Data.Char

digit :: ReadP Char
digit = satisfy isDigit