/
ConstraintTermsPrototype.lhs
62 lines (48 loc) · 1.92 KB
/
ConstraintTermsPrototype.lhs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
Author: Dominic Orchard
License: BSD
Prototype implementation of constraint synonsm and constraint families as described in
"Haskell Type Constraints Unleashed" (Dominic Orchard, Tom Schrijvers)
> module Main where
> import Language.Haskell.Exts.Fixity
> import Language.Haskell.Exts.Syntax
> import Language.Haskell.Exts.Parser
> import Language.Haskell.Exts.Pretty
> import System.Environment
import System.IO
> import Rewrite.Helpers
> import Rewrite.Synonyms
> import Rewrite.Families
> import Rewrite.PreTransform
> transform = rewriteFamilies . rewriteSynonyms
> preTransform = preTransformFamilies . preTransformSynonyms
> main = do
> xs <- getArgs
> case xs of
> [x] -> mainB x
> [x,y] -> mainA x y
> [x,y,z] -> mainA y z
> otherwise -> putStr usageMessage
> mainC input =
> case myParseHsModule (preTransform input) of
> Left err -> print err
> Right x -> putStr $ (header ++ (prettyPrint $ transform x) ++ "\n\n")
> mainA inFile outFile = do
> input <- readFile inFile
> parsed <- return $ myParseHsModule (preTransform input)
> case parsed of
> Left err -> print err
> Right x -> writeFile outFile (header ++ (prettyPrint $ transform x))
> mainB inFile = do
> input <- readFile inFile
> parsed <- return $ myParseHsModule (preTransform input)
> case parsed of
> Left err -> print err
> Right x -> putStr $ (header ++ (prettyPrint $ transform x) ++ "\n\n")
> header = concatMap (\x -> "{-# LANGUAGE "++x++" #-}\n") ["FlexibleContexts",
> "FlexibleInstances",
> "UndecidableInstances",
> "TypeFamilies",
> "GADTs"]
>
> usageMessage = "usage:\t constraintTermExts input.hs output.hs\n or"++
> "\t constraintTermExts input.hs\n\n"