├── .gitignore
├── README.md
├── cabal.project
├── examples
    ├── ackermann.spk
    ├── better_euler_sieve.spk
    ├── cartesian.spk
    ├── church.spk
    ├── collatz.spk
    ├── comparedna.spk
    ├── enumChar.spk
    ├── euler_sieve.spk
    ├── evenodd.spk
    ├── fac.spk
    ├── fib.spk
    ├── fix.spk
    ├── fix2.spk
    ├── fizzbuzz.spk
    ├── floats.spk
    ├── generalized_fizzbuzz.spk
    ├── hanoi.spk
    ├── helloworld.spk
    ├── hintrestrict.spk
    ├── interactive
    │   ├── iobind.spk
    │   └── zeroper.spk
    ├── iota.spk
    ├── lcg.spk
    ├── listmonad.spk
    ├── lsystem.spk
    ├── matrix.spk
    ├── mergesort.spk
    ├── multimod.spk
    ├── multipat.spk
    ├── n_queens.spk
    ├── newmod.spk
    ├── ninetyninebottles.spk
    ├── overloaded_fac.spk
    ├── printbool.spk
    ├── putchr.spk
    ├── quine.spk
    ├── show.spk
    ├── statet.spk
    ├── strpat.spk
    ├── superrels.spk
    ├── test_division.spk
    ├── testbool.spk
    ├── textbox.spk
    ├── typeof.spk
    ├── weird_syntax.spk
    └── zip.spk
├── runtests.sh
├── runtime
    ├── js
    │   └── spinnaker.js
    └── scm
    │   └── spinnaker.scm
├── spinnaker.cabal
├── src
    ├── ArgParser.hs
    ├── Backends
    │   ├── MLtoJS.hs
    │   └── MLtoSCM.hs
    ├── CompDefs.hs
    ├── HL
    │   ├── Defunctionalize.hs
    │   ├── HLOps.hs
    │   ├── HLOptimize.hs
    │   └── Monomorphizer.hs
    ├── HLDefs.hs
    ├── ML
    │   ├── HLtoML.hs
    │   ├── MLOps.hs
    │   └── MLOptimize.hs
    ├── MLDefs.hs
    ├── Main.hs
    ├── Parser
    │   ├── Demod.hs
    │   ├── MPCL.hs
    │   └── Parser.hs
    ├── PrettyPrinter.hs
    ├── ResultT.hs
    ├── SyntaxDefs.hs
    └── Typer
    │   ├── KindTyper.hs
    │   ├── MGUs.hs
    │   ├── TypeTyper.hs
    │   ├── Typer.hs
    │   ├── TypingDefs.hs
    │   └── VariantComplete.hs
├── stdlib
    ├── core.spk
    ├── debug.spk
    ├── either.spk
    ├── list.spk
    ├── maybe.spk
    ├── monad.spk
    ├── std.spk
    └── text.spk
└── vim
    ├── ftdetect
        └── spinnaker.vim
    └── syntax
        └── spinnaker.vim


