spl.icl

   1 module spl
   2
   3 import StdFile
   4 import StdBool
   5 import StdMisc
   6 import StdFunc
   7 import StdTuple
   8 import StdList
   9 import StdString
  10 import Data.Either
  11 import Data.Maybe
  12 import Data.Func
  13 import System.CommandLine
  14 import GenPrint
  15 import Data.Map
  16 from Text import class Text(concat,join), instance Text String
  17
  18 import parse
  19 import lex
  20 import sem
  21 import AST
  22 import gen
  23 from yard import :: Error, instance toString Error
  24
  25 :: Opts = {
  26         version :: Bool,
  27         program :: String,
  28         lex :: Bool,
  29         parse :: Bool,
  30         sem :: Bool,
  31     gen :: Bool,
  32         fp :: Maybe String,
  33         help :: Bool}
  34
  35 derive gPrint TokenValue
  36
  37 preamble :: AST -> AST
  38 preamble (AST fd) = AST (pre ++ fd)
  39         where
  40                 pre = [
  41                         FunDecl zero "1printstr" ["x"] Nothing [] [
  42                                 IfStmt (FunExpr zero "isEmpty" [VarExpr zero (VarDef "x" [])] [])
  43                                         []
  44                                         [FunStmt "1printchar" [VarExpr zero (VarDef "x" [FieldHd])] []
  45                                         ,FunStmt "1printstr" [VarExpr zero (VarDef "x" [FieldTl])] []]]
  46                         ,
  47                         FunDecl zero "1printbool" ["x"] Nothing [] [
  48                                 IfStmt (VarExpr zero (VarDef "x" []))
  49                                         [FunStmt "1printstr" [strOp2 $ fromString "True"] []]
  50                                         [FunStmt "1printstr" [strOp2 $ fromString "False"] []]
  51                         ]]
  52
  53                 strOp2 :: [Char] -> Expr
  54                 strOp2 [] = EmptyListExpr zero
  55                 strOp2 [x:xs] = Op2Expr zero (CharExpr zero x) BiCons (strOp2 xs)
  56
  57 Start :: *World -> *World
  58 Start w
  59 # (args, w) = parseArgs w
  60 # (stdin, w) = stdio w
  61 | args.version
  62         # stdin = stdin
  63                 <<< "spl 0.1 (17 march 2016)\n"
  64                 <<< "Copyright Pim Jager and Mart Lubbers\n"
  65         = snd $ fclose stdin w
  66 | args.help
  67         # stdin = stdin
  68                 <<< "Usage: " <<< args.program <<< " [OPTION] [FILE]\n"
  69                 <<< "<spl> ::= <spl> <parser> <lexer>\n"
  70                 <<< "Lex parse and either FILE or stdin\n"
  71                 <<< "\n"
  72                 <<< "Options:\n"
  73                 <<< "  --help             Show this help\n"
  74                 <<< "  --version          Show the version\n"
  75                 <<< "  --[no-]lex         Lexer output(default: disabled)\n"
  76                 <<< "  --[no-]parse       Parser output(default: disabled)\n"
  77                 <<< "  --[no-]sem         Semantic analysis output(default: disabled)\n"
  78                 <<< "  --[no-]code        Code generation output(default: enabled)\n"
  79         = snd $ fclose stdin w
  80 # (contents, stdin, w) = readFileOrStdin stdin args.fp w
  81 = case contents of
  82         (Left cs) = snd $ fclose (stdin <<< cs) w
  83         (Right cs) = case lexer cs of
  84                 (Left e) = snd $ fclose (stdin <<< toString e <<< "\n") w
  85                 (Right lexOut)
  86                 # stdin = if (not args.lex) stdin (
  87                         stdin <<< "//LEXER\n" <<< printTokens lexOut <<< "//LEXER\n")
  88                 = case parser lexOut of
  89                         (Left e) = snd $ fclose (stdin <<< toString e <<< "\n") w
  90                         (Right parseOut)
  91                         # stdin = if (not args.parse) stdin (
  92                                 stdin <<<  "//PARSER\n" <<< toString parseOut <<< "//PARSER\n")
  93                         = case sem (preamble parseOut) of
  94                                 (Left e) = snd $ fclose (stdin <<< join "\n" (map toString e) <<< "\n") w
  95                                 (Right ast)
  96                                 # stdin = if (not args.sem) stdin (stdin
  97                                         <<< "//SEM G\n" <<< toString ast <<< "//SEMA\n")
  98                                 = case gen ast of
  99                                         (Left e) = snd $ fclose (stdin <<< e) w
 100                                         (Right asm)
 101                                         # stdin = if (not args.gen) stdin (stdin
 102                         <<< ";CODE GEN\n" <<< asm <<< "\n;CODE GEN\n")
 103                                         = snd $ fclose (stdin <<< "\n") w
 104                 where
 105                         printConstraints :: Constraints -> String
 106                         printConstraints [] = ""
 107                         printConstraints [(t1, t2):ts] = concat [
 108                                 "(", toString t1, ",", toString t2, ")"] +++ printConstraints ts
 109
 110                         printTokens :: [Token] -> String
 111                         printTokens ts = concat $ flatten $ map pt ts
 112                                 where
 113                                 pt ({line,col},token) = [toString line, ":",
 114                                                 toString col, ": ", printToString token, "\n"]
 115
 116 parseArgs :: *World -> (Opts, *World)
 117 parseArgs w
 118 # ([p:args], w) = getCommandLine w
 119 = (pa args {
 120         program=p,
 121         version=False,
 122         lex=False,
 123         parse=False,
 124         sem=False,
 125     gen=True,
 126         fp=Nothing,
 127         help=False}, w)
 128 where
 129         pa :: [String] Opts -> Opts
 130         pa [] o = o
 131         pa ["--help":r] o = pa r {o & help=True}
 132         pa ["--version":r] o = pa r {o & version=True}
 133         pa ["--lex":r] o = pa r {o & lex=True}
 134         pa ["--no-lex":r] o = pa r {o & lex=False}
 135         pa ["--parse":r] o = pa r {o & parse=True}
 136         pa ["--no-parse":r] o = pa r {o & parse=False}
 137         pa ["--sem":r] o = pa r {o & sem=True}
 138         pa ["--no-sem":r] o = pa r {o & sem=False}
 139     pa ["--code":r] o = pa r {o & gen=True}
 140     pa ["--no-code":r] o = pa r {o & gen=False}
 141         pa [x:r] o = pa r {o & fp=Just x}
 142
 143 readFileOrStdin :: *File (Maybe String) *World -> *(Either String [Char], *File, *World)
 144 readFileOrStdin stdin Nothing w
 145 # (cs, stdin) = readEntireFile stdin
 146 = (Right cs, stdin, w)
 147 readFileOrStdin stdin (Just fp) w
 148 # (b, fin, w) = fopen fp FReadText w
 149 | not b = (Left "Unable to open file", stdin, w)
 150 # (cs,  fin) = readEntireFile fin
 151 # (b, w) = fclose fin w
 152 | not b = (Left "Unable to close file", stdin, w)
 153 = (Right cs, stdin, w)
 154
 155 readEntireFile :: *File -> *([Char], *File)
 156 readEntireFile f
 157 # (b, c, f) = freadc f
 158 | not b = ([], f)
 159 # (cs, f) = readEntireFile f
 160 = ([c:cs], f)