ghc/CONTRIB/mira2hs

   1 #!/bin/sh
   2
   3 # mira2hs - Convert Miranda to Haskell (or Gofer)
   4
   5 # usage:        mira2hs [infile [outfile]]
   6 #
   7 # Input defaults to stdin, output defaults to <infile>.hs or stdout if
   8 # input is stdin
   9
  10 # Copyright Denis Howe 1992
  11 #
  12 # Permission is granted to make and distribute verbatim or modified
  13 # copies of this program, provided that every such copy or derived
  14 # work carries the above copyright notice and is distributed under
  15 # terms identical to these.
  16 #
  17 # Miranda is a trademark of Research Software Limited.
  18 # (E-mail: mira-request@ukc.ac.uk).
  19 #
  20 # Denis Howe <dbh@doc.ic.ac.uk>
  21
  22 # NOTE: This program needs a sed which understands \<word\> regular
  23 # expressions, eg. Sun or GNU sed (gsed).
  24
  25 # partain: got it from wombat.doc.ic.ac.uk:pub
  26
  27 # 1.05 18 Sep 1992 zip -> zipPair
  28 # 1.04 29 Jul 1992 Improve handling of ==, -- and whitespace round guards
  29 #                 $infix -> `infix`
  30 # 1.03 24 Apr 1992 Incorporate Lennart's miranda.hs functions
  31 #                 Replace most Miranda fns & operators
  32 #                 Use \<word\> patterns, ';' -> ',' in list comprehension
  33 #                 Provide example main functions
  34 # 1.02 30 Mar 1992 Mods to header, fix handling of type,type
  35 #                 Comment out String definition, Bool ops
  36 #                 num -> Int, = -> == in guards
  37 # 1.01 10 Dec 1991 Convert type names to initial capital
  38 # 1.00 27 Sep 1991 Initial version advertised to net
  39
  40 # Does NOT handle:
  41 #       continued inequalities (a < x < b)
  42 #       boolean '=' operator -> '==' (except in guards)
  43 #       main function
  44 #       multi-line type definitions
  45 #       guards on different line from body
  46 #       diagonalised list comprehensions (//)
  47 #       repeated variables in patterns (eg. LHS of function)
  48 #       filemode -> statusFile, getenv -> getEnv, read -> readFile, system
  49 #       include directives
  50 #       conflicts with prelude identifiers
  51
  52 # Miranda's num type (Integral+Floating) is changed to Int so won't
  53 # work for non-intger nums.  Miranda has irrefutable ("lazy") tuple
  54 # patterns so you may need to add a ~, like ~(x,y) in Haskell.
  55 # Haskell functions "length" and "not" may need parentheses round
  56 # their arguments.
  57
  58 # mira2hs copes equally well with literate and illiterate scripts.  It
  59 # doesn't care what characters lines begins with - it assumes
  60 # everything is code.  It will convert code even inside comments.
  61 #
  62 # For literate programs you will have to turn the standard header into
  63 # literate form and rename the output .lhs.  You might want to do this
  64 # to (a copy of) mira2hs itself if you have lots of literate progs.
  65
  66 # ToDo: = inside brackets -> ==
  67
  68 if [ -n "$1" ]
  69 then    in=$1
  70         out=`basename $in .m`.hs
  71 else    in="Standard input"
  72 fi
  73 [ -n "$2" ] && out=$2
  74 tmp=/tmp/m2h$$
  75 script=${tmp}s
  76
  77 # Prepend a standard header and some function definitions.
  78 echo -- $in converted to Haskell by $USER on `date` > $tmp
  79 cat << "++++" >> $tmp
  80 module Main (main) where
  81
  82 -------------------- mira2hs functions --------------------
  83
  84 cjustify :: Int -> String -> String
  85 cjustify n s = spaces l ++ s ++ spaces r
  86                where
  87                m = n - length s
  88                l = div m 2
  89                r = m - l
  90
  91 e :: (Floating a) => a
  92 e = exp 1
  93
  94 hugenum :: (RealFloat a) => a
  95 hugenum = encodeFloat (r^d-1) (n-d)
  96           where r = floatRadix hugenum
  97                 d = floatDigits hugenum
  98                 (_,n) = floatRange hugenum
  99
 100 subscripts :: [a] -> [Int]      -- Miranda index
 101 subscripts xs = f xs 0
 102                 where f []     n = []
 103                       f (_:xs) n = n : f xs (n+1)
 104
 105 integer :: (RealFrac a) => a -> Bool
 106 integer x = x == fromIntegral (truncate x)
 107
 108 lay :: [String] -> String
 109 lay = concat . map (++"\n")
 110
 111 layn :: [String] -> String
 112 layn =  concat . zipWith f [1..]
 113            where
 114            f :: Int -> String -> String
 115            f n x = rjustify 4 (show n) ++ ") " ++ x ++ "\n"
 116
 117 limit :: (Eq a) => [a] -> a
 118 limit (x:y:ys) | x == y    = x
 119                | otherwise = limit (y:ys)
 120 limit _                    = error "limit: bad use"
 121
 122 ljustify :: Int -> String -> String
 123 ljustify n s = s ++ spaces (n - length s)
 124
 125 member :: (Eq a) => [a] -> a -> Bool
 126 member xs x = elem x xs
 127
 128 merge :: (Ord a) => [a] -> [a] -> [a]
 129 merge []         ys                     = ys
 130 merge xs         []                     = xs
 131 merge xxs@(x:xs) yys@(y:ys) | x <= y    = x : merge xs  yys
 132                             | otherwise = y : merge xxs ys
 133
 134 numval :: (Num a) => String -> a
 135 numval cs = read cs
 136
 137 postfix :: [a] -> a -> [a]
 138 postfix xs x = xs ++ [x]
 139
 140 rep :: Int -> b -> [b]
 141 rep n x = take n (repeat x)
 142
 143 rjustify :: Int -> String -> String
 144 rjustify n s = spaces (n - length s) ++ s
 145
 146 seq :: (Eq a) => a -> b -> b
 147 seq x y = if x == x then y else y
 148
 149 shownum :: (Num a) => a -> String
 150 shownum x = show x
 151
 152 sort :: (Ord a) => [a] -> [a]
 153 sort x  | n <= 1        = x
 154         | otherwise     = merge (sort (take n2 x)) (sort (drop n2 x))
 155                           where n = length x
 156                                 n2 = div n 2
 157 spaces :: Int -> String
 158 spaces 0 = ""
 159 spaces n = ' ' : spaces (n-1)
 160
 161 tinynum :: (RealFloat a) => a
 162 tinynum = encodeFloat 1 (n-d)
 163           where r = floatRadix tinynum
 164                 d = floatDigits tinynum
 165                 (n,_) = floatRange tinynum
 166
 167 undef :: a
 168 undef = error "undefined"
 169
 170 zipPair (x,y) = zip x y
 171
 172 -- Following is UNTESTED
 173 data Sys_message =
 174         Stdout String | Stderr String | Tofile String String |
 175         Closefile String | Appendfile String |
 176 --      System String |
 177         Exit Int
 178
 179 doSysMessages :: [Sys_message] -> Dialogue
 180 doSysMessages requests responses = doMsgs requests []
 181
 182 doMsgs []                       afs     = []
 183 doMsgs ((Appendfile f):rs)      afs     = doMsgs rs (f:afs)
 184 doMsgs ((Exit n)      :rs)      afs     = []
 185 doMsgs (r             :rs)      afs
 186  = doMsg r : doMsgs rs afs
 187   where doMsg (Stdout s)        = AppendChan stdout s
 188         doMsg (Stderr s)        = AppendChan stderr s
 189         doMsg (Tofile f s)      | elem f afs = AppendFile f s
 190                                 | otherwise  = WriteFile  f s
 191         doMsg (Closefile f)
 192          = error "doSysMessages{mira2hs}: Closefile sys_message not supported"
 193 --      doMsg (Closefile f)     = CloseFile f   -- optional
 194 --      doMsg (System cmd)
 195 --       = error "doSysMessages{mira2hs}: System sys_message not supported"
 196
 197 -- Pick a main.  (If I was clever main would be an overloaded fn :-).
 198 main :: Dialogue
 199 -- main = printString s         -- s :: String
 200 -- main = interact f            -- f :: String -> String
 201 -- main = doSysMessages l       -- l :: [Sys_message]
 202 -- main = print x               -- x :: (Text a) => a
 203
 204 printString :: String -> Dialogue
 205 printString s = appendChan stdout s abort done
 206
 207 -------------------- mira2hs functions end --------------------
 208
 209 ++++
 210 # It's amazing what sed can do.
 211 sed '
 212 # Type synonyms and constructed types: insert "type" or "data".  Add a
 213 # dummy :: to flag this line to the type name munging below.  Beware
 214 # ====== in comments.
 215 /[^=]==[^=]/s/\(.*=\)=/::type \1/g
 216 /::=/s/\(.*\)::=/::data \1=/g
 217 # Change type variable *s to "a"s
 218 /::/s/\*/a/g
 219 # List length & various other renamed functions (# reused below).
 220 s/ *# */ length /g
 221 s/\<arctan\>/atan/g
 222 s/\<code\>/ord/g
 223 s/\<converse\>/flip/g
 224 s/\<decode\>/chr/g
 225 s/\<dropwhile\>/dropWhile/g
 226 s/\<digit\>/isDigit/g
 227 s/\<entier\>/floor/g
 228 s/\<hd\>/head/g
 229 s/\<index\>/subscripts/g
 230 s/\<letter\>/isAlpha/g
 231 s/\<map2\>/zipWith/g
 232 s/\<max\>/maximum/g
 233 s/\<max2\>/max/g
 234 s/\<min\>/minimum/g
 235 s/\<min2\>/min/g
 236 s/\<mkset\>/nub/g
 237 s/\<neg\>/negate/g
 238 s/\<scan\>/scanl/g
 239 s/\<tl\>/tail/g
 240 # Miranda uncurried zip -> zipPair (above).  Do before zip2->zip.
 241 s/\<zip\>/zipPair/g
 242 # Miranda curried zip2 -> zip
 243 s/\<zip2\>/zip/g
 244 # Haskel div and mod are functions, not operators
 245 s/\<div\>/\`div\`/g
 246 s/\<mod\>/\`mod\`/g
 247 # Locate commas introducing guards by temporarily changing others.
 248 # Replace comma with #  when after || or unmatched ( or [ or before
 249 # unmatched ) or ] or in string or char constants.  Replace
 250 # matched () not containing commas with _<_ _>_ and matched []
 251 # with _{_ _}_ and repeat until no substitutions.
 252 : comma
 253 s/\(||.*\),/\1#/g
 254 s/\([[(][^])]*\),/\1#/g
 255 s/,\([^[(]*[])]\)/#\1/g
 256 s/(\([^),]*\))/_<_\1_>_/g
 257 s/\[\([^],]*\)\]/_{_\1_}_/g
 258 s/"\(.*\),\(.*\)"/"\1#\2"/g
 259 '"#change quotes
 260 s/','/'#'/g
 261 "'#change quotes
 262 t comma
 263 # Restore () and []
 264 s/_<_/(/g
 265 s/_>_/)/g
 266 s/_{_/[/g
 267 s/_}_/]/g
 268 # The only commas left now introduce guards, remove optional "if"
 269 s/,[    ]*if/,/g
 270 s/[     ]*,[    ]*/,/g
 271 # Temporarily change ~=, <=, >=.
 272 s%~=%/_eq_%g
 273 s/<=/<_eq_/g
 274 s/>=/>_eq_/g
 275 # Replace every = in guard with == (do after type synonyms)
 276 : neq
 277 s/\(,.*[^=]\)=\([^=]\)/\1==\2/
 278 t neq
 279 # Fix other equals
 280 s/_eq_/=/g
 281 # Replace <pattern> = <rhs> , <guard> with <pattern> | (<guard>) = <rhs>
 282 s/=\(..*\),\(..*\)/| (\2) =\1/g
 283 s/(otherwise)/otherwise/g
 284 # Restore other commas
 285 s/#/,/g
 286 # List difference.  Beware ------ in comments.
 287 s/\([^-]\)--\([^-]\)/\1\\\\\2/g
 288 # Comments (do after list diff)
 289 s/||/--/g
 290 s/--|/---/g
 291 # Boolean not, or, and (do after comments)
 292 s/ *~ */ not /g
 293 s% *\\/ *% || %g
 294 s/&/&&/g
 295 # list indexing
 296 s/!/!!/g
 297 # Locate semicolon in list comprehensions by temporarily replacing ones
 298 # in string or char constants with #.  Replace matched [] not
 299 # containing semicolon with _{_ _}_ and repeat until no substitutions.
 300 : semico
 301 s/\[\([^];]*\)\]/_{_\1_}_/g
 302 s/"\([^;"]*\);\([^;"]*\)"/"\1#\2"/g
 303 '"#change quotes
 304 s/';'/'#'/g
 305 "'# change quotes
 306 t semico
 307 # Remaining [ ] must contain semicolons which we change to comas.
 308 : lcomp
 309 s/\(\[[^;]*\);/\1,/g
 310 s/;\([^;]*\]\)/,\1/g
 311 t lcomp
 312 # Restore [] and other semicolons
 313 s/_{_/[/g
 314 s/_}_/]/g
 315 s/#/;/g
 316 # Miranda dollar turns a function into an infix operator
 317 s/\$\([_A-Za-z0-9'\'']\{1,\}\)/`\1`/g
 318 ' $1 >> $tmp
 319
 320 # Create a sed script to change the first letter of each type name to
 321 # upper case.
 322 # Dummy definitions for predefined types (num is special).
 323 (
 324         echo ::type char =
 325         echo ::type bool =
 326         echo ::type sys_message =
 327         cat $tmp
 328 ) | \
 329 # Find type definitions & extract type names
 330 sed -n '/::data[        ].*=/{
 331 h;s/::data[      ]*\([^  =]\).*/\1/p
 332 y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/;p
 333 g;s/::data[      ]*[^   =]\([^  =]*\).*=.*/\1/p
 334 }
 335 /::type[        ].*=/{
 336 h;s/::type[      ]*\([^  =]\).*/\1/p
 337 y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/;p
 338 g;s/::type[      ]*[^   =]\([^  =]*\).*=.*/\1/p
 339 }' | \
 340 # Read lower case initial, upper case inital and rest of type name.
 341 # Type is always after "::".
 342 (
 343 echo ": loop"
 344 while read h; read H; read t
 345 do echo "/::/s/\<$h$t\>/$H$t/g"
 346 done
 347 cat << "++++"
 348 # num -> Int
 349 /::/s/\<num\>/Int/g
 350 # Loop round to catch type,type,..
 351 t loop
 352 # Remove the dummy :: flags from type definitions.
 353 s/::type/type/
 354 s/::data/data/
 355 # Comment out string type if defined.
 356 s/\(type[       ]*String[       ]*=\)/-- \1/
 357 ++++
 358 ) > $script
 359
 360 if [ "$out" ]
 361 then    exec > $out
 362 fi
 363 sed -f $script $tmp
 364 rm -f ${tmp}*