/.gitignore:
--------------------------------------------------------------------------------
1 | /dist-newstyle
2 | /brainstorm
3 | /TODO
4 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | # The Spinnaker programming language
  2 | - [The general idea](#idea)
  3 |     - [Target audience](#target)
  4 | - [Features](#features)
  5 |     - [Basics](#basics)
  6 |     - [Type relations and instance resolution](#types)
  7 |     - [Easy lists](#lists)
  8 |     - [Lets, binds, patterns](#lets)
  9 |     - [More types](#types)
 10 |     - [Mutual recursion](#recursion)
 11 |     - [Modules](#modules)
 12 |     - [FFI (sort of)](#ffi)
 13 | - [Roadmap](#roadmap)
 14 | 
 15 | Compile any example with `cabal run spinnaker -- -f=example_source_path`  (if you don't want to install the compiler on your system), this will output an `out.js` , which you can run with `node` or `bun`.
 16 | The compiler can emit Javascript or Scheme. To select a backend, simply supply the `--backend=` argument with one of the following: `js` or `scm`.
 17 | It probably won't work on Windows, but I haven't tested it.
 18 | 
 19 | ## The general idea <a name="idea"></a>
 20 | Spinnaker is a purely functional, eagerly evaluated programming language. It's design lies somewhere between Haskell, PureScript and Roc, while it's syntax has had some opinionated changes (for example being whitespace-insensitive).
 21 | I have no previous experience in compilers or computer science, but I decided to start implementing the language as a way to explore the problem space and figure out the best architecture. My end goal would be to rewrite the compiler from scratch once I'm satisfied with the features I implemented and how to do it.
 22 | I've written my own parsing combinator library and command line argument parser. Of course, they don't work as well as the libraries available, but I want to *'reinvent the wheel'* as much as possible.
 23 | 
 24 | ### Target audience <a name="target"></a>
 25 | I decided to make a programming language when I realized that no existing one offered the exact blend of features I wanted. For example, Haskell is awesome, but I don't really like whitespace-sensitivity or lazy evaluation.
 26 | As such, don't expect Spinnaker to have some fancy new feature you've never heard of before, or to be revolutionary in any sense. This language will be as good as it needs to be to justify using it over other languages in my own projects.
 27 | This document is not intended to sell you on the language, but showcase it to people that might be interested in offering feedback on it.
 28 | 
 29 | ## Features <a name="features"></a>
 30 | ### Basics <a name="basics"></a>
 31 | Spinnaker enables brevity. Here is a very simple Hello World:
 32 | ```
 33 | def main = Core.putStrLn "Hello, World!"
 34 | ```
 35 | Lambdas are the heart of the language, hence they require minimal syntax.
 36 | Spinnaker features polymorphic type inference at the top-level:
 37 | ```
 38 | def compose = \f, g, x -> f (g x)
 39 | ```
 40 | Operators are easy to define, they are all right-associative and have the same precedence. All operator sections are supported.
 41 | ```
 42 | def (<|) = compose
 43 | 
 44 | def add = (+)
 45 | def add1 = (1 +)
 46 | def sub3 = (- 3)
 47 | ```
 48 | Keep in mind that the space between the minus sign and the three is significant. If it weren't there the parser would read an integer literal of value `-3`. This doesn't apply to the plus sign.
 49 | 
 50 | Type relations (analogous to Haskell's MultiParamTypeClasses) provide a mechanism for terse ad-hoc polymorphism:
 51 | ```
 52 | def string_true_5 = show True ++ show 5
 53 | ```
 54 | Pattern matching is concise:
 55 | ```
 56 | def and = \x, y ->
 57 |     put x, y
 58 |     | True, True -> True
 59 |     | _, _ -> False
 60 | ```
 61 | You can also write pattern-matching lambdas:
 62 | ```
 63 | def and =
 64 |     \ True, True -> True
 65 |     | _, _ -> False
 66 | 
 67 | def head =
 68 |     \ [] -> error "Error message here"
 69 |     | [x | _] -> x
 70 | ```
 71 | Tuple sections are supported:
 72 | ```
 73 | def need_fst = (, 1)
 74 | def need_snd = (0, )
 75 | def need_middles = (0,,,3)
 76 | 
 77 | def zip = List.map2 (,)
 78 | ```
 79 | Spinnaker supports monadic IO, which can be nicely perfomed with the `bind` syntax:
 80 | ```
 81 | use Std
 82 | 
 83 | def main =
 84 |     _ <- putStr "What's your name? ";
 85 |     name <- getLn;
 86 |     putStrLn $ "Hello, " ++ name ++ "!"
 87 | ```
 88 | You may have noticed that `main` has different types in these examples. We can get away with it because the compiler leverages the power of type relations to choose the best implementation of the entry point. This behavior is extensible to user-defined types by implementing the `ProgramTop` relation.
 89 | 
 90 | ### Type relations and instance resolution <a name="typerels"></a>
 91 | You can define type relations, for example the classic `Functor` and `Monad`:
 92 | ```
 93 | rel pub Functor f = fmap : forall a b. (a -> b) -> f a -> f b
 94 | 
 95 | # A Monad relation requires a Functor super-relation
 96 | rel pub {Functor m} => Monad m =
 97 |     return : forall a. a -> m a,
 98 |     bind : forall a b. m a -> (a -> m b) -> m b
 99 | ```
100 | An example of an instance:
101 | ```
102 | inst Functor Maybe {
103 |     def fmap =
104 |         \ _, None -> None
105 |         | f, Some x -> Some (f x)
106 | }
107 | ```
108 | Overlapping instances are permitted, Spinnaker always chooses the most specific instance. If it can't, it fails. This can be useful, for example, to avoid implementing a `Functor` for every `Monad` if you don't want to, but you can still provide an efficient implementation for a specific type, which the compiler will choose.
109 | In fact, the standard library provides this instance:
110 | ```
111 | inst forall m. {Monad m} => Functor m {
112 |     def fmap = \f, m -> bind m (f |> return)
113 | }
114 | ```
115 | 
116 | ### Easy lists <a name="lists"></a>
117 | There's special syntax for lists, which refer to a user-defined `List` type in the standard library. For example, this removes the second element of a list:
118 | ```
119 | def remove_second : forall a. [a] -> [a]
120 |     = \[x, x' | xs] -> [x | xs]
121 | ```
122 | 
123 | ### Lets, binds, patterns <a name="lets"></a>
124 | Let and bind syntaxes respectively reduce to pattern matching and lambdas, so you can use any valid pattern in them.
125 | ```
126 | let <any pat> = e0 -> e1
127 | #same as
128 | put e0 | <any pat> -> e1
129 | 
130 | <any pat> <- e0; e1
131 | #same as
132 | bind e0 (\<any pat> -> e1)
133 | ```
134 | 
135 | ### More types <a name="types"></a>
136 | Data types are defined as you'd expect:
137 | ```
138 | data Either a b = Left a | Right b
139 | ```
140 | Type synonyms are experimental:
141 | ```
142 | typesyn String = [Chr]
143 | typesyn Point a = (a, a)
144 | ```
145 | You can provide type annotations to top-level definitions and expressions. While they are generally not needed, they are sometimes necessary to specify relation instances:
146 | ```
147 | def fac : Int -> Int =
148 |     \ 0 -> 1
149 |     | n -> n * fac (n - 1)
150 | 
151 | def map : forall a b. (a -> b) -> [a] -> [b] =
152 |     \ _, [] -> []
153 |     | f, [x | xs] -> f x :: map f xs
154 | 
155 | def false = toEnum 0 : Bool
156 | ```
157 | 
158 | ### Mutual recursion <a name="recursion"></a>
159 | To aid type inference and clarity, mutually recursive values must be defined together with the `and` keyword:
160 | ```
161 | def isEven =
162 |     \ 0 -> True
163 |     | n -> not $ isOdd $ n - 1
164 | 
165 | and isOdd =
166 |     \ 0 -> False
167 |     | n -> not $ isEven $ n - 1
168 | ```
169 | This also works for data types (but not for type synonyms):
170 | ```
171 | data A a b = NilA a | ConsA a (B a b)
172 | and B a b = NilB b | ConsB b (A a b)
173 | ```
174 | 
175 | ### Modules <a name="modules"></a>
176 | You can define modules and import them from files:
177 | ```
178 | # ./a.spk
179 | def pub answer_to_everything = 42
180 | 
181 | mod pub Nums {
182 |     def pub five = 5
183 | }
184 | 
185 | # ./main.spk
186 | mod A "a.spk"
187 | use A
188 | 
189 | def main = answer_to_everything + Nums.five
190 | ```
191 | You can also bring a module in scope for a select expression with the inline use syntax. Note that parentheses aren't optional.
192 | ```
193 | def main = Std.( 0..10 )
194 | ```
195 | 
196 | ### FFI (sort of) <a name="ffi"></a>
197 | As of now, you can only use functions defined in the host language (which, at the moment, is just the `js` backend). They can be declared in Spinnaker as follows (note that they must be monomorphic):
198 | ```
199 | ext someExternalFunction "functionName" : Int, Flt -> Bool
200 | 
201 | def getABool = someExternalFunction 3 1.2
202 | ```
203 | This compiles to the following `js` call:
204 | ```
205 | functionName(3, 1.2)
206 | ```
207 | Such an approach fails when considering user-defined or polymorphic types, but it's sufficient to define a basic runtime.
208 | 
209 | ## Roadmap <a name="roadmap"></a>
210 | Entries are in rough order of priority
211 | - Expand the standard library
212 | - Compilation to a C subset
213 | - Decent error messages
214 | - Document compiler behavior and restrictions
215 | - Support for defining libraries
216 | - Automatic generation of documentation from sources
217 | - The compiler is painfully slow, this needs fixing
218 | - Tail-call optimization
219 | - REPL
220 | - Redefine an FFI (in particular, function exports)
221 | - Add a `comptime` directive for certain types of expressions
222 | - Maybe implement the Perceus technique
223 | - Still on the fence about records and row polymorphism
224 | 


--------------------------------------------------------------------------------
/cabal.project:
--------------------------------------------------------------------------------
1 | packages: ./spinnaker.cabal
2 | 


--------------------------------------------------------------------------------
/examples/ackermann.spk:
--------------------------------------------------------------------------------
1 | use Std
2 | 
3 | def ackermann =
4 |     \ 0, n -> n + 1
5 |     | m, 0 -> ackermann (m - 1) 1
6 |     | m, n -> ackermann (m - 1) (ackermann m (n - 1))
7 | 
8 | def main = map (ackermann 3) (0..=5)
9 | 


--------------------------------------------------------------------------------
/examples/better_euler_sieve.spk:
--------------------------------------------------------------------------------
 1 | use Std
 2 | use List
 3 | 
 4 | def filter_muls_aux =
 5 |     \ acc, _, _, [] -> reverse acc
 6 |     | acc, cur, n, l@[x | xs] ->
 7 |         if cur > x then filter_muls_aux (x :: acc) cur n xs
 8 |         else if cur == x then filter_muls_aux acc (cur+n) n xs
 9 |         else filter_muls_aux acc (cur+n) n l
10 | def filter_muls = \x -> filter_muls_aux [] x x
11 | 
12 | def sieve_iter =
13 |     \ lim, acc, l@[x | xs] ->
14 |         if lim < x*x then reverse acc ++ l
15 |         else sieve_iter lim (x :: acc) (filter_muls x xs)
16 | def sieve = \n -> sieve_iter n [] (2..=n)
17 | 
18 | def main = putStrLn $ "There are " ++ show (length (sieve 10_000)) ++ " primes up to 10000"
19 | 


--------------------------------------------------------------------------------
/examples/cartesian.spk:
--------------------------------------------------------------------------------
 1 | use Std
 2 | 
 3 | def cartesian = \l, l' ->
 4 |     x <- l;
 5 |     map (x,) l'
 6 | 
 7 | def powerset =
 8 |     \ [] -> [[]]
 9 |     | [x | xs] ->
10 |         s <- powerset xs;
11 |         [s, x::s]
12 | 
13 | def main =
14 |     _ <- print $ cartesian ('a'..='d') (1..=3);
15 |     print $ powerset (0..3)
16 | 


--------------------------------------------------------------------------------
/examples/church.spk:
--------------------------------------------------------------------------------
 1 | use Core
 2 | 
 3 | mod Church {
 4 |     def pub true = \a, b -> a
 5 |     def pub false = \a, b -> b
 6 | 
 7 |     def pub zero= \f, x -> x
 8 |     def pub succ= \a, f, x -> a f (f x)
 9 |     def pub one = succ zero
10 | 
11 |     def pub add = \a, b, f, x -> a f (b f x)
12 |     def pub mul = \a, b, f, x -> a (b f) x
13 |     def pub exp = \a, b -> b a
14 | 
15 |     # def pub pred : forall n. ((n -> n) -> n -> n) -> (n -> n) -> n -> n
16 |     #             = \n, f, x -> n(\g, h->h (g f)) (\u->x) (\u->u)
17 |     # def pub sub = \a, b -> b pred a
18 | 
19 |     def pub iszero = \n -> n (\x -> false) true
20 | 
21 |     def pub ctoi = \a -> a (1+) 0
22 |     def pub ctob = \a -> a True False
23 | } use Church
24 | 
25 | def six = mul (succ one) (succ (succ one))
26 | 
27 | def main =
28 |     print (ctoi $ exp six (succ one))
29 |     >> print (ctob $ iszero zero)
30 |     >> print (ctob $ iszero one)
31 | 


--------------------------------------------------------------------------------
/examples/collatz.spk:
--------------------------------------------------------------------------------
 1 | use Std
 2 | 
 3 | def collatz = \l, n ->
 4 |     if n == 1 then 1 :: l else
 5 |     collatz (n :: l) (
 6 |         put rem n 2
 7 |         | 0 -> n / 2
 8 |         | 1 -> 1 + 3*n
 9 |     )
10 | 
11 | def main = reverse $ collatz [] 42
12 | 


--------------------------------------------------------------------------------
/examples/comparedna.spk:
--------------------------------------------------------------------------------
 1 | use Std
 2 | use List
 3 | 
 4 | # TODO: metti nella stdlib
 5 | def findIndicesAux =
 6 |     \ _, acc, _, [] -> reverse acc
 7 |     | n, acc, f, [x | xs] ->
 8 |         findIndicesAux (n + 1) (if f x then n :: acc else acc) f xs
 9 | and findIndices : forall a. (a -> Bool) -> [a] -> [Int]
10 |     = findIndicesAux 0 []
11 | 
12 | def s0 = "gtcgattaca"
13 | def s1 = "atctcatcca"
14 | 
15 | def main = putStrLn $ "DNA mismatches: " ++ show $ findIndices id $ map2 (!=) s0 s1
16 | 


--------------------------------------------------------------------------------
/examples/enumChar.spk:
--------------------------------------------------------------------------------
1 | def main = Std.('a'..='z')
2 | 


--------------------------------------------------------------------------------
/examples/euler_sieve.spk:
--------------------------------------------------------------------------------
 1 | use Std
 2 | use Maybe use List
 3 | 
 4 | def sieve = \n -> let sieve_iter =
 5 |         \ [] -> None
 6 |         | [x | xs] -> Some (x, xs \\ map (x*) $ x :: take (length xs / x) xs)
 7 |     -> unfoldr sieve_iter (2..=n)
 8 | 
 9 | def main = sieve 100
10 | 


--------------------------------------------------------------------------------
/examples/evenodd.spk:
--------------------------------------------------------------------------------
 1 | use Std
 2 | 
 3 | def even =
 4 |     \ 0 -> True
 5 |     | n -> odd (n - 1)
 6 | and odd =
 7 |     \ 0 -> False
 8 |     | n -> even (n - 1)
 9 | 
10 | def main = (0..9) |-> map $ \n->(even n, odd n)
11 | 


--------------------------------------------------------------------------------
/examples/fac.spk:
--------------------------------------------------------------------------------
1 | use Core
2 | 
3 | def fac =
4 |     \ 0 -> 1
5 |     | n -> n * fac (n - 1)
6 | 
7 | def main = fac 5
8 | 


--------------------------------------------------------------------------------
/examples/fib.spk:
--------------------------------------------------------------------------------
 1 | use Core
 2 | 
 3 | def fibAux =
 4 |     \ seed0, _, 0 -> seed0
 5 |     | seed0, seed1, n -> fibAux seed1 (seed0+seed1) (n - 1)
 6 | 
 7 | def fib = fibAux 0 1
 8 | 
 9 | def main = fib 10
10 | 


--------------------------------------------------------------------------------
/examples/fix.spk:
--------------------------------------------------------------------------------
 1 | use Core
 2 | 
 3 | def fix : forall a b. ((a -> b) -> a -> b) -> a -> b
 4 |     = \f, x -> f (fix f) x
 5 | 
 6 | def fac = fix $
 7 |     \ _, 0 -> 1
 8 |     | f, n -> n * f (n - 1)
 9 | 
10 | def main = fac 5
11 | 


--------------------------------------------------------------------------------
/examples/fix2.spk:
--------------------------------------------------------------------------------
1 | use Std
2 | 
3 | def fix2 = \f, g, x -> f (fix2 g f) x
4 | 
5 | def main =
6 |     let fix2even = fix2 (\f, x -> if x == 0 then True else f (x - 1)) (\f, x -> if x == 0 then False else f (x - 1)) ->
7 |     map fix2even (0..4)
8 | 


--------------------------------------------------------------------------------
/examples/fizzbuzz.spk:
--------------------------------------------------------------------------------
 1 | use Std
 2 | 
 3 | def fizzbuzz = \n -> put rem n 3, rem n 5
 4 |     | 0, 0 -> "FizzBuzz"
 5 |     | 0, _ -> "Fizz"
 6 |     | _, 0 -> "Buzz"
 7 |     | _, _ -> show n
 8 | 
 9 | def main = putStr $ Text.unlines $ map fizzbuzz $ 1..=15
10 | 


--------------------------------------------------------------------------------
/examples/floats.spk:
--------------------------------------------------------------------------------
 1 | use Std
 2 | 
 3 | def ceiling = (0.0 -) |> floor |> (0 -)
 4 | 
 5 | def round = (2.0 *) |> ceiling |> (/ 2)
 6 | 
 7 | def main =
 8 |     let l = [0.0, 1.0, 2.3, 2.4999, 2.5, 2.50001, 2.8, 3.0000001, 3.000001] ->
 9 |     _ <- putStrLn $ "vec: " ++ show l;
10 |     _ <- putStrLn $ "floors:   " ++ show $ map floor l;
11 |     _ <- putStrLn $ "ceilings: " ++ show $ map ceiling l;
12 |     _ <- putStrLn $ "rounds:   " ++ show $ map round l;
13 |     return ()
14 | 


--------------------------------------------------------------------------------
/examples/generalized_fizzbuzz.spk:
--------------------------------------------------------------------------------
 1 | use Std
 2 | use List
 3 | 
 4 | def fizzbuzz = \divs, words, n ->
 5 |     let rems = map (rem n) divs ->
 6 |     if all (0!=) rems then show n
 7 |     else concat $ map2 (\0, w -> w | _, _ -> "") rems words
 8 | 
 9 | def main = putStr $ Text.unlines $ map (fizzbuzz [2, 3, 5] ["Fizz", "Buzz", "Bazz"]) $ 1..=30
10 | 


--------------------------------------------------------------------------------
/examples/hanoi.spk:
--------------------------------------------------------------------------------
 1 | use Core
 2 | 
 3 | def hanoiAux =
 4 |     \ _, _, 0 -> []
 5 |     | from, to, n ->
 6 |         let interm = 3 - from + to ->
 7 |         hanoiAux from interm (n - 1) ++ (from, to) :: hanoiAux interm to (n - 1)
 8 | and hanoi = hanoiAux 0 1
 9 | 
10 | def main = hanoi 4
11 | 


--------------------------------------------------------------------------------
/examples/helloworld.spk:
--------------------------------------------------------------------------------
1 | def main = Core.putStrLn "Ciao Mondo!"
2 | 


--------------------------------------------------------------------------------
/examples/hintrestrict.spk:
--------------------------------------------------------------------------------
1 | use Core
2 | 
3 | def hinted : Int -> Int = \x->x
4 | def main = hinted (fromInt 5)
5 | 


--------------------------------------------------------------------------------
/examples/interactive/iobind.spk:
--------------------------------------------------------------------------------
1 | use Core
2 | 
3 | def main : IO ()
4 |          = _ <- putStr "Scrivi il tuo nome: ";
5 |            n <- getLn;
6 |            putStrLn ("Ciao, " ++ n ++ "!")
7 | 


--------------------------------------------------------------------------------
/examples/interactive/zeroper.spk:
--------------------------------------------------------------------------------
 1 | use Std
 2 | use List
 3 | 
 4 | def intersperse = \e, l -> put l
 5 |     | [] -> []
 6 |     | [ x] -> [x]
 7 |     | [x | xs] -> [x, e | intersperse e xs]
 8 | 
 9 | def diagonal = \l -> put l
10 |     | [] -> []
11 |     | [[x|_] | ls] -> x :: diagonal (map tail ls)
12 | 
13 | data Segno = Zero | Per | Vuoto
14 | 
15 | inst Show Segno {
16 |     def show = \c -> put c
17 |         | Zero -> "O"
18 |         | Per -> "X"
19 |         | Vuoto -> " "
20 | }
21 | inst Eq Segno {
22 |     def (==) =
23 |         \ Zero, Zero -> True
24 |         | Per, Per -> True
25 |         | Vuoto, Vuoto -> True
26 |         | _, _ -> False
27 |     def (!=) = \a, b -> not (a == b)
28 | }
29 | 
30 | def vuoto = \b, x, y -> nth x (nth y b) == Vuoto
31 | 
32 | def showBoard = map (map show |> intersperse "|" |> Text.unwords)
33 |              |> intersperse "\n---------\n" |> concat
34 | 
35 | def alternate =
36 |     \ Zero -> Per
37 |     | Per -> Zero
38 | 
39 | def wins = \s, brd -> any (all (s==)) $
40 |        diagonal brd
41 |     :: diagonal (reverse brd)
42 |     :: brd
43 |     ++ transpose brd
44 | 
45 | def getInput : IO (Int, Int)
46 |     = input <- getLn;
47 |     put input
48 |     | [cx, ',', cy] ->
49 |         let x = fromEnum cx - 48 ->
50 |         let y = fromEnum cy - 48 ->
51 |         if all id [x >= 0, x <= 2, y >= 0, y <= 2]
52 |             then return (x, y)
53 |             else putStr "Invalid input: " >> getInput
54 |     | _ -> putStr "Invalid input: " >> getInput
55 | 
56 | def loop : Segno -> [[Segno]] -> IO ()
57 |     = \p, brd -> putStrLn (showBoard brd) >>
58 |     putStr ("Player " ++ show p ++ " input x,y: ") >>
59 |     (x, y) <- getInput;
60 |     if vuoto brd x y then
61 |         let brd' = updateAt y (updateAt x (const p)) brd ->
62 |         if wins p brd'
63 |             then putStrLn (showBoard brd') >> putStrLn ("Player " ++ show p ++ " won!")
64 |         else if any (any (Vuoto==)) brd'
65 |             then loop (alternate p) brd'
66 |         else putStrLn (showBoard brd') >> putStrLn "Draw!"
67 |     else putStrLn "This square is already occupied" >> loop p brd
68 | 
69 | 
70 | def main = loop Zero (replicate 3 (replicate 3 Vuoto))
71 | 


--------------------------------------------------------------------------------
/examples/iota.spk:
--------------------------------------------------------------------------------
 1 | use Std
 2 | 
 3 | data Iota
 4 |     = ILeaf
 5 |     | INode Iota Iota
 6 | 
 7 | inst Show Iota {
 8 |     def show =
 9 |         \ ILeaf -> "ι"
10 |         | INode i0 i1 -> "(" ++ show i0 ++ show i1 ++ ")"
11 | }
12 | 
13 | def iota_parse =
14 |     \ ['1'|s] -> (ILeaf, s)
15 |     | ['0'|s] ->
16 |         let (i0, s') = iota_parse s ->
17 |         let (i1, s'') = iota_parse s' ->
18 |         (INode i0 i1, s'')
19 | 
20 | def jot_revcomp =
21 |     \ [] -> "I"
22 |     | ['0'|s] -> "((" ++ jot_revcomp s ++ "S)K)"
23 |     | ['1'|s] -> "(S(K" ++ jot_revcomp s ++ "))"
24 | 
25 | def jot_comp = reverse |> jot_revcomp
26 | 
27 | def main =
28 |     _ <- putStrLn $ "Parsed Iota: " ++ show $ map (iota_parse |> fst) ["0011011", "0101011"];
29 |     putStrLn $ "Jot to SK: " ++ show $ map jot_comp ["11100", "11111000"]
30 | 


--------------------------------------------------------------------------------
/examples/lcg.spk:
--------------------------------------------------------------------------------
 1 | use Std
 2 | 
 3 | def bsd_round = \n -> rem (12345 + n*1103515245) (2^31)
 4 | 
 5 | data pub Random a = Random (Int -> a)
 6 | 
 7 | inst Monad Random {
 8 |     def return = \x -> Random (const x)
 9 |     def bind =
10 |         \ Random sf, f -> Random (\s ->
11 |             let Random sf' = f (sf s)
12 |             -> sf' (bsd_round s))
13 | }
14 | def pub randInt : Random Int = Random id
15 | 
16 | def pub runRandom : forall a. Int -> Random a -> a =
17 |     \ seed, Random f -> f seed
18 | 
19 | def main = runRandom 0 $
20 |     x <- randInt;
21 |     y <- randInt;
22 |     z <- randInt;
23 |     w <- randInt;
24 |     return (x, y, z, w)
25 | 


--------------------------------------------------------------------------------
/examples/listmonad.spk:
--------------------------------------------------------------------------------
1 | use Std
2 | 
3 | def main =
4 |     x <- 0..=5;
5 |     y <- 0..=4;
6 |     _ <- Monad.guard (5 >= x+y);
7 |     return (x, y)
8 | 


--------------------------------------------------------------------------------
/examples/lsystem.spk:
--------------------------------------------------------------------------------
 1 | use Std
 2 | use List
 3 | use Maybe
 4 | 
 5 | def step = \rules, state ->
 6 |     c <- state;
 7 |     fromMaybe [c] (lookup c rules)
 8 | 
 9 | def stepn = \n, rules, axiom ->
10 |     foldl (\s, _ -> step rules s) axiom (0..n)
11 | 
12 | def main =
13 |     putStrLn (stepn 5 [('0', "01"), ('1', "10")] "0")
14 |     >> putStrLn (stepn 2 [('F', "FF"), ('X', "F+[[X]-X]-F[-FX]+X")] "X")
15 | 


--------------------------------------------------------------------------------
/examples/matrix.spk:
--------------------------------------------------------------------------------
  1 | use Std
  2 | 
  3 | mod TypeNat {
  4 |     # TODO: questo deve diventare una libreria, è abbastanza utile
  5 | 
  6 |     data pub S a = S a
  7 |     data pub Z = Z
  8 |     # NOTE: Wrapper per i TypeNat, è un semplice holder di phantom type
  9 |     data pub NatWrap a = NatWrap
 10 | 
 11 |     # Numeri natuali condificati con Peano in type-level, al momento si può controllare soltanto l'equivalenza grazie all'unificazione, ma con le dipendenze funzionali si potrebbero anche codificare delle operazioni di base
 12 |     # Un tipo è un naturale di type-level se implementa questa relazione, cioè se si può convertire (tramite un wrapper) a un naturale value-level
 13 |     rel pub TyNat a = tynatInt : NatWrap a -> Int
 14 | 
 15 |     # Istanze della relazione per 0 e S(n)
 16 |     inst TyNat Z { def tynatInt = const 0 }
 17 |     inst forall a. {TyNat a} => TyNat (S a) {
 18 |         def tynatInt = const (1 + tynatInt (NatWrap : NatWrap a))
 19 |     }
 20 | }
 21 | 
 22 | mod Matrix {
 23 |     use List
 24 |     use Maybe
 25 |     use TypeNat
 26 | 
 27 |     # Una matrice è un wrapper di una lista di liste, con due phantom type che rappresentano il numero di righe e colonne
 28 |     data pub Matrix r c a = Matrix [[a]]
 29 | 
 30 |     # Stampa la matrice
 31 |     inst forall r c a.{TyNat r, TyNat c, Show [a]} => Show (Matrix r c a) {
 32 |         def show = \Matrix l -> "Matrix " ++ show (tynatInt $ NatWrap : NatWrap r) ++ "x" ++ show (tynatInt $ NatWrap : NatWrap c) ++ ':'::show l
 33 |     }
 34 | 
 35 |     # Matrice identità, nota che le dimensioni della matrice vengono rilevate automaticamente
 36 |     def pub identity : forall n a.{TyNat n, Num a} => Matrix n n a
 37 |         =   let n = tynatInt (NatWrap : NatWrap n) ->
 38 |             let iter = 0..n ->
 39 |             Matrix $ map (\y -> map (\x -> if x == y then fromInt 1 else fromInt 0) iter) iter
 40 | 
 41 |     # Matrice zero, nota che le dimensioni della matrice vengono rilevate automaticamente
 42 |     def pub zero : forall r c a.{TyNat r, TyNat c, Num a} => Matrix r c a
 43 |         =   let r = tynatInt (NatWrap : NatWrap r) ->
 44 |             let c = tynatInt (NatWrap : NatWrap c) ->
 45 |             let iterr = 0..r ->
 46 |             let iterc = 0..c ->
 47 |             Matrix $ map (const $ map (const $ fromInt 0) iterc) iterr
 48 | 
 49 |     # Converti una list di liste in matrice controllandone le dimensioni, un crash è possibile solo qui
 50 |     def pub mxfromList : forall r c a. {TyNat r, TyNat c, Num a} => [[a]] -> Matrix r c a
 51 |         = \l ->
 52 |             let r = tynatInt (NatWrap : NatWrap r) ->
 53 |             let c = tynatInt (NatWrap : NatWrap c) ->
 54 |             Matrix $ if length l != r
 55 |                 then error "List has wrong number of rows"
 56 |                 else map (\l' -> if length l' != c then error "List row has wrong number of columns" else l') l
 57 | 
 58 |     # Trasposizione
 59 |     def pub mxtranspose : forall r c a. Matrix r c a -> Matrix c r a
 60 |         = \Matrix l -> Matrix (transpose l)
 61 | 
 62 |     # Somma
 63 |     def pub mxadd : forall r c a.{TyNat r, TyNat c, Num a} => Matrix r c a -> Matrix r c a -> Matrix r c a
 64 |         = \Matrix l, Matrix l' -> Matrix $ map2 (map2 (+)) l l'
 65 | 
 66 |     # Prodotto interno generalizzato
 67 |     def pub mxinner : forall m n p a b c. ([a] -> [b] -> c) -> Matrix m n a -> Matrix n p b -> Matrix m p c
 68 |         = \f, Matrix l, Matrix l' ->
 69 |             let tl' = transpose l' ->
 70 |             Matrix $ map (\rowa -> map (f rowa) tl') l
 71 | 
 72 |     # Prodotto tra matrici classico
 73 |     def pub mxmul : forall m n p a. {Num a} => Matrix m n a -> Matrix n p a -> Matrix m p a
 74 |          = mxinner (\a, b -> foldl (+) (fromInt 0) (map2 (*) a b))
 75 | 
 76 |     def swapFront =
 77 |         \ _, _, [] -> None
 78 |         | n, curr, [r | rows] ->
 79 |             if all (fromInt 0 ==) (take n r) && fromInt 0 != nth n r
 80 |                 then Some (r, reverse curr ++ rows)
 81 |                 else swapFront n (r :: curr) rows
 82 | 
 83 |     # Annulla l'n-esimo elemento di ogni riga grazie a una somma proporzionale a r
 84 |     def canceln = \n, r, rows ->
 85 |         map (\row ->
 86 |             let ratio = nth n row / nth n r ->
 87 |             map2 (-) row (map (ratio *) r)
 88 |         ) rows
 89 | 
 90 |     # Annulla gli elementi superiori arrivando a una diagonale (NOTE: l'input è invertito)
 91 |     def cancelTop =
 92 |         \ _, curr, [] -> curr
 93 |         | n, curr, [r | rows] ->
 94 |             cancelTop (n - 1) (map (/ nth n r) r :: curr) (canceln n r rows)
 95 | 
 96 |     # Diagonalizza
 97 |     def diagonalize =
 98 |         \ n, curr, [] -> return $ cancelTop (n - 1) [] curr
 99 |         | n, curr, rows ->
100 |             (r, rows') <- swapFront n [] rows;
101 |             diagonalize (n + 1) (r :: curr) (canceln n r rows')
102 | 
103 |     # Trova l'inverso con l'eliminazione Gauss-Jordan
104 |     def pub inverseList
105 |         = \list ->
106 |             let n = length list ->
107 |             let ident =
108 |                 let iter = 0..n ->
109 |                 map (\y -> map (\x -> if x == y then fromInt 1 else fromInt 0) iter) iter ->
110 |             let augmented = map2 (++) list ident ->
111 |             fmap (map (drop n)) $ diagonalize 0 [] augmented
112 | 
113 |     # Wrapper per le matrici type-safe
114 |     def pub mxinverse : forall m a. {Eq a, Num a} => Matrix m m a -> Maybe (Matrix m m a)
115 |         = \Matrix l -> fmap Matrix (inverseList l)
116 | } use Matrix
117 | 
118 | use TypeNat
119 | 
120 | # Risolve i Least Squares: (X^T X)^-1 X^T Y
121 | def lsq_solve = \x, y ->
122 |     fmap (flip mxmul (mxmul (mxtranspose x) y)) (mxinverse $ mxmul (mxtranspose x) x)
123 | 
124 | def main =
125 |     let x = mxfromList [[0.0, 1.0], [1.0, 1.0], [2.0, 1.0], [3.0, 1.0]] : Matrix (S(S(S(S Z)))) (S(S Z)) Flt ->
126 |     let y = mxfromList [[1.0], [2.0], [4.0], [-1.0]] : Matrix (S(S(S(S Z)))) (S Z) Flt ->
127 |     lsq_solve x y
128 | 


--------------------------------------------------------------------------------
/examples/mergesort.spk:
--------------------------------------------------------------------------------
 1 | use Std
 2 | use List
 3 | 
 4 | mod pub Sort {
 5 |     def split = \l -> splitAt (length l / 2) l
 6 | 
 7 |     def merge = \cmp, ll, lr ->
 8 |         put ll, lr
 9 |         | l, [] -> l
10 |         | [], l -> l
11 |         | [xa | xsa], [xb | xsb] -> (
12 |             put cmp xa xb
13 |             | True -> xa :: merge cmp xsa (xb::xsb)
14 |             | False -> xb :: merge cmp (xa::xsa) xsb
15 |         )
16 | 
17 |     def pub sortBy = \cmp, list ->
18 |         put list
19 |         | [] -> []
20 |         | [x] -> list
21 |         | _ -> let (left, right) = split list ->
22 |             merge cmp (sortBy cmp left) (sortBy cmp right)
23 | 
24 |     def pub sort = sortBy (<=)
25 | }
26 | 
27 | def ordleft = \(a,_),(b,_)->a <= b
28 | def ordright = \(_,a),(_,b)->a <= b
29 | 
30 | def main =
31 |     Sort.sortBy ordleft $
32 |     Sort.sortBy ordright $
33 |         x <- -5..0;
34 |         y <- reverse $ 0..10;
35 |         return (x, y)
36 | 


--------------------------------------------------------------------------------
/examples/multimod.spk:
--------------------------------------------------------------------------------
 1 | mod M {
 2 |     mod A {
 3 |         def pub a = 10
 4 |         def pub b = 1
 5 |     }
 6 |     mod B {
 7 |         def pub a = 11
 8 |         def pub c = 2
 9 |     }
10 |     use pub A
11 |     use B
12 | }
13 | 
14 | def main = M.a
15 | 


--------------------------------------------------------------------------------
/examples/multipat.spk:
--------------------------------------------------------------------------------
 1 | use Core
 2 | 
 3 | def main = putStrLn $
 4 |     put 213, True
 5 |     | 213, False -> "a"
 6 |     | 2, True -> "b"
 7 |     | _, False -> "c"
 8 |     | 3, _ -> "d"
 9 |     | a, b -> show (a, b)
10 | 


--------------------------------------------------------------------------------
/examples/n_queens.spk:
--------------------------------------------------------------------------------
 1 | use Std
 2 | use List use Monad
 3 | 
 4 | def is_safe_aux = \i, ps, n -> put ps
 5 |     | [] -> True
 6 |     | [p | ps'] ->
 7 |         if (p != n) && (abs (n - p) != i)
 8 |         then is_safe_aux (i + 1) ps' n
 9 |         else False
10 | and is_safe = is_safe_aux 1
11 | 
12 | def partial = \n, i -> put i
13 |     | 0 -> [[]]
14 |     | _ ->
15 |         q <- partial n (i - 1);
16 |         p <- 0..n;
17 |         _ <- guard (is_safe q p);
18 |         return (p :: q)
19 | 
20 | def n_queens = \n -> partial n n
21 | 
22 | def print_sol =
23 |     let print_row = \n, p -> putStrLn $ concat $ map (\x -> if x == p then "Q " else ". ") (0..n) ->
24 |     \s -> mapM_ (print_row (length s)) s
25 | 
26 | def main = mapM_ (print_sol |> (>> putChr '\n')) $ n_queens 6
27 | 


--------------------------------------------------------------------------------
/examples/newmod.spk:
--------------------------------------------------------------------------------
 1 | mod pub MyMod {
 2 |     use Core
 3 |     def internal_1 = 1
 4 |     def internal_2 = 2
 5 |     def internal_add = (+)
 6 |     def pub pubresult = internal_add internal_1 internal_2
 7 | }
 8 | 
 9 | mod UseAs{use pub Core}
10 | 
11 | def main = UseAs.(*) MyMod.pubresult 5
12 | 


--------------------------------------------------------------------------------
/examples/ninetyninebottles.spk:
--------------------------------------------------------------------------------
 1 | use Std
 2 | 
 3 | def bottles =
 4 |     \ 0 -> "no more bottles"
 5 |     | 1 -> "1 bottle"
 6 |     | n -> show n ++ " bottles"
 7 | 
 8 | def verse = \n ->
 9 |     if n == 0
10 |     then "No more bottles of beer on the wall, no more bottles of beer.\nGo to the store and buy some more, 99 bottles of beer on the wall."
11 |     else bottles n
12 |         ++ " of beer on the wall, " ++ bottles n ++ " of beer.\nTake one down, pass it around, "
13 |         ++ bottles (n - 1) ++ " of beer on the wall.\n"
14 | 
15 | def main = Monad.mapM_ (putStrLn <| verse) (reverse $ 0..100)
16 | 


--------------------------------------------------------------------------------
/examples/overloaded_fac.spk:
--------------------------------------------------------------------------------
1 | use Core
2 | 
3 | def fac = \n ->
4 |     if n == fromInt 0
5 |     then fromInt 1
6 |     else n * fac (n - fromInt 1)
7 | 
8 | def main = fac (fromInt 5) : Int
9 | 


--------------------------------------------------------------------------------
/examples/printbool.spk:
--------------------------------------------------------------------------------
1 | use Core
2 | 
3 | def main = print True
4 | 


--------------------------------------------------------------------------------
/examples/putchr.spk:
--------------------------------------------------------------------------------
1 | use Core
2 | 
3 | def main = putChr 'c' >> putChr 's' >> putChr '\n'
4 | 


--------------------------------------------------------------------------------
/examples/quine.spk:
--------------------------------------------------------------------------------
1 | use Std def main=(\s->putStr s>>print s)"use Std def main=(\\s->putStr s>>print s)"
2 | 


--------------------------------------------------------------------------------
/examples/show.spk:
--------------------------------------------------------------------------------
1 | use Core
2 | 
3 | def main =
4 |     let s = "Ciao\\\nMondo!" ->
5 |     print ((True, 10), (s, ()))
6 |     >> putStrLn s
7 |     >> print [[0, 1, 2], [3, 4, 5], [6, 7, 8, 9]]
8 | 
9 | 


--------------------------------------------------------------------------------
/examples/statet.spk:
--------------------------------------------------------------------------------
 1 | use Std
 2 | use Monad
 3 | use State
 4 | 
 5 | def main = flip runStateT 0 $
 6 |     puts 10 >>
 7 |     s <- gets;
 8 |     (lift $ print s) >>
 9 |     puts (s + 1)
10 | 


--------------------------------------------------------------------------------
/examples/strpat.spk:
--------------------------------------------------------------------------------
1 | def strtonum =
2 |     \ "uno" -> 1
3 |     | "due" -> 2
4 |     | "tre" -> 3
5 |     | _     -> -1
6 | 
7 | def main = Core.map strtonum ["uno", "due", "tre", "nonvalido", "un", "ue"]
8 | 


--------------------------------------------------------------------------------
/examples/superrels.spk:
--------------------------------------------------------------------------------
 1 | use Core
 2 | 
 3 | rel Rel0 a = el0:a
 4 | rel {Rel0 a} => Rel1 a = el1:a
 5 | 
 6 | inst Rel0 Flt {def el0=0.0}
 7 | inst Rel1 Int {def el1=0}
 8 | 
 9 | # Rel0 serve per Rel1, ma viene definito dopo. Questo potrebbe essere un bug. Succede perché i controlli di superrel vengono effettuati durante i controlli delle definizioni, non il typecheck delle istanze
10 | inst Rel0 Int {def el0=0}
11 | 
12 | def somef = fmap id <| return
13 | def eq : forall a. {Ord a} => a -> a -> Bool
14 |     = (==)
15 | 
16 | def main = fmap id (print ())
17 | 


--------------------------------------------------------------------------------
/examples/test_division.spk:
--------------------------------------------------------------------------------
1 | use Std
2 | 
3 | def dividend_divisor_pairs = [(8, 3), (8, -3), (-8, 3), (-8, -3), (1, 2), (1, -2), (-1, 2), (-1, -2)]
4 | 
5 | def main = map (\(a, b) -> (a / b, rem a b)) dividend_divisor_pairs
6 | 


--------------------------------------------------------------------------------
/examples/testbool.spk:
--------------------------------------------------------------------------------
 1 | use Std
 2 | 
 3 | def test = \f ->
 4 |     b <- [False, True];
 5 |     a <- [False, True];
 6 |     [f a b]
 7 | 
 8 | def main =
 9 |     putStr "and " >> print (test (&&)) >>
10 |     putStr "or  " >> print (test (||)) >>
11 |     putStr "not " >> print (map not [False, True])
12 | 


--------------------------------------------------------------------------------
/examples/textbox.spk:
--------------------------------------------------------------------------------
 1 | use Std
 2 | use List
 3 | 
 4 | mod Corners {
 5 |     def pub v  = '│'
 6 |     def pub h  = '─'
 7 |     def pub ur = '┐'
 8 |     def pub ul = '┌'
 9 |     def pub dl = '└'
10 |     def pub dr = '┘'
11 | }
12 | 
13 | def complete_line = \len, str -> str ++ replicate (len - length str) ' '
14 | def max_len = map length |> foldl max 0
15 | 
16 | def complete = \lines ->
17 |     let maxlen = max_len lines ->
18 |     map (complete_line maxlen) lines
19 | 
20 | def make_box_lines = \lines ->
21 |     let lines' = complete lines ->
22 |     let len = length $ head lines' ->
23 |     let lines'' = map ((++ [' ', Corners.v]) |> ([Corners.v, ' '] ++)) lines' ->
24 |     let edge = replicate (len + 2) Corners.h ->
25 |     let upper_edge = Corners.ul :: edge ++ [Corners.ur] ->
26 |     let lower_edge = Corners.dl :: edge ++ [Corners.dr] ->
27 |     upper_edge :: lines'' ++ [lower_edge]
28 | 
29 | def make_box = Text.lines |> make_box_lines |> Text.unlines
30 | 
31 | def main = putStr $ make_box $ "Hi\nline1\nline_2"
32 | 


--------------------------------------------------------------------------------
/examples/typeof.spk:
--------------------------------------------------------------------------------
 1 | use Std
 2 | 
 3 | mod Typeof {
 4 |     mod pub Defs {
 5 |         data pub TOTok a = TOTok
 6 |         rel pub Typeof a = typeofT : TOTok a -> String
 7 |     } use Defs
 8 | 
 9 |     def pub typeof : forall a. {Typeof a} => a -> String
10 |         = const (typeofT (TOTok : TOTok a))
11 | 
12 |     inst Typeof Int { def typeofT = const "Int" }
13 |     inst Typeof Flt { def typeofT = const "Flt" }
14 |     inst Typeof () { def typeofT = const "()" }
15 |     inst Typeof Bool { def typeofT = const "Bool" }
16 |     inst Typeof Chr { def typeofT = const "Chr" }
17 |     inst forall a b. {Typeof a, Typeof b} => Typeof (a, b) {
18 |         def typeofT = const $ "(" ++ typeofT (TOTok:TOTok a)  ++ ", " ++ typeofT (TOTok:TOTok b) ++ ")"
19 |     }
20 |     inst forall a. {Typeof a} => Typeof [a] {
21 |         def typeofT = const $ "[" ++ typeofT (TOTok:TOTok a) ++ "]"
22 |     }
23 |     inst Typeof String { def typeofT = const "String" }
24 | 
25 | }
26 | 
27 | def main
28 |     =  putStrLn (Typeof.typeof 1)
29 |     >> putStrLn (Typeof.typeof 1.1)
30 |     >> putStrLn (Typeof.typeof ())
31 |     >> putStrLn (Typeof.typeof True)
32 |     >> putStrLn (Typeof.typeof 'a')
33 |     >> putStrLn (Typeof.typeof (1, 1.1))
34 |     >> putStrLn (Typeof.typeof [0])
35 |     >> putStrLn (Typeof.typeof "ciao")
36 |     >> putStrLn (Typeof.typeof $ List.tail [(1,())])
37 | 


--------------------------------------------------------------------------------
/examples/weird_syntax.spk:
--------------------------------------------------------------------------------
 1 | use Std
 2 | 
 3 | def minus_six : Int = (-6)
 4 | def six_sub : Int -> Int = (6 -)
 5 | def sub_six : Int -> Int = (- 6)
 6 | 
 7 | def range : [Int] = (-6..10)
 8 | def weird_pat : Int -> Int -> Int =
 9 |     let (!-!) = (-) -> (!-!)
10 | def minus_pat = let (-5) = -5 -> ()
11 | 
12 | def diff_range : [Int] =
13 |     map sub_six range
14 | 
15 | def main = print minus_six >> print diff_range
16 | 


--------------------------------------------------------------------------------
/examples/zip.spk:
--------------------------------------------------------------------------------
1 | use Std
2 | use List
3 | 
4 | def main = let list = [0, 123, 13, 5, 523] ->
5 |     map2 (+) (0..length list) list
6 | 


--------------------------------------------------------------------------------
/runtests.sh:
--------------------------------------------------------------------------------
 1 | #!/bin/sh
 2 | backend="scm"
 3 | interpreter="gambitc -i"
 4 | 
 5 | out_file="out.$backend"
 6 | timings_file=$(mktemp)
 7 | 
 8 | for file in examples/*.spk
 9 | do
10 |     echo "########### Running test: $file"
11 |     cabal run spinnaker -- --file $file --verbose --backend=$backend | awk '/Unoptimized program size:/,0'
12 |     echo "----"
13 |     { time $(echo $interpreter $out_file); } 2>> $timings_file
14 |     echo "###########"
15 |     echo ""
16 | done
17 | echo "Tests complete. Total time spent in execution: "
18 | awk -F'[ms]' '/real/ {print $2}' $timings_file | awk 'gsub(/,/,".") {sum += $0} END {print sum}'
19 | rm $timings_file
20 | rm $out_file
21 | 


--------------------------------------------------------------------------------
/runtime/js/spinnaker.js:
--------------------------------------------------------------------------------
  1 | class RealWorld_ { constructor(){} }
  2 | class Tup0 { constructor(){} }
  3 | class Tup2 {
  4 |     constructor(x0, x1) {
  5 |         this[0] = x0;
  6 |         this[1] = x1;
  7 |     }
  8 | }
  9 | class Tup3 {
 10 |     constructor(x0, x1, x2) {
 11 |         this[0] = x0;
 12 |         this[1] = x1;
 13 |         this[2] = x2;
 14 |     }
 15 | }
 16 | class Tup4 {
 17 |     constructor(x0, x1, x2, x3) {
 18 |         this[0] = x0;
 19 |         this[1] = x1;
 20 |         this[2] = x2;
 21 |         this[3] = x3;
 22 |     }
 23 | }
 24 | 
 25 | function spinnaker_addInt(a, b) {
 26 |     return a + b;
 27 | }
 28 | function spinnaker_subInt(a, b) {
 29 |     return a - b;
 30 | }
 31 | function spinnaker_mulInt(a, b) {
 32 |     return a * b;
 33 | }
 34 | function spinnaker_divInt(a, b) {
 35 |     return Math.trunc(a / b); //TODO euclidean division
 36 | }
 37 | function spinnaker_remInt(a, b) {
 38 |     return a % b;
 39 | }
 40 | function spinnaker_equInt (a, b) {
 41 |     return a === b;
 42 | }
 43 | function spinnaker_neqInt (a, b) {
 44 |     return a !== b;
 45 | }
 46 | function spinnaker_leqInt (a, b) {
 47 |     return a <= b;
 48 | }
 49 | function spinnaker_greInt (a, b) {
 50 |     return a > b;
 51 | }
 52 | 
 53 | function spinnaker_addFlt(a, b) {
 54 |     return a + b;
 55 | }
 56 | function spinnaker_subFlt(a, b) {
 57 |     return a - b;
 58 | }
 59 | function spinnaker_mulFlt(a, b) {
 60 |     return a * b;
 61 | }
 62 | function spinnaker_divFlt(a, b) {
 63 |     return a / b;
 64 | }
 65 | function spinnaker_equFlt (a, b) {
 66 |     return a === b;
 67 | }
 68 | function spinnaker_neqFlt (a, b) {
 69 |     return a !== b;
 70 | }
 71 | function spinnaker_leqFlt (a, b) {
 72 |     return a <= b;
 73 | }
 74 | function spinnaker_greFlt (a, b) {
 75 |     return a > b;
 76 | }
 77 | 
 78 | function spinnaker_andBool (a, b) {
 79 |     return a && b;
 80 | }
 81 | function spinnaker_orBool (a, b) {
 82 |     return a || b;
 83 | }
 84 | function spinnaker_notBool (a) {
 85 |     return !a;
 86 | }
 87 | 
 88 | function spinnaker_floorFlt(a) {
 89 |     return Math.floor(a);
 90 | }
 91 | function spinnaker_convItoF(a) {
 92 |     return a;
 93 | }
 94 | 
 95 | function spinnaker_convItoC(a) {
 96 |     return String.fromCharCode(a);
 97 | }
 98 | function spinnaker_convCtoI(a) {
 99 |     return a.charCodeAt();
100 | }
101 | 
102 | let chrbuffer = ""
103 | function spinnaker_putChr(c,rw) {
104 |     chrbuffer = chrbuffer + c;
105 |     if (c === '\n') {
106 |         process.stdout.write(chrbuffer);
107 |         chrbuffer = "";
108 |     }
109 |     return rw;
110 | }
111 | 
112 | let fs = require("fs");
113 | function spinnaker_getChr(rw) {
114 |     process.stdout.write(chrbuffer);
115 |     chrbuffer = "";
116 |     let buffer = Buffer.alloc(4);
117 |     fs.readSync(0,buffer,0,1,null);
118 |     let fst = buffer[0];
119 |     if (fst < 0xe0) {
120 |         if(fst > 0x7F) {
121 |             fs.readSync(0,buffer,1,1,null);
122 |         }
123 |     } else if (fst < 0xf0) {
124 |         fs.readSync(0,buffer,1,2,null);
125 |     } else {
126 |         fs.readSync(0,buffer,1,3,null);
127 |     }
128 |     let string = buffer.toString('utf8');
129 |     return new Tup2(string.substr(0,string.indexOf('\0')), rw);
130 | }
131 | 
132 | //TODO spinnaker_putChr serio, spinnaker_getChr serio, spinnaker_isEOF
133 | function spinnaker_exit(i, rw) {
134 |     process.exit(i);
135 |     return rw;
136 | }
137 | 


--------------------------------------------------------------------------------
/runtime/scm/spinnaker.scm:
--------------------------------------------------------------------------------
 1 | (define-macro (spinnaker_comp_chrLit x) (integer->char x))
 2 | 
 3 | (define-syntax spinnaker_addInt (syntax-rules () ((_ a b)
 4 |     (+ a b))))
 5 | (define-syntax spinnaker_subInt (syntax-rules () ((_ a b)
 6 |     (- a b))))
 7 | (define-syntax spinnaker_mulInt (syntax-rules () ((_ a b)
 8 |     (* a b))))
 9 | (define-syntax spinnaker_divInt (syntax-rules () ((_ a b)
10 |     (quotient a b))))
11 | (define-syntax spinnaker_remInt (syntax-rules () ((_ a b)
12 |     (remainder a b))))
13 | (define-syntax spinnaker_equInt (syntax-rules () ((_ a b)
14 |     (= a b))))
15 | (define-syntax spinnaker_neqInt (syntax-rules () ((_ a b)
16 |     (not (= a b)))))
17 | (define-syntax spinnaker_leqInt (syntax-rules () ((_ a b)
18 |     (<= a b))))
19 | (define-syntax spinnaker_greInt (syntax-rules () ((_ a b)
20 |     (> a b))))
21 | 
22 | (define-syntax spinnaker_addFlt (syntax-rules () ((_ a b)
23 |     (+ a b))))
24 | (define-syntax spinnaker_subFlt (syntax-rules () ((_ a b)
25 |     (- a b))))
26 | (define-syntax spinnaker_mulFlt (syntax-rules () ((_ a b)
27 |     (* a b))))
28 | (define-syntax spinnaker_divFlt (syntax-rules () ((_ a b)
29 |     (/ a b))))
30 | (define-syntax spinnaker_equFlt (syntax-rules () ((_ a b)
31 |     (= a b))))
32 | (define-syntax spinnaker_neqFlt (syntax-rules () ((_ a b)
33 |     (not (= a b)))))
34 | (define-syntax spinnaker_leqFlt (syntax-rules () ((_ a b)
35 |     (<= a b))))
36 | (define-syntax spinnaker_greFlt (syntax-rules () ((_ a b)
37 |     (> a b))))
38 | 
39 | (define-syntax spinnaker_andBool (syntax-rules () ((_ a b)
40 |     (and a b))))
41 | (define-syntax spinnaker_orBool (syntax-rules () ((_ a b)
42 |     (or a b))))
43 | (define-syntax spinnaker_notBool (syntax-rules () ((_ a)
44 |     (not a))))
45 | 
46 | (define-syntax spinnaker_floorFlt (syntax-rules () ((_ a)
47 |     (inexact->exact (floor a)))))
48 | (define-syntax spinnaker_convItoF (syntax-rules () ((_ a)
49 |     (exact->inexact a))))
50 | 
51 | (define-syntax spinnaker_convItoC (syntax-rules () ((_ a)
52 |     (integer->char a))))
53 | (define-syntax spinnaker_convCtoI (syntax-rules () ((_ a)
54 |     (char->integer a))))
55 | 
56 | (define (spinnaker_putChr c rw)
57 |     (write-char c)
58 |     rw)
59 | (define (spinnaker_getChr rw)
60 |     (list "(,)" (read-char) rw))
61 | 
62 | (define (spinnaker_exit i rw)
63 |     (exit i)
64 |     rw)
65 | 


--------------------------------------------------------------------------------
/spinnaker.cabal:
--------------------------------------------------------------------------------
 1 | cabal-version: 3.0
 2 | name:          spinnaker
 3 | version:       0.1.0.0
 4 | 
 5 | -- A short (one-line) description of the package.
 6 | synopsis:      The Spinnaker Programming Language
 7 | 
 8 | -- A longer description of the package.
 9 | description:   TODO
10 | 
11 | -- A URL where users can report bugs.
12 | -- bug-reports:
13 | 
14 | -- The license under which the package is released.
15 | -- license:
16 | author:        Caius Iulius Caesar
17 | maintainer:    caiusiuliuscaesar84@gmail.com
18 | 
19 | -- A copyright notice.
20 | -- copyright:
21 | category:      Language
22 | build-type:    Simple
23 | -- extra-sources: CHANGELOG.md
24 | 
25 | data-files:    runtime/ stdlib/
26 | 
27 | common warnings
28 |     ghc-options: -Wall -Wno-incomplete-patterns -Wno-incomplete-uni-patterns -Wno-type-defaults -Wno-unused-do-bind -Wno-unused-matches
29 | 
30 | executable spinnaker
31 |     import:           warnings
32 | 
33 |     main-is:          Main.hs
34 | 
35 |     -- Modules included in this executable, other than Main.
36 |     other-modules:
37 |         Paths_spinnaker
38 |         CompDefs
39 |         ArgParser
40 |         ResultT
41 |         PrettyPrinter
42 | 
43 |         Parser.MPCL
44 |         SyntaxDefs
45 |         Parser.Parser
46 |         Parser.Demod
47 | 
48 |         HLDefs
49 |         HL.HLOps
50 |         Typer.TypingDefs
51 |         Typer.MGUs
52 |         Typer.KindTyper
53 |         Typer.VariantComplete
54 |         Typer.TypeTyper
55 |         Typer.Typer
56 | 
57 |         HL.Monomorphizer
58 |         HL.HLOptimize
59 |         HL.Defunctionalize
60 | 
61 |         MLDefs
62 |         ML.MLOps
63 |         ML.HLtoML
64 |         ML.MLOptimize
65 | 
66 |         --Backends.VM.MLtoVM
67 |         --Backends.VM.VM
68 |         Backends.MLtoJS
69 |         Backends.MLtoSCM
70 |     -- LANGUAGE extensions used by modules in this package.
71 |     -- other-extensions:
72 |     build-depends:    base ^>=4.18.0.0, mtl, containers
73 |     hs-source-dirs:   src
74 |     default-language: Haskell2010
75 | 


--------------------------------------------------------------------------------
/src/ArgParser.hs:
--------------------------------------------------------------------------------
 1 | module ArgParser where
 2 | import Control.Monad(join)
 3 | import Data.List(intercalate, transpose, partition)
 4 | import Data.Maybe(fromJust, isJust, catMaybes)
 5 | import System.Environment
 6 | 
 7 | data Arg =
 8 |     Arg {
 9 |         argID    :: String,
10 |         argShort :: Maybe Char,
11 |         argLong  :: Maybe String,
12 |         argIsOpt :: Bool,
13 |         argData  :: Maybe ArgData,
14 |         argDesc  :: String
15 |     }
16 | 
17 | data ArgData
18 |     = ArgDataStr (Maybe String)
19 |     | ArgDataOpt [String] (Maybe String)
20 |     -- | ArgDataInt (Maybe Int)
21 |     -- | ArgDataFlt (Maybe Float)
22 | 
23 | showDefault :: (a -> String) -> Maybe a -> String
24 | showDefault _ Nothing = ""
25 | showDefault f (Just d) = " (default=" ++ f d ++ ")"
26 | 
27 | showArgData :: ArgData -> String
28 | showArgData (ArgDataStr s) = "<string>" ++ showDefault id s
29 | showArgData (ArgDataOpt opts s) = intercalate "|" opts ++ showDefault id s
30 | --showArgData (ArgDataInt s) = "<int>" ++ showDefault show s
31 | --showArgData (ArgDataFlt s) = "<flt>" ++ showDefault show s
32 | 
33 | getHelpColumns :: Arg -> [String]
34 | getHelpColumns arg = [maybe "" (('-':) . (:[])) (argShort arg), maybe "" ("--"++) (argLong arg), if argIsOpt arg then "[opt]" else "", maybe "" showArgData (argData arg), argDesc arg]
35 | 
36 | showHelp :: [Arg] -> String
37 | showHelp args =
38 |     let aass = map getHelpColumns args
39 |         maxlens = map (maximum . map length) $ transpose aass
40 |         pad len s = s ++ replicate (len - length s) ' '
41 |         aasspadded = map (zipWith pad maxlens) aass
42 |     in unlines $ map (intercalate "  ") aasspadded
43 | 
44 | type Parse = [(String, Maybe String)]
45 | parseArgs :: [Arg] -> [String] -> Either String Parse
46 | parseArgs = inner []
47 |   where inner :: Parse -> [Arg] -> [String] -> Either String Parse
48 |         inner parse defs [] = do
49 |             defaults <- checkRemaining defs
50 |             return $ catMaybes defaults ++ parse
51 |         inner parse defs (arg:args) = do
52 |             let argname = takeWhile ('='/=) arg
53 |                 eqargstring = dropWhile ('='/=) arg
54 |                 margstring = if null eqargstring then Nothing else Just (tail eqargstring)
55 |             (def, defs') <- getDef argname defs
56 |             case (argData def, margstring) of
57 |                 (Nothing, Nothing) -> inner ((argID def, Nothing):parse) defs' args
58 |                 (Just argdata, Just argstring) -> checkData argdata argstring >> inner ((argID def, Just argstring):parse) defs' args
59 |                 (Nothing, Just _) -> Left $ "unexpected data after the argument: " ++ argID def
60 |                 (Just argdata, Nothing) -> case args of
61 |                                     [] -> Left $ "expected some data after the argument: " ++ argID def
62 |                                     a:args' -> checkData argdata a >> inner ((argID def, Just a):parse) defs' args'
63 |         getDef arg defs =
64 |             case partition (\def -> elem arg $ catMaybes [('-':).(:[]) <$> argShort def, ("--"++) <$> argLong def]) defs of
65 |                 ([], _) -> Left $ "unrecognized argument: " ++ arg
66 |                 ([def], defs') -> return (def, defs')
67 |         checkData (ArgDataStr _) _ = return ()
68 |         checkData (ArgDataOpt opts _) d = if elem d opts then return () else Left $ d ++ " is not a valid option (" ++ intercalate "|" opts ++ ")"
69 |         checkRemaining = mapM (\arg ->
70 |                     case argData arg of
71 |                         Just (ArgDataStr (Just def)) -> return $ Just (argID arg, Just def)
72 |                         Just (ArgDataOpt _ (Just def)) -> return $ Just (argID arg, Just def)
73 |                         _ -> if argIsOpt arg then return Nothing else Left $ "expected non-optional argument: " ++ argID arg
74 |                 )
75 | 
76 | parseArgsIO :: [Arg] -> IO Parse
77 | parseArgsIO defs = do
78 |     args <- getArgs
79 |     case parseArgs defs args of
80 |         Left e -> error e
81 |         Right p -> return p
82 | 
83 | gotArg :: String -> Parse -> Bool
84 | gotArg = (isJust .) . lookup
85 | getArg :: String -> Parse -> Maybe String
86 | getArg = (join .) . lookup
87 | forceGetArg :: String -> Parse -> String
88 | forceGetArg = (fromJust .) . getArg
89 | 


--------------------------------------------------------------------------------
/src/Backends/MLtoJS.hs:
--------------------------------------------------------------------------------
  1 | module Backends.MLtoJS where
  2 | import GHC.Unicode(isPrint, isSpace)
  3 | import Control.Monad.State
  4 | import Data.Maybe(fromJust, fromMaybe)
  5 | import HLDefs
  6 | import MLDefs
  7 | import ML.MLOps
  8 | import Typer.TypingDefs(isTupLabl)
  9 | 
 10 | type IdentMap = [(String, String)]
 11 | type CodeGen a = State (Int, IdentMap, IdentMap, IdentMap, [String]) a
 12 | 
 13 | emit :: String -> CodeGen ()
 14 | emit code' = do
 15 |     (uid, var, comb, lab, code) <- get
 16 |     put (uid, var, comb, lab, code':code)
 17 | 
 18 | getVariant :: String -> CodeGen String
 19 | getVariant v = let (istup, n) = isTupLabl v in
 20 |     if istup then return $ "Tup"++show n
 21 |     else do
 22 |     (_, var, _, _, _) <- get
 23 |     return $ fromMaybe v (lookup v var) -- se non si trova una variante significa che è una classe esterna, perciò il nome resta invariato
 24 | 
 25 | getCombinator :: String -> CodeGen String
 26 | getCombinator c = do
 27 |     (_, _, comb, _, _) <- get
 28 |     return $ fromMaybe c (lookup c comb) -- se non si trova un combinatore significa che è una funzione esterna, perciò il nome resta invariato
 29 | 
 30 | getLabel :: String -> CodeGen String
 31 | getLabel l = do
 32 |     (_, _, _, lab, _) <- get
 33 |     return $ fromJust $ lookup l lab
 34 | 
 35 | newLabel :: CodeGen String
 36 | newLabel = do
 37 |     (uid, var, comb, lab, code) <- get
 38 |     put (uid+1, var, comb, lab, code)
 39 |     return ("label"++show uid)
 40 | 
 41 | newMapVariant :: String -> CodeGen String
 42 | newMapVariant v = do
 43 |     (uid, var, comb, lab, code) <- get
 44 |     put (uid+1, (v, "Variant"++show uid):var, comb, lab, code)
 45 |     return ("Variant"++show uid)
 46 | 
 47 | newMapCombinator :: String -> CodeGen String
 48 | newMapCombinator c = do
 49 |     (uid, var, comb, lab, code) <- get
 50 |     put (uid+1, var, (c, "combinator"++show uid):comb, lab, code)
 51 |     return ("combinator"++show uid)
 52 | 
 53 | newMapLabel :: String -> CodeGen String
 54 | newMapLabel l = do
 55 |     (uid, var, comb, lab, code) <- get
 56 |     put (uid+1, var, comb, (l,"label"++show uid):lab, code)
 57 |     return ("label"++show uid)
 58 | 
 59 | toCommaList :: [String] -> String
 60 | toCommaList [] = ""
 61 | toCommaList [x] = x
 62 | toCommaList (x:xs) = x ++ ", " ++ toCommaList xs
 63 | 
 64 | tojsLit :: Literal -> String
 65 | tojsLit (LitInteger i) = show i
 66 | tojsLit (LitFloating f) = show f
 67 | tojsLit (LitCharacter c)
 68 |     | isSpace c || elem c "\\\"\'" = show c
 69 |     | isPrint c = ['\"', c, '\"']
 70 |     | otherwise = show c
 71 | 
 72 | emitTest :: String -> MLPattern -> CodeGen ()
 73 | emitTest l (MLPLiteral lit) = emit $ "if(" ++ l ++ " === " ++ tojsLit lit ++ "){\n"
 74 | emitTest l (MLPVariant "True") = emit $ "if(" ++ l ++ "){\n"
 75 | emitTest l (MLPVariant "False") = emit $ "if(!" ++ l ++ "){\n"
 76 | emitTest l (MLPVariant v) = do
 77 |     v' <- getVariant v
 78 |     emit $ "if(" ++ l ++ " instanceof " ++ v' ++ "){\n"
 79 | 
 80 | tojsBlock :: (String -> String) -> MLExpr -> CodeGen ()
 81 | tojsBlock final (_, _, MLLet l e0 e1) = do
 82 |     l' <- newMapLabel l
 83 |     e0' <- tojsExpr e0
 84 |     emit $ "let " ++ l' ++ " = " ++ e0' ++ ";\n"
 85 |     tojsBlock final e1
 86 | tojsBlock final (_, _, MLTest tv pes def) = do
 87 |     tv' <- tojsExpr tv
 88 |     l' <- newLabel
 89 |     emit $ "let " ++ l' ++ " = " ++ tv' ++ ";\n"
 90 |     mapM_ (\(p, e) -> do
 91 |         emitTest l' p
 92 |         tojsBlock final e
 93 |         emit "} else ") pes
 94 |     emit "{\n"
 95 |     tojsBlock final def
 96 |     emit "}\n"
 97 | tojsBlock final (_, _, MLError c s) = emit $ "throw new Error(" ++ show(show c ++ s) ++ ");\n"
 98 | tojsBlock final other = do
 99 |     expr <- tojsExpr other
100 |     emit $ final expr
101 | 
102 | tojsExpr :: MLExpr -> CodeGen String
103 | tojsExpr (_, _, MLLiteral lit) = return $ tojsLit lit
104 | tojsExpr (_, _, MLLabel l) = getLabel l
105 | tojsExpr (_, _, MLConstructor "True" []) = return "true"
106 | tojsExpr (_, _, MLConstructor "False" []) = return "false"
107 | tojsExpr (_, _, MLProj e _ n) = do
108 |     e' <- tojsExpr e
109 |     return $ "(" ++ e' ++ ")[" ++ show n ++ "]"
110 | tojsExpr (_, _, MLConstructor v es) = do
111 |     v' <- getVariant v
112 |     es' <- mapM tojsExpr es
113 |     return $ "new " ++ v' ++ "(" ++ toCommaList es' ++ ")"
114 | tojsExpr (_, _, MLCombinator c es) = do
115 |     c' <- getCombinator c
116 |     es' <- mapM tojsExpr es
117 |     return $ c' ++ "(" ++ toCommaList es' ++ ")"
118 | tojsExpr (_, _, MLJoin j es) = do
119 |     j' <- getLabel j
120 |     es' <- mapM tojsExpr es
121 |     return $ j' ++ "(" ++ toCommaList es' ++ ")"
122 | tojsExpr (_, _, MLLet l e0 e1) = do
123 |     l' <- newMapLabel l
124 |     e0' <- tojsExpr e0
125 |     emit $ "let " ++ l' ++ " = " ++ e0' ++ ";\n"
126 |     tojsExpr e1
127 | tojsExpr (_, _, MLLetJoin j lvs e0 e1) = do
128 |     j' <- newMapLabel j
129 |     as <- mapM (newMapLabel . fst) lvs
130 |     emit $ "let " ++ j' ++ " = function(" ++ toCommaList as ++ "){\n"
131 |     tojsBlock (\e' -> "return " ++ e' ++ ";\n") e0
132 |     emit "};\n"
133 |     tojsExpr e1
134 | tojsExpr other = do
135 |     l <- newLabel
136 |     emit $ "let " ++ l ++ ";\n"
137 |     tojsBlock (\e -> l ++ " = " ++ e ++ ";\n") other
138 |     return l
139 | 
140 | tojsVariant :: [String] -> String -> Int -> CodeGen ()
141 | tojsVariant vused vname numargs =
142 |     if not (elem vname vused) then return ()
143 |     else do
144 |         vname' <- newMapVariant vname
145 |         let args = map (("x"++) . show) [0..numargs-1]
146 |         emit $ "class " ++ vname' ++ "{\nconstructor(" ++ toCommaList args ++ "){\n"
147 |         mapM_ (\(n, arg) -> emit $ "this["++show n++"] = " ++ arg ++ ";\n"
148 |                 ) $ zip [0..] args
149 |         emit "}\n}\n\n"
150 | 
151 | tojsDataSummaries :: [String] -> [DataSummary] -> CodeGen ()
152 | tojsDataSummaries vused summaries =
153 |     let stripped = do
154 |             (_, variants) <- summaries
155 |             map (\(vname, args) -> (vname, length args)) variants
156 |     in mapM_ (uncurry $ tojsVariant vused) stripped
157 | 
158 | tojsCombinators :: [MLDef] -> CodeGen ()
159 | tojsCombinators combs = do
160 |     mapM_ (\(c, _, _) -> newMapCombinator c) combs
161 |     mapM_ (\(c, asts, e) -> do
162 |             c' <- getCombinator c
163 |             as <- mapM (newMapLabel . fst) asts
164 |             emit $ "function " ++ c' ++ "(" ++ toCommaList as ++ "){\n"
165 |             tojsBlock (\e' -> "return " ++ e' ++ ";\n") e
166 |             emit "}\n\n"
167 |             ) combs
168 | 
169 | tojsProgram :: [DataSummary] -> MLProgram -> String
170 | tojsProgram datasummaries (ep, defs) = concat $ reverse $ (\(_,(_,_,_,_,code))->code) $ flip runState (0, [], [], [], []) $ do
171 |     let vused = variantsUsedProg (ep, defs)
172 |     tojsDataSummaries vused datasummaries
173 |     tojsCombinators defs
174 |     tojsBlock (++ ";\n") ep
175 | 


--------------------------------------------------------------------------------
/src/Backends/MLtoSCM.hs:
--------------------------------------------------------------------------------
  1 | module Backends.MLtoSCM where
  2 | import Control.Monad.State
  3 | import Data.Maybe(fromJust, fromMaybe)
  4 | import Data.Char(ord)
  5 | import HLDefs
  6 | import MLDefs
  7 | import ML.MLOps
  8 | 
  9 | type IdentMap = [(String, String)]
 10 | type CodeGen a = State (Int, IdentMap, IdentMap, IdentMap, [String]) a
 11 | 
 12 | emit :: String -> CodeGen ()
 13 | emit code' = do
 14 |     (uid, var, comb, lab, code) <- get
 15 |     put (uid, var, comb, lab, code':code)
 16 | 
 17 | getVariant :: String -> CodeGen String
 18 | getVariant v = do
 19 |     (_, var, _, _, _) <- get
 20 |     return $ fromMaybe (show v) (lookup v var) -- se non si trova una variante significa che è una classe esterna, perciò il nome resta invariato
 21 | 
 22 | getCombinator :: String -> CodeGen String
 23 | getCombinator c = do
 24 |     (_, _, comb, _, _) <- get
 25 |     return $ fromMaybe c (lookup c comb) -- se non si trova un combinatore significa che è una funzione esterna, perciò il nome resta invariato
 26 | 
 27 | getLabel :: String -> CodeGen String
 28 | getLabel l = do
 29 |     (_, _, _, lab, _) <- get
 30 |     return $ fromJust $ lookup l lab
 31 | 
 32 | newLabel :: CodeGen String
 33 | newLabel = do
 34 |     (uid, var, comb, lab, code) <- get
 35 |     put (uid+1, var, comb, lab, code)
 36 |     return ("label"++show uid)
 37 | 
 38 | newMapVariant :: String -> CodeGen String
 39 | newMapVariant v = do
 40 |     (uid, var, comb, lab, code) <- get
 41 |     put (uid+1, (v, show $ show uid):var, comb, lab, code)
 42 |     return (show $ show uid)
 43 | 
 44 | newMapCombinator :: String -> CodeGen String
 45 | newMapCombinator c = do
 46 |     (uid, var, comb, lab, code) <- get
 47 |     put (uid+1, var, (c, "combinator"++show uid):comb, lab, code)
 48 |     return ("combinator"++show uid)
 49 | 
 50 | newMapLabel :: String -> CodeGen String
 51 | newMapLabel l = do
 52 |     (uid, var, comb, lab, code) <- get
 53 |     put (uid+1, var, comb, (l,"label"++show uid):lab, code)
 54 |     return ("label"++show uid)
 55 | 
 56 | toscmLit :: Literal -> String
 57 | toscmLit (LitInteger i) = show i
 58 | toscmLit (LitFloating f) = show f
 59 | toscmLit (LitCharacter c) = "(spinnaker_comp_chrLit " ++ show (ord c) ++ ")"
 60 | 
 61 | variantAccess :: Int -> String -> String
 62 | variantAccess n l = "(cadr" ++ cdrs n l ++ ")"
 63 |     where
 64 |         cdrs 0 myl = ' ':myl
 65 |         cdrs myn myl = "(cdr" ++ cdrs (myn - 1) myl ++ ")"
 66 | 
 67 | genTest :: String -> MLPattern -> CodeGen String
 68 | genTest l (MLPLiteral lit@(LitCharacter _)) = return $ "((char=? " ++ l ++ " " ++ toscmLit lit ++ ")"
 69 | genTest l (MLPLiteral lit) = return $ "((= " ++ l ++ " " ++ toscmLit lit ++ ")"
 70 | genTest l (MLPVariant "True") = return $ "(" ++ l ++ " "
 71 | genTest l (MLPVariant "False") = return $ "((not " ++ l ++ ") "
 72 | genTest l (MLPVariant v) = do
 73 |     v' <- getVariant v
 74 |     return $ "((string=? (car " ++ l ++ ") " ++ v' ++ ") "
 75 | 
 76 | toscmExpr :: MLExpr -> CodeGen String
 77 | toscmExpr (_, _, MLTest tv pes def) = do
 78 |     tv' <- toscmExpr tv
 79 |     l' <- newLabel
 80 |     conds <- mapM (\(p, e) -> do
 81 |         test <- genTest l' p
 82 |         e' <- toscmExpr e
 83 |         return $ test ++ e' ++ ")\n") pes
 84 |     def' <- toscmExpr def
 85 |     return $ "(let ((" ++ l' ++ " " ++ tv' ++ "))" ++ "(cond " ++ concat conds ++ "(#t " ++ def' ++ "))" ++ ")"
 86 | toscmExpr (_, _, MLError c s) = return $ "(error " ++ show(show c ++ s) ++ ")"
 87 | toscmExpr (_, _, MLProj e _ n) = do
 88 |     e' <- toscmExpr e
 89 |     return (variantAccess n e')
 90 | toscmExpr (_, _, MLLiteral lit) = return $ toscmLit lit
 91 | toscmExpr (_, _, MLLabel l) = getLabel l
 92 | toscmExpr (_, _, MLConstructor "True" []) = return "#t"
 93 | toscmExpr (_, _, MLConstructor "False" []) = return "#f"
 94 | toscmExpr (_, _, MLConstructor v es) = do
 95 |     v' <- getVariant v
 96 |     es' <- mapM toscmExpr es
 97 |     return $ "(list " ++ unwords (v' : es') ++ ")" --TODO interleave/intersperse
 98 | toscmExpr (_, _, MLCombinator c es) = do
 99 |     c' <- getCombinator c
100 |     es' <- mapM toscmExpr es
101 |     return $ "(" ++ unwords (c' : es') ++ ")"
102 | toscmExpr (_, _, MLJoin j es) = do
103 |     j' <- getLabel j
104 |     es' <- mapM toscmExpr es
105 |     return $ "(" ++ unwords (j' : es') ++ ")"
106 | toscmExpr (_, _, MLLet l e0 e1) = do
107 |     l' <- newMapLabel l
108 |     e0' <- toscmExpr e0
109 |     e1' <- toscmExpr e1
110 |     return $ "(let ((" ++ l' ++ " " ++ e0' ++ "))\n" ++ e1' ++ ")"
111 | toscmExpr (_, _, MLLetJoin j lts e0 e1) = do
112 |     j' <- newMapLabel j
113 |     e1' <- toscmExpr e1
114 |     as <- mapM (newMapLabel . fst) lts
115 |     e0' <- toscmExpr e0
116 |     return $ "(let ((" ++ j' ++ " (lambda (" ++ unwords as ++ ") " ++ e0' ++ ")))\n" ++ e1' ++ ")"
117 |     
118 | 
119 | toscmVariant :: [String] -> String -> Int -> CodeGen ()
120 | toscmVariant vused vname numargs =
121 |     if elem vname vused then const () <$> newMapVariant vname
122 |     else return ()
123 | 
124 | toscmDataSummaries :: [String] -> [DataSummary] -> CodeGen ()
125 | toscmDataSummaries vused summaries =
126 |     let stripped = do
127 |             (_, variants) <- summaries
128 |             map (\(vname, args) -> (vname, length args)) variants
129 |     in mapM_ (uncurry $ toscmVariant vused) stripped
130 | 
131 | toscmCombinators :: [MLDef] -> CodeGen ()
132 | toscmCombinators combs = do
133 |     mapM_ (\(c, _, _) -> newMapCombinator c) combs
134 |     mapM_ (\(c, asts, e) -> do
135 |             c' <- getCombinator c
136 |             as <- mapM (newMapLabel . fst) asts
137 |             let define = "(define (" ++ unwords (c':as) ++ ")\n"
138 |             body <- toscmExpr e
139 |             emit $ define ++ body ++ ")\n\n"
140 |             ) combs
141 | 
142 | toscmProgram :: [DataSummary] -> MLProgram -> String
143 | toscmProgram datasummaries (ep, defs) = concat $ reverse $ (\(_,(_,_,_,_,code))->code) $ flip runState (0, [], [], [], []) $ do
144 |     let vused = variantsUsedProg (ep, defs)
145 |     toscmDataSummaries vused datasummaries
146 |     toscmCombinators defs
147 |     ep' <- toscmExpr ep
148 |     emit ep'
149 | 


--------------------------------------------------------------------------------
/src/CompDefs.hs:
--------------------------------------------------------------------------------
 1 | module CompDefs where
 2 | import Control.Monad.Reader
 3 | import System.CPUTime
 4 | import ArgParser
 5 | 
 6 | data CompState = CompState {
 7 |     dataDir :: String,
 8 |     argOptions :: Parse
 9 |     }
10 | 
11 | type CompMon = ReaderT CompState IO
12 | 
13 | runCompMon :: CompState -> CompMon a -> IO a
14 | runCompMon = flip runReaderT
15 | 
16 | getDataDir :: CompMon String
17 | getDataDir = asks dataDir
18 | 
19 | getArgOptions :: CompMon Parse
20 | getArgOptions = asks argOptions
21 | 
22 | compLog :: String -> CompMon ()
23 | compLog l = do
24 |     opts <- getArgOptions
25 |     if gotArg "verbose" opts
26 |     then lift $ putStrLn l
27 |     else return ()
28 | 
29 | time :: CompMon t -> CompMon (t, Double)
30 | time a = do
31 |     start <- lift getCPUTime
32 |     v <- a
33 |     end <- lift getCPUTime
34 |     let diff = fromIntegral (end - start) / (10^9)
35 |     return (v, diff)
36 | 


--------------------------------------------------------------------------------
/src/HL/Defunctionalize.hs:
--------------------------------------------------------------------------------
  1 | module HL.Defunctionalize (defunProgram) where
  2 | import Control.Monad.State
  3 | import Data.List(nub)
  4 | 
  5 | import CompDefs
  6 | import HLDefs
  7 | import HL.HLOps
  8 | import Typer.TypingDefs
  9 | import Parser.MPCL(dummyStdCoord)
 10 | 
 11 | type ApplysEnv = [(DataType, (String, [(String, [(String, DataType)], String)]))]
 12 | type DefunEnv = (Int, [Combinator], ApplysEnv)
 13 | type DefunState t = StateT DefunEnv CompMon t
 14 | 
 15 | getUid :: DefunState String
 16 | getUid = do
 17 |     (u, cs, env) <- get
 18 |     put (u+1, cs, env)
 19 |     return ('#':show u)
 20 | 
 21 | getApply :: DataType -> DefunState String
 22 | getApply t = do
 23 |     (u, cs, env) <- get
 24 |     case lookup t env of
 25 |         Just (l, _) -> return l
 26 |         Nothing -> do
 27 |             s <- getUid
 28 |             let combl = "_apply" ++ s
 29 |             (u', _, _) <- get
 30 |             put (u', cs, (t, (combl, [])):env)
 31 |             return combl
 32 | addApply :: DataType -> [DataType] -> String -> DefunState String
 33 | addApply t freets cmb = do
 34 |     (u, cs, env) <- get
 35 |     ((combl, brs), aps) <-
 36 |         case lookup t env of
 37 |             Just dat -> return (dat, filter ((t /=) . fst) env)
 38 |             Nothing -> do
 39 |                 s <- getUid
 40 |                 let combl = "_apply" ++ s
 41 |                 return ((combl, []), env)
 42 |     sv <- getUid
 43 |     frees <- mapM (\ft -> fmap (\s -> ("_v" ++ s, ft)) getUid) freets
 44 |     let varl = "Closure_" ++ sv
 45 |         brs' = (varl, frees, cmb) : brs
 46 |     (u', _, _) <- get
 47 |     put (u', cs, (t, (combl, brs')) : aps)
 48 |     return varl
 49 | 
 50 | addComb :: Combinator -> DefunState ()
 51 | addComb cmb = do
 52 |     (u, cs, env) <- get
 53 |     put (u, cmb:cs, env)
 54 | newComb :: [(String, DataType)] -> HLExpr -> DefunState String
 55 | newComb as e = do
 56 |     s <- getUid
 57 |     let combl = "_comb" ++ s
 58 |     (u, cs, env) <- get
 59 |     put (u, (combl, False, as, e):cs, env)
 60 |     return combl
 61 | 
 62 | freeLabls :: HLExpr -> [(String, DataType)]
 63 | freeLabls (_, _, ExprLiteral _) = []
 64 | freeLabls (_, _, ExprApp f a) = nub $ freeLabls f ++ freeLabls a --TODO: le coppie labl, datatype sono sempre uguali?
 65 | freeLabls (_, t, ExprLabel l) = [(l, t)]
 66 | freeLabls (_, _, ExprConstructor l es) = nub $ es >>= freeLabls
 67 | freeLabls (_, _, ExprCombinator l es) = nub $ es >>= freeLabls
 68 | freeLabls (_, _, ExprLambda l e) = filter ((l /=) . fst) $ freeLabls e
 69 | freeLabls (_, _, ExprPut vs pses) =
 70 |     let lvss = map freeLabls vs
 71 |         lpses = map (\(ps, e) ->
 72 |             let le = freeLabls e
 73 |                 in filter (\l -> not $ any (appearsPat (fst l)) ps) le
 74 |             ) pses
 75 |     in nub $ concat $ lvss ++ lpses
 76 | freeLabls (_, _, ExprHint _ e) = freeLabls e
 77 | 
 78 | defunExpr :: HLExpr -> DefunState HLExpr
 79 | defunExpr e@(_, _, ExprLiteral _) = return e
 80 | defunExpr e@(_, _, ExprLabel _) = return e
 81 | defunExpr (c, t, ExprApp f@(_, tf, _) a) = do
 82 |     f' <- defunExpr f
 83 |     a' <- defunExpr a
 84 |     apl <- getApply tf
 85 |     return (c, t, ExprCombinator apl [f', a'])
 86 | defunExpr (c, t, ExprConstructor l es) = do
 87 |     es' <- mapM defunExpr es
 88 |     return (c, t, ExprConstructor l es')
 89 | defunExpr (c, t, ExprCombinator l es) = do
 90 |     es' <- mapM defunExpr es
 91 |     return (c, t, ExprCombinator l es')
 92 | defunExpr le@(c, t@(DataTypeApp (DataTypeApp _ at) _), ExprLambda l e) = do
 93 |     let frees = freeLabls le
 94 |     e' <- defunExpr e
 95 |     myc <- newComb (frees ++ [(l, at)]) e'
 96 |     myv <- addApply t (map snd frees) myc
 97 |     let freerefs = map (\(myl, myt) -> (c, myt, ExprLabel myl)) frees
 98 |     return (c, t, ExprConstructor myv freerefs)
 99 | defunExpr (c, t, ExprPut vs pses) = do
100 |     vs' <- mapM defunExpr vs
101 |     pses' <- mapM (\(ps, e) -> fmap (\e' -> (ps, e')) (defunExpr e)) pses
102 |     return (c, t, ExprPut vs' pses')
103 | defunExpr (_, _, ExprHint _ e) = defunExpr e
104 | 
105 | applysToComb :: DefunState ()
106 | applysToComb = do
107 |     (_, _, aps) <- get
108 |     acmbs <- mapM applyToComb aps
109 |     (n, cmbs, _) <- get
110 |     put (n, acmbs ++ cmbs, [])
111 |     where applyToComb (t@(DataTypeApp (DataTypeApp _ at) rt), (combl, vars)) = do
112 |             s <- getUid
113 |             let funl = "_fun" ++ s
114 |                 argl = "_arg" ++ s
115 |                 vartobranch (vname, ls, cmb) =
116 |                     ([(dummyStdCoord, t, Nothing, PatVariant vname (map (\(l,lt) -> (dummyStdCoord, lt, Just l, PatWildcard)) ls))],
117 |                         (dummyStdCoord, rt, ExprCombinator cmb (map (\(l, lt) -> (dummyStdCoord, lt, ExprLabel l)) (ls ++ [(argl, at)]))))
118 |             return (combl, True, [(funl, t), (argl, at)], (dummyStdCoord, rt, ExprPut [(dummyStdCoord, t, ExprLabel funl)] (map vartobranch vars)))
119 | 
120 | 
121 | applysToDataSummary :: ApplysEnv -> [DataSummary]
122 | applysToDataSummary = map summarizeApply
123 |     where summarizeApply (dt, (_, brs)) = (dt, map summarizeBranch brs)
124 |           summarizeBranch (varl, datalabs, _) = (varl, map snd datalabs)
125 | 
126 | defunProgram :: MonoProgram -> Int -> CompMon ([DataSummary], MonoProgram, Int)
127 | defunProgram (ep, defs) n = do
128 |     ((datasummary, ep'), (n', combs, _)) <- runStateT defunmon (n, [], [])
129 |     return (datasummary, (ep', combs), n')
130 |     where defunmon = do
131 |             ep' <- defunExpr ep
132 |             mapM_ (\(l, il, as, e) -> do
133 |                 e' <- defunExpr e
134 |                 addComb (l, il, as, e')
135 |                 ) defs
136 |             (_, _, aps) <- get
137 |             let datasummary = applysToDataSummary aps
138 |             applysToComb
139 |             return (datasummary, ep')
140 | 


--------------------------------------------------------------------------------
/src/HL/HLOps.hs:
--------------------------------------------------------------------------------
 1 | module HL.HLOps where
 2 | import Data.Maybe (isJust, maybeToList, fromMaybe)
 3 | import Typer.TypingDefs(DataType)
 4 | import HLDefs
 5 | 
 6 | 
 7 | patVarsInner PatWildcard = []
 8 | patVarsInner (PatLiteral _) = []
 9 | patVarsInner (PatVariant c ps) = ps >>= patVars
10 | 
11 | patVars :: HLPattern -> [(String, DataType)]
12 | patVars (_, _, Nothing, ip) = patVarsInner ip
13 | patVars (_, t, Just l, ip) = (l, t) : patVarsInner ip
14 | 
15 | appearsPat :: String -> HLPattern -> Bool
16 | appearsPat l pat = isJust $ lookup l (patVars pat)
17 | 
18 | appears :: String -> HLExpr -> Int
19 | appears _ (_, _, ExprLiteral _) = 0
20 | appears l (_, _, ExprApp f a) = appears l f + appears l a
21 | appears l (_, _, ExprLabel l') = if l == l' then 1 else 0
22 | appears l (_, _, ExprConstructor c es) = sum (map (appears l) es)
23 | appears l (_, _, ExprCombinator c es) = (if c == l then 1 else 0) + sum (map (appears l) es)
24 | appears l (_, _, ExprLambda l' e) = if l == l' then 0 else appears l e
25 | appears l (_, _, ExprPut vs pses) = sum (map (appears l) vs) +
26 |     sum (map (\(ps, e)->if any (appearsPat l) ps then 0 else appears l e) pses)
27 | 
28 | appearsDefs :: String -> [Combinator] -> Int
29 | appearsDefs l defs = sum $ map (\(_,_,as,e) -> if elem l (map fst as) then 0 else appears l e) defs
30 | 
31 | exprSize :: HLExpr -> Int
32 | exprSize (_, _, ExprLiteral _) = 1
33 | exprSize (_, _, ExprApp f a) = exprSize f + exprSize a --TODO: +1?
34 | exprSize (_, _, ExprLabel _) = 1
35 | exprSize (_, _, ExprConstructor _ es) = 1 + sum (map exprSize es)
36 | exprSize (_, _, ExprCombinator _ es) = 1 + sum (map exprSize es)
37 | exprSize (_, _, ExprLambda p e) = 1 + exprSize e --TODO patSize p?
38 | exprSize (_, _, ExprPut vs pses) = length pses + sum (map exprSize vs) + sum (map (exprSize . snd) pses) --TODO patsize pses?
39 | exprSize (_, _, ExprHint _ e) = exprSize e
40 | 
41 | programSize :: MonoProgram -> Int
42 | programSize (ep, defs) = exprSize ep + sum (map (exprSize . (\(_,_,_,a)->a)) defs)
43 | 
44 | inline :: [(String, HLExpr)] -> HLExpr -> HLExpr
45 | inline binds e@(_, _, ExprLiteral _) = e
46 | inline binds e@(c, _, ExprLabel l') = fromMaybe e (lookup l' binds)
47 | inline binds (c, t, ExprApp f a) = (c, t, ExprApp (inline binds f) (inline binds a))
48 | inline binds (c, t, ExprConstructor cn es) = (c, t, ExprConstructor cn (map (inline binds) es))
49 | inline binds (c, t, ExprCombinator cn es) = (c, t, ExprCombinator cn (map (inline binds) es))
50 | inline binds (c, t, ExprLambda l' le) =
51 |     let newbinds = filter ((l' /=) . fst) binds
52 |         in (c, t, ExprLambda l' (inline newbinds le))
53 | inline binds (c, t, ExprPut vs pses) = (c, t, ExprPut (map (inline binds) vs)
54 |     (map (\(p, e)->
55 |         --TODO: questo è un fix per evitare shadowing, significa che bisogna ristrutturare l'optimizer per creare nuove variabili uniche
56 |         let newbinds = filter (\(sl, _) -> not $ any (appearsPat sl) p) binds in
57 |             (p, inline newbinds e)) pses))
58 | 
59 | 


--------------------------------------------------------------------------------
/src/HL/HLOptimize.hs:
--------------------------------------------------------------------------------
  1 | module HL.HLOptimize where
  2 | import Data.Char (ord, chr)
  3 | import Data.List (sortBy)
  4 | 
  5 | import Parser.MPCL(StdCoord)
  6 | import HLDefs
  7 | import HL.HLOps
  8 | import Typer.TypingDefs
  9 | 
 10 | inlineHeuristic :: HLExpr -> Int -> Bool
 11 | inlineHeuristic e timesappears =
 12 |     let size = exprSize e
 13 |         addedSize = size*(timesappears - 1)
 14 |     in size < 8 || addedSize < size
 15 | 
 16 | isSimple :: HLExpr -> Bool
 17 | isSimple (_, _, ExprLiteral _) = True
 18 | isSimple (_, _, ExprLabel _) = True
 19 | isSimple (_, _, ExprConstructor _ es) = all isSimple es
 20 | isSimple (_, _, ExprLambda _ _) = True
 21 | isSimple (_, _, ExprHint _ e) = isSimple e
 22 | isSimple _ = False
 23 | 
 24 | inlineComb :: Combinator -> HLExpr -> HLExpr
 25 | inlineComb cmb e@(_, _, ExprLiteral _) = e
 26 | inlineComb cmb e@(_, _, ExprLabel l') = e
 27 | inlineComb cmb (c, t, ExprApp f a) = (c, t, ExprApp (inlineComb cmb f) (inlineComb cmb a))
 28 | inlineComb cmb (c, t, ExprConstructor cn es) = (c, t, ExprConstructor cn (map (inlineComb cmb) es))
 29 | inlineComb cmb@(cn, _, as, e) (c, t, ExprCombinator mcn es)
 30 |     | cn == mcn =
 31 |         let es' = map (inlineComb cmb) es
 32 |             binds = zip (map fst as) es'
 33 |             newe = inline binds e
 34 |         in newe
 35 |     | otherwise = (c, t, ExprCombinator mcn (map (inlineComb cmb) es))
 36 | inlineComb cmb e@(c, t, ExprLambda l' le) = (c, t, ExprLambda l' (inlineComb cmb le))
 37 | inlineComb cmb (c, t, ExprPut vs pses) = (c, t, ExprPut (map (inlineComb cmb) vs)
 38 |     (map (\(p, e)-> (p, inlineComb cmb e)) pses))
 39 | inlineComb cmb (_, _, ExprHint _ e) = inlineComb cmb e
 40 | 
 41 | inlineDefs :: Combinator -> [Combinator] -> [Combinator]
 42 | inlineDefs cmb [] = []
 43 | inlineDefs cmb ((ld, il, as, e):defs') = (ld, il, as, inlineComb cmb e):inlineDefs cmb defs'
 44 | 
 45 | sortInlines :: MonoProgram -> MonoProgram
 46 | sortInlines (ep, defs) =
 47 |     let weighted = map (\c@(_,il,_,e)->((il,exprSize e), c)) defs
 48 |     in (ep, map snd $ sortBy (\(w,_) (w', _) -> compare w' w) weighted)
 49 | 
 50 | --    (ep, sortBy (\(l,il,as,e) (l',il',as',e')->
 51 | --        compare (il', (appears l ep + appearsDefs l defs)) (il, (appears l' ep + appearsDefs l' defs))
 52 | --    ) defs)
 53 | 
 54 | -- TODO: non considera l'esplosione della dimensione a causa di argomenti utilizzati più volte
 55 | inlineProgram :: MonoProgram -> MonoProgram
 56 | inlineProgram prog = loop [] (sortInlines prog)
 57 |     where
 58 |         loop procd (ep, []) = (ep, procd)
 59 |         loop procd (ep, cmb@(l, il, as, e):defs)
 60 |             | (appears l ep + appearsDefs l (procd ++ defs)) == 0
 61 |                 = loop procd (ep, defs)
 62 |             | appears l e == 0 && inlineHeuristic e (appears l ep + appearsDefs l (procd++defs))
 63 |                 = loop (inlineDefs cmb procd) (inlineComb cmb ep, inlineDefs cmb defs)
 64 |             | otherwise = loop (cmb:procd) (ep, defs)
 65 | 
 66 | data SieveRes
 67 |     = Always [(String, HLExpr)]
 68 |     | Maybe
 69 |     | Never
 70 | 
 71 | concatRess :: [SieveRes] -> SieveRes
 72 | concatRess [] = Always []
 73 | concatRess (Never:_) = Never
 74 | concatRess (Maybe:_) = Maybe
 75 | concatRess (Always bs:rs) = case concatRess rs of
 76 |     Never -> Never
 77 |     Maybe -> Maybe
 78 |     Always bs' -> Always (bs ++ bs')
 79 | 
 80 | 
 81 | sievePatternInner :: HLPatternData -> HLExpr -> SieveRes
 82 | sievePatternInner PatWildcard _ = Always []
 83 | sievePatternInner (PatLiteral plit) (_, _, ExprLiteral elit) =
 84 |     if plit == elit then Always [] else Never
 85 | sievePatternInner (PatVariant pvar ps) (_, _, ExprConstructor evar es) =
 86 |     if pvar == evar
 87 |     then sievePatternList ps es
 88 |     else Never
 89 | sievePatternInner p e = Maybe
 90 | 
 91 | sievePattern :: HLPattern -> HLExpr -> SieveRes
 92 | sievePattern (_, _, Nothing, patdata) e = sievePatternInner patdata e
 93 | sievePattern (_, _, Just l, patdata) e =
 94 |     let inner = sievePatternInner patdata e
 95 |         in concatRess [Always[(l, e)],inner]
 96 | 
 97 | sievePatternList :: [HLPattern] -> [HLExpr] -> SieveRes
 98 | sievePatternList ps es = concatRess (zipWith sievePattern ps es)
 99 | 
100 | sievePatterns :: [HLExpr] -> [([HLPattern], HLExpr)] -> [([HLPattern], HLExpr)]
101 | sievePatterns v = reverse . loop []
102 |     where loop pses' [] = pses'
103 |           loop pses' ((p, e):pses) =
104 |             case sievePatternList p v of
105 |                 Always _ -> (p, e):pses'
106 |                 Maybe -> loop ((p, e):pses') pses
107 |                 Never -> loop pses' pses
108 | 
109 | optimizeBI :: StdCoord -> DataType -> String -> [HLExpr] -> HLExpr
110 | optimizeBI c t "spinnaker_addInt" [(_, _, ExprLiteral (LitInteger i0)),(_, _, ExprLiteral (LitInteger i1))] = (c, t, ExprLiteral (LitInteger (i0+i1)))
111 | optimizeBI c t "spinnaker_subInt" [(_, _, ExprLiteral (LitInteger i0)),(_, _, ExprLiteral (LitInteger i1))] = (c, t, ExprLiteral (LitInteger (i0-i1)))
112 | optimizeBI c t "spinnaker_mulInt" [(_, _, ExprLiteral (LitInteger i0)),(_, _, ExprLiteral (LitInteger i1))] = (c, t, ExprLiteral (LitInteger (i0*i1)))
113 | optimizeBI c t "spinnaker_divInt" [(_, _, ExprLiteral (LitInteger i0)),(_, _, ExprLiteral (LitInteger i1))] = (c, t, ExprLiteral (LitInteger (quot i0 i1)))
114 | optimizeBI c t "spinnaker_remInt" [(_, _, ExprLiteral (LitInteger i0)),(_, _, ExprLiteral (LitInteger i1))] = (c, t, ExprLiteral (LitInteger (rem i0 i1)))
115 | optimizeBI c t "spinnaker_equInt" [(_, _, ExprLiteral (LitInteger i0)),(_, _, ExprLiteral (LitInteger i1))] = (c, t, ExprConstructor (if i0 == i1 then "True" else "False") [])
116 | optimizeBI c t "spinnaker_neqInt" [(_, _, ExprLiteral (LitInteger i0)),(_, _, ExprLiteral (LitInteger i1))] = (c, t, ExprConstructor (if i0 /= i1 then "True" else "False") [])
117 | optimizeBI c t "spinnaker_leqInt" [(_, _, ExprLiteral (LitInteger i0)),(_, _, ExprLiteral (LitInteger i1))] = (c, t, ExprConstructor (if i0 <= i1 then "True" else "False") [])
118 | optimizeBI c t "spinnaker_greInt" [(_, _, ExprLiteral (LitInteger i0)),(_, _, ExprLiteral (LitInteger i1))] = (c, t, ExprConstructor (if i0 > i1 then "True" else "False") [])
119 | 
120 | optimizeBI c t "spinnaker_addFlt" [(_, _, ExprLiteral (LitFloating f0)),(_, _, ExprLiteral (LitFloating f1))] = (c, t, ExprLiteral (LitFloating (f0+f1)))
121 | optimizeBI c t "spinnaker_subFlt" [(_, _, ExprLiteral (LitFloating f0)),(_, _, ExprLiteral (LitFloating f1))] = (c, t, ExprLiteral (LitFloating (f0-f1)))
122 | optimizeBI c t "spinnaker_mulFlt" [(_, _, ExprLiteral (LitFloating f0)),(_, _, ExprLiteral (LitFloating f1))] = (c, t, ExprLiteral (LitFloating (f0*f1)))
123 | optimizeBI c t "spinnaker_divFlt" [(_, _, ExprLiteral (LitFloating f0)),(_, _, ExprLiteral (LitFloating f1))] = (c, t, ExprLiteral (LitFloating (f0/f1)))
124 | optimizeBI c t "spinnaker_equFlt" [(_, _, ExprLiteral (LitFloating f0)),(_, _, ExprLiteral (LitFloating f1))] = (c, t, ExprConstructor (if f0 == f1 then "True" else "False") [] )
125 | optimizeBI c t "spinnaker_neqFlt" [(_, _, ExprLiteral (LitFloating f0)),(_, _, ExprLiteral (LitFloating f1))] = (c, t, ExprConstructor (if f0 /= f1 then "True" else "False") [] )
126 | optimizeBI c t "spinnaker_leqFlt" [(_, _, ExprLiteral (LitFloating f0)),(_, _, ExprLiteral (LitFloating f1))] = (c, t, ExprConstructor (if f0 <= f1 then "True" else "False") [] )
127 | optimizeBI c t "spinnaker_greFlt" [(_, _, ExprLiteral (LitFloating f0)),(_, _, ExprLiteral (LitFloating f1))] = (c, t, ExprConstructor (if f0 > f1 then "True" else "False") [] )
128 | optimizeBI c t "spinnaker_convItoF" [(_, _, ExprLiteral (LitInteger i))] = (c, t, ExprLiteral (LitFloating (fromIntegral i)))
129 | optimizeBI c t "spinnaker_floorFlt" [(_, _, ExprLiteral (LitFloating f))] = (c, t, ExprLiteral (LitInteger (floor f)))
130 | 
131 | optimizeBI c t "spinnaker_convItoC" [(_, _, ExprLiteral (LitInteger i))] = (c, t, ExprLiteral (LitCharacter (chr i)))
132 | optimizeBI c t "spinnaker_convCtoI" [(_, _, ExprLiteral (LitCharacter ch))] = (c, t, ExprLiteral (LitInteger (ord ch)))
133 | 
134 | optimizeBI c t "spinnaker_andBool" [(_, _, ExprConstructor b0 []),(_, _, ExprConstructor b1 [])] =
135 |     let b = case (b0, b1) of
136 |             ("True", "True") -> "True"
137 |             ("True", "False") -> "False"
138 |             ("False", "True") -> "False"
139 |             ("False", "False") -> "False"
140 |     in (c, t, ExprConstructor b [])
141 | optimizeBI c t "spinnaker_orBool" [(_, _, ExprConstructor b0 []),(_, _, ExprConstructor b1 [])] =
142 |     let b = case (b0, b1) of
143 |             ("True", "True") -> "True"
144 |             ("True", "False") -> "True"
145 |             ("False", "True") -> "True"
146 |             ("False", "False") -> "False"
147 |     in (c, t, ExprConstructor b [])
148 | optimizeBI c t "spinnaker_notBool" [(_, _, ExprConstructor b0 [])] =
149 |     let b = case b0 of
150 |             "True" -> "False"
151 |             "False" -> "True"
152 |     in (c, t, ExprConstructor b [])
153 | 
154 | optimizeBI c t l es = (c, t, ExprCombinator l es)
155 | 
156 | optimizeExpr :: HLExpr -> HLExpr
157 | optimizeExpr e@(_, _, ExprLiteral _) = e
158 | optimizeExpr (c, t, ExprApp f a@(_, at, _)) =
159 |     let f' = optimizeExpr f
160 |         a' = optimizeExpr a
161 |     in case f' of
162 |         (_, _, ExprLambda l inner) -> optimizeExpr (c, t, ExprPut [a'] [([(c, at, Just l, PatWildcard)], inner)])
163 |         _ -> (c, t, ExprApp f' a')
164 | optimizeExpr e@(_, _, ExprLabel _) = e
165 | optimizeExpr (c, t, ExprConstructor l es) = (c, t, ExprConstructor l (map optimizeExpr es))
166 | optimizeExpr (c, t, ExprCombinator l es) = optimizeBI c t l (map optimizeExpr es)
167 | optimizeExpr (c, t, ExprPut vals pses) = --TODO: putofput
168 |     let vals' = map optimizeExpr vals
169 |         pses' = sievePatterns vals' pses
170 |         pses'' = map (\(p,e)->(p,optimizeExpr e)) pses'
171 |     in case pses'' of
172 |         [(p, e)] -> case sievePatternList p vals' of
173 |             Always bs -> 
174 |                 if all (\(ml,me)->let numappears = appears ml e
175 |                                     -- TODO: la condizione con isSimple potrebbe impedire alcune ottimizzazioni
176 |                                     in (isSimple me || numappears <= 1)  && inlineHeuristic me numappears) bs
177 |                 then optimizeExpr $
178 |                     foldl (\me (l,e')->inline [(l, e')] me) e bs
179 |                 else (c, t, ExprPut (map snd bs) [(map (\(ml, (mc, mt, _))-> (mc, mt, Just ml, PatWildcard)) bs, e)])
180 |             _ -> (c, t, ExprPut vals' pses'')
181 |         _ -> (c, t, ExprPut vals' pses'')
182 |         --error $ "OPTIMIZED val " ++ show val' ++ "\npses " ++ show pses ++ "\npses'" ++ show pses'
183 | optimizeExpr (c, t, ExprLambda pat e) = (c, t, ExprLambda pat (optimizeExpr e))
184 | optimizeExpr (_, _, ExprHint _ e) = optimizeExpr e
185 | 
186 | liftComb :: Combinator -> (Combinator, Combinator) --lambda e lifted
187 | liftComb (l, il, as, e) =
188 |     let (clts, e'@(innerc, innert, _)) = liftLambda e
189 |         newlab = l ++ "lifted"
190 |         newas = map (\(myl, myat) -> (myl ++ "lifted", myat)) as
191 |         newclts = map (\(myc, (myl, myat)) -> (myc, (myl ++ "lifted", myat))) clts
192 |         newinner = (innerc, innert, ExprCombinator newlab (map (\(al, at) -> (innerc, at, ExprLabel al)) $ newas ++ map snd newclts))
193 |         newlam = foldr (\(myc, (myl, myat)) mye@(_, myrt, _) -> (myc, buildFunType myat myrt, ExprLambda myl mye)) newinner newclts
194 |     in ((l, True, newas, newlam), (newlab, il, as ++ map snd clts, e'))
195 |     where --liftLambda :: HLExpr -> ([(StdCoord, (String, DataType))], HLExpr)
196 |           liftLambda (c, DataTypeApp (DataTypeApp _ a) _, ExprLambda myl le) =
197 |             let (clts, le') = liftLambda le in ((c, (myl, a)):clts, le')
198 |           liftLambda (_, _, ExprHint _ mye) = liftLambda mye
199 |           liftLambda mye = ([], mye)
200 | liftCombs :: MonoProgram -> MonoProgram
201 | liftCombs (ep, defs) =
202 |     let (lams, lifts) = unzip $ map liftComb defs
203 |     in (foldr inlineComb ep lams, foldr inlineDefs lifts lams)
204 | 
205 | optimizeDefExprs :: MonoProgram -> MonoProgram
206 | optimizeDefExprs (ep, defs) = (optimizeExpr ep,
207 |             map (\(l,il,as,e)->(l,il,as,optimizeExpr e)) defs)
208 | 
209 | optimizeProgram :: [MonoProgram -> MonoProgram] -> MonoProgram -> MonoProgram
210 | optimizeProgram passes p = foldl (flip ($)) p passes
211 | 


--------------------------------------------------------------------------------
/src/HL/Monomorphizer.hs:
--------------------------------------------------------------------------------
  1 | module HL.Monomorphizer (monomorphizeProgram) where
  2 | import qualified Data.Map as Map
  3 | import qualified Data.Set as Set
  4 | import Data.List(find, partition)
  5 | import Data.Maybe(isJust, catMaybes)
  6 | import Control.Monad(join)
  7 | import Control.Monad.State
  8 | 
  9 | import CompDefs
 10 | import HLDefs
 11 | import Parser.MPCL(dummyStdCoord)
 12 | import Typer.TypingDefs
 13 | import Typer.MGUs
 14 | import Typer.TypeTyper(substApplyExpr)
 15 | 
 16 | type Instances = [(DataType, String)]
 17 | type Generators = [(DataType, HLExpr)]
 18 | 
 19 | type MonoEnv = (Int, [Combinator], Map.Map String (Instances, Generators))
 20 | type MonoState t = StateT MonoEnv CompMon t
 21 | 
 22 | monoLog :: String -> MonoState ()
 23 | monoLog = lift . compLog
 24 | 
 25 | addDef :: String -> HLExpr -> MonoState ()
 26 | addDef l e = do
 27 |     (u, defs, env) <- get
 28 |     put (u, (l, False, [], e) : defs, env)
 29 | getInsts :: String -> MonoState Instances
 30 | getInsts l = do
 31 |     (_, _, e) <- get
 32 |     let Just (is, _) = Map.lookup l e
 33 |     return is
 34 | addInst :: String -> DataType -> String -> MonoState ()
 35 | addInst l t l' = do
 36 |     (u, defs, e) <- get
 37 |     let Just (is, gs) = Map.lookup l e
 38 |         e' = Map.insert l ((t, l'):is, gs) e
 39 |     put (u, defs, e')
 40 | getGenerators :: String -> MonoState Generators
 41 | getGenerators l = do
 42 |     (_, _, e) <- get
 43 |     let Just (_, gs) = Map.lookup l e
 44 |     return gs
 45 | newMonoSuffix :: MonoState String
 46 | newMonoSuffix = do
 47 |     (u, defs, e) <- get
 48 |     put (u+1, defs, e)
 49 |     return ('#':show u)
 50 | isGlobal :: String -> MonoState Bool
 51 | isGlobal l = do
 52 |     (_, _, e) <- get
 53 |     return $ isJust $ Map.lookup l e
 54 | 
 55 | findGenerator :: String -> DataType -> Generators -> Maybe HLExpr
 56 | findGenerator l t = getMostSpecific
 57 |     where reduceMostSpecifics :: [(DataType, HLExpr)]->[(DataType, HLExpr)]->[(DataType, HLExpr)]
 58 |           reduceMostSpecifics sps [] = sps
 59 |           reduceMostSpecifics sps ((te, e):tses')
 60 |             | any (\(te', _) -> isJust (match dummyStdCoord te te')) (sps ++ tses')
 61 |                 = reduceMostSpecifics sps tses'
 62 |             | otherwise =  reduceMostSpecifics ((te, e):sps) tses'
 63 |           getMostSpecific tses =
 64 |             let matching = catMaybes [match dummyStdCoord te t >> Just (te, e) | (te, e) <- tses]
 65 |                 specifics = reduceMostSpecifics [] matching
 66 |             in case specifics of
 67 |                 [] -> error $ "No matching generators of: " ++ show l ++ " with type: " ++ show t ++ "\nAvailable gens: " ++ show tses
 68 |                 [(te, e)] -> do
 69 |                     s <- match dummyStdCoord te t
 70 |                     Just (substApplyExpr s e)
 71 |                 xs -> error $ "Cannot find most specific instance of: " ++ show l ++ " with type: " ++ show t ++ "\n    Possible instances are: " ++ show (map fst xs)
 72 | 
 73 | generateInstance :: String -> DataType -> MonoState String
 74 | generateInstance l t = do
 75 |     gs <- getGenerators l
 76 |     let Just e = findGenerator l t gs
 77 |     s <- newMonoSuffix
 78 |     addInst l t (l++s)
 79 |     e' <- monomorphize s e
 80 |     addDef (l++s) e'
 81 |     return (l++s)
 82 | 
 83 | findInstance :: String -> DataType -> MonoState String
 84 | findInstance l t =  if (not . null) (freetyvars t) then error "WHAT: there are free type variables in instance search" else do
 85 |     monoLog $ "Looking for instance of: " ++ show l ++ " with type: " ++ show t
 86 |     is <- getInsts l
 87 |     case find ((==) t . fst) is of
 88 |         Just (_, l') -> do
 89 |             monoLog $ "Instance found: " ++ show l'
 90 |             return l'
 91 |         Nothing -> do
 92 |             monoLog "Instance not found, generating..."
 93 |             generateInstance l t
 94 | 
 95 | monomorphizePatInner :: String -> HLPatternData -> MonoState HLPatternData
 96 | monomorphizePatInner _ PatWildcard = return PatWildcard
 97 | monomorphizePatInner _ p@(PatLiteral _) = return p
 98 | monomorphizePatInner s (PatVariant c ps) = do
 99 |     ps' <- mapM (monomorphizePat s) ps
100 |     return (PatVariant c ps')
101 |     --TODO: In futuro trova i data giusti
102 | 
103 | monomorphizePat :: String -> HLPattern -> MonoState HLPattern
104 | monomorphizePat s (c, t, ml, i) = do
105 |     i' <- monomorphizePatInner s i
106 |     return (c, t, fmap (++s) ml, i')
107 | 
108 | monomorphizeInner :: DataType -> String -> HLExprData -> MonoState HLExprData
109 | monomorphizeInner _ _ e@(ExprLiteral _) = return e
110 | monomorphizeInner _ s (ExprApp f a) = do
111 |     f' <- monomorphize s f
112 |     a' <- monomorphize s a
113 |     return (ExprApp f' a')
114 | monomorphizeInner t s (ExprLabel l) = do
115 |     isglob <- isGlobal l
116 |     if isglob then do
117 |         l' <- findInstance l t
118 |         return (ExprCombinator l' [])
119 |     else return (ExprLabel (l++s))
120 | monomorphizeInner _ s (ExprConstructor c es) = do
121 |     es' <- mapM (monomorphize s) es
122 |     return (ExprConstructor c es')
123 | monomorphizeInner _ s (ExprCombinator l es) = do
124 |     es' <- mapM (monomorphize s) es
125 |     return (ExprCombinator l es')
126 | monomorphizeInner _ s (ExprLambda l e) = do
127 |     e' <- monomorphize s e
128 |     return (ExprLambda (l++s) e')
129 | monomorphizeInner _ s (ExprPut vs pses) = do
130 |     vs' <- mapM (monomorphize s) vs
131 |     pses' <- mapM (\(ps, e) -> do {ps' <- mapM (monomorphizePat s) ps; e' <- monomorphize s e; return (ps', e')}) pses
132 |     return (ExprPut vs' pses')
133 | monomorphizeInner t s (ExprHint _ e) = do
134 |     e' <- monomorphize s e
135 |     return (ExprHint t e')
136 | 
137 | monomorphize :: String -> HLExpr -> MonoState HLExpr
138 | monomorphize s e@(c, t, _) = do
139 |     let monoSubst = Map.fromList $ map (\q -> (q, buildTupType [])) $ Set.toList (freetyvars t)
140 |         (_, t', ed) = substApplyExpr monoSubst e
141 |     ed' <- monomorphizeInner t' s ed
142 |     return (c, t', ed')
143 | 
144 | myListMerge :: Eq k => [(k,v)]->[(k,[v])]
145 | myListMerge [] = []
146 | myListMerge ((k,v):kvs) =
147 |     let (isk, isntk) = partition ((k==) . fst) kvs
148 |         in (k, v:map snd isk):myListMerge isntk
149 | 
150 | monomorphizeProgram :: (HLExpr, BlockProgram) -> CompMon MonoProgram
151 | monomorphizeProgram (entryPoint, BlockProgram datagroups extdefs reldefs valgroups instdefs) =
152 |     let
153 |         valbinds = join valgroups
154 |         valVtables = map (\(ValDef _ l _ _ e@(_, t, _))->(l, [(t, e)])) valbinds
155 |         instsList = myListMerge $ map (\(InstDef _ (Qual _ (Pred l _)) cles) -> (l, cles)) instdefs
156 |         instsListTEs = map (\(il, cless) -> (il, map (\(c, l, e@(_, t, _))->(l, (t, e))) (concat cless))) instsList
157 |         instsVtables :: [(String, [(DataType, HLExpr)])]
158 |         instsVtables = concatMap (myListMerge . snd) instsListTEs
159 | 
160 |         env = Map.fromList $ map (\(l, tses) -> (l, ([], tses))) (valVtables ++ instsVtables)
161 |     in do
162 |         (entryPoint', (_, defs, _)) <- runStateT (monomorphize "" entryPoint) (0, [], env)
163 |         return (entryPoint', defs)
164 |     --TODO: così main può avere soltanto il tipo: (), il che non viene controllato nel typer
165 | 


--------------------------------------------------------------------------------
/src/HLDefs.hs:
--------------------------------------------------------------------------------
 1 | module HLDefs where
 2 | import Parser.MPCL(StdCoord)
 3 | import Typer.TypingDefs
 4 | 
 5 | data Literal
 6 |     = LitInteger Int
 7 |     | LitFloating Float
 8 |     | LitCharacter Char
 9 |     deriving (Show, Eq)
10 | 
11 | data HLPatternData
12 |     = PatWildcard
13 |     | PatLiteral Literal --Il literal rappresentato
14 |     | PatVariant String [HLPattern] --Nome della variante, lista di argomenti di questo
15 |     deriving Show
16 | type HLPattern = (StdCoord, DataType, Maybe String, HLPatternData) -- coordinate, eventuale assegnazione del valore (tipo haskell labl@pat) e pattern vero e proprio
17 | 
18 | data HLExprData
19 |     = ExprLiteral Literal --Valore letterale
20 |     | ExprApp HLExpr HLExpr --Funzione, argomento
21 |     | ExprLabel String --Riferimento a label
22 |     | ExprConstructor String [HLExpr] -- Riferimento a una variante e argomenti "applicati"
23 |     | ExprCombinator String [HLExpr] -- Riferimento al combinatore e argomenti
24 |     | ExprLambda String HLExpr --Argomento e valore interno
25 |     | ExprPut [HLExpr] [([HLPattern], HLExpr)] --Valore da controllare, lista di pattern e i branch corrispondenti
26 |     | ExprHint DataType HLExpr --type hint di un'espressione
27 |     deriving Show
28 | type HLExpr = (StdCoord, DataType, HLExprData)
29 | 
30 | data HLValDef
31 |     = ValDef StdCoord String (Maybe (Qual DataType)) [Pred] HLExpr -- Cordinate della definizione, nome del valore, type hint, espressione
32 |     deriving Show
33 | 
34 | data HLExtDef = ExtDef StdCoord String String [DataType] DataType
35 |     deriving Show
36 | 
37 | data HLDataVariant
38 |     = DataVariant StdCoord String [(StdCoord, DataType)]
39 |     deriving Show
40 | 
41 | data HLDataDef
42 |     = DataDef StdCoord String [(String, TyQuant)] [HLDataVariant]
43 |     deriving Show
44 | 
45 | data HLRelDef
46 |     = RelDef StdCoord String [TyQuant] [Pred] [(StdCoord, String, Qual DataType)]
47 |     deriving Show
48 | 
49 | data HLInstDef
50 |     = InstDef StdCoord (Qual Pred) [(StdCoord, String, HLExpr)]
51 |     deriving Show
52 | 
53 | data BlockProgram = BlockProgram [[HLDataDef]] [HLRelDef] [HLExtDef] [[HLValDef]] [HLInstDef]
54 | 
55 | type DataSummary = (DataType, [(String, [DataType])])
56 | blockProgramToDataSummary :: BlockProgram -> [DataSummary]
57 | blockProgramToDataSummary (BlockProgram ddefgroups _ _ _ _) = do
58 |     ddefs <- ddefgroups
59 |     flip map ddefs $ \(DataDef _ l qs variants) ->
60 |         let datakind = dataQsToKind qs
61 |             datatype = foldl DataTypeApp (DataTypeName l datakind) $ map (DataQuant . snd) qs
62 |             variantinfo = map (\(DataVariant _ vl csds) -> (vl, map snd csds)) variants
63 |         in (datatype, variantinfo)
64 | 
65 | type Inline = Bool
66 | type Combinator = (String, Inline, [(String, DataType)], HLExpr)
67 | type MonoProgram = (HLExpr, [Combinator])
68 | 


--------------------------------------------------------------------------------
/src/ML/HLtoML.hs:
--------------------------------------------------------------------------------
  1 | module ML.HLtoML(hltoml) where
  2 | import Parser.MPCL(StdCoord)
  3 | import CompDefs
  4 | import Typer.TypingDefs
  5 | import HLDefs
  6 | import HL.HLOps
  7 | import MLDefs
  8 | import ML.MLOps
  9 | import Control.Monad.State
 10 | 
 11 | type Branches = [([(String, HLPattern)], MLExpr)]
 12 | pushvalassigns :: Branches -> Branches
 13 | pushvalassigns = map (uncurry $ pushvals [])
 14 |     where pushvals ps [] e = (ps, e)
 15 |           pushvals ps ((l,(c, pt, ml, pd)):lps) e =
 16 |               let ps' = case pd of
 17 |                     PatWildcard -> ps
 18 |                     _ -> (l, (c, pt, Nothing, pd)) : ps
 19 |                   e' = case ml of
 20 |                       Nothing -> e
 21 |                       Just patlab -> mlsubst patlab (c, pt, MLLabel l) e
 22 |               in pushvals ps' lps e'
 23 | 
 24 | makeJoins :: Branches -> MLState (Branches, [(String, [(String, DataType)], MLExpr)])
 25 | makeJoins = fmap unzip . mapM makeJoinsSingle
 26 |     where makeJoinsSingle (lps, e@(c, t, _)) = let ltys = filter ((/= 0) . flip mlappears e . fst) $ lpatsVars lps in do
 27 |             joinLab <- newlab
 28 |             return ((lps, (c, t, MLJoin joinLab $ map (\(argl, argt)->(c, argt, MLLabel argl)) ltys)), (joinLab, ltys, e))
 29 |           lpatsVars lps = lps >>= (patVars . snd)
 30 | 
 31 | chooseTestHeuristic :: Branches -> (StdCoord, DataType, String)
 32 | chooseTestHeuristic ((lps,_):lpsses) = 
 33 |     let occurences = map (\(l, p) -> ((l,p), length $ filter (any ((l ==) . fst) . fst) lpsses)) lps
 34 |         (lab, (c, pt, _, _)) = fst $ maximumOn snd occurences
 35 |     in (c, pt, lab)
 36 |     where maximumOn f = foldr1 (\a b -> if f a < f b then b else a)
 37 | 
 38 | patCompatibility :: (MLPattern, [(String, DataType)]) -> HLPattern -> Maybe [(String, HLPattern)]
 39 | patCompatibility (MLPLiteral l, []) (_,_,_, PatLiteral l') = if l == l' then Just [] else Nothing
 40 | patCompatibility (MLPVariant v, ls) (_,_,_, PatVariant v' ps) = if v == v' then Just $ zipWith (\myl myp -> (fst myl, myp)) ls ps else Nothing
 41 | 
 42 | pattomlpat :: HLPattern -> MLState (MLPattern, [(String, DataType)])
 43 | pattomlpat (c, pt, _, PatLiteral lit) = return (MLPLiteral lit, [])
 44 | pattomlpat (c, pt, _, PatVariant var subps) = do
 45 |     ls <- mapM (\(_,mypt,_,_)-> (\pl -> (pl, mypt)) <$> newlab) subps
 46 |     return (MLPVariant var, ls)
 47 | 
 48 | appendTest :: HLPattern -> ([(String, HLPattern)], MLExpr) -> [((MLPattern, [(String, DataType)]), Branches)] -> MLState [((MLPattern, [(String, DataType)]), Branches)]
 49 | appendTest hlpat (lps, e) [] = do
 50 |     pat <- pattomlpat hlpat
 51 |     let Just subtests = patCompatibility pat hlpat
 52 |         in return [(pat, [(subtests ++ lps, e)])]
 53 | appendTest hlpat branch@(lps, e) ((p, bs) : pbs) =
 54 |     case patCompatibility p hlpat of
 55 |         Nothing -> ((p, bs) :) <$> appendTest hlpat branch pbs
 56 |         Just subtests -> return $ (p, bs ++ [(subtests ++ lps, e)]) : pbs
 57 | 
 58 | splitTests :: String -> Branches -> MLState ([((MLPattern, [(String, DataType)]), Branches)], Branches)
 59 | splitTests lab = inner [] []
 60 |   where inner pbs notest [] = return (pbs, notest)
 61 |         inner pbs notest (lpse@(lps, e):lpsses) =
 62 |             case lookup lab lps of
 63 |                 Nothing -> inner pbs (notest++[lpse]) lpsses
 64 |                 Just hlpat -> do
 65 |                     let lps' = filter ((lab /=) . fst) lps
 66 |                     pbs' <- appendTest hlpat (lps', e) pbs
 67 |                     inner pbs' notest lpsses
 68 | 
 69 | treatput :: StdCoord -> DataType -> Branches -> MLState MLExpr
 70 | treatput c t [] = return (c, t, MLError c "Pattern matching failure")
 71 | treatput c t lpsses = do
 72 |     let lpsses' = pushvalassigns lpsses
 73 |     if null $ fst $ head lpsses' then return $ snd $ head lpsses'
 74 |     else do
 75 |         let (testc, testty, testlab) = chooseTestHeuristic lpsses'
 76 |         lift $ compLog $ show testc ++ " TESTING LABEL:" ++ show testlab
 77 |         (test, notest) <- splitTests testlab lpsses'
 78 |         (notest', joins) <- makeJoins notest
 79 |         mltest <- mapM (\((pat, projs), branches) -> do
 80 |                 res <- treatput c t (branches ++ notest')
 81 |                 let res_projs = case pat of
 82 |                         MLPLiteral _ -> res
 83 |                         MLPVariant vname -> foldr (\(projn, (projl, projt)) e -> (c, t, MLLet projl (c, projt, MLProj (c, testty, MLLabel testlab) vname projn) e) ) res
 84 |                             $ filter (\(_, (projl, _)) -> mlappears projl res /= 0)
 85 |                             $ zip [0..] projs
 86 |                 return (pat, res_projs)
 87 |             ) test
 88 |         mlnotest <- treatput testc t notest'
 89 |         return $ foldr (\(joinl, joinargs, joine) e -> (c, t, MLLetJoin joinl joinargs joine e))
 90 |             (c, t, MLTest (testc, testty, MLLabel testlab)  mltest mlnotest)
 91 |             joins
 92 | 
 93 | exprtomlexpr :: HLExpr -> MLState MLExpr
 94 | exprtomlexpr (c, t, ExprLiteral l) = return (c, t,MLLiteral l)
 95 | exprtomlexpr (c, t, ExprLabel l) = return (c, t, MLLabel l)
 96 | exprtomlexpr (c, t, ExprConstructor v es) = do
 97 |     mles <- mapM exprtomlexpr es
 98 |     return (c, t, MLConstructor v mles)
 99 | exprtomlexpr (c, t, ExprCombinator cmb es) = do
100 |     mles <- mapM exprtomlexpr es
101 |     return (c, t, MLCombinator cmb mles)
102 | exprtomlexpr (c, t, ExprPut es psses) = do
103 |     mles <- mapM exprtomlexpr es
104 |     ls <- mapM (const newlab) [1..length es]
105 |     mergedlps_etoml <- mapM (\(ps, e) -> do
106 |             mle <- exprtomlexpr e --TODO: metti label qui per evitare duplicazione, oppure crea combinatori nello step precedente
107 |             return (zip ls ps, mle)) psses
108 |     mlmatch <- treatput c t mergedlps_etoml
109 |     return $ foldr (\(l, e) e' -> (c, t, MLLet l e e')) mlmatch $ zip ls mles
110 | 
111 | hltoml :: MonoProgram -> Int -> CompMon (MLProgram, Int)
112 | hltoml (expr, combs) uid = flip runStateT uid $ do
113 |     mlexpr <- exprtomlexpr expr
114 |     defs <- mapM combtodef combs
115 |     return (mlexpr, defs)
116 |     where combtodef (labl, il, args, myexpr) = do
117 |             mlexpr <- exprtomlexpr myexpr
118 |             return (labl, args, mlexpr)
119 | 


--------------------------------------------------------------------------------
/src/ML/MLOps.hs:
--------------------------------------------------------------------------------
 1 | module ML.MLOps where
 2 | import Data.List(union)
 3 | import Control.Monad.State
 4 | import CompDefs
 5 | import MLDefs
 6 | 
 7 | type MLState t = StateT Int CompMon t
 8 | runMLState :: MLState t -> Int -> CompMon (t, Int)
 9 | runMLState = runStateT
10 | 
11 | newlab :: MLState String
12 | newlab = do
13 |     uid <- get
14 |     put (uid + 1)
15 |     return ("_ml#" ++ show uid)
16 | 
17 | mlexprSize :: MLExpr -> Int
18 | mlexprSize (_, _, MLLiteral _) = 1
19 | mlexprSize (_, _, MLLabel _) = 1
20 | mlexprSize (_, _, MLConstructor _ es) = 1 + sum (map mlexprSize es)
21 | mlexprSize (_, _, MLCombinator _ es) = 1 + sum (map mlexprSize es)
22 | mlexprSize (_, _, MLJoin _ es) = 1 + sum (map mlexprSize es)
23 | mlexprSize (_, _, MLTest tv pes def) = 1 + mlexprSize tv + sum (map (mlexprSize . snd) pes) + mlexprSize def
24 | mlexprSize (_, _, MLProj e _ _) = 1 + mlexprSize e
25 | mlexprSize (_, _, MLLet _ e0 e1) = 1 + mlexprSize e0 + mlexprSize e1
26 | mlexprSize (_, _, MLLetJoin _ _ e0 e1) = mlexprSize e0 + mlexprSize e1
27 | mlexprSize (_, _, MLError _ _) = 1
28 | 
29 | mlappears :: String -> MLExpr -> Int
30 | mlappears l (_, _, MLLiteral _) = 0
31 | mlappears l (_, _, MLLabel l') = if l == l' then 1 else 0
32 | mlappears l (_, _, MLConstructor _ es) = sum (map (mlappears l) es)
33 | mlappears l (_, _, MLCombinator _ es) = sum (map (mlappears l) es)
34 | mlappears l (_, _, MLJoin j es) = (if l == j then 1 else 0) + sum (map (mlappears l) es)
35 | mlappears l (_, _, MLTest tv pes def) = mlappears l tv + sum (map (mlappears l . snd) pes) + mlappears l def
36 | mlappears l (_, _, MLProj e _ _) = mlappears l e
37 | mlappears l (_, _, MLLet l' e0 e1) = mlappears l e0 + (if l == l' then 0 else mlappears l e1)
38 | mlappears l (_, _, MLLetJoin j lts e0 e1) = (if elem l (map fst lts) then 0 else mlappears l e0) + (if l == j then 0 else mlappears l e1)
39 | mlappears l (_, _, MLError _ _) = 0
40 | 
41 | mlprogramSize :: MLProgram -> Int
42 | mlprogramSize (ep, defs) = mlexprSize ep + sum (map (mlexprSize . (\(_,_,a)->a)) defs)
43 | 
44 | mlsubst :: String -> MLExpr -> MLExpr -> MLExpr
45 | mlsubst l e' e@(_, _, MLLiteral _) = e
46 | mlsubst l e' e@(_, _, MLLabel myl) = if myl == l then e' else e
47 | mlsubst l e' (c, t, MLConstructor v es) = (c, t, MLConstructor v $ map (mlsubst l e') es)
48 | mlsubst l e' (c, t, MLCombinator cmb es) = (c, t, MLCombinator cmb $ map (mlsubst l e') es)
49 | mlsubst l e' (c, t, MLJoin j es) = (c, t, MLJoin j $ map (mlsubst l e') es)
50 | mlsubst l e' (c, t, MLTest tv pes def) = (c, t, MLTest (mlsubst l e' tv) (map (\(myp, mye) -> (myp, mlsubst l e' mye)) pes) (mlsubst l e' def))
51 | mlsubst l e' (c, t, MLProj e var n) = (c, t, MLProj (mlsubst l e' e) var n)
52 | mlsubst l e' (c, t, MLLet ll e0 e1) = (c, t, MLLet ll (mlsubst l e' e0) (mlsubst l e' e1)) --TODO: La sostituzione può avvenire solo se ll != l
53 | mlsubst l e' (c, t, MLLetJoin j lts e0 e1) = (c, t, MLLetJoin j lts (mlsubst l e' e0) (mlsubst l e' e1))--TODO: La sostituzione può avvenire solo se l nonelem lts
54 | mlsubst _ _ e@(_, _, MLError _ _) = e
55 | 
56 | joinsubst :: (String, [String], MLExpr) -> MLExpr -> MLExpr
57 | joinsubst _ e@(_, _, MLLiteral _) = e
58 | joinsubst _ e@(_, _, MLLabel _) = e
59 | joinsubst j (c, t, MLConstructor v es) = (c, t, MLConstructor v $ map (joinsubst j) es)
60 | joinsubst j (c, t, MLCombinator cmb es) = (c, t, MLCombinator cmb $ map (joinsubst j) es)
61 | joinsubst (l, as, je) e@(_, _, MLJoin myl es) = if myl == l then foldl (\e' (al, ae) -> mlsubst al ae e') je (zip as es) else e
62 | joinsubst j (c, t, MLTest tv pes def) = (c, t, MLTest (joinsubst j tv) (map (\(myp, mye) -> (myp, joinsubst j mye)) pes) (joinsubst j def))
63 | joinsubst j (c, t, MLProj e var n) = (c, t, MLProj (joinsubst j e) var n)
64 | joinsubst j (c, t, MLLet ll e0 e1) = (c, t, MLLet ll (joinsubst j e0) (joinsubst j e1)) --TODO: La sostituzione può avvenire solo se ll != l
65 | joinsubst j (c, t, MLLetJoin jl lts e0 e1) = (c, t, MLLetJoin jl lts (joinsubst j e0) (joinsubst j e1))--TODO: La sostituzione può avvenire solo se j != jl
66 | joinsubst _ e@(_, _, MLError _ _) = e
67 | 
68 | unions :: Eq a => [[a]] -> [a]
69 | unions = foldr union []
70 | --TODO: specializza a tipi?
71 | variantsUsed :: MLExpr -> [String]
72 | variantsUsed (_, _, MLLiteral _) = []
73 | variantsUsed (_, _, MLLabel _) = []
74 | variantsUsed (_, _, MLConstructor v es) = unions $ [v]:map variantsUsed es
75 | variantsUsed (_, _, MLCombinator _ es) = unions $ map variantsUsed es
76 | variantsUsed (_, _, MLJoin _ es) = unions $ map variantsUsed es
77 | variantsUsed (_, _, MLTest tv pes def) = unions $ variantsUsed tv : variantsUsed def : map (\(p, e) -> union (patvar p) (variantsUsed e)) pes
78 |     where patvar p = case p of
79 |             MLPVariant pl -> [pl]
80 |             _ -> []
81 | variantsUsed (_, _, MLProj _ var _) = [var]
82 | variantsUsed (_, _, MLLet _ e0 e1) = union (variantsUsed e0) (variantsUsed e1)
83 | variantsUsed (_, _, MLLetJoin _ _ e0 e1) = union (variantsUsed e0) (variantsUsed e1)
84 | variantsUsed (_, _, MLError _ _) = []
85 | 
86 | variantsUsedProg :: MLProgram -> [String]
87 | variantsUsedProg (ep, defs) =
88 |     unions $ variantsUsed ep : map variantsUsedDef defs
89 |     where variantsUsedDef (_, _, e) = variantsUsed e
90 | 


--------------------------------------------------------------------------------
/src/ML/MLOptimize.hs:
--------------------------------------------------------------------------------
 1 | module ML.MLOptimize where
 2 | import MLDefs
 3 | import ML.MLOps
 4 | 
 5 | optimizeMLExpr :: MLExpr -> MLExpr
 6 | optimizeMLExpr e@(_, _, MLLiteral _) = e
 7 | optimizeMLExpr e@(_, _, MLLabel _) = e
 8 | optimizeMLExpr e@(_, _, MLError _ _) = e
 9 | optimizeMLExpr (c, t, MLProj e var n) = (c, t, MLProj (optimizeMLExpr e) var n)
10 | optimizeMLExpr (c, t, MLConstructor v es) = (c, t, MLConstructor v $ map optimizeMLExpr es)
11 | optimizeMLExpr (c, t, MLCombinator v es) = (c, t, MLCombinator v $ map optimizeMLExpr es)
12 | optimizeMLExpr (c, t, MLJoin j es) = (c, t, MLJoin j $ map optimizeMLExpr es)
13 | optimizeMLExpr (c, t, MLTest tv pes def) = (c, t, MLTest (optimizeMLExpr tv) (map (\(p, e) -> (p, optimizeMLExpr e)) pes) (optimizeMLExpr def))
14 | optimizeMLExpr (c, t, MLLet l e0@(_, _, MLLabel _) e1) = mlsubst l e0 $ optimizeMLExpr e1
15 | optimizeMLExpr (c, t, MLLet l e0 e1) =
16 |     let e0' = optimizeMLExpr e0
17 |         e1' = optimizeMLExpr e1
18 |     in case mlappears l e1' of
19 |         0 -> e1'
20 |         1 -> mlsubst l e0' e1'
21 |         _ -> (c, t, MLLet l e0' e1')
22 |     --TODO: sostituzione di un'espressione usata una sola volta
23 | optimizeMLExpr (c, t, MLLetJoin j lts e0 e1) = 
24 |     let e0' = optimizeMLExpr e0
25 |         e1' = optimizeMLExpr e1
26 |     in case mlappears j e1' of
27 |         0 -> e1'
28 |         1 -> joinsubst (j, map fst lts, e0') e1' --TODO: può capitare che e0' sia ottimizzato considerando che gli argomenti sono label, mentre quando viene inlinizzato possono non esserlo, basterebbe introdurre dei let in joinsubst e ottimizzare su quelli
29 |         _ -> (c, t, MLLetJoin j lts e0' e1')
30 |     --TODO: inline se è chiamato solo una volta
31 | 
32 | optimizeMLProg :: MLProgram -> MLProgram
33 | optimizeMLProg (ep, defs) =
34 |     (optimizeMLExpr ep, map optimizeDef defs)
35 |     where optimizeDef (lab, args, expr) = (lab, args, optimizeMLExpr expr)
36 | 


--------------------------------------------------------------------------------
/src/MLDefs.hs:
--------------------------------------------------------------------------------
 1 | module MLDefs where
 2 | import Parser.MPCL(StdCoord)
 3 | import Typer.TypingDefs
 4 | import HLDefs (Literal)
 5 | 
 6 | data MLPattern
 7 |     = MLPLiteral Literal
 8 |     | MLPVariant String
 9 |     deriving Show
10 | 
11 | data MLExprData
12 |     = MLLiteral Literal
13 |     | MLLabel String
14 |     | MLConstructor String [MLExpr]
15 |     | MLCombinator String [MLExpr]
16 |     | MLJoin String [MLExpr]
17 |     | MLTest MLExpr [(MLPattern, MLExpr)] MLExpr
18 |     | MLProj MLExpr String Int
19 |     | MLLet String MLExpr MLExpr
20 |     | MLLetJoin String [(String, DataType)] MLExpr MLExpr
21 |     | MLError StdCoord String --TODO: la coordinata si può prendere dall'esterno, sostituisci la stringa con una reference al tipo di errore, oppure specializza solo al pattern matching, o ancora utilizza un'espressione esterna
22 |     deriving Show
23 | 
24 | type MLExpr = (StdCoord, DataType, MLExprData)
25 | type MLDef = (String, [(String, DataType)], MLExpr)
26 | type MLProgram = (MLExpr, [MLDef])
27 | 


--------------------------------------------------------------------------------
/src/Main.hs:
--------------------------------------------------------------------------------
  1 | import System.IO
  2 | import System.Environment
  3 | import System.CPUTime
  4 | import Data.Tree
  5 | import Control.Monad.State
  6 | 
  7 | import qualified Paths_spinnaker as Paths
  8 | 
  9 | import CompDefs
 10 | import ArgParser
 11 | import HLDefs
 12 | import HL.HLOps
 13 | import PrettyPrinter
 14 | import Parser.Demod
 15 | import Typer.TypingDefs
 16 | import Typer.Typer
 17 | import HL.Monomorphizer
 18 | import HL.HLOptimize
 19 | import HL.Defunctionalize
 20 | import ML.MLOps
 21 | import ML.MLOptimize
 22 | import ML.HLtoML
 23 | --import Backends.VM.MLtoVM
 24 | --import qualified Backends.VM.VM as VM
 25 | import Backends.MLtoJS
 26 | import Backends.MLtoSCM
 27 | 
 28 | timeTyper :: TyperState t -> TyperState (t, Double)
 29 | timeTyper a = do
 30 |     start <- lift $ lift $ lift getCPUTime
 31 |     v <- a
 32 |     end <- lift $ lift $ lift getCPUTime
 33 |     let diff = fromIntegral (end - start) / (10^9)
 34 |     return (v, diff)
 35 | 
 36 | frontendCompile :: String -> CompMon (Either String (TypingEnv, HLExpr, BlockProgram, (Double, Double)), Int)
 37 | frontendCompile fname = fmap (\(eitherprog, (uid, _, _)) -> (eitherprog, uid)) $ runTyperState (0,0,0) $ do
 38 |     rootpath <- lift $ lift getDataDir
 39 |     typerLog $ "Current data dir: " ++ rootpath
 40 |     ((_denv, entry, block), t_demod) <- timeTyper $ demodProgram (rootpath ++ "/")  "stdlib/core.spk" "stdlib/std.spk" fname
 41 |     typerLog $ "DemodProgram:\n" ++ drawTree (toTreeBlockProgram block)
 42 |     ((env, tyblock), t_typer) <- timeTyper $ typeBlockProgram block
 43 |     typerLog $ "Typed Program:\n" ++ drawTree (toTreeBlockProgram tyblock)
 44 |     return (env, entry, tyblock, (t_demod, t_typer))
 45 | 
 46 | monoOptiPasses, defunOptiPasses :: [MonoProgram -> MonoProgram]
 47 | monoOptiPasses = [optimizeDefExprs, liftCombs, inlineProgram, optimizeDefExprs]
 48 |                  --[liftCombs, optimizeDefExprs, inlineProgram, optimizeDefExprs]
 49 | defunOptiPasses = [optimizeDefExprs, inlineProgram, optimizeDefExprs]
 50 | 
 51 | compile :: CompMon ()
 52 | compile = do
 53 |     source <- fmap (forceGetArg "source_file") getArgOptions
 54 |     ((eitherprog, uid),t_frontend) <- time $ frontendCompile source
 55 |     let (ep, block, ts) = case eitherprog of
 56 |             Left e -> error $ "Frontend compilation error: " ++ e
 57 |             Right (_, myep, myblock, myts) -> (myep, myblock, myts)
 58 |     let typeddatasummary = blockProgramToDataSummary block --TODO sposta questa operazione in qualche altro file
 59 |     (prog, t_mono) <- time $ monomorphizeProgram (ep, block)
 60 |     (mono, t_opti) <- time $ return $ optimizeProgram monoOptiPasses prog
 61 |     compLog $ "Mono " ++ showMonoProg mono
 62 |     ((defundatasummary, defraw, uid'), t_defun) <- time $ defunProgram mono uid
 63 |     let datasummary = typeddatasummary ++ defundatasummary
 64 |     compLog $ "Final data summary: " ++ show datasummary
 65 |     (defopti, t_opti2) <- time $ return $ optimizeProgram defunOptiPasses defraw
 66 |     compLog $ "Defun " ++ showMonoProg defopti
 67 | 
 68 |     ((mlprog, uid''), t_toml) <- time $ hltoml defopti uid'
 69 |     let mlopti = optimizeMLProg mlprog
 70 |     compLog $ "MLProg " ++ showMLProg mlopti
 71 | 
 72 |     compLog $ "Unoptimized program size: " ++ show (programSize prog) ++ ", optimized program size: " ++ show (programSize mono) ++ ", defun program size: " ++ show (programSize defopti) ++ ", ML program size: " ++ show (mlprogramSize mlopti)
 73 |     compLog $ "Timings: frontend:" ++ show t_frontend ++ show ts ++ "ms mono:" ++ show t_mono ++ "ms opti:" ++ show t_opti ++ "ms defun:" ++ show t_defun ++ "ms opti2:" ++ show t_opti2 ++ "ms toml:" ++ show t_toml ++ "ms"
 74 | 
 75 |     backend <- fmap (forceGetArg "backend") getArgOptions
 76 |     case backend of
 77 |         "js" -> do
 78 |             let jsprog = tojsProgram datasummary mlopti
 79 |             rootpath <- getDataDir
 80 |             runtimehandle <- lift $ openFile (rootpath ++ "/runtime/js/spinnaker.js") ReadMode
 81 |             runtimecode <- lift $ hGetContents runtimehandle
 82 |             lift $ writeFile "out.js" $ runtimecode ++ jsprog
 83 |         "scm" -> do
 84 |             let scmprog = toscmProgram datasummary mlopti
 85 |             rootpath <- getDataDir
 86 |             runtimehandle <- lift $ openFile (rootpath ++ "/runtime/scm/spinnaker.scm") ReadMode
 87 |             runtimecode <- lift $ hGetContents runtimehandle
 88 |             lift $ writeFile "out.scm" $ runtimecode ++ scmprog
 89 |         -- "vm" -> do
 90 |         --     let vmprog = progToVm mlopti
 91 |         --     compLog $ "VM Bytecode: " ++ show vmprog
 92 |         --     lift $ hFlush stdout
 93 |         --     (_, t_eval) <- time $ lift $ VM.evalProg vmprog
 94 |         --     compLog $ "Program eval time:" ++ show t_eval ++ "ms"
 95 | 
 96 | argdefs :: [Arg]
 97 | argdefs =
 98 |     [ Arg {argID="help", argShort=Just 'h', argLong=Just "help", argIsOpt=True, argData=Nothing, argDesc="Display this message"}
 99 |     , Arg {argID="verbose", argShort=Just 'v', argLong=Just "verbose", argIsOpt=True, argData=Nothing, argDesc="Verbose compiler output"}
100 |     , Arg {argID="source_file", argShort=Just 'f', argLong=Just "file", argIsOpt=False, argData=Just $ ArgDataStr Nothing, argDesc="Specify source code file"}
101 |     , Arg {argID="backend", argShort=Nothing, argLong=Just "backend", argIsOpt=True, argData=Just $ ArgDataOpt ["js", "scm"] (Just "js"), argDesc="Specify the compiler backend"}
102 |     ]
103 | 
104 | main :: IO ()
105 | main = getArgs >>= \args ->
106 |     case parseArgs argdefs args of
107 |         Left _ -> putStr $ "The Spinnaker Compiler\n"++showHelp argdefs
108 |         Right argparse -> do
109 |             datadir <- Paths.getDataDir
110 |             if gotArg "help" argparse then putStr $ "The Spinnaker Compiler\n"++showHelp argdefs else return ()
111 |             runCompMon CompState{dataDir=datadir, argOptions=argparse} compile
112 | 


--------------------------------------------------------------------------------
/src/Parser/MPCL.hs:
--------------------------------------------------------------------------------
  1 | --Micro Parser Combinator Library -- Just Enough To Be Dangerous!
  2 | module Parser.MPCL where
  3 | 
  4 | import GHC.Base
  5 | import GHC.Unicode
  6 | 
  7 | type ErrMessage = String
  8 | data ParseResult coord t
  9 |     = POk t (coord, String)
 10 |     | PFail coord ErrMessage
 11 |     | PFatal coord ErrMessage
 12 |     deriving Show
 13 | 
 14 | data Parser coord a
 15 |     = PValue a
 16 |     | PParse ((coord, String)->ParseResult coord a)
 17 | 
 18 | instance Applicative (Parser coord) where
 19 |     pure = PValue
 20 |     (<*>) = ap
 21 | 
 22 | instance Monad (Parser coord) where
 23 |     (PValue a) >>= f = f a
 24 |     (PParse pf) >>= f = PParse(\cs ->
 25 |         case pf cs of
 26 |             POk e cs1 -> parse (f e) cs1
 27 |             PFail c m -> PFail c m
 28 |             PFatal c m -> PFatal c m
 29 |         )
 30 | 
 31 | instance Functor (Parser coord) where
 32 |     fmap f p =
 33 |         (p >>= (pure . f))
 34 | 
 35 | -- Funzione primaria di parsing
 36 | parse :: Parser c a -> (c, String) -> ParseResult c a
 37 | parse (PValue v) cs = POk v cs
 38 | parse (PParse f) cs = f cs
 39 | 
 40 | -- Scelta con preferenza a sinistra:
 41 | -- (p <|| k) = p se p è valido, altrimenti k
 42 | -- TODO magari conviene far vedere tutti i messaggi di errore quando falliscono
 43 | infixr 5 <||
 44 | (<||) :: Parser c a -> Parser c a -> Parser c a
 45 | (PValue v) <|| _ = PValue v
 46 | (PParse f) <|| p = PParse(\cs ->
 47 |     case f cs of
 48 |         PFail _ _ -> parse p cs
 49 |         resf -> resf
 50 |     )
 51 | 
 52 | --Restituisce un parser che non consuma l'input
 53 | look :: Parser c a -> Parser c a
 54 | look p = PParse(\cs ->
 55 |     case parse p cs of
 56 |         POk el _ -> POk el cs
 57 |         resp -> resp
 58 |     )
 59 | 
 60 | --Restituisce un parser che fallisce catastroficamente se non è soddisfatto
 61 | require :: Parser c a -> Parser c a
 62 | require p = PParse(\cs ->
 63 |     case parse p cs of
 64 |         PFail c e -> PFatal c e
 65 |         resp -> resp
 66 |     )
 67 | --Restituisce un parser che converte i fallimenti catastrofici in fallimenti normali
 68 | recover :: Parser c a -> Parser c a
 69 | recover p = PParse(\cs ->
 70 |     case parse p cs of
 71 |         PFatal c e -> PFail c e
 72 |         resp -> resp
 73 |     )
 74 | 
 75 | discard :: Parser c a -> Parser c ()
 76 | discard = fmap (const ())
 77 | {-
 78 | --Aggiunge la stringa specificata all'inizio del messaggio di errore
 79 | detailError s p = PParse(\cs ->
 80 |     let resp = parse p cs in case resp of
 81 |         POk _ _ -> resp
 82 |         PFail c preve -> PFail c (s++'\n':preve)-- parse (PPFail (fst cs, s++'\n':preve)) cs
 83 |         PFatal c preve -> PFatal c (s++'\n':preve)-- parse (PPFail (fst cs, s++'\n':preve)) cs
 84 |     )
 85 | -}
 86 | 
 87 | --Sostituisce il messaggio di errore con la stringa specificata
 88 | --TODO: Forse bisogna conservare le coordinate originarie?
 89 | --TODO: Forse sovrascrivi anche l'errore fatale
 90 | describeError :: String -> Parser c a -> Parser c a
 91 | describeError s p = PParse(\cs ->
 92 |     case parse p cs of
 93 |         PFail c preve -> PFail (fst cs) s
 94 |         resp -> resp
 95 |     )
 96 | 
 97 | --Messaggio di errore in caso di fallimento "soft"
 98 | pfail :: String -> Parser c a
 99 | pfail e = PParse(\(c, s) -> PFail c e)
100 | --Messaggio di errore fatale
101 | pfatal :: String -> Parser c a
102 | pfatal e = PParse(\(c, s) -> PFatal c e)
103 | 
104 | --Ha successo se e solo se si è arrivati alla fine del file
105 | reachedEof :: Parser c ()
106 | reachedEof = PParse(\(c, s) ->
107 |     case s of
108 |         [] -> POk () (c, s)
109 |         xs -> PFail c ("EOF not reached, remaining string: " ++ xs)
110 |     )
111 | 
112 | --Elabora uno o più elementi del parser specificato
113 | munch1 :: Parser c a -> Parser c [a]
114 | munch1 p = do {
115 |     e <- p;
116 |     es <- munch p;
117 |     return (e:es)
118 | }
119 | 
120 | --Elabora zero o più elementi del parser specificato
121 | munch :: Parser c a -> Parser c [a]
122 | munch p = munch1 p <|| return []
123 | 
124 | --Elabora uno o più p separati da sep
125 | sepBy1 :: Parser c p -> Parser c sep -> Parser c [p]
126 | sepBy1 p sep = do {
127 |     e <- p;
128 |     es <- munch (sep >> require p); -- se c'è il separatore è necessario l'elemento
129 |     return (e:es)
130 | }
131 | 
132 | --Elabora zero o più p separati da sep
133 | sepBy :: Parser c p -> Parser c sep -> Parser c [p]
134 | sepBy p sep = sepBy1 p sep <|| return []
135 | 
136 | --Elabora due o più p separati da sep
137 | sepBy2 :: Parser c p -> Parser c sep -> Parser c [p]
138 | sepBy2 p sep = do {
139 |     e <- p;
140 |     es <- munch1 (sep >> require p);
141 |     return (e:es)
142 | }
143 | 
144 | --Se e ha successo il parser fallisce, altrimenti fai p
145 | difference :: Show e => Parser c p -> Parser c e -> Parser c p
146 | difference p e = PParse(\cs ->
147 |     case parse e cs of
148 |         POk res (c, _) -> PFail c ("Unexpected parse: " ++ show res)
149 |         _ -> parse p cs
150 |     )
151 | 
152 | --Se p è ha successo lo restituisce, altrimenti val
153 | option :: a -> Parser c a -> Parser c a
154 | option val p = p <|| return val
155 | 
156 | --Se p è ha successo restituisce Just p, altrimenti Nothing
157 | optional :: Parser c a -> Parser c (Maybe a)
158 | optional p = fmap Just p <|| return Nothing
159 | 
160 | --come ReadP.satisfy, ma newc è una funzione da una coordinata alla successiva, questo dà la possibilità di cambiare sistema di riferimento
161 | satisfyInternal :: (c -> Char -> c) -> (Char -> Bool) -> String -> Parser c (c, Char)
162 | satisfyInternal newc cond emsg = PParse(\(coord, str) ->
163 |     case str of
164 |         [] -> PFail coord emsg
165 |         (c:cs) -> if cond c then POk (coord, c) (newc coord c, cs)
166 |                             else PFail coord emsg
167 |     )
168 | 
169 | --Definizioni utili
170 | 
171 | --Sistema di coordinate predefinito, viene stampato con la forma: [file:line:col]
172 | data StdCoord = Coord String Int Int
173 | type StdParser = Parser StdCoord
174 | 
175 | instance Show StdCoord where
176 |     show (Coord file line col) =
177 |         "[" ++ file ++ ":" ++ show line ++ ":" ++ show col ++ "]"
178 | dummyStdCoord :: StdCoord
179 | dummyStdCoord = Coord "" 0 0
180 | 
181 | stdcoordNewc :: StdCoord -> Char -> StdCoord
182 | stdcoordNewc (Coord file line col) char = --TODO: Come si trattano i caratteri a più celle?
183 |     case char of
184 |         '\n' -> Coord file (line+1) 1
185 |         _ -> Coord file line (col+1)
186 | 
187 | --satisfy con StdCoord
188 | stdSatisfy :: (Char -> Bool) -> String -> StdParser (StdCoord, Char)
189 | stdSatisfy = satisfyInternal stdcoordNewc
190 | 
191 | --raccoglie il carattere specificato
192 | thisChar :: Char -> StdParser (StdCoord, Char)
193 | thisChar char = stdSatisfy (char==) ("Expected character: \'" ++ char : '\'' : [])
194 | --raccoglie uno dei caratteri specificati
195 | anyChar :: [Char] -> StdParser (StdCoord, Char)
196 | anyChar chars = stdSatisfy (\c -> any (c==) chars) ("Expected one of these chars: \"" ++ chars ++ "\"")
197 | 
198 | --alcuni parser utili
199 | asciiAlphaLower, asciiAlphaUpper, digit, asciiAlphaNumeric, whiteSpace :: StdParser (StdCoord, Char)
200 | asciiAlphaLower   = anyChar "abcdefghijklmnopqrstuvwxyz"
201 | asciiAlphaUpper   = anyChar "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
202 | digit             = anyChar "01234567890"
203 | asciiAlphaNumeric = asciiAlphaLower <|| asciiAlphaUpper <|| digit
204 | whiteSpace        = stdSatisfy isSpace "Expected a whitespace"
205 | 


--------------------------------------------------------------------------------
/src/PrettyPrinter.hs:
--------------------------------------------------------------------------------
  1 | module PrettyPrinter where
  2 | import Data.Tree
  3 | import SyntaxDefs
  4 | import HLDefs
  5 | import MLDefs
  6 | 
  7 | --Roba per HL
  8 | toTreeHLPattern p = Node (show p) []
  9 | 
 10 | toTreeHLExpr (c, dt, ExprLiteral l) = Node (show c ++ " DT:" ++ show dt ++ " Literal: " ++ show l) []
 11 | toTreeHLExpr (c, dt, ExprApp f a) = Node (show c ++ " DT:" ++ show dt ++ " Function call") [toTreeHLExpr f, toTreeHLExpr a]
 12 | toTreeHLExpr (c, dt, ExprLabel l) = Node (show c ++ " DT:" ++ show dt ++ " Label: " ++ show l) []
 13 | toTreeHLExpr (c, dt, ExprConstructor l es) = Node (show c ++ " DT:" ++ show dt ++ " Constructor: " ++ show l) (map toTreeHLExpr es)
 14 | toTreeHLExpr (c, dt, ExprCombinator l es) = Node (show c ++ " DT:" ++ show dt ++ " Combinator: " ++ show l) (map toTreeHLExpr es)
 15 | toTreeHLExpr (c, dt, ExprLambda l expr) = Node (show c ++ " DT:" ++ show dt ++ " Lambda") [Node ("arg " ++ show l) [], Node "expr" [toTreeHLExpr expr]]
 16 | toTreeHLExpr (c, dt, ExprPut vals branches) = Node (show c ++ " DT:" ++ show dt ++ " Put") [Node "vals" (map toTreeHLExpr vals), Node "branches" (map (\(p, e) -> Node "branch" [Node "pat" [toTreeHLPattern p], Node "expr" [toTreeHLExpr e]]) branches)]
 17 | toTreeHLExpr (c, dt, ExprHint hint e) = Node (show c ++ " DT:" ++ show dt ++ " Hinting with type: " ++ show hint) [toTreeHLExpr e]
 18 | 
 19 | toTreeHLValDef (ValDef c s t ps e) = Node (show c ++ " Defining val: " ++ show s ++ " typehint: " ++ show t ++ " qualifiers: " ++ show ps) [toTreeHLExpr e]
 20 | 
 21 | toTreeHLExtDef (ExtDef c l lext tas tr) = Node (show c ++ " External combinator: " ++ show l ++ " which imports: " ++ show lext) [Node "with arg " $ map (\ta->Node (show ta)[]) tas, Node "and return type" [Node (show tr) []]]
 22 | toTreeHLDataVariant (DataVariant c labl args) = Node (show c ++ " DataVariant: " ++ show labl) (map (\t->Node ("Arg: " ++ show t) []) args)
 23 | toTreeHLDataDef (DataDef c labl quants variants) = Node (show c ++ " Defining data: " ++ show labl ++ " with quantifiers: " ++ show quants)
 24 |     (map toTreeHLDataVariant variants)
 25 | 
 26 | toTreeHLRelDef (RelDef c label quants preds decls) = Node (show c ++ " Defining rel: " ++ show preds ++ " => " ++ show label ++ show quants ++ " declares: ") (map (\(c, l, t)->Node (show c ++ " Decl: " ++ l ++ " of type: " ++ show t) []) decls)
 27 | toTreeHLInstDef (InstDef c qualpred defs) = Node (show c ++ " Defining inst: " ++ show qualpred) (map (\(c, l, e)->Node (show c ++ " Def: " ++ show l) [toTreeHLExpr e]) defs)
 28 | 
 29 | toTreeBlockProgram (BlockProgram datagroups reldefs extdefs valgroups instdefs) = Node "BlockProgram" [
 30 |         Node "Datas" (map (Node "Group of datas" . map toTreeHLDataDef) datagroups),
 31 |         Node "Rels" (map toTreeHLRelDef reldefs),
 32 |         Node "Exts" (map toTreeHLExtDef extdefs),
 33 |         Node "Vals" (map (Node "Group of vals" . map toTreeHLValDef) valgroups),
 34 |         Node "Insts" (map toTreeHLInstDef instdefs)
 35 |     ]
 36 | 
 37 | toTreeMonoDef (l, il, as, e) = Node (show l ++ " inline: " ++ show il) [Node "args" (map (\(al,at)-> Node (show al ++ ":" ++ show at) []) as), toTreeHLExpr e]
 38 | toTreeMonoDefs defs = Node "MonoDefs" (map toTreeMonoDef defs)
 39 | showMonoProg (ep, defs) = "EP: " ++ drawTree (toTreeHLExpr ep) ++ "\nDefs: " ++ drawTree (toTreeMonoDefs defs)
 40 | 
 41 | --Roba per ML
 42 | toTreeMLPattern p = Node (show p) []
 43 | 
 44 | toTreeMLBranch (pat, expr) = Node "branch" [toTreeMLPattern pat, toTreeMLExpr expr]
 45 | 
 46 | toTreeMLExpr (c, dt, MLLiteral l) = Node (show c ++ " DT:" ++ show dt ++ " Literal: " ++ show l) []
 47 | toTreeMLExpr (c, dt, MLLabel l) = Node (show c ++ " DT:" ++ show dt ++ " Label: " ++ show l) []
 48 | toTreeMLExpr (c, dt, MLConstructor l es) = Node (show c ++ " DT:" ++ show dt ++ " Constructor: " ++ show l) (map toTreeMLExpr es)
 49 | toTreeMLExpr (c, dt, MLCombinator l es) = Node (show c ++ " DT:" ++ show dt ++ " Combinator: " ++ show l) (map toTreeMLExpr es)
 50 | toTreeMLExpr (c, dt, MLJoin l es) = Node (show c ++ " DT:" ++ show dt ++ " Join: " ++ show l) (map toTreeMLExpr es)
 51 | toTreeMLExpr (c, dt, MLTest tv pes def) = Node (show c ++ " DT:" ++ show dt ++ " TEST") (Node "testval" [toTreeMLExpr tv] : map toTreeMLBranch pes ++ [Node "def" [toTreeMLExpr def]])
 52 | toTreeMLExpr (c, dt, MLProj e var n) = Node (show c ++ " DT: " ++ show dt ++ " PROJ FIELD " ++ show n) [toTreeMLExpr e]
 53 | toTreeMLExpr (c, dt, MLLet l e0 e1) = Node (show c ++ " DT:" ++ show dt ++ " LET:" ++ show l) [Node "val" [toTreeMLExpr e0], Node "expr" [toTreeMLExpr e1]]
 54 | toTreeMLExpr (c, dt, MLLetJoin l args e0 e1) = Node (show c ++ " DT:" ++ show dt ++ " LETJOIN:" ++ show l) [Node "args" (map (\(al, at) -> Node (show al ++ ":" ++ show at) []) args), Node "val" [toTreeMLExpr e0], Node "expr" [toTreeMLExpr e1]]
 55 | toTreeMLExpr (c, dt, MLError _ s) = Node (show c ++ " DT:" ++ show dt ++ " ERROR:" ++ show s) []
 56 | 
 57 | toTreeMLDef (l, as, e) = Node (show l) [Node "args" (map (\(al,at)-> Node (show al ++ ":" ++ show at) []) as), toTreeMLExpr e]
 58 | toTreeMLDefs defs = Node "MLDefs" (map toTreeMLDef defs)
 59 | showMLProg (ep, defs) = "EP: " ++ drawTree (toTreeMLExpr ep) ++ "\nDefs: " ++ drawTree (toTreeMLDefs defs)
 60 | --Roba per Syn
 61 | toTreeSynPattern p = Node (show p) []
 62 | 
 63 | toTreeSynBranch (pats, e) = Node "branch" [Node "pats" (map toTreeSynPattern pats), Node "expr" [toTreeSynExpr e]]
 64 | 
 65 | toTreeSynExpr (c, SynExprLiteral l) = Node (show c ++ " Literal: " ++ show l) []
 66 | toTreeSynExpr (c, SynExprApp f a) = Node (show c ++ " Function call") [toTreeSynExpr f, toTreeSynExpr a]
 67 | toTreeSynExpr (c, SynExprLabel l) = Node (show c ++ " Label: " ++ show l) []
 68 | toTreeSynExpr (c, SynExprConstructor l) = Node (show c ++ " Constructor: " ++ show l) []
 69 | toTreeSynExpr (c, SynExprTuple es) = Node (show c ++ " Tuple") (map (maybe (Node "SECTION" []) toTreeSynExpr) es)
 70 | toTreeSynExpr (c, SynExprLambda branches) = Node (show c ++ " Lambda") [Node "branches" (map toTreeSynBranch branches)]
 71 | toTreeSynExpr (c, SynExprSndSection op expr) = Node (show c ++ " Second section of operator: " ++ show op) [toTreeSynExpr expr]
 72 | toTreeSynExpr (c, SynExprPut vals branches) = Node (show c ++ " Put") [Node "vals" (map toTreeSynExpr vals), Node "branches" (map toTreeSynBranch branches)]
 73 | toTreeSynExpr (c, SynExprString s) = Node (show c ++ "String literal: " ++ show s) []
 74 | toTreeSynExpr (c, SynExprListNil) = Node (show c ++ " Empty List") []
 75 | toTreeSynExpr (c, SynExprListConss es final) = Node (show c ++ " List") (map toTreeSynExpr es ++ [Node "With final elems" [toTreeSynExpr final]])
 76 | toTreeSynExpr (c, SynExprIfThenElse cond iftrue iffalse) = Node (show c ++ " IfThenElse") [Node "Condition" [toTreeSynExpr cond], Node "If True" [toTreeSynExpr iftrue], Node "If False" [toTreeSynExpr iffalse]]
 77 | toTreeSynExpr (c, SynExprInlineUse path e) = Node (show c ++ "Inline use: " ++ show path) [toTreeSynExpr e]
 78 | toTreeSynExpr (c, SynExprBind pat me fe) = Node (show c ++ "Monadic bind to pattern: " ++ show pat) [toTreeSynExpr me, toTreeSynExpr fe]
 79 | toTreeSynExpr (c, SynExprHint hint e) = Node (show c ++ "Hinting with type") [toTreeSynTypeExpr hint, toTreeSynExpr e]
 80 | 
 81 | toTreeSynValDef (SynValDef c v s te e) = Node (show c ++ " Defining " ++ show v ++ " val: " ++ show s ++ " typehint: " ++ show te) [toTreeSynExpr e]
 82 | 
 83 | toTreeSynTypeExpr :: SyntaxTypeExpr -> Tree String
 84 | toTreeSynTypeExpr te = Node (show te) []
 85 | 
 86 | toTreeSynDataVariant (SynDataVariant c labl args) = Node (show c ++ " DataVariant: " ++ show labl) (map toTreeSynTypeExpr args)
 87 | 
 88 | toTreeSynDataDef (SynDataDef c v labl quants variants) = Node (show c ++ " Defining " ++ show v ++ " data: " ++ show labl ++ " with quantifiers: " ++ show quants)
 89 |     (map toTreeSynDataVariant variants)
 90 | 
 91 | toTreeSynRelValDecl (c, l, te) = Node (show c ++ " Declare val: " ++ show l ++ " of type: " ++ show te) []
 92 | toTreeSynModDef (ModMod c v l m) = Node (show c ++ " Defining " ++ show v ++ " module: " ++ show l) [toTreeSynMod m]
 93 | toTreeSynModDef (ModFromFile c v l f) = Node (show c ++ " Importing " ++ show v ++ " module: " ++ show l ++ " from file " ++ show f) []
 94 | toTreeSynModDef (ModUse c v p) = Node (show c ++ " Using " ++ show v ++ " module: " ++ show p) []
 95 | toTreeSynModDef (ModTypeSyn c v l qs e) = Node (show c ++ " " ++ show v ++ " type synonym: " ++ show l ++ " tyargs: " ++ show qs) [toTreeSynTypeExpr e]
 96 | toTreeSynModDef (ModValGroup vvdefs) = Node "Group of vals" (map toTreeSynValDef vvdefs)
 97 | toTreeSynModDef (ModDataGroup group) = Node "Group of datas" (map toTreeSynDataDef group)
 98 | toTreeSynModDef (ModRel c v preds l qs defs) = Node (show c ++ " " ++ show v ++ " rel definition: " ++ show l ++ " tyargs: " ++ show qs ++ " with preds: {" ++ show preds ++ "}") (map toTreeSynRelValDecl defs)
 99 | toTreeSynModDef (ModInst c qs preds head instdefs) = Node (show c ++ " Instance definition of: " ++ show head ++ " quantified with forall." ++ show qs ++ "{" ++ show preds ++ "}" ++ " with inst_val_defs") (map (\(c', l, e)->Node ("Defining: " ++ show l) [toTreeSynExpr e]) instdefs)
100 | toTreeSynModDef (ModExt c v l lext tas tr) = Node (show c ++ " Declaring " ++ show v ++ " combinator: " ++ show l ++ " which imports: " ++ show lext) [Node "with argument type" (map toTreeSynTypeExpr tas), Node "and return type" [toTreeSynTypeExpr tr]]
101 | toTreeSynMod (Module defs) = Node "Module" (map toTreeSynModDef defs)
102 | 


--------------------------------------------------------------------------------
/src/ResultT.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
 2 | module ResultT where
 3 | import Control.Monad.Trans
 4 | import Control.Monad.State
 5 | 
 6 | newtype ResultT m a = ResultT (m (Either String a))
 7 | 
 8 | runResultT :: ResultT m a -> m (Either String a)
 9 | runResultT (ResultT m) = m
10 | 
11 | instance Functor m => Functor (ResultT m) where
12 |     fmap f (ResultT m) = ResultT (fmap (fmap f) m)
13 | instance Applicative m => Applicative (ResultT m) where
14 |     pure a = ResultT (pure (Right a))
15 |     (<*>) (ResultT mf) (ResultT ma) = ResultT (fmap (<*>) mf <*> ma)
16 | instance Monad m => Monad (ResultT m) where
17 |     (>>=) (ResultT m) mf = ResultT (
18 |         do  eitherval <- m
19 |             case eitherval of
20 |                 Left s -> return $ Left s
21 |                 Right a -> let ResultT m' = mf a in m'
22 |         )
23 | instance MonadTrans ResultT where
24 |     lift m = ResultT (Right <$> m)
25 | instance MonadState s m => MonadState s (ResultT m) where
26 |     get = lift get
27 |     put = lift . put
28 |     state = lift . state
29 | instance Monad m => MonadFail (ResultT m) where
30 |     fail s = ResultT (return (Left s))
31 | 


--------------------------------------------------------------------------------
/src/SyntaxDefs.hs:
--------------------------------------------------------------------------------
 1 | module SyntaxDefs where
 2 | import HLDefs(Literal(..))
 3 | import Parser.MPCL(StdCoord)
 4 | 
 5 | data Path = Path [String] String
 6 |     deriving Show
 7 | 
 8 | data SyntaxPatternData
 9 |     = SynPatWildcard
10 |     | SynPatLiteral Literal --Il literal rappresentato
11 |     | SynPatTuple [SyntaxPattern] --Lista di elementi della n-tupla
12 |     | SynPatVariant Path [SyntaxPattern] --Nome della variante, lista di argomenti di questo
13 |     | SynPatListNil -- lista vuota
14 |     | SynPatListConss [SyntaxPattern] SyntaxPattern -- primi elementi della lista, continuazione
15 |     deriving Show
16 | type SyntaxPattern = (StdCoord, Maybe String, SyntaxPatternData) -- coordinate, eventuale assegnazione del valore (tipo haskell labl@pat) e pattern vero e proprio
17 | 
18 | data SyntaxExprData
19 |     = SynExprLiteral Literal --Valore letterale
20 |     | SynExprApp SyntaxExpr SyntaxExpr --Funzione, argomento
21 |     | SynExprLabel Path --Riferimento a label
22 |     | SynExprConstructor Path -- Riferimento a una variante
23 |     | SynExprSndSection Path SyntaxExpr -- Sezioni di tipo (OP META)
24 |     | SynExprTuple [Maybe SyntaxExpr] --Elementi della n-tupla
25 |     | SynExprLambda [SyntaxBranch] --Argomenti(anche "smontati" e con match) e valore interno
26 |     | SynExprPut [SyntaxExpr] [SyntaxBranch] --Valore da controllare, lista di pattern e i branch corrispondenti
27 |     | SynExprString String -- Costante stringa
28 |     | SynExprListNil -- lista vuota
29 |     | SynExprListConss [SyntaxExpr] SyntaxExpr -- primi elementi della lista, continuazione
30 |     | SynExprIfThenElse SyntaxExpr SyntaxExpr SyntaxExpr -- condizione, branch per true, branch per false
31 |     | SynExprInlineUse Path SyntaxExpr -- modulo da portare nel contesto, espressione
32 |     | SynExprBind SyntaxPattern SyntaxExpr SyntaxExpr --assegnazione, monade, funzione di trasformazione
33 |     | SynExprHint SyntaxTypeExpr SyntaxExpr --type hint di un'espressione
34 |     deriving Show
35 | type SyntaxExpr = (StdCoord, SyntaxExprData)
36 | 
37 | type SyntaxBranch = ([SyntaxPattern], SyntaxExpr)
38 | 
39 | data SyntaxTypeExprData
40 |     = SynTypeExprQuantifier String -- Nome del quantifier
41 |     | SynTypeExprNTuple Int -- Numero di elementi della tupla
42 |     | SynTypeExprList -- Costruttore del tipo delle liste
43 |     | SynTypeExprName Path -- Nome del tipo
44 |     | SynTypeExprApp SyntaxTypeExpr [SyntaxTypeExpr] --Tipo funzione, tipi argomento
45 |     deriving Show
46 | type SyntaxTypeExpr = (StdCoord, SyntaxTypeExprData)
47 | type SyntaxTyPred = (StdCoord, Path, [SyntaxTypeExpr])
48 | type SyntaxTySchemeExpr = (StdCoord, [String], [SyntaxTyPred], SyntaxTypeExpr)
49 | 
50 | data SyntaxValDef
51 |     = SynValDef StdCoord Visibility String (Maybe SyntaxTySchemeExpr) SyntaxExpr -- Cordinate della definizione, nome del valore, espressione
52 |     deriving Show
53 | 
54 | data SyntaxDataVariant
55 |     = SynDataVariant StdCoord String [SyntaxTypeExpr] --Coordinate della definizione, nome della variante, lista di argomenti sia come tipo concreto (da assegnare in fase di tipizzazione), sia come espressione di tipi
56 |     deriving Show
57 | 
58 | data SyntaxDataDef
59 |     = SynDataDef StdCoord Visibility String [String] [SyntaxDataVariant] --Coordinate della definizione, nome del tipo, lista di tipi argomento e quantificatori corrispondenti (da assegnare in fase di tipizzazione), varianti del tipo
60 |     deriving Show
61 | 
62 | data Visibility = Public | Private
63 |     deriving Show
64 | 
65 | type SyntaxModRelValDecl = (StdCoord, String, SyntaxTySchemeExpr)
66 | data SyntaxModDef
67 |     = ModMod StdCoord Visibility String SyntaxModule
68 |     | ModFromFile StdCoord Visibility String String
69 |     | ModUse StdCoord Visibility Path
70 |     | ModTypeSyn StdCoord Visibility String [String] SyntaxTypeExpr
71 |     | ModValGroup [SyntaxValDef]
72 |     | ModDataGroup [SyntaxDataDef]
73 |     | ModRel StdCoord Visibility [SyntaxTyPred] String [String] [SyntaxModRelValDecl] --visibilità, superrels, nome, tyvars, corpo
74 |     | ModInst StdCoord [String] [SyntaxTyPred] SyntaxTyPred [(StdCoord, String, SyntaxExpr)]-- visibilità, predicato quantificato da constraints con forall, definizioni
75 |     | ModExt StdCoord Visibility String String [SyntaxTypeExpr] SyntaxTypeExpr
76 |     deriving Show
77 | data SyntaxModule = Module [SyntaxModDef]
78 |     deriving Show
79 | 


--------------------------------------------------------------------------------
/src/Typer/KindTyper.hs:
--------------------------------------------------------------------------------
  1 | module Typer.KindTyper where
  2 | import qualified Data.Map as Map
  3 | import qualified Data.Set as Set
  4 | import Data.Maybe(fromJust, isJust)
  5 | 
  6 | import HLDefs
  7 | import Typer.TypingDefs
  8 | import Typer.MGUs
  9 | import Parser.MPCL(StdCoord)
 10 | 
 11 | substApplyKindEnv :: KindSubst -> TypingEnv -> TypingEnv
 12 | substApplyKindEnv s (TypingEnv ts ks vs cs rs) = TypingEnv ts (Map.map (kSubstApply s) ks) vs cs rs
 13 | --TODO: il pattern \(a,b)->(a, f b) si può sostituire con un fmap f
 14 | substApplyVariant :: KindSubst -> HLDataVariant -> HLDataVariant
 15 | substApplyVariant s (DataVariant c l ts) = DataVariant c l (map (\(myc,t)->(myc, kSubstApply s t)) ts)
 16 | substApplyQuants :: KindSubst -> [(String, TyQuant)] -> [(String, TyQuant)]
 17 | substApplyQuants s qs = map (\(l,q)->(l, kSubstApply s q)) qs
 18 | substApplyDataDef :: KindSubst -> HLDataDef -> HLDataDef
 19 | substApplyDataDef s (DataDef c l qs vs) = DataDef c l (substApplyQuants s qs) (map (substApplyVariant s) vs)
 20 | substApplyRelDecls :: KindSubst -> [(StdCoord, String, Qual DataType)] -> [(StdCoord, String, Qual DataType)]
 21 | substApplyRelDecls s decls = map (\(c, l, t) -> (c, l, kSubstApply s t)) decls
 22 | 
 23 | -- Funzioni di typing
 24 | getTyData :: StdCoord -> TypingEnv -> String -> TyperState Kind
 25 | getTyData c (TypingEnv _ ks _ _ _) l
 26 |     | fst $ isTupLabl l = let len = snd $ isTupLabl l in
 27 |         return $ foldr (\_->KFun KType) KType [0..len - 1]
 28 |     | otherwise = case Map.lookup l ks of
 29 |         Nothing -> fail $ show c ++ " Unbound typename: " ++ l
 30 |         Just k -> return k
 31 | 
 32 | typeTyExpr :: StdCoord -> TypingEnv -> DataType -> TyperState (KindSubst, Kind, DataType)
 33 | typeTyExpr _ env (DataCOORD c dt) = typeTyExpr c env dt
 34 | typeTyExpr c _ (DataQuant q) =
 35 |     return (nullKSubst, kind q, DataQuant q)
 36 | {-typeTyExpr env qmap (c, TypeExprTuple exprs) = do
 37 |     (s, ts) <- typeTyExprsStar env qmap exprs
 38 |     return $ (s, KType, DataTuple ts)-}
 39 | typeTyExpr c env (DataTypeName l k) = do
 40 |     k' <- getTyData c env l
 41 |     return (nullKSubst, k', DataTypeName l k')
 42 | typeTyExpr c env (DataTypeApp f a) = do
 43 |     q <- freshKind
 44 |     (s1, k1, tf) <- typeTyExpr c env f
 45 |     (s2, k2, ta) <- typeTyExpr c env (kSubstApply s1 a)
 46 |     s3 <- kindmgu c (kSubstApply s2 k1) (KFun k2 q)
 47 |     let finals = composeKSubst s3 (composeKSubst s2 s1)
 48 |         finalk = kSubstApply s3 q in
 49 |             return (finals, finalk, DataTypeApp (kSubstApply finals tf) (kSubstApply finals ta))
 50 | 
 51 | typeAndUnifyList :: Kinds e => (StdCoord -> TypingEnv -> e -> TyperState (KindSubst, Kind, e)) -> TypingEnv -> [(StdCoord, e)] -> [Kind] -> TyperState (KindSubst, [(StdCoord, e)])
 52 | typeAndUnifyList tye env [] [] = return (nullKSubst, [])
 53 | typeAndUnifyList tye env ((c,e):es) (mk:ks) = do
 54 |     (s, k, t) <- tye c env e
 55 |     s' <- kindmgu c k mk
 56 |     (s'', ts) <- typeAndUnifyList tye env (map (\(c',e')->(c', kSubstApply (composeKSubst s' s) e')) es) ks
 57 |     let s''' = composeKSubst s'' (composeKSubst s' s)
 58 |     return (s''', (c, kSubstApply s''' t):ts)
 59 | 
 60 | typeTyExprsStar :: TypingEnv -> [(StdCoord, DataType)] -> TyperState (KindSubst, [(StdCoord, DataType)])
 61 | typeTyExprsStar env ts = typeAndUnifyList typeTyExpr env ts (replicate (length ts) KType)
 62 | typeQualTypeStar :: TypingEnv -> [(StdCoord, Qual DataType)] -> TyperState (KindSubst, [(StdCoord, Qual DataType)])
 63 | typeQualTypeStar env ts = typeAndUnifyList typeQualType env ts (replicate (length ts) KType)
 64 | 
 65 | typeDataVariants :: TypingEnv -> [HLDataVariant] -> TyperState (KindSubst, [HLDataVariant])
 66 | typeDataVariants env [] = return (nullKSubst, [])
 67 | typeDataVariants env (v:vs) = do
 68 |     (s, v') <- typeDataVariant v
 69 |     (s', vs') <- typeDataVariants env vs
 70 |     return (composeKSubst s' s, substApplyVariant s' v' : vs')
 71 |     where typeDataVariant (DataVariant c l es) = do
 72 |             (s, ts) <- typeTyExprsStar env es
 73 |             return (s, DataVariant c l ts)
 74 | 
 75 | typeDataDef :: TypingEnv -> HLDataDef -> TyperState (KindSubst, HLDataDef)
 76 | typeDataDef env (DataDef c l qs vs) = do
 77 |     (s, vs') <- typeDataVariants env vs
 78 |     return (s, DataDef c l qs vs')
 79 | 
 80 | typeDataDefsLoop :: TypingEnv -> [HLDataDef] -> TyperState (KindSubst, [HLDataDef])
 81 | typeDataDefsLoop env [] = return (nullKSubst, [])
 82 | typeDataDefsLoop env (ddef:ddefs) = do
 83 |     (s, ddef') <- typeDataDef env ddef
 84 |     (s', ddefs') <- typeDataDefsLoop (substApplyKindEnv s env) ddefs
 85 |     return (composeKSubst s' s, ddef':ddefs')
 86 | 
 87 | 
 88 | addDataDefsEnv :: TypingEnv -> [HLDataDef] -> TypingEnv
 89 | addDataDefsEnv env ddefs =
 90 |     let datadeftotype (DataDef _ l qs vs) =
 91 |             foldl DataTypeApp (DataTypeName l (dataQsToKind qs)) (map (DataQuant . snd) qs)
 92 |         varianttovdata t qs (DataVariant _ l ts) =
 93 |             Map.singleton l (VariantData l (map snd qs) (map snd ts) t)
 94 |         getvariantdatas ddef@(DataDef _ l qs vs) =
 95 |             Map.unions $ map (varianttovdata (datadeftotype ddef) qs) vs
 96 |     in foldl (\(TypingEnv ts ks vs cs rs) ddef@(DataDef c l qs _)->
 97 |             TypingEnv ts (Map.insert l (dataQsToKind qs) ks) (Map.union vs (getvariantdatas ddef)) cs rs
 98 |         ) env ddefs
 99 | 
100 | unionDataDefEnv :: TypingEnv -> HLDataDef -> TyperState KindSubst
101 | unionDataDefEnv (TypingEnv _ ks _ _ _) (DataDef c l qs _) = kindmgu c (dataQsToKind qs) $ fromJust (Map.lookup l ks)
102 | 
103 | kindMonomorphize :: Kinds k => k -> KindSubst
104 | kindMonomorphize = Map.fromList . map (flip (,) KType) . Set.toList . freeKindQuants
105 | 
106 | dataMonomorphize :: HLDataDef -> KindSubst
107 | dataMonomorphize (DataDef _ _ qs _) = Map.unions $ map (kindMonomorphize . kind . snd) qs
108 | 
109 | typeDataDefGroup :: TypingEnv -> [HLDataDef] -> TyperState (KindSubst, TypingEnv, [HLDataDef])
110 | typeDataDefGroup env ddefs = let datas_env =addDataDefsEnv env ddefs in do
111 |     (s, ddefs') <- typeDataDefsLoop datas_env ddefs
112 |     substs <- mapM (unionDataDefEnv (substApplyKindEnv s datas_env)) ddefs'
113 |     let s' = foldl (flip composeKSubst) s substs
114 |         ddefs'' = map (substApplyDataDef s') ddefs'
115 |         s'' = Map.unions $ map dataMonomorphize ddefs''
116 |         ddefs''' = map (substApplyDataDef s'') ddefs''
117 |         s''' = composeKSubst s'' s'
118 |         env' = addDataDefsEnv (substApplyKindEnv s''' env) ddefs''' --TODO: è necessario? se non sbaglio l'env è senza variabili
119 |         in return (s''', env', ddefs''')
120 | 
121 | typeDataDefGroups :: TypingEnv -> [[HLDataDef]] -> TyperState (KindSubst, TypingEnv, [[HLDataDef]])
122 | typeDataDefGroups env [] = return (nullKSubst, env, [])
123 | typeDataDefGroups env (ddefs:ddefss) = do
124 |     (s, env', ddefs') <- typeDataDefGroup env ddefs
125 |     (s', env'', ddefss') <- typeDataDefGroups env' ddefss
126 |     return (composeKSubst s' s, env'', map (substApplyDataDef s') ddefs':ddefss') --TODO: è necessaro? se non sbaglio l'env è senza variabili
127 | 
128 | typeExtDefs :: TypingEnv -> [HLExtDef] -> TyperState [HLExtDef]
129 | typeExtDefs env edefs = mapM (\(ExtDef c l lext tas tr)-> do 
130 |     (_, tr':tas') <- typeTyExprsStar env (map (\mt->(c,mt)) (tr:tas))
131 |     --TODO controlla monomorfizzazione
132 |     return (ExtDef c l lext (map snd tas') (snd tr'))) edefs
133 | 
134 | extDefsInEnv :: TypingEnv -> [HLExtDef] -> TypingEnv
135 | extDefsInEnv env@(TypingEnv ts ks vs cs rs) edefs =
136 |     let ltpairs = map (\(ExtDef c l lext tas tr) -> (lext, (tas, tr))) edefs
137 |     in TypingEnv ts ks vs (Map.union (Map.fromList ltpairs) cs) rs
138 | 
139 | typeRelDecls :: TypingEnv  -> [(StdCoord, String, Qual DataType)] -> TyperState (KindSubst, [(StdCoord, String, Qual DataType)])
140 | typeRelDecls env decls = do
141 |     (s, csts) <- typeQualTypeStar env (map (\(c,l,t)->(c,t)) decls)
142 |     let s' = Map.unions $ map (\(c, t) -> kindMonomorphize $ kind t) csts
143 |     return (composeKSubst s' s, zipWith (\(_,l,_) (c, t)->(c,l, kSubstApply s' t)) decls csts)
144 | 
145 | 
146 | addRel :: String -> [TyQuant] -> [Pred] ->  [(StdCoord, String, Qual DataType)] -> TypingEnv -> TypingEnv
147 | addRel l qs preds decls (TypingEnv ts ks vs cs rs) =
148 |     let relpred = Pred l (map DataQuant qs)
149 |         declpairs = map (\(_,d,Qual ps t)->(d, Qual (relpred:ps) t)) decls
150 |         in TypingEnv ts ks vs cs (Map.insert l (RelData qs preds declpairs []) rs)
151 | 
152 | typeRelDef :: TypingEnv -> HLRelDef -> TyperState (KindSubst, TypingEnv, HLRelDef)
153 | typeRelDef env (RelDef c l qs preds decls) = do
154 |     (s, preds') <- typePreds c env preds
155 |     (s', decls') <- typeRelDecls env (substApplyRelDecls s decls)
156 |     let s'' = Map.unions $ map (kindMonomorphize . kind . kSubstApply (composeKSubst s' s)) qs
157 |         s''' = composeKSubst s'' (composeKSubst s' s)
158 |         preds'' = map (substApplyPred s''') preds'
159 |         decls'' = substApplyRelDecls s''' decls'
160 |         qs' = map (kSubstApply s''') qs
161 |         in return (s''', addRel l qs' preds'' decls'' (substApplyKindEnv s''' env), RelDef c l qs' preds'' decls'') --TODO: è necessario? se non sbaglio l'env è senza variabili.
162 | 
163 | typeRelDefs :: TypingEnv -> [HLRelDef] -> TyperState (KindSubst, TypingEnv, [HLRelDef])
164 | typeRelDefs env [] = return (nullKSubst, env, [])
165 | typeRelDefs env (reldef:reldefs) = do
166 |     (s, env', reldef') <- typeRelDef env reldef
167 |     (s', env'', reldefs') <- typeRelDefs env' reldefs
168 |     return (composeKSubst s' s, env'', reldef':reldefs') --TODO: è necessario? se non sbaglio l'env è senza variabili. TODO: se è necessario qui c'è un bug, non viene applicata la sostituzione s' a reldef'
169 | 
170 | typePred :: StdCoord -> TypingEnv -> Pred -> TyperState (KindSubst, Pred)
171 | typePred c env@(TypingEnv _ _ _ _ rs) (Pred l ts) =
172 |     case Map.lookup l rs of
173 |         Just (RelData qs _ _ _) -> do
174 |             if length qs /= length ts
175 |             then fail $ show c ++ " TypeRel: " ++ show l ++ " applied to wrong number of arguments"
176 |             else do
177 |                 (s, ts') <- typeAndUnifyList typeTyExpr env (zip (replicate (length ts) c) ts) (map kind qs)
178 |                 return (s, Pred l (map snd ts'))
179 | 
180 | typePreds :: StdCoord -> TypingEnv -> [Pred] -> TyperState (KindSubst, [Pred])
181 | typePreds c env [] = return (nullKSubst, [])
182 | typePreds c env (p:ps) = do
183 |     (s, p') <- typePred c env p
184 |     (s', ps') <- typePreds c env (map (substApplyPred s) ps)
185 |     return (composeKSubst s' s, substApplyPred s' p' : ps')
186 | 
187 | typeQualPred :: StdCoord -> TypingEnv -> Qual Pred -> TyperState (KindSubst, Qual Pred)
188 | typeQualPred c env (Qual preds p) = do
189 |     (s, p':preds') <- typePreds c env (p:preds)
190 |     return (s, Qual preds' p')
191 | 
192 | typeQualType :: StdCoord -> TypingEnv -> Qual DataType -> TyperState (KindSubst, Kind, Qual DataType)
193 | typeQualType c env (Qual preds a) = do
194 |     (s, preds') <- typePreds c env preds
195 |     (s', k, a') <- typeTyExpr c env (kSubstApply s a)
196 |     return (composeKSubst s' s, k, Qual (map (substApplyPred s') preds') a')
197 | 
198 | addInst :: Qual Pred -> TypingEnv -> TypingEnv
199 | addInst p@(Qual _ (Pred l _)) (TypingEnv ts ks vs cs rs) = TypingEnv ts ks vs cs $ Map.adjust (\(RelData qs preds decls myinsts)->RelData qs preds decls (p:myinsts)) l rs
200 | 
201 | --TODO: Sposta in altro file
202 | --TODO: Controlla qui che non ci siano qualificatori liberi nelle definizioni
203 | addRelDecls :: TypingEnv -> TypingEnv
204 | addRelDecls env@(TypingEnv ts ks vs cs rs) =
205 |     let general_decl_pairs = concat $ map (\(_, RelData _ _ lqts _)->map (\(l, qt)->(l, generalize env qt)) lqts) $ Map.toList rs
206 |         general_decls_map = Map.fromList general_decl_pairs
207 |         in TypingEnv (Map.union ts general_decls_map) ks vs cs rs
208 | 
209 | typeExprHints :: KindSubst -> TypingEnv -> HLExpr -> TyperState HLExpr
210 | typeExprHints s _ (c, t, ExprLiteral l) = return (c, t, ExprLiteral l)
211 | typeExprHints s env (c, t, ExprApp f a) = do
212 |     f' <- typeExprHints s env f
213 |     a' <- typeExprHints s env a
214 |     return (c, t, ExprApp f' a')
215 | typeExprHints s _ (c, t, ExprLabel l) = return (c, t, ExprLabel l)
216 | typeExprHints s env (c, t, ExprConstructor l es) = do
217 |     es' <- mapM (typeExprHints s env) es
218 |     return (c, t, ExprConstructor l es')
219 | typeExprHints s env (c, t, ExprCombinator l es) = do
220 |     es' <- mapM (typeExprHints s env) es
221 |     return (c, t, ExprCombinator l es')
222 | typeExprHints s env (c, t, ExprLambda l e) = do
223 |     e' <- typeExprHints s env e
224 |     return (c, t, ExprLambda l e')
225 | typeExprHints s env (c, t, ExprPut vs pses) = do
226 |     vs' <- mapM (typeExprHints s env) vs
227 |     pses' <- mapM (\(p, e) -> do {e' <- typeExprHints s env e; return (p, e')}) pses
228 |     return (c, t, ExprPut vs' pses')
229 | typeExprHints s env (c, t, ExprHint hint e) = do
230 |     (ks, k, hint') <- typeTyExpr c env (kSubstApply s hint)
231 |     if null (freeKindQuants hint') then return ()
232 |     else error $ show c ++ " KWHAT" ++ show hint' ++ show s
233 |     case k of
234 |         KType -> return ()
235 |         _ -> fail $ show c ++ " Kind of type hint should be T, instead found: " ++ show k
236 |     e' <- typeExprHints s env e
237 |     return (c, t, ExprHint hint' e')
238 | 
239 | typeKInstDef :: TypingEnv -> HLInstDef -> TyperState (KindSubst, TypingEnv, HLInstDef)
240 | typeKInstDef env (InstDef c qualhead defs) = do
241 |     (s, qualhead'@(Qual _ h@(Pred l _))) <- typeQualPred c env qualhead
242 |     let currInsts = map (\(Qual _ mp)->mp) $ insts env l
243 |     mapM_ (\i->
244 |         if isJust (matchPred h i) && isJust (matchPred i h)
245 |             then fail $ show c ++ " L'istanza " ++ show qualhead' ++ " è identica a un'altra già definita: " ++ show i
246 |             else return ()
247 |         ) currInsts
248 |     --TODO: monomorfizzazione del qualhead
249 |     defs' <- mapM (\(myc,myl,e)->do
250 |         e' <- typeExprHints s env e
251 |         return (myc, myl, e')
252 |         ) defs
253 |     return (s, addInst qualhead' env, InstDef c qualhead' defs')
254 |     --TODO: controlli vari su defs (e.g. condizioni Paterson), applica la sostituzione su defs se aggiungo i cast nelle espressioni
255 | 
256 | typeKInstDefs :: TypingEnv -> [HLInstDef] -> TyperState (KindSubst, TypingEnv, [HLInstDef])
257 | typeKInstDefs env [] = return (nullKSubst, env, [])
258 | typeKInstDefs env (instdef:instdefs) = do
259 |     (s, env', instdef') <- typeKInstDef env instdef
260 |     (s', env'', instdefs') <- typeKInstDefs env' instdefs
261 |     return (composeKSubst s' s, env'', instdef':instdefs') --TODO: è necessario? se non sbaglio l'env è senza variabili. TODO: se è necessario qui c'è un bug, non viene applicata la sostituzione s' a instdef'
262 | 
263 | -- Typing degli hint
264 | typeValDefHint :: TypingEnv -> HLValDef -> TyperState HLValDef
265 | typeValDefHint env vdef@(ValDef c l Nothing ps e) = do
266 |     e' <- typeExprHints Map.empty env e
267 |     return $ ValDef c l Nothing ps e'
268 | typeValDefHint env (ValDef c l (Just tyscheme) ps e) = do
269 |     (s, _, dt) <- typeQualType c env tyscheme
270 |     s' <- kindmgu c (kind dt) KType
271 |     let s'' = kindMonomorphize (kSubstApply s' dt)
272 |         s''' = composeKSubst s'' (composeKSubst s' s)
273 |     typerLog $ show c ++" ValDef " ++ show l ++ " has type hint: " ++ show (kSubstApply s''' dt)
274 |     e' <- typeExprHints s''' env e
275 |     return $ ValDef c l (Just (kSubstApply s''' dt)) ps e'
276 | 
277 | typeValDefHints :: TypingEnv -> [[HLValDef]] -> TyperState [[HLValDef]]
278 | typeValDefHints env vdefss = mapM (mapM $ typeValDefHint env) vdefss
279 | 


--------------------------------------------------------------------------------
/src/Typer/MGUs.hs:
--------------------------------------------------------------------------------
  1 | module Typer.MGUs where
  2 | import qualified Data.Map as Map
  3 | import qualified Data.Set as Set
  4 | import Data.Maybe(fromJust, isJust, isNothing, catMaybes)
  5 | 
  6 | import Typer.TypingDefs
  7 | import Parser.MPCL(StdCoord, dummyStdCoord)
  8 | -- MGU per i kinds
  9 | nullKSubst :: KindSubst
 10 | nullKSubst = Map.empty
 11 | 
 12 | composeKSubst :: KindSubst -> KindSubst -> KindSubst
 13 | composeKSubst s1 s2 = Map.union (Map.map (kSubstApply s1) s2) s1
 14 | 
 15 | kindQBind :: StdCoord -> KindQuant -> Kind -> TyperState KindSubst
 16 | kindQBind c kq t | t == KindQuant kq = return nullKSubst
 17 |                  | Set.member kq (freeKindQuants t) = fail $ show c ++ " Occurs check fails in kind inference: " ++ show (KindQuant kq) ++ " and " ++ show t
 18 |                  | otherwise = return $ Map.singleton kq t
 19 | 
 20 | kindmgu :: StdCoord -> Kind -> Kind -> TyperState KindSubst
 21 | kindmgu c (KindQuant kq) t = kindQBind c kq t
 22 | kindmgu c t (KindQuant kq) = kindQBind c kq t
 23 | kindmgu _ KType KType = return nullKSubst
 24 | kindmgu c (KFun a r) (KFun a' r') = do
 25 |     s1 <- kindmgu c a a'
 26 |     s2 <- kindmgu c (kSubstApply s1 r) (kSubstApply s1 r')
 27 |     return $ composeKSubst s1 s2
 28 | kindmgu c k1 k2 = fail $ show c ++ " Cannot unify kinds: " ++ show k1 ++ " and " ++ show k2
 29 | 
 30 | -- MGU per i tipi
 31 | composeSubst :: Subst -> Subst -> Subst
 32 | composeSubst sa sb = Map.union (Map.map (substApply sa) sb) sa
 33 | 
 34 | nullSubst :: Subst
 35 | nullSubst = Map.empty
 36 | 
 37 | --TODO: Sposta in altro file, sono funzioni per l'env
 38 | --tyBindRemove (TypingEnv typeEnv kindEnv) labl = TypingEnv (Map.delete labl typeEnv) kindEnv
 39 | tyBindAdd :: TypingEnv -> String -> TyScheme -> TypingEnv
 40 | tyBindAdd (TypingEnv ts ks vs cs rs) labl scheme = TypingEnv (Map.insert labl scheme ts) ks vs cs rs
 41 | 
 42 | generalize :: TypingEnv -> Qual DataType -> TyScheme
 43 | generalize env t =
 44 |     let quants = Set.toList $ Set.difference (freetyvars t) (freetyvars env)
 45 |     in TyScheme quants t
 46 | 
 47 | getInstantiationSubst :: [TyQuant] -> TyperState Subst
 48 | getInstantiationSubst qs = do
 49 |     nqs <- mapM (\(TyQuant _ k) -> freshType k) qs
 50 |     return $ Map.fromList (zip qs nqs)
 51 | 
 52 | instantiate :: TyScheme -> TyperState (Qual DataType)
 53 | instantiate scm@(TyScheme qs t) = do
 54 |     subst <- getInstantiationSubst qs
 55 |     typerLog $ "Instantiating: " ++ show scm ++ " with subst: " ++ show subst
 56 |     return $ substApply subst t
 57 | 
 58 | --Algoritmo MGU
 59 | quantBind :: MonadFail m => StdCoord -> TyQuant -> DataType -> m Subst
 60 | quantBind c q t
 61 |     | (case t of
 62 |         DataQuant q' -> q' == q
 63 |         _ -> False) = return nullSubst
 64 |     | Set.member q (freetyvars t) = fail $ show c ++ " Occurs check fails: " ++ show q ++ " into " ++ show t
 65 |     | kind q /= kind t = fail $ show c ++ " Kinds do not match in substitution: " ++ show q ++ "into " ++ show t
 66 |     | otherwise = return (Map.singleton q t)
 67 | 
 68 | mgu :: MonadFail m => StdCoord -> DataType -> DataType -> m Subst
 69 | --TODO: regole per resilienza DataCOORD?
 70 | mgu c (DataQuant q) t = quantBind c q t
 71 | mgu c t (DataQuant q) = quantBind c q t
 72 | mgu c t@(DataTypeName s k) t'@(DataTypeName s' k') =
 73 |     if s == s'  && k == k' then return nullSubst else fail $ show c ++ " Could not unify typenames: " ++ show t ++ " and " ++ show t'
 74 | mgu c (DataTypeApp f a) (DataTypeApp f' a') = do
 75 |     s <- mgu c f f'
 76 |     s' <- mgu c (substApply s a) (substApply s a')
 77 |     return (composeSubst s' s)
 78 | mgu c t t' =
 79 |     fail $ show c ++ " Could not unify types: " ++ show t ++ " and " ++ show t'
 80 | 
 81 | liftUnionList :: MonadFail m => (StdCoord -> DataType -> DataType -> m Subst) -> StdCoord -> [(DataType, DataType)] -> m Subst
 82 | liftUnionList m c tts =
 83 |     foldl (\m_subst (dta, dtb) -> do{
 84 |         s <- m_subst;
 85 |         s' <- m c (substApply s dta) (substApply s dtb);
 86 |         return $ composeSubst s' s
 87 |     }) (return nullSubst) tts
 88 | 
 89 | --TODO: Da testare
 90 | match :: MonadFail m => StdCoord -> DataType -> DataType -> m Subst
 91 | match c src tgt = do
 92 |     s <- mgu c src tgt
 93 |     let
 94 |         keyss = Set.fromList $ map fst $ Map.toList s
 95 |         frees = freetyvars tgt
 96 |         transformsInTgt = Set.intersection keyss frees
 97 |         in if null transformsInTgt then return s
 98 |         else fail $ show c ++ " Could not match type: " ++ show src ++ " into: " ++ show tgt
 99 | 
100 | liftUnionPred :: MonadFail m => (StdCoord -> DataType -> DataType -> m Subst) -> StdCoord -> Pred -> Pred -> m Subst
101 | liftUnionPred m c (Pred l ts) (Pred l' ts')
102 |     | l == l' = liftUnionList m c (zip ts ts')
103 |     | otherwise = fail $ show c ++ " Rel labels differ: " ++ l ++ " and " ++ l'
104 | 
105 | mguPred, matchPred :: Pred -> Pred -> Maybe Subst
106 | mguPred = liftUnionPred mgu dummyStdCoord
107 | matchPred = liftUnionPred match dummyStdCoord
108 | 
109 | data ChooseInstRes --TODO: Questa interfaccia non è corretta
110 |     = OneMatch [Pred]
111 |     | MultipleMatches [InstData]
112 |     | NoUnifiers
113 |     | PossibleUnifiers [InstData]
114 |     deriving Show
115 | 
116 | insts :: TypingEnv -> String -> [InstData]
117 | insts (TypingEnv _ _ _ _ rels) l =
118 |     let (RelData _ _ _ idatas) = fromJust $ Map.lookup l rels in idatas
119 | 
120 | supers :: TypingEnv -> Pred -> [Pred]
121 | supers (TypingEnv _ _ _ _ rels) (Pred l ts) =
122 |     let (RelData qs ps _ _) = fromJust $ Map.lookup l rels
123 |         s = Map.fromList (zip qs ts)
124 |     in map (substApply s) ps
125 | 
126 | bySuper :: TypingEnv -> Pred -> [Pred]
127 | bySuper env p = p:concat [bySuper env p' | p' <- supers env p]
128 | 
129 | chooseInst :: TypingEnv -> Pred -> ChooseInstRes
130 | chooseInst env p@(Pred l ts) =
131 |     let matchInsts = getBestUniInsts matchPred
132 |         mguInsts = getBestUniInsts mguPred
133 |         in if null mguInsts then NoUnifiers
134 |         else case matchInsts of
135 |             [] -> PossibleUnifiers mguInsts --No matching instances, failure?
136 |             [i@(Qual ps h)] -> --Se è l'unica instance specifica
137 |                 if elem i mguInsts then case matchPred h p of--Se è tra i più specifici di tutte le possibili instances
138 |                     --TODO: elem controlla tutto il predicato qualificato, forse dovrebbe ignorare i qualificatori
139 |                     Just u -> OneMatch (map (substApply u) ps) --Allora prendi i constraint
140 |                 else PossibleUnifiers mguInsts --altrimenti niente, i constraint potrebbero cambiare con un tipo più specifico
141 |             ps -> MultipleMatches ps --Ci sono più instance specifiche
142 |     where
143 |         reduceToSpecifics :: [Qual Pred] -> [Qual Pred] -> [Qual Pred]
144 |         reduceToSpecifics sqs [] = sqs
145 |         reduceToSpecifics sqs (q@(Qual _ h):qs) =
146 |             let areThereMoreSpecific = any (\(Qual _ h') ->
147 |                         isJust (matchPred h h') && isNothing (matchPred h' h)
148 |                     ) (sqs ++ qs)
149 |                 in if areThereMoreSpecific
150 |                     then reduceToSpecifics sqs qs
151 |                     else reduceToSpecifics (q:sqs) qs
152 |         tryInstUnion m q@(Qual _ h) = do
153 |             u <- m h p
154 |             Just q
155 |         getBestUniInsts m  =
156 |             let uniInsts = catMaybes [tryInstUnion m it | it <- insts env l]
157 |                 in reduceToSpecifics [] uniInsts
158 | 
159 | entail :: TypingEnv -> [Pred] -> Pred -> Bool
160 | entail env ps p
161 |     = any (elem p . bySuper env) ps
162 |     || case chooseInst env p of
163 |         OneMatch qs -> all (entail env ps) qs
164 |         _ -> False
165 | 
166 | simplify :: TypingEnv -> [Pred] -> [Pred]
167 | simplify env = loop []
168 |     where
169 |         loop sps [] = sps
170 |         loop sps (p:ps) | entail env (sps ++ ps) p = loop sps ps
171 |                         | otherwise = loop (p:sps) ps
172 | 
173 | toHnfs :: MonadFail m => StdCoord -> TypingEnv -> [Pred] -> m [Pred]
174 | toHnfs c env ps = do
175 |         pss <- mapM (toHnf c env) ps
176 |         return (concat pss)
177 | toHnf :: MonadFail m => StdCoord -> TypingEnv -> Pred -> m [Pred]
178 | toHnf c env p = case chooseInst env p of
179 |     OneMatch ps -> toHnfs c env ps
180 |     NoUnifiers -> fail $ show c ++ " No compatible instance for: " ++ show p ++ "\n    Instances for rel: " ++ show (insts env $ (\(Pred l _)->l) p)
181 |     _ -> return [p] -- TODO: In certi casi anche qui serve un fail (quando per esempio è sicuramente impossibile decidere l'instance più specifica)--TODO: forse bisogna usare la regola isHnf
182 | reduce :: MonadFail m => StdCoord -> TypingEnv -> [Pred] -> m [Pred]
183 | reduce c env ps = do
184 |     qs <- toHnfs c env ps
185 |     return (simplify env qs)
186 | 
187 | --TODO: Questa funzione tiene in conto anche delle variabili libere nell'env, dovrebbe essere la cosa giusta ma non ne sono del tutto sicuro
188 | checkAmbiguousQual :: (Types t, Show t) => StdCoord -> TypingEnv -> Qual t -> TyperState ()
189 | checkAmbiguousQual c env (Qual ps t) =
190 |     let freepsvars = Set.unions $ map freetyvars ps
191 |         freedatavars = Set.union (freetyvars t) (freetyvars env)
192 |         difference = Set.difference freepsvars freedatavars
193 |         in if null difference then return ()
194 |         else fail $ show c ++ " Qualifier is ambiguous, it qualifies over type variables: " ++ show (Set.toList difference) ++ " in: " ++ show (Qual ps t)
195 | 


--------------------------------------------------------------------------------
/src/Typer/TypeTyper.hs:
--------------------------------------------------------------------------------
  1 | module Typer.TypeTyper where
  2 | import qualified Data.Map as Map
  3 | 
  4 | import HLDefs
  5 | import Typer.TypingDefs
  6 | import Typer.MGUs
  7 | import Parser.MPCL (StdCoord)
  8 | 
  9 | getVariantData :: TypingEnv -> String -> TyperState VariantData
 10 | getVariantData (TypingEnv _ _ vs _ _) l
 11 |     | fst $ isTupLabl l = let len = snd $ isTupLabl l in do
 12 |             qs <- mapM (\_->newTyQuant KType) [1..len]
 13 |             let ts = map DataQuant qs in return $ VariantData l qs ts (buildTupType ts)
 14 |     | otherwise = case Map.lookup l vs of
 15 |         --Nothing -> fail $ show c ++ " Unbound constructor: " ++ l
 16 |         Just vdata -> return vdata
 17 | 
 18 | -- Funzioni di typing
 19 | typeLit :: Literal -> DataType
 20 | typeLit (LitInteger _) = intT
 21 | typeLit (LitFloating _) = fltT
 22 | typeLit (LitCharacter _) = chrT
 23 | 
 24 | -- Funzioni per i pattern, DA RICONTROLLARE E COMPLETARE
 25 | typePat :: TypingEnv -> HLPattern -> TyperState (DataType, HLPattern)
 26 | typePat _ (c, _, ml, PatWildcard) = do
 27 |     t <- freshType KType
 28 |     return (t, (c, t, ml, PatWildcard))
 29 | typePat _ (c, _, ml, PatLiteral lit) =
 30 |     let t = typeLit lit in
 31 |         return (t, (c, t, ml, PatLiteral lit))
 32 | typePat env (c, _, ml, PatVariant v ps) = do
 33 |     (VariantData _ qs vts dt) <- getVariantData env v
 34 |     if length ps /= length vts then fail $ show c ++ " Constructor is applied to wrong number of arguments"
 35 |     else do
 36 |         s <- getInstantiationSubst qs
 37 |         (pts, ps') <- typePats env ps
 38 |         s' <- liftUnionList mgu c $ zip (map (substApply s) vts) pts --TODO questo in teoria controlla la validità degli argomenti, va rifatto, forse serve un algoritmo di unificazione "one-way"
 39 |         typerLog $ show c ++ " Variante:"++v++" di tipo-istanza:"++show (substApply s dt) ++ " unificato in:" ++ show (substApply s' (substApply s dt))
 40 |         let newsubst = composeSubst s' s
 41 |             dt' = substApply newsubst dt
 42 |         return (dt', (c, dt', ml, PatVariant v (substApplyPats newsubst ps')))
 43 | typePats :: TypingEnv -> [HLPattern] -> TyperState ([DataType], [HLPattern])
 44 | typePats env pats = unzip <$> mapM (typePat env) pats
 45 | 
 46 | --TODO Da testare
 47 | patListPatVarsInEnv :: (DataType -> TyScheme) -> TypingEnv -> [HLPattern] -> [DataType] -> TyperState TypingEnv
 48 | patListPatVarsInEnv gf env ps ts = foldl (\me (p, t)->do{e<-me; patVarsInEnv gf e p t}) (return env) (zip ps ts)
 49 | 
 50 | innerPatVarsInEnv :: (DataType -> TyScheme) -> StdCoord -> TypingEnv -> HLPatternData -> DataType -> TyperState TypingEnv
 51 | innerPatVarsInEnv _ _ env PatWildcard dt = return env
 52 | innerPatVarsInEnv _ _ env (PatLiteral _) dt = return env
 53 | innerPatVarsInEnv gf c env (PatVariant v ps) dt = do
 54 |     (VariantData _ qs vts vdt) <- getVariantData env v
 55 |     s <- mgu c vdt dt --TODO: Forse serve un algoritmo di unificazione "one-way"
 56 |     patListPatVarsInEnv gf env ps (map (substApply s) vts)
 57 | 
 58 | -- TODO: potrei usare il tipo nel pattern se opportunamente sostituito
 59 | patVarsInEnv :: (DataType -> TyScheme) -> TypingEnv -> HLPattern -> DataType -> TyperState TypingEnv
 60 | patVarsInEnv gf env (c, _, Nothing, pdata) dt = innerPatVarsInEnv gf c env pdata dt
 61 | patVarsInEnv gf env (c, _, Just labl, pdata) dt =
 62 |     let env' = tyBindAdd env labl (gf dt)
 63 |     in innerPatVarsInEnv gf c env' pdata dt
 64 | 
 65 | -- Funzioni per le espressioni
 66 | typeExprs :: TypingEnv -> [HLExpr] -> TyperState (Subst, [Pred], [DataType], [HLExpr])
 67 | typeExprs env [] = return (nullSubst, [], [], [])
 68 | typeExprs env (e:es) = do
 69 |     (s, ps, t, e') <- typeExpr env e
 70 |     (s', ps', ts, es') <- typeExprs (substApply s env) es
 71 |     return (composeSubst s' s, ps ++ ps', t:ts, e':es')
 72 | typeConsAbstraction :: StdCoord -> TypingEnv -> [DataType] -> [HLExpr] -> TyperState (Subst, [Pred], [HLExpr])
 73 | typeConsAbstraction c env argts es = --NOTE: Funziona solo se i combinatori sono monomorfici
 74 |     if length argts /= length es then
 75 |         fail $ show c ++ " Constructor is applied to wrong number of arguments" --TODO: generalizza messaggio di errore?
 76 |     else do
 77 |     (s, ps, ts, es') <- typeExprs env es
 78 |     s' <- liftUnionList mgu c (zip (map (substApply s) argts) ts)
 79 |     let s'' = composeSubst s' s
 80 |     return (s'', map (substApply s'') ps, es')
 81 | 
 82 | typeExprInternal :: TypingEnv -> HLExpr -> TyperState (Subst, [Pred], DataType, HLExpr)
 83 | typeExprInternal _ (c, _, ExprLiteral lit) = do
 84 |     let dt = typeLit lit in return (nullSubst, [], dt, (c, dt, ExprLiteral lit))
 85 | typeExprInternal (TypingEnv env _ _ _ _) (c, _, ExprLabel labl) =
 86 |     case Map.lookup labl env of
 87 |         --Nothing -> fail $ show c ++ " Unbound variable: " ++ labl
 88 |         Just scheme -> do
 89 |                           typerLog $ show c ++ " LABEL:" ++ labl ++ " of scheme:" ++ show scheme
 90 |                           Qual ps t <- instantiate scheme
 91 |                           return (nullSubst, ps, t, (c, t, ExprLabel labl))
 92 | typeExprInternal env (c, _, ExprConstructor l es) = do
 93 |     (VariantData _ qs argts dt) <- getVariantData env l
 94 |     is <- getInstantiationSubst qs
 95 |     let argts' = map (substApply is) argts
 96 |         dt' = substApply is dt
 97 |     (s, ps, es') <- typeConsAbstraction c env argts' es
 98 |     let dt'' = substApply s dt'
 99 |     return (s, ps, dt'', (c, dt'', ExprConstructor l es'))
100 | typeExprInternal env@(TypingEnv _ _ _ cs _) (c, _, ExprCombinator l es) = do
101 |     case Map.lookup l cs of
102 |         Just (tas, tr) -> do
103 |             (s, ps, es') <- typeConsAbstraction c env tas es
104 |             let tr' = substApply s tr
105 |             return (s, ps, tr', (c, tr', ExprCombinator l es'))
106 | typeExprInternal env (c, _, ExprApp f a) = do
107 |     q <- freshType KType
108 |     (s1, ps1, t1, f') <- typeExpr env f
109 |     (s2, ps2, t2, a') <- typeExpr (substApply s1 env) a
110 |     s3 <- mgu c (substApply s2 t1) (buildFunType t2 q)
111 |     let finals = composeSubst s3 (composeSubst s2 s1)
112 |         finalt = substApply finals q
113 |         finalps = map (substApply finals) (ps1++ps2)
114 |     -- typerLog $ show c ++" TYPINGAPP s:" ++ show finals ++ " Call:" ++ show t1 ++ " with:" ++ show t2
115 |     return (finals, finalps, finalt, (c, finalt, ExprApp f' a'))
116 | -- TODO: Da qui in poi controllare bene, non so se è giusto
117 | typeExprInternal env (c, _, ExprLambda labl expr) = do
118 |     argt <- freshType KType
119 |     let env' = tyBindAdd env labl (TyScheme [] $ Qual [] argt)
120 |     (s, ps, t, e) <- typeExpr env' expr
121 |     let finaldt = buildFunType (substApply s argt) t
122 |         in return (s, ps, finaldt, (c, finaldt, ExprLambda labl e))
123 | typeExprInternal env (c, _, ExprPut vals pses) = do
124 |     (s, ps, tvals, vals') <- typeExprs env vals
125 |     (s', tvals', pses') <- unifyPats (substApply s env) tvals pses
126 |     let temps = composeSubst s' s
127 |     tempt <- freshType KType--TODO GIUSTO IL FRESH?
128 |     typerLog $ show c ++ " PUT temps:" ++ show temps ++ " ps:" ++ show (map (substApply temps) ps) ++ " tval:" ++ show tvals'
129 |     (s'', ps'', texpr, pses'') <- typePutBranches (substApply temps env) (map (substApply temps) ps) tvals' tempt pses'
130 |     typerLog $ show c ++ " PUT" ++ show tempt ++ " tval:" ++ show tvals' ++ " texpr:"++show texpr
131 |     let finals = composeSubst s'' temps
132 |         finalps = map (substApply finals) (ps++ps'')
133 |         finalt = substApply finals texpr
134 |         in return (finals, finalps, finalt, (c, finalt, ExprPut vals' pses''))
135 | typeExprInternal env (c, _, ExprHint hint e) = do
136 |     (s, ps, t, e') <- typeExpr env e
137 |     s' <- match c t hint
138 |     let t' = substApply s' t
139 |     return (composeSubst s' s, map (substApply s') ps, t', (c, t', ExprHint hint e'))
140 | 
141 | typeExpr :: TypingEnv -> HLExpr -> TyperState (Subst, [Pred], DataType, HLExpr)
142 | typeExpr env expr@(c, _, _) = do
143 |     (s, ps, t, expr') <- typeExprInternal env expr
144 |     ps' <- reduce c env ps
145 |     --checkAmbiguousQual c env (Qual ps' t)
146 |     return (s, ps', t, expr')
147 | 
148 | --Funzioni helper per putexpr
149 | unifyPats :: TypingEnv -> [DataType] -> [([HLPattern], HLExpr)] -> TyperState (Subst, [DataType], [([HLPattern], HLExpr)])
150 | unifyPats _ ts [] = return (nullSubst, ts, [])
151 | unifyPats env ts ((pats, e@(c, _, _)):branches)
152 |     | length pats /= length ts = fail $ show c ++ " Match has " ++ show (length pats) ++ " patterns, but matches on " ++ show (length ts) ++ " expressions"
153 |     | otherwise = do
154 |         (tpats, pats') <- typePats env pats
155 |         s <- liftUnionList mgu c (zip ts tpats)
156 |         (s', ts', branches') <- unifyPats (substApply s env) (map (substApply s) ts) branches
157 |         return (composeSubst s' s, ts', (pats', e):branches')
158 | 
159 | typePutBranches :: TypingEnv -> [Pred] -> [DataType] -> DataType -> [([HLPattern], HLExpr)] -> TyperState (Subst, [Pred], DataType, [([HLPattern], HLExpr)])
160 | typePutBranches _ _ _ texpr [] = return (nullSubst, [], texpr, [])
161 | typePutBranches env pspat tpats texpr ((pats, expr@(c, _, _)):branches) = do
162 |     typerLog $ " PUTBRANCH_SRT tpat:" ++ show tpats ++ " texpr:" ++ show texpr
163 |     env' <- patListPatVarsInEnv (TyScheme [] . Qual pspat) env pats tpats
164 |     (s, psexpr, texpr', expr') <- typeExpr env' expr
165 |     typerLog $ " PUTBRANCH_TEX texpr: " ++ show texpr ++ " texpr':" ++ show texpr'
166 |     s' <- mgu c (substApply s texpr') (substApply s texpr) --TODO: è giusto l'ordine (texpr' prima)?
167 |     let mys = composeSubst s' s
168 |     typerLog $ " PUTBRANCH_MYS: " ++ show mys
169 |     (s'', psbranches, tfinal, others) <- typePutBranches (substApply mys env) (map (substApply mys) pspat) (map (substApply mys) tpats) (substApply s' texpr) branches
170 |     typerLog $ " PUTBRANCH_END tfinal:" ++ show tfinal ++ " s:" ++ show (composeSubst s'' mys)
171 |     let finals = composeSubst s'' mys
172 |         finalps = map (substApply finals) (psexpr++psbranches)
173 |         in return (finals, finalps, tfinal, (pats, expr'):others)
174 | 
175 | --Sostituzioni su espressioni e definizioni, eseguite solo nel toplevel (riduci ancora il numero di applicazioni)
176 | substApplyPat :: Subst -> HLPattern -> HLPattern
177 | substApplyPat s (c, dt, ml, PatWildcard) = (c, substApply s dt, ml, PatWildcard)
178 | substApplyPat s (c, dt, ml, PatLiteral lit) = (c, substApply s dt, ml, PatLiteral lit)
179 | substApplyPat s (c, dt, ml, PatVariant v ps) = (c, substApply s dt, ml, PatVariant v (substApplyPats s ps))
180 | 
181 | substApplyPats :: Subst -> [HLPattern] -> [HLPattern]
182 | substApplyPats = map . substApplyPat
183 | 
184 | substApplyExpr :: Subst -> HLExpr -> HLExpr
185 | substApplyExpr s (c, dt, ExprLiteral l) = (c, substApply s dt, ExprLiteral l)
186 | substApplyExpr s (c, dt, ExprApp f a) = (c, substApply s dt, ExprApp (substApplyExpr s f) (substApplyExpr s a))
187 | substApplyExpr s (c, dt, ExprLabel l) = (c, substApply s dt, ExprLabel l)
188 | substApplyExpr s (c, dt, ExprConstructor l es) = (c, substApply s dt, ExprConstructor l (map (substApplyExpr s) es))
189 | substApplyExpr s (c, dt, ExprCombinator l es) = (c, substApply s dt, ExprCombinator l (map (substApplyExpr s) es))
190 | substApplyExpr s (c, dt, ExprLambda p e) = (c, substApply s dt, ExprLambda p (substApplyExpr s e))
191 | substApplyExpr s (c, dt, ExprPut vs psandes) = (c, substApply s dt, ExprPut (map (substApplyExpr s) vs) (map (\(p, e) -> (substApplyPats s p, substApplyExpr s e)) psandes))
192 | substApplyExpr s (c, dt, ExprHint hint e) = (c, substApply s dt, ExprHint hint (substApplyExpr s e))
193 | 
194 | substApplyValDef :: Subst -> HLValDef -> HLValDef
195 | substApplyValDef s (ValDef c l t ps e) = ValDef c l t (map (substApply s) ps) (substApplyExpr s e)
196 | 
197 | --Funzioni per le definizioni globali
198 | 
199 | quantifiedValDefEnv :: TypingEnv -> [HLValDef] -> TyperState TypingEnv
200 | quantifiedValDefEnv init_env [] = return init_env
201 | quantifiedValDefEnv env (ValDef c l mhint _ _:vdefs) = do
202 |     t <- case mhint of
203 |         Nothing -> fmap (Qual []) (freshType KType)
204 |         Just hint -> return hint
205 |     typerLog $ show c ++ " Binding label: " ++ show l ++ " to temporary type: " ++ show t
206 |     let env' = tyBindAdd env l (TyScheme [] t)
207 |     quantifiedValDefEnv env' vdefs
208 | 
209 | typeValDefsLoop :: TypingEnv -> [HLValDef] -> TyperState (Subst, [HLValDef])
210 | typeValDefsLoop _ [] = return (nullSubst, [])
211 | typeValDefsLoop env (vdef:vdefs) = do
212 |     (s, vdef') <- typeValDef vdef
213 |     (s', vdefs') <- typeValDefsLoop (substApply s env) (map (substApplyValDef s) vdefs)
214 |     return (composeSubst s' s, substApplyValDef s' vdef':vdefs')
215 |     where typeValDef (ValDef c l t _ e) = do --TODO: Qui dimentico i predicati già presenti, dovrebbero essere spazzatura dalle tipizzazioni precedenti
216 |             (s, ps, dt, e') <- typeExpr env e
217 |             typerLog $ "typed valdef: " ++ l ++ " with type: " ++ show (Qual ps dt) ++ " and subst: " ++ show s
218 |             return (s, ValDef c l t ps e')
219 | 
220 | addValDefsEnv :: TypingEnv -> [HLValDef] -> TypingEnv
221 | addValDefsEnv env vdefs = foldl
222 |     (\e (ValDef _ l _ ps (_, t, _))->
223 |             tyBindAdd e l (generalize e (Qual ps t))
224 |         ) env vdefs
225 | 
226 | unionValDefsEnv :: TypingEnv -> [HLValDef] -> TyperState Subst
227 | unionValDefsEnv env [] = return nullSubst
228 | unionValDefsEnv env@(TypingEnv ts _ _ _ _) (vdef:vdefs) = do
229 |     s <- unionValDefEnv vdef
230 |     s' <- unionValDefsEnv (substApply s env) (map (substApplyValDef s) vdefs)
231 |     return (composeSubst s' s)
232 |     where unionValDefEnv (ValDef c l _ ps (_, t, _)) = do
233 |             Qual ps' tFromEnv <- case Map.lookup l ts of --TODO: Sto dimenticando i predicati, è giusto?
234 |                 Just scheme -> instantiate scheme
235 |             s <- mgu c t tFromEnv
236 |             typerLog $ "union of env and vdef "++ l ++": " ++ show s
237 |             return s
238 | 
239 | checkHintType :: StdCoord -> TypingEnv -> DataType -> DataType -> TyperState Subst
240 | checkHintType c env typehint typet = match c typet typehint
241 | 
242 | checkHintPreds :: StdCoord -> TypingEnv -> [Pred] -> [Pred] -> TyperState ()
243 | checkHintPreds c env pshint pst = mapM_ checkHintPred pst
244 |     where checkHintPred pt = if entail env pshint pt
245 |             then return ()
246 |             else fail $ show c ++ " Type hint qualifiers: " ++ show pshint ++ " do not entail constraint: " ++ show pt
247 | 
248 | checkValDefsHint :: TypingEnv -> [HLValDef] -> TyperState Subst
249 | checkValDefsHint _ [] = return nullSubst
250 | checkValDefsHint env (ValDef c l Nothing _ _:vdefs) = checkValDefsHint env vdefs
251 | checkValDefsHint env@(TypingEnv ts _ _ _ _) (ValDef c l (Just (Qual _ hint)) ps (_, t, _):vdefs) = do
252 |     s <- checkHintType c env hint t
253 |     s' <- checkValDefsHint (substApply s env) (map (substApplyValDef s) vdefs)
254 |     return (composeSubst s' s)
255 | 
256 | checkValDefsHintPreds :: TypingEnv -> [HLValDef] -> TyperState [HLValDef]
257 | checkValDefsHintPreds env vdefs = mapM checkValDefHintPreds vdefs
258 |     where checkValDefHintPreds vdef@(ValDef _ _ Nothing _ _) = return vdef
259 |           checkValDefHintPreds (ValDef c l hint@(Just (Qual pshint thint)) pst e) = do
260 |             checkHintPreds c env pshint pst
261 |             return $ ValDef c l hint pshint e
262 | 
263 | -- TODO: Quali di queste sostituzioni possono essere eliminate? (probabilmente quelle introdotte da typeValDefsLoop...)
264 | -- TODO: Mi sa che questa funzione non dovrebbe restituire una sostituzione
265 | typeValDefGroup :: TypingEnv -> [HLValDef] -> TyperState (Subst, TypingEnv, [HLValDef])
266 | typeValDefGroup env vdefs = do
267 |     vars_env <- quantifiedValDefEnv env vdefs
268 |     (s, vdefs') <- typeValDefsLoop vars_env vdefs
269 |     s' <- unionValDefsEnv (substApply s vars_env) vdefs'
270 |     s'' <- checkValDefsHint (substApply s' vars_env) (map (substApplyValDef s') vdefs') --TODO: La posizione è giusta?
271 |     let sfinal = composeSubst s'' (composeSubst s' s)
272 |         vdefs'' = map (substApplyValDef sfinal) vdefs'
273 |         ps = concatMap (\(ValDef _ _ _ myps _) -> myps) vdefs''
274 |         vdefs''' = map (\(ValDef c l h _ e)->ValDef c l h ps e) vdefs''
275 |             --typerLog $ "Final ValDef Subst: " ++ show sfinal
276 |     mapM_ (\(ValDef c _ _ ps' (_, t, _))->checkAmbiguousQual c env (Qual ps' t)) vdefs'''
277 |     vdefs'''' <- checkValDefsHintPreds env vdefs'''
278 |     let env' = addValDefsEnv (substApply sfinal env) vdefs''''
279 |     if null $ freetyvars env' then return (sfinal, env', vdefs'''')
280 |     else fail $ show ((\(ValDef c _ _ _ _)->c) $ head vdefs''') ++ " Ci sono delle variabili di tipo libere dopo la tipizzazione di un gruppo di valdef"
281 | 
282 | typeValDefGroups :: TypingEnv -> [[HLValDef]] -> TyperState (Subst, TypingEnv, [[HLValDef]])
283 | typeValDefGroups env [] = return (nullSubst, env, [])
284 | typeValDefGroups env (vdefs:vdefss) = do
285 |     (s, env', vdefs') <- typeValDefGroup env vdefs --TODO: forse anche questa sostituzione dopo averla applicata al contesto può essere eliminata
286 |     (s', env'', vdefss') <- typeValDefGroups env' vdefss
287 |     return (composeSubst s' s, env'', map (substApplyValDef s') vdefs':vdefss')
288 | 
289 | typeInstDef :: TypingEnv -> HLInstDef -> TyperState HLInstDef
290 | typeInstDef env@(TypingEnv _ _ _ _ rs) (InstDef c qh@(Qual ps h@(Pred l ts)) defs) =
291 |     case Map.lookup l rs of
292 |         Just (RelData qs preds decls _) -> do --TODO: controlla validità dei preds
293 |             let instSubst = Map.fromList $ zip qs ts
294 |                 substdecls = map (\(ld, td)->(ld, substApply instSubst td)) decls
295 |             defs' <- typeInstMembers (Map.fromList substdecls) [] defs
296 |             -- TODO: Forse questo controllo va spostato da qualche altra parte (check superrel)
297 |             mapM_ ((\p ->
298 |                 if entail env ps p
299 |                     then return ()
300 |                     else fail $ show c ++ " L'istanza " ++ show qh ++ " non verifica il predicato: " ++ show p
301 |                 ) . substApply instSubst) preds
302 |             return $ InstDef c qh defs'
303 |     where typeInstMembers declmap final [] = return $ reverse final
304 |           typeInstMembers declmap final ((dc,dl,e):members) =
305 |                 case Map.lookup dl declmap of
306 |                     Just (Qual dps dt) -> do
307 |                         (s, eps, te, e') <- typeExpr env e
308 |                         s' <- checkHintType dc env dt te
309 |                         let finals = composeSubst s' s
310 |                             finale = substApplyExpr finals e'
311 |                         checkHintPreds dc env (ps ++ dps) (map (substApply s') eps)
312 |                         typeInstMembers declmap ((dc, dl, finale):final) members
313 | typeInstDefs :: TypingEnv -> [HLInstDef] -> TyperState [HLInstDef]
314 | typeInstDefs env = mapM (typeInstDef env)
315 | 


--------------------------------------------------------------------------------
/src/Typer/Typer.hs:
--------------------------------------------------------------------------------
 1 | module Typer.Typer (typeBlockProgram) where
 2 | import qualified Data.Map as Map
 3 | 
 4 | import HLDefs
 5 | import Typer.TypingDefs
 6 | import Typer.KindTyper
 7 | import Typer.TypeTyper
 8 | import Typer.VariantComplete
 9 | 
10 | --Definizioni builtin per Typing
11 | builtinTypingTypes :: [(String, Kind)]
12 | builtinTypingTypes =
13 |     [   ("->#BI", KFun KType (KFun KType KType))
14 |     ,   ("Int#BI", KType)
15 |     ,   ("Flt#BI", KType)
16 |     ,   ("Chr#BI", KType)
17 |     ,   ("Bool#BI", KType)
18 |     ,   ("RealWorld_#BI", KType)
19 |     ]
20 | builtinTypingVars :: [VariantData]
21 | builtinTypingVars =
22 |     [   VariantData "RealWorld_" [] [] realworldT
23 |     ,   VariantData "True" [] [] boolT
24 |     ,   VariantData "False" [] [] boolT
25 |     ]
26 | initTypingEnv :: TypingEnv
27 | initTypingEnv = TypingEnv Map.empty (Map.fromList builtinTypingTypes) (Map.fromList $ map (\v@(VariantData l _ _ _)->(l,v)) builtinTypingVars) Map.empty Map.empty
28 | 
29 | --Programma typer
30 | typeBlockProgram :: BlockProgram -> TyperState (TypingEnv, BlockProgram)
31 | typeBlockProgram (BlockProgram ddefgroups reldefs extdefs vdefgroups instdefs) = do
32 |     (ks, e, ddefgroups') <- typeDataDefGroups initTypingEnv ddefgroups
33 |     extdefs' <- typeExtDefs e extdefs
34 |     let e' = extDefsInEnv e extdefs'
35 |     vdefgroups' <- completeVariantValDefGroups e' vdefgroups
36 |     instdefs' <- completeVariantInstDefs e' instdefs
37 |     (ks', e'', reldefs') <- typeRelDefs e' reldefs
38 |     (ks'', e''', instdefs'') <- typeKInstDefs (addRelDecls e'') instdefs'
39 |     vdefgroups'' <- typeValDefHints e'' vdefgroups'
40 |     (ts, e'''', vdefgroups''') <- typeValDefGroups e''' vdefgroups''
41 |     instdefs''' <- typeInstDefs e'''' instdefs''
42 |     typerLog $ "Final kind substitution (datas): " ++ show ks
43 |     typerLog $ "Final kind substitution (rels): " ++ show ks'
44 |     typerLog $ "Final kind substitution (insts): " ++ show ks''
45 |     typerLog $ "Final type substitution: " ++ show ts
46 |     typerLog $ "Final env: " ++ show e''''
47 |     typerLog $ "Final env freetyvars: " ++ show (freetyvars e'''')
48 |     return (e'''', BlockProgram ddefgroups' reldefs' extdefs' vdefgroups''' instdefs''')
49 | 


--------------------------------------------------------------------------------
/src/Typer/TypingDefs.hs:
--------------------------------------------------------------------------------
  1 | module Typer.TypingDefs where
  2 | import Control.Monad.State
  3 | import qualified Data.Map as Map
  4 | import qualified Data.Set as Set
  5 | 
  6 | import CompDefs
  7 | import ResultT
  8 | import Parser.MPCL(StdCoord)
  9 | 
 10 | type KindQuant = Int
 11 | 
 12 | data Kind
 13 |     = KindNOTHING --Kind temporaneo generato dal parser
 14 |     | KType
 15 |     | KindQuant KindQuant --Questo l'ho tolto perché alla fine dell'inferenza tutti i kind liberi diventano *
 16 |     | KFun Kind Kind
 17 |     deriving Eq
 18 | 
 19 | data DataType
 20 |     = DataNOTHING --Tipo temporaneo generato dal parser
 21 |     | DataCOORD StdCoord DataType --Tipo temporaneo generato dal parser, serve per migliorare i messaggi di errore nel kind inference, dopodiché vengono eliminati.
 22 |     | DataQuant TyQuant --Quantificatore
 23 |     | DataTypeName String Kind -- Nome del tipo, kind del tipo
 24 |     | DataTypeApp DataType DataType --Funzione di tipi, argomento
 25 | 
 26 | type KindSubst = Map.Map KindQuant Kind
 27 | -- Classe kinds, usata per sostituzioni e per avere il kind
 28 | class Kinds t where
 29 |     kind :: t->Kind
 30 |     kSubstApply :: KindSubst -> t -> t
 31 |     freeKindQuants :: t -> Set.Set KindQuant
 32 | 
 33 | type Subst = Map.Map TyQuant DataType
 34 | class Types t where
 35 |     freetyvars :: t -> Set.Set TyQuant
 36 |     substApply :: Subst -> t -> t
 37 | 
 38 | 
 39 | instance Kinds Kind where
 40 |     kind = id
 41 |     kSubstApply _ KType = KType
 42 |     kSubstApply s (KindQuant q) = case Map.lookup q s of
 43 |         Nothing -> KindQuant q
 44 |         Just k -> k
 45 |     kSubstApply s (KFun a r) = KFun (kSubstApply s a) (kSubstApply s r)
 46 |     kSubstApply _ KindNOTHING = KindNOTHING
 47 | 
 48 |     freeKindQuants KType = Set.empty
 49 |     freeKindQuants (KindQuant q) = Set.singleton q
 50 |     freeKindQuants (KFun k k') = Set.union (freeKindQuants k) (freeKindQuants k')
 51 | 
 52 | 
 53 | instance Kinds TyQuant where
 54 |     kind (TyQuant _ k) = k
 55 |     kSubstApply s (TyQuant t k) = TyQuant t (kSubstApply s k)
 56 |     freeKindQuants (TyQuant _ k) = freeKindQuants k
 57 | 
 58 | instance Kinds DataType where
 59 |     kind (DataQuant q) = kind q
 60 |     --kind (DataTuple _) = KType
 61 |     kind (DataTypeName _ k) = k
 62 |     kind (DataTypeApp t _) = let (KFun _ k) = kind t in k
 63 |     kind (DataCOORD _ t) = kind t
 64 | 
 65 |     kSubstApply s (DataQuant q) = DataQuant (kSubstApply s q)
 66 |     --kSubstApply s (DataTuple ts) = DataTuple (map (kSubstApply s) ts)
 67 |     kSubstApply s (DataTypeName l k) = DataTypeName l (kSubstApply s k)
 68 |     kSubstApply s (DataTypeApp t1 t2) = DataTypeApp (kSubstApply s t1) (kSubstApply s t2)
 69 |     kSubstApply s (DataCOORD c t) = DataCOORD c (kSubstApply s t)
 70 | 
 71 |     freeKindQuants (DataQuant q) = freeKindQuants q
 72 |     freeKindQuants (DataTypeName _ k) = freeKindQuants k
 73 |     freeKindQuants (DataTypeApp f a) = Set.union (freeKindQuants f) (freeKindQuants a)
 74 |     freeKindQuants (DataCOORD _ t) = freeKindQuants t
 75 | 
 76 | substApplyPred :: KindSubst -> Pred -> Pred
 77 | substApplyPred s (Pred l ts) = Pred l $ map (kSubstApply s) ts
 78 | 
 79 | freeKindQuantsPred :: Pred -> Set.Set KindQuant
 80 | freeKindQuantsPred (Pred l ts) = Set.unions (map freeKindQuants ts)
 81 | 
 82 | instance Kinds t => Kinds (Qual t) where
 83 |     kind (Qual _ t) = kind t
 84 |     kSubstApply s (Qual ps t) = Qual (map (substApplyPred s) ps) (kSubstApply s t)
 85 |     freeKindQuants (Qual ps t) = Set.unions (freeKindQuants t : map freeKindQuantsPred ps)
 86 | 
 87 | instance Types DataType where
 88 |     freetyvars (DataQuant q) = Set.singleton q
 89 |     freetyvars (DataTypeName _ _) = Set.empty
 90 |     freetyvars (DataTypeApp dta dtb) = Set.union (freetyvars dta) (freetyvars dtb)
 91 |     freetyvars (DataCOORD _ t) = freetyvars t
 92 | 
 93 |     substApply s (DataQuant q) = case Map.lookup q s of
 94 |         Nothing -> DataQuant q
 95 |         Just t -> t
 96 |     substApply s (DataTypeApp dta dtb) =
 97 |         DataTypeApp (substApply s dta) (substApply s dtb)
 98 |     substApply s (DataTypeName tn k) = DataTypeName tn k
 99 |     --substApply s t = error $ "APPLY: " ++ show s ++ show t
100 |     substApply s (DataCOORD c t) = DataCOORD c (substApply s t)
101 | 
102 | instance Types Pred where
103 |     freetyvars (Pred _ ts) = Set.unions $ map freetyvars ts
104 |     substApply s (Pred l ts) = Pred l $ map (substApply s) ts
105 | 
106 | instance Types t => Types (Qual t) where
107 |     freetyvars (Qual ps t) = Set.unions $ freetyvars t : map freetyvars ps
108 |     substApply s (Qual ps t) = Qual (map (substApply s) ps) (substApply s t)
109 | 
110 | instance Types TyScheme where
111 |     freetyvars (TyScheme qs dt) = Set.difference (freetyvars dt) (Set.fromList qs)
112 |     substApply s (TyScheme qs dt) = TyScheme qs (substApply (foldr Map.delete s qs) dt)
113 | 
114 | instance Types TypingEnv where
115 |     freetyvars (TypingEnv ts _ _ _ _) = Set.unions $ map freetyvars (Map.elems ts)
116 |     substApply s (TypingEnv ts ks vs cs rs) = TypingEnv (Map.map (substApply s) ts) ks vs cs rs
117 | 
118 | instance Show Kind where
119 |     show KindNOTHING = "NOTHING"
120 |     show KType = "T"
121 |     show (KindQuant q) = "k" ++ show q
122 |     show (KFun a r) = "(" ++ show a ++ "->" ++ show r ++ ")"
123 | 
124 | type TyQuantId = Int
125 | data TyQuant = TyQuant TyQuantId Kind
126 |     deriving Eq
127 | instance Ord TyQuant where
128 |     compare (TyQuant t1 _) (TyQuant t2 _) = compare t1 t2
129 | instance Show TyQuant where
130 |     show (TyQuant i k) = "q"++show i++":"++show k
131 | 
132 | instance Eq DataType where
133 |     DataCOORD _ t == t' = t == t'
134 |     t == DataCOORD _ t' = t == t'
135 |     DataQuant q == DataQuant q' = q == q'
136 |     DataTypeName l k == DataTypeName l' k' = l == l' && k == k'
137 |     DataTypeApp f a == DataTypeApp f' a' = f == f' && a == a'
138 |     _ == _ = False
139 | 
140 | -- TODO: Miglior debug per tipi tupla (o tipi-nome)
141 | instance Show DataType where
142 |     show DataNOTHING = "NOTHING"
143 |     show (DataCOORD c dt) = "(AT"++show c ++ " " ++ show dt ++ ")"
144 |     show (DataQuant q) = show q
145 |     show (DataTypeName s k) = s++":"++show k
146 |     show (DataTypeApp (DataTypeApp (DataTypeName "->#BI" _) a) r) = "(" ++ show a ++ "->" ++ show r ++ ")" --Caso speciale per le funzioni
147 |     show (DataTypeApp f a) = "(" ++ show f ++ " " ++ show a ++ ")"
148 | 
149 | data Pred = Pred String [DataType]
150 |     deriving Eq
151 | instance Show Pred where
152 |     show (Pred l ts) = l ++ concatMap ((' ':) . show) ts
153 | 
154 | data Qual t = Qual [Pred] t
155 |     deriving Eq
156 | 
157 | instance Show t => Show (Qual t) where
158 |     show (Qual ps a) = '{': foldr (\l r->show l ++ ", " ++ r) "} => " ps ++ show a
159 | 
160 | data TyScheme = TyScheme [TyQuant] (Qual DataType)
161 | instance Show TyScheme where
162 |     show (TyScheme qs dt) = let showq (TyQuant q k) = " " ++ show q ++ ":" ++ show k in
163 |         "forall" ++ concatMap showq qs ++ "." ++ show dt
164 | 
165 | data VariantData = VariantData String [TyQuant] [DataType] DataType -- Nome della variante, quantificatori generici, argomenti, datatype di appartenenza
166 |     deriving Show
167 | 
168 | type CombData = ([DataType], DataType)
169 | -- Definizioni rel
170 | type InstData = Qual Pred
171 | data RelData = RelData [TyQuant] [Pred] [(String, Qual DataType)] [InstData]
172 |     deriving Show
173 | type RelEnv = Map.Map String RelData
174 | 
175 | -- contesto dei tipi (Types), specie (Kinds), costruttori (Variants), combinatori e relazioni
176 | data TypingEnv = TypingEnv (Map.Map String TyScheme) (Map.Map String Kind) (Map.Map String VariantData) (Map.Map String CombData) RelEnv --NOTE: Il nome della variante qui è duplicato
177 |     deriving Show
178 | 
179 | --Definizioni utili
180 | isTupLabl :: String -> (Bool, Int) --TODO: usa un maybe
181 | isTupLabl "()" = (True, 0)
182 | isTupLabl ('(':rest) = (")" == dropWhile (','==) rest, length rest)
183 | isTupLabl _ = (False, 0)
184 | 
185 | makeTupLabl :: Int -> String
186 | makeTupLabl 0 = "()"
187 | makeTupLabl 1 = error "Tuples of length 1 are forbidden"
188 | makeTupLabl len = '(':replicate (len - 1) ',' ++")"
189 | 
190 | buildTupKind :: Int -> Kind
191 | buildTupKind len = foldr (\_ ret -> KFun KType ret) KType [1..len]
192 | 
193 | buildTupType :: [DataType] -> DataType
194 | buildTupType ts =
195 |     let len = length ts
196 |         labl = makeTupLabl len
197 |     in foldl DataTypeApp (DataTypeName labl $ buildTupKind len) ts
198 | 
199 | buildFunType :: DataType -> DataType -> DataType
200 | buildFunType a r =
201 |     DataTypeApp (DataTypeApp (DataTypeName "->#BI" (KFun KType (KFun KType KType))) a) r
202 | 
203 | intT, fltT, boolT, chrT, realworldT :: DataType
204 | intT = DataTypeName "Int#BI" KType
205 | fltT = DataTypeName "Flt#BI" KType
206 | boolT = DataTypeName "Bool#BI" KType
207 | chrT = DataTypeName "Chr#BI" KType
208 | realworldT = DataTypeName "RealWorld_#BI" KType
209 | 
210 | -- Infrastruttura monadica
211 | 
212 | type TyperStateData = (Int, KindQuant, TyQuantId)
213 | 
214 | type TyperState t = ResultT (StateT TyperStateData CompMon) t
215 | 
216 | typerLog :: String -> TyperState ()
217 | typerLog = lift . lift . compLog
218 | 
219 | newUniqueSuffix :: TyperState String
220 | newUniqueSuffix = do
221 |     (u, k, t) <- get
222 |     put (u+1, k, t)
223 |     return ('#':show u)
224 | 
225 | newTyQuant :: Kind -> TyperState TyQuant
226 | newTyQuant k = do
227 |     (u, kq, tq) <- get
228 |     put (u, kq, tq+1)
229 |     return $ TyQuant tq k
230 | 
231 | freshType :: Kind -> TyperState DataType
232 | freshType k = do
233 |     q <- newTyQuant k
234 |     return $ DataQuant q
235 | 
236 | newKindQuant :: TyperState KindQuant
237 | newKindQuant = do
238 |     (u, k, t) <- get
239 |     put (u, k+1, t)
240 |     return k
241 | 
242 | freshKind :: TyperState Kind
243 | freshKind = KindQuant <$> newKindQuant
244 | 
245 | dataQsToKind :: [(String, TyQuant)] -> Kind
246 | dataQsToKind = foldr (KFun . kind . snd) KType
247 | 
248 | runTyperState :: TyperStateData -> TyperState t -> CompMon (Either String t, TyperStateData)
249 | runTyperState s t =
250 |     runStateT (runResultT t) s
251 | 


--------------------------------------------------------------------------------
/src/Typer/VariantComplete.hs:
--------------------------------------------------------------------------------
 1 | module Typer.VariantComplete(completeVariantValDefGroups, completeVariantInstDefs) where
 2 | import HLDefs
 3 | import Typer.TypingDefs
 4 | import Typer.TypeTyper(getVariantData)
 5 | 
 6 | completeVariant :: TypingEnv -> HLExpr -> TyperState HLExpr
 7 | completeVariant _ e@(_, _, ExprLiteral _) = return e
 8 | completeVariant env (c, t, ExprApp e0 e1) = do
 9 |     e0' <- completeVariant env e0
10 |     e1' <- completeVariant env e1
11 |     return (c, t, ExprApp e0' e1')
12 | completeVariant _ e@(_, _, ExprLabel _) = return e
13 | completeVariant env (c, t, ExprConstructor l es) = do
14 |     es' <- mapM (completeVariant env) es
15 |     VariantData _ vqs vts vt <- getVariantData env l
16 |     let zerotoadde = [0..length vts - length es -1]
17 |     addesuffixes <- mapM (const newUniqueSuffix) zerotoadde
18 |     return $ let
19 |             addenames = map ("_v"++) addesuffixes
20 |             addees = map (\myl -> (c, DataNOTHING, ExprLabel myl)) addenames
21 |         in foldr (\myl e -> (c, DataNOTHING, ExprLambda myl e)) (c, DataNOTHING, ExprConstructor l (es' ++ addees)) addenames
22 | completeVariant env (c, t, ExprCombinator l es) = do
23 |     es' <- mapM (completeVariant env) es
24 |     return (c, t, ExprCombinator l es')
25 | completeVariant env (c, t, ExprLambda l e) = do
26 |     e' <- completeVariant env e
27 |     return (c, t, ExprLambda l e')
28 | completeVariant env (c, t, ExprPut vs pses) = do
29 |     vs' <- mapM (completeVariant env) vs
30 |     pses' <- mapM (\(p, e)-> completeVariant env e >>= \e' -> return (p, e')) pses
31 |     return (c, t, ExprPut vs' pses')
32 | completeVariant env (c, t, ExprHint hint e) = do
33 |     e' <- completeVariant env e
34 |     return (c, t, ExprHint hint e')
35 | 
36 | completeVariantValDefGroups :: TypingEnv -> [[HLValDef]] -> TyperState [[HLValDef]]
37 | completeVariantValDefGroups env = mapM (mapM (\(ValDef c l t ps e)-> ValDef c l t ps <$> completeVariant env e))
38 | 
39 | completeVariantInstDefs :: TypingEnv -> [HLInstDef] -> TyperState [HLInstDef]
40 | completeVariantInstDefs env = mapM (\(InstDef c qh defs)->
41 |     InstDef c qh <$>
42 |     mapM (\(c', l, e)-> do
43 |         e' <- completeVariant env e
44 |         return (c', l, e')) defs)
45 | 


--------------------------------------------------------------------------------
/stdlib/core.spk:
--------------------------------------------------------------------------------
  1 | # TODO:Questo file andrà copiato in una stringa nel compilatore
  2 | 
  3 | mod Builtins {
  4 |     # Combinatori primitivi
  5 |     ext pub _addInt "spinnaker_addInt" : Int, Int -> Int
  6 |     ext pub _subInt "spinnaker_subInt" : Int, Int -> Int
  7 |     ext pub _mulInt "spinnaker_mulInt" : Int, Int -> Int
  8 |     ext pub _divInt "spinnaker_divInt" : Int, Int -> Int
  9 |     ext pub _remInt "spinnaker_remInt" : Int, Int -> Int
 10 |     ext pub _equInt "spinnaker_equInt" : Int, Int -> Bool
 11 |     ext pub _neqInt "spinnaker_neqInt" : Int, Int -> Bool
 12 |     ext pub _leqInt "spinnaker_leqInt" : Int, Int -> Bool
 13 |     ext pub _greInt "spinnaker_greInt" : Int, Int -> Bool
 14 | 
 15 |     ext pub _addFlt "spinnaker_addFlt" : Flt, Flt -> Flt
 16 |     ext pub _subFlt "spinnaker_subFlt" : Flt, Flt -> Flt
 17 |     ext pub _mulFlt "spinnaker_mulFlt" : Flt, Flt -> Flt
 18 |     ext pub _divFlt "spinnaker_divFlt" : Flt, Flt -> Flt
 19 |     ext pub _equFlt "spinnaker_equFlt" : Flt, Flt -> Bool
 20 |     ext pub _neqFlt "spinnaker_neqFlt" : Flt, Flt -> Bool
 21 |     ext pub _leqFlt "spinnaker_leqFlt" : Flt, Flt -> Bool
 22 |     ext pub _greFlt "spinnaker_greFlt" : Flt, Flt -> Bool
 23 |     ext pub _floorFlt "spinnaker_floorFlt" : Flt -> Int
 24 |     ext pub _convItoF "spinnaker_convItoF" : Int -> Flt
 25 | 
 26 |     ext pub _andBool "spinnaker_andBool" : Bool, Bool -> Bool
 27 |     ext pub _orBool "spinnaker_orBool" : Bool, Bool -> Bool
 28 |     ext pub _notBool "spinnaker_notBool" : Bool -> Bool
 29 | 
 30 |     ext pub _convItoC "spinnaker_convItoC" : Int -> Chr
 31 |     ext pub _convCtoI "spinnaker_convCtoI" : Chr -> Int
 32 |     ext pub _putChr "spinnaker_putChr" : Chr, RealWorld_ -> RealWorld_
 33 |     ext pub _getChr "spinnaker_getChr" : RealWorld_ -> (Chr, RealWorld_)
 34 |     ext pub _isEOF "spinnaker_isEOF" : RealWorld_ -> (Bool, RealWorld_)
 35 |     ext pub _exit "spinnaker_exit" : Int, RealWorld_ -> RealWorld_
 36 | }
 37 | 
 38 | def pub (|>) : forall a b c. (a -> b) -> (b -> c) -> (a -> c)
 39 |     = \f,g,x->g(f x)
 40 | def pub (<|) : forall a b c. (b -> c) -> (a -> b) -> (a -> c)
 41 |     = \f,g,x->f(g x)
 42 | def pub (|->) : forall a b. a -> (a -> b) -> b
 43 |     = \x,f->f x
 44 | def pub ($) : forall a b. (a -> b) -> a -> b
 45 |     = \a,b->a b
 46 | def pub flip : forall a b c. (a -> b -> c) -> b -> a -> c
 47 |     = \f,x,y->f y x
 48 | def pub curry : forall a b c. ((a, b) -> c) -> a -> b -> c
 49 |     = \f,x,y->f(x,y)
 50 | def pub uncurry : forall a b c. (a -> b -> c) -> (a, b) -> c
 51 |     = \f,(x,y)->f x y
 52 | def pub id : forall a. a -> a
 53 |     = \x->x
 54 | def pub const : forall a b. a -> b -> a
 55 |     = \x,_->x
 56 | def pub fst : forall a b. (a, b) -> a
 57 |     = \(a,_)->a
 58 | def pub snd : forall a b. (a, b) -> b
 59 |     = \(_,b)->b
 60 | 
 61 | mod BoolCore {
 62 |     use Builtins
 63 | 
 64 |     def pub (&&) : Bool -> Bool -> Bool = _andBool
 65 |     def pub (||) : Bool -> Bool -> Bool = _orBool
 66 |     def pub not : Bool -> Bool = _notBool
 67 | } use pub BoolCore
 68 | 
 69 | mod NumCore {
 70 |     # Relazioni e istanze dei numerici builtin
 71 | 
 72 |     rel pub Num a =
 73 |         (+) : a -> a -> a,
 74 |         (-) : a -> a -> a,
 75 |         (*) : a -> a -> a,
 76 |         (/) : a -> a -> a,
 77 |         fromInt : Int -> a
 78 | 
 79 |     rel pub Eq a =
 80 |         (==) : a -> a -> Bool,
 81 |         (!=) : a -> a -> Bool
 82 | 
 83 |     inst forall a b. {Eq a, Eq b} => Eq (a, b) {
 84 |         def (==) = \(a, b), (a', b') -> (a == a') && (b == b')
 85 |         def (!=) = \a, b -> not $ a == b
 86 |     }
 87 | 
 88 |     rel pub {Eq a} => Ord a =
 89 |         (>) : a -> a -> Bool,
 90 |         (<=) : a -> a -> Bool
 91 |     def pub (<) : forall a. {Ord a} => a -> a -> Bool
 92 |         = \a, b -> b > a
 93 |     def pub (>=) : forall a. {Ord a} => a -> a -> Bool
 94 |         = \a, b -> b <= a
 95 | 
 96 | 
 97 |     rel pub Enum a =
 98 |         fromEnum : a -> Int,
 99 |         toEnum : Int -> a
100 | 
101 | 
102 |     use Builtins
103 | 
104 |     def pub rem : Int -> Int -> Int
105 |         = _remInt
106 | 
107 |     # TODO: forse incorpora in Num
108 |     def pub abs : forall a. {Num a, Ord a} => a -> a
109 |         = \a -> put a < fromInt 0
110 |         | True -> fromInt 0 - a
111 |         | False -> a
112 | 
113 |     def expAux =
114 |         \ curr, a, 0 -> curr
115 |         | curr, a, n -> expAux (a * curr) a (n - 1)
116 |     and pub (^) : forall a. {Num a} => a -> Int -> a
117 |         = expAux (fromInt 1)
118 | 
119 |     inst Enum Int {
120 |         def toEnum = id
121 |         def fromEnum = id
122 |     }
123 | 
124 |     inst Enum Chr {
125 |         def toEnum = _convItoC
126 |         def fromEnum = _convCtoI
127 |     }
128 | 
129 |     inst Num Int {
130 |         def (+) = _addInt
131 |         def (-) = _subInt
132 |         def (*) = _mulInt
133 |         def (/) = _divInt
134 |         def fromInt = id
135 |     }
136 | 
137 |     inst Eq Int {
138 |         def (==) = _equInt
139 |         def (!=) = _neqInt
140 |     }
141 | 
142 |     inst Eq Bool {
143 |         def (==) =
144 |             \ True, True -> True
145 |             | False, False -> True
146 |             | _, _ -> False
147 |         def (!=) =
148 |             \ True, True -> False
149 |             | False, False -> False
150 |             | _, _ -> True
151 |     }
152 | 
153 |     inst Num Flt {
154 |         def (+) = _addFlt
155 |         def (-) = _subFlt
156 |         def (*) = _mulFlt
157 |         def (/) = _divFlt
158 |         def fromInt = _convItoF
159 |     }
160 |     def pub floor = _floorFlt
161 | 
162 |     inst Eq Flt {
163 |         def (==) = _equFlt
164 |         def (!=) = _neqFlt
165 |     }
166 | 
167 |     inst Eq Chr {
168 |         def (==) = \a, b -> fromEnum a == fromEnum b
169 |         def (!=) = \a, b -> fromEnum a != fromEnum b
170 |     }
171 | 
172 |     inst Ord Int {
173 |         def (>) = _greInt
174 |         def (<=)= _leqInt
175 |     }
176 | 
177 |     inst Ord Flt {
178 |         def (>) = _greFlt
179 |         def (<=)= _leqFlt
180 |     }
181 |     inst Ord Chr {
182 |         def (>) = \a, b -> fromEnum a > fromEnum b
183 |         def (<=) = \a, b -> fromEnum a <= fromEnum b
184 |     }
185 | 
186 | } use pub NumCore
187 | 
188 | mod MonadCore {
189 |     # Definizione di Monade e delle strutture da cui dipende
190 | 
191 |     rel pub Functor f =
192 |         # LAWS
193 |         # 1. fmap id = id
194 |         # 2. fmap (f <| g) = fmap f <| fmap g
195 |         fmap : forall a b. (a -> b) -> f a -> f b
196 | 
197 |     rel pub {Functor m} => Monad m =
198 |         # LAWS
199 |         # 1. bind (return a) k = k a
200 |         # 2. bind m return = m
201 |         # 3. bind m (\x -> bind (k x) h) = bind (bind m k) h
202 |         # 4. fmap f m = bind m (\x -> return f x)
203 |         return : forall a. a -> m a,
204 |         bind : forall a b. m a -> (a -> m b) -> m b
205 | 
206 |     def pub (<$>) : forall f a b. {Functor f} => (a -> b) -> f a -> f b
207 |         = fmap
208 |     def pub (>>=) : forall m a b. {Monad m} => m a -> (a -> m b) -> m b
209 |         = bind
210 |     def pub (>>) : forall m a b. {Monad m} => m a -> m b -> m b
211 |         = \m, m' -> m >>= \_ -> m'
212 | 
213 |     inst forall m. {Monad m} => Functor m {
214 |         def fmap = \f, m -> bind m (\x->return (f x))
215 |     }
216 | 
217 |     inst forall l. Functor ((,) l) {
218 |         def fmap = \f, (l, a) -> (l, f a)
219 |     }
220 | } use pub MonadCore
221 | 
222 | mod ListCore {
223 |     # Definizione di lista e alcuni primitivi molto utili
224 | 
225 |     data pub List a
226 |         = Nil
227 |         | Cons a (List a)
228 | 
229 |     def pub (::) : forall a. a -> List a -> List a
230 |         = Cons
231 | 
232 |     def reverseAux = \acc, l ->
233 |         put l
234 |         | Nil -> acc
235 |         | Cons x xs -> reverseAux (x :: acc) xs
236 |     def pub reverse : forall a. List a -> List a
237 |     = reverseAux Nil
238 | 
239 |     def mapAux = \procd, f, l -> put l
240 |         | Nil -> reverse procd
241 |         | Cons x xs -> mapAux (f x :: procd) f xs
242 |     def pub map : forall a b. (a -> b) -> List a -> List b
243 |         = mapAux Nil
244 | 
245 |     inst Functor List {def fmap = map}
246 | 
247 |     def pub (++) : forall a. List a -> List a -> List a
248 |         = \l, l' -> put l
249 |         | Nil -> l'
250 |         | Cons x xs -> x :: (xs ++ l')
251 | 
252 |     inst Monad List {
253 |         def return = \x -> x :: Nil
254 |         def bind = \l, f->
255 |             put l
256 |             | Nil -> Nil
257 |             | Cons x xs -> f x ++ bind xs f
258 |     }
259 | 
260 |     inst forall a. {Eq a} => Eq (List a) {
261 |         def (==) =
262 |             \ Nil, Nil -> True
263 |             | Cons x xs, Cons y ys -> (put x == y
264 |                 | True -> xs == ys
265 |                 | _ -> False)
266 |             | _, _ -> False
267 |         def (!=) = \a, b -> not (a == b)
268 |     }
269 | 
270 | } use pub ListCore
271 | 
272 | mod ShowCore {
273 |     typesyn pub String = List Chr
274 |     # Definizione di Show e delle sue istanze sui tipi builtin
275 | 
276 |     rel pub Show a = show : a -> String
277 | 
278 |     def pub strNil : String = Nil
279 |     inst Show () {
280 |         def show = \() -> '('::')':: Nil
281 |     }
282 | 
283 |     inst Show Bool {
284 |         def show =
285 |             \ True -> 'T'::'r'::'u'::'e'::Nil
286 |             | False -> 'F'::'a'::'l'::'s'::'e'::Nil
287 |     }
288 | 
289 |     def showDigit : Int -> Chr = \i -> toEnum (fromEnum '0' + i)
290 | 
291 |     def showNosignAux = \s, i -> put i
292 |         | 0 -> s
293 |         | _ -> showNosignAux (showDigit (abs $ rem i 10) :: s) (i / 10)
294 |     def showNosign = showNosignAux Nil
295 | 
296 |     def showInt = \i -> put i
297 |         | 0 -> '0' :: Nil
298 |         | _ ->  put i > 0
299 |                 | True -> showNosign i
300 |                 | _ -> '-' :: showNosign i
301 | 
302 |     inst Show Int { def show = showInt }
303 | 
304 |     # TODO Test
305 |     def showFracAux =
306 |         \ 0, _ -> Nil
307 |         | n, f ->
308 |             let f' = f * 10.0 ->
309 |             let flr = floor f' ->
310 |             showDigit flr :: showFracAux (n - 1) (f' - fromInt flr)
311 |     # TODO taglio a 4 cifre decimali, non considera la prima cifra esclusa (fa un floor quindi)
312 |     def showFrac = showFracAux 4
313 | 
314 |     def showNonNegFlt = \f ->
315 |         let flr = floor f ->
316 |         show flr ++ '.' :: showFrac (f - fromInt flr)
317 | 
318 |     def showFlt = \f ->
319 |         put f < 0.0
320 |         | True -> '-' :: showNonNegFlt (0.0-f)
321 |         | _ -> showNonNegFlt f
322 | 
323 |     inst Show Flt { def show = showFlt }
324 | 
325 |     def escapeChr =
326 |         \ '\n' -> '\\'::'n'::Nil
327 |         | '\\' -> '\\'::'\\'::Nil
328 |         | '\'' -> '\\'::'\''::Nil
329 |         | '"' -> '\\'::'"'::Nil
330 |         | c -> c::Nil #Solo se 32 <= fromEnum c <= 126
331 | 
332 |     inst Show Chr {
333 |         def show = \c -> Cons '\'' (escapeChr c) ++ ('\''::Nil)
334 |     }
335 | 
336 |     inst Show String {
337 |         def show = \l -> Cons '"' (l >>= escapeChr) ++ ('"'::Nil)
338 |     }
339 | 
340 |     def showListAux =
341 |         \ Nil -> ']' :: Nil
342 |         | Cons x Nil -> show x ++ (']' :: Nil)
343 |         | Cons x xs -> show x ++ Cons ',' (Cons ' ' Nil) ++ showListAux xs
344 | 
345 |     def showList = \l -> '[' :: showListAux l
346 | 
347 |     def showtup2 = \a, b -> show a ++ ','::' ':: show b
348 |     def showtup3 = \a, b, c -> show a ++ ','::' '::showtup2 b c
349 |     def showtup4 = \a, b, c, d -> showtup2 a b ++ ','::' ':: showtup2 c d
350 | 
351 |     inst forall a. {Show a} => Show (List a) {
352 |         def show = showList
353 |     }
354 | 
355 |     inst forall a b. {Show a, Show b} => Show (a, b) {
356 |         def show = \(a, b) -> '(' :: showtup2 a b ++ (')'::Nil)
357 |     }
358 | 
359 |     inst forall a b c. {Show a, Show b, Show c} => Show (a, b, c) {
360 |         def show = \(a, b, c) -> '(' :: showtup3 a b c ++ (')'::Nil)
361 |     }
362 | 
363 |     inst forall a b c d. {Show a, Show b, Show c, Show d} => Show (a, b, c, d) {
364 |         def show = \(a, b, c, d) -> '(':: showtup4 a b c d ++ (')'::Nil)
365 |     }
366 | 
367 | } use pub ShowCore
368 | 
369 | mod IOCore {
370 |     # Definizione del monade IO e delle operazioni primitive
371 | 
372 |     data pub IO a = IO (RealWorld_ -> (a, RealWorld_))
373 | 
374 |     inst Functor IO {
375 |         def fmap = \f, IO tf -> IO (\rw->
376 |                 let (a, rw') = tf rw ->
377 |                     (f a, rw')
378 |             )
379 |     }
380 | 
381 |     inst Monad IO {
382 |         def return = \a -> IO(\rw -> (a, rw))
383 |         def bind = \IO tf, f -> IO (\rw->
384 |                 let (a, rw') = tf rw ->
385 |                 let IO tf' = f a ->
386 |                 tf' rw'
387 |             )
388 |     }
389 | 
390 |     mod pub UnsafeIO {
391 |         use Builtins
392 | 
393 |         def pub putChr = _putChr
394 |         def pub getChr = _getChr
395 |         def pub isEOF = _isEOF
396 |         def pub exit = _exit
397 | 
398 |         def pub putStr : String -> RealWorld_ -> RealWorld_
399 |             = \s, rw -> put s
400 |             | Nil -> rw
401 |             | Cons c cs ->
402 |                 let rw' = putChr c rw ->
403 |                 putStr cs rw'
404 |         def pub putStrLn = \s, rw ->
405 |             let rw' = putStr s rw ->
406 |             putChr '\n' rw'
407 |         def pub getLn = \rw ->
408 |             put getChr rw
409 |             | ('\n', rw') -> (Nil, rw')
410 |             | (c, rw') ->
411 |                 let (s, rw'') = getLn rw' ->
412 |                 (c :: s, rw'')
413 | 
414 |         def pub runTopIO = \IO tf -> let ((), rw) = tf RealWorld_ -> rw
415 |     }
416 | 
417 |     def pub putChr : Chr -> IO ()
418 |         = \c -> IO(\s->((), UnsafeIO.putChr c s))
419 |     def pub getChr : IO Chr
420 |         = IO UnsafeIO.getChr
421 |     def pub putStr : String -> IO ()
422 |         = \l -> IO(\s->((), UnsafeIO.putStr l s))
423 |     def pub putStrLn : String -> IO ()
424 |         = \l -> IO(\s->((), UnsafeIO.putStrLn l s))
425 |     def pub getLn : IO String
426 |         = IO UnsafeIO.getLn
427 |     def pub isEOF : IO Bool
428 |         = IO UnsafeIO.isEOF
429 | 
430 |     def pub print : forall a. {Show a} => a -> IO ()
431 |         = show |> putStrLn
432 | 
433 |     #TODO: sposta in Debug
434 |     def errorAux : forall a. String -> RealWorld_ -> a
435 |         = \s, rw -> errorAux s (UnsafeIO.exit 1 (UnsafeIO.putStrLn s rw))
436 |     def pub error : forall a. String -> a
437 |         = \s -> errorAux ('e'::'r'::'r'::'o'::'r'::':'::' '::s) RealWorld_
438 | } use pub IOCore
439 | 
440 | 
441 | # TODO: inserisci in un modulo a sé
442 | 
443 | rel pub ProgramTop a = runProgramTop : a -> IO ()
444 | 
445 | inst ProgramTop (IO ()) { def runProgramTop = id }
446 | 
447 | inst forall a. {Show a} => ProgramTop a { def runProgramTop = print }
448 | 
449 | inst forall a. {ProgramTop a} => ProgramTop (IO a) {
450 |     def runProgramTop = (>>= runProgramTop)
451 | }
452 | 


--------------------------------------------------------------------------------
/stdlib/debug.spk:
--------------------------------------------------------------------------------
 1 | use Core
 2 | 
 3 | def carryPutStrLn : forall a. RealWorld_ -> String -> a -> (a, RealWorld_)
 4 |     = \rw, s, a -> put s
 5 |         | [] -> (a, UnsafeIO.putChr '\n' rw)
 6 |         | [c | cs] ->
 7 |             let rw' = UnsafeIO.putChr c rw ->
 8 |             carryPutStrLn rw' cs a
 9 | 
10 | def pub trace : forall a. String -> a -> a
11 |     = \s, a -> fst (carryPutStrLn RealWorld_ s a)
12 | 
13 | def pub traceit : forall a. {Show a} => a -> a
14 |     = \a -> trace (show a) a
15 | 


--------------------------------------------------------------------------------
/stdlib/either.spk:
--------------------------------------------------------------------------------
 1 | use Core
 2 | 
 3 | data pub Either a b = Left a | Right b
 4 | 
 5 | def pub isLeft : forall a b. Either a b -> Bool =
 6 |     \ Left _ -> True
 7 |     | Right _ -> False
 8 | 
 9 | def pub isRight : forall a b. Either a b -> Bool =
10 |     \ Left _ -> True
11 |     | Right _ -> False
12 | 
13 | def pub either : forall a b c. (a -> c) -> (b -> c) -> Either a b -> c =
14 |     \ fa, _, Left a -> fa a
15 |     | _, fb, Right b -> fb b
16 | 
17 | inst forall a b. {Show a, Show b} => Show (Either a b) {
18 |     def show =
19 |         \ Left a -> "Left (" ++ show a ++ ")"
20 |         | Right b -> "Right (" ++ show b ++ ")"
21 | }
22 | 
23 | inst forall a. Functor (Either a) {
24 |     def fmap =
25 |         \ _, Left a -> Left a
26 |         | f, Right b -> Right (f b)
27 | }
28 | 
29 | inst forall a. Monad (Either a) {
30 |     def return = Right
31 |     def bind =
32 |         \ Left a, _ -> Left a
33 |         | Right b, f -> f b
34 | }
35 | 


--------------------------------------------------------------------------------
/stdlib/list.spk:
--------------------------------------------------------------------------------
  1 | use Core
  2 | 
  3 | mod Maybe "maybe.spk"
  4 | 
  5 | 
  6 | def pub head : forall a. [a] -> a
  7 |     = \[x | xs] -> x
  8 | def pub tail : forall a. [a] -> [a]
  9 |     = \[x | xs] -> xs
 10 | def pub last : forall a. [a] -> a =
 11 |     \ [x] -> x
 12 |     | [x | xs] -> last xs
 13 | def pub init : forall a. [a] -> [a] =
 14 |     \ [x] -> []
 15 |     | [x | xs] -> x :: (init xs)
 16 | 
 17 | # TODO: uncons
 18 | 
 19 | def pub null : forall a. [a] -> Bool =
 20 |     \ [] -> True
 21 |     | _ -> False
 22 | 
 23 | def lengthAux = \n, l -> put l
 24 |     | [] -> n
 25 |     | [_ | xs] -> lengthAux (n + 1) xs
 26 | and pub length : forall a. [a] -> Int
 27 |     = lengthAux 0
 28 | 
 29 | def pub foldl : forall a s. (s -> a -> s) -> s -> [a] -> s
 30 |     = \f, s, l -> put l
 31 |     | [] -> s
 32 |     | [x | xs] -> foldl f (f s x) xs
 33 | 
 34 | def pub foldr : forall s a. (a -> s -> s) -> s -> [a] -> s
 35 |     = \f, s, l -> put l
 36 |     | [] -> s
 37 |     | [x | xs] -> f x (foldr f s xs)
 38 | 
 39 | def pub foldl1 : forall a. (a -> a -> a) -> [a] -> a
 40 |     = \f, [x | xs] -> foldl f x xs
 41 | 
 42 | # TODO: foldr1, scanl, scanr, scanl1, scanr1
 43 | 
 44 | # TODO: versione tail-call?
 45 | def pub unfoldr : forall a b. (a -> Maybe.Maybe (b, a)) -> a -> [b]
 46 |     = \f, a -> put f a
 47 |     | Maybe.None -> []
 48 |     | Maybe.Some (b, a') -> b :: unfoldr f a'
 49 | 
 50 | def replicateAux =
 51 |     \ curr, 0, _ -> curr
 52 |     | curr, n, a -> replicateAux (a :: curr) (n - 1) a
 53 | and pub replicate : forall a. Int -> a -> [a]
 54 |     = replicateAux []
 55 | 
 56 | # TODO: Tailcall
 57 | def pub map2 : forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
 58 |     = \f, l, l' -> put l, l'
 59 |     | [], _ -> []
 60 |     | _, [] -> []
 61 |     | [x | xs], [x' | xs'] -> f x x' :: map2 f xs xs'
 62 | 
 63 | # TODO: Tailcall
 64 | # zip = map2 (,)
 65 | def pub zip : forall a b. [a] -> [b] -> [(a, b)] =
 66 |     \ [], _ -> []
 67 |     | _, [] -> []
 68 |     | [x | xs], [x' | xs'] -> (x, x') :: zip xs xs'
 69 | 
 70 | def pub any : forall a. (a -> Bool) -> [a] -> Bool
 71 |     = \bf, l -> put l
 72 |     | [] -> False
 73 |     | [x | xs] -> put bf x
 74 |         | True -> True
 75 |         | _ -> any bf xs
 76 | 
 77 | def pub all : forall a. (a -> Bool) -> [a] -> Bool
 78 |     = \bf, l -> put l
 79 |     | [] -> True
 80 |     | [x | xs] -> put bf x
 81 |         | False -> False
 82 |         | _ -> all bf xs
 83 | 
 84 | # TODO: and, or, sum, product, maximum, minimum
 85 | 
 86 | def pub elem : forall a. {Eq a} => a -> [a] -> Bool
 87 |     = \x -> any (x ==)
 88 | 
 89 | def pub nth : forall a. Int -> [a] -> a
 90 |     = \n, l -> put n
 91 |     | 0 -> head l
 92 |     | _ -> nth (n - 1) (tail l)
 93 | 
 94 | # TODO: versione tail-call
 95 | def pub updateAt : forall a. Int -> (a -> a) -> [a] -> [a]
 96 |     = \n, f, l -> put n, l
 97 |     | 0, [x | xs] -> f x :: xs
 98 |     | _, [x | xs] -> x :: updateAt (n - 1) f xs
 99 | 
100 | def filterAux
101 |     = \c, f, l -> put l
102 |     | [] -> reverse c
103 |     | [x | xs] ->
104 |         let newc = if f x then x :: c else c ->
105 |         filterAux newc f xs
106 | and pub filter : forall a. (a -> Bool) -> [a] -> [a]
107 |     = filterAux []
108 | 
109 | def pub find : forall a. (a -> Bool) -> [a] -> Maybe.Maybe a =
110 |     \ f, [] -> Maybe.None
111 |     | f, [x | xs] -> if f x
112 |         then Maybe.Some x
113 |         else find f xs
114 | 
115 | def findIndexAux =
116 |     \ _, _, [] -> Maybe.None
117 |     | n, f, [x | xs] -> if f x
118 |         then Maybe.Some n
119 |         else findIndexAux (n+1) f xs
120 | and pub findIndex : forall a. (a -> Bool) -> [a] -> Maybe.Maybe Int
121 |     = findIndexAux 0
122 | 
123 | def pub elemIndex : forall a. {Eq a} => a -> [a] -> Maybe.Maybe Int
124 |     = \a -> findIndex (a ==)
125 | 
126 | def pub lookup : forall a b. {Eq a} => a -> [(a, b)] -> Maybe.Maybe b
127 |     = \a -> fmap snd <| find (fst |> (a ==))
128 | 
129 | # TODO: partition, elemIndices, findIndex serio, findIndices
130 | 
131 | # TODO: forse conviene utilizzare una funzione passata come argomento come trasformazione di c e l, oppure reimplementare take e drop autonomamente
132 | def splitAtAux = \c, i, l -> put i, l
133 |     | 0, _ -> (reverse c, l)
134 |     | _, [x | xs] -> splitAtAux (x::c) (i - 1) xs
135 | and pub splitAt : forall a. Int -> [a] -> ([a], [a])
136 |     = splitAtAux []
137 | 
138 | def pub take : forall a. Int -> [a] -> [a]
139 |     = \i, l -> fst (splitAtAux [] i l)
140 | def pub drop : forall a. Int -> [a] -> [a]
141 |     = \i, l -> snd (splitAtAux [] i l)
142 | 
143 | def splitWhileAux =
144 |     \ c, _, [] -> (reverse c, [])
145 |     | c, f, [x | xs] ->
146 |         if f x then splitWhileAux (x :: c) f xs
147 |         else (reverse c, x :: xs)
148 | #TODO: equivalente a 'span' di haskell. considera di rinominare
149 | and pub splitWhile : forall a. (a -> Bool) -> [a] -> ([a], [a])
150 |     = splitWhileAux []
151 | 
152 | def pub takeWhile : forall a. (a -> Bool) -> [a] -> [a]
153 |     = \f, l -> fst (splitWhileAux [] f l)
154 | def pub dropWhile : forall a. (a -> Bool) -> [a] -> [a]
155 |     = \f, l -> snd (splitWhileAux [] f l)
156 | 
157 | def pub (\\) : forall a. {Eq a} => [a] -> [a] -> [a]
158 |     = \l, m -> filter (\x -> all (x !=) m) l
159 | 
160 | # TODO?: inits, tails
161 | 
162 | # TODO: Tailcall
163 | def pub nub : forall a. {Eq a} => [a] -> [a] =
164 |     \ [] -> []
165 |     | [x | xs] -> x :: nub (filter (x !=) xs)
166 | 
167 | # TODO: nubBy, union, unionBy, intersect, intersectBy, insert, insertBy, sort, sortBy, sortOn, delete, deleteBy
168 | 
169 | def pub concat : forall a. [[a]] -> [a]
170 |     = (>>= id)
171 | 
172 | def transposeAux =
173 |     \ [l] -> map (::[]) l
174 |     | [l | ls] -> map2 (::) l (transposeAux ls)
175 | and pub transpose : forall a. [[a]] -> [[a]] =
176 |     \ [] -> []
177 |     | ls -> transposeAux ls
178 | # TODO: intercalate, subsequences, permutations, enumerate
179 | 
180 | 
181 | # NOTE: forse deve andare in un altro file
182 | def pub catMaybes : forall a. [Maybe.Maybe a] -> [a] =
183 |     \ [] -> []
184 |     | [Maybe.None | xs] -> catMaybes xs
185 |     | [Maybe.Some x | xs] -> x :: catMaybes xs
186 | 
187 | 


--------------------------------------------------------------------------------
/stdlib/maybe.spk:
--------------------------------------------------------------------------------
 1 | use Core
 2 | 
 3 | mod Monad "monad.spk"
 4 | 
 5 | data pub Maybe a = None | Some a
 6 | 
 7 | def pub isSome : forall a. Maybe a -> Bool =
 8 |     \ None -> False
 9 |     | Some _ -> True
10 | 
11 | def pub isNone : forall a. Maybe a -> Bool =
12 |     \ None -> True
13 |     | Some _ -> False
14 | 
15 | def pub fromSome : forall a. Maybe a -> a
16 |     = \Some a -> a
17 | 
18 | def pub maybe : forall a b. b -> (a -> b) -> Maybe a -> b
19 |     = \b, f, m -> put m
20 |     | None -> b
21 |     | Some a -> f a
22 | 
23 | def pub fromMaybe : forall a. a -> Maybe a -> a
24 |   = \a -> maybe a id
25 | 
26 | inst forall a. {Show a} => Show (Maybe a) { #NOTE: temporaneo, aggiunge parentesi di troppo
27 |     def show =
28 |         \ None -> "None"
29 |         | Some a -> "Some (" ++ show a ++ ")"
30 | }
31 | 
32 | inst forall a. {Eq a} => Eq (Maybe a) {
33 |     def (==) =
34 |         \ None, None -> True
35 |         | Some a, Some b -> a == b
36 |         | _, _ -> False
37 |     def (!=) =
38 |         \ None, None -> False
39 |         | Some a, Some b -> a != b
40 |         | _, _ -> True
41 | }
42 | 
43 | inst Functor Maybe {
44 |     def fmap = \f, m -> put m
45 |         | None -> None
46 |         | Some a -> Some (f a)
47 | }
48 | inst Monad Maybe {
49 |     def return = \a -> Some a
50 |     def bind = \m, f -> put m
51 |         | None -> None
52 |         | Some a -> f a
53 | }
54 | 
55 | inst Monad.MonadPlus Maybe {
56 |     def mzero = None
57 |     def mplus = \a, b -> put a
58 |         | None -> b
59 |         | Some _ -> a
60 | }
61 | 
62 | inst Monad.MonadFail Maybe { def fail = \_ -> None }
63 | 


--------------------------------------------------------------------------------
/stdlib/monad.spk:
--------------------------------------------------------------------------------
 1 | use Core
 2 | 
 3 | def mapMAux = \procd, f, l -> put l
 4 |     | [] -> return (reverse procd)
 5 |     | [x | xs] ->
 6 |         a <- f x;
 7 |         mapMAux (a :: procd) f xs
 8 | def pub mapM : forall m a b. {Monad m} => (a -> m b) -> [a] -> m [b]
 9 |     = mapMAux []
10 | 
11 | def pub mapM_ : forall m a b. {Monad m} => (a -> m b) -> [a] -> m () =
12 |     \ _, [] -> return ()
13 |     | f, [x | xs] -> f x >> mapM_ f xs
14 | 
15 | rel pub {Monad m} => MonadPlus m =
16 |     # LAWS
17 |     # 1) MONOID
18 |     # 1.1) mplus mzero a = a
19 |     # 1.2) mplus a mzero = a
20 |     # 1.3) mplus (mplus a b) c = mplus a (mplus b c)
21 |     # 2) mzero >>= f = mzero
22 |     # 3) m >> mzero = mzero
23 |     mzero : forall a. m a,
24 |     mplus : forall a. m a -> m a -> m a
25 | 
26 | def pub guard : forall m. {MonadPlus m} => Bool -> m () =
27 |     \ True -> return ()
28 |     | False -> mzero
29 | 
30 | inst MonadPlus [] {
31 |     def mzero = []
32 |     def mplus = (++)
33 | }
34 | 
35 | rel pub {Monad m} => MonadFail m =
36 |     # Se {MonadPlus m} si può considerare: mzero = fail "mzero"
37 |     fail : forall a. String -> m a
38 | 
39 | inst MonadFail IO {
40 |     def fail = error
41 | }
42 | 
43 | rel pub MonadTrans t = lift : forall m a. {Monad m, Monad (t m)} => m a -> t m a
44 |     # LAWS
45 |     # 1) lift <| return = return
46 |     # 2) lift (m >>= f) = lift m >>= (lift <| f)
47 | 
48 | # Monade identità, può servire come placeholder nei transformers, ad esempio State s a = StateT s Id a
49 | mod pub Id {
50 |     data pub Id a = Id a
51 |     def pub runId : forall a. Id a -> a = \Id a -> a
52 |     
53 |     inst Functor Id {
54 |         def fmap = \f, Id a -> Id (f a)
55 |     }
56 |     inst Monad Id {
57 |         def return = Id
58 |         def bind = \Id a, f -> f a
59 |     }
60 | }
61 | 
62 | mod pub State {
63 |     # qui la mancanza delle FunctionalDependencies è un problema, in diversi casi l'inferenza è indecidibile
64 |     # rel pub {Monad m} => MonadState m s =
65 |     #     gets : m s,
66 |     #     puts : s -> m ()
67 | 
68 |     data pub StateT s m a = StateT (s -> m (a, s))
69 |     def pub runStateT : forall s m a. StateT s m a -> s -> m (a, s)
70 |         = \StateT sf -> sf
71 | 
72 |     inst forall s f. {Functor f} => Functor (StateT s f) {
73 |         def fmap = \f, StateT sf -> StateT (\s ->
74 |             fmap (\(a, s') -> (f a, s')) (sf s) )
75 |     }
76 | 
77 |     inst forall s m. {Monad m} => Monad (StateT s m) {
78 |         def return = \a -> StateT (\s -> return (a, s))
79 |         def bind = \StateT sf, f -> StateT (\s ->
80 |             (a, s') <- sf s;
81 |             let StateT sf' = f a ->
82 |             sf' s'
83 |         )
84 |     }
85 | 
86 |     # inst forall s m. {Monad m} => MonadState (StateT s m) s {
87 |         def pub gets = StateT (\s -> return (s, s))
88 |         def pub puts = \s -> StateT(const $ return ((), s))
89 |     # }
90 | 
91 |     inst forall s. MonadTrans (StateT s) {
92 |         def lift = \m -> StateT (\s -> fmap (\a -> (a, s)) m)
93 |     }
94 | 
95 |     typesyn pub State s = StateT s Id.Id
96 |     def pub runState : forall s a. (State s) a -> s -> (a, s) = \m, s -> Id.runId (runStateT m s)
97 | }
98 | 


--------------------------------------------------------------------------------
/stdlib/std.spk:
--------------------------------------------------------------------------------
 1 | use pub Core
 2 | 
 3 | mod pub Monad "monad.spk"
 4 | 
 5 | mod pub List "list.spk"
 6 | 
 7 | mod pub Maybe "maybe.spk"
 8 | 
 9 | mod pub Either "either.spk"
10 | 
11 | mod pub Text "text.spk"
12 | 
13 | mod pub Debug "debug.spk"
14 | 
15 | def pub max : forall a. {Ord a} => a -> a -> a
16 |     = \a, b -> if a > b then a else b
17 | def pub min : forall a. {Ord a} => a -> a -> a
18 |     = \a, b -> if a < b then a else b
19 | 
20 | def innerdotdot = \acc, from, to ->
21 |     if from > to then acc
22 |     else innerdotdot (toEnum to :: acc) from (to - 1)
23 | def pub (..) : forall a. {Enum a} => a -> a -> [a]
24 |     = \from, to ->
25 |         innerdotdot [] (fromEnum from) (fromEnum to - 1)
26 | def pub (..=) : forall a. {Enum a} => a -> a -> [a]
27 |     = \from, to ->
28 |         innerdotdot [] (fromEnum from) (fromEnum to)
29 | 
30 | #TODO sposta in debug
31 | def pub todo : forall a. a
32 |     = error "TODO"
33 | 


--------------------------------------------------------------------------------
/stdlib/text.spk:
--------------------------------------------------------------------------------
 1 | use Core
 2 | 
 3 | mod Maybe "maybe.spk"
 4 | use Maybe
 5 | mod List "list.spk"
 6 | use List
 7 | 
 8 | def pub unwords : [String] -> String =
 9 |     \ [] -> []
10 |     | ws -> foldl1 (\t, w -> t ++ ' ':: w) ws
11 | 
12 | # TODO: Tailcall
13 | def pub unlines : [String] -> String =
14 |     \ [] -> []
15 |     | [l | ls] -> l ++ '\n'::unlines ls
16 | 
17 | def linesAux =
18 |     \ ls, [], "" -> reverse ls
19 |     | ls, w, "" -> reverse (reverse w :: ls)
20 |     | ls, w, ['\n' | s] -> linesAux (reverse w :: ls) [] s
21 |     | ls, w, [c | s] -> linesAux ls (c :: w) s
22 | and pub lines : String -> [String]
23 |     = linesAux [] []
24 | 
25 | # TODO: words
26 | 
27 | rel pub Read a = readRest : String -> Maybe (a, String)
28 | 
29 | def pub readMaybe : forall a. {Read a} => String -> Maybe a
30 |     = \s ->
31 |         (p, r) <- readRest s;
32 |         if null r then return p
33 |         else None
34 | 
35 | def pub read : forall a. {Read a} => String -> a
36 |     = \s -> put readMaybe s
37 |     | None -> error "read: no parse"
38 |     | Some p -> p
39 | 
40 | # TODO: whitespace e paren-insensitive ? Ammetti underscore?
41 | 
42 | def readDigits = \s ->
43 |     let (ds, r) = splitWhile (\d -> any (d ==) "0123456789") s ->
44 |     (map (fromEnum |> (- fromEnum '0')) ds, r)
45 | 
46 | def readInt =
47 |     let aux = \s ->
48 |         let (ds, r) = readDigits s ->
49 |         if (length ds != 0)
50 |             then Some (foldl (\st, d -> (10 * st) + d) 0 ds, r)
51 |             else None
52 |     ->
53 |     \ ['-' | s] -> fmap (\(n, r) -> (0 - n, r)) (aux s)
54 |     | s -> aux s
55 | 
56 | #TODO TEST
57 | def readFlt =
58 |     let aux = \s ->
59 |         let (intds, r) = readDigits s ->
60 |         if null intds then None
61 |         else let (fltds, r') =
62 |             put r
63 |             | ['.' | chrs] -> readDigits chrs #TODO None se è vuoto
64 |             | _ -> ([], r)
65 |         -> Some (fst $ foldl (\(n, p), d -> (n + fromInt d * p, p * 0.1)) (0.0, 10.0 ^ (length intds - 1)) (intds ++ fltds), r')
66 |     ->
67 |     \ ['-' | s] -> fmap (\(n, r) -> (0.0 - n, r)) (aux s)
68 |     | s -> aux s
69 | 
70 | def readBool =
71 |     \ ['T','r','u','e' | xs] -> Some (True, xs)
72 |     | ['F','a','l','s','e' | xs] -> Some (False, xs)
73 |     | _ -> None
74 | 
75 | inst Read Int {
76 |     def readRest = readInt
77 | }
78 | 
79 | inst Read Flt {
80 |     def readRest = readFlt
81 | }
82 | 
83 | inst Read Bool {
84 |     def readRest = readBool
85 | }
86 | 


--------------------------------------------------------------------------------
/vim/ftdetect/spinnaker.vim:
--------------------------------------------------------------------------------
1 | au BufNewFile,BufRead *.spk set filetype=spinnaker
2 | 


--------------------------------------------------------------------------------
/vim/syntax/spinnaker.vim:
--------------------------------------------------------------------------------
 1 | " Syntax highlighting di base per spinnaker (file .spk)
 2 | 
 3 | if version < 600
 4 |   syn clear
 5 | elseif exists("b:current_syntax")
 6 |   finish
 7 | endif
 8 | 
 9 | syn keyword spinnakerTopDef mod data def and ext rel inst typesyn
10 | syn keyword spinnakerModKeyword use pub
11 | syn keyword spinnakerKeyword let put forall
12 | syn keyword spinnakerConditional if then else
13 | syn match spinnakerOperator "\v[:!$%&\*\+/\-<=>\?@\\^|~.]+"
14 | syn match spinnakerNumber "\v[0-9][0-9_]*"
15 | syn match spinnakerFloat "\v[0-9][0-9_]*\.[0-9_]+"
16 | syn keyword spinnakerTodo TODO FIXME NOTE contained
17 | syn match spinnakerLineComment "#.*$" contains=spinnakerTodo
18 | syn match spinnakerIdentifier "[_a-z][a-zA-Z0-9_']*"
19 | syn match spinnakerChar "'[^'\\]'\|'\\.'\|'\\u[0-9a-fA-F]\{4}'"
20 | syn region spinnakerString start=+"+ skip=+\\\\\|\\"+ end=+"+
21 |   \ contains=@Spell
22 | syn match spinnakerType "[A-Z][a-zA-Z0-9_']*"
23 | syn region spinnakerParens matchgroup=spinnakerDelimiter start="(" end=")" contains=TOP,@Spell
24 | syn region spinnakerBrackets matchgroup=spinnakerDelimiter start="\[" end="]" contains=TOP,@Spell
25 | syn region spinnakerBlock matchgroup=spinnakerDelimiter start="{" end="}" contains=TOP,@Spell
26 | syn match spinnakerSeparator  "[,;]"
27 | 
28 | highlight def link spinnakerIdentifier Normal
29 | highlight def link spinnakerType Type
30 | highlight def link spinnakerTopDef Define
31 | highlight def link spinnakerModKeyword Include
32 | highlight def link spinnakerKeyword Keyword
33 | highlight def link spinnakerConditional Conditional
34 | highlight def link spinnakerNumber Number
35 | highlight def link spinnakerFloat Float
36 | highlight def link spinnakerOperator Operator
37 | highlight def link spinnakerTodo Todo
38 | highlight def link spinnakerLineComment Comment
39 | highlight def link spinnakerChar String
40 | highlight def link spinnakerString String
41 | highlight def link spinnakerDelimiter Delimiter
42 | highlight def link spinnakerSeparator Delimiter
43 | 
44 | let b:current_syntax = "spinnaker"
45 | " in A.B.c A e B devono essere blu (Include)
46 | " highlight per |, ->, \
47 | 


--------------------------------------------------------------------------------