saplcg.icl 4.42 KB
Newer Older
1
2
3
4
5
module saplcg

import StdFile
import StdList

6
from Data.Func import $, mapSt, seqSt
7
from Data.Map import fromList, newMap
8
import System.CommandLine
9
import System.Environment
10
11
12
13
14
15
16
17
import System.FilePath
import System.Options
import Text

import Sapl.Target.CleanFlavour
import Sapl.Target.JS.CodeGeneratorJS

:: Options =
18
19
20
21
	{ home       :: !Maybe FilePath
	, paths      :: ![FilePath]
	, libraries  :: ![String]
	, modules    :: ![String]
22
23
24
25
26
	, trampoline :: !Bool
	}

defaultOptions :: Options
defaultOptions =
27
28
29
30
	{ home       = Nothing
	, paths      = ["."]
	, libraries  = ["StdEnv"]
	, modules    = []
31
32
33
	, trampoline = False
	}

34
35
36
37
38
39
40
41
42
43
44
45
defaultParserState :: ParserState
defaultParserState =
	{ ps_level        = 0
	, ps_constructors = fromList
		[ ("_predefined._Nil",  {index=0,nr_cons=2,nr_args=0,args=[]})
		, ("_predefined._Cons", {index=1,nr_cons=2,nr_args=2,args=[TypedVar (NormalVar "x" 0) NoType, TypedVar (NormalVar "xs" 0) NoType]})
		]
	, ps_functions    = newMap
	, ps_CAFs         = newMap
	, ps_genFuns      = []
	}

46
Start w
47
# ([prog:args],w) = getCommandLine w
48
# noUsage = Nothing
49
# usage = Just ("Usage: " +++ prog +++ " [OPTIONS] MOD [MOD..]")
50

51
52
53
# opts = defaultOptions
# (home,w) = getEnvironmentVariable "CLEAN_HOME" w
# opts = parseOptions optionDescription args {opts & home=home}
54
55
56
| isError opts = error noUsage (join "\n" $ fromError opts) w
# opts = fromOk opts

57
| isEmpty opts.modules = error usage "No modules given" w
58

59
# (files,(pst,w)) = mapSt (parseModule opts) opts.modules (defaultParserState,w)
60
61
| any isNothing files = error Nothing "Parsing failed" w

62
# (out,w) = stdio w
63
# (out,_,w) = genCode opts (join "\n" [f \\ Just f <- files]) (out,pst,w)
Camil Staps's avatar
Camil Staps committed
64
65
# (_,w) = fclose out w

66
67
68
69
= w
where
	optionDescription :: Option Options
	optionDescription = WithHelp True $ Options
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
		[ Shorthand "-H" "--clean-home" $ Option
			"--clean-home"
			(\h opts -> Ok {opts & home=Just h})
			"DIR"
			"Clean installation directory (default: $CLEAN_HOME)"
		, Shorthand "-IL" "--include-lib" $ Option
			"--include-lib"
			(\l opts -> Ok {opts & libraries=opts.libraries ++ [l]})
			"LIB"
			"Library to include when searching for modules"
		, Shorthand "-I" "--include" $ Option
			"--include"
			(\d opts -> Ok {opts & paths=opts.paths ++ [d]})
			"DIR"
			"Directory to include when searching for modules"
		, Shorthand "-t" "--trampoline" $ Flag
86
87
88
89
			"--trampoline"
			(\opts -> Ok {opts & trampoline=True})
			"Turn on trampoline code"
		, Operand False
90
91
92
			(\m opts -> Just $ Ok {opts & modules=opts.modules ++ [m]})
			"MODULE"
			"Modules to generate code for"
93
94
95
96
97
98
99
100
101
102
103
104
105
		]

error :: !(Maybe String) !String !*World -> *World
error usage s w
# io = stderr
# io = io <<< s <<< "\n"
# io = case usage of
	Nothing -> io
	Just u  -> io <<< u <<< "\n"
# (_,w) = fclose io w
# w = setReturnCode 1 w
= w

106
107
108
109
110
parseModule :: !Options !String !*(!ParserState,!*World) -> *(!Maybe String, !*(!ParserState,!*World))
parseModule opts mod (pst,w)
#! (fp,w) = findModule opts.paths opts.libraries w
| isNothing fp = (Nothing, (pst, error Nothing ("Could not find " +++ mod) w))
#! fp = fromJust fp
111
#! (f,w) = readFile fp w
112
113
114
| isError f = (Nothing, (pst, error Nothing (fromError f <+ " " +++ fp) w))
#! f = fromOk f
#! parseRes = parse (tokensWithPositions f)
115
| isError parseRes = (Nothing, (pst, error Nothing (mod +++ ": " <+ fromError parseRes) w))
116
117
#! (_,pst`) = fromOk parseRes
= (Just f, (mergeParserStates pst` (Just pst),w))
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
where
	modparts = split "." mod
	modPath = foldl (</>) "" (init modparts)
	modBasename = last modparts

	findModule :: ![FilePath] ![String] !*World -> *(!Maybe FilePath, !*World)
	findModule [] [lib:libs] w | isJust opts.home
	# (e,w) = fileExists filename w
	= if e (Just filename, w) (findModule [] libs w)
	where
		filename = (fromJust opts.home </> "lib" </> lib </> modPath </> "Clean System Files" </> modBasename +++ ".sapl")
	findModule [path:paths] libs w
	# (e,w) = fileExists filename w
	= if e (Just filename, w) (findModule paths libs w)
	where
		filename = (path </> modPath </> "Clean System Files" </> modBasename +++ ".sapl")
	findModule _ _ w = (Nothing, w)
135
136
137
138

genCode :: !Options !String !*(!*File,!ParserState,!*World) -> *(!*File,!ParserState,!*World)
genCode opts sapl (out,pst,w)
#! genResult = generateJS cleanFlavour opts.trampoline sapl (Just pst)
139
140
141
142
143
| isError genResult = (out, pst, error Nothing (fromError genResult) w)
#! (res,pst) = fromOk genResult
#! (mbError,out) = intoFile res out
#! out = out <<< "\n"
#! w = if (isError mbError) (error Nothing "Error while writing output\n" w) w
144
= (out,pst,w)