reintroduce the compiler API

src/compiler/api/Data/Binary.hs

@@ -0,0 +1,814 @@
+{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      : Data.Binary
+-- Copyright   : Lennart Kolmodin
+-- License     : BSD3-style (see LICENSE)
+-- 
+-- Maintainer  : Lennart Kolmodin <kolmodin@dtek.chalmers.se>
+-- Stability   : unstable
+-- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances
+--
+-- Binary serialisation of Haskell values to and from lazy ByteStrings.
+-- The Binary library provides methods for encoding Haskell values as
+-- streams of bytes directly in memory. The resulting @ByteString@ can
+-- then be written to disk, sent over the network, or futher processed
+-- (for example, compressed with gzip).
+--
+-- The 'Binary' package is notable in that it provides both pure, and
+-- high performance serialisation.
+--
+-- Values are always encoded in network order (big endian) form, and
+-- encoded data should be portable across machine endianess, word size,
+-- or compiler version. For example, data encoded using the Binary class
+-- could be written from GHC, and read back in Hugs.
+--
+-----------------------------------------------------------------------------
+
+module Data.Binary (
+
+    -- * The Binary class
+      Binary(..)
+
+    -- $example
+
+    -- * The Get and Put monads
+    , Get
+    , Put
+
+    -- * Useful helpers for writing instances
+    , putWord8
+    , getWord8
+
+    -- * Binary serialisation
+    , encode                    -- :: Binary a => a -> ByteString
+    , decode                    -- :: Binary a => ByteString -> a
+
+    -- * IO functions for serialisation
+    , encodeFile                -- :: Binary a => FilePath -> a -> IO ()
+    , decodeFile                -- :: Binary a => FilePath -> IO a
+
+    , encodeFile_               -- :: FilePath -> Put   -> IO ()
+    , decodeFile_               -- :: FilePath -> Get a -> IO a
+
+-- Lazy put and get
+--  , lazyPut
+--  , lazyGet
+
+    , module Data.Word -- useful
+
+    ) where
+
+#include "MachDeps.h"
+
+import Data.Word
+
+import Data.Binary.Put
+import Data.Binary.Get
+import Data.Binary.IEEE754 ( putFloat64be, getFloat64be)
+import Control.Monad
+import Control.Exception
+import Foreign
+import System.IO
+
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy as L
+
+import Data.Char    (chr,ord)
+import Data.List    (unfoldr)
+
+-- And needed for the instances:
+import qualified Data.ByteString as B
+import qualified Data.Map        as Map
+import qualified Data.Set        as Set
+import qualified Data.IntMap     as IntMap
+import qualified Data.IntSet     as IntSet
+import qualified Data.Ratio      as R
+
+import qualified Data.Tree as T
+
+import Data.Array.Unboxed
+
+--
+-- This isn't available in older Hugs or older GHC
+--
+#if __GLASGOW_HASKELL__ >= 606
+import qualified Data.Sequence as Seq
+import qualified Data.Foldable as Fold
+#endif
+
+------------------------------------------------------------------------
+
+-- | The @Binary@ class provides 'put' and 'get', methods to encode and
+-- decode a Haskell value to a lazy ByteString. It mirrors the Read and
+-- Show classes for textual representation of Haskell types, and is
+-- suitable for serialising Haskell values to disk, over the network.
+--
+-- For parsing and generating simple external binary formats (e.g. C
+-- structures), Binary may be used, but in general is not suitable
+-- for complex protocols. Instead use the Put and Get primitives
+-- directly.
+--
+-- Instances of Binary should satisfy the following property:
+--
+-- > decode . encode == id
+--
+-- That is, the 'get' and 'put' methods should be the inverse of each
+-- other. A range of instances are provided for basic Haskell types. 
+--
+class Binary t where
+    -- | Encode a value in the Put monad.
+    put :: t -> Put
+    -- | Decode a value in the Get monad
+    get :: Get t
+
+-- $example
+-- To serialise a custom type, an instance of Binary for that type is
+-- required. For example, suppose we have a data structure:
+--
+-- > data Exp = IntE Int
+-- >          | OpE  String Exp Exp
+-- >    deriving Show
+--
+-- We can encode values of this type into bytestrings using the
+-- following instance, which proceeds by recursively breaking down the
+-- structure to serialise:
+--
+-- > instance Binary Exp where
+-- >       put (IntE i)          = do put (0 :: Word8)
+-- >                                  put i
+-- >       put (OpE s e1 e2)     = do put (1 :: Word8)
+-- >                                  put s
+-- >                                  put e1
+-- >                                  put e2
+-- > 
+-- >       get = do t <- get :: Get Word8
+-- >                case t of
+-- >                     0 -> do i <- get
+-- >                             return (IntE i)
+-- >                     1 -> do s  <- get
+-- >                             e1 <- get
+-- >                             e2 <- get
+-- >                             return (OpE s e1 e2)
+--
+-- Note how we write an initial tag byte to indicate each variant of the
+-- data type.
+--
+-- We can simplify the writing of 'get' instances using monadic
+-- combinators:
+-- 
+-- >       get = do tag <- getWord8
+-- >                case tag of
+-- >                    0 -> liftM  IntE get
+-- >                    1 -> liftM3 OpE  get get get
+--
+-- The generation of Binary instances has been automated by a script
+-- using Scrap Your Boilerplate generics. Use the script here:
+--  <http://darcs.haskell.org/binary/tools/derive/BinaryDerive.hs>.
+--
+-- To derive the instance for a type, load this script into GHCi, and
+-- bring your type into scope. Your type can then have its Binary
+-- instances derived as follows:
+--
+-- > $ ghci -fglasgow-exts BinaryDerive.hs
+-- > *BinaryDerive> :l Example.hs
+-- > *Main> deriveM (undefined :: Drinks)
+-- >
+-- > instance Binary Main.Drinks where
+-- >      put (Beer a) = putWord8 0 >> put a
+-- >      put Coffee = putWord8 1
+-- >      put Tea = putWord8 2
+-- >      put EnergyDrink = putWord8 3
+-- >      put Water = putWord8 4
+-- >      put Wine = putWord8 5
+-- >      put Whisky = putWord8 6
+-- >      get = do
+-- >        tag_ <- getWord8
+-- >        case tag_ of
+-- >          0 -> get >>= \a -> return (Beer a)
+-- >          1 -> return Coffee
+-- >          2 -> return Tea
+-- >          3 -> return EnergyDrink
+-- >          4 -> return Water
+-- >          5 -> return Wine
+-- >          6 -> return Whisky
+-- >
+--
+-- To serialise this to a bytestring, we use 'encode', which packs the
+-- data structure into a binary format, in a lazy bytestring
+--
+-- > > let e = OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2))
+-- > > let v = encode e
+--
+-- Where 'v' is a binary encoded data structure. To reconstruct the
+-- original data, we use 'decode'
+--
+-- > > decode v :: Exp
+-- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2))
+--
+-- The lazy ByteString that results from 'encode' can be written to
+-- disk, and read from disk using Data.ByteString.Lazy IO functions,
+-- such as hPutStr or writeFile:
+--
+-- > > writeFile "/tmp/exp.txt" (encode e)
+--
+-- And read back with:
+--
+-- > > readFile "/tmp/exp.txt" >>= return . decode :: IO Exp
+-- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2))
+--
+-- We can also directly serialise a value to and from a Handle, or a file:
+-- 
+-- > > v <- decodeFile  "/tmp/exp.txt" :: IO Exp
+-- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2))
+--
+-- And write a value to disk
+--
+-- > > encodeFile "/tmp/a.txt" v
+--
+
+------------------------------------------------------------------------
+-- Wrappers to run the underlying monad
+
+-- | Encode a value using binary serialisation to a lazy ByteString.
+--
+encode :: Binary a => a -> ByteString
+encode = runPut . put
+{-# INLINE encode #-}
+
+-- | Decode a value from a lazy ByteString, reconstructing the original structure.
+--
+decode :: Binary a => ByteString -> a
+decode = runGet get
+
+------------------------------------------------------------------------
+-- Convenience IO operations
+
+-- | Lazily serialise a value to a file
+--
+-- This is just a convenience function, it's defined simply as:
+--
+-- > encodeFile f = B.writeFile f . encode
+--
+-- So for example if you wanted to compress as well, you could use:
+--
+-- > B.writeFile f . compress . encode
+--
+encodeFile :: Binary a => FilePath -> a -> IO ()
+encodeFile f v = L.writeFile f (encode v)
+
+encodeFile_ :: FilePath -> Put -> IO ()
+encodeFile_ f m = L.writeFile f (runPut m)
+
+-- | Lazily reconstruct a value previously written to a file.
+--
+-- This is just a convenience function, it's defined simply as:
+--
+-- > decodeFile f = return . decode =<< B.readFile f
+--
+-- So for example if you wanted to decompress as well, you could use:
+--
+-- > return . decode . decompress =<< B.readFile f
+--
+decodeFile :: Binary a => FilePath -> IO a
+decodeFile f = bracket (openBinaryFile f ReadMode) hClose $ \h -> do
+    s <- L.hGetContents h
+    evaluate $ runGet get s
+
+decodeFile_ :: FilePath -> Get a -> IO a
+decodeFile_ f m = bracket (openBinaryFile f ReadMode) hClose $ \h -> do
+    s <- L.hGetContents h
+    evaluate $ runGet m s
+
+-- needs bytestring 0.9.1.x to work 
+
+------------------------------------------------------------------------
+-- Lazy put and get
+
+-- lazyPut :: (Binary a) => a -> Put
+-- lazyPut a = put (encode a)
+
+-- lazyGet :: (Binary a) => Get a
+-- lazyGet = fmap decode get
+
+------------------------------------------------------------------------
+-- Simple instances
+
+-- The () type need never be written to disk: values of singleton type
+-- can be reconstructed from the type alone
+instance Binary () where
+    put ()  = return ()
+    get     = return ()
+
+-- Bools are encoded as a byte in the range 0 .. 1
+instance Binary Bool where
+    put     = putWord8 . fromIntegral . fromEnum
+    get     = liftM (toEnum . fromIntegral) getWord8
+
+-- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2
+instance Binary Ordering where
+    put     = putWord8 . fromIntegral . fromEnum
+    get     = liftM (toEnum . fromIntegral) getWord8
+
+------------------------------------------------------------------------
+-- Words and Ints
+
+-- Words8s are written as bytes
+instance Binary Word8 where
+    put     = putWord8
+    get     = getWord8
+
+-- Words16s are written as 2 bytes in big-endian (network) order
+instance Binary Word16 where
+    put     = putWord16be
+    get     = getWord16be
+
+-- Words32s are written as 4 bytes in big-endian (network) order
+instance Binary Word32 where
+    put     = putWord32be
+    get     = getWord32be
+
+-- Words64s are written as 8 bytes in big-endian (network) order
+instance Binary Word64 where
+    put     = putWord64be
+    get     = getWord64be
+
+-- Int8s are written as a single byte.
+instance Binary Int8 where
+    put i   = put (fromIntegral i :: Word8)
+    get     = liftM fromIntegral (get :: Get Word8)
+
+-- Int16s are written as a 2 bytes in big endian format
+instance Binary Int16 where
+    put i   = put (fromIntegral i :: Word16)
+    get     = liftM fromIntegral (get :: Get Word16)
+
+-- Int32s are written as a 4 bytes in big endian format
+instance Binary Int32 where
+    put i   = put (fromIntegral i :: Word32)
+    get     = liftM fromIntegral (get :: Get Word32)
+
+-- Int64s are written as a 8 bytes in big endian format
+instance Binary Int64 where
+    put i   = put (fromIntegral i :: Word64)
+    get     = liftM fromIntegral (get :: Get Word64)
+
+------------------------------------------------------------------------
+
+-- Words are written as sequence of bytes. The last bit of each
+-- byte indicates whether there are more bytes to be read
+instance Binary Word where
+    put i | i <=               0x7f = do put  a
+          | i <=             0x3fff = do put (a .|. 0x80)
+                                         put  b
+          | i <=           0x1fffff = do put (a .|. 0x80)
+                                         put (b .|. 0x80)
+                                         put  c
+          | i <=          0xfffffff = do put (a .|. 0x80)
+                                         put (b .|. 0x80)
+                                         put (c .|. 0x80)
+                                         put  d
+-- -- #if WORD_SIZE_IN_BITS < 64
+          | otherwise               = do put (a .|. 0x80)
+                                         put (b .|. 0x80)
+                                         put (c .|. 0x80)
+                                         put (d .|. 0x80)
+                                         put  e
+{-
+-- Restricted to 32 bits even on 64-bit systems, so that negative
+-- Ints are written as 5 bytes instead of 10 bytes (TH 2013-02-13)
+--#else
+          | i <=        0x7ffffffff = do put (a .|. 0x80)
+                                         put (b .|. 0x80)
+                                         put (c .|. 0x80)
+                                         put (d .|. 0x80)
+                                         put  e
+          | i <=      0x3ffffffffff = do put (a .|. 0x80)
+                                         put (b .|. 0x80)
+                                         put (c .|. 0x80)
+                                         put (d .|. 0x80)
+                                         put (e .|. 0x80)
+                                         put  f
+          | i <=    0x1ffffffffffff = do put (a .|. 0x80)
+                                         put (b .|. 0x80)
+                                         put (c .|. 0x80)
+                                         put (d .|. 0x80)
+                                         put (e .|. 0x80)
+                                         put (f .|. 0x80)
+                                         put  g
+          | i <=   0xffffffffffffff = do put (a .|. 0x80)
+                                         put (b .|. 0x80)
+                                         put (c .|. 0x80)
+                                         put (d .|. 0x80)
+                                         put (e .|. 0x80)
+                                         put (f .|. 0x80)
+                                         put (g .|. 0x80)
+                                         put  h
+          | i <=   0xffffffffffffff = do put (a .|. 0x80)
+                                         put (b .|. 0x80)
+                                         put (c .|. 0x80)
+                                         put (d .|. 0x80)
+                                         put (e .|. 0x80)
+                                         put (f .|. 0x80)
+                                         put (g .|. 0x80)
+                                         put  h
+          | i <= 0x7fffffffffffffff = do put (a .|. 0x80)
+                                         put (b .|. 0x80)
+                                         put (c .|. 0x80)
+                                         put (d .|. 0x80)
+                                         put (e .|. 0x80)
+                                         put (f .|. 0x80)
+                                         put (g .|. 0x80)
+                                         put (h .|. 0x80)
+                                         put  j
+          | otherwise               = do put (a .|. 0x80)
+                                         put (b .|. 0x80)
+                                         put (c .|. 0x80)
+                                         put (d .|. 0x80)
+                                         put (e .|. 0x80)
+                                         put (f .|. 0x80)
+                                         put (g .|. 0x80)
+                                         put (h .|. 0x80)
+                                         put (j .|. 0x80)
+                                         put  k
+-- #endif
+-}
+          where
+            a = fromIntegral (       i    .&. 0x7f) :: Word8
+            b = fromIntegral (shiftR i  7 .&. 0x7f) :: Word8
+            c = fromIntegral (shiftR i 14 .&. 0x7f) :: Word8
+            d = fromIntegral (shiftR i 21 .&. 0x7f) :: Word8
+            e = fromIntegral (shiftR i 28 .&. 0x7f) :: Word8
+{-
+            f = fromIntegral (shiftR i 35 .&. 0x7f) :: Word8
+            g = fromIntegral (shiftR i 42 .&. 0x7f) :: Word8
+            h = fromIntegral (shiftR i 49 .&. 0x7f) :: Word8
+            j = fromIntegral (shiftR i 56 .&. 0x7f) :: Word8
+            k = fromIntegral (shiftR i 63 .&. 0x7f) :: Word8
+-}
+    get = do i <- getWord8
+             (if i <= 0x7f
+                then return (fromIntegral i)
+                else do n <- get
+                        return $ (n `shiftL` 7) .|. (fromIntegral (i .&. 0x7f)))
+
+-- Int has the same representation as Word
+instance Binary Int where
+    put i   = put (fromIntegral i :: Word)
+    get     = liftM toInt32 (get :: Get Word)
+      where
+       -- restrict to 32 bits (for PGF portability, TH 2013-02-13)
+       toInt32 w = fromIntegral (fromIntegral w::Int32)::Int
+
+------------------------------------------------------------------------
+-- 
+-- Portable, and pretty efficient, serialisation of Integer
+--
+
+-- Fixed-size type for a subset of Integer
+type SmallInt = Int32
+
+-- Integers are encoded in two ways: if they fit inside a SmallInt,
+-- they're written as a byte tag, and that value.  If the Integer value
+-- is too large to fit in a SmallInt, it is written as a byte array,
+-- along with a sign and length field.
+
+instance Binary Integer where
+
+    {-# INLINE put #-}
+    put n | n >= lo && n <= hi = do
+        putWord8 0
+        put (fromIntegral n :: SmallInt)  -- fast path
+     where
+        lo = fromIntegral (minBound :: SmallInt) :: Integer
+        hi = fromIntegral (maxBound :: SmallInt) :: Integer
+
+    put n = do
+        putWord8 1
+        put sign
+        put (unroll (abs n))         -- unroll the bytes
+     where
+        sign = fromIntegral (signum n) :: Word8
+
+    {-# INLINE get #-}
+    get = do
+        tag <- get :: Get Word8
+        case tag of
+            0 -> liftM fromIntegral (get :: Get SmallInt)
+            _ -> do sign  <- get
+                    bytes <- get
+                    let v = roll bytes
+                    return $! if sign == (1 :: Word8) then v else - v
+
+--
+-- Fold and unfold an Integer to and from a list of its bytes
+--
+unroll :: Integer -> [Word8]
+unroll = unfoldr step
+  where
+    step 0 = Nothing
+    step i = Just (fromIntegral i, i `shiftR` 8)
+
+roll :: [Word8] -> Integer
+roll   = foldr unstep 0
+  where
+    unstep b a = a `shiftL` 8 .|. fromIntegral b
+
+{-
+
+--
+-- An efficient, raw serialisation for Integer (GHC only)
+--
+
+-- TODO  This instance is not architecture portable.  GMP stores numbers as
+-- arrays of machine sized words, so the byte format is not portable across
+-- architectures with different endianess and word size.
+
+import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy)
+import GHC.Base     hiding (ord, chr)
+import GHC.Prim
+import GHC.Ptr (Ptr(..))
+import GHC.IOBase (IO(..))
+
+instance Binary Integer where
+    put (S# i)    = putWord8 0 >> put (I# i)
+    put (J# s ba) = do
+        putWord8 1
+        put (I# s)
+        put (BA ba)
+
+    get = do
+        b <- getWord8
+        case b of
+            0 -> do (I# i#) <- get
+                    return (S# i#)
+            _ -> do (I# s#) <- get
+                    (BA a#) <- get
+                    return (J# s# a#)
+
+instance Binary ByteArray where
+
+    -- Pretty safe.
+    put (BA ba) =
+        let sz   = sizeofByteArray# ba   -- (primitive) in *bytes*
+            addr = byteArrayContents# ba
+            bs   = unsafePackAddress (I# sz) addr
+        in put bs   -- write as a ByteString. easy, yay!
+
+    -- Pretty scary. Should be quick though
+    get = do
+        (fp, off, n@(I# sz)) <- liftM toForeignPtr get      -- so decode a ByteString
+        assert (off == 0) $ return $ unsafePerformIO $ do
+            (MBA arr) <- newByteArray sz                    -- and copy it into a ByteArray#
+            let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe?
+            withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n)
+            freezeByteArray arr
+
+-- wrapper for ByteArray#
+data ByteArray = BA  {-# UNPACK #-} !ByteArray#
+data MBA       = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld)
+
+newByteArray :: Int# -> IO MBA
+newByteArray sz = IO $ \s ->
+  case newPinnedByteArray# sz s of { (# s', arr #) ->
+  (# s', MBA arr #) }
+
+freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
+freezeByteArray arr = IO $ \s ->
+  case unsafeFreezeByteArray# arr s of { (# s', arr' #) ->
+  (# s', BA arr' #) }
+
+-}
+
+instance (Binary a,Integral a) => Binary (R.Ratio a) where
+    put r = put (R.numerator r) >> put (R.denominator r)
+    get = liftM2 (R.%) get get
+
+------------------------------------------------------------------------
+
+-- Char is serialised as UTF-8
+instance Binary Char where
+    put a | c <= 0x7f     = put (fromIntegral c :: Word8)
+          | c <= 0x7ff    = do put (0xc0 .|. y)
+                               put (0x80 .|. z)
+          | c <= 0xffff   = do put (0xe0 .|. x)
+                               put (0x80 .|. y)
+                               put (0x80 .|. z)
+          | c <= 0x10ffff = do put (0xf0 .|. w)
+                               put (0x80 .|. x)
+                               put (0x80 .|. y)
+                               put (0x80 .|. z)
+          | otherwise     = error "Not a valid Unicode code point"
+     where
+        c = ord a
+        z, y, x, w :: Word8
+        z = fromIntegral (c           .&. 0x3f)
+        y = fromIntegral (shiftR c 6  .&. 0x3f)
+        x = fromIntegral (shiftR c 12 .&. 0x3f)
+        w = fromIntegral (shiftR c 18 .&. 0x7)
+
+    get = do
+        let getByte = liftM (fromIntegral :: Word8 -> Int) get
+            shiftL6 = flip shiftL 6 :: Int -> Int
+        w <- getByte
+        r <- case () of
+                _ | w < 0x80  -> return w
+                  | w < 0xe0  -> do
+                                    x <- liftM (xor 0x80) getByte
+                                    return (x .|. shiftL6 (xor 0xc0 w))
+                  | w < 0xf0  -> do
+                                    x <- liftM (xor 0x80) getByte
+                                    y <- liftM (xor 0x80) getByte
+                                    return (y .|. shiftL6 (x .|. shiftL6
+                                            (xor 0xe0 w)))
+                  | otherwise -> do
+                                x <- liftM (xor 0x80) getByte
+                                y <- liftM (xor 0x80) getByte
+                                z <- liftM (xor 0x80) getByte
+                                return (z .|. shiftL6 (y .|. shiftL6
+                                        (x .|. shiftL6 (xor 0xf0 w))))
+        return $! chr r
+
+------------------------------------------------------------------------
+-- Instances for the first few tuples
+
+instance (Binary a, Binary b) => Binary (a,b) where
+    put (a,b)           = put a >> put b
+    get                 = liftM2 (,) get get
+
+instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
+    put (a,b,c)         = put a >> put b >> put c
+    get                 = liftM3 (,,) get get get
+
+instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
+    put (a,b,c,d)       = put a >> put b >> put c >> put d
+    get                 = liftM4 (,,,) get get get get
+
+instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where
+    put (a,b,c,d,e)     = put a >> put b >> put c >> put d >> put e
+    get                 = liftM5 (,,,,) get get get get get
+
+-- 
+-- and now just recurse:
+--
+
+instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f)
+        => Binary (a,b,c,d,e,f) where
+    put (a,b,c,d,e,f)   = put (a,(b,c,d,e,f))
+    get                 = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f)
+
+instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g)
+        => Binary (a,b,c,d,e,f,g) where
+    put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g))
+    get                 = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g)
+
+instance (Binary a, Binary b, Binary c, Binary d, Binary e,
+          Binary f, Binary g, Binary h)
+        => Binary (a,b,c,d,e,f,g,h) where
+    put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h))
+    get                   = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h)
+
+instance (Binary a, Binary b, Binary c, Binary d, Binary e,
+          Binary f, Binary g, Binary h, Binary i)
+        => Binary (a,b,c,d,e,f,g,h,i) where
+    put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i))
+    get                     = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i)
+
+instance (Binary a, Binary b, Binary c, Binary d, Binary e,
+          Binary f, Binary g, Binary h, Binary i, Binary j)
+        => Binary (a,b,c,d,e,f,g,h,i,j) where
+    put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j))
+    get                       = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j)
+
+------------------------------------------------------------------------
+-- Container types
+
+instance Binary a => Binary [a] where
+    put l  = put (length l) >> mapM_ put l
+    get    = do n <- get :: Get Int
+                xs <- replicateM n get
+                return xs
+
+instance (Binary a) => Binary (Maybe a) where
+    put Nothing  = putWord8 0
+    put (Just x) = putWord8 1 >> put x
+    get = do
+        w <- getWord8
+        case w of
+            0 -> return Nothing
+            _ -> liftM Just get
+
+instance (Binary a, Binary b) => Binary (Either a b) where
+    put (Left  a) = putWord8 0 >> put a
+    put (Right b) = putWord8 1 >> put b
+    get = do
+        w <- getWord8
+        case w of
+            0 -> liftM Left  get
+            _ -> liftM Right get
+
+------------------------------------------------------------------------
+-- ByteStrings (have specially efficient instances)
+
+instance Binary B.ByteString where
+    put bs = do put (B.length bs)
+                putByteString bs
+    get    = get >>= getByteString
+
+--
+-- Using old versions of fps, this is a type synonym, and non portable
+-- 
+-- Requires 'flexible instances'
+--
+instance Binary ByteString where
+    put bs = do put (fromIntegral (L.length bs) :: Int)
+                putLazyByteString bs
+    get    = get >>= getLazyByteString
+
+------------------------------------------------------------------------
+-- Maps and Sets
+
+instance (Ord a, Binary a) => Binary (Set.Set a) where
+    put s = put (Set.size s) >> mapM_ put (Set.toAscList s)
+    get   = liftM Set.fromDistinctAscList get
+
+instance (Ord k, Binary k, Binary e) => Binary (Map.Map k e) where
+    put m = put (Map.size m) >> mapM_ put (Map.toAscList m)
+    get   = liftM Map.fromDistinctAscList get
+
+instance Binary IntSet.IntSet where
+    put s = put (IntSet.size s) >> mapM_ put (IntSet.toAscList s)
+    get   = liftM IntSet.fromDistinctAscList get
+
+instance (Binary e) => Binary (IntMap.IntMap e) where
+    put m = put (IntMap.size m) >> mapM_ put (IntMap.toAscList m)
+    get   = liftM IntMap.fromDistinctAscList get
+
+------------------------------------------------------------------------
+-- Queues and Sequences
+
+#if __GLASGOW_HASKELL__ >= 606
+--
+-- This is valid Hugs, but you need the most recent Hugs
+--
+
+instance (Binary e) => Binary (Seq.Seq e) where
+    put s = put (Seq.length s) >> Fold.mapM_ put s
+    get = do n <- get :: Get Int
+             rep Seq.empty n get
+      where rep xs 0 _ = return $! xs
+            rep xs n g = xs `seq` n `seq` do
+                           x <- g
+                           rep (xs Seq.|> x) (n-1) g
+
+#endif
+
+------------------------------------------------------------------------
+-- Floating point
+
+-- instance Binary Double where
+--     put d = put (decodeFloat d)
+--     get   = liftM2 encodeFloat get get
+
+instance Binary Double where
+    put = putFloat64be
+    get = getFloat64be
+
+instance Binary Float where
+    put f = put (decodeFloat f)
+    get   = liftM2 encodeFloat get get
+
+------------------------------------------------------------------------
+-- Trees
+
+instance (Binary e) => Binary (T.Tree e) where
+    put (T.Node r s) = put r >> put s
+    get = liftM2 T.Node get get
+
+------------------------------------------------------------------------
+-- Arrays
+
+instance (Binary i, Ix i, Binary e) => Binary (Array i e) where
+    put a = do
+        put (bounds a)
+        put (rangeSize $ bounds a) -- write the length
+        mapM_ put (elems a)        -- now the elems.
+    get = do
+        bs <- get
+        n  <- get                  -- read the length
+        xs <- replicateM n get     -- now the elems.
+        return (listArray bs xs)
+
+--
+-- The IArray UArray e constraint is non portable. Requires flexible instances
+--
+instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where
+    put a = do
+        put (bounds a)
+        put (rangeSize $ bounds a) -- now write the length
+        mapM_ put (elems a)
+    get = do
+        bs <- get
+        n  <- get
+        xs <- replicateM n get
+        return (listArray bs xs)

src/compiler/api/Data/Binary/Builder.hs

@@ -0,0 +1,450 @@
+{-# LANGUAGE CPP, MagicHash #-}
+-- for unboxed shifts
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      : Data.Binary.Builder
+-- Copyright   : Lennart Kolmodin, Ross Paterson
+-- License     : BSD3-style (see LICENSE)
+-- 
+-- Maintainer  : Lennart Kolmodin <kolmodin@dtek.chalmers.se>
+-- Stability   : experimental
+-- Portability : portable to Hugs and GHC
+--
+-- Efficient construction of lazy bytestrings.
+--
+-----------------------------------------------------------------------------
+
+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
+#include "MachDeps.h"
+#endif
+
+module Data.Binary.Builder (
+
+    -- * The Builder type
+      Builder
+    , toLazyByteString
+
+    -- * Constructing Builders
+    , empty
+    , singleton
+    , append
+    , fromByteString        -- :: S.ByteString -> Builder
+    , fromLazyByteString    -- :: L.ByteString -> Builder
+
+    -- * Flushing the buffer state
+    , flush
+
+    -- * Derived Builders
+    -- ** Big-endian writes
+    , putWord16be           -- :: Word16 -> Builder
+    , putWord32be           -- :: Word32 -> Builder
+    , putWord64be           -- :: Word64 -> Builder
+
+    -- ** Little-endian writes
+    , putWord16le           -- :: Word16 -> Builder
+    , putWord32le           -- :: Word32 -> Builder
+    , putWord64le           -- :: Word64 -> Builder
+
+    -- ** Host-endian, unaligned writes
+    , putWordhost           -- :: Word -> Builder
+    , putWord16host         -- :: Word16 -> Builder
+    , putWord32host         -- :: Word32 -> Builder
+    , putWord64host         -- :: Word64 -> Builder
+
+  ) where
+
+#if MIN_VERSION_base(4,8,0)
+import Prelude hiding (empty)
+#endif
+import Foreign(Word,Word8,Ptr,Storable,ForeignPtr,withForeignPtr,poke,plusPtr,sizeOf)
+import System.IO.Unsafe(unsafePerformIO)
+import Data.Monoid
+--import Data.Word
+import qualified Data.ByteString      as S
+import qualified Data.ByteString.Lazy as L
+
+#ifdef BYTESTRING_IN_BASE
+import Data.ByteString.Base (inlinePerformIO)
+import qualified Data.ByteString.Base as S
+#else
+import Data.ByteString.Internal (accursedUnutterablePerformIO)
+import qualified Data.ByteString.Internal as S
+--import qualified Data.ByteString.Lazy.Internal as L
+#endif
+
+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
+import GHC.Base(Int(..),uncheckedShiftRL#,)
+import GHC.Word (Word32(..),Word16(..),Word64(..))
+
+#if MIN_VERSION_base(4,16,0)
+import GHC.Exts (wordToWord16#, word16ToWord#, wordToWord32#, word32ToWord#)
+#endif
+#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608 
+import GHC.Word (uncheckedShiftRL64#)
+#endif
+#if __GLASGOW_HASKELL__ >= 900 
+import GHC.Word (uncheckedShiftRL64#)
+#endif
+#endif
+
+------------------------------------------------------------------------
+
+-- | A 'Builder' is an efficient way to build lazy 'L.ByteString's.
+-- There are several functions for constructing 'Builder's, but only one
+-- to inspect them: to extract any data, you have to turn them into lazy
+-- 'L.ByteString's using 'toLazyByteString'.
+--
+-- Internally, a 'Builder' constructs a lazy 'L.Bytestring' by filling byte
+-- arrays piece by piece.  As each buffer is filled, it is \'popped\'
+-- off, to become a new chunk of the resulting lazy 'L.ByteString'.
+-- All this is hidden from the user of the 'Builder'.
+
+newtype Builder = Builder {
+        -- Invariant (from Data.ByteString.Lazy):
+        --      The lists include no null ByteStrings.
+        runBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString]
+    }
+
+#if MIN_VERSION_base(4,11,0)
+instance Semigroup Builder where
+  (<>) = append
+#endif
+
+instance Monoid Builder where
+    mempty  = empty
+    {-# INLINE mempty #-}
+    mappend = append
+    {-# INLINE mappend #-}
+
+------------------------------------------------------------------------
+
+-- | /O(1)./ The empty Builder, satisfying
+--
+--  * @'toLazyByteString' 'empty' = 'L.empty'@
+--
+empty :: Builder
+empty = Builder id
+{-# INLINE empty #-}
+
+-- | /O(1)./ A Builder taking a single byte, satisfying
+--
+--  * @'toLazyByteString' ('singleton' b) = 'L.singleton' b@
+--
+singleton :: Word8 -> Builder
+singleton = writeN 1 . flip poke
+{-# INLINE singleton #-}
+
+------------------------------------------------------------------------
+
+-- | /O(1)./ The concatenation of two Builders, an associative operation
+-- with identity 'empty', satisfying
+--
+--  * @'toLazyByteString' ('append' x y) = 'L.append' ('toLazyByteString' x) ('toLazyByteString' y)@
+--
+append :: Builder -> Builder -> Builder
+append (Builder f) (Builder g) = Builder (f . g)
+{-# INLINE append #-}
+
+-- | /O(1)./ A Builder taking a 'S.ByteString', satisfying
+--
+--  * @'toLazyByteString' ('fromByteString' bs) = 'L.fromChunks' [bs]@
+--
+fromByteString :: S.ByteString -> Builder
+fromByteString bs
+  | S.null bs = empty
+  | otherwise = flush `append` mapBuilder (bs :)
+{-# INLINE fromByteString #-}
+
+-- | /O(1)./ A Builder taking a lazy 'L.ByteString', satisfying
+--
+--  * @'toLazyByteString' ('fromLazyByteString' bs) = bs@
+--
+fromLazyByteString :: L.ByteString -> Builder
+fromLazyByteString bss = flush `append` mapBuilder (L.toChunks bss ++)
+{-# INLINE fromLazyByteString #-}
+
+------------------------------------------------------------------------
+
+-- Our internal buffer type
+data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8)
+                     {-# UNPACK #-} !Int                -- offset
+                     {-# UNPACK #-} !Int                -- used bytes
+                     {-# UNPACK #-} !Int                -- length left
+
+------------------------------------------------------------------------
+
+-- | /O(n)./ Extract a lazy 'L.ByteString' from a 'Builder'.
+-- The construction work takes place if and when the relevant part of
+-- the lazy 'L.ByteString' is demanded.
+--
+toLazyByteString :: Builder -> L.ByteString
+toLazyByteString m = L.fromChunks $ unsafePerformIO $ do
+    buf <- newBuffer defaultSize
+    return (runBuilder (m `append` flush) (const []) buf)
+
+-- | /O(1)./ Pop the 'S.ByteString' we have constructed so far, if any,
+-- yielding a new chunk in the result lazy 'L.ByteString'.
+flush :: Builder
+flush = Builder $ \ k buf@(Buffer p o u l) ->
+    if u == 0
+      then k buf
+      else S.PS p o u : k (Buffer p (o+u) 0 l)
+
+------------------------------------------------------------------------
+
+--
+-- copied from Data.ByteString.Lazy
+--
+defaultSize :: Int
+defaultSize = 32 * k - overhead
+    where k = 1024
+          overhead = 2 * sizeOf (undefined :: Int)
+
+------------------------------------------------------------------------
+
+-- | Sequence an IO operation on the buffer
+unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder
+unsafeLiftIO f =  Builder $ \ k buf -> accursedUnutterablePerformIO $ do
+    buf' <- f buf
+    return (k buf')
+{-# INLINE unsafeLiftIO #-}
+
+-- | Get the size of the buffer
+withSize :: (Int -> Builder) -> Builder
+withSize f = Builder $ \ k buf@(Buffer _ _ _ l) ->
+    runBuilder (f l) k buf
+
+-- | Map the resulting list of bytestrings.
+mapBuilder :: ([S.ByteString] -> [S.ByteString]) -> Builder
+mapBuilder f = Builder (f .)
+
+------------------------------------------------------------------------
+
+-- | Ensure that there are at least @n@ many bytes available.
+ensureFree :: Int -> Builder
+ensureFree n = n `seq` withSize $ \ l ->
+    if n <= l then empty else
+        flush `append` unsafeLiftIO (const (newBuffer (max n defaultSize)))
+{-# INLINE ensureFree #-}
+
+-- | Ensure that @n@ many bytes are available, and then use @f@ to write some
+-- bytes into the memory.
+writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder
+writeN n f = ensureFree n `append` unsafeLiftIO (writeNBuffer n f)
+{-# INLINE writeN #-}
+
+writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer
+writeNBuffer n f (Buffer fp o u l) = do
+    withForeignPtr fp (\p -> f (p `plusPtr` (o+u)))
+    return (Buffer fp o (u+n) (l-n))
+{-# INLINE writeNBuffer #-}
+
+newBuffer :: Int -> IO Buffer
+newBuffer size = do
+    fp <- S.mallocByteString size
+    return $! Buffer fp 0 0 size
+{-# INLINE newBuffer #-}
+
+------------------------------------------------------------------------
+-- Aligned, host order writes of storable values
+
+-- | Ensure that @n@ many bytes are available, and then use @f@ to write some
+-- storable values into the memory.
+writeNbytes :: Storable a => Int -> (Ptr a -> IO ()) -> Builder
+writeNbytes n f = ensureFree n `append` unsafeLiftIO (writeNBufferBytes n f)
+{-# INLINE writeNbytes #-}
+
+writeNBufferBytes :: Storable a => Int -> (Ptr a -> IO ()) -> Buffer -> IO Buffer
+writeNBufferBytes n f (Buffer fp o u l) = do
+    withForeignPtr fp (\p -> f (p `plusPtr` (o+u)))
+    return (Buffer fp o (u+n) (l-n))
+{-# INLINE writeNBufferBytes #-}
+
+------------------------------------------------------------------------
+
+--
+-- We rely on the fromIntegral to do the right masking for us.
+-- The inlining here is critical, and can be worth 4x performance
+--
+
+-- | Write a Word16 in big endian format
+putWord16be :: Word16 -> Builder
+putWord16be w = writeN 2 $ \p -> do
+    poke p               (fromIntegral (shiftr_w16 w 8) :: Word8)
+    poke (p `plusPtr` 1) (fromIntegral (w)              :: Word8)
+{-# INLINE putWord16be #-}
+
+-- | Write a Word16 in little endian format
+putWord16le :: Word16 -> Builder
+putWord16le w = writeN 2 $ \p -> do
+    poke p               (fromIntegral (w)              :: Word8)
+    poke (p `plusPtr` 1) (fromIntegral (shiftr_w16 w 8) :: Word8)
+{-# INLINE putWord16le #-}
+
+-- putWord16le w16 = writeN 2 (\p -> poke (castPtr p) w16)
+
+-- | Write a Word32 in big endian format
+putWord32be :: Word32 -> Builder
+putWord32be w = writeN 4 $ \p -> do
+    poke p               (fromIntegral (shiftr_w32 w 24) :: Word8)
+    poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8)
+    poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w  8) :: Word8)
+    poke (p `plusPtr` 3) (fromIntegral (w)               :: Word8)
+{-# INLINE putWord32be #-}
+
+--
+-- a data type to tag Put/Check. writes construct these which are then
+-- inlined and flattened. matching Checks will be more robust with rules.
+--
+
+-- | Write a Word32 in little endian format
+putWord32le :: Word32 -> Builder
+putWord32le w = writeN 4 $ \p -> do
+    poke p               (fromIntegral (w)               :: Word8)
+    poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w  8) :: Word8)
+    poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 16) :: Word8)
+    poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 w 24) :: Word8)
+{-# INLINE putWord32le #-}
+
+-- on a little endian machine:
+-- putWord32le w32 = writeN 4 (\p -> poke (castPtr p) w32)
+
+-- | Write a Word64 in big endian format
+putWord64be :: Word64 -> Builder
+#if WORD_SIZE_IN_BITS < 64
+--
+-- To avoid expensive 64 bit shifts on 32 bit machines, we cast to
+-- Word32, and write that
+--
+putWord64be w =
+    let a = fromIntegral (shiftr_w64 w 32) :: Word32
+        b = fromIntegral w                 :: Word32
+    in writeN 8 $ \p -> do
+    poke p               (fromIntegral (shiftr_w32 a 24) :: Word8)
+    poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 16) :: Word8)
+    poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a  8) :: Word8)
+    poke (p `plusPtr` 3) (fromIntegral (a)               :: Word8)
+    poke (p `plusPtr` 4) (fromIntegral (shiftr_w32 b 24) :: Word8)
+    poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 16) :: Word8)
+    poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b  8) :: Word8)
+    poke (p `plusPtr` 7) (fromIntegral (b)               :: Word8)
+#else
+putWord64be w = writeN 8 $ \p -> do
+    poke p               (fromIntegral (shiftr_w64 w 56) :: Word8)
+    poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 48) :: Word8)
+    poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 40) :: Word8)
+    poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 32) :: Word8)
+    poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 24) :: Word8)
+    poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 16) :: Word8)
+    poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w  8) :: Word8)
+    poke (p `plusPtr` 7) (fromIntegral (w)               :: Word8)
+#endif
+{-# INLINE putWord64be #-}
+
+-- | Write a Word64 in little endian format
+putWord64le :: Word64 -> Builder
+
+#if WORD_SIZE_IN_BITS < 64
+putWord64le w =
+    let b = fromIntegral (shiftr_w64 w 32) :: Word32
+        a = fromIntegral w                 :: Word32
+    in writeN 8 $ \p -> do
+    poke (p)             (fromIntegral (a)               :: Word8)
+    poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a  8) :: Word8)
+    poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 16) :: Word8)
+    poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 a 24) :: Word8)
+    poke (p `plusPtr` 4) (fromIntegral (b)               :: Word8)
+    poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b  8) :: Word8)
+    poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 16) :: Word8)
+    poke (p `plusPtr` 7) (fromIntegral (shiftr_w32 b 24) :: Word8)
+#else
+putWord64le w = writeN 8 $ \p -> do
+    poke p               (fromIntegral (w)               :: Word8)
+    poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w  8) :: Word8)
+    poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 16) :: Word8)
+    poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 24) :: Word8)
+    poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 32) :: Word8)
+    poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 40) :: Word8)
+    poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 48) :: Word8)
+    poke (p `plusPtr` 7) (fromIntegral (shiftr_w64 w 56) :: Word8)
+#endif
+{-# INLINE putWord64le #-}
+
+-- on a little endian machine:
+-- putWord64le w64 = writeN 8 (\p -> poke (castPtr p) w64)
+
+------------------------------------------------------------------------
+-- Unaligned, word size ops
+
+-- | /O(1)./ A Builder taking a single native machine word. The word is
+-- written in host order, host endian form, for the machine you're on.
+-- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine,
+-- 4 bytes. Values written this way are not portable to
+-- different endian or word sized machines, without conversion.
+--
+putWordhost :: Word -> Builder
+putWordhost w = writeNbytes (sizeOf (undefined :: Word)) (\p -> poke p w)
+{-# INLINE putWordhost #-}
+
+-- | Write a Word16 in native host order and host endianness.
+-- 2 bytes will be written, unaligned.
+putWord16host :: Word16 -> Builder
+putWord16host w16 = writeNbytes (sizeOf (undefined :: Word16)) (\p -> poke p w16)
+{-# INLINE putWord16host #-}
+
+-- | Write a Word32 in native host order and host endianness.
+-- 4 bytes will be written, unaligned.
+putWord32host :: Word32 -> Builder
+putWord32host w32 = writeNbytes (sizeOf (undefined :: Word32)) (\p -> poke p w32)
+{-# INLINE putWord32host #-}
+
+-- | Write a Word64 in native host order.
+-- On a 32 bit machine we write two host order Word32s, in big endian form.
+-- 8 bytes will be written, unaligned.
+putWord64host :: Word64 -> Builder
+putWord64host w = writeNbytes (sizeOf (undefined :: Word64)) (\p -> poke p w)
+{-# INLINE putWord64host #-}
+
+------------------------------------------------------------------------
+-- Unchecked shifts
+
+{-# INLINE shiftr_w16 #-}
+shiftr_w16 :: Word16 -> Int -> Word16
+{-# INLINE shiftr_w32 #-}
+shiftr_w32 :: Word32 -> Int -> Word32
+{-# INLINE shiftr_w64 #-}
+shiftr_w64 :: Word64 -> Int -> Word64
+
+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
+#if MIN_VERSION_base(4,16,0)
+shiftr_w16 (W16# w) (I# i) = W16# (wordToWord16# ((word16ToWord# w) `uncheckedShiftRL#`   i))
+shiftr_w32 (W32# w) (I# i) = W32# (wordToWord32# ((word32ToWord# w) `uncheckedShiftRL#`   i))
+#else
+shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#`   i)
+shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#`   i)
+#endif
+
+
+#if WORD_SIZE_IN_BITS < 64
+shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)
+
+#if __GLASGOW_HASKELL__ <= 606
+-- Exported by GHC.Word in GHC 6.8 and higher
+foreign import ccall unsafe "stg_uncheckedShiftRL64"
+    uncheckedShiftRL64#     :: Word64# -> Int# -> Word64#
+#endif
+
+#else
+#if __GLASGOW_HASKELL__ <= 810
+shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)
+#else
+shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)
+#endif
+#endif
+
+#else
+shiftr_w16 = shiftR
+shiftr_w32 = shiftR
+shiftr_w64 = shiftR
+#endif

src/compiler/api/Data/Binary/Get.hs

@@ -0,0 +1,571 @@
+{-# LANGUAGE CPP, MagicHash #-}
+-- This module makes profiling a lot slower, so don't add automatic cost centres 
+{-# OPTIONS_GHC -fno-prof-auto #-}
+-- for unboxed shifts
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      : Data.Binary.Get
+-- Copyright   : Lennart Kolmodin
+-- License     : BSD3-style (see LICENSE)
+-- 
+-- Maintainer  : Lennart Kolmodin <kolmodin@dtek.chalmers.se>
+-- Stability   : experimental
+-- Portability : portable to Hugs and GHC.
+--
+-- The Get monad. A monad for efficiently building structures from
+-- encoded lazy ByteStrings
+--
+-----------------------------------------------------------------------------
+
+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
+#include "MachDeps.h"
+#endif
+
+module Data.Binary.Get (
+
+    -- * The Get type
+      Get
+    , runGet
+    , runGetState
+
+    -- * Parsing
+    , skip
+    , uncheckedSkip
+    , lookAhead
+    , lookAheadM
+    , lookAheadE
+    , uncheckedLookAhead
+
+    -- * Utility
+    , bytesRead
+    , getBytes
+    , remaining
+    , isEmpty
+
+    -- * Parsing particular types
+    , getWord8
+
+    -- ** ByteStrings
+    , getByteString
+    , getLazyByteString
+    , getLazyByteStringNul
+    , getRemainingLazyByteString
+
+    -- ** Big-endian reads
+    , getWord16be
+    , getWord32be
+    , getWord64be
+
+    -- ** Little-endian reads
+    , getWord16le
+    , getWord32le
+    , getWord64le
+
+    -- ** Host-endian, unaligned reads
+    , getWordhost
+    , getWord16host
+    , getWord32host
+    , getWord64host
+
+  ) where
+
+import Control.Monad (when,liftM, ap)
+import Control.Monad.Fix
+import Data.Maybe (isNothing)
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+
+#ifdef BYTESTRING_IN_BASE
+import qualified Data.ByteString.Base as B
+#else
+import qualified Data.ByteString.Internal as B
+import qualified Data.ByteString.Lazy.Internal as L
+#endif
+
+import Control.Applicative (Applicative(..))
+
+import Foreign
+
+-- used by splitAtST
+#if MIN_VERSION_base(4,6,0)
+import Control.Monad.ST.Unsafe(unsafeInterleaveST)
+#else
+import Control.Monad.ST(unsafeInterleaveST)
+#endif
+import Control.Monad.ST(runST)
+import Data.STRef
+
+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
+import GHC.Base
+import GHC.Word
+--import GHC.Int
+#if MIN_VERSION_base(4,16,0)
+import GHC.Exts (wordToWord16#, word16ToWord#, wordToWord32#, word32ToWord#)
+#endif
+#if __GLASGOW_HASKELL__ >= 900 
+import GHC.Word (uncheckedShiftL64#)
+#endif
+#endif
+
+-- Control.Monad.Fail import will become redundant in GHC 8.8+
+import qualified Control.Monad.Fail as Fail
+
+
+-- | The parse state
+data S = S {-# UNPACK #-} !B.ByteString  -- current chunk
+           L.ByteString                  -- the rest of the input
+           {-# UNPACK #-} !Int64         -- bytes read
+
+-- | The Get monad is just a State monad carrying around the input ByteString
+newtype Get a = Get { unGet :: S -> (a, S) }
+
+instance Functor Get where
+    fmap f m = Get (\s -> case unGet m s of
+                            (a, s') -> (f a, s'))
+    {-# INLINE fmap #-}
+
+instance Applicative Get where
+    pure  = return
+    (<*>) = ap
+
+instance Monad Get where
+    return a  = Get (\s -> (a, s))
+    {-# INLINE return #-}
+
+    m >>= k   = Get (\s -> case unGet m s of
+                             (a, s') -> unGet (k a) s')
+    {-# INLINE (>>=) #-}
+
+#if !(MIN_VERSION_base(4,13,0))
+    fail      = failDesc
+#endif
+
+instance Fail.MonadFail Get where
+    fail      = failDesc
+
+instance MonadFix Get where
+    mfix f = Get (\s -> let (a,s') = unGet (f a) s 
+                        in (a,s'))
+
+------------------------------------------------------------------------
+
+get :: Get S
+get   = Get (\s -> (s, s))
+
+put :: S -> Get ()
+put s = Get (\_ -> ((), s))
+
+------------------------------------------------------------------------
+--
+-- dons, GHC 6.10: explicit inlining disabled, was killing performance.
+-- Without it, GHC seems to do just fine. And we get similar
+-- performance with 6.8.2 anyway.
+--
+
+initState :: L.ByteString -> S
+initState xs = mkState xs 0
+{- INLINE initState -}
+
+{-
+initState (B.LPS xs) =
+    case xs of
+      []      -> S B.empty L.empty 0
+      (x:xs') -> S x (B.LPS xs') 0
+-}
+
+#ifndef BYTESTRING_IN_BASE
+mkState :: L.ByteString -> Int64 -> S
+mkState l = case l of
+    L.Empty      -> S B.empty L.empty
+    L.Chunk x xs -> S x xs
+{- INLINE mkState -}
+
+#else
+mkState :: L.ByteString -> Int64 -> S
+mkState (B.LPS xs) =
+    case xs of
+        [] -> S B.empty L.empty
+        (x:xs') -> S x (B.LPS xs')
+#endif
+
+-- | Run the Get monad applies a 'get'-based parser on the input ByteString
+runGet :: Get a -> L.ByteString -> a
+runGet m str = case unGet m (initState str) of (a, _) -> a
+
+-- | Run the Get monad applies a 'get'-based parser on the input
+-- ByteString. Additional to the result of get it returns the number of
+-- consumed bytes and the rest of the input.
+runGetState :: Get a -> L.ByteString -> Int64 -> (a, L.ByteString, Int64)
+runGetState m str off =
+    case unGet m (mkState str off) of
+      (a, ~(S s ss newOff)) -> (a, s `joinBS` ss, newOff)
+
+------------------------------------------------------------------------
+
+failDesc :: String -> Get a
+failDesc err = do
+    S _ _ bytes <- get
+    Get (error (err ++ ". Failed reading at byte position " ++ show bytes))
+
+-- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available.
+skip :: Int -> Get ()
+skip n = readN (fromIntegral n) (const ())
+
+-- | Skip ahead @n@ bytes. No error if there isn't enough bytes.
+uncheckedSkip :: Int64 -> Get ()
+uncheckedSkip n = do
+    S s ss bytes <- get
+    if fromIntegral (B.length s) >= n
+      then put (S (B.drop (fromIntegral n) s) ss (bytes + n))
+      else do
+        let rest = L.drop (n - fromIntegral (B.length s)) ss
+        put $! mkState rest (bytes + n)
+
+-- | Run @ga@, but return without consuming its input.
+-- Fails if @ga@ fails.
+lookAhead :: Get a -> Get a
+lookAhead ga = do
+    s <- get
+    a <- ga
+    put s
+    return a
+
+-- | Like 'lookAhead', but consume the input if @gma@ returns 'Just _'.
+-- Fails if @gma@ fails.
+lookAheadM :: Get (Maybe a) -> Get (Maybe a)
+lookAheadM gma = do
+    s <- get
+    ma <- gma
+    when (isNothing ma) $
+        put s
+    return ma
+
+-- | Like 'lookAhead', but consume the input if @gea@ returns 'Right _'.
+-- Fails if @gea@ fails.
+lookAheadE :: Get (Either a b) -> Get (Either a b)
+lookAheadE gea = do
+    s <- get
+    ea <- gea
+    case ea of
+        Left _ -> put s
+        _      -> return ()
+    return ea
+
+-- | Get the next up to @n@ bytes as a lazy ByteString, without consuming them. 
+uncheckedLookAhead :: Int64 -> Get L.ByteString
+uncheckedLookAhead n = do
+    S s ss _ <- get
+    if n <= fromIntegral (B.length s)
+        then return (L.fromChunks [B.take (fromIntegral n) s])
+        else return $ L.take n (s `joinBS` ss)
+
+------------------------------------------------------------------------
+-- Utility
+
+-- | Get the total number of bytes read to this point.
+bytesRead :: Get Int64
+bytesRead = do
+    S _ _ b <- get
+    return b
+
+-- | Get the number of remaining unparsed bytes.
+-- Useful for checking whether all input has been consumed.
+-- Note that this forces the rest of the input.
+remaining :: Get Int64
+remaining = do
+    S s ss _ <- get
+    return (fromIntegral (B.length s) + L.length ss)
+
+-- | Test whether all input has been consumed,
+-- i.e. there are no remaining unparsed bytes.
+isEmpty :: Get Bool
+isEmpty = do
+    S s ss _ <- get
+    return (B.null s && L.null ss)
+
+------------------------------------------------------------------------
+-- Utility with ByteStrings
+
+-- | An efficient 'get' method for strict ByteStrings. Fails if fewer
+-- than @n@ bytes are left in the input.
+getByteString :: Int -> Get B.ByteString
+getByteString n = readN n id
+{-# INLINE getByteString #-}
+
+-- | An efficient 'get' method for lazy ByteStrings. Does not fail if fewer than
+-- @n@ bytes are left in the input.
+getLazyByteString :: Int64 -> Get L.ByteString
+getLazyByteString n = do
+    S s ss bytes <- get
+    let big = s `joinBS` ss
+    case splitAtST n big of
+      (consume, rest) -> do put $ mkState rest (bytes + n)
+                            return consume
+{-# INLINE getLazyByteString #-}
+
+-- | Get a lazy ByteString that is terminated with a NUL byte. Fails
+-- if it reaches the end of input without hitting a NUL.
+getLazyByteStringNul :: Get L.ByteString
+getLazyByteStringNul = do
+    S s ss bytes <- get
+    let big = s `joinBS` ss
+        (consume, t) = L.break (== 0) big
+        (h, rest) = L.splitAt 1 t
+    if L.null h
+      then fail "too few bytes"
+      else do
+        put $ mkState rest (bytes + L.length consume + 1)
+        return consume
+{-# INLINE getLazyByteStringNul #-}
+
+-- | Get the remaining bytes as a lazy ByteString
+getRemainingLazyByteString :: Get L.ByteString
+getRemainingLazyByteString = do
+    S s ss _ <- get
+    return (s `joinBS` ss)
+
+------------------------------------------------------------------------
+-- Helpers
+
+-- | Pull @n@ bytes from the input, as a strict ByteString.
+getBytes :: Int -> Get B.ByteString
+getBytes n = do
+    S s ss bytes <- get
+    if n <= B.length s
+        then do let (consume,rest) = B.splitAt n s
+                put $! S rest ss (bytes + fromIntegral n)
+                return $! consume
+        else
+              case L.splitAt (fromIntegral n) (s `joinBS` ss) of
+                (consuming, rest) ->
+                    do let now = B.concat . L.toChunks $ consuming
+                       put $! mkState rest (bytes + fromIntegral n)
+                       -- forces the next chunk before this one is returned
+                       if (B.length now < n)
+                         then
+                            fail "too few bytes"
+                         else
+                            return now
+{- INLINE getBytes -}
+-- ^ important
+
+#ifndef BYTESTRING_IN_BASE
+joinBS :: B.ByteString -> L.ByteString -> L.ByteString
+joinBS bb lb
+    | B.null bb = lb
+    | otherwise = L.Chunk bb lb
+
+#else
+joinBS :: B.ByteString -> L.ByteString -> L.ByteString
+joinBS bb (B.LPS lb)
+    | B.null bb = B.LPS lb
+    | otherwise = B.LPS (bb:lb)
+#endif
+    -- don't use L.append, it's strict in it's second argument :/
+{- INLINE joinBS -}
+
+-- | Split a ByteString. If the first result is consumed before the --
+-- second, this runs in constant heap space.
+--
+-- You must force the returned tuple for that to work, e.g.
+-- 
+-- > case splitAtST n xs of
+-- >    (ys,zs) -> consume ys ... consume zs
+--
+splitAtST :: Int64 -> L.ByteString -> (L.ByteString, L.ByteString)
+splitAtST i ps | i <= 0 = (L.empty, ps)
+#ifndef BYTESTRING_IN_BASE
+splitAtST i ps          = runST (
+     do r  <- newSTRef undefined
+        xs <- first r i ps
+        ys <- unsafeInterleaveST (readSTRef r)
+        return (xs, ys))
+
+  where
+        first r 0 xs@(L.Chunk _ _) = writeSTRef r xs    >> return L.Empty
+        first r _ L.Empty          = writeSTRef r L.Empty >> return L.Empty
+
+        first r n (L.Chunk x xs)
+          | n < l     = do writeSTRef r (L.Chunk (B.drop (fromIntegral n) x) xs)
+                           return $ L.Chunk (B.take (fromIntegral n) x) L.Empty
+          | otherwise = do writeSTRef r (L.drop (n - l) xs)
+                           liftM (L.Chunk x) $ unsafeInterleaveST (first r (n - l) xs)
+
+         where l = fromIntegral (B.length x)
+#else
+splitAtST i (B.LPS ps)  = runST (
+     do r  <- newSTRef undefined
+        xs <- first r i ps
+        ys <- unsafeInterleaveST (readSTRef r)
+        return (B.LPS xs, B.LPS ys))
+
+  where first r 0 xs     = writeSTRef r xs >> return []
+        first r _ []     = writeSTRef r [] >> return []
+        first r n (x:xs)
+          | n < l     = do writeSTRef r (B.drop (fromIntegral n) x : xs)
+                           return [B.take (fromIntegral n) x]
+          | otherwise = do writeSTRef r (L.toChunks (L.drop (n - l) (B.LPS xs)))
+                           fmap (x:) $ unsafeInterleaveST (first r (n - l) xs)
+
+         where l = fromIntegral (B.length x)
+#endif
+{- INLINE splitAtST -}
+
+-- Pull n bytes from the input, and apply a parser to those bytes,
+-- yielding a value. If less than @n@ bytes are available, fail with an
+-- error. This wraps @getBytes@.
+readN :: Int -> (B.ByteString -> a) -> Get a
+readN n f = fmap f $ getBytes n
+{- INLINE readN -}
+-- ^ important
+
+------------------------------------------------------------------------
+-- Primtives
+
+-- helper, get a raw Ptr onto a strict ByteString copied out of the
+-- underlying lazy byteString. So many indirections from the raw parser
+-- state that my head hurts...
+
+getPtr :: Storable a => Int -> Get a
+getPtr n = do
+    (fp,o,_) <- readN n B.toForeignPtr
+    return . B.accursedUnutterablePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)
+{- INLINE getPtr -}
+
+------------------------------------------------------------------------
+
+-- | Read a Word8 from the monad state
+getWord8 :: Get Word8
+getWord8 = getPtr (sizeOf (undefined :: Word8))
+{- INLINE getWord8 -}
+
+-- | Read a Word16 in big endian format
+getWord16be :: Get Word16
+getWord16be = do
+    s <- readN 2 id
+    return $! (fromIntegral (s `B.index` 0) `shiftl_w16` 8) .|.
+              (fromIntegral (s `B.index` 1))
+{- INLINE getWord16be -}
+
+-- | Read a Word16 in little endian format
+getWord16le :: Get Word16
+getWord16le = do
+    s <- readN 2 id
+    return $! (fromIntegral (s `B.index` 1) `shiftl_w16` 8) .|.
+              (fromIntegral (s `B.index` 0) )
+{- INLINE getWord16le -}
+
+-- | Read a Word32 in big endian format
+getWord32be :: Get Word32
+getWord32be = do
+    s <- readN 4 id
+    return $! (fromIntegral (s `B.index` 0) `shiftl_w32` 24) .|.
+              (fromIntegral (s `B.index` 1) `shiftl_w32` 16) .|.
+              (fromIntegral (s `B.index` 2) `shiftl_w32`  8) .|.
+              (fromIntegral (s `B.index` 3) )
+{- INLINE getWord32be -}
+
+-- | Read a Word32 in little endian format
+getWord32le :: Get Word32
+getWord32le = do
+    s <- readN 4 id
+    return $! (fromIntegral (s `B.index` 3) `shiftl_w32` 24) .|.
+              (fromIntegral (s `B.index` 2) `shiftl_w32` 16) .|.
+              (fromIntegral (s `B.index` 1) `shiftl_w32`  8) .|.
+              (fromIntegral (s `B.index` 0) )
+{- INLINE getWord32le -}
+
+-- | Read a Word64 in big endian format
+getWord64be :: Get Word64
+getWord64be = do
+    s <- readN 8 id
+    return $! (fromIntegral (s `B.index` 0) `shiftl_w64` 56) .|.
+              (fromIntegral (s `B.index` 1) `shiftl_w64` 48) .|.
+              (fromIntegral (s `B.index` 2) `shiftl_w64` 40) .|.
+              (fromIntegral (s `B.index` 3) `shiftl_w64` 32) .|.
+              (fromIntegral (s `B.index` 4) `shiftl_w64` 24) .|.
+              (fromIntegral (s `B.index` 5) `shiftl_w64` 16) .|.
+              (fromIntegral (s `B.index` 6) `shiftl_w64`  8) .|.
+              (fromIntegral (s `B.index` 7) )
+{- INLINE getWord64be -}
+
+-- | Read a Word64 in little endian format
+getWord64le :: Get Word64
+getWord64le = do
+    s <- readN 8 id
+    return $! (fromIntegral (s `B.index` 7) `shiftl_w64` 56) .|.
+              (fromIntegral (s `B.index` 6) `shiftl_w64` 48) .|.
+              (fromIntegral (s `B.index` 5) `shiftl_w64` 40) .|.
+              (fromIntegral (s `B.index` 4) `shiftl_w64` 32) .|.
+              (fromIntegral (s `B.index` 3) `shiftl_w64` 24) .|.
+              (fromIntegral (s `B.index` 2) `shiftl_w64` 16) .|.
+              (fromIntegral (s `B.index` 1) `shiftl_w64`  8) .|.
+              (fromIntegral (s `B.index` 0) )
+{- INLINE getWord64le -}
+
+------------------------------------------------------------------------
+-- Host-endian reads
+
+-- | /O(1)./ Read a single native machine word. The word is read in
+-- host order, host endian form, for the machine you're on. On a 64 bit
+-- machine the Word is an 8 byte value, on a 32 bit machine, 4 bytes.
+getWordhost :: Get Word
+getWordhost = getPtr (sizeOf (undefined :: Word))
+{- INLINE getWordhost -}
+
+-- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness.
+getWord16host :: Get Word16
+getWord16host = getPtr (sizeOf (undefined :: Word16))
+{- INLINE getWord16host -}
+
+-- | /O(1)./ Read a Word32 in native host order and host endianness.
+getWord32host :: Get Word32
+getWord32host = getPtr  (sizeOf (undefined :: Word32))
+{- INLINE getWord32host -}
+
+-- | /O(1)./ Read a Word64 in native host order and host endianess.
+getWord64host   :: Get Word64
+getWord64host = getPtr  (sizeOf (undefined :: Word64))
+{- INLINE getWord64host -}
+
+------------------------------------------------------------------------
+-- Unchecked shifts
+
+shiftl_w16 :: Word16 -> Int -> Word16
+shiftl_w32 :: Word32 -> Int -> Word32
+shiftl_w64 :: Word64 -> Int -> Word64
+
+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
+#if MIN_VERSION_base(4,16,0)
+shiftl_w16 (W16# w) (I# i) = W16# (wordToWord16# ((word16ToWord# w) `uncheckedShiftL#`   i))
+shiftl_w32 (W32# w) (I# i) = W32# (wordToWord32# ((word32ToWord# w) `uncheckedShiftL#`   i))
+#else
+shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#`   i)
+shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#`   i)
+#endif
+
+#if WORD_SIZE_IN_BITS < 64
+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)
+
+#if __GLASGOW_HASKELL__ <= 606
+-- Exported by GHC.Word in GHC 6.8 and higher
+foreign import ccall unsafe "stg_uncheckedShiftL64"
+    uncheckedShiftL64#     :: Word64# -> Int# -> Word64#
+#endif
+
+#else
+#if __GLASGOW_HASKELL__ <= 810
+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)
+#else
+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)
+#endif
+
+#endif
+
+#else
+shiftl_w16 = shiftL
+shiftl_w32 = shiftL
+shiftl_w64 = shiftL
+#endif

src/compiler/api/Data/Binary/IEEE754.lhs

@@ -0,0 +1,402 @@
+% Copyright (C) 2009 John Millikin <jmillikin@gmail.com>
+% 
+% This program is free software: you can redistribute it and/or modify
+% it under the terms of the GNU General Public License as published by
+% the Free Software Foundation, either version 3 of the License, or
+% any later version.
+% 
+% This program is distributed in the hope that it will be useful,
+% but WITHOUT ANY WARRANTY; without even the implied warranty of
+% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+% GNU General Public License for more details.
+% 
+% You should have received a copy of the GNU General Public License
+% along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+\ignore{
+\begin{code}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Data.Binary.IEEE754 (
+    -- * Parsing
+      getFloat16be, getFloat16le
+    , getFloat32be, getFloat32le
+    , getFloat64be, getFloat64le
+
+    -- * Serializing
+    , putFloat32be, putFloat32le
+    , putFloat64be, putFloat64le
+) where
+
+import Data.Bits ((.&.), (.|.), shiftL, shiftR, Bits)
+import Data.Word (Word8)
+import Data.List (foldl')
+
+import qualified Data.ByteString as B
+import Data.Binary.Get (Get, getByteString)
+import Data.Binary.Put (Put, putByteString)
+\end{code}
+}
+
+\section{Parsing}
+
+\subsection{Public interface}
+
+\begin{code}
+getFloat16be :: Get Float
+getFloat16be = getFloat (ByteCount 2) splitBytes
+\end{code}
+
+\begin{code}
+getFloat16le :: Get Float
+getFloat16le = getFloat (ByteCount 2) $ splitBytes . reverse
+\end{code}
+
+\begin{code}
+getFloat32be :: Get Float
+getFloat32be = getFloat (ByteCount 4) splitBytes
+\end{code}
+
+\begin{code}
+getFloat32le :: Get Float
+getFloat32le = getFloat (ByteCount 4) $ splitBytes . reverse
+\end{code}
+
+\begin{code}
+getFloat64be :: Get Double
+getFloat64be = getFloat (ByteCount 8) splitBytes
+\end{code}
+
+\begin{code}
+getFloat64le :: Get Double
+getFloat64le = getFloat (ByteCount 8) $ splitBytes . reverse
+\end{code}
+
+\subsection{Implementation}
+
+Split the raw byte array into (sign, exponent, significand) components.
+The exponent and signifcand are drawn directly from the bits in the
+original float, and have not been unbiased or otherwise modified.
+
+\begin{code}
+splitBytes :: [Word8] -> RawFloat
+splitBytes bs = RawFloat width sign exp' sig expWidth sigWidth where
+    width = ByteCount (length bs)
+    nBits = bitsInWord8 bs
+    sign = if head bs .&. 0x80 == 0x80
+             then Negative
+             else Positive
+
+    expStart = 1
+    expWidth = exponentWidth nBits
+    expEnd = expStart + expWidth
+    exp' = Exponent . fromIntegral $ bitSlice bs expStart expEnd
+
+    sigWidth = nBits - expEnd
+    sig  = Significand $ bitSlice bs expEnd nBits
+\end{code}
+
+\subsubsection{Encodings and special values}
+
+The next step depends on the value of the exponent $e$, size of the
+exponent field in bits $w$, and value of the significand.
+
+\begin{table}[h]
+\begin{center}
+\begin{tabular}{lrl}
+\toprule
+Exponent                & Significand & Format \\
+\midrule
+$0$                     & $0$           & Zero \\
+$0$                     & $> 0$         & Denormalised \\
+$1 \leq e \leq 2^w - 2$ & \textit{any} & Normalised \\
+$2^w-1$                 & $0$           & Infinity \\
+$2^w-1$                 & $> 0$         & NaN \\
+\bottomrule
+\end{tabular}
+\end{center}
+\end{table}
+
+There's no built-in literals for Infinity or NaN, so they
+are constructed using the {\tt Read} instances for {\tt Double} and
+{\tt Float}.
+
+\begin{code}
+merge :: (Read a, RealFloat a) => RawFloat -> a
+merge f@(RawFloat _ _ e sig eWidth _)
+    | e == 0 = if sig == 0
+                 then 0.0
+                 else denormalised f
+    | e == eMax - 1 = if sig == 0
+                        then read "Infinity"
+                        else read "NaN"
+    | otherwise = normalised f
+    where eMax = 2 `pow` eWidth
+\end{code}
+
+If a value is normalised, its significand has an implied {\tt 1} bit
+in its most-significant bit. The significand must be adjusted by
+this value before being passed to {\tt encodeField}.
+
+\begin{code}
+normalised :: RealFloat a => RawFloat -> a
+normalised f = encodeFloat fraction exp' where
+    Significand sig = rawSignificand f
+    Exponent exp' = unbiased - sigWidth
+
+    fraction = sig + (1 `bitShiftL` rawSignificandWidth f)
+
+    sigWidth = fromIntegral $ rawSignificandWidth f
+    unbiased = unbias (rawExponent f) (rawExponentWidth f)
+\end{code}
+
+For denormalised values, the implied {\tt 1} bit is the least-significant
+bit of the exponent.
+
+\begin{code}
+denormalised :: RealFloat a => RawFloat -> a
+denormalised f = encodeFloat sig exp' where
+    Significand sig = rawSignificand f
+    Exponent exp' = unbiased - sigWidth + 1
+
+    sigWidth = fromIntegral $ rawSignificandWidth f
+    unbiased = unbias (rawExponent f) (rawExponentWidth f)
+\end{code}
+
+By composing {\tt splitBytes} and {\tt merge}, the absolute value of the
+float is calculated. Before being returned to the calling function, it
+must be signed appropriately.
+
+\begin{code}
+getFloat :: (Read a, RealFloat a) => ByteCount
+            -> ([Word8] -> RawFloat) -> Get a
+getFloat (ByteCount width) parser = do
+    raw <- fmap (parser . B.unpack) $ getByteString width
+    let absFloat = merge raw
+    return $ case rawSign raw of
+               Positive ->  absFloat
+               Negative -> -absFloat
+\end{code}
+
+\section{Serialising}
+
+\subsection{Public interface}
+
+\begin{code}
+putFloat32be :: Float -> Put
+putFloat32be = putFloat (ByteCount 4) id
+\end{code}
+
+\begin{code}
+putFloat32le :: Float -> Put
+putFloat32le = putFloat (ByteCount 4) reverse
+\end{code}
+
+\begin{code}
+putFloat64be :: Double -> Put
+putFloat64be = putFloat (ByteCount 8) id
+\end{code}
+
+\begin{code}
+putFloat64le :: Double -> Put
+putFloat64le = putFloat (ByteCount 8) reverse
+\end{code}
+
+\subsection{Implementation}
+
+Serialisation is similar to parsing. First, the float is converted to
+a structure representing raw bitfields. The values returned from
+{\tt decodeFloat} are clamped to their expected lengths before being
+stored in the {\tt RawFloat}.
+
+\begin{code}
+splitFloat :: RealFloat a => ByteCount -> a -> RawFloat
+splitFloat width x = raw where
+    raw = RawFloat width sign clampedExp clampedSig expWidth sigWidth
+    sign = if isNegativeNaN x || isNegativeZero x || x < 0
+             then Negative
+             else Positive
+    clampedExp = clamp expWidth exp'
+    clampedSig = clamp sigWidth sig
+    (exp', sig) = case (dFraction, dExponent, biasedExp) of
+                    (0, 0, _) -> (0, 0)
+                    (_, _, 0) -> (0, Significand $ truncatedSig + 1)
+                    _         -> (biasedExp, Significand truncatedSig)
+    expWidth = exponentWidth $ bitCount width
+    sigWidth = bitCount width - expWidth - 1 -- 1 for sign bit
+
+    (dFraction, dExponent) = decodeFloat x
+
+    rawExp = Exponent $ dExponent + fromIntegral sigWidth
+    biasedExp = bias rawExp expWidth
+    truncatedSig = abs dFraction - (1 `bitShiftL` sigWidth)
+\end{code}
+
+Then, the {\tt RawFloat} is converted to a list of bytes by mashing all
+the fields together into an {\tt Integer}, and chopping up that integer
+in 8-bit blocks.
+
+\begin{code}
+rawToBytes :: RawFloat -> [Word8]
+rawToBytes raw = integerToBytes mashed width where
+    RawFloat width sign exp' sig expWidth sigWidth = raw
+    sign' :: Word8
+    sign' = case sign of
+              Positive -> 0
+              Negative -> 1
+    mashed = mashBits sig sigWidth .
+             mashBits exp' expWidth .
+             mashBits sign' 1 $ 0
+\end{code}
+
+{\tt clamp}, given a maximum bit count and a value, will strip any 1-bits
+in positions above the count.
+
+\begin{code}
+clamp :: (Num a, Bits a) => BitCount -> a -> a
+clamp = (.&.) . mask where
+    mask 1 = 1
+    mask n | n > 1 = (mask (n - 1) `shiftL` 1) + 1
+    mask _ = undefined
+\end{code}
+
+For merging the fields, just shift the starting integer over a bit and
+then \textsc{or} it with the next value. The weird parameter order allows
+easy composition.
+
+\begin{code}
+mashBits :: (Bits a, Integral a) => a -> BitCount -> Integer -> Integer
+mashBits _ 0 x = x
+mashBits y n x = (x `bitShiftL` n) .|. fromIntegral y
+\end{code}
+
+Given an integer, read it in 255-block increments starting from the LSB.
+Each increment is converted to a byte and added to the final list.
+
+\begin{code}
+integerToBytes :: Integer -> ByteCount -> [Word8]
+integerToBytes _ 0 = []
+integerToBytes x n = bytes where
+    bytes = integerToBytes (x `shiftR` 8) (n - 1) ++ [step]
+    step = fromIntegral x .&. 0xFF
+\end{code}
+
+Finally, the raw parsing is wrapped up in {\tt Put}. The second parameter
+allows the same code paths to be used for little- and big-endian
+serialisation.
+
+\begin{code}
+putFloat :: (RealFloat a) => ByteCount -> ([Word8] -> [Word8]) -> a -> Put
+putFloat width f x = putByteString $ B.pack bytes where
+    bytes = f . rawToBytes . splitFloat width $ x
+\end{code}
+
+\section{Raw float components}
+
+Information about the raw bit patterns in the float is stored in
+{\tt RawFloat}, so they don't have to be passed around to the various
+format cases. The exponent should be biased, and the significand
+shouldn't have it's implied MSB (if applicable).
+
+\begin{code}
+data RawFloat = RawFloat
+    { rawWidth            :: ByteCount
+    , rawSign             :: Sign
+    , rawExponent         :: Exponent
+    , rawSignificand      :: Significand
+    , rawExponentWidth    :: BitCount
+    , rawSignificandWidth :: BitCount
+    }
+    deriving (Show)
+\end{code}
+
+\section{Exponents}
+
+Calculate the proper size of the exponent field, in bits, given the
+size of the full structure.
+
+\begin{code}
+exponentWidth :: BitCount -> BitCount
+exponentWidth k
+    | k == 16         = 5
+    | k == 32         = 8
+    | k `mod` 32 == 0 = ceiling (4 * logBase 2 (fromIntegral k)) - 13
+    | otherwise       = error "Invalid length of floating-point value"
+\end{code}
+
+\begin{code}
+bias :: Exponent -> BitCount -> Exponent
+bias e eWidth = e - (1 - (2 `pow` (eWidth - 1)))
+\end{code}
+
+\begin{code}
+unbias :: Exponent -> BitCount -> Exponent
+unbias e eWidth = e + 1 - (2 `pow` (eWidth - 1))
+\end{code}
+
+\section{Byte and bit counting}
+
+\begin{code}
+data Sign = Positive | Negative
+    deriving (Show)
+
+newtype Exponent = Exponent Int
+    deriving (Show, Eq, Num, Ord, Real, Enum, Integral, Bits)
+
+newtype Significand = Significand Integer
+    deriving (Show, Eq, Num, Ord, Real, Enum, Integral, Bits)
+
+newtype BitCount = BitCount Int
+    deriving (Show, Eq, Num, Ord, Real, Enum, Integral)
+
+newtype ByteCount = ByteCount Int
+    deriving (Show, Eq, Num, Ord, Real, Enum, Integral)
+
+bitCount :: ByteCount -> BitCount
+bitCount (ByteCount x) = BitCount (x * 8)
+
+bitsInWord8 :: [Word8] -> BitCount
+bitsInWord8 = bitCount . ByteCount . length
+
+bitShiftL :: (Bits a) => a -> BitCount -> a
+bitShiftL x (BitCount n) = shiftL x n
+
+bitShiftR :: (Bits a) => a -> BitCount -> a
+bitShiftR x (BitCount n) = shiftR x n
+\end{code}
+
+\section{Utility}
+
+Considering a byte list as a sequence of bits, slice it from start
+inclusive to end exclusive, and return the resulting bit sequence as an
+integer.
+
+\begin{code}
+bitSlice :: [Word8] -> BitCount -> BitCount -> Integer
+bitSlice bs = sliceInt (foldl' step 0 bs) bitCount' where
+    step acc w     = shiftL acc 8 + fromIntegral w
+    bitCount'      = bitsInWord8 bs
+\end{code}
+
+Slice a single integer by start and end bit location
+
+\begin{code}
+sliceInt :: Integer -> BitCount -> BitCount -> BitCount -> Integer
+sliceInt x xBitCount s e = fromIntegral sliced where
+    sliced = (x .&. startMask) `bitShiftR` (xBitCount - e)
+    startMask = n1Bits (xBitCount - s)
+    n1Bits n  = (2 `pow` n) - 1
+\end{code}
+
+Integral version of {\tt (**)}
+
+\begin{code}
+pow :: (Integral a, Integral b, Integral c) => a -> b -> c
+pow b e = floor $ fromIntegral b ** fromIntegral e
+\end{code}
+
+Detect whether a float is {\tt $-$NaN}
+
+\begin{code}
+isNegativeNaN :: RealFloat a => a -> Bool
+isNegativeNaN x = isNaN x && (floor x > 0)
+\end{code}

src/compiler/api/Data/Binary/Put.hs

@@ -0,0 +1,210 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      : Data.Binary.Put
+-- Copyright   : Lennart Kolmodin
+-- License     : BSD3-style (see LICENSE)
+-- 
+-- Maintainer  : Lennart Kolmodin <kolmodin@dtek.chalmers.se>
+-- Stability   : stable
+-- Portability : Portable to Hugs and GHC. Requires MPTCs
+--
+-- The Put monad. A monad for efficiently constructing lazy bytestrings.
+--
+-----------------------------------------------------------------------------
+
+module Data.Binary.Put (
+
+    -- * The Put type
+      Put
+    , PutM(..)
+    , runPut
+    , runPutM
+    , putBuilder
+    , execPut
+
+    -- * Flushing the implicit parse state
+    , flush
+
+    -- * Primitives
+    , putWord8
+    , putByteString
+    , putLazyByteString
+
+    -- * Big-endian primitives
+    , putWord16be
+    , putWord32be
+    , putWord64be
+
+    -- * Little-endian primitives
+    , putWord16le
+    , putWord32le
+    , putWord64le
+
+    -- * Host-endian, unaligned writes
+    , putWordhost           -- :: Word   -> Put
+    , putWord16host         -- :: Word16 -> Put
+    , putWord32host         -- :: Word32 -> Put
+    , putWord64host         -- :: Word64 -> Put
+
+  ) where
+
+import Data.Monoid
+import Data.Binary.Builder (Builder, toLazyByteString)
+import qualified Data.Binary.Builder as B
+
+import Data.Word
+import qualified Data.ByteString      as S
+import qualified Data.ByteString.Lazy as L
+import Control.Applicative
+
+
+------------------------------------------------------------------------
+
+-- XXX Strict in buffer only. 
+data PairS a = PairS a {-UNPACK-}!Builder
+
+sndS :: PairS a -> Builder
+sndS (PairS _ b) = b
+
+-- | The PutM type. A Writer monad over the efficient Builder monoid.
+newtype PutM a = Put { unPut :: PairS a }
+
+-- | Put merely lifts Builder into a Writer monad, applied to ().
+type Put = PutM ()
+
+instance Functor PutM where
+        fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w
+        {-# INLINE fmap #-}
+
+instance Applicative PutM where
+        pure    = return
+        m <*> k = Put $
+            let PairS f w  = unPut m
+                PairS x w' = unPut k
+            in PairS (f x) (w `mappend` w')
+
+-- Standard Writer monad, with aggressive inlining
+instance Monad PutM where
+    return a = Put $ PairS a mempty
+    {-# INLINE return #-}
+
+    m >>= k  = Put $
+        let PairS a w  = unPut m
+            PairS b w' = unPut (k a)
+        in PairS b (w `mappend` w')
+    {-# INLINE (>>=) #-}
+
+    m >> k  = Put $
+        let PairS _ w  = unPut m
+            PairS b w' = unPut k
+        in PairS b (w `mappend` w')
+    {-# INLINE (>>) #-}
+
+tell :: Builder -> Put
+tell b = Put $ PairS () b
+{-# INLINE tell #-}
+
+putBuilder :: Builder -> Put
+putBuilder = tell
+{-# INLINE putBuilder #-}
+
+-- | Run the 'Put' monad
+execPut :: PutM a -> Builder
+execPut = sndS . unPut
+{-# INLINE execPut #-}
+
+-- | Run the 'Put' monad with a serialiser
+runPut :: Put -> L.ByteString
+runPut = toLazyByteString . sndS . unPut
+{-# INLINE runPut #-}
+
+-- | Run the 'Put' monad with a serialiser and get its result
+runPutM :: PutM a -> (a, L.ByteString)
+runPutM (Put (PairS f s)) = (f, toLazyByteString s)
+{-# INLINE runPutM #-}
+
+------------------------------------------------------------------------
+
+-- | Pop the ByteString we have constructed so far, if any, yielding a
+-- new chunk in the result ByteString.
+flush               :: Put
+flush               = tell B.flush
+{-# INLINE flush #-}
+
+-- | Efficiently write a byte into the output buffer
+putWord8            :: Word8 -> Put
+putWord8            = tell . B.singleton
+{-# INLINE putWord8 #-}
+
+-- | An efficient primitive to write a strict ByteString into the output buffer.
+-- It flushes the current buffer, and writes the argument into a new chunk.
+putByteString       :: S.ByteString -> Put
+putByteString       = tell . B.fromByteString
+{-# INLINE putByteString #-}
+
+-- | Write a lazy ByteString efficiently, simply appending the lazy
+-- ByteString chunks to the output buffer
+putLazyByteString   :: L.ByteString -> Put
+putLazyByteString   = tell . B.fromLazyByteString
+{-# INLINE putLazyByteString #-}
+
+-- | Write a Word16 in big endian format
+putWord16be         :: Word16 -> Put
+putWord16be         = tell . B.putWord16be
+{-# INLINE putWord16be #-}
+
+-- | Write a Word16 in little endian format
+putWord16le         :: Word16 -> Put
+putWord16le         = tell . B.putWord16le
+{-# INLINE putWord16le #-}
+
+-- | Write a Word32 in big endian format
+putWord32be         :: Word32 -> Put
+putWord32be         = tell . B.putWord32be
+{-# INLINE putWord32be #-}
+
+-- | Write a Word32 in little endian format
+putWord32le         :: Word32 -> Put
+putWord32le         = tell . B.putWord32le
+{-# INLINE putWord32le #-}
+
+-- | Write a Word64 in big endian format
+putWord64be         :: Word64 -> Put
+putWord64be         = tell . B.putWord64be
+{-# INLINE putWord64be #-}
+
+-- | Write a Word64 in little endian format
+putWord64le         :: Word64 -> Put
+putWord64le         = tell . B.putWord64le
+{-# INLINE putWord64le #-}
+
+------------------------------------------------------------------------
+
+-- | /O(1)./ Write a single native machine word. The word is
+-- written in host order, host endian form, for the machine you're on.
+-- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine,
+-- 4 bytes. Values written this way are not portable to
+-- different endian or word sized machines, without conversion.
+--
+putWordhost         :: Word -> Put
+putWordhost         = tell . B.putWordhost
+{-# INLINE putWordhost #-}
+
+-- | /O(1)./ Write a Word16 in native host order and host endianness.
+-- For portability issues see @putWordhost@.
+putWord16host       :: Word16 -> Put
+putWord16host       = tell . B.putWord16host
+{-# INLINE putWord16host #-}
+
+-- | /O(1)./ Write a Word32 in native host order and host endianness.
+-- For portability issues see @putWordhost@.
+putWord32host       :: Word32 -> Put
+putWord32host       = tell . B.putWord32host
+{-# INLINE putWord32host #-}
+
+-- | /O(1)./ Write a Word64 in native host order
+-- On a 32 bit machine we write two host order Word32s, in big endian form.
+-- For portability issues see @putWordhost@.
+putWord64host       :: Word64 -> Put
+putWord64host       = tell . B.putWord64host
+{-# INLINE putWord64host #-}

src/compiler/api/GF/Command/Abstract.hs

@@ -0,0 +1,109 @@
+module GF.Command.Abstract(module GF.Command.Abstract,Expr,showExpr,Literal(..),Term) where
+
+import PGF2
+import GF.Grammar.Grammar(Term)
+
+type Ident = String
+
+type CommandLine = [Pipe]
+
+type Pipe = [Command]
+
+data Command
+   = Command Ident [Option] Argument
+   deriving Show
+
+data TransactionCommand
+   = CreateFun [Option] Fun Type
+   | CreateCat [Option] Cat [Hypo]
+   | CreateConcrete [Option] ConcName
+   | CreateLin [Option] Fun Term Bool
+   | CreateLincat [Option] Cat Term
+   | DropFun [Option] Fun
+   | DropCat [Option] Cat
+   | DropConcrete [Option] ConcName
+   | DropLin [Option] Fun
+   | DropLincat [Option] Cat
+   deriving Show
+
+data Option
+  = OOpt Ident
+  | OFlag Ident Literal
+  deriving (Eq,Ord,Show)
+
+data Argument
+  = AExpr Expr
+  | ATerm Term
+  | ANoArg
+  | AMacro Ident
+  deriving Show
+
+valIntOpts :: String -> Int -> [Option] -> Int
+valIntOpts flag def opts =
+  case [v | OFlag f (LInt v) <- opts, f == flag] of
+    (v:_) -> fromIntegral v
+    _     -> def
+
+valFltOpts :: String -> Double -> [Option] -> Double
+valFltOpts flag def opts =
+  case [v | OFlag f v <- opts, v <- toFlt v, f == flag] of
+    (v:_) -> v
+    _     -> def
+  where
+    toFlt (LInt v) = [fromIntegral v]
+    toFlt (LFlt f) = [f]
+    toFlt _        = []
+
+valStrOpts :: String -> String -> [Option] -> String
+valStrOpts flag def opts =
+  case listFlags flag opts of
+    v:_ -> valueString v
+    _   -> def
+
+maybeIntOpts :: String -> a -> (Int -> a) -> [Option] -> a
+maybeIntOpts flag def fn opts =
+  case [v | OFlag f (LInt v) <- opts, f == flag] of
+    (v:_) -> fn (fromIntegral v)
+    _     -> def
+
+maybeStrOpts :: String -> a -> (String -> a) -> [Option] -> a
+maybeStrOpts flag def fn opts =
+  case listFlags flag opts of
+    v:_ -> fn (valueString v)
+    _   -> def
+
+listFlags flag opts = [v | OFlag f v <- opts, f == flag]
+
+valueString v =
+  case v of
+    LInt v -> show v
+    LFlt v -> show v
+    LStr v -> v
+
+isOpt :: String -> [Option] -> Bool
+isOpt o opts = elem (OOpt o) opts
+
+isFlag :: String -> [Option] -> Bool
+isFlag o opts = elem o [x | OFlag x _ <- opts]
+
+optsAndFlags :: [Option] -> ([Option],[Option])
+optsAndFlags = foldr add ([],[]) where
+  add o (os,fs) = case o of
+    OOpt _    -> (o:os,fs)
+    OFlag _ _ -> (os,o:fs)
+
+prOpt :: Option -> String
+prOpt o = case o of
+  OOpt i    -> i
+  OFlag f x -> f ++ "=" ++ show x
+
+mkOpt :: String -> Option
+mkOpt = OOpt
+
+-- abbreviation convention from gf commands
+getCommandOp s = case break (=='_') s of
+     (a:_,_:b:_) -> [a,b]  -- axx_byy --> ab
+     _ -> case s of
+       [a,b] -> s          -- ab  --> ab
+       a:_ -> [a]          -- axx --> a
+

src/compiler/api/GF/Command/CommandInfo.hs

@@ -0,0 +1,81 @@
+module GF.Command.CommandInfo where
+import GF.Command.Abstract(Option,Expr,Term)
+import GF.Text.Pretty(render)
+import GF.Grammar.Grammar(Term(K))
+import GF.Grammar.Printer() -- instance Pretty Term
+import PGF2(mkStr,unStr,showExpr)
+
+data CommandInfo m = CommandInfo {
+  exec     :: [Option] -> CommandArguments -> m CommandOutput,
+  synopsis :: String,
+  syntax   :: String,
+  explanation :: String,
+  longname :: String,
+  options  :: [(String,String)],
+  flags    :: [(String,String)],
+  examples :: [(String,String)],
+  needsTypeCheck :: Bool
+  }
+
+mapCommandExec f c = c { exec = \ opts ts -> f (exec c opts ts) }
+
+--emptyCommandInfo :: CommandInfo env
+emptyCommandInfo = CommandInfo {
+  exec = error "command not implemented",
+  synopsis = "",
+  syntax = "",
+  explanation = "",
+  longname = "",
+  options = [],
+  flags = [],
+  examples = [],
+  needsTypeCheck = True
+  }
+--------------------------------------------------------------------------------
+
+class Monad m => TypeCheckArg m where typeCheckArg :: Expr -> m Expr
+
+--------------------------------------------------------------------------------
+
+data CommandArguments = Exprs [(Expr,Float)] | Strings [String] | Term Term
+
+newtype CommandOutput = Piped (CommandArguments,String) ---- errors, etc
+
+-- ** Converting command output
+fromStrings ss         = Piped (Strings ss, unlines ss)
+fromExprs show_p es    = Piped (Exprs es,unlines (map (\(e,p) -> (if show_p then (++) ("["++show p++"] ") else id) (showExpr [] e)) es))
+fromString  s          = Piped (Strings [s], s)
+pipeWithMessage es msg = Piped (Exprs es,msg)
+pipeMessage msg        = Piped (Exprs [],msg)
+pipeExprs   es         = Piped (Exprs es,[]) -- only used in emptyCommandInfo
+void                   = Piped (Exprs [],"")
+
+-- ** Converting command input
+
+toStrings args =
+    case args of
+      Strings ss -> ss
+      Exprs es -> zipWith showAsString (True:repeat False) es
+      Term t -> [render t]
+  where
+    showAsString first (e,p) =
+      case unStr e of
+        Just s  -> s
+        Nothing -> ['\n'|not first] ++
+                   showExpr [] e ---newline needed in other cases than the first
+
+toExprs args =
+  case args of
+    Exprs es -> map fst es
+    Strings ss -> map mkStr ss
+    Term t -> [mkStr (render t)]
+
+toTerm args =
+  case args of
+    Term t -> t
+    Strings ss -> K $ unwords ss -- hmm
+    Exprs es -> K $ unwords $ map (showExpr [] . fst) es -- hmm
+
+-- ** Creating documentation
+
+mkEx s = let (command,expl) = break (=="--") (words s) in (unwords command, unwords (drop 1 expl))

src/compiler/api/GF/Command/CommonCommands.hs

@@ -0,0 +1,251 @@
+-- | Commands that work in any type of environment, either because they don't
+-- use the PGF, or because they are just documented here and implemented
+-- elsewhere
+module GF.Command.CommonCommands where
+import Data.List(sort)
+import GF.Command.CommandInfo
+import qualified Data.Map as Map
+import GF.Infra.SIO
+import GF.Infra.UseIO(writeUTF8File)
+import GF.Infra.Option(renameEncoding)
+import GF.System.Console(changeConsoleEncoding)
+import GF.System.Process
+import GF.Command.Abstract --(isOpt,valStrOpts,prOpt)
+import GF.Text.Pretty
+import GF.Text.Transliterations
+import GF.Text.Lexing(stringOp,opInEnv)
+import Data.Char (isSpace)
+
+import PGF2(showExpr)
+
+extend old new = Map.union (Map.fromList new) old -- Map.union is left-biased
+
+commonCommands :: (Monad m,MonadSIO m) => Map.Map String (CommandInfo m)
+commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
+  ("!", emptyCommandInfo {
+     synopsis = "system command: escape to system shell",
+     syntax   = "! SYSTEMCOMMAND",
+     examples = [
+       ("! ls *.gf",  "list all GF files in the working directory")
+       ]
+     }),
+  ("?", emptyCommandInfo {
+     synopsis = "system pipe: send value from previous command to a system command",
+     syntax   = "? SYSTEMCOMMAND",
+     examples = [
+       ("gt | l | ? wc",  "generate, linearize, word-count")
+       ]
+     }),
+  ("dc",  emptyCommandInfo {
+     longname = "define_command",
+     syntax = "dc IDENT COMMANDLINE",
+     synopsis = "define a command macro",
+     explanation = unlines [
+       "Defines IDENT as macro for COMMANDLINE, until IDENT gets redefined.",
+       "A call of the command has the form %IDENT. The command may take an",
+       "argument, which in COMMANDLINE is marked as ?0. Both strings and",
+       "trees can be arguments. Currently at most one argument is possible.",
+       "This command must be a line of its own, and thus cannot be a part",
+       "of a pipe."
+       ]
+     }),
+  ("dt",  emptyCommandInfo {
+     longname = "define_tree",
+     syntax = "dt IDENT (TREE | STRING | \"<\" COMMANDLINE)",
+     synopsis = "define a tree or string macro",
+     explanation = unlines [
+       "Defines IDENT as macro for TREE or STRING, until IDENT gets redefined.",
+       "The defining value can also come from a command, preceded by \"<\".",
+       "If the command gives many values, the first one is selected.",
+       "A use of the macro has the form %IDENT. Currently this use cannot be",
+       "a subtree of another tree. This command must be a line of its own",
+       "and thus cannot be a part of a pipe."
+       ],
+     examples = [
+       mkEx ("dt ex \"hello world\"                    -- define ex as string"),
+       mkEx ("dt ex UseN man_N                         -- define ex as string"),
+       mkEx ("dt ex < p -cat=NP \"the man in the car\" -- define ex as parse result"),
+       mkEx ("l -lang=LangSwe %ex | ps -to_utf8        -- linearize the tree ex")
+       ]
+     }),
+  ("e",  emptyCommandInfo {
+     longname = "empty",
+     synopsis = "empty the environment"
+     }),
+  ("eh",  emptyCommandInfo {
+     longname = "execute_history",
+     syntax = "eh FILE",
+     synopsis = "read commands from a file and execute them"
+     }),
+  ("ph", emptyCommandInfo {
+     longname = "print_history",
+     synopsis = "print command history",
+     explanation = unlines [
+       "Prints the commands issued during the GF session.",
+       "The result is readable by the eh command.",
+       "The result can be used as a script when starting GF."
+       ],
+     examples = [
+      mkEx "ph | wf -file=foo.gfs  -- save the history into a file"
+      ]
+     }),
+  ("ps", emptyCommandInfo {
+     longname = "put_string",
+     syntax = "ps OPT? STRING",
+     synopsis = "return a string, possibly processed with a function",
+     explanation = unlines [
+       "Returns a string obtained from its argument string by applying",
+       "string processing functions in the order given in the command line",
+       "option list. Thus 'ps -f -g s' returns g (f s). Typical string processors",
+       "are lexers and unlexers, but also character encoding conversions are possible.",
+       "The unlexers preserve the division of their input to lines.",
+       "To see transliteration tables, use command ut."
+       ],
+     examples = [
+       mkEx "l (EAdd 3 4) | ps -unlexcode    -- linearize code-like output",
+       mkEx "ps -lexcode | p -cat=Exp        -- parse code-like input",
+       mkEx "gr -cat=QCl | l | ps -bind      -- linearization output from LangFin",
+       mkEx "ps -to_devanagari \"A-p\"         -- show Devanagari in UTF8 terminal",
+       mkEx "rf -file=Hin.gf | ps -env=quotes -to_devanagari -- convert translit to UTF8",
+       mkEx "rf -file=Ara.gf | ps -from_utf8 -env=quotes -from_arabic -- convert UTF8 to transliteration",
+       mkEx "ps -to=chinese.trans \"abc\"      -- apply transliteration defined in file chinese.trans",
+       mkEx "ps -lexgreek \"a)gavoi` a)'nvrwpoi' tines*\" -- normalize ancient greek accentuation"
+       ],
+     exec = \opts x-> do
+               let (os,fs) = optsAndFlags opts
+               trans <- optTranslit opts
+
+               if isOpt "lines" opts 
+                  then return $ fromStrings $ map (trans . stringOps (envFlag fs) (map prOpt os)) $ toStrings x
+                  else return ((fromString . trans . stringOps (envFlag fs) (map prOpt os) . toString) x),
+     options = [
+       ("lines","apply the operation separately to each input line, returning a list of lines")
+       ] ++
+       stringOpOptions,
+     flags = [
+       ("env","apply in this environment only"),
+       ("from","backward-apply transliteration defined in this file (format 'unicode translit' per line)"),
+       ("to",  "forward-apply transliteration defined in this file")
+       ]
+     }),
+  ("q",  emptyCommandInfo {
+     longname = "quit",
+     synopsis = "exit GF interpreter"
+     }),
+  ("r",  emptyCommandInfo {
+     longname = "reload",
+     synopsis = "repeat the latest import command"
+     }),
+
+  ("se", emptyCommandInfo {
+     longname = "set_encoding",
+     synopsis = "set the encoding used in current terminal",
+     syntax   = "se ID",
+     examples = [
+      mkEx "se cp1251 -- set encoding to cp1521",
+      mkEx "se utf8   -- set encoding to utf8 (default)"
+      ],
+     needsTypeCheck = False,
+     exec = \ opts ts ->
+       case words (toString ts) of
+         [c] -> do let cod = renameEncoding c
+                   restricted $ changeConsoleEncoding cod
+                   return void
+         _ -> return (pipeMessage "se command not parsed")
+    }),
+  ("sp", emptyCommandInfo {
+     longname = "system_pipe",
+     synopsis = "send argument to a system command",
+     syntax   = "sp -command=\"SYSTEMCOMMAND\", alt. ? SYSTEMCOMMAND",
+     exec = \opts arg -> do
+       let syst = optComm opts  -- ++ " " ++ tmpi
+       {-
+       let tmpi = "_tmpi" ---
+       let tmpo = "_tmpo"
+       restricted $ writeFile tmpi $ toString arg
+       restrictedSystem $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo
+       fmap fromString $ restricted $ readFile tmpo,
+       -}
+       fmap (fromStrings . lines) . restricted . readShellProcess syst . unlines . map (dropWhile (=='\n')) $ toStrings $ arg,
+
+     flags = [
+       ("command","the system command applied to the argument")
+       ],
+     examples = [
+       mkEx "gt | l | ? wc  -- generate trees, linearize, and count words"
+       ]
+     }),
+  ("ut", emptyCommandInfo {
+     longname = "unicode_table",
+     synopsis = "show a transliteration table for a unicode character set",
+     exec = \opts _ -> do
+         let t = concatMap prOpt (take 1 opts)
+         let out = maybe "no such transliteration" characterTable $ transliteration t
+         return $ fromString out,
+     options = transliterationPrintNames
+     }),
+  ("wf", emptyCommandInfo {
+     longname = "write_file",
+     synopsis = "send string or tree to a file",
+     exec = \opts arg-> do
+         let file = valStrOpts "file" "_gftmp" opts
+         if isOpt "append" opts
+           then restricted $ appendFile file (toLines arg)
+           else restricted $ writeUTF8File file (toLines arg)
+         return void,
+     options = [
+       ("append","append to file, instead of overwriting it")
+       ],
+     flags = [("file","the output filename")]
+     })
+  ]
+ where
+   optComm opts = valStrOpts "command" "" opts
+
+   optTranslit opts = case (valStrOpts "to" "" opts, valStrOpts "from" "" opts) of
+     ("","")  -> return id
+     (file,"") -> do
+       src <- restricted $ readFile file
+       return $ transliterateWithFile file src False
+     (_,file) -> do
+       src <- restricted $ readFile file
+       return $ transliterateWithFile file src True
+
+stringOps menv opts s = foldr (menvop . app) s (reverse opts)
+  where
+    app f = maybe id id (stringOp (const False) f)
+    menvop op = maybe op (\ (b,e) -> opInEnv b e op) menv
+
+envFlag fs =
+  case valStrOpts "env" "global" fs of
+    "quotes" -> Just ("\"","\"")
+    _ -> Nothing
+
+stringOpOptions = sort $ [
+       ("chars","lexer that makes every non-space character a token"),
+       ("from_cp1251","decode from cp1251 (Cyrillic used in Bulgarian resource)"),
+       ("from_utf8","decode from utf8 (default)"),
+       ("lextext","text-like lexer"),
+       ("lexcode","code-like lexer"),
+       ("lexmixed","mixture of text and code, as in LaTeX (code between $...$, \\(...)\\, \\[...\\])"),
+       ("lexgreek","lexer normalizing ancient Greek accentuation"),
+       ("lexgreek2","lexer normalizing ancient Greek accentuation for text with vowel length annotations"),
+       ("to_cp1251","encode to cp1251 (Cyrillic used in Bulgarian resource)"),
+       ("to_html","wrap in a html file with linebreaks"),
+       ("to_utf8","encode to utf8 (default)"),
+       ("unlextext","text-like unlexer"),
+       ("unlexcode","code-like unlexer"),
+       ("unlexmixed","mixture of text and code (code between $...$, \\(...)\\, \\[...\\])"),
+       ("unchars","unlexer that puts no spaces between tokens"),
+       ("unlexgreek","unlexer de-normalizing ancient Greek accentuation"),
+       ("unwords","unlexer that puts a single space between tokens (default)"),
+       ("words","lexer that assumes tokens separated by spaces (default)")
+       ] ++
+      concat [
+       [("from_" ++ p, "from unicode to GF " ++ n ++ " transliteration"),
+        ("to_"   ++ p, "from GF " ++ n ++ " transliteration to unicode")] |
+                                    (p,n) <- transliterationPrintNames]
+
+-- ** Converting command input
+toString  = unwords . toStrings
+toLines = unlines . toStrings

src/compiler/api/GF/Command/Help.hs

@@ -0,0 +1,91 @@
+module GF.Command.Help where
+import GF.Command.Messages
+import GF.Command.Abstract(isOpt,getCommandOp)
+import GF.Command.CommandInfo
+
+import GF.Data.Operations((++++))
+import qualified Data.Map as Map
+
+
+commandHelpAll' allCommands opts = unlines $
+  commandHelp' opts (isOpt "full" opts) `map` Map.toList allCommands
+
+commandHelp' opts = if isOpt "t2t" opts then commandHelpTags else commandHelp
+
+--commandHelp :: Bool -> (String,CommandInfo env) -> String
+commandHelp full (co,info) = unlines . compact $ [
+  co ++ optionally (", " ++) (longname info),
+  synopsis info] ++ if full then [
+  "",
+  optionally (("syntax:" ++++).("  "++).(++"\n")) (syntax info),
+  explanation info,
+  section "options:"  [" -" ++ o ++ "\t" ++ e | (o,e) <- options info],
+  section "flags:"    [" -" ++ o ++ "\t" ++ e | (o,e) <- flags info],
+  section "examples:" ["  " ++ o ++ "\t--" ++ e | (o,e) <- examples info]
+  ] else []
+
+-- for printing with txt2tags formatting
+
+--commandHelpTags :: Bool -> (String,CommandInfo env) -> String
+commandHelpTags full (co,info) = unlines . compact $ [
+  "#VSPACE","",
+  "===="++hdrname++"====",
+  "#NOINDENT",
+  name ++ ": " ++
+  "//" ++ synopsis info ++ ".//"] ++ if full then [
+  "","#TINY","",
+  explanation info,
+  optionally ("- Syntax: "++) (lit (syntax info)),
+  section "- Options:\n"  [" | ``-" ++ o ++ "`` | " ++ e | (o,e) <- options info],
+  section "- Flags:\n"    [" | ``-" ++ o ++ "`` | " ++ e | (o,e) <- flags info],
+  section "- Examples:\n" [" | ``"  ++ o ++ "`` | " ++ e | (o,e) <- examples info],
+  "", "#NORMAL", ""
+  ] else []
+ where
+   hdrname = co ++ equal (longname info)
+   name = lit co ++ equal (lit (longname info))
+
+   lit = optionally (wrap "``")
+   equal = optionally (" = "++)
+-- verbatim = optionally (wrap ["```"])
+   wrap d s = d++s++d
+
+section hdr = optionally ((hdr++++).unlines)
+
+optionally f [] = []
+optionally f s  = f s
+
+compact [] = []
+compact ([]:xs@([]:_)) = compact xs
+compact (x:xs) = x:compact xs
+
+helpCommand allCommands =
+  ("h", emptyCommandInfo {
+     longname = "help",
+     syntax = "h (-full)? COMMAND?",
+     synopsis = "get description of a command, or a the full list of commands",
+     explanation = unlines [
+       "Displays information concerning the COMMAND.",
+       "Without argument, shows the synopsis of all commands."
+       ],
+     options = [
+       ("changes","give a summary of changes from GF 2.9"),
+       ("coding","give advice on character encoding"),
+       ("full","give full information of the commands"),
+       ("license","show copyright and license information"),
+       ("t2t","output help in txt2tags format")
+       ],
+     exec = \opts args ->
+       let
+        msg = case toStrings args of
+          _ | isOpt "changes" opts -> changesMsg
+          _ | isOpt "coding" opts -> codingMsg
+          _ | isOpt "license" opts -> licenseMsg
+          [s] -> let co = getCommandOp s in
+                 case Map.lookup co allCommands of
+                   Just info -> commandHelp' opts True (co,info)
+                   _ -> "command not found"
+          _ -> commandHelpAll' allCommands opts
+       in return (fromString msg),
+     needsTypeCheck = False
+     })

src/compiler/api/GF/Command/Importing.hs

@@ -0,0 +1,95 @@
+module GF.Command.Importing (importGrammar, importSource) where
+
+import PGF2
+import PGF2.Transactions
+
+import GF.Compile
+import GF.Compile.Multi (readMulti)
+import GF.Compile.GetGrammar (getBNFCRules, getEBNFRules)
+import GF.Grammar (ModuleName,SourceGrammar) -- for cc command
+import GF.Grammar.BNFC
+import GF.Grammar.EBNF
+import GF.Grammar.CFG
+import GF.Compile.CFGtoPGF
+import GF.Infra.UseIO(die,tryIOE)
+import GF.Infra.Option
+import GF.Data.ErrM
+
+import System.FilePath
+import System.Directory
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Control.Monad(foldM)
+import Control.Exception(catch,throwIO)
+
+-- import a grammar in an environment where it extends an existing grammar
+importGrammar :: (FilePath -> IO PGF) -> Maybe PGF -> Options -> [FilePath] -> IO (Maybe PGF)
+importGrammar readNGF pgf0 opts  _
+  | Just name <- flag optBlank opts = do
+        mb_ngf_file <- if snd (flag optLinkTargets opts)
+                         then do let fname = name <.> ".ngf"
+                                 putStr ("(Boot image "++fname++") ")
+                                 return (Just fname)
+                         else do return Nothing
+        pgf <- newNGF name mb_ngf_file 0
+        return (Just pgf)
+importGrammar readNGF pgf0 _    [] = return pgf0
+importGrammar readNGF pgf0 opts fs
+  | all (extensionIs ".cf")   fs = fmap Just $ importCF opts fs getBNFCRules bnfc2cf
+  | all (extensionIs ".ebnf") fs = fmap Just $ importCF opts fs getEBNFRules ebnf2cf
+  | all (extensionIs ".gfm")  fs = do
+        ascss <- mapM readMulti fs
+        let cs = concatMap snd ascss
+        importGrammar readNGF pgf0 opts cs
+  | all (\f -> extensionIs ".gf" f || extensionIs ".gfo" f) fs = do
+        res <- tryIOE $ compileToPGF opts pgf0 fs
+        case res of
+          Ok pgf  -> return (Just pgf)
+          Bad msg -> do putStrLn ('\n':'\n':msg)
+                        return pgf0
+  | all (extensionIs ".pgf") fs = foldM (importPGF opts) pgf0 fs
+  | all (extensionIs ".ngf") fs = do
+        case fs of
+          [f] -> fmap Just $ readNGF f
+          _   -> die $ "Only one .ngf file could be loaded at a time"
+  | otherwise =  die $ "Don't know what to do with these input files: " ++ unwords fs
+  where
+    extensionIs ext = (== ext) .  takeExtension
+
+importPGF :: Options -> Maybe PGF -> FilePath -> IO (Maybe PGF)
+importPGF opts Nothing    f
+  | snd (flag optLinkTargets opts) = do let f' = replaceExtension f ".ngf"
+                                        exists <- doesFileExist f'
+                                        if exists
+                                          then removeFile f'
+                                          else return ()
+                                        putStr ("(Boot image "++f'++") ")
+                                        mb_probs <- case flag optProbsFile opts of
+                                                      Nothing   -> return Nothing
+                                                      Just file -> fmap Just (readProbabilitiesFromFile file)
+                                        fmap Just (bootNGFWithProbs f mb_probs f')
+  | otherwise                      = do mb_probs <- case flag optProbsFile opts of
+                                                      Nothing   -> return Nothing
+                                                      Just file -> fmap Just (readProbabilitiesFromFile file)
+                                        fmap Just (readPGFWithProbs f mb_probs)
+importPGF opts (Just pgf) f        = fmap Just (modifyPGF pgf (mergePGF f) `catch`
+                                                (\e@(PGFError loc msg) ->
+                                                      if msg == "The abstract syntax names doesn't match"
+                                                        then do putStrLn (msg++", previous concretes discarded.")
+                                                                readPGF f
+                                                        else throwIO e))
+
+importSource :: Options -> [FilePath] -> IO (ModuleName,SourceGrammar)
+importSource opts files = fmap snd (batchCompile opts files)
+
+-- for different cf formats
+importCF opts files get convert = impCF
+  where
+    impCF = do
+      rules <- fmap (convert . concat) $ mapM (get opts) files
+      startCat <- case rules of
+                    (Rule cat _ _ : _) -> return cat
+                    _                  -> fail "empty CFG"
+      probs <- maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts)
+      let pgf = cf2pgf opts (last files) (mkCFG startCat Set.empty rules) probs
+      return pgf

src/compiler/api/GF/Command/Interpreter.hs

@@ -0,0 +1,107 @@
+module GF.Command.Interpreter (
+  CommandEnv(..),mkCommandEnv,
+  interpretCommandLine,
+  getCommandOp
+  ) where
+import GF.Command.CommandInfo
+import GF.Command.Abstract
+import GF.Command.Parse
+import GF.Infra.UseIO(putStrLnE)
+import PGF2
+
+import Control.Monad(when)
+import qualified Data.Map as Map
+import GF.Infra.UseIO (Output)
+import qualified Control.Monad.Fail as Fail
+
+data CommandEnv m = CommandEnv {
+  commands      :: Map.Map String (CommandInfo m),
+  commandmacros :: Map.Map String CommandLine,
+  expmacros     :: Map.Map String Expr
+  }
+
+--mkCommandEnv :: PGFEnv -> CommandEnv
+mkCommandEnv cmds = CommandEnv cmds Map.empty Map.empty
+
+--interpretCommandLine :: CommandEnv -> String -> SIO ()
+interpretCommandLine :: (Fail.MonadFail m, Output m, TypeCheckArg m) => CommandEnv m -> String -> m ()
+interpretCommandLine env line =
+  case readCommandLine line of
+    Just []    -> return ()
+    Just pipes -> mapM_ (interpretPipe env) pipes
+    Nothing    -> putStrLnE $ "command not parsed: "++line
+
+interpretPipe env cs = do
+     Piped v@(_,s) <- intercs cs void
+     putStrLnE s
+     return ()
+  where
+   intercs [] args = return args
+   intercs (c:cs) (Piped (args,_)) = interc c args >>= intercs cs
+
+   interc comm@(Command co opts arg) args =
+     case co of
+       '%':f -> case Map.lookup f (commandmacros env) of
+         Just css ->
+           do args <- getCommandTrees env False arg args
+              mapM_ (interpretPipe env) (appLine args css)
+              return void
+         Nothing  -> do
+           putStrLnE $ "command macro " ++ co ++ " not interpreted"
+           return void
+       _ -> interpret env args comm
+
+   appLine = map . map . appCommand
+
+-- | macro definition applications: replace ?i by (exps !! i)
+appCommand :: CommandArguments -> Command -> Command
+appCommand args c@(Command i os arg) = case arg of
+  AExpr e -> Command i os (AExpr (exprSubstitute e (toExprs args)))
+  _       -> c
+
+-- | return the trees to be sent in pipe, and the output possibly printed
+--interpret :: CommandEnv -> [Expr] -> Command -> SIO CommandOutput
+interpret env trees comm = 
+  do (info,opts,trees) <- getCommand env trees comm
+     tss@(Piped (_,s)) <- exec info opts trees
+     when (isOpt "tr" opts) $ putStrLnE s
+     return tss
+
+-- | analyse command parse tree to a uniform datastructure, normalizing comm name
+--- the env is needed for macro lookup
+--getCommand :: CommandEnv -> [Expr] -> Command -> Either String (CommandInfo PGFEnv,[Option],[Expr])
+getCommand env es co@(Command c opts arg) =
+  do info <- getCommandInfo  env c
+     checkOpts info opts
+     es <- getCommandTrees env (needsTypeCheck info) arg es
+     return (info,opts,es)
+
+--getCommandInfo :: CommandEnv -> String -> Either String (CommandInfo PGFEnv)
+getCommandInfo env cmd = 
+  case Map.lookup (getCommandOp cmd) (commands env) of
+    Just info -> return info
+    Nothing   -> fail $ "command not found: " ++ cmd
+
+--checkOpts :: CommandInfo env -> [Option] -> Either String ()
+checkOpts info opts = 
+  case
+    [o | OOpt  o   <- opts, notElem o ("tr" : map fst (options info))] ++
+    [o | OFlag o _ <- opts, notElem o (map fst (flags info))]
+  of
+    []  -> return () 
+    [o] -> fail $ "option not interpreted: " ++ o
+    os  -> fail $ "options not interpreted: " ++ unwords os
+
+--getCommandTrees :: CommandEnv -> Bool -> Argument -> [Expr] -> Either String [Expr]
+getCommandTrees env needsTypeCheck a args =
+  case a of
+    AMacro m -> case Map.lookup m (expmacros env) of
+                  Just e -> one e
+                  _      -> return (Exprs []) -- report error?
+    AExpr e -> if needsTypeCheck
+               then one =<< typeCheckArg e
+               else one e
+    ATerm t -> return (Term t)
+    ANoArg  -> return args  -- use piped
+  where
+    one e = return (Exprs [(e,0)]) -- ignore piped

src/compiler/api/GF/Command/Messages.hs

@@ -0,0 +1,83 @@
+module GF.Command.Messages where
+
+import GF.Infra.BuildInfo(buildInfo)
+import Data.Version(showVersion)
+import Paths_gf(version)
+
+
+welcome = unlines [
+  "                              ",
+  "         *  *  *              ",
+  "      *           *           ",
+  "    *               *         ",
+  "   *                          ",
+  "   *                          ",
+  "   *        * * * * * *       ",
+  "   *        *         *       ",
+  "    *       * * * *  *        ",
+  "      *     *      *          ",
+  "         *  *  *              ",
+  "                              ",
+  "This is GF version "++showVersion version++". ",
+  buildInfo,
+  "License: see help -license.   "--,
+  -- Google Code is shutting down August 2015
+--"Bug reports: http://code.google.com/p/grammatical-framework/issues/list"
+  ]
+
+licenseMsg = unlines [
+ "Copyright (c)", 
+ "Krasimir Angelov, Bj\246rn Bringert, H\229kan Burden, Hans-Joachim Daniels,",
+ "Ramona Enache, Markus Forsberg, Thomas Hallgren, Harald Hammarstr\246m,",
+ "Kristofer Johannisson, Janna Khegai, Peter Ljungl\246f, Petri M\228enp\228\228, and", 
+ "Aarne Ranta, 1998-2010.",
+ "",
+ "The compiler is under GNU General Public License (GPL)",
+ "while all Haskell and most GF libraries that come with the distribution are",
+ "under dual GNU Lesser General Public License (LGPL) and BSD License,",
+ "see LICENSE in the GF source distribution for details."
+ ]
+
+codingMsg = unlines [
+  "The GF shell uses Unicode internally, but assumes user input to be UTF8",
+  "and converts terminal and file output to UTF8. If your terminal is not UTF8", 
+  "see 'help set_encoding."
+ ]
+
+changesMsg = unlines [
+  "While GF 3.0 is backward compatible with source grammars, the shell commands", 
+  "have changed from version 2.9. Below the most importand changes. Bug reports",
+  "and feature requests should be sent to http://trac.haskell.org/gf/.",
+  "",
+  "af     use wf -append",
+  "at     not supported",
+  "eh     not yet supported", 
+  "es     no longer supported; use javascript generation",
+  "g      not yet supported", 
+  "l      now by default multilingual",
+  "ml     not yet supported", 
+  "p      now by default multilingual",
+  "pi     not yet supported", 
+  "pl     not yet supported", 
+  "pm     subsumed to pg",
+  "po     not yet supported",
+  "pt     not yet supported", 
+  "r      not yet supported",
+  "rf     changed syntax",
+  "rl     not supported",
+  "s      no longer needed",
+  "sa     not supported",
+  "sf     not supported",
+  "si     not supported",
+  "so     not yet supported", 
+  "t      use pipe with l and p",
+  "tb     use l -treebank",
+  "tl     not yet supported", 
+  "tq     changed syntax",
+  "ts     not supported",
+  "tt     use ps",
+  "ut     not supported",
+  "vg     not yet supported",
+  "wf     changed syntax",
+  "wt     not supported"
+  ]

src/compiler/api/GF/Command/Parse.hs

@@ -0,0 +1,150 @@
+module GF.Command.Parse(readCommandLine, readTransactionCommand, pCommand) where
+
+import PGF(pExpr,pIdent)
+import PGF2(BindType(..),readType,readContext)
+import GF.Infra.Ident(identS)
+import GF.Grammar.Grammar(Term(Abs))
+import GF.Grammar.Parser(runPartial,pTerm)
+import GF.Command.Abstract
+
+import Data.Char(isDigit,isSpace)
+import Control.Monad(liftM2)
+import Text.ParserCombinators.ReadP
+
+readCommandLine :: String -> Maybe CommandLine
+readCommandLine s =
+    case [x | (x,cs) <- readP_to_S pCommandLine s, all isSpace cs] of
+      [x] -> Just x
+      _   -> Nothing
+
+pCommandLine =
+  (skipSpaces >> char '-' >> char '-' >> pTheRest >> return [])   -- comment
+  <++
+  (sepBy (skipSpaces >> pPipe) (skipSpaces >> char ';'))
+
+pPipe = sepBy1 (skipSpaces >> pCommand) (skipSpaces >> char '|')
+
+pCommand = (do
+  cmd  <- pIdent <++ (char '%' >> fmap ('%':) pIdent)
+  skipSpaces
+  opts <- sepBy pOption skipSpaces
+  arg  <- if getCommandOp cmd == "cc" then pArgTerm else pArgument
+  return (Command cmd opts arg)
+  )
+    <++ (do
+  char '?'
+  skipSpaces
+  c <- pSystemCommand
+  return (Command "sp" [OFlag "command" (LStr c)] ANoArg)
+  )
+
+readTransactionCommand :: String -> Maybe TransactionCommand
+readTransactionCommand s =
+    case [x | (x,cs) <- readP_to_S pTransactionCommand s, all isSpace cs] of
+      [x] -> Just x
+      _   -> Nothing
+
+pTransactionCommand = do
+  skipSpaces
+  cmd <- pIdent
+  skipSpaces
+  opts <- sepBy pOption skipSpaces
+  skipSpaces
+  kwd <- pIdent
+  skipSpaces
+  case kwd of
+    "fun" | take 1 cmd == "c" -> do
+               f <- pIdent
+               skipSpaces
+               char ':'
+               skipSpaces
+               ty <- readS_to_P (\s -> case readType s of
+                                         Just ty -> [(ty,"")]
+                                         Nothing -> [])
+               return (CreateFun opts f ty)
+          | take 1 cmd == "d" -> do
+                f <- pIdent
+                return (DropFun opts f)
+    "cat" | take 1 cmd == "c" -> do
+               c <- pIdent
+               skipSpaces
+               ctxt <- readS_to_P (\s -> case readContext s of
+                                           Just ty -> [(ty,"")]
+                                           Nothing -> [])
+               return (CreateCat opts c ctxt)
+          | take 1 cmd == "d" -> do
+                c <- pIdent
+                return (DropCat opts c)
+    "concrete"
+          | take 1 cmd == "c" -> do
+               name <- pIdent
+               return (CreateConcrete opts name)
+          | take 1 cmd == "d" -> do
+               name <- pIdent
+               return (DropConcrete opts name)
+    "lin" | elem (take 1 cmd) ["c","a"] -> do
+               f <- pIdent
+               skipSpaces
+               args <- sepBy pIdent skipSpaces
+               skipSpaces
+               char '='
+               skipSpaces
+               t  <- readS_to_P (\s -> case runPartial pTerm s of
+                                         Right (s,t) -> [(t,s)]
+                                         _ -> [])
+               return (CreateLin opts f (foldr (Abs Explicit . identS) t args) (take 1 cmd == "a"))
+          | take 1 cmd == "d" -> do
+                f <- pIdent
+                return (DropLin opts f)
+    "lincat"
+          | take 1 cmd == "c" -> do
+               f <- pIdent
+               skipSpaces
+               char '='
+               skipSpaces
+               t  <- readS_to_P (\s -> case runPartial pTerm s of
+                                         Right (s,t) -> [(t,s)]
+                                         _ -> [])
+               return (CreateLincat opts f t)
+          | take 1 cmd == "d" -> do
+                f <- pIdent
+                return (DropLincat opts f)
+    _     -> pfail
+
+pOption = do
+  char '-'
+  flg <- pIdent
+  option (OOpt flg) (fmap (OFlag flg) (char '=' >> pValue))
+
+pValue = do
+  fmap LInt (readS_to_P reads)
+  <++
+  fmap LFlt (readS_to_P reads)
+  <++
+  fmap LStr (readS_to_P reads)
+  <++
+  fmap LStr pFilename
+
+pFilename = liftM2 (:) (satisfy isFileFirst) (munch (not . isSpace)) where
+  isFileFirst c = not (isSpace c) && not (isDigit c)
+
+pArgument =
+  option ANoArg
+    (fmap AExpr pExpr
+              <++
+    (skipSpaces >> char '%' >> fmap AMacro pIdent))
+
+pArgTerm = ATerm `fmap` readS_to_P sTerm
+  where
+    sTerm s = case runPartial pTerm s of
+                Right (s,t) -> [(t,s)]
+                _ -> []
+
+pSystemCommand =
+    (char '"' >> (manyTill (pEsc <++ get) (char '"')))
+      <++
+    pTheRest
+  where
+    pEsc = char '\\' >> get
+
+pTheRest = munch (const True)

src/compiler/api/GF/Command/SourceCommands.hs

@@ -0,0 +1,282 @@
+-- | Commands requiring source grammar in env
+module GF.Command.SourceCommands(HasGrammar(..),sourceCommands) where
+
+import Prelude hiding (putStrLn)
+import qualified Prelude as P(putStrLn)
+import Data.List(nub,isInfixOf,isPrefixOf)
+import qualified Data.ByteString.UTF8 as UTF8(fromString)
+import qualified Data.Map as Map
+
+import GF.Infra.SIO(MonadSIO(..),restricted)
+import GF.Infra.Dependencies(depGraph)
+import GF.Infra.CheckM
+import GF.Text.Pretty(render,pp)
+import GF.Data.Str(sstr)
+import GF.Data.Operations (chunks,err,raise)
+
+import GF.Grammar hiding (Ident,isPrefixOf)
+import GF.Grammar.Analyse
+import GF.Grammar.Parser (runP, pExp)
+import GF.Grammar.ShowTerm
+import GF.Grammar.Lookup (allOpers,allOpersTo)
+import GF.Compile.Rename(renameSourceTerm)
+import GF.Compile.Compute.Concrete(normalForm)
+import GF.Compile.TypeCheck.Concrete as TC(inferLType,ppType)
+import GF.Compile.TypeCheck.Primitives(predefMod)
+
+import GF.Command.Abstract(Option(..),isOpt,listFlags,valueString,valStrOpts)
+import GF.Command.CommandInfo
+
+class (Monad m,MonadSIO m) => HasGrammar m where
+  getGrammar :: m Grammar
+
+sourceCommands :: HasGrammar m => Map.Map String (CommandInfo m)
+sourceCommands = Map.fromList [
+  ("cc", emptyCommandInfo {
+     longname = "compute_concrete",
+     syntax = "cc (-all | -table | -unqual)? TERM",
+     synopsis = "computes concrete syntax term using a source grammar",
+     explanation = unlines [
+       "Compute TERM by concrete syntax definitions. Uses the topmost",
+       "module (the last one imported) to resolve constant names.",
+       "N.B.1 You need the flag -retain or -resource when importing the grammar,",
+       "if you want the definitions to be available after compilation.",
+       "N.B.2 The resulting term is not a tree in the sense of abstract syntax",
+       "and hence not a valid input to a Tree-expecting command.",
+       "This command must be a line of its own, and thus cannot be a part",
+       "of a pipe."
+       ],
+     options = [
+       ("all","pick all strings (forms and variants) from records and tables"),
+       ("list","all strings, comma-separated on one line"),
+       ("one","pick the first strings, if there is any, from records and tables"),
+       ("table","show all strings labelled by parameters"),
+       ("unqual","hide qualifying module names"),
+       ("trace","trace computations")
+       ],
+     needsTypeCheck = False, -- why not True?
+     exec = withStrings compute_concrete
+     }),
+  ("dg",  emptyCommandInfo {
+     longname = "dependency_graph",
+     syntax = "dg (-only=MODULES)?",
+     synopsis = "print module dependency graph",
+     explanation = unlines [
+       "Prints the dependency graph of source modules.",
+       "Requires that import has been done with the -retain flag.",
+       "The graph is written in the file _gfdepgraph.dot",
+       "which can be further processed by Graphviz (the system command 'dot').",
+       "By default, all modules are shown, but the -only flag restricts them",
+       "by a comma-separated list of patterns, where 'name*' matches modules",
+       "whose name has prefix 'name', and other patterns match modules with",
+       "exactly the same name. The graphical conventions are:",
+       "  solid box = abstract, solid ellipse = concrete, dashed ellipse = other",
+       "  solid arrow empty head = of, solid arrow = **, dashed arrow = open",
+       "  dotted arrow = other dependency"
+       ],
+     flags = [
+       ("only","list of modules included (default: all), literally or by prefix*")
+       ],
+     examples = [
+       mkEx "dg -only=SyntaxEng,Food*  -- shows only SyntaxEng, and those with prefix Food"
+       ],
+     needsTypeCheck = False,
+     exec = withStrings dependency_graph
+     }),
+  ("sd", emptyCommandInfo {
+     longname = "show_dependencies",
+     syntax = "sd QUALIFIED_CONSTANT+",
+     synopsis = "show all constants that the given constants depend on",
+     explanation = unlines [
+       "Show recursively all qualified constant names, by tracing back the types and definitions",
+       "of each constant encountered, but just listing every name once.",
+       "This command requires a source grammar to be in scope, imported with 'import -retain'.",
+       "Notice that the accuracy is better if the modules are compiled with the flag -optimize=noexpand.",
+       "This command must be a line of its own, and thus cannot be a part of a pipe."
+       ],
+     options = [
+       ("size","show the size of the source code for each constants (number of constructors)")
+       ],
+     examples = [
+       mkEx "sd ParadigmsEng.mkV ParadigmsEng.mkN  -- show all constants on which mkV and mkN depend",
+       mkEx "sd -size ParadigmsEng.mkV    -- show all constants on which mkV depends, together with size"
+       ],
+     needsTypeCheck = False,
+     exec = withStrings show_deps
+     }),
+
+  ("so", emptyCommandInfo {
+     longname = "show_operations",
+     syntax = "so (-grep=STRING)* TYPE?",
+     synopsis = "show all operations in scope, possibly restricted to a value type",
+     explanation = unlines [
+       "Show the names and type signatures of all operations available in the current resource.",
+       "If no grammar is loaded with 'import -retain' or 'import -resource',",
+       "then only the predefined operations are in scope.",
+       "The operations include also the parameter constructors that are in scope.",
+       "The optional TYPE filters according to the value type.",
+       "The grep STRINGs filter according to other substrings of the type signatures."{-,
+       "This command must be a line of its own, and thus cannot be a part",
+       "of a pipe."-}
+       ],
+     flags = [
+       ("grep","substring used for filtering (the command can have many of these)")
+       ],
+     options = [
+       ("raw","show the types in computed forms (instead of category names)")
+       ],
+     examples = [
+         mkEx "so Det -- show all opers that create a Det",
+         mkEx "so -grep=Prep -- find opers relating to Prep",
+         mkEx "so | wf -file=/tmp/opers -- write the list of opers to a file"
+       ],
+     needsTypeCheck = False,
+     exec = withStrings show_operations
+     }),
+
+  ("ss", emptyCommandInfo {
+     longname = "show_source",
+     syntax = "ss (-strip)? (-save)? MODULE*",
+     synopsis = "show the source code of modules in scope, possibly just headers",
+     explanation = unlines [
+       "Show compiled source code, i.e. as it is included in GF object files.",
+       "This command requires a source grammar to be in scope, imported with 'import -retain'.",
+       "The optional MODULE arguments cause just these modules to be shown.",
+       "The -size and -detailedsize options show code size as the number of constructor nodes.",
+       "This command must be a line of its own, and thus cannot be a part of a pipe."
+       ],
+     options = [
+       ("detailedsize", "instead of code, show the sizes of all judgements and modules"),
+       ("save", "save each MODULE in file MODULE.gfh instead of printing it on terminal"),
+       ("size", "instead of code, show the sizes of all modules"),
+       ("strip","show only type signatures of oper's and lin's, not their definitions")
+       ],
+     examples = [
+       mkEx "ss                         -- print complete current source grammar on terminal",
+       mkEx "ss -strip -save MorphoFin  -- print the headers in file MorphoFin.gfh"
+       ],
+     needsTypeCheck = False,
+     exec = withStrings show_source
+     })
+  ]
+  where
+    withStrings exec opts ts =
+      do sgr <- getGrammar
+         liftSIO (exec opts (toStrings ts) sgr)
+
+    compute_concrete opts ws sgr = fmap fst $ runCheck $
+      case runP pExp (UTF8.fromString s) of
+        Left (_,msg) -> return $ pipeMessage msg
+        Right t      -> do t <- checkComputeTerm opts sgr t
+                           return (fromString (showTerm sgr style q t))
+      where
+        (style,q) = pOpts TermPrintDefault Qualified opts
+        s = unwords ws
+
+        pOpts style q []     = (style,q)
+        pOpts style q (o:os) =
+          case o of
+            OOpt "table"   -> pOpts TermPrintTable   q           os
+            OOpt "all"     -> pOpts TermPrintAll     q           os
+            OOpt "list"    -> pOpts TermPrintList    q           os
+            OOpt "one"     -> pOpts TermPrintOne     q           os
+            OOpt "default" -> pOpts TermPrintDefault q           os
+            OOpt "unqual"  -> pOpts style            Unqualified os
+            OOpt "qual"    -> pOpts style            Qualified   os
+            _              -> pOpts style            q           os
+
+    show_deps os xs sgr = do
+          ops <- case xs of
+             _:_ -> do
+               let ts = [t | Right t <- map (runP pExp . UTF8.fromString) xs]
+               err error (return . nub . concat) $ mapM (constantDepsTerm sgr) ts
+             _   -> error "expected one or more qualified constants as argument"
+          let prTerm = showTerm sgr TermPrintDefault Qualified
+          let size = sizeConstant sgr
+          let printed
+                | isOpt "size" os =
+                    let sz = map size ops in
+                    unlines $ ("total: " ++ show (sum sz)) :
+                              [prTerm f ++ "\t" ++ show s | (f,s) <- zip ops sz]
+                | otherwise = unwords $ map prTerm ops
+          return $ fromString printed
+
+    show_operations os ts sgr0 = fmap fst $ runCheck $ do
+      let (sgr,mo) = case greatestResource sgr0 of
+                       Nothing -> (mGrammar [predefMod], fst predefMod)
+                       Just mo -> (sgr0,mo)
+          greps = map valueString (listFlags "grep" os)
+      ops <- case ts of
+               _:_ -> do let Right t = runP pExp (UTF8.fromString (unwords ts))
+                         ty <- checkComputeTerm os sgr t
+                         return $ allOpersTo sgr ty
+               _   -> return $ allOpers sgr
+      let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops]
+          printer = showTerm sgr TermPrintDefault
+                             (if isOpt "raw" os then Qualified else Unqualified)
+          printed = [unwords [showIdent op, ":", printer ty] | (op,ty) <- sigs]
+      return . fromString $ unlines [l | l <- printed, all (`isInfixOf` l) greps]
+
+    show_source os ts sgr = do
+      let strip = if isOpt "strip" os then stripSourceGrammar else id
+      let mygr = strip $ case ts of
+            _:_ -> mGrammar [(i,m) | (i,m) <- modules sgr, elem (render i) ts]
+            [] -> sgr
+      case () of
+        _ | isOpt "detailedsize" os ->
+               return . fromString $ printSizesGrammar mygr
+        _ | isOpt "size" os -> do
+               let sz = sizesGrammar mygr
+               return . fromStrings $
+                 ("total\t" ++ show (fst sz)):
+                 [render j ++ "\t" ++ show (fst k) | (j,k) <- snd sz]
+        _ | isOpt "save" os ->
+              do mapM_ saveModule (modules mygr)
+                 return void
+              where
+                saveModule m@(i,_) =
+                  let file = (render i ++ ".gfh")
+                  in restricted $
+                        do writeFile file (render (ppModule Qualified m))
+                           P.putStrLn ("wrote " ++ file)
+
+        _ -> return . fromString $ render mygr
+
+    dependency_graph opts ws sgr =
+      do let stop = case valStrOpts "only" "" opts of
+                      "" -> Nothing
+                      fs -> Just $ chunks ',' fs
+         restricted $
+            do writeFile "_gfdepgraph.dot" (depGraph stop sgr)
+               P.putStrLn "wrote graph in file _gfdepgraph.dot"
+         return void
+
+checkComputeTerm os sgr0 t =
+  do let (sgr,mo) = case greatestResource sgr0 of
+                      Nothing -> (mGrammar [predefMod], fst predefMod)
+                      Just mo -> (sgr0,mo)
+     t <- renameSourceTerm sgr mo t
+     (t,_) <- inferLType sgr [] t
+     fmap evalStr (normalForm sgr t)
+  where
+    -- ** Try to compute pre{...} tokens in token sequences
+    evalStr t =
+      case t of
+        C t1 t2 -> foldr1 C (evalC [t])
+        _ -> composSafeOp evalStr t
+
+    evalC (C t1 t2:ts) = evalC (t1:t2:ts)
+    evalC (t1@(Alts t tts):ts) = case evalC ts of
+                              K s:ts' -> matchPrefix t tts s:K s:ts'
+                              ts' -> evalStr t1:ts'
+    evalC (t:ts) = evalStr t:evalC ts
+    evalC [] = []
+
+    matchPrefix t0 tts0 s = foldr match1 t tts
+      where
+        alts@(Alts t tts) = evalStr (Alts t0 tts0)
+
+        match1 (u,a) r = err (const alts) ok (strsFromTerm a)
+          where ok as = if any (`isPrefixOf` s) (map sstr as)
+                        then u
+                        else r

src/compiler/api/GF/Command/TreeOperations.hs

@@ -0,0 +1,39 @@
+module GF.Command.TreeOperations (
+  treeOp,
+  allTreeOps,
+  ) where
+
+import PGF2(Expr,PGF,Fun,compute,mkApp,unApp,unMeta,exprSize,exprFunctions)
+import Data.List
+
+type TreeOp = [Expr] -> [Expr]
+
+treeOp :: PGF -> String -> Maybe (Either TreeOp (Fun -> TreeOp))
+treeOp pgf f = fmap snd $ lookup f $ allTreeOps pgf
+
+allTreeOps :: PGF -> [(String,(String,Either TreeOp (Fun -> TreeOp)))]
+allTreeOps pgf = [
+   ("compute",("compute by using semantic definitions (def)",
+      Left  $ map (compute pgf))),
+   ("largest",("sort trees from largest to smallest, in number of nodes",
+      Left  $ largest)),
+   ("nub",("remove duplicate trees",
+      Left  $ nub)),
+   ("smallest",("sort trees from smallest to largest, in number of nodes",
+      Left  $ smallest)),
+   ("subtrees",("return all fully applied subtrees (stopping at abstractions), by default sorted from the largest",
+      Left  $ concatMap subtrees)),
+   ("funs",("return all fun functions appearing in the tree, with duplications",
+      Left  $ \es -> [mkApp f [] | e <- es, f <- exprFunctions e]))
+  ]
+
+largest :: [Expr] -> [Expr]
+largest = reverse . smallest
+
+smallest :: [Expr] -> [Expr]
+smallest = sortBy (\t u -> compare (exprSize t) (exprSize u))
+
+subtrees :: Expr -> [Expr]
+subtrees t = t : case unApp t of
+  Just (f,ts) -> concatMap subtrees ts
+  _ -> []  -- don't go under abstractions

src/compiler/api/GF/Compile.hs

@@ -0,0 +1,118 @@
+module GF.Compile (compileToPGF, link, batchCompile, srcAbsName) where
+
+import GF.Compile.GeneratePMCFG(generatePMCFG)
+import GF.Compile.GrammarToPGF(grammar2PGF)
+import GF.Compile.ReadFiles(ModEnv,getOptionsFromFile,getAllFiles,
+                            importsOfModule)
+import GF.CompileOne(compileOne)
+
+import GF.Grammar.Grammar(Grammar,emptyGrammar,modules,mGrammar,
+                          abstractOfConcrete,prependModule)--,msrc,modules
+
+import GF.Infra.CheckM
+import GF.Infra.Ident(ModuleName,moduleNameS)--,showIdent
+import GF.Infra.Option
+import GF.Infra.UseIO(IOE,FullPath,liftIO,getLibraryDirectory,putIfVerb,
+                      justModuleName,extendPathEnv,putStrE,putPointE,warnOut)
+import GF.Data.Operations(raise,(+++),err)
+
+import Control.Monad(foldM,when,(<=<))
+import GF.System.Directory(getCurrentDirectory,doesFileExist,getModificationTime)
+import System.FilePath((</>),isRelative,dropFileName)
+import qualified Data.Map as Map(empty,insert,elems) --lookup
+import Data.List(nub)
+import Data.Time(UTCTime)
+import GF.Text.Pretty(render,($$),(<+>),nest)
+
+import PGF2(PGF,readProbabilitiesFromFile)
+
+-- | Compiles a number of source files and builds a 'PGF' structure for them.
+-- This is a composition of 'link' and 'batchCompile'.
+compileToPGF :: Options -> Maybe PGF -> [FilePath] -> IOE PGF
+compileToPGF opts mb_pgf fs = link opts mb_pgf . snd =<< batchCompile opts fs
+
+-- | Link a grammar into a 'PGF' that can be used to 'PGF.linearize' and
+-- 'PGF.parse' with the "PGF" run-time system.
+link :: Options -> Maybe PGF -> (ModuleName,Grammar) -> IOE PGF
+link opts mb_pgf (cnc,gr) =
+  putPointE Normal opts "linking ... " $ do
+    let abs = srcAbsName gr cnc
+
+    -- if a module was compiled with no-pmcfg then we generate now
+    cwd <- getCurrentDirectory
+    (gr',warnings) <- runCheck' opts (fmap mGrammar $ mapM (generatePMCFG opts cwd gr) (modules gr))
+    warnOut opts warnings
+
+    probs <- liftIO (maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts))
+    pgf <- grammar2PGF opts mb_pgf gr' abs probs
+    when (verbAtLeast opts Normal) $ putStrE "OK"
+    return pgf
+
+-- | Returns the name of the abstract syntax corresponding to the named concrete syntax
+srcAbsName gr cnc = err (const cnc) id $ abstractOfConcrete gr cnc
+
+-- | Compile the given grammar files and everything they depend on.
+-- Compiled modules are stored in @.gfo@ files (unless the @-tags@ option is
+-- used, in which case tags files are produced instead).
+-- Existing @.gfo@ files are reused if they are up-to-date
+-- (unless the option @-src@ aka @-force-recomp@ is used).
+batchCompile :: Options -> [FilePath] -> IOE (UTCTime,(ModuleName,Grammar))
+batchCompile opts files = do
+  (gr,menv) <- foldM (compileModule opts) emptyCompileEnv files
+  let cnc = moduleNameS (justModuleName (last files))
+      t = maximum . map fst $ Map.elems menv
+  return (t,(cnc,gr))
+
+-- | compile with one module as starting point
+-- command-line options override options (marked by --#) in the file
+-- As for path: if it is read from file, the file path is prepended to each name.
+-- If from command line, it is used as it is.
+compileModule :: Options -- ^ Options from program command line and shell command.
+              -> CompileEnv -> FilePath -> IOE CompileEnv
+compileModule opts1 env@(_,rfs) file =
+  do file <- getRealFile file
+     opts0 <- getOptionsFromFile file
+     let curr_dir = dropFileName file
+     lib_dir  <- getLibraryDirectory (addOptions opts0 opts1)
+     let opts = addOptions (fixRelativeLibPaths curr_dir lib_dir opts0) opts1
+     ps0 <- extendPathEnv opts
+     let ps = nub (curr_dir : ps0)
+     putIfVerb opts $ "module search path:" +++ show ps ----
+     files <- getAllFiles opts ps rfs file
+     putIfVerb opts $ "files to read:" +++ show files ----
+     let names = map justModuleName files
+     putIfVerb opts $ "modules to include:" +++ show names ----
+     foldM (compileOne' opts) env files
+  where
+    getRealFile file = do
+      exists <- doesFileExist file
+      if exists
+        then return file
+        else if isRelative file
+               then do lib_dir <- getLibraryDirectory opts1
+                       let file1 = lib_dir </> file
+                       exists <- doesFileExist file1
+                       if exists
+                         then return file1
+                         else raise (render ("None of these files exists:" $$ nest 2 (file $$ file1)))
+               else raise (render ("File" <+> file <+> "does not exist."))
+
+compileOne' :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
+compileOne' opts env@(gr,_) = extendCompileEnv env <=< compileOne opts gr
+
+-- auxiliaries
+
+-- | The environment
+type CompileEnv = (Grammar,ModEnv)
+
+emptyCompileEnv :: CompileEnv
+emptyCompileEnv = (emptyGrammar,Map.empty)
+
+extendCompileEnv (gr,menv) (mfile,mo) =
+  do menv2 <- case mfile of
+                Just file ->
+                  do let (mod,imps) = importsOfModule mo
+                     t <- getModificationTime file
+                     return $ Map.insert mod (t,imps) menv
+                _ -> return menv
+     return (prependModule gr mo,menv2)

src/compiler/api/GF/Compile/CFGtoPGF.hs

@@ -0,0 +1,136 @@
+{-# LANGUAGE FlexibleContexts, ImplicitParams #-}
+module GF.Compile.CFGtoPGF (cf2pgf) where
+
+import GF.Grammar.CFG
+import GF.Infra.UseIO
+import GF.Infra.Option
+import GF.Compile.OptimizePGF
+
+import PGF2
+
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
+import Data.Array.IArray
+import Data.List
+import Data.Maybe(fromMaybe)
+
+--------------------------
+-- the compiler ----------
+--------------------------
+
+cf2pgf :: Options -> FilePath -> ParamCFG -> Map.Map Fun Double -> PGF
+cf2pgf opts fpath cf probs = error "TODO: cf2pgf" {-
+ build (let abstr = cf2abstr cf probs
+        in newPGF [] aname abstr [(cname, cf2concr opts abstr cf)])
+ where
+   name = justModuleName fpath
+   aname = name ++ "Abs"
+   cname = name
+
+cf2abstr :: (?builder :: Builder s) => ParamCFG -> Map.Map Fun Double -> B s AbstrInfo
+cf2abstr cfg probs = newAbstr aflags acats afuns
+  where
+    aflags = [("startcat", LStr (fst (cfgStartCat cfg)))]
+
+    acats  = [(c', [], toLogProb (fromMaybe 0 (Map.lookup c' probs))) | cat <- allCats' cfg, let c' = cat2id cat]
+    afuns  = [(f', dTyp [hypo Explicit "_" (dTyp [] (cat2id c) []) | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)) [], 0, [], toLogProb (fromMaybe 0 (Map.lookup f' funs_probs)))
+                            | rule <- allRules cfg
+                            , let f' = mkRuleName rule]
+
+    funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++))
+                     [(cat,[(f',Map.lookup f' probs)]) | rule <- allRules cfg,
+                                                         let cat = cat2id (ruleLhs rule),
+                                                         let f' = mkRuleName rule]
+      where
+        pad :: [(a,Maybe Double)] -> [(a,Double)]
+        pad pfs = [(f,fromMaybe deflt mb_p) | (f,mb_p) <- pfs]
+          where
+            deflt = case length [f | (f,Nothing) <- pfs] of
+                      0 -> 0
+                      n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n)
+
+    toLogProb = realToFrac . negate . log
+
+    cat2id = fst
+
+cf2concr :: (?builder :: Builder s) => Options -> B s AbstrInfo -> ParamCFG -> B s ConcrInfo
+cf2concr opts abstr cfg = 
+  let (lindefs',linrefs',productions',cncfuns',sequences',cnccats') =
+           (if flag optOptimizePGF opts then optimizePGF (fst (cfgStartCat cfg)) else id)
+                (lindefsrefs,lindefsrefs,IntMap.toList productions,cncfuns,sequences,cnccats)
+  in newConcr abstr [] []
+              lindefs' linrefs'
+              productions' cncfuns'
+              sequences' cnccats' totalCats
+  where
+    cats  = allCats' cfg
+    rules = allRules cfg
+
+    idSeq = [SymCat 0 0]
+
+    sequences0 = Set.fromList (idSeq : 
+                               map mkSequence rules)
+    sequences  = Set.toList sequences0
+
+    idFun = ("_",[Set.findIndex idSeq sequences0])
+    ((fun_cnt,cncfuns0),productions0) = mapAccumL (convertRule cs) (1,[idFun]) rules
+    productions = foldl addProd IntMap.empty (concat (productions0++coercions))
+    cncfuns = reverse cncfuns0
+
+    lbls = ["s"]
+    (fid,cnccats) = (mapAccumL mkCncCat 0 . Map.toList . Map.fromListWith max)
+                         [(c,p) | (c,ps) <- cats, p <- ps]
+    ((totalCats,cs), coercions) = mapAccumL mkCoercions (fid,Map.empty) cats
+
+    lindefsrefs = map mkLinDefRef cats
+
+    convertRule cs (funid,funs) rule =
+      let args   = [PArg [] (cat2arg c) | NonTerminal c <- ruleRhs rule]
+          prod   = PApply funid args
+          seqid  = Set.findIndex (mkSequence rule) sequences0
+          fun    = (mkRuleName rule, [seqid])
+          funid' = funid+1
+      in funid' `seq` ((funid',fun:funs),let (c,ps) = ruleLhs rule in [(cat2fid c p, prod) | p <- ps])
+
+    mkSequence rule = snd $ mapAccumL convertSymbol 0 (ruleRhs rule)
+      where
+        convertSymbol d (NonTerminal (c,_)) = (d+1,if c `elem` ["Int","Float","String"] then SymLit d 0 else SymCat d 0)
+        convertSymbol d (Terminal t)        = (d,  SymKS t)
+
+    mkCncCat fid (cat,n)
+      | cat == "Int"    = (fid, (cat, fidInt,    fidInt,    lbls))
+      | cat == "Float"  = (fid, (cat, fidFloat,  fidFloat,  lbls))
+      | cat == "String" = (fid, (cat, fidString, fidString, lbls))
+      | otherwise       = let fid' = fid+n+1
+                          in fid' `seq` (fid', (cat, fid, fid+n, lbls))
+
+    mkCoercions (fid,cs) c@(cat,[p]) = ((fid,cs),[])
+    mkCoercions (fid,cs) c@(cat,ps ) =
+      let fid' = fid+1
+      in fid' `seq` ((fid', Map.insert c fid cs), [(fid,PCoerce (cat2fid cat p)) | p <- ps])
+
+    mkLinDefRef (cat,_) =
+      (cat2fid cat 0,[0])
+
+    addProd prods (fid,prod) =
+      case IntMap.lookup fid prods of
+        Just set -> IntMap.insert fid (prod:set) prods
+        Nothing  -> IntMap.insert fid [prod]     prods
+
+    cat2fid cat p =
+      case [start | (cat',start,_,_) <- cnccats, cat == cat'] of
+        (start:_) -> fid+p
+        _         -> error "cat2fid"
+
+    cat2arg c@(cat,[p]) = cat2fid cat p
+    cat2arg c@(cat,ps ) =
+      case Map.lookup c cs of
+        Just fid -> fid
+        Nothing  -> error "cat2arg"
+
+mkRuleName rule =
+  case ruleName rule of
+	CFObj n _ -> n
+	_         -> "_"
+-}

src/compiler/api/GF/Compile/CheckGrammar.hs

@@ -0,0 +1,332 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : CheckGrammar
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/11 23:24:33 $
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.31 $
+--
+-- AR 4\/12\/1999 -- 1\/4\/2000 -- 8\/9\/2001 -- 15\/5\/2002 -- 27\/11\/2002 -- 18\/6\/2003
+--
+-- type checking also does the following modifications:
+--
+--  - types of operations and local constants are inferred and put in place
+--
+--  - both these types and linearization types are computed
+--
+--  - tables are type-annotated
+-----------------------------------------------------------------------------
+
+module GF.Compile.CheckGrammar(checkModule) where
+
+import Prelude hiding ((<>))
+import GF.Infra.Ident
+import GF.Infra.Option
+
+import GF.Compile.TypeCheck.Abstract
+import GF.Compile.TypeCheck.Concrete(checkLType,inferLType,ppType)
+import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType)
+import GF.Compile.Compute.Concrete(normalForm)
+
+import GF.Grammar
+import GF.Grammar.Lexer
+import GF.Grammar.Lookup
+
+import GF.Data.Operations
+import GF.Infra.CheckM
+
+import Data.List
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Control.Monad
+import GF.Text.Pretty
+
+-- | checking is performed in the dependency order of modules
+checkModule :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
+checkModule opts cwd sgr mo@(m,mi) = do
+  checkRestrictedInheritance cwd sgr mo
+  mo <- case mtype mi of
+          MTConcrete a -> do let gr = prependModule sgr mo
+                             abs <- lookupModule gr a
+                             checkCompleteGrammar opts cwd gr (a,abs) mo
+          _            -> return mo
+  infoss <- checkInModule cwd mi NoLoc empty $ topoSortJments2 mo
+  foldM (foldM (checkInfo opts cwd sgr)) mo infoss
+
+-- check if restricted inheritance modules are still coherent
+-- i.e. that the defs of remaining names don't depend on omitted names
+checkRestrictedInheritance :: FilePath -> SourceGrammar -> SourceModule -> Check ()
+checkRestrictedInheritance cwd sgr (name,mo) = checkInModule cwd mo NoLoc empty $ do
+  let irs = [ii | ii@(_,mi) <- mextend mo, mi /= MIAll]  -- names with restr. inh.
+  let mrs = [((i,m),mi) | (i,m) <- mos, Just mi <- [lookup i irs]]
+                             -- the restr. modules themself, with restr. infos
+  mapM_ checkRem mrs
+ where
+   mos = modules sgr
+   checkRem ((i,m),mi) = do
+     let (incl,excl) = partition (isInherited mi) (Map.keys (jments m))
+     let incld c   = Set.member c (Set.fromList incl)
+     let illegal c = Set.member c (Set.fromList excl)
+     let illegals = [(f,is) |
+           (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)]
+     case illegals of
+       [] -> return ()
+       cs -> checkWarn ("In inherited module" <+> i <> ", dependence of excluded constants:" $$
+                         nest 2 (vcat [f <+> "on" <+> fsep is | (f,is) <- cs]))
+   allDeps = concatMap (allDependencies (const True) . jments . snd) mos
+
+checkCompleteGrammar :: Options -> FilePath -> Grammar -> Module -> Module -> Check Module
+checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc empty $ do
+  let jsa = jments abs
+  let jsc = jments cnc
+
+  -- check that all concrete constants are in abstract; build types for all lin
+  jsc <- foldM checkCnc Map.empty (Map.toList jsc)
+
+  -- check that all abstract constants are in concrete; build default lin and lincats
+  jsc <- foldM checkAbs jsc (Map.toList jsa)
+
+  return (cm,cnc{jments=jsc})
+  where
+   checkAbs js i@(c,info) =
+     case info of
+       AbsFun (Just (L loc ty)) _ _ _
+           -> do let mb_def = do
+                       let (cxt,(_,i),_) = typeForm ty
+                       info <- lookupIdent i js
+                       info <- case info of
+                                 (AnyInd _ m) -> do (m,info) <- lookupOrigInfo gr (m,i)
+                                                    return info
+                                 _            -> return info
+                       case info of
+                         CncCat (Just (L loc (RecType []))) _ _ _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt)
+                         _                                          -> Bad "no def lin"
+
+                 case lookupIdent c js of
+                   Ok (AnyInd _ _) -> return js
+                   Ok (CncFun ty (Just def) mn mf) ->
+                                 return $ Map.insert c (CncFun ty (Just def) mn mf) js
+                   Ok (CncFun ty Nothing    mn mf) ->
+                     case mb_def of
+                       Ok def -> return $ Map.insert c (CncFun ty (Just (L NoLoc def)) mn mf) js
+                       Bad _  -> do noLinOf c
+                                    return js
+                   _ -> do
+                     case mb_def of
+                       Ok def -> do linty <- linTypeOfType gr cm (L loc ty)
+                                    return $ Map.insert c (CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js
+                       Bad _  -> do noLinOf c
+                                    return js
+         where noLinOf c = checkWarn ("no linearization of" <+> c)
+       AbsCat (Just _) -> case lookupIdent c js of
+         Ok (AnyInd _ _) -> return js
+         Ok (CncCat (Just _) _ _ _ _) -> return js
+         Ok (CncCat Nothing md mr mp mpmcfg) -> do
+           checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}")
+           return $ Map.insert c (CncCat (Just (L NoLoc defLinType)) md mr mp mpmcfg) js
+         _ -> do
+           checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}")
+           return $ Map.insert c (CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing Nothing) js
+       _ -> return js
+
+   checkCnc js (c,info) =
+     case info of
+       CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of
+                             Ok (_,AbsFun (Just (L loc ty)) _ _ _) ->
+                                        do linty <- linTypeOfType gr cm (L loc ty)
+                                           return $ Map.insert c (CncFun (Just linty) d mn mf) js
+                             _       -> do checkWarn ("function" <+> c <+> "is not in abstract")
+                                           return js
+       CncCat {} ->
+         case lookupOrigInfo gr (am,c) of
+           Ok (_,AbsCat _) -> return $ Map.insert c info js
+           {- -- This might be too pedantic:
+           Ok (_,AbsFun {}) ->
+                   checkError ("lincat:"<+>c<+>"is a fun, not a cat")
+           -}
+           _ -> do checkWarn ("category" <+> c <+> "is not in abstract")
+                   return js
+
+       _ -> return $ Map.insert c info js
+
+checkInfo :: Options -> FilePath -> SourceGrammar -> SourceModule -> (Ident,Info) -> Check SourceModule
+checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
+  checkReservedId c
+  case info of
+    AbsCat (Just (L loc cont)) ->
+      mkCheck loc "the category" $
+        checkContext gr cont
+
+    AbsFun (Just (L loc typ)) ma md moper -> do
+      mkCheck loc "the type of function" $
+        checkTyp gr typ
+      typ <- compAbsTyp [] typ   -- to calculate let definitions
+      case md of
+        Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $
+                                          checkDef gr (fst sm,c) typ eq) eqs
+        Nothing  -> return ()
+      update sm c (AbsFun (Just (L loc typ)) ma md moper)
+
+    CncCat mty mdef mref mpr mpmcfg -> do
+      mty  <- case mty of
+                Just (L loc typ) -> chIn loc "linearization type of" $ do
+                                      (typ,_) <- checkLType gr [] typ typeType
+                                      typ  <- normalForm gr typ
+                                      return (Just (L loc typ))
+                Nothing          -> return Nothing
+      mdef <- case (mty,mdef) of
+                (Just (L _ typ),Just (L loc def)) ->
+                    chIn loc "default linearization of" $ do
+                       (def,_) <- checkLType gr [] def (mkFunType [typeStr] typ)
+                       return (Just (L loc def))
+                _ -> return Nothing
+      mref <- case (mty,mref) of
+                (Just (L _ typ),Just (L loc ref)) ->
+                    chIn loc "reference linearization of" $ do
+                       (ref,_) <- checkLType gr [] ref (mkFunType [typ] typeStr)
+                       return (Just (L loc ref))
+                _ -> return Nothing
+      mpr  <- case mpr of
+                (Just (L loc t)) ->
+                    chIn loc "print name of" $ do
+                       (t,_) <- checkLType gr [] t typeStr
+                       return (Just (L loc t))
+                _ -> return Nothing
+      update sm c (CncCat mty mdef mref mpr mpmcfg)
+
+    CncFun mty mt mpr mpmcfg -> do
+      mt <- case (mty,mt) of
+              (Just (_,cat,cont,val),Just (L loc trm)) ->
+                  chIn loc "linearization of" $ do
+                     (trm,_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val)  -- erases arg vars
+                     return (Just (L loc (etaExpand [] trm cont)))
+              _ -> return mt
+      mpr  <- case mpr of
+                (Just (L loc t)) ->
+                    chIn loc "print name of" $ do
+                       (t,_) <- checkLType gr [] t typeStr
+                       return (Just (L loc t))
+                _ -> return Nothing
+      update sm c (CncFun mty mt mpr mpmcfg)
+
+    ResOper pty pde -> do
+      (pty', pde') <- case (pty,pde) of
+         (Just (L loct ty), Just (L locd de)) -> do
+           ty'     <- chIn loct "operation" $ do
+                         (ty,_) <- checkLType gr [] ty typeType
+                         normalForm gr ty
+           (de',_) <- chIn locd "operation" $
+                         checkLType gr [] de ty'
+           return (Just (L loct ty'), Just (L locd de'))
+         (Nothing         , Just (L locd de)) -> do
+           (de',ty') <- chIn locd "operation" $
+                          inferLType gr [] de
+           return (Just (L locd ty'), Just (L locd de'))
+         (Just (L loct ty), Nothing) -> do
+           chIn loct "operation" $
+             checkError (pp "No definition given to the operation")
+      update sm c (ResOper pty' pde')
+
+    ResOverload os tysts -> chIn NoLoc "overloading" $ do
+      tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gr [] t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts  -- return explicit ones
+      tysts0 <- lookupOverload gr (fst sm,c)  -- check against inherited ones too
+      tysts1 <- mapM (uncurry $ flip (checkLType gr []))
+                  [(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
+      --- this can only be a partial guarantee, since matching
+      --- with value type is only possible if expected type is given
+      checkUniq $
+        sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
+      update sm c (ResOverload os [(y,x) | (x,y) <- tysts'])
+
+    ResParam (Just (L loc pcs)) _ -> do
+      (sm,cnt,ts,pcs) <- chIn loc "parameter type" $
+                            mkParamValues sm c 0 [] pcs
+      update sm c (ResParam (Just (L loc pcs)) (Just (ts,cnt)))
+
+    _ ->  return sm
+ where
+   gr = prependModule sgr sm
+   chIn loc cat = checkInModule cwd (snd sm) loc ("Happened in" <+> cat <+> c)
+
+   mkParamValues sm         c cnt ts []           = return (sm,cnt,[],[])
+   mkParamValues sm@(mn,mi) c cnt ts ((p,co):pcs) = do
+     co <- mapM (\(b,v,ty) -> normalForm gr ty >>= \ty -> return (b,v,ty)) co
+     sm <- case lookupIdent p (jments mi) of
+             Ok (ResValue (L loc _) _) -> update sm p (ResValue (L loc (mkProdSimple co (QC (mn,c)))) cnt)
+             Bad msg                   -> checkError (pp msg)
+     vs <- liftM sequence $ mapM (\(_,_,ty) -> allParamValues gr ty) co
+     (sm,cnt,ts,pcs) <- mkParamValues sm c (cnt+length vs) ts pcs
+     return (sm,cnt,map (mkApp (QC (mn,p))) vs ++ ts,(p,co):pcs)
+
+   checkUniq xss = case xss of
+     x:y:xs
+      | x == y    -> checkError $ "ambiguous for type" <+>
+                                  ppType (mkFunType (tail x) (head x))
+      | otherwise -> checkUniq $ y:xs
+     _ -> return ()
+
+   mkCheck loc cat ss = case ss of
+     [] -> return sm
+     _ -> chIn loc cat $ checkError (vcat ss)
+
+   compAbsTyp g t = case t of
+     Vr x -> maybe (checkError ("no value given to variable" <+> x)) return $ lookup x g
+     Let (x,(_,a)) b -> do
+       a' <- compAbsTyp g a
+       compAbsTyp ((x, a'):g) b
+     Prod b x a t -> do
+       a' <- compAbsTyp g a
+       t' <- compAbsTyp ((x,Vr x):g) t
+       return $ Prod b x a' t'
+     Abs _ _ _ -> return t
+     _ -> composOp (compAbsTyp g) t
+
+   etaExpand xs t            []               = t
+   etaExpand xs (Abs bt x t) (_        :cont) = Abs bt x (etaExpand (x:xs) t              cont)
+   etaExpand xs t            ((bt,_,ty):cont) = Abs bt x (etaExpand (x:xs) (App t (Vr x)) cont)
+     where
+       x = freeVar 1 xs
+
+       freeVar i xs
+         | elem x xs = freeVar (i+1) xs
+         | otherwise = x
+         where
+           x = identS ("v"++show i)
+
+   update (mn,mi) c info = return (mn,mi{jments=Map.insert c info (jments mi)})
+
+
+-- | for grammars obtained otherwise than by parsing ---- update!!
+checkReservedId :: Ident -> Check ()
+checkReservedId x =
+  when (isReservedWord x) $
+       checkWarn ("reserved word used as identifier:" <+> x)
+
+-- auxiliaries
+
+-- | linearization types and defaults
+linTypeOfType :: Grammar -> ModuleName -> L Type -> Check ([Ident],Ident,Context,Type)
+linTypeOfType cnc m (L loc typ) = do
+  let (ctxt,res_cat) = typeSkeleton typ
+  val <- lookLin res_cat
+  lin_args <- mapM mkLinArg (zip [1..] ctxt)
+  let (args,arg_cats) = unzip lin_args
+  return (arg_cats, snd res_cat, args, val)
+ where
+   mkLinArg (i,(n,mc@(m,cat))) = do
+     val  <- lookLin mc
+     let vars = mkRecType varLabel $ replicate n typeStr
+     rec <- if n==0 then return val else
+                       errIn (render ("extending" $$
+                                      nest 2 vars $$
+                                      "with" $$
+                                      nest 2 val)) $
+                             plusRecType vars val
+     return ((Explicit,varX i,rec),cat)
+   lookLin (_,c) = checks [ --- rather: update with defLinType ?
+      lookupLincat cnc m c >>= normalForm cnc
+     ,return defLinType
+     ]

src/compiler/api/GF/Compile/Compute/Abstract.hs

@@ -0,0 +1,138 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.Compile.Abstract.Compute
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/02 20:50:19 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.8 $
+--
+-- computation in abstract syntax w.r.t. explicit definitions.
+--
+-- old GF computation; to be updated
+-----------------------------------------------------------------------------
+
+module GF.Compile.Compute.Abstract (LookDef,
+		   compute, 
+		   computeAbsTerm, 
+		   computeAbsTermIn, 
+		   beta
+		  ) where
+
+import GF.Data.Operations
+
+import GF.Grammar
+import GF.Grammar.Lookup
+
+import Debug.Trace
+import Data.List(intersperse)
+import Control.Monad (liftM, liftM2)
+import GF.Text.Pretty
+
+-- for debugging
+tracd m t = t 
+-- tracd = trace
+
+compute :: SourceGrammar -> Term -> Err Term
+compute = computeAbsTerm
+
+computeAbsTerm :: SourceGrammar -> Term -> Err Term
+computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) []
+
+-- | a hack to make compute work on source grammar as well
+type LookDef = Ident -> Ident -> Err (Maybe Int,Maybe [Equation])
+
+computeAbsTermIn :: LookDef -> [Ident] -> Term -> Err Term
+computeAbsTermIn lookd xs e = errIn (render (text "computing" <+> ppTerm Unqualified 0 e)) $ compt xs e where
+  compt vv t = case t of
+--    Prod x a b  -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b)
+--    Abs x b     -> liftM  (Abs  x)              (compt (x:vv) b)
+    _ -> do
+      let t' = beta vv t
+      (yy,f,aa) <- termForm t'
+      let vv' = map snd yy ++ vv
+      aa'    <- mapM (compt vv') aa
+      case look f of
+        Just eqs -> tracd (text "\nmatching" <+> ppTerm Unqualified 0 f) $ 
+                          case findMatch eqs aa' of
+          Ok (d,g) -> do
+            --- let (xs,ts) = unzip g
+            --- ts' <- alphaFreshAll vv' ts
+            let g' = g --- zip xs ts'
+            d' <- compt vv' $ substTerm vv' g' d
+            tracd (text "by Egs:" <+> ppTerm Unqualified 0 d') $ return $ mkAbs yy $ d'
+          _ -> tracd (text "no match" <+> ppTerm Unqualified 0 t') $ 
+               do
+            let v = mkApp f aa'
+            return $ mkAbs yy $ v
+        _ -> do
+          let t2 = mkAbs yy $ mkApp f aa'
+          tracd (text "not defined" <+> ppTerm Unqualified 0 t2) $ return t2
+
+  look t = case t of
+     (Q (m,f)) -> case lookd m f of
+       Ok (_,md) -> md
+       _ -> Nothing
+     _ -> Nothing
+
+beta :: [Ident] -> Exp -> Exp
+beta vv c = case c of
+  Let (x,(_,a)) b -> beta vv $ substTerm vv [(x,beta vv a)] (beta (x:vv) b) 
+  App f         a -> 
+    let (a',f') = (beta vv a, beta vv f) in 
+    case f' of
+      Abs _ x b -> beta vv $ substTerm vv [(x,a')] (beta (x:vv) b) 
+      _ ->               (if a'==a && f'==f then id else beta vv) $ App f' a'
+  Prod b x a t      -> Prod b x (beta vv a) (beta (x:vv) t)
+  Abs b x t       -> Abs b x (beta (x:vv) t)
+  _               -> c
+
+-- special version of pattern matching, to deal with comp under lambda
+
+findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution)
+findMatch cases terms = case cases of
+  [] -> Bad $ render (text "no applicable case for" <+> hcat (punctuate comma (map (ppTerm Unqualified 0) terms)))
+  (patts,_):_ | length patts /= length terms -> 
+       Bad (render (text "wrong number of args for patterns :" <+> 
+                    hsep (map (ppPatt Unqualified 0) patts) <+> text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms)))
+  (patts,val):cc -> case mapM tryMatch (zip patts terms) of
+     Ok substs -> return (tracd (text "value" <+> ppTerm Unqualified 0 val) val, concat substs)
+     _         -> findMatch cc terms
+
+tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
+tryMatch (p,t) = do 
+  t' <- termForm t
+  trym p t'
+ where
+
+  trym p t' = err (\s -> tracd s (Bad s)) (\t -> tracd (prtm p t) (return t)) $ ---- 
+              case (p,t') of
+    (PW,    _) | notMeta t -> return [] -- optimization with wildcard
+    (PV x,  _) | notMeta t -> return [(x,t)]
+    (PString s, ([],K i,[])) | s==i -> return []
+    (PInt s, ([],EInt i,[])) | s==i -> return []
+    (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
+    (PP (q,p) pp, ([], QC (r,f), tt)) | 
+       p `eqStrIdent` f && length pp == length tt -> do
+         matches <- mapM tryMatch (zip pp tt)
+         return (concat matches)
+    (PP (q,p) pp, ([], Q (r,f), tt)) | 
+       p `eqStrIdent` f && length pp == length tt -> do
+         matches <- mapM tryMatch (zip pp tt)
+         return (concat matches)
+    (PT _ p',_) -> trym p' t'
+    (PAs x p',_) -> do
+       subst <- trym p' t'
+       return $ (x,t) : subst
+    _ -> Bad (render (text "no match in pattern" <+> ppPatt Unqualified 0 p <+> text "for" <+> ppTerm Unqualified 0 t))
+
+  notMeta e = case e of
+    Meta _  -> False
+    App f a -> notMeta f &&  notMeta a  
+    Abs _ _ b -> notMeta b
+    _ -> True
+
+  prtm p g = 
+    ppPatt Unqualified 0 p <+> colon $$ hsep (punctuate semi [ppIdent x <+> char '=' <+> ppTerm Unqualified 0 y | (x,y) <- g])

src/compiler/api/GF/Compile/Compute/Concrete.hs

@@ -0,0 +1,914 @@
+{-# LANGUAGE RankNTypes, BangPatterns, CPP #-}
+
+-- | Functions for computing the values of terms in the concrete syntax, in
+-- | preparation for PMCFG generation.
+module GF.Compile.Compute.Concrete
+           ( normalForm
+           , Value(..), Thunk, ThunkState(..), Env, Scope, showValue
+           , MetaThunks, Constraint
+           , EvalM(..), runEvalM, runEvalOneM, evalError, evalWarn
+           , eval, apply, force, value2term, patternMatch
+           , newThunk, newEvaluatedThunk
+           , newResiduation, newNarrowing, getVariables
+           , getRef, setRef
+           , getResDef, getInfo, getResType, getOverload
+           , getAllParamValues
+           ) where
+
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
+
+import GF.Grammar hiding (Env, VGen, VApp, VRecType)
+import GF.Grammar.Lookup(lookupResDef,lookupResType,
+                         lookupOrigInfo,lookupOverloadTypes,
+                         allParamValues)
+import GF.Grammar.Predef
+import GF.Grammar.Lockfield(lockLabel)
+import GF.Grammar.Printer
+import GF.Data.Operations(Err(..))
+import GF.Infra.CheckM
+import GF.Infra.Option
+import Data.STRef
+import Data.Maybe(fromMaybe)
+import Data.List
+import Data.Char
+import Control.Monad
+import Control.Monad.ST
+import Control.Applicative hiding (Const)
+import qualified Control.Monad.Fail as Fail
+import qualified Data.Map as Map
+import GF.Text.Pretty
+import PGF2.Transactions(LIndex)
+
+-- * Main entry points
+
+normalForm :: Grammar -> Term -> Check Term
+normalForm gr t =
+  fmap mkFV (runEvalM gr (eval [] t [] >>= value2term []))
+  where
+    mkFV [t] = t
+    mkFV ts  = FV ts
+
+type Sigma s = Value s
+type Constraint s = Value s
+
+data ThunkState s
+  = Unevaluated (Env s) Term
+  | Evaluated {-# UNPACK #-} !Int (Value s)
+  | Hole        {-# UNPACK #-} !MetaId
+  | Narrowing   {-# UNPACK #-} !MetaId Type
+  | Residuation {-# UNPACK #-} !MetaId (Scope s) (Maybe (Constraint s))
+
+type Thunk s = STRef s (ThunkState s)
+type Env s = [(Ident,Thunk s)]
+type Scope s = [(Ident,Value s)]
+
+data Value s
+  = VApp QIdent [Thunk s]
+  | VMeta (Thunk s) [Thunk s]
+  | VSusp (Thunk s) (Value s -> EvalM s (Value s)) [Thunk s]
+  | VGen  {-# UNPACK #-} !Int [Thunk s]
+  | VClosure (Env s) Term
+  | VProd BindType Ident (Value s) (Value s)
+  | VRecType [(Label, Value s)]
+  | VR [(Label, Thunk s)]
+  | VP (Value s) Label [Thunk s]
+  | VExtR (Value s) (Value s)
+  | VTable (Value s) (Value s)
+  | VT (Value s) (Env s) [Case]
+  | VV (Value s) [Thunk s]
+  | VS (Value s) (Thunk s) [Thunk s]
+  | VSort Ident
+  | VInt Integer
+  | VFlt Double
+  | VStr String
+  | VEmpty
+  | VC (Value s) (Value s)
+  | VGlue (Value s) (Value s)
+  | VPatt Int (Maybe Int) Patt
+  | VPattType (Value s)
+  | VAlts (Value s) [(Value s, Value s)]
+  | VStrs [Value s]
+    -- These two constructors are only used internally
+    -- in the PMCFG generator.
+  | VSymCat Int LIndex [(LIndex, (Thunk s, Type))]
+  | VSymVar Int Int
+    -- These two constructors are only used internally
+    -- in the type checker.
+  | VCRecType [(Label, Bool, Constraint s)]
+  | VCInts (Maybe Integer) (Maybe Integer)
+
+
+showValue (VApp q tnks) = "(VApp "++unwords (show q : map (const "_") tnks) ++ ")"
+showValue (VMeta _ _) = "VMeta"
+showValue (VSusp _ _ _) = "VSusp"
+showValue (VGen i _) = "(VGen "++show i++")"
+showValue (VClosure _ _) = "VClosure"
+showValue (VProd _ x v1 v2) = "VProd ("++show x++") ("++showValue v1++") ("++showValue v2++")"
+showValue (VRecType _) = "VRecType"
+showValue (VR lbls) = "(VR {"++unwords (map (\(lbl,_) -> show lbl) lbls)++"})"
+showValue (VP v l _) = "(VP "++showValue v++" "++show l++")"
+showValue (VExtR _ _) = "VExtR"
+showValue (VTable v1 v2) = "VTable ("++showValue v1++") ("++showValue v2++")"
+showValue (VT _ _ cs) = "(VT "++show cs++")"
+showValue (VV _ _) = "VV"
+showValue (VS v _ _) = "(VS "++showValue v++")"
+showValue (VSort s) = "(VSort "++show s++")"
+showValue (VInt _) = "VInt"
+showValue (VFlt _) = "VFlt"
+showValue (VStr s) = "(VStr "++show s++")"
+showValue VEmpty = "VEmpty"
+showValue (VC _ _) = "VC"
+showValue (VGlue _ _) = "VGlue"
+showValue (VPatt _ _ _) = "VPatt"
+showValue (VPattType _) = "VPattType"
+showValue (VAlts _ _) = "VAlts"
+showValue (VStrs _) = "VStrs"
+showValue (VSymCat _ _ _) = "VSymCat"
+
+eval env (Vr x)         vs  = do (tnk,depth) <- lookup x env
+                                 withVar depth $ do
+                                   v <- force tnk
+                                   apply v vs
+                              where
+                                lookup x []   = evalError ("Variable" <+> pp x <+> "is not in scope")
+                                lookup x ((y,tnk):env)
+                                  | x == y    = return (tnk,length env)
+                                  | otherwise = lookup x env
+eval env (Sort s)       []
+  | s == cTok               = return (VSort cStr)
+  | otherwise               = return (VSort s)
+eval env (EInt n)       []  = return (VInt n)
+eval env (EFloat d)     []  = return (VFlt d)
+eval env (K t)          []  = return (VStr t)
+eval env Empty          []  = return VEmpty
+eval env (App t1 t2)    vs  = do tnk <- newThunk env t2
+                                 eval env t1 (tnk : vs)
+eval env (Abs b x t)    []  = return (VClosure env (Abs b x t))
+eval env (Abs b x t) (v:vs) = eval ((x,v):env) t vs
+eval env (Meta i)       vs  = do tnk <- newHole i
+                                 return (VMeta tnk vs)
+eval env (ImplArg t)    []  = eval env t []
+eval env (Prod b x t1 t2)[] = do v1 <- eval env t1 []
+                                 return (VProd b x v1 (VClosure env t2))
+eval env (Typed t ty)   vs  = eval env t vs
+eval env (RecType lbls) []  = do lbls <- mapM (\(lbl,ty) -> fmap ((,) lbl) (eval env ty [])) lbls
+                                 return (VRecType (sortRec lbls))
+eval env (R as)         []  = do as <- mapM (\(lbl,(_,t)) -> fmap ((,) lbl) (newThunk env t)) as
+                                 return (VR as)
+eval env (P t lbl)      vs  = do v <- eval env t []
+                                 case v of
+                                   VR as -> case lookup lbl as of
+                                              Nothing  -> evalError ("Missing value for label" <+> pp lbl $$
+                                                                     "in" <+> pp (P t lbl))
+                                              Just tnk -> do v <- force tnk
+                                                             apply v vs
+                                   v     -> return (VP v lbl vs)
+eval env (ExtR t1 t2)   []  = do v1 <- eval env t1 []
+                                 v2 <- eval env t2 []
+                                 case (v1,v2) of
+                                   (VR       as1,VR       as2) -> return (VR       (foldl (\as (lbl,v) -> update lbl v as) as1 as2))
+                                   (VRecType as1,VRecType as2) -> return (VRecType (foldl (\as (lbl,v) -> update lbl v as) as1 as2))
+                                   _                           -> return (VExtR v1 v2)
+eval env (Table t1 t2)  []  = do v1 <- eval env t1 []
+                                 v2 <- eval env t2 []
+                                 return (VTable v1 v2)
+eval env (T (TTyped ty) cs)[]=do vty <- eval env ty []
+                                 return (VT vty env cs)
+eval env (T (TWild ty) cs) []=do vty <- eval env ty []
+                                 return (VT vty env cs)
+eval env (V ty ts)      []  = do vty <- eval env ty []
+                                 tnks <- mapM (newThunk env) ts
+                                 return (VV vty tnks)
+eval env (S t1 t2)      vs  = do v1   <- eval env t1 []
+                                 tnk2 <- newThunk env t2
+                                 let v0 = VS v1 tnk2 vs
+                                 case v1 of
+                                   VT _  env cs -> patternMatch v0 (map (\(p,t) -> (env,[p],tnk2:vs,t)) cs)
+                                   VV vty tnks  -> do ty <- value2term (map fst env) vty
+                                                      vtableSelect v0 ty tnks tnk2 vs
+                                   v1           -> return v0
+eval env (Let (x,(_,t1)) t2) vs = do tnk <- newThunk env t1
+                                     eval ((x,tnk):env) t2 vs
+eval env (Q q@(m,id))   vs
+  | m == cPredef            = do vs' <- mapM force vs
+                                 mb_res <- evalPredef id vs'
+                                 case mb_res of
+                                   Const res -> return res
+                                   RunTime   -> return (VApp q vs)
+                                   NonExist  -> return (VApp (cPredef,cNonExist) [])
+  | otherwise               = do t <- getResDef q
+                                 eval env t vs
+eval env (QC q)         vs  = return (VApp q vs)
+eval env (C t1 t2)      []  = do v1 <- eval env t1 []
+                                 v2 <- eval env t2 []
+                                 case (v1,v2) of
+                                   (v1,    VEmpty) -> return v1
+                                   (VEmpty,v2    ) -> return v2
+                                   _               -> return (VC v1 v2)
+eval env t@(Glue t1 t2) []  = do v1 <- eval env t1 []
+                                 v2 <- eval env t2 []
+                                 let glue VEmpty        v             = v
+                                     glue (VC v1 v2)    v             = VC v1 (glue v2 v)
+                                     glue (VApp q [])   v
+                                       | q == (cPredef,cNonExist)     = VApp q []
+                                     glue v             VEmpty        = v
+                                     glue v             (VC v1 v2)    = VC (glue v v1) v2
+                                     glue v             (VApp q [])
+                                       | q == (cPredef,cNonExist)     = VApp q []
+                                     glue (VStr s1)     (VStr s2)     = VStr (s1++s2)
+                                     glue v             (VAlts d vas) = VAlts (glue v d) [(glue v v',ss) | (v',ss) <- vas]
+                                     glue (VAlts d vas) (VStr s)      = pre d vas s
+                                     glue (VAlts d vas) v             = glue d v
+                                     glue v1          v2              = VGlue v1 v2
+
+                                     pre vd []                 s             = glue vd (VStr s)
+                                     pre vd ((v,VStrs ss):vas) s
+                                      | or [startsWith s' s | VStr s' <- ss] = glue v (VStr s)
+                                      | otherwise                            = pre vd vas s
+
+                                 return (glue v1 v2)
+eval env (EPatt min max p) [] = return (VPatt min max p)
+eval env (EPattType t)  []  = do v <- eval env t []
+                                 return (VPattType v)
+eval env (ELincat c ty) []  = do v <- eval env ty []
+                                 let lbl = lockLabel c
+                                     lv  = VRecType []
+                                 case v of
+                                   (VRecType as) -> return (VRecType (update lbl lv as))
+                                   _             -> return (VExtR v (VRecType [(lbl,lv)]))
+eval env (ELin c t)     []  = do v <- eval env t []
+                                 let lbl = lockLabel c
+                                 tnk <- newEvaluatedThunk (VR [])
+                                 case v of
+                                   (VR as) -> return (VR (update lbl tnk as))
+                                   _       -> return (VExtR v (VR [(lbl,tnk)]))
+eval env (FV ts)        vs  = msum [eval env t vs | t <- ts]
+eval env (Alts d as)    []  = do vd <- eval env d []
+                                 vas <- forM as $ \(t,s) -> do
+                                           vt <- eval env t []
+                                           vs <- eval env s []
+                                           return (vt,vs)
+                                 return (VAlts vd vas)
+eval env (Strs ts)      []  = do vs <- mapM (\t -> eval env t []) ts
+                                 return (VStrs vs)
+eval env (TSymCat d r rs) []= do rs <- forM rs $ \(i,(pv,ty)) ->
+                                         case lookup pv env of
+                                           Just tnk -> return (i,(tnk,ty))
+                                           Nothing  -> evalError ("Variable" <+> pp pv <+> "is not in scope")
+                                 return (VSymCat d r rs)
+eval env (TSymVar d r)  []  = do return (VSymVar d r)
+eval env t              vs  = evalError ("Cannot reduce term" <+> pp t)
+
+apply (VMeta m vs0)                 vs  = return (VMeta m   (vs0++vs))
+apply (VSusp m k vs0)               vs  = return (VSusp m k (vs0++vs))
+apply (VApp f  vs0)                 vs  = return (VApp f (vs0++vs))
+apply (VGen i  vs0)                 vs  = return (VGen i (vs0++vs))
+apply (VClosure env (Abs b x t)) (v:vs) = eval ((x,v):env) t vs
+apply v                             []  = return v
+
+evalPredef id [v]
+  | id == cLength = case value2string v of
+                      Const s -> return (Const (VInt (genericLength s)))
+                      _       -> return RunTime
+evalPredef id [v1,v2]
+  | id == cTake   = return (fmap string2value (liftA2 genericTake (value2int v1) (value2string v2)))
+evalPredef id [v1,v2]
+  | id == cDrop   = return (fmap string2value (liftA2 genericDrop (value2int v1) (value2string v2)))
+evalPredef id [v1,v2]
+  | id == cTk     = return (fmap string2value (liftA2 genericTk (value2int v1) (value2string v2)))
+  where
+    genericTk n = reverse . genericDrop n . reverse
+evalPredef id [v1,v2]
+  | id == cDp     = return (fmap string2value (liftA2 genericDp (value2int v1) (value2string v2)))
+  where
+    genericDp n = reverse . genericTake n . reverse
+evalPredef id [v]
+  | id == cIsUpper= return (fmap toPBool (liftA (all isUpper) (value2string v)))
+evalPredef id [v]
+  | id == cToUpper= return (fmap string2value (liftA (map toUpper) (value2string v)))
+evalPredef id [v]
+  | id == cToLower= return (fmap string2value (liftA (map toLower) (value2string v)))
+evalPredef id [v1,v2]
+  | id == cEqStr  = return (fmap toPBool (liftA2 (==) (value2string v1) (value2string v2)))
+evalPredef id [v1,v2]
+  | id == cOccur  = return (fmap toPBool (liftA2 occur (value2string v1) (value2string v2)))
+evalPredef id [v1,v2]
+  | id == cOccurs  = return (fmap toPBool (liftA2 occurs (value2string v1) (value2string v2)))
+evalPredef id [v1,v2]
+  | id == cEqInt  = return (fmap toPBool (liftA2 (==) (value2int v1) (value2int v2)))
+evalPredef id [v1,v2]
+  | id == cLessInt= return (fmap toPBool (liftA2 (<) (value2int v1) (value2int v2)))
+evalPredef id [v1,v2]
+  | id == cPlus   = return (fmap VInt (liftA2 (+) (value2int v1) (value2int v2)))
+evalPredef id [v]
+  | id == cError  = case value2string v of
+                      Const msg -> fail msg
+                      _         -> fail "Indescribable error appeared"
+evalPredef id vs  = return RunTime
+
+toPBool True  = VApp (cPredef,cPTrue)  []
+toPBool False = VApp (cPredef,cPFalse) []
+
+occur s1 []          = False
+occur s1 s2@(_:tail) = check s1 s2
+  where
+    check xs        []  = False
+    check []        ys  = True
+    check (x:xs) (y:ys)
+      | x == y          = check xs ys
+    check _      _      = occur s1 tail
+
+occurs cs s2 = any (\c -> elem c s2) cs
+
+update lbl v []              = [(lbl,v)]
+update lbl v (a@(lbl',_):as)
+  | lbl==lbl'                = (lbl,v) : as
+  | otherwise                = a : update lbl v as
+
+
+patternMatch v0 []                      = return v0
+patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
+  where
+    match env []              eqs      args  = eval env t args
+    match env (PT ty p   :ps) eqs      args  = match env (p:ps) eqs args
+    match env (PAlt p1 p2:ps) eqs      args  = match env (p1:ps) ((env,p2:ps,args,t):eqs) args
+    match env (PM q      :ps) eqs      args  = do t <- getResDef q
+                                                  v <- eval [] t []
+                                                  case v of
+                                                    VPatt _ _ p -> match env (p:ps) eqs args
+                                                    _ -> evalError $ hang "Expected pattern macro:" 4
+                                                                          (pp t)
+    match env (PV v      :ps) eqs (arg:args) = match ((v,arg):env) ps eqs args
+    match env (PAs v p   :ps) eqs (arg:args) = match ((v,arg):env) (p:ps) eqs (arg:args)
+    match env (PW        :ps) eqs (arg:args) = match env ps eqs args
+    match env (PTilde _  :ps) eqs (arg:args) = match env ps eqs args
+    match env (p         :ps) eqs (arg:args) = do
+      v <- force arg
+      match' env p ps eqs arg v args
+
+    match' env p ps eqs arg v args = do
+      case (p,v) of
+        (p,       VMeta i   vs) -> susp i (\v -> apply v vs >>= \v -> match' env p ps eqs arg v args)
+        (p,       VGen  i   vs) -> return v0
+        (p,       VSusp i k vs) -> susp i (\v -> k v >>= \v -> apply v vs >>= \v -> match' env p ps eqs arg v args)
+        (PP q qs, VApp r tnks)
+          | q == r        -> match env (qs++ps) eqs (tnks++args)
+        (PR pas, VR as)   -> matchRec env (reverse pas) as ps eqs args
+        (PString s1, VStr s2)
+          | s1 == s2      -> match env ps eqs args
+        (PString s1, VEmpty)
+          | null s1       -> match env ps eqs args
+        (PSeq min1 max1 p1 min2 max2 p2,v)
+                          -> case value2string v of
+                               Const s -> do let n  = length s
+                                                 lo = min1 `max` (n-fromMaybe n max2)
+                                                 hi = (n-min2) `min` fromMaybe n max1
+                                                 (ds,cs) = splitAt lo s
+                                             eqs <- matchStr env (p1:p2:ps) eqs (hi-lo) (reverse ds) cs args
+                                             patternMatch v0 eqs
+                               RunTime -> return v0
+                               NonExist-> patternMatch v0 eqs
+        (PRep minp maxp p, v)
+                          -> case value2string v of
+                               Const s -> do let n = length s `div` (max minp 1)
+                                             eqs <- matchRep env n minp maxp p minp maxp p ps ((env,PString []:ps,(arg:args),t) : eqs) (arg:args)
+                                             patternMatch v0 eqs
+                               RunTime -> return v0
+                               NonExist-> patternMatch v0 eqs
+        (PChar, VStr [_]) -> match env ps eqs args
+        (PChars cs, VStr [c])
+          | elem c cs     -> match env ps eqs args
+        (PInt n, VInt m)
+          | n == m        -> match env ps eqs args
+        (PFloat n, VFlt m)
+          | n == m        -> match env ps eqs args
+        _                 -> patternMatch v0 eqs
+
+    matchRec env []            as ps eqs args = match env ps eqs args
+    matchRec env ((lbl,p):pas) as ps eqs args =
+      case lookup lbl as of
+        Just tnk -> matchRec env pas as (p:ps) eqs (tnk:args)
+        Nothing  -> evalError ("Missing value for label" <+> pp lbl)
+
+    matchStr env ps eqs i ds []     args = do
+      arg1 <- newEvaluatedThunk (string2value (reverse ds))
+      arg2 <- newEvaluatedThunk (string2value [])
+      return ((env,ps,arg1:arg2:args,t) : eqs)
+    matchStr env ps eqs 0 ds cs     args = do
+      arg1 <- newEvaluatedThunk (string2value (reverse ds))
+      arg2 <- newEvaluatedThunk (string2value cs)
+      return ((env,ps,arg1:arg2:args,t) : eqs)
+    matchStr env ps eqs i ds (c:cs) args = do
+      arg1 <- newEvaluatedThunk (string2value (reverse ds))
+      arg2 <- newEvaluatedThunk (string2value (c:cs))
+      eqs  <- matchStr env ps eqs (i-1 :: Int) (c:ds) cs args
+      return ((env,ps,arg1:arg2:args,t) : eqs)
+
+    matchRep env 0 minp maxp p minq maxq q ps eqs args = do
+      return eqs
+    matchRep env n minp maxp p minq maxq q ps eqs args = do
+      matchRep env (n-1) minp maxp p (minp+minq) (liftM2 (+) maxp maxq) (PSeq minp maxp p minq maxq q) ps ((env,q:ps,args,t) : eqs) args
+
+
+vtableSelect v0 ty tnks tnk2 vs = do
+  v2 <- force tnk2
+  (i,_) <- value2index v2 ty
+  v <- force (tnks !! i)
+  apply v vs
+  where
+    value2index (VR as) (RecType lbls) = compute lbls
+      where
+        compute []              = return (0,1)
+        compute ((lbl,ty):lbls) = do
+          case lookup lbl as of
+            Just tnk -> do v <- force tnk
+                           (r, cnt ) <- value2index v ty
+                           (r',cnt') <- compute lbls
+                           return (r*cnt'+r',cnt*cnt')
+            Nothing  -> evalError ("Missing value for label" <+> pp lbl $$
+                                   "among" <+> hsep (punctuate (pp ',') (map fst as)))
+    value2index (VApp q tnks) ty = do
+      (r ,ctxt,cnt ) <- getIdxCnt q
+      (r',     cnt') <- compute ctxt tnks
+      return (r+r',cnt)
+      where
+        getIdxCnt q = do
+          (_,ResValue (L _ ty) idx) <- getInfo q
+          let (ctxt,QC p) = typeFormCnc ty
+          (_,ResParam _ (Just (_,cnt))) <- getInfo p
+          return (idx,ctxt,cnt)
+
+        compute []              []         = return (0,1)
+        compute ((_,_,ty):ctxt) (tnk:tnks) = do
+          v <- force tnk
+          (r, cnt ) <- value2index v ty
+          (r',cnt') <- compute ctxt tnks
+          return (r*cnt'+r',cnt*cnt')
+    value2index (VInt n)          ty
+      | Just max <- isTypeInts ty    = return (fromIntegral n,fromIntegral max+1)
+    value2index (VMeta i vs) ty = do
+      v <- susp i (\v -> apply v vs)
+      value2index v ty
+    value2index (VSusp i k vs) ty = do
+      v <- susp i (\v -> k v >>= \v -> apply v vs)
+      value2index v ty
+    value2index v ty = do t <- value2term [] v
+                          evalError ("the parameter:" <+> ppTerm Unqualified 0 t $$
+                                     "cannot be evaluated at compile time.")
+
+
+susp i ki = EvalM $ \gr k mt d r msgs -> do
+  s <- readSTRef i
+  case s of
+    Narrowing id (QC q) -> case lookupOrigInfo gr q of
+                             Ok (m,ResParam (Just (L _ ps)) _) -> bindParam gr k mt d r msgs s m ps
+                             Bad msg -> return (Fail (pp msg) msgs)
+    Narrowing id ty
+      | Just max <- isTypeInts ty
+                        -> bindInt gr k mt d r msgs s 0 max
+    Evaluated _ v       -> case ki v of
+                             EvalM f -> f gr k mt d r msgs
+    _                   -> k (VSusp i ki []) mt d r msgs
+  where
+    bindParam gr k mt d r msgs s m []             = return (Success r msgs)
+    bindParam gr k mt d r msgs s m ((p, ctxt):ps) = do
+      (mt',tnks) <- mkArgs mt ctxt
+      let v = VApp (m,p) tnks
+      writeSTRef i (Evaluated 0 v)
+      res <- case ki v of
+               EvalM f -> f gr k mt' d r msgs
+      writeSTRef i s
+      case res of
+        Fail msg  msgs -> return (Fail msg msgs)
+        Success r msgs -> bindParam gr k mt d r msgs s m ps
+
+    mkArgs mt []              = return (mt,[])
+    mkArgs mt ((_,_,ty):ctxt) = do
+      let i = case Map.maxViewWithKey mt of
+                Just ((i,_),_) -> i+1
+                _              -> 0
+      tnk  <- newSTRef (Narrowing i ty)
+      (mt,tnks) <- mkArgs (Map.insert i tnk mt) ctxt
+      return (mt,tnk:tnks)
+
+    bindInt gr k mt d r msgs s iv max
+      | iv <= max = do
+         let v = VInt iv
+         writeSTRef i (Evaluated 0 v)
+         res <- case ki v of
+                  EvalM f -> f gr k mt d r msgs
+         writeSTRef i s
+         case res of
+           Fail msg  msgs -> return (Fail msg msgs)
+           Success r msgs -> bindInt gr k mt d r msgs s (iv+1) max
+      | otherwise = return (Success r msgs)
+
+
+value2term xs (VApp q tnks) =
+  foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (if fst q == cPredef then Q q else QC q) tnks
+value2term xs (VMeta m vs) = do
+  s <- getRef m
+  case s of
+    Evaluated _ v       -> do v <- apply v vs
+                              value2term xs v
+    Unevaluated env t   -> do v <- eval env t vs
+                              value2term xs v
+    Hole i              -> foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (Meta i) vs
+    Residuation i _ ctr -> case ctr of
+                             Just ctr -> value2term xs ctr
+                             Nothing  -> foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (Meta i) vs
+    Narrowing i _       -> foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (Meta i) vs
+value2term xs (VSusp j k vs) = do
+  v <- k (VGen maxBound vs)
+  value2term xs v
+value2term xs (VGen j tnks) =
+  foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (Vr (reverse xs !! j)) tnks
+value2term xs (VClosure env (Abs b x t)) = do
+  tnk <- newEvaluatedThunk (VGen (length xs) [])
+  v <- eval ((x,tnk):env) t []
+  let x' = mkFreshVar xs x
+  t <- value2term (x':xs) v
+  return (Abs b x' t)
+value2term xs (VProd b x v1 v2)
+  | x == identW = do t1 <- value2term xs v1
+                     v2 <- case v2 of
+                             VClosure env t2 -> eval env t2 []
+                             v2              -> return v2
+                     t2 <- value2term xs v2
+                     return (Prod b x t1 t2)
+  | otherwise   = do t1 <- value2term xs v1
+                     tnk <- newEvaluatedThunk (VGen (length xs) [])
+                     v2 <- case v2 of
+                             VClosure env t2 -> eval ((x,tnk):env) t2 []
+                             v2              -> return v2
+                     t2 <- value2term (x:xs) v2
+                     return (Prod b (mkFreshVar xs x) t1 t2)
+value2term xs (VRecType lbls) = do
+  lbls <- mapM (\(lbl,v) -> fmap ((,) lbl) (value2term xs v)) lbls
+  return (RecType lbls)
+value2term xs (VR as) = do
+  as <- mapM (\(lbl,tnk) -> fmap (\t -> (lbl,(Nothing,t))) (tnk2term xs tnk)) as
+  return (R as)
+value2term xs (VP v lbl tnks) = do
+  t <- value2term xs v
+  foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (P t lbl) tnks
+value2term xs (VExtR v1 v2) = do
+  t1 <- value2term xs v1
+  t2 <- value2term xs v2
+  return (ExtR t1 t2) 
+value2term xs (VTable v1 v2) = do
+  t1 <- value2term xs v1
+  t2 <- value2term xs v2
+  return (Table t1 t2)
+value2term xs (VT vty env cs)= do
+  ty <- value2term xs vty
+  cs <- forM cs $ \(p,t) -> do
+          (_,xs',env') <- pattVars (length xs,xs,env) p
+          v <- eval env' t []
+          t <- value2term xs' v
+          return (p,t)
+  return (T (TTyped ty) cs)
+value2term xs (VV vty tnks)= do ty <- value2term xs vty
+                                ts <- mapM (tnk2term xs) tnks
+                                return (V ty ts)
+value2term xs (VS v1 tnk2 tnks) = do t1 <- value2term xs v1
+                                     t2 <- tnk2term xs tnk2
+                                     foldM (\e1 tnk -> fmap (App e1) (tnk2term xs tnk)) (S t1 t2) tnks
+value2term xs (VSort s) = return (Sort s)
+value2term xs (VStr tok) = return (K tok)
+value2term xs (VInt n) = return (EInt n)
+value2term xs (VFlt n) = return (EFloat n)
+value2term xs VEmpty = return Empty
+value2term xs (VC v1 v2) = do
+  t1 <- value2term xs v1
+  t2 <- value2term xs v2
+  return (C t1 t2)
+value2term xs (VGlue v1 v2) = do
+  t1 <- value2term xs v1
+  t2 <- value2term xs v2
+  return (Glue t1 t2)
+value2term xs (VPatt min max p) = return (EPatt min max p)
+value2term xs (VPattType v) = do t <- value2term xs v
+                                 return (EPattType t)
+value2term xs (VAlts vd vas) = do
+  d <- value2term xs vd
+  as <- forM vas $ \(vt,vs) -> do
+           t <- value2term xs vt
+           s <- value2term xs vs
+           return (t,s)
+  return (Alts d as)
+value2term xs (VStrs vs) = do
+  ts <- mapM (value2term xs) vs
+  return (Strs ts)
+value2term xs (VCInts (Just i) Nothing) = return (App (Q (cPredef,cInts)) (EInt i))
+value2term xs (VCInts Nothing (Just j)) = return (App (Q (cPredef,cInts)) (EInt j))
+value2term xs (VCRecType lctrs) = do
+  ltys <- mapM (\(l,o,ctr) -> value2term xs ctr >>= \ty -> return (l,ty)) lctrs
+  return (RecType ltys)
+value2term xs (VSymCat d r rs) = return (TSymCat d r [(i,(identW,ty)) | (i,(_,ty)) <- rs])
+value2term xs v = error (showValue v)
+
+pattVars st (PP _ ps)    = foldM pattVars st ps
+pattVars st (PV x)       = case st of
+                             (i,xs,env) -> do tnk <- newEvaluatedThunk (VGen i [])
+                                              return (i+1,x:xs,(x,tnk):env)
+pattVars st (PR as)      = foldM (\st (_,p) -> pattVars st p) st as
+pattVars st (PT ty p)    = pattVars st p
+pattVars st (PAs x p)    = do st <- case st of
+                                      (i,xs,env) -> do tnk <- newEvaluatedThunk (VGen i [])
+                                                       return (i+1,x:xs,(x,tnk):env)
+                              pattVars st p
+pattVars st (PImplArg p) = pattVars st p
+pattVars st (PSeq _ _ p1 _ _ p2) = do st <- pattVars st p1
+                                      pattVars st p2
+pattVars st _            = return st
+
+data ConstValue a
+  = Const a
+  | RunTime
+  | NonExist
+
+instance Functor ConstValue where
+  fmap f (Const c) = Const (f c)
+  fmap f RunTime   = RunTime
+  fmap f NonExist  = NonExist
+
+instance Applicative ConstValue where
+  pure = Const
+
+  (Const f) <*> (Const x) = Const (f x)
+  NonExist  <*> _         = NonExist
+  _         <*> NonExist  = NonExist
+  RunTime   <*>  _        = RunTime
+  _         <*>  RunTime  = RunTime
+
+#if MIN_VERSION_base(4,10,0)
+  liftA2 f (Const a) (Const b) = Const (f a b)
+  liftA2 f NonExist  _         = NonExist
+  liftA2 f _         NonExist  = NonExist
+  liftA2 f RunTime   _         = RunTime
+  liftA2 f _         RunTime   = RunTime
+#endif
+
+value2string v = fmap (\(_,ws,_) -> unwords ws) (value2string' v False [] [])
+
+value2string' (VStr w1)   True (w2:ws) qs = Const (False,(w1++w2):ws,qs)
+value2string' (VStr w)    _    ws      qs = Const (False,w       :ws,qs)
+value2string' VEmpty      b    ws      qs = Const (b,ws,qs)
+value2string' (VC v1 v2)  b    ws      qs =
+  case value2string' v2 b ws qs of
+    Const (b,ws,qs) -> value2string' v1 b ws qs
+    res             -> res
+value2string' (VApp q []) b    ws      qs
+  | q == (cPredef,cNonExist)              = NonExist
+value2string' (VApp q []) b    ws      qs
+  | q == (cPredef,cSOFT_SPACE)            = if null ws
+                                              then Const (b,ws,q:qs)
+                                              else Const (b,ws,qs)
+value2string' (VApp q []) b     ws     qs
+  | q == (cPredef,cBIND) || q == (cPredef,cSOFT_BIND) 
+                                          = if null ws
+                                              then Const (True,ws,q:qs)
+                                              else Const (True,ws,qs)
+value2string' (VApp q []) b     ws     qs
+  | q == (cPredef,cCAPIT) = capit ws
+  where
+    capit []            = Const (b,[],q:qs)
+    capit ((c:cs) : ws) = Const (b,(toUpper c : cs) : ws,qs)
+    capit ws            = Const (b,ws,qs)
+value2string' (VApp q []) b     ws     qs
+  | q == (cPredef,cALL_CAPIT) = all_capit ws
+  where
+    all_capit []       = Const (b,[],q:qs)
+    all_capit (w : ws) = Const (b,map toUpper w : ws,qs)
+value2string' (VAlts vd vas) b  ws     qs =
+  case ws of
+    []    -> value2string' vd b ws qs
+    (w:_) -> pre vd vas w b ws qs
+  where
+    pre vd []                 w            = value2string' vd
+    pre vd ((v,VStrs ss):vas) w
+      | or [startsWith s w | VStr s <- ss] = value2string' v
+      | otherwise                          = pre vd vas w
+value2string' _ _ _ _ = RunTime
+
+startsWith []          _ = True
+startsWith (x:xs) (y:ys)
+  | x == y               = startsWith xs ys
+startsWith      _      _ = False
+
+
+string2value s = string2value' (words s)
+
+string2value' []     = VEmpty
+string2value' [w]    = VStr w
+string2value' (w:ws) = VC (VStr w) (string2value' ws)
+
+value2int (VInt n) = Const n
+value2int _        = RunTime
+
+-----------------------------------------------------------------------
+-- * Evaluation monad
+
+type MetaThunks s = Map.Map MetaId (Thunk s)
+type Cont s r = MetaThunks s -> Int -> r -> [Message] -> ST s (CheckResult r [Message])
+newtype EvalM s a = EvalM (forall r . Grammar -> (a -> Cont s r) -> Cont s r)
+
+instance Functor (EvalM s) where
+  fmap f (EvalM g) = EvalM (\gr k -> g gr (k . f))
+
+instance Applicative (EvalM s) where
+  pure x = EvalM (\gr k -> k x)
+  (EvalM f) <*> (EvalM x) = EvalM (\gr k -> f gr (\f -> x gr (\x -> k (f x))))
+
+instance Monad (EvalM s) where
+  (EvalM f) >>= g = EvalM (\gr k -> f gr (\x -> case g x of
+                                                  EvalM g -> g gr k))
+#if !(MIN_VERSION_base(4,13,0))
+  -- Monad(fail) will be removed in GHC 8.8+
+  fail = Fail.fail
+#endif
+
+instance Fail.MonadFail (EvalM s) where
+  fail msg = EvalM (\gr k _ _ r msgs -> return (Fail (pp msg) msgs))
+
+instance Alternative (EvalM s) where
+  empty = EvalM (\gr k _ _ r msgs -> return (Success r msgs))
+  (EvalM f) <|> (EvalM g) = EvalM $ \gr k mt b r msgs -> do
+     res <- f gr k mt b r msgs
+     case res of
+       Fail msg  msgs -> return (Fail msg msgs)
+       Success r msgs -> g gr k mt b r msgs
+
+instance MonadPlus (EvalM s) where
+
+runEvalM :: Grammar -> (forall s . EvalM s a) -> Check [a]
+runEvalM gr f = Check $ \(es,ws) ->
+  case runST (case f of
+                EvalM f -> f gr (\x mt _ xs ws -> return (Success (x:xs) ws)) Map.empty maxBound [] ws) of
+    Fail msg   ws -> Fail msg (es,ws)
+    Success xs ws -> Success (reverse xs) (es,ws)
+
+runEvalOneM :: Grammar -> (forall s . EvalM s a) -> Check a
+runEvalOneM gr f = Check $ \(es,ws) ->
+  case runST (case f of
+                EvalM f -> f gr (\x mt _ xs ws -> return (Success (x:xs) ws)) Map.empty maxBound [] ws) of
+    Fail msg      ws -> Fail msg (es,ws)
+    Success []    ws -> Fail (pp "The evaluation produced no results") (es,ws)
+    Success (x:_) ws -> Success x (es,ws)
+
+evalError :: Message -> EvalM s a
+evalError msg = EvalM (\gr k _ _ r msgs -> return (Fail msg msgs))
+  
+evalWarn :: Message -> EvalM s ()
+evalWarn msg = EvalM (\gr k mt d r msgs -> k () mt d r (msg:msgs))
+
+getResDef :: QIdent -> EvalM s Term
+getResDef q = EvalM $ \gr k mt d r msgs -> do
+  case lookupResDef gr q of
+    Ok t    -> k t mt d r msgs
+    Bad msg -> return (Fail (pp msg) msgs)
+
+getInfo :: QIdent -> EvalM s (ModuleName,Info)
+getInfo q = EvalM $ \gr k mt d r msgs -> do
+  case lookupOrigInfo gr q of
+    Ok res  -> k res mt d r msgs
+    Bad msg -> return (Fail (pp msg) msgs)
+
+getResType :: QIdent -> EvalM s Type
+getResType q = EvalM $ \gr k mt d r msgs -> do
+  case lookupResType gr q of
+    Ok t    -> k t mt d r msgs
+    Bad msg -> return (Fail (pp msg) msgs)
+
+getOverload :: Term -> QIdent -> EvalM s (Term,Type)
+getOverload t q = EvalM $ \gr k mt d r msgs -> do
+  case lookupOverloadTypes gr q of
+    Ok ttys -> let err = "Overload resolution failed" $$
+                         "of term   " <+> pp t $$
+                         "with types" <+> vcat [ppTerm Terse 0 ty | (_,ty) <- ttys]
+
+                   go []         = return (Fail err msgs)
+                   go (tty:ttys) = do res <- k tty mt d r msgs
+                                      case res of
+                                        Fail _ _       -> return res -- go ttys
+                                        Success r msgs -> return (Success r msgs)
+
+               in go ttys
+    Bad msg -> return (Fail (pp msg) msgs)
+
+getAllParamValues :: Type -> EvalM s [Term]
+getAllParamValues ty = EvalM $ \gr k mt d r msgs ->
+  case allParamValues gr ty of
+    Ok ts   -> k ts mt d r msgs
+    Bad msg -> return (Fail (pp msg) msgs)
+
+newThunk env t = EvalM $ \gr k mt d r msgs -> do
+ tnk <- newSTRef (Unevaluated env t)
+ k tnk mt d r msgs
+
+newEvaluatedThunk v = EvalM $ \gr k mt d r msgs -> do
+ tnk <- newSTRef (Evaluated maxBound v)
+ k tnk mt d r msgs
+
+newHole i = EvalM $ \gr k mt d r msgs ->
+  if i == 0
+    then do tnk <- newSTRef (Hole i)
+            k tnk mt d r msgs
+    else case Map.lookup i mt of
+           Just tnk -> k tnk mt d r msgs
+           Nothing  -> do tnk <- newSTRef (Hole i)
+                          k tnk (Map.insert i tnk mt) d r msgs
+
+newResiduation scope = EvalM $ \gr k mt d r msgs -> do
+  let i = Map.size mt + 1
+  tnk <- newSTRef (Residuation i scope Nothing)
+  k (i,tnk) (Map.insert i tnk mt) d r msgs
+
+newNarrowing ty = EvalM $ \gr k mt d r msgs -> do
+  let i = Map.size mt + 1
+  tnk <- newSTRef (Narrowing i ty)
+  k (i,tnk) (Map.insert i tnk mt) d r msgs
+
+withVar d0 (EvalM f) = EvalM $ \gr k mt d1 r msgs ->
+                                  let !d = min d0 d1
+                                  in f gr k mt d r msgs
+
+getVariables :: EvalM s [(LVar,LIndex)]
+getVariables = EvalM $ \gr k mt d ws r -> do
+  ps <- metas2params gr (Map.elems mt)
+  k ps mt d ws r
+  where
+    metas2params gr []         = return []
+    metas2params gr (tnk:tnks) = do
+      st <- readSTRef tnk
+      case st of
+        Narrowing i ty -> do let cnt = case allParamValues gr ty of
+                                         Ok ts   -> length ts
+                                         Bad msg -> error msg
+                             params <- metas2params gr tnks
+                             if cnt > 1
+                               then return ((i-1,cnt):params)
+                               else return params
+        _              -> metas2params gr tnks
+
+getRef tnk = EvalM $ \gr k mt d r msgs -> readSTRef tnk >>= \st -> k st mt d r msgs
+setRef tnk st = EvalM $ \gr k mt d r msgs -> do
+  old <- readSTRef tnk
+  writeSTRef tnk st
+  res <- k () mt d r msgs
+  writeSTRef tnk old
+  return res
+
+force tnk = EvalM $ \gr k mt d r msgs -> do
+  s <- readSTRef tnk
+  case s of
+    Unevaluated env t -> case eval env t [] of
+                           EvalM f -> f gr (\v mt b r msgs -> do let d = length env
+                                                                 writeSTRef tnk (Evaluated d v)
+                                                                 r <- k v mt d r msgs
+                                                                 writeSTRef tnk s
+                                                                 return r) mt d r msgs
+    Evaluated d v     -> k v mt d r msgs
+    Hole _            -> k (VMeta tnk []) mt d r msgs
+    Residuation _ _ _ -> k (VMeta tnk []) mt d r msgs
+    Narrowing _ _     -> k (VMeta tnk []) mt d r msgs
+
+tnk2term xs tnk = EvalM $ \gr k mt d r msgs ->
+  let join f g = do res <- f
+                    case res of
+                      Fail msg  msgs -> return (Fail msg msgs)
+                      Success r msgs -> g r msgs
+
+      flush []  k1 mt r msgs = k1 mt r msgs
+      flush [x] k1 mt r msgs = join (k x mt d r msgs) (k1 mt)
+      flush xs  k1 mt r msgs = join (k (FV (reverse xs)) mt d r msgs) (k1 mt)
+
+      acc d0 x mt d (r,!c,xs) msgs
+        | d < d0    = flush xs (\mt r msgs -> join (k x mt d r msgs) (\r msgs -> return (Success (r,c+1,[]) msgs))) mt r msgs
+        | otherwise = return (Success (r,c+1,x:xs) msgs)
+
+  in do s <- readSTRef tnk
+        case s of
+          Unevaluated env t -> do let d0 = length env
+                                  res <- case eval env t [] of
+                                           EvalM f -> f gr (\v mt d msgs r -> do writeSTRef tnk (Evaluated d0 v)
+                                                                                 r <- case value2term xs v of
+                                                                                        EvalM f -> f gr (acc d0) mt d msgs r
+                                                                                 writeSTRef tnk s
+                                                                                 return r) mt maxBound (r,0,[]) msgs
+                                  case res of
+                                    Fail msg msgs         -> return (Fail msg msgs)
+                                    Success (r,0,xs) msgs -> k (FV []) mt d r msgs
+                                    Success (r,c,xs) msgs -> flush xs (\mt msgs r -> return (Success msgs r)) mt r msgs
+          Evaluated d0 v    -> do res <- case value2term xs v of
+                                           EvalM f -> f gr (acc d0) mt maxBound (r,0,[]) msgs
+                                  case res of
+                                    Fail msg msgs         -> return (Fail msg msgs)
+                                    Success (r,0,xs) msgs -> k (FV []) mt d r msgs
+                                    Success (r,c,xs) msgs -> flush xs (\mt r msgs -> return (Success r msgs)) mt r msgs
+          Hole i            -> k (Meta i) mt d r msgs
+          Residuation i _ _ -> k (Meta i) mt d r msgs
+          Narrowing i _     -> k (Meta i) mt d r msgs
+
+scopeEnv   scope = zipWithM (\x i -> newEvaluatedThunk (VGen i []) >>= \tnk -> return (x,tnk)) (reverse scope) [0..]

src/compiler/api/GF/Compile/ConcreteToHaskell.hs

@@ -0,0 +1,417 @@
+-- | Translate concrete syntax to Haskell
+module GF.Compile.ConcreteToHaskell(concretes2haskell,concrete2haskell) where
+
+import PGF2(Literal(..))
+import Data.List(isPrefixOf,sort,sortOn)
+import qualified Data.Map as M
+import qualified Data.Set as S
+import GF.Text.Pretty
+--import GF.Grammar.Predef(cPredef,cInts)
+--import GF.Compile.Compute.Predef(predef)
+--import GF.Compile.Compute.Value(Predefined(..))
+import GF.Infra.Ident(Ident,identC,identS,identW,prefixIdent,showRawIdent,rawIdentS)
+import GF.Infra.Option
+import GF.Haskell as H
+import GF.Grammar.Canonical as C
+import GF.Compile.GrammarToCanonical
+import Debug.Trace(trace)
+
+-- | Generate Haskell code for the all concrete syntaxes associated with
+-- the named abstract syntax in given the grammar.
+concretes2haskell opts absname gr = do
+  Grammar abstr cncs <- grammar2canonical opts absname gr
+  return [(filename,render80 $ concrete2haskell opts abstr cncmod)
+             | cncmod<-cncs,
+               let ModId name = concName cncmod
+                   filename = showRawIdent name ++ ".hs" :: FilePath
+         ]
+
+-- | Generate Haskell code for the given concrete module.
+-- The only options that make a difference are
+-- @-haskell=noprefix@ and @-haskell=variants@.
+concrete2haskell opts
+                 abstr@(Abstract _ _ cats funs)
+                 modinfo@(Concrete cnc absname _ ps lcs lns) =
+  haskPreamble absname cnc $$
+  vcat (
+    nl:Comment "--- Parameter types ---":
+    map paramDef ps ++
+    nl:Comment "--- Type signatures for linearization functions ---":
+    map signature cats ++
+    nl:Comment "--- Linearization functions for empty categories ---":
+    emptydefs ++
+    nl:Comment "--- Linearization types ---":
+    map lincatDef lcs ++
+    nl:Comment "--- Linearization functions ---":
+    lindefs ++
+    nl:Comment "--- Type classes for projection functions ---":
+    map labelClass (S.toList labels) ++
+    nl:Comment "--- Record types ---":
+    concatMap recordType recs)
+  where
+    nl = Comment ""
+    recs = S.toList (S.difference (records (lcs,lns)) common_records)
+
+    labels = S.difference (S.unions (map S.fromList recs)) common_labels
+    common_records = S.fromList [[label_s]]
+    common_labels = S.fromList [label_s]
+    label_s = LabelId (rawIdentS "s")
+
+    signature (CatDef c _) = TypeSig lf (Fun abs (pure lin))
+      where
+        abs = tcon0 (prefixIdent "A." (gId c))
+        lin = tcon0 lc
+        lf = linfunName c
+        lc = lincatName c
+
+    emptydefs = map emptydef (S.toList emptyCats)
+    emptydef c = Eqn (linfunName c,[WildP]) (Const "undefined")
+
+    emptyCats = allcats `S.difference` linfuncats
+      where
+     --funcats = S.fromList [c | FunDef f (C.Type _ (TypeApp c _))<-funs]
+       allcats = S.fromList [c | CatDef c _<-cats]
+
+    gId :: ToIdent i => i -> Ident
+    gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G")
+          . toIdent
+
+    va = haskellOption opts HaskellVariants
+    pure = if va then ListT else id
+
+    haskPreamble :: ModId -> ModId -> Doc
+    haskPreamble absname cncname =
+      "{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}" $$
+      "module" <+> cncname <+> "where" $$
+      "import Prelude hiding (Ordering(..))" $$
+      "import Control.Applicative((<$>),(<*>))" $$
+      "import PGF.Haskell" $$
+      "import qualified" <+> absname <+> "as A" $$
+      "" $$
+      "--- Standard definitions ---" $$
+      "linString (A.GString s) ="<+>pure "R_s [TK s]" $$
+      "linInt (A.GInt i) ="<+>pure "R_s [TK (show i)]" $$
+      "linFloat (A.GFloat x) ="<+>pure "R_s [TK (show x)]" $$
+      "" $$
+      "----------------------------------------------------" $$
+      "-- Automatic translation from GF to Haskell follows" $$
+      "----------------------------------------------------"
+      where
+        pure = if va then brackets else pp
+
+    paramDef pd =
+      case pd of
+        ParamAliasDef p t -> H.Type (conap0 (gId p)) (convLinType t)
+        ParamDef p pvs -> Data (conap0 (gId p)) (map paramCon pvs) derive
+          where
+            paramCon (Param c cs) = ConAp (gId c) (map (tcon0.gId) cs)
+            derive = ["Eq","Ord","Show"]
+
+    convLinType = ppT
+      where
+        ppT t =
+          case t of
+            FloatType -> tcon0 (identS "Float")
+            IntType -> tcon0 (identS "Int")
+            ParamType (ParamTypeId p) -> tcon0 (gId p)
+            RecordType rs -> tcon (rcon' ls) (map ppT ts)
+              where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-rs]
+            StrType -> tcon0 (identS "Str")
+            TableType pt lt -> Fun (ppT pt) (ppT lt)
+--          TupleType lts ->
+
+    lincatDef (LincatDef c t) = tsyn0 (lincatName c) (convLinType t)
+
+    linfuncats = S.fromList linfuncatl
+    (linfuncatl,lindefs) = unzip (linDefs lns)
+
+    linDefs = map eqn . sortOn fst . map linDef
+      where eqn (cat,(f,(ps,rhs))) = (cat,Eqn (f,ps) rhs)
+
+    linDef (LinDef f xs rhs0) =
+        (cat,(linfunName cat,(lhs,rhs)))
+      where
+        lhs = [ConP (aId f) (map VarP abs_args)]
+        aId f = prefixIdent "A." (gId f)
+
+        [lincat] = [lincat | LincatDef c lincat<-lcs,c==cat]
+        [C.Type absctx (TypeApp cat _)] = [t | FunDef f' t<-funs, f'==f]
+
+        abs_args = map abs_arg args
+        abs_arg = prefixIdent "abs_"
+        args = map (prefixIdent "g" . toIdent) xs
+
+        rhs = lets (zipWith letlin args absctx)
+                   (convert vs (coerce env lincat rhs0))
+          where
+            vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args]
+            env= [(VarValueId (Unqual x),lc)|(VarId x,lc)<-zip xs (map arglincat absctx)]
+
+        letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) =
+          (a,Ap (Var (linfunName acat)) (Var (abs_arg a)))
+
+        arglincat (TypeBinding _ (C.Type _ (TypeApp acat _))) = lincat
+          where
+            [lincat] = [lincat | LincatDef c lincat<-lcs,c==acat]
+
+    convert = convert' va
+
+    convert' va vs = ppT
+      where
+        ppT0 = convert' False vs
+        ppTv vs' = convert' va vs'
+
+        pure = if va then single else id
+
+        ppT t =
+          case t of
+            TableValue ty cs -> pure (table cs)
+            Selection t p -> select (ppT t) (ppT p)
+            ConcatValue t1 t2 -> concat (ppT t1) (ppT t2)
+            RecordValue r -> aps (rcon ls) (map ppT ts)
+              where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-r]
+            PredefValue p -> single (Var (toIdent p)) -- hmm
+            Projection t l -> ap (proj l) (ppT t)
+            VariantValue [] -> empty
+            VariantValue ts@(_:_) -> variants ts
+            VarValue x -> maybe (Var (gId x)) (pure . Var) $ lookup x vs
+            PreValue vs t' -> pure (alts t' vs)
+            ParamConstant (Param c vs) -> aps (Var (pId c)) (map ppT vs)
+            ErrorValue s -> ap (Const "error") (Const (show s)) -- !!
+            LiteralValue l -> ppL l
+            _ -> error ("convert "++show t)
+
+        ppL l =
+          case l of
+            LFlt x -> pure (lit x)
+            LInt n -> pure (lit n)
+            LStr s -> pure (token s)
+
+        pId p@(ParamId s) =
+          if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack
+
+        table cs =
+            if all (null.patVars) ps
+            then lets ds (LambdaCase [(ppP p,t')|(p,t')<-zip ps ts'])
+            else LambdaCase (map ppCase cs)
+          where
+            (ds,ts') = dedup ts
+            (ps,ts) = unzip [(p,t)|TableRow p t<-cs]
+        ppCase (TableRow p t) = (ppP p,ppTv (patVars p++vs) t)
+{-
+        ppPredef n =
+          case predef n of
+            Ok BIND       -> single (c "BIND")
+            Ok SOFT_BIND  -> single (c "SOFT_BIND")
+            Ok SOFT_SPACE -> single (c "SOFT_SPACE")
+            Ok CAPIT      -> single (c "CAPIT")
+            Ok ALL_CAPIT  -> single (c "ALL_CAPIT")
+            _ -> Var n
+-}
+        ppP p =
+          case p of
+            ParamPattern (Param c ps) -> ConP (gId c) (map ppP ps)
+            RecordPattern r -> ConP (rcon' ls) (map ppP ps)
+              where (ls,ps) = unzip $ sortOn fst [(l,p)|RecordRow l p<-r]
+            WildPattern -> WildP
+
+        token s = single (c "TK" `Ap` lit s)
+
+        alts t' vs = single (c "TP" `Ap` List (map alt vs) `Ap` ppT0 t')
+          where
+            alt (s,t) = Pair (List (pre s)) (ppT0 t)
+            pre s = map lit s
+
+        c = Const
+        lit s = c (show s) -- hmm
+        concat = if va then concat' else plusplus
+          where
+            concat' (List [List ts1]) (List [List ts2]) = List [List (ts1++ts2)]
+            concat' t1 t2 = Op t1 "+++" t2
+
+        pure' = single -- forcing the list monad
+
+        select = if va then select' else Ap
+        select' (List [t]) (List [p]) = Op t "!" p
+        select' (List [t]) p = Op t "!$" p
+        select' t p = Op t "!*" p
+
+        ap = if va then ap' else Ap
+          where
+            ap' (List [f]) x = fmap f x
+            ap' f x = Op f "<*>" x
+            fmap f (List [x]) = pure' (Ap f x)
+            fmap f x = Op f "<$>" x
+
+    --  join = if va then join' else id
+        join' (List [x]) = x
+        join' x = c "concat" `Ap` x
+
+        empty = if va then List [] else c "error" `Ap` c (show "empty variant")
+        variants = if va then \ ts -> join' (List (map ppT ts))
+                         else \ (t:_) -> ppT t
+
+        aps f [] = f
+        aps f (a:as) = aps (ap f a) as
+
+        dedup ts =
+            if M.null dups
+            then ([],map ppT ts)
+            else ([(ev i,ppT t)|(i,t)<-defs],zipWith entry ts is)
+          where
+            entry t i = maybe (ppT t) (Var . ev) (M.lookup i dups)
+            ev i = identS ("e'"++show i)
+
+            defs = [(i1,t)|(t,i1:_:_)<-ms]
+            dups = M.fromList [(i2,i1)|(_,i1:is@(_:_))<-ms,i2<-i1:is]
+            ms = M.toList m
+            m = fmap sort (M.fromListWith (++) (zip ts [[i]|i<-is]))
+            is = [0..]::[Int]
+
+
+--con = Cn . identS
+
+class Records t where
+  records :: t -> S.Set [LabelId]
+
+instance Records t => Records [t] where
+  records = S.unions . map records
+
+instance (Records t1,Records t2) => Records (t1,t2) where
+  records (t1,t2) = S.union (records t1) (records t2)
+
+instance Records LincatDef where
+  records (LincatDef _ lt) = records lt
+
+instance Records LinDef where
+  records (LinDef _ _ lv) = records lv
+
+instance Records LinType where
+  records t =
+    case t of
+      RecordType r -> rowRecords r
+      TableType pt lt -> records (pt,lt)
+      TupleType ts -> records ts
+      _ -> S.empty
+
+rowRecords r = S.insert (sort ls) (records ts)
+  where (ls,ts) = unzip [(l,t)|RecordRow l t<-r]
+
+instance Records LinValue where
+  records v =
+    case v of
+      ConcatValue v1 v2 -> records (v1,v2)
+      ParamConstant (Param c vs) -> records vs
+      RecordValue r -> rowRecords r
+      TableValue t r -> records (t,r)
+      TupleValue vs -> records vs
+      VariantValue vs -> records vs
+      PreValue alts d -> records (map snd alts,d)
+      Projection v l -> records v
+      Selection v1 v2 -> records (v1,v2)
+      _ -> S.empty
+
+instance Records rhs => Records (TableRow rhs) where
+  records (TableRow _ v) = records v
+
+
+-- | Record subtyping is converted into explicit coercions in Haskell
+coerce env ty t =
+  case (ty,t) of
+    (_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
+    (TableType ti tv,TableValue _ cs) ->
+      TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs]
+    (RecordType rt,RecordValue r) ->
+      RecordValue [RecordRow l (coerce env ft f) |
+                     RecordRow l f<-r,ft<-[ft | RecordRow l' ft <- rt, l'==l]]
+    (RecordType rt,VarValue x)->
+      case lookup x env of
+        Just ty' | ty'/=ty -> -- better to compare to normal form of ty'
+                            --trace ("coerce "++render ty'++" to "++render ty) $
+                            app (to_rcon rt) [t]
+                 | otherwise -> t -- types match, no coercion needed
+        _ -> trace (render ("missing type to coerce"<+>x<+>"to"<+>render ty
+                            $$ "in" <+> map fst env))
+                   t
+    _ -> t
+  where
+    app f ts = ParamConstant (Param f ts) -- !! a hack
+    to_rcon = ParamId . Unqual . rawIdentS . to_rcon' . labels
+
+patVars p = []
+
+labels r = [l | RecordRow l _ <- r]
+
+proj = Var . identS . proj'
+proj' (LabelId l) = "proj_" ++ showRawIdent l
+rcon = Var . rcon'
+rcon' = identS . rcon_name
+rcon_name ls = "R"++concat (sort ['_':showRawIdent l | LabelId l <- ls])
+to_rcon' = ("to_"++) . rcon_name
+
+recordType ls =
+    Data lhs [app] ["Eq","Ord","Show"]:
+    enumAllInstance:
+    zipWith projection vs ls ++
+    [Eqn (identS (to_rcon' ls),[VarP r])
+         (foldl Ap (Var cn) [Var (identS (proj' l)) `Ap` Var r|l<-ls])]
+  where
+    r = identS "r"
+    cn = rcon' ls
+ -- Not all record labels are syntactically correct as type variables in Haskell
+ -- app = cn<+>ls
+    lhs = ConAp cn vs -- don't reuse record labels
+    app = fmap TId lhs
+    tapp = foldl TAp (TId cn) (map TId vs)
+    vs = [identS ('t':show i)|i<-[1..n]]
+    n = length ls
+
+    projection v l = Instance [] (TId name `TAp` tapp `TAp` TId v)
+                              [((prj,[papp]),Var v)]
+     where
+       name = identS ("Has_"++render l)
+       prj = identS (proj' l)
+       papp = ConP cn (map VarP vs)
+
+    enumAllInstance =
+       Instance ctx (tEnumAll `TAp` tapp)[(lhs0 "enumAll",enumCon cn n)]
+      where
+        ctx =  [tEnumAll `TAp` TId v|v<-vs]
+        tEnumAll = TId (identS "EnumAll")
+
+labelClass l =
+    Class [] (ConAp name [r,a]) [([r],[a])]
+          [(identS (proj' l),TId r `Fun` TId a)]
+  where
+    name = identS ("Has_"++render l)
+    r = identS "r"
+    a = identS "a"
+
+enumCon name arity =
+    if arity==0
+    then single (Var name)
+    else foldl ap (single (Var name)) (replicate arity (Const "enumAll"))
+  where
+    ap (List [f]) a = Op f "<$>" a
+    ap f a = Op f "<*>" a
+
+lincatName,linfunName :: CatId -> Ident
+lincatName c = prefixIdent "Lin" (toIdent c)
+linfunName c = prefixIdent "lin" (toIdent c)
+
+class ToIdent i where toIdent :: i -> Ident
+
+instance ToIdent ParamId where toIdent (ParamId q) = qIdentC q
+instance ToIdent PredefId where toIdent (PredefId s) = identC s
+instance ToIdent CatId   where toIdent (CatId s) = identC s
+instance ToIdent C.FunId where toIdent (FunId s) = identC s
+instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentC q
+
+qIdentC = identS . unqual
+
+unqual (Qual (ModId m) n) = showRawIdent m++"_"++ showRawIdent n
+unqual (Unqual n) = showRawIdent n
+
+instance ToIdent VarId where
+  toIdent Anonymous = identW
+  toIdent (VarId s) = identC s

src/compiler/api/GF/Compile/ExampleBased.hs

@@ -0,0 +1,70 @@
+module GF.Compile.ExampleBased (
+  parseExamplesInGrammar,
+  configureExBased
+  ) where
+
+import PGF2
+import Data.List
+
+parseExamplesInGrammar :: ExConfiguration -> FilePath -> IO (FilePath,[String])
+parseExamplesInGrammar conf file = do
+  src <- readFile file                             -- .gfe
+  let file' = take (length file - 3) file ++ "gf"  -- .gf
+  ws <- convertFile conf src file'
+  return (file',ws)
+
+convertFile :: ExConfiguration -> String -> FilePath -> IO [String]
+convertFile conf src file = do
+  writeFile file "" -- "-- created by example-based grammar writing in GF\n"
+  conv [] src
+ where
+  conv ws s = do
+    (cex,end) <- findExample s
+    if null end then return (nub (sort ws)) else do
+      ws2 <- convEx cex
+      conv (ws2 ++ ws) end
+  findExample s = case s of
+    '%':'e':'x':cs -> return $ getExample cs
+    c:cs -> appf [c] >> findExample cs
+    _ -> return (undefined,s)
+  getExample s = 
+    let 
+      (cat,exend) = break (=='"') s
+      (ex,   end) = break (=='"') (tail exend)
+    in ((unwords (words cat),ex), tail end)  -- quotes ignored
+  pgf = resource_pgf conf
+  lang = language conf 
+  convEx (cat,ex) = do
+    appn "("
+    let typ = maybe (error "no valid cat") id $ readType cat
+    ws <- case parse lang typ ex of
+      ParseFailed _ _ -> do
+        appv ("WARNING: cannot parse example " ++ ex) 
+        return []
+      ParseIncomplete ->
+        return []
+      ParseOk ts ->
+        case ts of
+          (t:tt) -> do
+            if null tt 
+              then return ()
+              else appv ("WARNING: ambiguous example " ++ ex) 
+            appn (printExp conf (fst t))
+            mapM_ (appn . ("  --- " ++) . printExp conf . fst) tt
+            appn ")" 
+            return [] 
+    return ws
+  appf = appendFile file
+  appn s = appf s >> appf "\n"
+  appv s = appn ("--- " ++ s) >> putStrLn s
+
+data ExConfiguration = ExConf {
+  resource_pgf :: PGF,
+  verbose  :: Bool,
+  language :: Concr,
+  printExp :: Expr -> String
+  }
+
+configureExBased :: PGF -> Concr -> (Expr -> String) -> ExConfiguration
+configureExBased pgf concr pr = ExConf pgf False concr pr
+

src/compiler/api/GF/Compile/Export.hs

@@ -0,0 +1,61 @@
+module GF.Compile.Export where
+
+import PGF2
+import GF.Compile.PGFtoHaskell
+--import GF.Compile.PGFtoAbstract
+import GF.Compile.PGFtoJava
+import GF.Infra.Option
+--import GF.Speech.CFG
+import GF.Speech.PGFToCFG
+import GF.Speech.SRGS_ABNF
+import GF.Speech.SRGS_XML
+import GF.Speech.JSGF
+import GF.Speech.GSL
+import GF.Speech.SRG
+import GF.Speech.VoiceXML
+import GF.Speech.SLF
+import GF.Speech.PrRegExp
+
+import Data.Maybe
+import qualified Data.Map as Map
+import System.FilePath
+import GF.Text.Pretty
+
+-- top-level access to code generation
+
+-- | Export a PGF to the given 'OutputFormat'. For many output formats,
+-- additional 'Options' can be used to control the output.
+exportPGF :: Options
+          -> OutputFormat 
+          -> PGF 
+          -> [(FilePath,String)] -- ^ List of recommended file names and contents.
+exportPGF opts fmt pgf = 
+    case fmt of
+      FmtPGFPretty    -> multi "txt" (showPGF)
+      FmtCanonicalGF  -> [] -- canon "gf" (render80 . abstract2canonical)
+      FmtCanonicalJson-> []
+      FmtHaskell      -> multi "hs"  (grammar2haskell opts name)
+      FmtJava         -> multi "java" (grammar2java opts name)
+      FmtBNF          -> single "bnf"   bnfPrinter
+      FmtEBNF         -> single "ebnf"  (ebnfPrinter opts)
+      FmtSRGS_XML     -> single "grxml" (srgsXmlPrinter opts)
+      FmtSRGS_XML_NonRec -> single "grxml" (srgsXmlNonRecursivePrinter opts)
+      FmtSRGS_ABNF    -> single "gram" (srgsAbnfPrinter opts)
+      FmtSRGS_ABNF_NonRec -> single "gram" (srgsAbnfNonRecursivePrinter opts)
+      FmtJSGF         -> single "jsgf"  (jsgfPrinter opts)
+      FmtGSL          -> single "gsl"   (gslPrinter opts)
+      FmtVoiceXML     -> single "vxml"  grammar2vxml
+      FmtSLF          -> single "slf"  slfPrinter
+      FmtRegExp       -> single "rexp" regexpPrinter
+      FmtFA           -> single "dot"  slfGraphvizPrinter
+      FmtLR           -> single "dot"  (\_ -> graphvizLRAutomaton)
+ where
+   name = fromMaybe (abstractName pgf) (flag optName opts)
+
+   multi :: String -> (PGF -> String) -> [(FilePath,String)]
+   multi ext pr = [(name <.> ext, pr pgf)]
+
+-- canon ext pr = [("canonical"</>name<.>ext,pr pgf)]
+
+   single :: String -> (PGF -> Concr -> String) -> [(FilePath,String)]
+   single ext pr = [(concreteName cnc <.> ext, pr pgf cnc) | cnc <- Map.elems (languages pgf)]

src/compiler/api/GF/Compile/GenerateBC.hs

@@ -0,0 +1,302 @@
+{-# LANGUAGE CPP #-}
+module GF.Compile.GenerateBC(generateByteCode) where
+
+import GF.Grammar
+import GF.Grammar.Lookup(lookupAbsDef,lookupFunType)
+import GF.Data.Operations
+import PGF2(Literal(..))
+import PGF2.ByteCode
+import qualified Data.Map as Map
+import Data.List(nub,mapAccumL)
+import Data.Maybe(fromMaybe)
+
+generateByteCode :: SourceGrammar -> Int -> [L Equation] -> [[Instr]]
+generateByteCode gr arity eqs =
+  let (bs,instrs) = compileEquations gr arity (arity+1) is 
+                                     (map (\(L _ (ps,t)) -> ([],ps,t)) eqs) 
+                                     Nothing
+                                     [b]
+      b = if arity == 0 || null eqs
+            then instrs
+            else CHECK_ARGS arity:instrs
+  in reverse bs
+  where
+    is = push_is (arity-1) arity []
+
+compileEquations :: SourceGrammar -> Int -> Int -> [IVal] -> [([(Ident,IVal)],[Patt],Term)] -> Maybe (Int,CodeLabel) -> [[Instr]] -> ([[Instr]],[Instr])
+compileEquations gr arity st _      []        fl bs = (bs,mkFail arity st fl)
+compileEquations gr arity st [] ((vs,[],t):_) fl bs = compileBody gr arity st vs t bs
+compileEquations gr arity st (i:is) eqs       fl bs = whilePP eqs Map.empty
+  where
+    whilePP []                           cns = case Map.toList cns of
+                                                 []       -> (bs,[FAIL])
+                                                 (cn:cns) -> let (bs1,instrs1) = compileBranch0 fl bs cn
+                                                                 bs2 = foldl (compileBranch fl) bs1 cns
+                                                                 bs3 = mkFail arity st fl : bs2
+                                                             in (bs3,[PUSH_FRAME, EVAL (shiftIVal (st+2) i) RecCall] ++ instrs1)
+    whilePP ((vs, PP c ps' : ps, t):eqs) cns = whilePP eqs (Map.insertWith (++) (Q c,length ps') [(vs,ps'++ps,t)] cns)
+    whilePP ((vs, PInt n   : ps, t):eqs) cns = whilePP eqs (Map.insertWith (++) (EInt n,0) [(vs,ps,t)] cns)
+    whilePP ((vs, PString s: ps, t):eqs) cns = whilePP eqs (Map.insertWith (++) (K s,0) [(vs,ps,t)] cns)
+    whilePP ((vs, PFloat d : ps, t):eqs) cns = whilePP eqs (Map.insertWith (++) (EFloat d,0) [(vs,ps,t)] cns)
+    whilePP ((vs, PImplArg p:ps, t):eqs) cns = whilePP ((vs,p:ps,t):eqs) cns
+    whilePP ((vs, PT _ p   : ps, t):eqs) cns = whilePP ((vs,p:ps,t):eqs) cns
+    whilePP ((vs, PAs x p  : ps, t):eqs) cns = whilePP (((x,i):vs,p:ps,t):eqs) cns
+    whilePP eqs                          cns = case Map.toList cns of
+                                                 []       -> whilePV eqs []
+                                                 (cn:cns) -> let fl1 = Just (st,length bs2)
+                                                                 (bs1,instrs1) = compileBranch0 fl1 bs cn
+                                                                 bs2 = foldl (compileBranch fl1) bs1 cns
+                                                                 (bs3,instrs3) = compileEquations gr arity st (i:is) eqs fl (instrs3:bs2)
+                                                             in (bs3,[PUSH_FRAME, EVAL (shiftIVal (st+2) i) RecCall] ++ instrs1)
+
+    whilePV []                           vrs = compileEquations gr arity st is vrs fl bs
+    whilePV ((vs, PV x     : ps, t):eqs) vrs = whilePV eqs (((x,i):vs,ps,t) : vrs)
+    whilePV ((vs, PW       : ps, t):eqs) vrs = whilePV eqs ((      vs,ps,t) : vrs)
+    whilePV ((vs, PTilde _ : ps, t):eqs) vrs = whilePV eqs ((      vs,ps,t) : vrs)
+    whilePV ((vs, PImplArg p:ps, t):eqs) vrs = whilePV ((vs,p:ps,t):eqs) vrs
+    whilePV ((vs, PT _ p   : ps, t):eqs) vrs = whilePV ((vs,p:ps,t):eqs) vrs
+    whilePV eqs                          vrs = let fl1 = Just (st,length bs1)
+                                                   (bs1,instrs1) = compileEquations gr arity st is vrs fl1 bs
+                                                   (bs2,instrs2) = compileEquations gr arity st (i:is) eqs fl (instrs2:bs1)
+                                               in (bs2,instrs1)
+
+    case_instr t =
+      case t of
+        (Q (_,id)) -> CASE (showIdent id)
+        (EInt n)   -> CASE_LIT (LInt n)
+        (K s)      -> CASE_LIT (LStr s)
+        (EFloat d) -> CASE_LIT (LFlt d)
+
+    saves n = reverse [SAVE i | i <- [0..n-1]]
+
+    compileBranch0 fl bs ((t,n),eqs) =
+      let (bs1,instrs) = compileEquations gr arity (st+n) (push_is (st+n-1) n is) eqs fl bs
+      in (bs1, case_instr t (length bs1) : saves n ++ instrs)
+
+    compileBranch l bs ((t,n),eqs) =
+      let (bs1,instrs) = compileEquations gr arity (st+n) (push_is (st+n-1) n is) eqs fl ((case_instr t (length bs1) : saves n ++ instrs) : bs)
+      in bs1
+
+mkFail arity st1 Nothing
+  | arity+1 /= st1 = [DROP (st1-arity), FAIL]
+  | otherwise      = [FAIL]
+mkFail arity st1 (Just (st0,l))
+  | st1 /= st0     = [DROP (st1-st0), JUMP l]
+  | otherwise      = [JUMP l]
+
+compileBody gr arity st vs e bs =
+  let eval st fun args 
+        | arity == 0 = let (st1,is) = pushArgs (st+2) (reverse args)
+                           fun'     = shiftIVal st1 fun
+                       in [PUSH_FRAME]++is++[EVAL fun' UpdateCall]
+        | otherwise  = let (st1,fun',is) = tuckArgs arity st fun args
+                       in is++[EVAL fun' (TailCall (st1-length args-1))]
+      (heap,bs1,is) = compileFun gr eval st vs e 0 bs []
+  in (bs1,if heap > 0 then (ALLOC heap : is) else is)
+
+compileFun gr eval st vs (Abs _ x e) h0 bs args =
+  let (h1,bs1,arg,is1) = compileLambda gr st vs [x] e h0 bs
+  in (h1,bs1,is1++eval st arg args)
+compileFun gr eval st vs (App e1 e2) h0 bs args =
+  let (h1,bs1,arg,is1) = compileArg gr st vs e2 h0 bs
+      (h2,bs2,is2) = compileFun gr eval st vs e1 h1 bs1 (arg:args)
+  in (h2,bs2,is1++is2)
+compileFun gr eval st vs (Q (m,id))  h0 bs args =
+  case lookupAbsDef gr m id of
+    Ok (_,Just _)
+       -> (h0,bs,eval st (GLOBAL (showIdent id)) args)
+    _  -> let Ok ty = lookupFunType gr m id
+              (ctxt,_,_) = typeForm ty
+              c_arity    = length ctxt
+              n_args = length args
+              is1    = setArgs st args
+              diff   = c_arity-n_args
+          in if diff <= 0
+               then if n_args == 0
+                      then (h0,bs,eval st (GLOBAL (showIdent id)) [])
+                      else let h1  = h0 + 2 + n_args
+                           in (h1,bs,PUT_CONSTR (showIdent id):is1++eval st (HEAP h0) [])
+               else let h1  = h0 + 1 + n_args
+                        is2 = [SET (FREE_VAR i) | i <- [0..n_args-1]] ++ [SET (ARG_VAR (i+1)) | i <- [0..diff-1]]
+                        b   = CHECK_ARGS diff :
+                              ALLOC (c_arity+2) : 
+                              PUT_CONSTR (showIdent id) : 
+                              is2 ++
+                              TUCK (ARG_VAR 0) diff :
+                              EVAL (HEAP h0) (TailCall diff) :
+                              []
+                    in (h1,b:bs,PUT_CLOSURE (length bs):is1++eval st (HEAP h0) [])
+compileFun gr eval st vs (QC qid)    h0 bs args =
+  compileFun gr eval st vs (Q qid) h0 bs args
+compileFun gr eval st vs (Vr x)      h0 bs args =
+  (h0,bs,eval st (getVar vs x) args)
+compileFun gr eval st vs (EInt n)    h0 bs _  =
+  let h1 = h0 + 2
+  in (h1,bs,PUT_LIT (LInt n) : eval st (HEAP h0) [])
+compileFun gr eval st vs (K s)       h0 bs _  =
+  let h1 = h0 + 2
+  in (h1,bs,PUT_LIT (LStr s) : eval st (HEAP h0) [])
+compileFun gr eval st vs (EFloat d)  h0 bs _  =
+  let h1 = h0 + 2
+  in (h1,bs,PUT_LIT (LFlt d) : eval st (HEAP h0) [])
+compileFun gr eval st vs (Typed e _) h0 bs args =
+  compileFun gr eval st vs e h0 bs args
+compileFun gr eval st vs (Let (x, (_, e1)) e2) h0 bs args =
+  let (h1,bs1,arg,is1) = compileLambda gr st vs [] e1 h0 bs
+      (h2,bs2,is2) = compileFun gr eval st ((x,arg):vs) e2 h1 bs1 args
+  in (h2,bs2,is1++is2)
+compileFun gr eval st vs e@(Glue e1 e2) h0 bs args =
+  let eval' st fun args = [PUSH_FRAME]++is++[EVAL fun' RecCall]
+                          where
+                            (_st1,is) = pushArgs (st+2) (reverse args)
+                            fun'     = shiftIVal st fun
+
+      flatten (Glue e1 e2) h0 bs =
+        let (h1,bs1,is1) = flatten e1 h0 bs
+            (h2,bs2,is2) = flatten e2 h1 bs1
+        in (h2,bs2,is1++is2)
+      flatten e            h0 bs =
+        let (h1,bs1,is1) = compileFun gr eval' (st+3) vs e  h0 bs  args
+        in (h1,bs1,is1++[ADD])
+
+      (h1,bs1,is) = flatten e h0 bs
+
+  in (h1,bs1,[PUSH_ACCUM (LFlt 0)]++is++[POP_ACCUM]++eval (st+1) (ARG_VAR st) [])
+compileFun gr eval st vs e _ _ _ = error (show e)
+
+compileArg gr st vs (Q(m,id)) h0 bs =
+  case lookupAbsDef gr m id of
+    Ok (_,Just _) -> (h0,bs,GLOBAL (showIdent id),[])
+    _             -> let Ok ty = lookupFunType gr m id
+                         (ctxt,_,_) = typeForm ty
+                         c_arity    = length ctxt
+                     in if c_arity == 0
+                          then (h0,bs,GLOBAL (showIdent id),[])
+                          else let is2 = [SET (ARG_VAR (i+1)) | i <- [0..c_arity-1]]
+                                   b   = CHECK_ARGS c_arity :
+                                         ALLOC (c_arity+2) :
+                                         PUT_CONSTR (showIdent id) :
+                                         is2 ++
+                                         TUCK (ARG_VAR 0) c_arity :
+                                         EVAL (HEAP h0) (TailCall c_arity) :
+                                         []
+                                   h1  = h0 + 2
+                               in (h1,b:bs,HEAP h0,[PUT_CLOSURE (length bs),SET_PAD])
+compileArg gr st vs (QC qid)    h0 bs =
+  compileArg gr st vs (Q qid) h0 bs
+compileArg gr st vs (Vr x)      h0 bs =
+  (h0,bs,getVar vs x,[])
+compileArg gr st vs (EInt n)    h0 bs =
+  let h1 = h0 + 2
+  in (h1,bs,HEAP h0,[PUT_LIT (LInt n)])
+compileArg gr st vs (K s)       h0 bs =
+  let h1 = h0 + 2
+  in (h1,bs,HEAP h0,[PUT_LIT (LStr s)])
+compileArg gr st vs (EFloat d)  h0 bs =
+  let h1 = h0 + 2
+  in (h1,bs,HEAP h0,[PUT_LIT (LFlt d)])
+compileArg gr st vs (Typed e _) h0 bs =
+  compileArg gr st vs e h0 bs
+compileArg gr st vs (ImplArg e) h0 bs =
+  compileArg gr st vs e h0 bs
+compileArg gr st vs e           h0 bs =
+  let (f,es)   = appForm e
+      isConstr = case f of
+                   Q c@(m,id) -> case lookupAbsDef gr m id of
+                                   Ok (_,Just _) -> Nothing
+                                   _             -> Just c
+                   QC c@(m,id) -> case lookupAbsDef gr m id of
+                                    Ok (_,Just _) -> Nothing
+                                    _             -> Just c
+                   _        -> Nothing
+  in case isConstr of
+       Just (m,id) ->
+            let Ok ty = lookupFunType gr m id
+                (ctxt,_,_) = typeForm ty
+                c_arity    = length ctxt
+                ((h1,bs1,is1),args) = mapAccumL (\(h,bs,is) e -> let (h1,bs1,arg,is1) = compileArg gr st vs e h bs
+                                                                 in ((h1,bs1,is++is1),arg)) 
+                                                (h0,bs,[])
+                                                es
+                n_args = length args
+                is2 = setArgs st args
+                diff   = c_arity-n_args
+            in if diff <= 0
+                 then let h2  = h1 + 2 + n_args
+                      in (h2,bs1,HEAP h1,is1 ++ (PUT_CONSTR (showIdent id) : is2))
+                 else let h2  = h1 + 1 + n_args
+                          is2 = [SET (FREE_VAR i) | i <- [0..n_args-1]] ++ [SET (ARG_VAR (i+1)) | i <- [0..diff-1]]
+                          b   = CHECK_ARGS diff :
+                                ALLOC (c_arity+2) :
+                                PUT_CONSTR (showIdent id) :
+                                is2 ++
+                                TUCK (ARG_VAR 0) diff :
+                                EVAL (HEAP h0) (TailCall diff) :
+                                []
+                      in (h2,b:bs1,HEAP h1,is1 ++ (PUT_CLOSURE (length bs):is2))
+       Nothing -> compileLambda gr st vs [] e h0 bs
+
+compileLambda gr st vs xs (Abs _ x e) h0 bs =
+  compileLambda gr st vs (x:xs) e h0 bs
+compileLambda gr st vs xs e           h0 bs =
+  let ys      = nub (freeVars xs e)
+      arity   = length xs
+      (bs1,b) = compileBody gr arity
+                               (arity+1)
+                               (zip xs (map ARG_VAR  [0..]) ++
+                                zip ys (map FREE_VAR [0..]))
+                               e (b1:bs)
+      b1 = if arity == 0
+             then b
+             else CHECK_ARGS arity:b
+      is = if null ys
+             then [SET_PAD]
+             else map (SET . shiftIVal st . getVar vs) ys
+      h1 = h0 + 1 + length is
+  in (h1,bs1,HEAP h0,PUT_CLOSURE (length bs) : is)
+
+getVar vs x =
+  case lookup x vs of
+    Just arg         -> arg
+    Nothing          -> error "compileVar: unknown variable"
+
+shiftIVal st (ARG_VAR i) = ARG_VAR (st-i-1)
+shiftIVal st arg         = arg
+
+pushArgs st []         = (st,[])
+pushArgs st (arg:args) = let (st1,is) = pushArgs (st+1) args
+                         in (st1, PUSH (shiftIVal st arg) : is)
+
+tuckArgs arity st fun args = (st2,shiftIVal st2 fun',is1++is2)
+  where
+    (st2,fun',is2) = tucks st1 0 fun tas
+    (st1,is1) = pushArgs st pas
+    (tas,pas) = splitAt st args'
+    args' = reverse (ARG_VAR arity : args)
+
+    tucks st i fun []             = (st,fun,[])
+    tucks st i fun (arg:args)
+      | arg == ARG_VAR i      = tucks st (i+1) fun args
+      | otherwise             = case save st (ARG_VAR i) (fun:args) of
+                                  Just (fun:args) -> let (st1,fun',is) = tucks (st+1) (i+1) fun args
+                                                     in (st1, fun', PUSH (ARG_VAR (st-i-1)) :
+                                                                    TUCK (shiftIVal (st+1) arg) (st-i) : is)
+                                  Nothing         -> let (st1,fun',is) = tucks st (i+1) fun args
+                                                     in (st1, fun', TUCK (shiftIVal st arg) (st-i-1) : is)
+
+    save st arg0 []         = Nothing
+    save st arg0 (arg:args)
+      | arg0 == arg         = Just (ARG_VAR st1 : fromMaybe args (save st arg0 args))
+      | otherwise           = fmap (arg :) (save st arg0 args)
+
+setArgs st []         = []
+setArgs st (arg:args) = SET (shiftIVal st arg) : setArgs st args
+
+freeVars xs (Abs _ x e) = freeVars (x:xs) e
+freeVars xs (Vr x)     
+  | not (elem x xs)     = [x]
+freeVars xs e           = collectOp (freeVars xs) e
+
+push_is :: Int -> Int -> [IVal] -> [IVal]
+push_is i 0 is = is
+push_is i n is = ARG_VAR i : push_is (i-1) (n-1) is

src/compiler/api/GF/Compile/GeneratePMCFG.hs

@@ -0,0 +1,338 @@
+{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : Krasimir Angelov
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- Convert PGF grammar to PMCFG grammar.
+--
+-----------------------------------------------------------------------------
+
+module GF.Compile.GeneratePMCFG
+    (generatePMCFG, pmcfgForm, type2fields
+    ) where
+
+import GF.Grammar hiding (VApp,VRecType)
+import GF.Grammar.Predef
+import GF.Grammar.Lookup
+import GF.Infra.CheckM
+import GF.Infra.Option
+import GF.Text.Pretty
+import GF.Compile.Compute.Concrete
+import GF.Data.Operations(Err(..))
+import PGF2.Transactions
+import Control.Monad
+import Control.Monad.State
+import Control.Monad.ST
+import qualified Data.Map.Strict as Map
+import qualified Data.Sequence as Seq
+import Data.List(mapAccumL,sortOn,sortBy)
+import Data.Maybe(fromMaybe,isNothing)
+import Data.STRef
+
+generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
+generatePMCFG opts cwd gr cmo@(cm,cmi)
+  | mstatus cmi == MSComplete && isModCnc cmi && isNothing (mseqs cmi) =
+                do let gr' = prependModule gr cmo
+                   (js,seqs) <- runStateT (Map.traverseWithKey (\id info -> StateT (addPMCFG opts cwd gr' cmi id info)) (jments cmi)) Map.empty
+                   return (cm,cmi{jments = js, mseqs=Just (mapToSequence seqs)})
+  | otherwise = return cmo
+  where
+    mapToSequence m = Seq.fromList (map fst (sortOn snd (Map.toList m)))
+
+type SequenceSet = Map.Map [Symbol] Int
+
+addPMCFG opts cwd gr cmi id (CncCat mty@(Just (L loc ty)) mdef mref mprn Nothing) seqs = do
+  (defs,seqs) <-
+          case mdef of
+            Nothing           -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do
+                                   term <- mkLinDefault gr ty
+                                   pmcfgForm gr term [(Explicit,identW,typeStr)] ty seqs
+            Just (L loc term) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do
+                                   pmcfgForm gr term [(Explicit,identW,typeStr)] ty seqs
+  (refs,seqs) <- 
+          case mref of
+            Nothing           -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do
+                                   term <- mkLinReference gr ty
+                                   pmcfgForm gr term [(Explicit,identW,ty)] typeStr seqs
+            Just (L loc term) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do
+                                   pmcfgForm gr term [(Explicit,identW,ty)] typeStr seqs
+  mprn  <- case mprn of
+             Nothing          -> return Nothing
+             Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do
+                                   prn <- normalForm gr prn
+                                   return (Just (L loc prn))
+  return (CncCat mty mdef mref mprn (Just (defs,refs)),seqs)
+addPMCFG opts cwd gr cmi id (CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) seqs = do
+  (rules,seqs) <-
+           checkInModule cwd cmi loc ("Happened in the PMCFG generation for" <+> id) $
+             pmcfgForm gr term ctxt val seqs
+  mprn  <- case mprn of
+             Nothing          -> return Nothing
+             Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do
+                                   prn <- normalForm gr prn
+                                   return (Just (L loc prn))
+  return (CncFun mty mlin mprn (Just rules),seqs)
+addPMCFG opts cwd gr cmi id info seqs = return (info,seqs)
+
+pmcfgForm :: Grammar -> Term -> Context -> Type -> SequenceSet -> Check ([Production],SequenceSet)
+pmcfgForm gr t ctxt ty seqs = do
+  res <- runEvalM gr $ do
+           (_,args) <- mapAccumM (\arg_no (_,_,ty) -> do
+                                          t <- EvalM (\gr k mt d r msgs -> do (mt,_,t) <- type2metaTerm gr arg_no mt 0 [] ty
+                                                                              k t mt d r msgs)
+                                          tnk <- newThunk [] t
+                                          return (arg_no+1,tnk))
+                                      0 ctxt
+           v <- eval [] t args
+           (lins,params) <- flatten v ty ([],[])
+           lins <- fmap reverse $ mapM str2lin lins
+           (r,rs,_) <- compute params
+           args <- zipWithM tnk2lparam args ctxt
+           vars <- getVariables
+           let res = LParam r (order rs)
+           return (vars,args,res,lins)
+  return (runState (mapM mkProduction res) seqs)
+  where
+    tnk2lparam tnk (_,_,ty) = do
+      v <- force tnk
+      (_,params) <- flatten v ty ([],[])
+      (r,rs,_) <- compute params
+      return (PArg [] (LParam r (order rs)))
+
+    compute []              = return (0,[],1)
+    compute ((v,ty):params) = do
+      (r, rs ,cnt ) <- param2int v ty
+      (r',rs',cnt') <- compute params
+      return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
+
+    mkProduction (vars,args,res,lins) = do
+      lins <- mapM getSeqId lins
+      return (Production vars args res lins)
+      where
+        getSeqId :: [Symbol] -> State (Map.Map [Symbol] SeqId) SeqId
+        getSeqId lin = state $ \m ->
+          case Map.lookup lin m of
+            Just seqid -> (seqid,m)
+            Nothing    -> let seqid = Map.size m
+                          in (seqid,Map.insert lin seqid m)
+
+type2metaTerm :: SourceGrammar -> Int -> MetaThunks s -> LIndex -> [(LIndex,(Ident,Type))] -> Type -> ST s (MetaThunks s,Int,Term)
+type2metaTerm gr d ms r rs (Sort s) | s == cStr =
+  return (ms,r+1,TSymCat d r rs)
+type2metaTerm gr d ms r rs (RecType lbls) = do
+  ((ms',r'),ass) <- mapAccumM (\(ms,r) (lbl,ty) -> case lbl of
+                                                        LVar j -> return ((ms,r),(lbl,(Just ty,TSymVar d j)))
+                                                        lbl    -> do (ms',r',t) <- type2metaTerm gr d ms r rs ty
+                                                                     return ((ms',r'),(lbl,(Just ty,t))))
+                                 (ms,r) lbls
+  return (ms',r',R ass)
+type2metaTerm gr d ms r rs (Table p q)
+  | count == 1 = do (ms',r',t) <- type2metaTerm gr d ms r rs q
+                    return (ms',r+(r'-r),T (TTyped p) [(PW,t)])
+  | otherwise  = do let pv    = varX (length rs+1)
+                    (ms',delta,t) <-
+                        fixST $ \(~(_,delta,_)) ->
+                                     do (ms',r',t) <- type2metaTerm gr d ms r ((delta,(pv,p)):rs) q
+                                        return (ms',r'-r,t)
+                    return (ms',r+delta*count,T (TTyped p) [(PV pv,t)])
+  where
+    count = case allParamValues gr p of
+              Ok ts   -> length ts
+              Bad msg -> error msg
+type2metaTerm gr d ms r rs ty@(QC q) = do
+  let i = Map.size ms + 1
+  tnk <- newSTRef (Narrowing i ty)
+  return (Map.insert i tnk ms,r,Meta i)
+type2metaTerm gr d ms r rs ty
+  | Just n <- isTypeInts ty = do
+      let i = Map.size ms + 1
+      tnk <- newSTRef (Narrowing i ty)
+      return (Map.insert i tnk ms,r,Meta i)
+
+flatten (VR as) (RecType lbls) st = do
+  foldM collect st lbls
+  where
+    collect st (lbl,ty) =
+      case lookup lbl as of
+        Just tnk -> do v <- force tnk
+                       flatten v ty st
+        Nothing  -> evalError ("Missing value for label" <+> pp lbl $$
+                               "among" <+> hsep (punctuate (pp ',') (map fst as)))
+flatten v@(VT _ env cs) (Table p q) st = do
+  ts <- getAllParamValues p
+  foldM collect st ts
+  where
+    collect st t = do
+      tnk <- newThunk [] t
+      let v0 = VS v tnk []
+      v <- patternMatch v0 (map (\(p,t) -> (env,[p],[tnk],t)) cs)
+      flatten v q st
+flatten (VV _ tnks) (Table _ q) st = do
+  foldM collect st tnks
+  where
+    collect st tnk = do
+      v <- force tnk
+      flatten v q st
+flatten v (Sort s) (lins,params) | s == cStr = do
+  deepForce v
+  return (v:lins,params)
+flatten v ty@(QC q) (lins,params) = do
+  deepForce v
+  return (lins,(v,ty):params)
+flatten v ty (lins,params)
+  | Just n <- isTypeInts ty = do deepForce v
+                                 return (lins,(v,ty):params)
+  | otherwise               = error (showValue v)
+
+deepForce (VR as)          = mapM_ (\(lbl,v) -> force v >>= deepForce) as
+deepForce (VApp q tnks)    = mapM_ (\tnk -> force tnk >>= deepForce) tnks
+deepForce (VC v1 v2)       = deepForce v1 >> deepForce v2
+deepForce (VAlts def alts) = do deepForce def
+                                mapM_ (\(v,_) -> deepForce v) alts
+deepForce (VSymCat d r rs) = mapM_ (\(_,(tnk,_)) -> force tnk >>= deepForce) rs
+deepForce _                = return ()
+
+str2lin (VApp q [])
+  | q == (cPredef, cBIND)       = return [SymBIND]
+  | q == (cPredef, cNonExist)   = return [SymNE]
+  | q == (cPredef, cSOFT_BIND)  = return [SymSOFT_BIND]
+  | q == (cPredef, cSOFT_SPACE) = return [SymSOFT_SPACE]
+  | q == (cPredef, cCAPIT)      = return [SymCAPIT]
+  | q == (cPredef, cALL_CAPIT)  = return [SymALL_CAPIT]
+str2lin (VStr s)         = return [SymKS s]
+str2lin (VSymCat d r rs) = do (r, rs) <- compute r rs
+                              return [SymCat d (LParam r (order rs))]
+  where
+    compute r' []                     = return (r',[])
+    compute r' ((cnt',(tnk,ty)):tnks) = do
+      v <- force tnk
+      (r, rs, cnt) <- param2int v ty
+      (r',rs') <- compute r' tnks
+      return (r*cnt'+r',combine cnt' rs rs')
+str2lin (VSymVar d r)    = return [SymVar d r]
+str2lin VEmpty           = return []
+str2lin (VC v1 v2)       = liftM2 (++) (str2lin v1) (str2lin v2)
+str2lin (VAlts def alts) = do def <- str2lin def
+                              alts <- forM alts $ \(v,VStrs vs) -> do
+                                lin <- str2lin v
+                                return (lin,[s | VStr s <- vs])
+                              return [SymKP def alts]
+str2lin v                = do t <- value2term [] v
+                              evalError ("the string:" <+> ppTerm Unqualified 0 t $$
+                                         "cannot be evaluated at compile time.")
+
+param2int (VR as) (RecType lbls) = compute lbls
+  where
+    compute []              = return (0,[],1)
+    compute ((lbl,ty):lbls) = do
+      case lookup lbl as of
+        Just tnk -> do v <- force tnk
+                       (r, rs ,cnt ) <- param2int v ty
+                       (r',rs',cnt') <- compute lbls
+                       return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
+        Nothing  -> evalError ("Missing value for label" <+> pp lbl $$
+                               "among" <+> hsep (punctuate (pp ',') (map fst as)))
+param2int (VApp q tnks) ty = do
+  (r ,    ctxt,cnt ) <- getIdxCnt q
+  (r',rs',     cnt') <- compute ctxt tnks
+  return (r+r',rs',cnt)
+  where
+    getIdxCnt q = do
+      (_,ResValue (L _ ty) idx) <- getInfo q
+      let (ctxt,QC p) = typeFormCnc ty
+      (_,ResParam _ (Just (_,cnt))) <- getInfo p
+      return (idx,ctxt,cnt)
+
+    compute []              []         = return (0,[],1)
+    compute ((_,_,ty):ctxt) (tnk:tnks) = do
+      v <- force tnk
+      (r, rs ,cnt ) <- param2int v ty
+      (r',rs',cnt') <- compute ctxt tnks
+      return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
+param2int (VInt n)        ty
+  | Just max <- isTypeInts ty= return (fromIntegral n,[],fromIntegral max+1)
+param2int (VMeta tnk _) ty = do
+  tnk_st <- getRef tnk
+  case tnk_st of
+    Evaluated _ v  -> param2int v ty
+    Narrowing j ty -> do ts <- getAllParamValues ty
+                         return (0,[(1,j-1)],length ts)
+param2int v ty = do t <- value2term [] v
+                    evalError ("the parameter:" <+> ppTerm Unqualified 0 t $$
+                               "cannot be evaluated at compile time.")
+
+combine' 1   rs 1    rs' = []
+combine' 1   rs cnt' rs' = rs'
+combine' cnt rs 1    rs' = rs
+combine' cnt rs cnt' rs' = combine cnt' rs rs'
+
+combine cnt'          []            rs' = rs'
+combine cnt'          rs             [] = [(r*cnt',pv) | (r,pv) <- rs]
+combine cnt' ((r,pv):rs) ((r',pv'):rs') =
+  case compare pv pv' of
+    LT -> (r*cnt',   pv ) : combine cnt' rs ((r',pv'):rs')
+    EQ -> (r*cnt'+r',pv ) : combine cnt' rs ((r',pv'):rs')
+    GT -> (       r',pv') : combine cnt' ((r,pv):rs) rs'
+
+order = sortBy (\(r1,_) (r2,_) -> compare r2 r1)
+
+mapAccumM f a []     = return (a,[])
+mapAccumM f a (x:xs) = do (a, y) <- f a x
+                          (a,ys) <- mapAccumM f a xs
+                          return (a,y:ys)
+
+type2fields :: SourceGrammar -> Type -> [String]
+type2fields gr = type2fields empty
+  where
+    type2fields d (Sort s) | s == cStr = [show d]
+    type2fields d (RecType lbls) =
+      concatMap (\(lbl,ty) -> type2fields (d <+> pp lbl) ty) lbls
+    type2fields d (Table p q) =
+      let Ok ts = allParamValues gr p
+      in concatMap (\t -> type2fields (d <+> ppTerm Unqualified 5 t) q) ts
+    type2fields d _ = []
+
+mkLinDefault :: SourceGrammar -> Type -> Check Term
+mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
+ where
+   mkDefField ty =
+     case ty of
+       Table p t  -> do t' <- mkDefField t
+                        let T _ cs = mkWildCases t'
+                        return $ T (TWild p) cs
+       Sort s | s == cStr -> return (Vr varStr)
+       QC p       -> case lookupParamValues gr p of
+                       Ok []    -> checkError ("no parameter values given to type" <+> ppQIdent Qualified p)
+                       Ok (v:_) -> return v
+                       Bad msg  -> fail msg
+       RecType r -> do
+         let (ls,ts) = unzip r
+         ts <- mapM mkDefField ts
+         return $ R (zipWith assign ls ts)
+       _ | Just _ <- isTypeInts ty -> return $ EInt 0 -- exists in all as first val
+       _ -> checkError ("a field in a linearization type cannot be" <+> ty)
+
+mkLinReference :: SourceGrammar -> Type -> Check Term
+mkLinReference gr typ = do
+  mb_term <- mkRefField typ (Vr varStr)
+  return (Abs Explicit varStr (fromMaybe Empty mb_term))
+  where
+    mkRefField ty trm =
+      case ty of
+        Table pty ty -> case allParamValues gr pty of
+                          Ok []     -> checkError ("no parameter values given to type" <+> pty)
+                          Ok (p:ps) -> mkRefField ty (S trm p)
+                          Bad msg   -> fail msg
+        Sort s | s == cStr -> return (Just trm)
+        QC p       -> return Nothing
+        RecType rs -> traverse rs trm
+        _ | Just _ <- isTypeInts ty -> return Nothing
+        _ -> checkError ("a field in a linearization type cannot be" <+> typ)
+
+    traverse []          trm = return Nothing
+    traverse ((l,ty):rs) trm = do res <- mkRefField ty (P trm l)
+                                  case res of
+                                    Just trm -> return (Just trm)
+                                    Nothing  -> traverse rs trm

src/compiler/api/GF/Compile/GetGrammar.hs

@@ -0,0 +1,138 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GetGrammar
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/15 17:56:13 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.16 $
+--
+-- this module builds the internal GF grammar that is sent to the type checker
+-----------------------------------------------------------------------------
+
+module GF.Compile.GetGrammar (getSourceModule, getBNFCRules, getEBNFRules) where
+
+import Prelude hiding (catch)
+
+import GF.Data.Operations
+
+import GF.Infra.UseIO
+import GF.Infra.Option(Options,optPreprocessors,addOptions,renameEncoding,optEncoding,flag,defaultEncoding)
+import GF.Grammar.Lexer
+import GF.Grammar.Parser
+import GF.Grammar.Grammar
+import GF.Grammar.BNFC
+import GF.Grammar.EBNF
+import GF.Compile.ReadFiles(parseSource)
+
+import qualified Data.ByteString.Char8 as BS
+import Data.Char(isAscii)
+import Control.Monad (foldM,when,unless)
+import System.Process (system)
+import GF.System.Directory(removeFile,getCurrentDirectory)
+import System.FilePath(makeRelative)
+
+--getSourceModule :: Options -> FilePath -> IOE SourceModule
+-- | Read a source file and parse it (after applying preprocessors specified in the options)
+getSourceModule opts file0 = 
+--errIn file0 $
+  do tmp <- liftIO $ foldM runPreprocessor (Source file0) (flag optPreprocessors opts)
+     raw <- liftIO $ keepTemp tmp
+   --ePutStrLn $ "1 "++file0
+     (optCoding,parsed) <- parseSource opts pModDef raw
+     case parsed of
+       Left (Pn l c,msg) -> do file <- liftIO $ writeTemp tmp
+                               cwd <- getCurrentDirectory
+                               let location = makeRelative cwd file++":"++show l++":"++show c
+                               raise (location++":\n   "++msg)
+       Right (i,mi0) ->
+         do liftIO $ removeTemp tmp
+            let mi =mi0 {mflags=mflags mi0 `addOptions` opts, msrc=file0}
+            case renameEncoding `fmap` flag optEncoding (mflags mi0) of
+              Just coding' -> 
+                when (coding/=coding') $
+                  raise $ "Encoding mismatch: "++coding++" /= "++coding'
+                where coding = maybe defaultEncoding renameEncoding optCoding
+              _ -> return ()
+            return (i,mi)
+
+getBNFCRules :: Options -> FilePath -> IOE [BNFCRule]
+getBNFCRules opts fpath = do
+  raw <- liftIO (BS.readFile fpath)
+---- debug  BS.putStrLn $ raws
+  (optCoding,parsed) <- parseSource opts pBNFCRules raw
+  case parsed of
+    Left _ -> do
+      let ifToChange s ss = if (BS.all (\c -> elem c [' ','\t']) s || BS.last s == ';')  then s else ss  -- change if not all space or end with ';'
+      let raws = BS.concat $ map (\s -> ifToChange s $ BS.concat [s,BS.singleton ';']) $ BS.split '\n' raw   -- add semicolon to each line to be able to parse the format in GF book
+      (optCoding,parseds) <- parseSource opts pBNFCRules raws
+      case parseds of
+        Left (Pn l c,msg) -> do cwd <- getCurrentDirectory
+                                let location = makeRelative cwd fpath++":"++show l++":"++show c
+                                raise (location++":\n   "++msg)
+        Right rules       -> return rules
+    Right rules       -> return rules
+
+getEBNFRules :: Options -> FilePath -> IOE [ERule]
+getEBNFRules opts fpath = do
+  raw <- liftIO (BS.readFile fpath)
+  (optCoding,parsed) <- parseSource opts pEBNFRules raw
+  case parsed of
+    Left (Pn l c,msg) -> do cwd <- getCurrentDirectory
+                            let location = makeRelative cwd fpath++":"++show l++":"++show c
+                            raise (location++":\n   "++msg)
+    Right rules       -> return rules
+
+runPreprocessor :: Temporary -> String -> IO Temporary
+runPreprocessor tmp0 p =
+    maybe external internal (lookup p builtin_preprocessors)
+  where
+    internal preproc = (Internal . preproc) `fmap` readTemp tmp0
+    external =
+      do file0 <- writeTemp tmp0
+         -- FIXME: should use System.IO.openTempFile
+         let file1a = "_gf_preproc.tmp"
+             file1b = "_gf_preproc2.tmp"
+             -- file0 and file1 must be different
+             file1 = if file0==file1a then file1b else file1a
+             cmd = p +++ file0 ++ ">" ++ file1
+         system cmd
+         return (Temp file1)
+
+--------------------------------------------------------------------------------
+
+builtin_preprocessors = [("mkPresent",mkPresent),("mkMinimal",mkMinimal)]
+
+mkPresent = omit_lines "--# notpresent"   -- grep -v "\-\-\# notpresent"
+mkMinimal = omit_lines "--# notminimal"   -- grep -v "\-\-\# notminimal"
+
+omit_lines s = BS.unlines . filter (not . BS.isInfixOf bs) . BS.lines
+  where bs = BS.pack s
+
+--------------------------------------------------------------------------------
+
+data Temporary = Source FilePath | Temp FilePath | Internal BS.ByteString
+
+writeTemp tmp =
+    case tmp of
+      Source path  -> return path
+      Temp   path  -> return path
+      Internal str -> do -- FIXME: should use System.IO.openTempFile
+                         let tmp = "_gf_preproc.tmp"
+                         BS.writeFile tmp str
+                         return tmp
+
+readTemp tmp = do str <- keepTemp tmp
+                  removeTemp tmp
+                  return str
+
+keepTemp tmp =
+    case tmp of
+      Source path  -> BS.readFile path
+      Temp   path  -> BS.readFile path
+      Internal str -> return str
+
+removeTemp (Temp path) = removeFile path
+removeTemp _           = return ()

src/compiler/api/GF/Compile/GrammarToCanonical.hs

@@ -0,0 +1,423 @@
+-- | Translate grammars to Canonical form
+-- (a common intermediate representation to simplify export to other formats)
+module GF.Compile.GrammarToCanonical(
+       grammar2canonical,abstract2canonical,concretes2canonical,
+       projection,selection
+       ) where
+import Data.List(nub,partition)
+import qualified Data.Map as M
+import Data.Maybe(fromMaybe)
+import qualified Data.Set as S
+import GF.Data.ErrM
+import GF.Text.Pretty
+import GF.Grammar.Grammar as G
+import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
+import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,composSafeOp,mkAbs,mkApp,term2patt,sortRec)
+import GF.Grammar.Lockfield(isLockLabel)
+import GF.Grammar.Predef(cPredef,cInts)
+import GF.Infra.Ident(ModuleName(..),Ident,identW,ident2raw,rawIdentS,showIdent)
+import GF.Infra.Option(Options,optionsPGF)
+import GF.Infra.CheckM
+import PGF2(Literal(..))
+import GF.Compile.Compute.Concrete(normalForm)
+import GF.Grammar.Canonical as C
+import System.FilePath ((</>), (<.>))
+import qualified Debug.Trace as T
+
+
+-- | Generate Canonical code for the named abstract syntax and all associated
+-- concrete syntaxes
+grammar2canonical :: Options -> ModuleName -> G.Grammar -> Check C.Grammar
+grammar2canonical opts absname gr = do
+  abs <- abstract2canonical absname gr
+  cncs <- concretes2canonical opts absname gr
+  return (Grammar abs (map snd cncs))
+
+-- | Generate Canonical code for the named abstract syntax
+abstract2canonical :: ModuleName -> G.Grammar -> Check Abstract
+abstract2canonical absname gr =
+  return (Abstract (modId absname) (convFlags gr absname) cats funs)
+  where
+    cats = [CatDef (gId c) (convCtx ctx) | ((_,c),AbsCat ctx) <- adefs]
+
+    funs = [FunDef (gId f) (convType ty) |
+            ((_,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs]
+
+    adefs = allOrigInfos gr absname
+
+    convCtx = maybe [] (map convHypo . unLoc)
+    convHypo (bt,name,t) =
+      case typeForm t of
+        ([],(_,cat),[]) -> gId cat -- !!
+        tf -> error ("abstract2canonical convHypo: " ++ show tf)
+
+    convType t =
+      case typeForm t of
+        (hyps,(_,cat),args) -> Type bs (TypeApp (gId cat) as)
+          where
+            bs = map convHypo' hyps
+            as = map convType args
+
+    convHypo' (bt,name,t) = TypeBinding (gId name) (convType t)
+
+-- | Generate Canonical code for the all concrete syntaxes associated with
+-- the named abstract syntax in given the grammar.
+concretes2canonical :: Options -> ModuleName -> G.Grammar -> Check [(FilePath, Concrete)]
+concretes2canonical opts absname gr =
+  sequence
+    [fmap ((,) cncname) (concrete2canonical gr absname cnc cncmod)
+        | cnc<-allConcretes gr absname,
+          let cncname = "canonical" </> render cnc <.> "gf"
+              Ok cncmod = lookupModule gr cnc
+        ]
+
+-- | Generate Canonical GF for the given concrete module.
+concrete2canonical :: G.Grammar -> ModuleName -> ModuleName -> ModuleInfo -> Check Concrete
+concrete2canonical gr absname cnc modinfo = do
+  defs <- fmap concat $ mapM (toCanonical gr absname) (M.toList (jments modinfo))
+  return (Concrete (modId cnc) (modId absname) (convFlags gr cnc)
+                   (neededParamTypes S.empty (params defs))
+                   [lincat | (_,Left lincat) <- defs]
+                   [lin | (_,Right lin) <- defs])
+  where
+    params = S.toList . S.unions . map fst
+
+    neededParamTypes have [] = []
+    neededParamTypes have (q:qs) =
+        if q `S.member` have
+        then neededParamTypes have qs
+        else let ((got,need),def) = paramType gr q
+             in def++neededParamTypes (S.union got have) (S.toList need++qs)
+
+-- toCanonical :: G.Grammar -> ModuleName -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)]
+toCanonical gr absname (name,jment) =
+  case jment of
+    CncCat (Just (L loc typ)) _ _ pprn _ -> do
+      ntyp <- normalForm gr typ
+      let pts = paramTypes gr ntyp
+      return [(pts,Left (LincatDef (gId name) (convType ntyp)))]
+    CncFun (Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn _ -> do
+      let params = [(b,x)|(b,x,_)<-ctx]
+          args   = map snd params
+      e0 <- normalForm gr (mkAbs params (mkApp def (map Vr args)))
+      let e   = cleanupRecordFields lincat (unAbs (length params) e0)
+          tts = tableTypes gr [e]
+      return [(tts,Right (LinDef (gId name) (map gId args) (convert gr e)))]
+    AnyInd _ m  -> case lookupOrigInfo gr (m,name) of
+                     Ok (m,jment) -> toCanonical gr absname (name,jment)
+                     _ -> return []
+    _ -> return []
+  where
+    unAbs 0 t = t
+    unAbs n (Abs _ _ t) = unAbs (n-1) t
+    unAbs _ t = t
+
+tableTypes :: G.Grammar -> [Term] -> S.Set QIdent
+tableTypes gr ts = S.unions (map tabtys ts)
+  where
+    tabtys t =
+      case t of
+        V t cc -> S.union (paramTypes gr t) (tableTypes gr cc)
+        T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs))
+        _ -> collectOp tabtys t
+
+paramTypes :: G.Grammar -> G.Type -> S.Set QIdent
+paramTypes gr t =
+  case t of
+    RecType fs -> S.unions (map (paramTypes gr.snd) fs)
+    Table t1 t2 -> S.union (paramTypes gr t1) (paramTypes gr t2)
+    App tf ta -> S.union (paramTypes gr tf) (paramTypes gr ta)
+    Sort _ -> S.empty
+    EInt _ -> S.empty
+    Q q -> lookup q
+    QC q -> lookup q
+    FV ts -> S.unions (map (paramTypes gr) ts)
+    _ -> ignore
+  where
+    lookup q = case lookupOrigInfo gr q of
+                 Ok (_,ResOper  _ (Just (L _ t))) ->
+                                       S.insert q (paramTypes gr t)
+                 Ok (_,ResParam {}) -> S.singleton q
+                 _ -> ignore
+
+    ignore = T.trace ("Ignore: " ++ show t) S.empty
+
+-- | Filter out record fields from definitions which don't appear in lincat.
+cleanupRecordFields :: G.Type -> Term -> Term
+cleanupRecordFields (RecType ls) (R as) =
+  let defnFields = M.fromList ls
+  in R
+      [ (lbl, (mty, t'))
+      | (lbl, (mty, t)) <- as
+      , M.member lbl defnFields
+      , let Just ty = M.lookup lbl defnFields
+      , let t' = cleanupRecordFields ty t
+      ]
+cleanupRecordFields ty t@(FV _) = composSafeOp (cleanupRecordFields ty) t
+cleanupRecordFields _ t = t
+
+convert :: G.Grammar -> Term -> LinValue
+convert gr = convert' gr []
+
+convert' :: G.Grammar -> [Ident] -> Term -> LinValue
+convert' gr vs = ppT
+  where
+    ppT0 = convert' gr vs
+    ppTv vs' = convert' gr vs'
+
+    ppT t =
+      case t of
+--      Abs b x t -> ...
+--      V ty ts -> VTableValue (convType ty) (map ppT ts)
+        V ty ts -> TableValue (convType ty) [TableRow (ppP p) (ppT t)|(p,t)<-zip ps ts]
+          where
+            Ok pts = allParamValues gr ty
+            Ok ps = mapM term2patt pts
+        T (TTyped ty) cs -> TableValue (convType ty) (map ppCase cs)
+        S t p -> selection (ppT t) (ppT p)
+        C t1 t2 -> concatValue (ppT t1) (ppT t2)
+        App f a -> ap (ppT f) (ppT a)
+        R r -> RecordValue (fields (sortRec r))
+        P t l -> projection (ppT t) (lblId l)
+        Vr x -> VarValue (gId x)
+        Cn x -> VarValue (gId x) -- hmm
+        Con c -> ParamConstant (Param (gId c) [])
+        Sort k -> VarValue (gId k)
+        EInt n -> LiteralValue (LInt n)
+        Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gQId m n)
+        QC (m,n) -> ParamConstant (Param (gQId m n) [])
+        K s -> LiteralValue (LStr s)
+        Empty -> LiteralValue (LStr "")
+        FV ts -> VariantValue (map ppT ts)
+        Alts t' vs -> alts vs (ppT t')
+        _ -> error $ "convert' ppT: " ++ show t
+
+    ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
+
+    ppPredef n = error "TODO: ppPredef" {-
+      case predef n of
+        Ok BIND       -> p "BIND"
+        Ok SOFT_BIND  -> p "SOFT_BIND"
+        Ok SOFT_SPACE -> p "SOFT_SPACE"
+        Ok CAPIT      -> p "CAPIT"
+        Ok ALL_CAPIT  -> p "ALL_CAPIT"
+        _ -> VarValue (gQId cPredef n) -- hmm
+      where
+       p = PredefValue . PredefId . rawIdentS
+-}
+    ppP p =
+      case p of
+        PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
+        PP (m,c) ps -> ParamPattern (Param (gQId m c) (map ppP ps))
+        PR r -> RecordPattern (fields r) {-
+        PW -> WildPattern
+        PV x -> VarP x
+        PString s -> Lit (show s) -- !!
+        PInt i -> Lit (show i)
+        PFloat x -> Lit (show x)
+        PT _ p -> ppP p
+        PAs x p -> AsP x (ppP p) -}
+        _ -> error $ "convert' ppP: " ++ show p
+      where
+        fields = map field . filter (not.isLockLabel.fst)
+        field (l,p) = RecordRow (lblId l) (ppP p)
+
+--  patToParam p = case ppP p of ParamPattern pv -> pv
+
+--  token s = single (c "TK" `Ap` lit s)
+
+    alts vs = PreValue (map alt vs)
+      where
+        alt (t,p) = (pre p,ppT0 t)
+
+        pre (K s) = [s]
+        pre Empty = [""]  -- Empty == K ""
+        pre (Strs ts) = concatMap pre ts
+        pre (EPatt _ _ p) = pat p
+        pre t = error $ "convert' alts pre: " ++ show t
+
+        pat (PString s) = [s]
+        pat (PAlt p1 p2) = pat p1++pat p2
+        pat (PSeq _ _ p1 _ _ p2) = [s1++s2 | s1<-pat p1, s2<-pat p2]
+        pat p = error $ "convert' alts pat: "++show p
+
+    fields = map field . filter (not.isLockLabel.fst)
+    field (l,(_,t)) = RecordRow (lblId l) (ppT t)
+  --c = Const
+  --c = VarValue . VarValueId
+  --lit s = c (show s) -- hmm
+
+    ap f a = case f of
+               ParamConstant (Param p ps) ->
+                 ParamConstant (Param p (ps++[a]))
+               _ -> error $ "convert' ap: "++render (ppA f <+> ppA a)
+
+concatValue :: LinValue -> LinValue -> LinValue
+concatValue v1 v2 =
+  case (v1,v2) of
+    (LiteralValue (LStr ""),_) -> v2
+    (_,LiteralValue (LStr "")) -> v1
+    _ -> ConcatValue v1 v2
+
+-- | Smart constructor for projections
+projection :: LinValue -> LabelId -> LinValue
+projection r l = fromMaybe (Projection r l) (proj r l)
+
+proj :: LinValue -> LabelId -> Maybe LinValue
+proj r l =
+  case r of
+    RecordValue r -> case [v | RecordRow l' v <- r, l'==l] of
+                          [v] -> Just v
+                          _ -> Nothing
+    _ -> Nothing
+
+-- | Smart constructor for selections
+selection :: LinValue -> LinValue -> LinValue
+selection t v =
+  -- Note: impossible cases can become possible after grammar transformation
+  case t of
+    TableValue tt r ->
+        case nub [rv | TableRow _ rv <- keep] of
+          [rv] -> rv
+          _ -> Selection (TableValue tt r') v
+      where
+        -- Don't introduce wildcard patterns, true to the canonical format,
+        -- annotate (or eliminate) rhs in impossible rows
+        r' = map trunc r
+        trunc r@(TableRow p e) = if mightMatchRow v r
+                                 then r
+                                 else TableRow p (impossible e)
+        {-
+        -- Creates smaller tables, but introduces wildcard patterns
+        r' = if null discard
+             then r
+             else keep++[TableRow WildPattern impossible]
+        -}
+        (keep,discard) = partition (mightMatchRow v) r
+    _ -> Selection t v
+
+impossible :: LinValue -> LinValue
+impossible = CommentedValue "impossible"
+
+mightMatchRow :: LinValue -> TableRow rhs -> Bool
+mightMatchRow v (TableRow p _) =
+  case p of
+    WildPattern -> True
+    _ -> mightMatch v p
+
+mightMatch :: LinValue -> LinPattern -> Bool
+mightMatch v p =
+  case v of
+    ConcatValue _ _ -> False
+    ParamConstant (Param c1 pvs) ->
+      case p of
+        ParamPattern (Param c2 pps) -> c1==c2 && length pvs==length pps &&
+                                       and [mightMatch v p|(v,p)<-zip pvs pps]
+        _ -> False
+    RecordValue rv ->
+      case p of
+        RecordPattern rp ->
+          and [maybe False (`mightMatch` p) (proj v l) | RecordRow l p<-rp]
+        _ -> False
+    _ -> True
+
+patVars :: Patt -> [Ident]
+patVars p =
+  case p of
+    PV x -> [x]
+    PAs x p -> x:patVars p
+    _ -> collectPattOp patVars p
+
+convType :: Term -> LinType
+convType = ppT
+  where
+    ppT t =
+      case t of
+        Table ti tv -> TableType (ppT ti) (ppT tv)
+        RecType rt -> RecordType (convFields rt)
+--      App tf ta -> TAp (ppT tf) (ppT ta)
+--      FV [] -> tcon0 (identS "({-empty variant-})")
+        Sort k -> convSort k
+--      EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal
+        FV (t:ts) -> ppT t -- !!
+        QC (m,n) -> ParamType (ParamTypeId (gQId m n))
+        Q (m,n) -> ParamType (ParamTypeId (gQId m n))
+        _ -> error $ "convType ppT: " ++ show t
+
+    convFields = map convField . filter (not.isLockLabel.fst)
+    convField (l,r) = RecordRow (lblId l) (ppT r)
+
+    convSort k = case showIdent k of
+                   "Float" -> FloatType
+                   "Int" -> IntType
+                   "Str" -> StrType
+                   _ -> error $ "convType convSort: " ++ show k
+
+toParamType :: Term -> ParamType
+toParamType t = case convType t of
+                  ParamType pt -> pt
+                  _ -> error $ "toParamType: " ++ show t
+
+toParamId :: Term -> ParamId
+toParamId t = case toParamType t of
+                   ParamTypeId p -> p
+
+paramType :: G.Grammar
+             -> (ModuleName, Ident)
+             -> ((S.Set (ModuleName, Ident), S.Set QIdent), [ParamDef])
+paramType gr q@(_,n) =
+    case lookupOrigInfo gr q of
+      Ok (m,ResParam (Just (L _ ps)) _)
+       {- - | m/=cPredef && m/=moduleNameS "Prelude"-} ->
+         ((S.singleton (m,n),argTypes ps),
+          [ParamDef name (map (param m) ps)]
+         )
+       where name = gQId m n
+      Ok (m,ResOper  _ (Just (L _ t)))
+        | m==cPredef && n==cInts ->
+           ((S.empty,S.empty),[]) {-
+           ((S.singleton (m,n),S.empty),
+            [Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
+        | otherwise ->
+           ((S.singleton (m,n),paramTypes gr t),
+            [ParamAliasDef (gQId m n) (convType t)])
+      _ -> ((S.empty,S.empty),[])
+  where
+    param m (n,ctx) = Param (gQId m n) [toParamId t|(_,_,t)<-ctx]
+    argTypes = S.unions . map argTypes1
+    argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
+
+lblId :: Label -> C.LabelId
+lblId (LIdent ri) = LabelId ri
+lblId (LVar i) = LabelId (rawIdentS (show i)) -- hmm
+
+modId :: ModuleName -> C.ModId
+modId (MN m) = ModId (ident2raw m)
+
+class FromIdent i where
+  gId :: Ident -> i
+
+instance FromIdent VarId where
+  gId i = if i == identW then Anonymous else VarId (ident2raw i)
+
+instance FromIdent C.FunId where gId = C.FunId . ident2raw
+instance FromIdent CatId where gId = CatId . ident2raw
+instance FromIdent ParamId where gId = ParamId . unqual
+instance FromIdent VarValueId where gId = VarValueId . unqual
+
+class FromIdent i => QualIdent i where
+  gQId :: ModuleName -> Ident -> i
+
+instance QualIdent ParamId where gQId m n = ParamId (qual m n)
+instance QualIdent VarValueId where gQId m n = VarValueId (qual m n)
+
+qual :: ModuleName -> Ident -> QualId
+qual m n = Qual (modId m) (ident2raw n)
+
+unqual :: Ident -> QualId
+unqual n = Unqual (ident2raw n)
+
+convFlags :: G.Grammar -> ModuleName -> Flags
+convFlags gr mn =
+  Flags [(rawIdentS n,v) |
+         (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]

src/compiler/api/GF/Compile/GrammarToPGF.hs

@@ -0,0 +1,461 @@
+{-# LANGUAGE BangPatterns, FlexibleContexts, MagicHash #-}
+module GF.Compile.GrammarToPGF (grammar2PGF) where
+
+import GF.Compile.GeneratePMCFG
+import GF.Compile.GenerateBC
+import GF.Compile.OptimizePGF
+
+import PGF2 hiding (mkType)
+import PGF2.Transactions
+import GF.Grammar.Predef
+import GF.Grammar.Grammar hiding (Production)
+import qualified GF.Grammar.Lookup as Look
+import qualified GF.Grammar as A
+import qualified GF.Grammar.Macros as GM
+
+import GF.Infra.Ident
+import GF.Infra.Option
+import GF.Infra.UseIO (IOE)
+import GF.Data.Operations
+
+import Control.Monad(forM_,foldM)
+import Data.List
+import Data.Char
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
+import qualified Data.Sequence as Seq
+import Data.Array.IArray
+import Data.Maybe(fromMaybe)
+import System.FilePath
+import System.Directory
+
+grammar2PGF :: Options -> Maybe PGF -> SourceGrammar -> ModuleName -> Map.Map PGF2.Fun Double -> IO PGF
+grammar2PGF opts mb_pgf gr am probs = do
+  let abs_name = mi2i am
+  pgf <- case mb_pgf of
+           Just pgf | abstractName pgf == abs_name   ->
+                         do return pgf
+           _        | snd (flag optLinkTargets opts) ->
+                         do let fname = maybe id (</>)
+                                              (flag optOutputDir opts)
+                                              (fromMaybe abs_name (flag optName opts)<.>"ngf")
+                            exists <- doesFileExist fname
+                            if exists
+                              then removeFile fname
+                              else return ()
+                            putStr ("(Boot image "++fname++") ")
+                            newNGF abs_name (Just fname) 0
+                    | otherwise ->
+                         do newNGF abs_name Nothing 0
+
+  pgf <- modifyPGF pgf $ do
+    sequence_ [setAbstractFlag name value | (name,value) <- optionsPGF aflags]
+    sequence_ [createCategory c ctxt p | (c,ctxt,p) <- cats]
+    sequence_ [createFunction f ty arity bcode p | (f,ty,arity,bcode,p) <- funs]
+    forM_ (allConcretes gr am) $ \cm ->
+      createConcrete (mi2i cm) $ do
+        let cflags = err (const noOptions) mflags (lookupModule gr cm)
+        sequence_ [setConcreteFlag name value | (name,value) <- optionsPGF cflags]
+        let infos = ( Seq.fromList [Left [SymCat 0 (LParam 0 [])]]
+                    , let id_prod = Production [] [PArg [] (LParam 0 [])] (LParam 0 []) [0]
+                          prods   = ([id_prod],[id_prod])
+                      in [(cInt,   CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
+                         ,(cString,CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
+                         ,(cFloat, CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
+                         ]
+                    )
+                    : prepareSeqTbls (Look.allOrigInfos gr cm)
+        infos <- processInfos createCncCats infos
+        infos <- processInfos createCncFuns infos
+        return ()
+  return pgf
+  where
+    aflags = err (const noOptions) mflags (lookupModule gr am)
+
+    adefs =
+        [((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++ 
+        Look.allOrigInfos gr am
+
+    toLogProb = realToFrac . negate . log
+
+    cats = [(c', snd (mkContext [] cont), toLogProb (fromMaybe 0 (Map.lookup c' probs))) |
+                               ((m,c),AbsCat (Just (L _ cont))) <- adefs, let c' = i2i c]
+
+    funs = [(f', mkType [] ty, arity, bcode, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) |
+                               ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs,
+                               let arity = mkArity ma mdef ty,
+                               let bcode = mkDef gr arity mdef,
+                               let f' = i2i f]
+                               
+    funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++))
+                    [(i2i cat,[(i2i f,Map.lookup f' probs)]) | ((m,f),AbsFun (Just (L _ ty)) _ _ _) <- adefs,
+                                                               let (_,(_,cat),_) = GM.typeForm ty,
+                                                               let f' = i2i f]
+      where
+        pad :: [(a,Maybe Double)] -> [(a,Double)]
+        pad pfs = [(f,fromMaybe deflt mb_p) | (f,mb_p) <- pfs]
+          where
+            deflt = case length [f | (f,Nothing) <- pfs] of
+                      0 -> 0
+                      n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n)
+
+    prepareSeqTbls infos = 
+       (map addSeqTable . Map.toList . Map.fromListWith (++))
+               [(m,[(c,info)]) | ((m,c),info) <- infos]
+       where
+         addSeqTable (m,infos) = 
+           case lookupModule gr m of
+             Ok mi   -> case mseqs mi of
+                          Just seqs -> (fmap Left seqs,infos)
+                          Nothing   -> (Seq.empty,[])
+             Bad msg -> error msg
+
+    processInfos f []                    = return []
+    processInfos f ((seqtbl,infos):rest) = do
+      seqtbl <- foldM f seqtbl infos
+      rest <- processInfos f rest
+      return ((seqtbl,infos):rest)
+
+    createCncCats seqtbl (c,CncCat (Just (L _ ty)) _ _ mprn (Just (lindefs,linrefs))) = do
+      seqtbl <- createLincat (i2i c) (type2fields gr ty) lindefs linrefs seqtbl
+      case mprn of
+        Nothing        -> return ()
+        Just (L _ prn) -> setPrintName (i2i c) (unwords (term2tokens prn))
+      return seqtbl
+    createCncCats seqtbl _ = return seqtbl
+
+    createCncFuns seqtbl (f,CncFun _ _ mprn (Just prods)) = do
+      seqtbl <- createLin (i2i f) prods seqtbl
+      case mprn of
+        Nothing        -> return ()
+        Just (L _ prn) -> setPrintName (i2i f) (unwords (term2tokens prn))
+      return seqtbl
+    createCncFuns seqtbl _ = return seqtbl
+
+    term2tokens (K tok)     = [tok]
+    term2tokens (C t1 t2)   = term2tokens t1 ++ term2tokens t2
+    term2tokens (Typed t _) = term2tokens t
+    term2tokens _           = []
+
+i2i :: Ident -> String
+i2i = showIdent
+
+mi2i :: ModuleName -> String
+mi2i (MN i) = i2i i
+
+mkType :: [Ident] -> A.Type -> PGF2.Type
+mkType scope t =
+  case GM.typeForm t of
+    (hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps
+                           in DTyp hyps' (i2i cat) (map (mkExp scope') args)
+
+mkExp :: [Ident] -> A.Term -> Expr
+mkExp scope t =
+  case t of
+    Q (_,c)  -> EFun (i2i c)
+    QC (_,c) -> EFun (i2i c)
+    Vr x     -> case lookup x (zip scope [0..]) of
+                  Just i  -> EVar  i
+                  Nothing -> EMeta 0
+    Abs b x t-> EAbs b (i2i x) (mkExp (x:scope) t)
+    App t1 t2-> EApp (mkExp scope t1) (mkExp scope t2)
+    EInt i   -> ELit (LInt (fromIntegral i))
+    EFloat f -> ELit (LFlt f)
+    K s      -> ELit (LStr s)
+    Meta i   -> EMeta i
+    _        -> EMeta 0
+{-
+mkPatt scope p = 
+  case p of
+    A.PP (_,c) ps->let (scope',ps') = mapAccumL mkPatt scope ps
+                   in (scope',C.PApp (i2i c) ps')
+    A.PV x      -> (x:scope,C.PVar (i2i x))
+    A.PAs x p   -> let (scope',p') = mkPatt scope p
+                   in (x:scope',C.PAs (i2i x) p')
+    A.PW        -> (  scope,C.PWild)
+    A.PInt i    -> (  scope,C.PLit (C.LInt (fromIntegral i)))
+    A.PFloat f  -> (  scope,C.PLit (C.LFlt f))
+    A.PString s -> (  scope,C.PLit (C.LStr s))
+    A.PImplArg p-> let (scope',p') = mkPatt scope p
+                   in (scope',C.PImplArg p')
+    A.PTilde t  -> (  scope,C.PTilde (mkExp scope t))
+-}
+
+mkContext :: [Ident] -> A.Context -> ([Ident],[PGF2.Hypo])
+mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
+                                                      in if x == identW
+                                                           then (  scope,(bt,i2i x,ty'))
+                                                           else (x:scope,(bt,i2i x,ty'))) scope hyps 
+
+mkDef gr arity (Just eqs) = generateByteCode gr arity eqs
+mkDef gr arity Nothing    = []
+
+mkArity (Just a) _        ty = a   -- known arity, i.e. defined function
+mkArity Nothing  (Just _) ty = 0   -- defined function with no arity - must be an axiom
+mkArity Nothing  _        ty = let (ctxt, _, _) = GM.typeForm ty  -- constructor
+                               in length ctxt
+{-
+genCncCats gr am cm cdefs = mkCncCats 0 cdefs
+  where
+    mkCncCats index []                                                = (index,[])
+    mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _ _):cdefs) 
+      | id == cInt    = 
+            let cc            = pgfCncCat gr (i2i id) lincat fidInt
+                (index',cats) = mkCncCats index cdefs
+            in (index', cc : cats)
+      | id == cFloat  = 
+            let cc            = pgfCncCat gr (i2i id) lincat fidFloat
+                (index',cats) = mkCncCats index cdefs
+            in (index', cc : cats)
+      | id == cString = 
+            let cc            = pgfCncCat gr (i2i id) lincat fidString
+                (index',cats) = mkCncCats index cdefs
+            in (index', cc : cats)
+      | otherwise     =
+            let cc@(_, _s, e, _) = pgfCncCat gr (i2i id) lincat index
+                (index',cats)    = mkCncCats (e+1) cdefs
+            in (index', cc : cats)
+    mkCncCats index (_                                          :cdefs) = mkCncCats index cdefs
+
+genCncFuns :: Grammar
+           -> ModuleName
+           -> ModuleName
+           -> Array SeqId [Symbol]
+           -> ([Symbol] -> [Symbol] -> Ordering)
+           -> Array SeqId [Symbol]
+           -> [(QIdent, Info)]
+           -> FId
+           -> Map.Map PGF2.Cat (Int,Int)
+           -> (FId,
+               [(FId, [Production])],
+               [(FId, [FunId])],
+               [(FId, [FunId])],
+               [(PGF2.Fun,[SeqId])])
+genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccat_ranges =
+  let (fid_cnt1,funs_cnt1,funs1,lindefs,linrefs) = mkCncCats cdefs fid_cnt  0 [] IntMap.empty IntMap.empty
+      (fid_cnt2,funs_cnt2,funs2,prods0)          = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty
+      prods                                      = [(fid,Set.toList prodSet) | (fid,prodSet) <- IntMap.toList prods0]
+  in (fid_cnt2,prods,IntMap.toList lindefs,IntMap.toList linrefs,reverse funs2)
+  where
+    mkCncCats []                                                          fid_cnt funs_cnt funs lindefs linrefs =
+      (fid_cnt,funs_cnt,funs,lindefs,linrefs)
+    mkCncCats (((m,id),CncCat _ _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs linrefs =
+      let !funs_cnt' = let (s_funid, e_funid) = bounds funs0
+                       in funs_cnt+(e_funid-s_funid+1)
+          lindefs'   = foldl' (toLinDef (am,id) funs_cnt) lindefs prods0
+          linrefs'   = foldl' (toLinRef (am,id) funs_cnt) linrefs prods0
+          funs'      = foldl' (toCncFun funs_cnt (m,mkLinDefId id)) funs (assocs funs0)
+      in mkCncCats cdefs fid_cnt funs_cnt' funs' lindefs' linrefs'
+    mkCncCats (_                                                  :cdefs) fid_cnt funs_cnt funs lindefs linrefs =
+      mkCncCats cdefs fid_cnt funs_cnt funs lindefs linrefs
+
+    mkCncFuns []                                                        fid_cnt funs_cnt funs lindefs crc prods =
+      (fid_cnt,funs_cnt,funs,prods)
+    mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs crc prods =
+      let ty_C           = err error (\x -> x) $ fmap GM.typeForm (Look.lookupFunType gr am id)
+          !funs_cnt'     = let (s_funid, e_funid) = bounds funs0
+                           in funs_cnt+(e_funid-s_funid+1)
+          !(fid_cnt',crc',prods')
+                         = foldl' (toProd lindefs ty_C funs_cnt)
+                                  (fid_cnt,crc,prods) prods0
+          funs'          = foldl' (toCncFun funs_cnt (m,id)) funs (assocs funs0)
+      in mkCncFuns cdefs fid_cnt' funs_cnt' funs' lindefs crc' prods'
+    mkCncFuns (_                                                :cdefs) fid_cnt funs_cnt funs lindefs crc prods = 
+      mkCncFuns cdefs fid_cnt funs_cnt funs lindefs crc prods
+
+    toProd lindefs (ctxt_C,res_C,_) offs st (A.Production fid0 funid0 args0) =
+      let !((fid_cnt,crc,prods),args) = mapAccumL mkArg st (zip ctxt_C args0)
+          set0    = Set.fromList (map (PApply (offs+funid0)) (sequence args))
+          fid     = mkFId res_C fid0
+          !prods' = case IntMap.lookup fid prods of
+                     Just set -> IntMap.insert fid (Set.union set0 set) prods
+                     Nothing  -> IntMap.insert fid set0 prods
+      in (fid_cnt,crc,prods')
+      where
+        mkArg st@(fid_cnt,crc,prods) ((_,_,ty),fid0s) =
+          case fid0s of
+            [fid0] -> (st,map (flip PArg (mkFId arg_C fid0)) ctxt)
+            fid0s  -> case Map.lookup fids crc of
+                        Just fid -> (st,map (flip PArg fid) ctxt)
+                        Nothing  -> let !crc'   = Map.insert fids fid_cnt crc
+                                        !prods' = IntMap.insert fid_cnt (Set.fromList (map PCoerce fids)) prods
+                                    in ((fid_cnt+1,crc',prods'),map (flip PArg fid_cnt) ctxt)
+          where
+            (hargs_C,arg_C) = GM.catSkeleton ty
+            ctxt = mapM (mkCtxt lindefs) hargs_C
+            fids = map (mkFId arg_C) fid0s
+
+    mkLinDefId id = prefixIdent "lindef " id
+
+    toLinDef res offs lindefs (A.Production fid0 funid0 args) =
+      if args == [[fidVar]]
+        then IntMap.insertWith (++) fid [offs+funid0] lindefs
+        else lindefs
+      where
+        fid = mkFId res fid0
+
+    toLinRef res offs linrefs (A.Production fid0 funid0 [fargs]) =
+      if fid0 == fidVar
+        then foldr (\fid -> IntMap.insertWith (++) fid [offs+funid0]) linrefs fids
+        else linrefs
+      where
+        fids = map (mkFId res) fargs
+
+    mkFId (_,cat) fid0 =
+      case Map.lookup (i2i cat) cnccat_ranges of
+        Just (s,e) -> s+fid0
+        Nothing    -> error ("GrammarToPGF.mkFId: missing category "++showIdent cat)
+
+    mkCtxt lindefs (_,cat) =
+      case Map.lookup (i2i cat) cnccat_ranges of
+        Just (s,e) -> [(fid,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]]
+        Nothing    -> error "GrammarToPGF.mkCtxt failed"
+
+    toCncFun offs (m,id) funs (funid0,lins0) =
+      let mseqs = case lookupModule gr m of
+                    Ok (ModInfo{mseqs=Just mseqs}) -> mseqs
+                    _                              -> ex_seqs
+      in (i2i id, map (newIndex mseqs) (elems lins0)):funs
+      where
+        newIndex mseqs i = binSearch (mseqs ! i) seqs (bounds seqs)
+
+        binSearch v arr (i,j)
+          | i <= j    = case ciCmp v (arr ! k) of
+                          LT -> binSearch v arr (i,k-1)
+                          EQ -> k
+                          GT -> binSearch v arr (k+1,j)
+          | otherwise = error "binSearch"
+          where
+            k = (i+j) `div` 2
+
+
+genPrintNames cdefs =
+  [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
+  where
+    prn (CncFun _ _   (Just (L _ tr)) _) = [flatten tr]
+    prn (CncCat _ _ _ (Just (L _ tr)) _) = [flatten tr]
+    prn _                                = []
+
+    flatten (K s)      = s
+    flatten (Alts x _) = flatten x
+    flatten (C x y)    = flatten x +++ flatten y
+
+mkArray    lst = listArray (0,length lst-1) lst
+mkMapArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
+mkSetArray set = listArray (0,Set.size set-1) (Set.toList set)
+
+-- The following is a version of Data.List.sortBy which together
+-- with the sorting also eliminates duplicate values 
+sortNubBy cmp = mergeAll . sequences
+  where
+    sequences (a:b:xs) =
+      case cmp a b of
+        GT -> descending b [a]  xs
+        EQ -> sequences (b:xs)
+        LT -> ascending  b (a:) xs
+    sequences xs = [xs]
+
+    descending a as []     = [a:as]
+    descending a as (b:bs) =
+      case cmp a b of
+        GT -> descending b (a:as) bs
+        EQ -> descending a as bs
+        LT -> (a:as) : sequences (b:bs)
+
+    ascending a as []     = let !x = as [a]
+                            in [x]
+    ascending a as (b:bs) =
+      case cmp a b of
+        GT -> let !x = as [a]
+              in x : sequences (b:bs)
+        EQ -> ascending a as bs
+        LT -> ascending b (\ys -> as (a:ys)) bs
+
+    mergeAll [x] = x
+    mergeAll xs  = mergeAll (mergePairs xs)
+
+    mergePairs (a:b:xs) = let !x = merge a b
+                          in x : mergePairs xs
+    mergePairs xs       = xs
+
+    merge as@(a:as') bs@(b:bs') =
+      case cmp a b of
+        GT -> b:merge as  bs'
+        EQ -> a:merge as' bs'
+        LT -> a:merge as' bs
+    merge [] bs         = bs
+    merge as []         = as
+
+-- The following function does case-insensitive comparison of sequences.
+-- This is used to allow case-insensitive parsing, while
+-- the linearizer still has access to the original cases.
+
+compareCaseInsensitive []     []     = EQ
+compareCaseInsensitive []     _      = LT
+compareCaseInsensitive _      []     = GT
+compareCaseInsensitive (x:xs) (y:ys) =
+  case compareSym x y of
+    EQ -> compareCaseInsensitive xs ys
+    x  -> x
+  where
+    compareSym s1 s2 =
+      case s1 of
+        SymCat d1 r1
+          -> case s2 of
+               SymCat d2 r2
+                 -> case compare d1 d2 of
+                      EQ -> r1 `compare` r2
+                      x  -> x
+               _ -> LT
+        SymLit d1 r1
+          -> case s2 of
+               SymCat {} -> GT
+               SymLit d2 r2
+                 -> case compare d1 d2 of
+                      EQ -> r1 `compare` r2
+                      x  -> x
+               _ -> LT
+        SymVar d1 r1
+          -> if tagToEnum# (getTag s2 ># 2#)
+               then LT
+               else case s2 of
+                      SymVar d2 r2
+                        -> case compare d1 d2 of
+                             EQ -> r1 `compare` r2
+                             x  -> x
+                      _ -> GT
+        SymKS t1
+          -> if tagToEnum# (getTag s2 ># 3#)
+               then LT
+               else case s2 of
+                      SymKS t2 -> t1 `compareToken` t2
+                      _          -> GT
+        SymKP a1 b1
+          -> if tagToEnum# (getTag s2 ># 4#)
+               then LT
+               else case s2 of
+                      SymKP a2 b2
+                        -> case compare a1 a2 of
+                             EQ -> b1 `compare` b2
+                             x  -> x
+                      _ -> GT
+        _ -> let t1 = getTag s1
+                 t2 = getTag s2
+             in if tagToEnum# (t1 <# t2) 
+                  then LT
+                  else if tagToEnum# (t1 ==# t2)
+                         then EQ
+                         else GT
+  
+    compareToken []     []     = EQ
+    compareToken []     _      = LT
+    compareToken _      []     = GT
+    compareToken (x:xs) (y:ys)
+      | x == y    = compareToken xs ys
+      | otherwise = case compare (toLower x) (toLower y) of
+                      EQ -> case compareToken xs ys of
+                              EQ -> compare x y
+                              x  -> x
+                      x  -> x
+-}

src/compiler/api/GF/Compile/ModDeps.hs

@@ -0,0 +1,143 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : ModDeps
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/11 23:24:34 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.14 $
+--
+-- Check correctness of module dependencies. Incomplete.
+--
+-- AR 13\/5\/2003
+-----------------------------------------------------------------------------
+
+module GF.Compile.ModDeps (mkSourceGrammar,
+		moduleDeps,
+		openInterfaces,
+		requiredCanModules
+	       ) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Option
+import GF.Grammar.Printer
+import GF.Compile.Update
+import GF.Grammar.Lookup
+import GF.Infra.Modules
+
+import GF.Data.Operations
+
+import Control.Monad
+import Data.List
+
+-- | to check uniqueness of module names and import names, the
+-- appropriateness of import and extend types,
+-- to build a dependency graph of modules, and to sort them topologically
+mkSourceGrammar :: [SourceModule] -> Err SourceGrammar
+mkSourceGrammar ms = do
+  let ns = map fst ms
+  checkUniqueErr ns
+  mapM (checkUniqueImportNames ns . snd) ms
+  deps    <- moduleDeps ms
+  deplist <- either 
+               return 
+               (\ms -> Bad $ "circular modules" +++ unwords (map show ms)) $ 
+               topoTest deps
+  return $ MGrammar [(m, maybe undefined id $ lookup m ms)  | IdentM m _ <- deplist]
+
+checkUniqueErr ::  (Show i, Eq i) => [i] -> Err ()
+checkUniqueErr ms = do
+  let msg = checkUnique ms
+  if null msg then return () else Bad $ unlines msg
+
+-- | check that import names don't clash with module names
+checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err ()
+checkUniqueImportNames ns mo = test [n | OQualif n v <- opens mo, n /= v]
+ where
+   test ms = testErr (all (`notElem` ns) ms)
+                     ("import names clashing with module names among" +++ unwords (map prt ms))
+
+type Dependencies = [(IdentM Ident,[IdentM Ident])]
+
+-- | to decide what modules immediately depend on what, and check if the
+-- dependencies are appropriate
+moduleDeps :: [SourceModule] -> Err Dependencies
+moduleDeps ms = mapM deps ms where
+  deps (c,m) = errIn ("checking dependencies of module" +++ prt c) $ case mtype m of
+      MTConcrete a -> do
+        am <- lookupModuleType gr a
+        testErr (mtype am == MTAbstract) "the of-module is not an abstract syntax" 
+        chDep (IdentM c (MTConcrete a)) 
+              (extends m) (MTConcrete a) (opens m) MTResource
+      t -> chDep (IdentM c t) (extends m) t (opens m) t
+
+  chDep it es ety os oty = do
+    ems <- mapM (lookupModuleType gr) es
+    testErr (all (compatMType ety . mtype) ests) "inappropriate extension module type" 
+    let ab = case it of
+               IdentM _ (MTConcrete a) -> [IdentM a MTAbstract]
+               _ -> [] ---- 
+    return (it, ab ++
+                [IdentM e ety | e <- es] ++ 
+                [IdentM (openedModule o) oty | o <- os])
+
+  -- check for superficial compatibility, not submodule relation etc: what can be extended
+  compatMType mt0 mt = case (mt0,mt) of
+    (MTResource,   MTConcrete _) -> True
+    (MTInstance _, MTConcrete _) -> True
+    (MTInterface,  MTAbstract)   -> True
+    (MTConcrete _, MTConcrete _) -> True
+    (MTInstance _, MTInstance _) -> True
+    (MTInstance _, MTResource) -> True
+    (MTResource, MTInstance _) -> True
+    ---- some more?
+    _ -> mt0 == mt
+  -- in the same way; this defines what can be opened
+  compatOType mt0 mt = case mt0 of
+    MTAbstract -> mt == MTAbstract
+    _ -> case mt of
+      MTResource -> True
+      MTInterface -> True
+      MTInstance _ -> True
+      _ -> False      
+
+  gr = MGrammar ms --- hack
+
+openInterfaces :: Dependencies -> Ident -> Err [Ident]
+openInterfaces ds m = do
+  let deps = [(i,ds) | (IdentM i _,ds) <- ds]
+  let more (c,_) = [(i,mt) | Just is <- [lookup c deps], IdentM i mt <- is]
+  let mods = iterFix (concatMap more) (more (m,undefined))
+  return $ [i | (i,MTInterface) <- mods]
+
+-- | this function finds out what modules are really needed in the canonical gr.
+-- its argument is typically a concrete module name
+requiredCanModules :: (Ord i, Show i) => Bool -> MGrammar i a -> i -> [i]
+requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where
+  exts = allExtends gr c
+  ops  = if isSingle 
+         then map fst (modules gr)
+         else iterFix (concatMap more) $ exts
+  more i = errVal [] $ do
+    m <- lookupModule gr i
+    return $ extends m ++ [o | o <- map openedModule (opens m)]
+  notReuse i = errVal True $ do
+    m <- lookupModule gr i
+    return $ isModRes m -- to exclude reused Cnc and Abs from required
+
+
+{-
+-- to test
+exampleDeps = [
+  (ir "Nat",[ii "Gen", ir "Adj"]),
+  (ir "Adj",[ii "Num", ii "Gen", ir "Nou"]),
+  (ir "Nou",[ii "Cas"])
+  ]
+
+ii s = IdentM (IC s) MTInterface
+ir s = IdentM (IC s) MTResource
+-}
+

src/compiler/api/GF/Compile/Multi.hs

@@ -0,0 +1,165 @@
+module GF.Compile.Multi (readMulti) where
+
+import Data.List
+import Data.Char
+
+-- AR 29 November 2010
+-- quick way of writing a multilingual lexicon and (with some more work) a grammar
+-- also several modules in one file
+-- file suffix .gfm (GF Multi)
+
+
+{-
+-- This multi-line comment is a possible file in the format.
+-- comments are as in GF, one-liners
+
+-- always start by declaring lang names as follows
+> langs Eng Fin Swe
+
+-- baseline rules: semicolon-separated line-by-line entries update abs and cncs, adding to S
+cheers ; skål ; terveydeksi
+
+-- alternatives within a language are comma-separated
+cheers ; skål ; terveydeksi, kippis
+
+-- more advanced: verbatim abstract rules prefixed by "> abs"
+> abs cat Drink ;
+> abs fun drink : Drink -> S ;
+
+-- verbatim concrete rules prefixed by ">" and comma-separated language list
+> Eng,Swe lin Gin = "gin" ; 
+
+-- multiple modules: modules as usual. Each module has to start from a new line.
+-- Should be UTF-8 encoded.
+
+-}
+
+{-
+main = do
+  xx <- getArgs
+  if null xx then putStrLn usage else do 
+    let (opts,file) = (init xx, last xx)
+    (absn,cncns) <- readMulti opts file
+    if elem "-pgf" xx 
+      then do
+         system ("gf -make -s -optimize-pgf " ++ unwords (map gfFile cncns))
+         putStrLn $ "wrote " ++ absn ++ ".pgf"
+      else return ()
+-}
+
+readMulti :: FilePath -> IO (FilePath,[FilePath])
+readMulti file = do
+  src <- readFile file
+  let multi = getMulti (takeWhile (/='.') file) src
+      absn  = absName multi
+      cncns = cncNames multi
+      raws  = rawModules multi
+  writeFile (gfFile absn) (absCode multi)
+  mapM_ (uncurry writeFile) 
+        [(gfFile cncn, cncCode absn cncn cod) | 
+          cncn <- cncNames multi, let cod = [r | (la,r) <- cncRules multi, la == cncn]]
+  putStrLn $ "wrote " ++ unwords (map gfFile (absn:cncns))
+  mapM_ (uncurry writeFile) [(gfFile n,s) | (n,s) <- raws] --- overwrites those above
+  return (gfFile absn, map gfFile cncns)
+
+data Multi = Multi {
+  rawModules :: [(String,String)],
+  absName  :: String,
+  cncNames :: [String],
+  startCat :: String,
+  absRules :: [String],
+  cncRules :: [(String,String)] -- lang,lin
+  }
+
+emptyMulti :: Multi 
+emptyMulti = Multi {
+  rawModules = [],
+  absName  = "Abs",
+  cncNames = [],
+  startCat = "S",
+  absRules = [],
+  cncRules = []
+  }
+
+absCode :: Multi -> String
+absCode multi = unlines $ header : start ++ (reverse (absRules multi)) ++ ["}"] where
+  header = "abstract " ++ absName multi ++ " = {"
+  start  = ["flags startcat = " ++ cat ++ " ;", "cat " ++ cat ++ " ;"]
+  cat = startCat multi
+
+cncCode :: String -> String -> [String] -> String
+cncCode ab cnc rules = unlines $ header : (reverse rules ++ ["}"]) where
+  header = "concrete " ++ cnc ++ " of " ++ ab ++ " = {"
+
+getMulti :: String -> String -> Multi
+getMulti m s = foldl (flip addMulti) (emptyMulti{absName = m}) (modlines (lines s))
+
+addMulti :: String -> Multi -> Multi
+addMulti line multi = case line of
+  '-':'-':_ -> multi
+  _ | all isSpace line -> multi
+  '>':s -> case words s of
+     "langs":ws -> let las = [absName multi ++ w | w <- ws] in multi {
+       cncNames = las, 
+       cncRules = concat [[(la,"lincat " ++ startCat multi ++ " = Str ;"),
+                           (la,"flags coding = utf8 ;")] | la <- las]
+       }
+     "startcat":c:ws -> multi {startCat = c}
+     "abs":ws   -> multi {
+       absRules = unwords ws : absRules multi
+       }
+     langs:ws   -> multi {
+       cncRules = [(absName multi ++ la, unwords ws) | la <- chop ',' langs] ++ cncRules multi
+       }
+  _ -> case words line of
+        m:name:_ | isModule m -> multi {
+          rawModules = (name,line):rawModules multi
+          } 
+        _ -> let (cat,fun,lins) = getRules (startCat multi) line in 
+              multi {
+               absRules = ("fun " ++ fun ++ " : " ++ cat ++ " ;") : absRules multi,
+               cncRules = zip (cncNames multi) lins ++ cncRules multi
+               }
+
+getRules :: String -> String -> (String,String,[String])
+getRules cat line = (cat, fun, map lin rss) where
+  rss = map (map unspace . chop ',') $ chop ';' line
+  fun = map idChar (head (head rss)) ++ "_" ++ cat
+  lin rs = "lin " ++ fun ++ " = " ++ unwords (intersperse "|" (map quote rs)) ++ " ;"
+
+chop :: Eq c => c -> [c] -> [[c]]
+chop c cs = case break (==c) cs of
+  (w,_:cs2) -> w : chop c cs2
+  ([],[])   -> []
+  (w,_)     -> [w]
+
+-- remove spaces from beginning and end, leave them in the middle
+unspace :: String -> String
+unspace = unwords . words
+
+quote :: String -> String
+quote r = "\"" ++ r ++ "\""
+
+-- to guarantee that the char can be used in an ident
+idChar :: Char -> Char
+idChar c = 
+  if (n > 47 && n < 58) || (n > 64 && n < 91) || (n > 96 && n < 123) 
+  then c
+  else '_'
+ where n = fromEnum c
+
+
+gfFile :: FilePath -> FilePath
+gfFile f = f ++ ".gf"
+
+isModule :: String -> Bool
+isModule = flip elem 
+  ["abstract","concrete","incomplete","instance","interface","resource"]
+
+modlines :: [String] -> [String]
+modlines ss = case ss of
+  l:ls -> case words l of
+    w:_ | isModule w -> case break (isModule . concat . take 1 . words) ls of
+      (ms,rest) -> unlines (l:ms) : modlines rest
+    _ -> l : modlines ls
+  _ -> []

src/compiler/api/GF/Compile/OptimizePGF.hs

@@ -0,0 +1,191 @@
+{-# LANGUAGE BangPatterns #-}
+module GF.Compile.OptimizePGF(optimizePGF) where
+
+import PGF2(Cat,Fun)
+import PGF2.Transactions
+import Data.Array.ST
+import Data.Array.Unboxed
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.IntSet as IntSet
+import qualified Data.IntMap as IntMap
+import qualified Data.List as List
+import Control.Monad.ST
+
+type ConcrData = ()
+{-([(FId,[FunId])],          -- ^ Lindefs
+                  [(FId,[FunId])],          -- ^ Linrefs
+                  [(FId,[Production])],     -- ^ Productions
+                  [(Fun,[SeqId])],          -- ^ Concrete functions   (must be sorted by Fun)
+                  [[Symbol]],               -- ^ Sequences            (must be sorted)
+                  [(Cat,FId,FId,[String])]) -- ^ Concrete categories
+-}
+optimizePGF :: Cat -> ConcrData -> ConcrData
+optimizePGF startCat = error "TODO: optimizePGF" {- topDownFilter startCat . bottomUpFilter
+
+catString = "String"
+catInt    = "Int"
+catFloat  = "Float"
+catVar    = "__gfVar"
+
+topDownFilter :: Cat -> ConcrData -> ConcrData
+topDownFilter startCat (lindefs,linrefs,prods,cncfuns,sequences,cnccats) =
+  let env0             = (Map.empty,Map.empty)
+      (env1,lindefs')  = List.mapAccumL (\env (fid,funids) -> let (env',funids') = List.mapAccumL (optimizeFun fid [PArg [] fidVar]) env funids in (env',(fid,funids')))
+                                        env0
+                                        lindefs
+      (env2,linrefs')  = List.mapAccumL (\env (fid,funids) -> let (env',funids') = List.mapAccumL (optimizeFun fidVar [PArg [] fid]) env funids in (env',(fid,funids')))
+                                        env1
+                                        linrefs
+      (env3,prods')    = List.mapAccumL (\env (fid,set)    -> let (env',set') = List.mapAccumL (optimizeProd fid) env set in (env',(fid,set')))
+                                        env2
+                                        prods
+      cnccats' = map filterCatLabels cnccats
+      (sequences',cncfuns') = env3
+  in (lindefs',linrefs',prods',mkSetArray cncfuns',mkSetArray  sequences',cnccats')
+  where
+    cncfuns_array   = listArray (0,length cncfuns-1)   cncfuns   :: Array FunId (Fun, [SeqId])
+    sequences_array = listArray (0,length sequences-1) sequences :: Array SeqId [Symbol]
+    prods_map  = IntMap.fromList prods
+    fid2catMap = IntMap.fromList ((fidVar,catVar) :  [(fid,cat) | (cat,start,end,lbls) <- cnccats,
+                                                                  fid <- [start..end]])
+
+    fid2cat fid =
+      case IntMap.lookup fid fid2catMap of
+        Just cat -> cat
+        Nothing  -> case [fid | Just set <- [IntMap.lookup fid prods_map], PCoerce fid <- set] of
+                      (fid:_) -> fid2cat fid
+                      _       -> error "unknown forest id"
+
+    starts =
+      [(startCat,lbl) | (cat,_,_,lbls) <- cnccats, cat==startCat, lbl <- [0..length lbls-1]]
+
+    allRelations =
+      Map.unionsWith Set.union
+                     [rel fid prod | (fid,set) <- prods, prod <- set]
+      where
+        rel fid (PApply funid args) = Map.fromList [((fid2cat fid,lbl),deps args seqid) | (lbl,seqid) <- zip [0..] lin]
+          where
+            (_,lin) = cncfuns_array ! funid
+        rel fid _                   = Map.empty
+
+        deps args seqid = Set.fromList [let PArg _ fid = args !! r in (fid2cat fid,d) | SymCat r d <- seq]
+          where
+            seq = sequences_array ! seqid
+
+    -- here we create a mapping from a category to an array of indices.
+    -- An element of the array is equal to -1 if the corresponding index
+    -- is not going to be used in the optimized grammar, or the new index
+    -- if it will be used
+    closure :: Map.Map Cat [Int]
+    closure = runST $ do
+      set <- initSet
+      addLitCat catString set
+      addLitCat catInt    set
+      addLitCat catFloat  set
+      addLitCat catVar    set
+      closureSet set starts
+      doneSet set
+      where
+        initSet :: ST s (Map.Map Cat (STUArray s Int Int))
+        initSet =
+          fmap Map.fromList $ sequence
+                        [fmap ((,) cat) (newArray (0,length lbls-1) (-1))
+                                             | (cat,_,_,lbls) <- cnccats]
+
+        addLitCat cat set =
+          case Map.lookup cat set of
+            Just indices -> writeArray indices 0 0
+            Nothing      -> return ()
+
+        closureSet set []                 = return ()
+        closureSet set (x@(cat,index):xs) =
+          case Map.lookup cat set of
+            Just indices -> do v <- readArray indices index
+                               writeArray indices index 0
+                               if v < 0
+                                 then case Map.lookup x allRelations of
+                                        Just ys -> closureSet set (Set.toList ys++xs)
+                                        Nothing -> closureSet set xs
+                                 else closureSet set xs
+            Nothing      -> error "unknown cat"
+
+        doneSet :: Map.Map Cat (STUArray s Int Int) -> ST s (Map.Map Cat [Int])
+        doneSet set =
+          fmap Map.fromAscList $ mapM done (Map.toAscList set)
+          where
+            done (cat,indices) = do
+              indices <- fmap (reindex 0) (getElems indices)
+              return (cat,indices)
+
+            reindex k []     = []
+            reindex k (v:vs)
+              | v < 0        = v : reindex k     vs
+              | otherwise    = k : reindex (k+1) vs
+
+    optimizeProd res env (PApply funid args) =
+      let (env',funid') = optimizeFun res args env funid
+      in (env', PApply funid' args)
+    optimizeProd res env prod = (env,prod)
+
+    optimizeFun res args (seqs,funs) funid =
+      let (seqs',lin')   = List.mapAccumL addUnique seqs [map updateSymbol (sequences_array ! seqid) | 
+                                                                   (idx,seqid) <- zip (indicesOf res) lin, idx >= 0]
+          (funs',funid') = addUnique funs (fun, lin')
+      in ((seqs',funs'), funid')
+      where
+        (fun,lin) = cncfuns_array ! funid
+
+        indicesOf fid
+          | fid < 0   = [0]
+          | otherwise =
+              case Map.lookup (fid2cat fid) closure of
+                Just indices -> indices
+                Nothing      -> error "unknown category"
+
+        addUnique seqs seq =
+          case Map.lookup seq seqs of
+            Just seqid -> (seqs,seqid)
+            Nothing    -> let seqid = Map.size seqs
+                          in (Map.insert seq seqid seqs, seqid)
+
+        updateSymbol (SymCat r d) = let PArg _ fid = args !! r in SymCat r (indicesOf fid !! d)
+        updateSymbol s            = s
+
+    filterCatLabels (cat,start,end,lbls) =
+      case Map.lookup cat closure of
+        Just indices -> let lbls' = [lbl | (idx,lbl) <- zip indices lbls, idx >= 0]
+                        in (cat,start,end,lbls')
+        Nothing      -> error ("unknown category")
+
+    mkSetArray map = sortSnd (Map.toList map)
+      where
+        sortSnd = List.map fst . List.sortBy (\(_,i) (_,j) -> compare i j)
+
+
+bottomUpFilter :: ConcrData -> ConcrData
+bottomUpFilter (lindefs,linrefs,prods,cncfuns,sequences,cnccats) =
+  (lindefs,linrefs,filterProductions IntMap.empty IntSet.empty prods,cncfuns,sequences,cnccats)
+
+filterProductions prods0 hoc0 prods
+  | prods0 == prods1 = IntMap.toList prods0
+  | otherwise        = filterProductions prods1 hoc1 prods
+  where
+    (prods1,hoc1) = foldl foldProdSet (IntMap.empty,IntSet.empty) prods
+
+    foldProdSet (!prods,!hoc) (fid,set)
+      | null set1 = (prods,hoc)
+      | otherwise = (IntMap.insert fid set1 prods,hoc1)
+      where
+        set1 = filter filterRule set
+        hoc1 = foldl accumHOC hoc set1
+
+    filterRule (PApply funid args) = all (\(PArg _ fid) -> isLive fid) args
+    filterRule (PCoerce fid)       = isLive fid
+    filterRule _                   = True
+
+    isLive fid = isPredefFId fid || IntMap.member fid prods0 || IntSet.member fid hoc0
+
+    accumHOC hoc (PApply funid args) = List.foldl' (\hoc (PArg hypos _) -> List.foldl' (\hoc fid -> IntSet.insert fid hoc) hoc (map snd hypos)) hoc args
+    accumHOC hoc _                   = hoc
+-}

src/compiler/api/GF/Compile/PGFtoHaskell.hs

@@ -0,0 +1,353 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : PGFtoHaskell
+-- Maintainer  : Aarne Ranta
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/06/17 12:39:07 $
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.8 $
+--
+-- to write a GF abstract grammar into a Haskell module with translations from
+-- data objects into GF trees. Example: GSyntax for Agda.
+-- AR 11/11/1999 -- 7/12/2000 -- 18/5/2004
+-----------------------------------------------------------------------------
+
+module GF.Compile.PGFtoHaskell (grammar2haskell) where
+
+import PGF2
+
+import GF.Data.Operations
+import GF.Infra.Option
+
+import Data.List(isPrefixOf,find,intercalate,intersperse,groupBy,sortBy)
+import Data.Maybe(mapMaybe)
+import qualified Data.Map as Map
+
+type Prefix = String -> String
+type DerivingClause = String
+
+-- | the main function
+grammar2haskell :: Options
+                -> String  -- ^ Module name.
+                -> PGF
+                -> String
+grammar2haskell opts name gr = foldr (++++) [] $
+  pragmas ++ haskPreamble gadt name derivingClause (extraImports ++ pgfImports) ++
+  [types, gfinstances gId lexical gr'] ++ compos
+    where gr' = hSkeleton gr
+          gadt = haskellOption opts HaskellGADT
+          dataExt = haskellOption opts HaskellData
+          pgf2 = haskellOption opts HaskellPGF2
+          lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat
+          gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars
+              | otherwise = ("G"++) . rmForbiddenChars
+          -- GF grammars allow weird identifier names inside '', e.g. 'VP/Object'
+          rmForbiddenChars = filter (`notElem` "'!#$%&*+./<=>?@\\^|-~")
+          pragmas | gadt = ["{-# LANGUAGE GADTs, FlexibleInstances, KindSignatures, RankNTypes, TypeSynonymInstances #-}"]
+                  | dataExt = ["{-# LANGUAGE DeriveDataTypeable #-}"]
+                  | otherwise = []
+          derivingClause
+                 | dataExt = "deriving (Show,Data)"
+                 | otherwise = "deriving Show"
+          extraImports | gadt = ["import Control.Monad.Identity", "import Data.Monoid"]
+                       | dataExt = ["import Data.Data"]
+                       | otherwise = []
+          pgfImports | pgf2 = ["import PGF2 hiding (Tree)", "", "showCId :: CId -> String", "showCId = id"]
+                     | otherwise = ["import PGF hiding (Tree)"]
+          types | gadt = datatypesGADT gId lexical gr'
+                | otherwise = datatypes gId derivingClause lexical gr'
+          compos | gadt = prCompos gId lexical gr' ++ composClass
+                 | otherwise = []
+
+haskPreamble :: Bool -> String -> String -> [String] -> [String]
+haskPreamble gadt name derivingClause imports =
+ [
+  "module " ++ name ++ " where",
+  ""
+ ] ++ imports ++ [
+  "",
+  "----------------------------------------------------",
+  "-- automatic translation from GF to Haskell",
+  "----------------------------------------------------",
+  "",
+  "class Gf a where",
+  "  gf :: a -> Expr",
+  "  fg :: Expr -> a",
+  "",
+  predefInst gadt derivingClause "GString" "String"  "unStr"    "mkStr",
+  "",
+  predefInst gadt derivingClause "GInt"    "Int"     "unInt"    "mkInt",
+  "",
+  predefInst gadt derivingClause "GFloat"  "Double"  "unFloat"  "mkFloat",
+  "",
+  "----------------------------------------------------",
+  "-- below this line machine-generated",
+  "----------------------------------------------------",
+  ""
+ ]
+
+predefInst :: Bool -> String -> String -> String -> String -> String -> String
+predefInst gadt derivingClause gtyp typ destr consr =
+  (if gadt
+    then []
+    else "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n"
+    )
+  ++
+  "instance Gf" +++ gtyp +++ "where" ++++
+  "  gf (" ++ gtyp +++ "x) =" +++ consr +++ "x" ++++
+  "  fg t =" ++++
+  "    case "++destr++" t of" ++++
+  "      Just x  -> " +++ gtyp +++ "x" ++++
+  "      Nothing -> error (\"no" +++ gtyp +++ "\" ++ show t)"
+
+type OIdent = String
+
+type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
+
+datatypes :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (String,HSkeleton) -> String
+datatypes gId derivingClause lexical = foldr (+++++) "" . filter (/="") . map (hDatatype gId derivingClause lexical) . snd
+
+gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
+gfinstances gId lexical (m,g) = foldr (+++++) "" $ filter (/="") $ map (gfInstance gId lexical m) g
+
+
+hDatatype  :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
+hDatatype _ _ _ ("Cn",_) = "" ---
+hDatatype gId _ _ (cat,[]) = "data" +++ gId cat
+hDatatype gId derivingClause _ (cat,rules) | isListCat (cat,rules) =
+ "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]"
+  +++ derivingClause
+hDatatype gId derivingClause lexical (cat,rules) =
+ "data" +++ gId cat +++ "=" ++
+ (if length rules == 1 then "" else "\n  ") +++
+ foldr1 (\x y -> x ++ "\n |" +++ y) constructors ++++
+ " " +++ derivingClause
+  where
+    constructors = [gId f +++ foldr (+++) "" (map (gId) xx) | (f,xx) <- nonLexicalRules (lexical cat) rules]
+                   ++ if lexical cat then [lexicalConstructor cat +++ "String"] else []
+
+nonLexicalRules :: Bool -> [(OIdent, [OIdent])] -> [(OIdent, [OIdent])]
+nonLexicalRules False rules = rules
+nonLexicalRules True rules = [r | r@(f,t) <- rules, not (null t)]
+
+lexicalConstructor :: OIdent -> String
+lexicalConstructor cat = "Lex" ++ cat
+
+predefTypeSkel :: HSkeleton
+predefTypeSkel = [(c,[]) | c <- ["String", "Int", "Float"]]
+
+-- GADT version of data types
+datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
+datatypesGADT gId lexical (_,skel) = unlines $
+    concatMap (hCatTypeGADT gId) (skel ++ predefTypeSkel) ++
+    [
+      "",
+      "data Tree :: * -> * where"
+    ] ++
+    concatMap (map ("  "++) . hDatatypeGADT gId lexical) skel ++
+    [
+      "  GString :: String -> Tree GString_",
+      "  GInt :: Int -> Tree GInt_",
+      "  GFloat :: Double -> Tree GFloat_",
+      "",
+      "instance Eq (Tree a) where",
+      "  i == j = case (i,j) of"
+    ] ++
+    concatMap (map ("    "++) . hEqGADT gId lexical) skel ++
+    [
+      "    (GString x, GString y) -> x == y",
+      "    (GInt x, GInt y) -> x == y",
+      "    (GFloat x, GFloat y) -> x == y",
+      "    _ -> False"
+    ]
+
+hCatTypeGADT :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> [String]
+hCatTypeGADT gId (cat,rules)
+    = ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_",
+       "data"+++gId cat++"_"]
+
+hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
+hDatatypeGADT gId lexical (cat, rules)
+    | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t]
+    | otherwise =
+        [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t
+          | (f,args) <- nonLexicalRules (lexical cat) rules ]
+        ++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else []
+  where t = "Tree" +++ gId cat ++ "_"
+
+hEqGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
+hEqGADT gId lexical (cat, rules)
+  | isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs]
+  | otherwise = ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ eqs r | r <- nonLexicalRules (lexical cat) rules]
+          ++ if lexical cat then ["(" ++ lexicalConstructor cat +++ "x" ++ "," ++ lexicalConstructor cat +++ "y" ++ ") -> x == y"] else []
+
+ where
+   patt s (f,xs) = unwords (gId f : mkSVars s (length xs))
+   eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y |
+     (x,y) <- zip (mkSVars "x" (length xs)) (mkSVars "y" (length xs)) ] ++ ["]"])
+   listr c = (c,["foo"]) -- foo just for length = 1
+   listeqs = "and [x == y | (x,y) <- zip x1 y1]"
+
+prCompos :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> [String]
+prCompos gId lexical (_,catrules) =
+    ["instance Compos Tree where",
+     "  compos r a f t = case t of"]
+    ++
+    ["    " ++ prComposCons (gId f) xs | (c,rs) <- catrules, not (isListCat (c,rs)),
+                                         (f,xs) <- rs, not (null xs)]
+    ++
+    ["    " ++ prComposCons (gId c) ["x1"] | (c,rs) <- catrules, isListCat (c,rs)]
+    ++
+    ["    _ -> r t"]
+  where
+    prComposCons f xs = let vs = mkVars (length xs) in
+                        f +++ unwords vs +++ "->" +++ rhs f (zip vs xs)
+    rhs f vcs = "r" +++ f +++ unwords (map (prRec f) vcs)
+    prRec f (v,c)
+      | isList f  = "`a` foldr (a . a (r (:)) . f) (r [])" +++ v
+      | otherwise = "`a`" +++ "f" +++ v
+    isList f = gId "List" `isPrefixOf` f
+
+gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String
+gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs
+
+hInstance :: (String -> String) -> (String -> Bool) -> String -> (String, [(OIdent, [OIdent])]) -> String
+----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
+hInstance gId _ m (cat,[]) = unlines [
+  "instance Show" +++ gId cat,
+  "",
+  "instance Gf" +++ gId cat +++ "where",
+  "  gf _ = undefined",
+  "  fg _ = undefined"
+  ]
+hInstance gId lexical m (cat,rules)
+ | isListCat (cat,rules) =
+  "instance Gf" +++ gId cat +++ "where" ++++
+     "  gf (" ++ gId cat +++ "[" ++ intercalate "," baseVars ++ "])"
+           +++ "=" +++ mkRHS ("Base"++ec) baseVars ++++
+     "  gf (" ++ gId cat +++ "(x:xs)) = "
+           ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")]
+-- no show for GADTs
+--     ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)"
+ | otherwise =
+  "instance Gf" +++ gId cat +++ "where\n" ++
+  unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules]
+            ++ if lexical cat then ["  gf (" ++ lexicalConstructor cat +++ "x) = mkApp (mkCId x) []"] else [])
+ where
+   ec = elemCat cat
+   baseVars = mkVars (baseSize (cat,rules))
+   mkInst f xx = let xx' = mkVars (length xx) in "  gf " ++
+     (if null xx then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
+     "=" +++ mkRHS f xx'
+   mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++
+       "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
+
+mkVars :: Int -> [String]
+mkVars = mkSVars "x"
+
+mkSVars :: String -> Int -> [String]
+mkSVars s n = [s ++ show i | i <- [1..n]]
+
+----fInstance m ("Cn",_) = "" ---
+fInstance _ _ m (cat,[]) = ""
+fInstance gId lexical m (cat,rules) =
+  "  fg t =" ++++
+  (if isList
+    then "    " ++ gId cat ++ " (fgs t) where\n     fgs t = case unApp t of"
+    else "    case unApp t of") ++++
+  unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++
+  (if lexical cat then "      Just (i,[]) -> " ++ lexicalConstructor cat +++ "i" else "") ++++
+  "      _ -> error (\"no" +++ cat ++ " \" ++ show t)"
+   where
+    isList = isListCat (cat,rules)
+    mkInst f xx =
+     "      Just (i," ++
+     "[" ++ prTList "," xx' ++ "])" +++
+     "| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx'
+       where
+         xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
+         mkRHS f vars
+           | isList =
+               if "Base" `isPrefixOf` f
+                             then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
+                 else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
+           | otherwise =
+               gId f +++
+               prTList " " [prParenth ("fg" +++ x) | x <- vars]
+
+--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
+hSkeleton :: PGF -> (String,HSkeleton)
+hSkeleton gr = 
+  (abstractName gr,
+   let fs = 
+         [(c, [(f, cs) | (f, cs,_) <- fs]) | 
+                                        fs@((_, _,c):_) <- fns]
+   in fs ++ [(c, []) | c <- cts, notElem c (["Int", "Float", "String"] ++ map fst fs)]
+  )
+ where
+   cts = categories gr
+   fns = groupBy valtypg (sortBy valtyps (mapMaybe jty (functions gr)))
+   valtyps (_,_,x) (_,_,y) = compare x y
+   valtypg (_,_,x) (_,_,y) = x == y
+   jty f = case functionType gr f of
+             Just ty -> let (hypos,valcat,_) = unType ty
+                        in Just (f,[argcat | (_,_,ty) <- hypos, let (_,argcat,_) = unType ty],valcat)
+             Nothing -> Nothing
+{-
+updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
+updateSkeleton cat skel rule =
+ case skel of
+   (cat0,rules):rr | cat0 == cat -> (cat0, rule:rules) : rr
+   (cat0,rules):rr               -> (cat0, rules) : updateSkeleton cat rr rule
+-}
+isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool
+isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2
+        && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
+    where
+      c = elemCat cat
+      fs = map fst rules
+
+-- | Gets the element category of a list category.
+elemCat :: OIdent -> OIdent
+elemCat = drop 4
+{-
+isBaseFun :: OIdent -> Bool
+isBaseFun f = "Base" `isPrefixOf` f
+
+isConsFun :: OIdent -> Bool
+isConsFun f = "Cons" `isPrefixOf` f
+-}
+baseSize :: (OIdent, [(OIdent, [OIdent])]) -> Int
+baseSize (_,rules) = length bs
+    where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules
+
+composClass :: [String]
+composClass =
+    [
+     "",
+     "class Compos t where",
+     "  compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)",
+     "         -> (forall a. t a -> m (t a)) -> t c -> m (t c)",
+     "",
+     "composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c",
+     "composOp f = runIdentity . composOpM (Identity . f)",
+     "",
+     "composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c)",
+     "composOpM = compos return ap",
+     "",
+     "composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m ()",
+     "composOpM_ = composOpFold (return ()) (>>)",
+     "",
+     "composOpMonoid :: (Compos t, Monoid m) => (forall a. t a -> m) -> t c -> m",
+     "composOpMonoid = composOpFold mempty mappend",
+     "",
+     "composOpMPlus :: (Compos t, MonadPlus m) => (forall a. t a -> m b) -> t c -> m b",
+     "composOpMPlus = composOpFold mzero mplus",
+     "",
+     "composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b",
+     "composOpFold z c f = unC . compos (\\_ -> C z) (\\(C x) (C y) -> C (c x y)) (C . f)",
+     "",
+     "newtype C b a = C { unC :: b }"
+    ]

src/compiler/api/GF/Compile/PGFtoJava.hs

@@ -0,0 +1,43 @@
+module GF.Compile.PGFtoJava (grammar2java) where
+
+import PGF2
+import Data.Maybe(maybe)
+import Data.List(intercalate)
+import GF.Infra.Option
+
+-- | the main function
+grammar2java :: Options
+                -> String  -- ^ Module name.
+                -> PGF
+                -> String
+grammar2java opts name gr = unlines $  
+  javaPreamble name ++ methods ++ javaEnding
+  where
+    methods = [javaMethod gr fun | fun <- functions gr]
+
+javaPreamble name =
+ [
+  "import org.grammaticalframework.pgf.*;",
+  "",
+  "public class " ++ name ++ " {",
+  ""
+ ]
+ 
+javaMethod gr fun =
+  "  public static Expr "++fun++"("++arg_decls++") { return new Expr("++show fun++args++"); }"
+  where
+    arity = maybe 0 getArrity (functionType gr fun)
+    vars  = ['e':show i | i <- [1..arity]]
+    
+    arg_decls = intercalate "," ["Expr "++v | v <- vars]
+    args      = if null vars then ",new Expr[] {}" else ","++intercalate "," vars
+
+    getArrity ty = length hypos
+      where
+        (hypos,_,_) = unType ty
+
+javaEnding =
+ [
+  "",
+  "}"
+ ]

src/compiler/api/GF/Compile/ReadFiles.hs

@@ -0,0 +1,277 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : ReadFiles
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/11 23:24:34 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.26 $
+--
+-- Decide what files to read as function of dependencies and time stamps.
+--
+-- make analysis for GF grammar modules. AR 11\/6\/2003--24\/2\/2004
+--
+-- to find all files that have to be read, put them in dependency order, and
+-- decide which files need recompilation. Name @file.gf@ is returned for them,
+-- and @file.gfo@ otherwise.
+-----------------------------------------------------------------------------
+
+module GF.Compile.ReadFiles
+           ( getAllFiles,ModName,ModEnv,importsOfModule,
+             findFile,gfImports,gfoImports,VersionTagged(..),
+             parseSource,getOptionsFromFile,getPragmas) where
+
+import Prelude hiding (catch)
+import GF.System.Catch
+import GF.Infra.UseIO
+import GF.Infra.Option
+import GF.Infra.Ident
+import GF.Data.Operations
+import GF.Grammar.Lexer
+import GF.Grammar.Parser
+import GF.Grammar.Grammar
+import GF.Grammar.Binary(VersionTagged(..),decodeModuleHeader)
+
+import System.IO(mkTextEncoding)
+import GF.Text.Coding(decodeUnicodeIO)
+
+import qualified Data.ByteString.UTF8 as UTF8
+import qualified Data.ByteString.Char8 as BS
+
+import Control.Monad
+import Data.Maybe(isJust)
+import Data.Char(isSpace)
+import qualified Data.Map as Map
+import Data.Time(UTCTime)
+import GF.System.Directory(getModificationTime,doesFileExist,canonicalizePath)
+import System.FilePath
+import GF.Text.Pretty
+
+type ModName = String
+type ModEnv  = Map.Map ModName (UTCTime,[ModName])
+
+
+-- | Returns a list of all files to be compiled in topological order i.e.
+-- the low level (leaf) modules are first.
+--getAllFiles :: (MonadIO m,ErrorMonad m) => Options -> [InitPath] -> ModEnv -> FileName -> m [FullPath]
+getAllFiles opts ps env file = do
+  -- read module headers from all files recursively
+  ds <- reverse `fmap` get [] [] (justModuleName file)
+  putIfVerb opts $ "all modules:" +++ show [name | (name,_,_,_,_,_) <- ds]
+  return $ paths ds
+  where
+    -- construct list of paths to read
+    paths ds = concatMap mkFile ds
+      where
+        mkFile (f,st,time,has_src,imps,p) =
+          case st of 
+            CSComp             -> [p </> gfFile f]
+            CSRead | has_src   -> [gf2gfo opts (p </> gfFile f)]
+                   | otherwise -> [p </> gfoFile f]
+            CSEnv              -> []
+
+    -- | traverses the dependency graph and returns a topologicaly sorted
+    -- list of ModuleInfo. An error is raised if there is circular dependency
+ {- get :: [ModName]          -- ^ keeps the current path in the dependency graph to avoid cycles
+        -> [ModuleInfo]       -- ^ a list of already traversed modules
+        -> ModName            -- ^ the current module
+        -> IOE [ModuleInfo]   -- ^ the final -}
+    get trc ds name
+      | name `elem` trc = raise $ "circular modules" +++ unwords trc
+      | (not . null) [n | (n,_,_,_,_,_) <- ds, name == n]     --- file already read
+                        = return ds
+      | otherwise       = do
+           (name,st0,t0,has_src,imps,p) <- findModule name
+           ds <- foldM (get (name:trc)) ds imps
+           let (st,t) | has_src &&
+                        flag optRecomp opts == RecompIfNewer &&
+                        (not . null) [f | (f,st,t1,_,_,_) <- ds, elem f imps && liftM2 (>=) t0 t1 /= Just True]
+                                  = (CSComp,Nothing)
+                      | otherwise = (st0,t0)
+           return ((name,st,t,has_src,imps,p):ds)
+
+    gfoDir = flag optGFODir opts
+
+    -- searches for module in the search path and if it is found
+    -- returns 'ModuleInfo'. It fails if there is no such module
+  --findModule :: ModName -> IOE ModuleInfo
+    findModule name = do
+      (file,gfTime,gfoTime) <- findFile gfoDir ps name
+
+      let mb_envmod = Map.lookup name env
+          (st,t) = selectFormat opts (fmap fst mb_envmod) gfTime gfoTime
+
+      (st,(mname,imps)) <-
+          case st of
+            CSEnv  -> return (st, (name, maybe [] snd mb_envmod))
+            CSRead -> do let gfo = if isGFO file then file else gf2gfo opts file
+                         t_imps <- gfoImports gfo
+                         case t_imps of
+                           Tagged imps -> return (st,imps)
+                           WrongVersion
+                             | isGFO file -> raise (file ++ " is compiled with different GF version and I can't find the source file")
+                             | otherwise  -> do imps <- gfImports opts file
+                                                return (CSComp,imps)
+            CSComp -> do imps <- gfImports opts file
+                         return (st,imps)
+      testErr (mname == name)
+              ("module name" +++ mname +++ "differs from file name" +++ name)
+      return (name,st,t,isJust gfTime,imps,dropFileName file)
+--------------------------------------------------------------------------------
+
+findFile gfoDir ps name =
+    maybe noSource haveSource =<< getFilePath ps (gfFile name)
+  where
+    haveSource gfFile =
+      do gfTime  <- getModificationTime gfFile
+         mb_gfoTime <- maybeIO $ getModificationTime (gf2gfo' gfoDir gfFile)
+         return (gfFile, Just gfTime, mb_gfoTime)
+
+    noSource =
+        maybe noGFO haveGFO =<< getFilePath gfoPath (gfoFile name)
+      where
+        gfoPath = maybe id (:) gfoDir ps
+
+        haveGFO gfoFile =
+          do gfoTime <- getModificationTime gfoFile
+             return (gfoFile, Nothing, Just gfoTime)
+
+        noGFO = raise (render ("File" <+> gfFile name <+> "does not exist." $$
+                               "searched in:" <+> vcat ps))
+
+gfImports opts file = importsOfModule `fmap` parseModHeader opts file
+
+gfoImports gfo = fmap importsOfModule `fmap` decodeModuleHeader gfo
+
+--------------------------------------------------------------------------------
+
+-- From the given Options and the time stamps computes
+-- whether the module have to be computed, read from .gfo or
+-- the environment version have to be used
+selectFormat :: Options -> Maybe UTCTime -> Maybe UTCTime -> Maybe UTCTime -> (CompStatus,Maybe UTCTime)
+selectFormat opts mtenv mtgf mtgfo =
+  case (mtenv,mtgfo,mtgf) of
+    (_,_,Just tgf)         | fromSrc  -> (CSComp,Nothing)
+    (Just tenv,_,_)        | fromComp -> (CSEnv, Just tenv)
+    (_,Just tgfo,_)        | fromComp -> (CSRead,Just tgfo)
+    (Just tenv,_,Just tgf) | tenv > tgf -> (CSEnv, Just tenv)
+    (_,Just tgfo,Just tgf) | tgfo > tgf -> (CSRead,Just tgfo)
+    (Just tenv,_,Nothing) -> (CSEnv,Just tenv) -- source does not exist
+    (_,Just tgfo,Nothing) -> (CSRead,Just tgfo)  -- source does not exist
+    _ -> (CSComp,Nothing)
+  where
+    fromComp = flag optRecomp opts == NeverRecomp
+    fromSrc  = flag optRecomp opts == AlwaysRecomp
+
+
+-- internal module dep information
+
+
+data CompStatus =
+   CSComp -- compile: read gf
+ | CSRead -- read gfo
+ | CSEnv  -- gfo is in env
+  deriving Eq
+
+type ModuleInfo = (ModName,CompStatus,Maybe UTCTime,Bool,[ModName],InitPath)
+
+importsOfModule :: SourceModule -> (ModName,[ModName])
+importsOfModule (m,mi) = (modName m,depModInfo mi [])
+  where
+    depModInfo mi =
+      depModType (mtype mi)  .
+      depExtends (mextend mi) .
+      depWith    (mwith mi)  .
+      depExDeps  (mexdeps mi).
+      depOpens   (mopens mi)
+
+    depModType (MTAbstract)       xs = xs
+    depModType (MTResource)       xs = xs
+    depModType (MTInterface)      xs = xs
+    depModType (MTConcrete m2)    xs = modName m2:xs
+    depModType (MTInstance (m2,_))    xs = modName m2:xs
+
+    depExtends es xs = foldr depInclude xs es
+
+    depWith (Just (m,_,is)) xs = modName m : depInsts is xs
+    depWith Nothing         xs = xs
+
+    depExDeps eds xs = map modName eds ++ xs
+
+    depOpens os xs = foldr depOpen xs os
+
+    depInsts is xs = foldr depInst xs is
+
+    depInclude (m,_) xs = modName m:xs
+
+    depOpen (OSimple n  ) xs = modName n:xs
+    depOpen (OQualif _ n) xs = modName n:xs
+
+    depInst (m,n) xs = modName m:modName n:xs
+
+    modName (MN m) = showIdent m
+
+
+parseModHeader opts file =
+  do --ePutStrLn file
+     (_,parsed) <- parseSource opts pModHeader =<< liftIO (BS.readFile file)
+     case parsed of
+       Right mo          -> return mo
+       Left (Pn l c,msg) ->
+                  raise (file ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg)
+
+parseSource opts p raw =
+  do (coding,utf8) <- toUTF8 opts raw
+     return (coding,runP p utf8)
+
+toUTF8 opts0 raw =
+  do opts <- getPragmas raw
+     let given = flag optEncoding opts -- explicitly given encoding
+         coding = getEncoding $ opts0 `addOptions` opts
+     utf8 <- if coding=="UTF-8"
+             then return raw
+             else if coding=="CP1252" -- Latin1
+                  then return . UTF8.fromString $ BS.unpack raw -- faster
+                  else do --ePutStrLn $ "toUTF8 from "++coding
+                          recodeToUTF8 coding raw
+     return (given,utf8)
+
+recodeToUTF8 coding raw =
+  liftIO $
+  do enc <- mkTextEncoding coding
+     -- decodeUnicodeIO uses a lot of stack space,
+     -- so we need to split the file into smaller pieces
+     ls <- mapM (decodeUnicodeIO enc) (BS.lines raw)
+     return $ UTF8.fromString (unlines ls)
+
+-- | options can be passed to the compiler by comments in @--#@, in the main file
+--getOptionsFromFile :: (MonadIO m,ErrorMonad m) => FilePath -> m Options
+getOptionsFromFile file = do
+  opts <- either failed getPragmas =<< (liftIO $ try $ BS.readFile file)
+  -- The coding flag should not be inherited by other files
+  return (addOptions opts (modifyFlags $ \ f -> f{optEncoding=Nothing}))
+  where
+    failed _ = raise $ "File " ++ file ++ " does not exist"
+
+
+getPragmas :: (ErrorMonad m) => BS.ByteString -> m Options
+getPragmas = parseModuleOptions . 
+             map (BS.unpack . BS.unwords . BS.words . BS.drop 3) .
+             filter (BS.isPrefixOf (BS.pack "--#")) .
+--           takeWhile (BS.isPrefixOf (BS.pack "--")) .
+--           filter (not . BS.null) .
+             map (BS.dropWhile isSpace) .
+             BS.lines
+
+getFilePath :: MonadIO m => [FilePath] -> String -> m (Maybe FilePath)
+getFilePath paths file = get paths
+  where
+    get []     = return Nothing
+    get (p:ps) = do let pfile = p </> file
+                    exist <- doesFileExist pfile
+                    if not exist
+                      then get ps
+                      else do pfile <- canonicalizePath pfile
+                              return (Just pfile)

src/compiler/api/GF/Compile/Rename.hs

@@ -0,0 +1,345 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Rename
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/30 18:39:44 $
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.19 $
+--
+-- AR 14\/5\/2003
+-- The top-level function 'renameGrammar' does several things:
+--
+--   - extends each module symbol table by indirections to extended module
+--
+--   - changes unqualified and as-qualified imports to absolutely qualified
+--
+--   - goes through the definitions and resolves names
+--
+-- Dependency analysis between modules has been performed before this pass.
+-- Hence we can proceed by @fold@ing "from left to right".
+-----------------------------------------------------------------------------
+
+module GF.Compile.Rename (
+     renameSourceTerm,
+     renameModule
+    ) where
+
+import GF.Infra.Ident
+import GF.Infra.CheckM
+import GF.Grammar.Grammar
+import GF.Grammar.Values
+import GF.Grammar.Predef
+import GF.Grammar.Lookup
+import GF.Grammar.Macros
+import GF.Grammar.Printer
+import GF.Data.Operations
+
+import Control.Monad
+import Data.List (nub,(\\))
+import qualified Data.List as L
+import qualified Data.Map as Map
+import Data.Maybe(mapMaybe)
+import GF.Text.Pretty
+
+-- | this gives top-level access to renaming term input in the cc command
+renameSourceTerm :: Grammar -> ModuleName -> Term -> Check Term
+renameSourceTerm g m t = do
+  mi     <- lookupModule g m
+  status <- buildStatus "" g (m,mi)
+  renameTerm status [] t
+
+renameModule :: FilePath -> Grammar -> Module -> Check Module
+renameModule cwd gr mo@(m,mi) = do
+  status <- buildStatus cwd gr mo
+  js     <- checkMapRecover (renameInfo cwd status mo) (jments mi)
+  return (m, mi{jments = js})
+
+type Status = (StatusMap, [(OpenSpec, StatusMap)])
+
+type StatusMap = Map.Map Ident StatusInfo
+
+type StatusInfo = Ident -> Term
+
+-- Delays errors, allowing many errors to be detected and reported
+renameIdentTerm env = accumulateError (renameIdentTerm' env)
+
+-- Fails immediately on error, makes it possible to try other possibilities
+renameIdentTerm' :: Status -> Term -> Check Term
+renameIdentTerm' env@(act,imps) t0 =
+  case t0 of
+    Vr c -> ident predefAbs c
+    Cn c -> ident (\_ s -> checkError s) c
+    Q (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
+    Q (m',c) -> do
+      m <- lookupErr m' qualifs
+      f <- lookupIdent c m
+      return $ f c
+    QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
+    QC (m',c) -> do
+      m <- lookupErr m' qualifs
+      f <- lookupIdent c m
+      return $ f c
+    _ -> return t0
+  where
+    opens   = [st  | (OSimple _,st) <- imps]
+    qualifs = [(m, st) | (OQualif m _, st) <- imps] ++
+              [(m, st) | (OQualif _ m, st) <- imps] ++
+              [(m, st) | (OSimple m, st) <- imps] -- qualif is always possible
+
+    -- this facility is mainly for BWC with GF1: you need not import PredefAbs
+    predefAbs c s
+      | isPredefCat c = return (Q (cPredefAbs,c))
+      | otherwise     = checkError s
+
+    ident alt c =
+      case Map.lookup c act of
+        Just f -> return (f c)
+        _      -> case mapMaybe (Map.lookup c) opens of
+                    [f]  -> return (f c)
+                    []   -> alt c ("constant not found:" <+> c $$
+                                   "given" <+> fsep (punctuate ',' (map fst qualifs)))
+                    fs   -> case nub [f c | f <- fs]  of
+                              [tr]     -> return tr
+                              ts@(t:_) -> do checkWarn ("atomic term" <+> ppTerm Qualified 0 t0 $$
+                                                        "conflict" <+> hsep (punctuate ',' (map (ppTerm Qualified 0) ts)) $$
+                                                        "given" <+> fsep (punctuate ',' (map fst qualifs)))
+                                             return (bestTerm ts) -- Heuristic for resource grammar. Returns t for all others.
+       where
+        -- Hotfix for https://github.com/GrammaticalFramework/gf-core/issues/56
+        -- Real bug is probably somewhere deeper in recognising excluded functions. /IL 2020-06-06
+        notFromCommonModule :: Term -> Bool
+        notFromCommonModule term =
+          let t = render $ ppTerm Qualified 0 term :: String
+           in not $ any (\moduleName -> moduleName `L.isPrefixOf` t)
+                        ["CommonX", "ConstructX", "ExtendFunctor"
+                        ,"MarkHTMLX", "ParamX", "TenseX", "TextX"]
+
+        -- If one of the terms comes from the common modules,
+        -- we choose the other one, because that's defined in the grammar.
+        bestTerm :: [Term] -> Term
+        bestTerm [] = error "constant not found" -- not reached: bestTerm is only called for case ts@(t:_)
+        bestTerm ts@(t:_) =
+          let notCommon = [t | t <- ts, notFromCommonModule t]
+           in case notCommon of
+                []    -> t -- All terms are from common modules, return first of original list
+                (u:_) -> u -- ≥1 terms are not from common modules, return first of those
+
+info2status :: Maybe ModuleName -> Ident -> Info -> StatusInfo
+info2status mq c i = case i of
+  AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq
+  ResValue _ _ -> maybe Con (curry QC) mq
+  ResParam _ _ -> maybe Con (curry QC) mq
+  AnyInd True m -> maybe Con (const (curry QC m)) mq
+  AnyInd False m -> maybe Cn (const (curry Q m)) mq
+  _           -> maybe Cn (curry Q) mq
+
+tree2status :: OpenSpec -> Map.Map Ident Info -> StatusMap
+tree2status o = case o of
+  OSimple i   -> Map.mapWithKey (info2status (Just i))
+  OQualif i j -> Map.mapWithKey (info2status (Just j))
+
+buildStatus :: FilePath -> Grammar -> Module -> Check Status
+buildStatus cwd gr mo@(m,mi) = checkInModule cwd mi NoLoc empty $ do
+  let gr1  = prependModule gr mo
+      exts = [(OSimple m,mi) | (m,mi) <- allExtends gr1 m]
+  ops <- mapM (\o -> lookupModule gr1 (openedModule o) >>= \mi -> return (o,mi)) (mopens mi)
+  let sts = map modInfo2status (exts++ops)
+  return (if isModCnc mi
+            then (Map.empty,       reverse sts)  -- the module itself does not define any names
+            else (self2status m mi,reverse sts)) -- so the empty ident is not needed
+
+modInfo2status :: (OpenSpec,ModuleInfo) -> (OpenSpec, StatusMap)
+modInfo2status (o,mo) = (o,tree2status o (jments mo))
+
+self2status :: ModuleName -> ModuleInfo -> StatusMap
+self2status c m = Map.mapWithKey (info2status (Just c)) (jments m)
+
+
+renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info
+renameInfo cwd status (m,mi) i info =
+  case info of
+    AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco)
+    AbsFun  pty pa ptr poper -> liftM4 AbsFun (renTerm pty) (return pa) (renMaybe (mapM (renLoc (renEquation status))) ptr) (return poper)
+    ResOper pty ptr -> liftM2 ResOper (renTerm pty) (renTerm ptr)
+    ResOverload os tysts -> liftM (ResOverload os) (mapM (renPair (renameTerm status [])) tysts)
+    ResParam (Just pp) m -> do
+      pp' <- renLoc (mapM (renParam status)) pp
+      return (ResParam (Just pp') m)
+    ResValue t i -> do
+      t <- renLoc (renameTerm status []) t
+      return (ResValue t i)
+    CncCat mcat mdef mref mpr mpmcfg -> liftM5 CncCat (renTerm mcat) (renTerm mdef) (renTerm mref) (renTerm mpr) (return mpmcfg)
+    CncFun mty mtr mpr mpmcfg -> liftM3 (CncFun mty)         (renTerm mtr) (renTerm mpr) (return mpmcfg)
+    _ -> return info
+  where
+    renTerm = renPerh (renameTerm status [])
+
+    renPerh ren = renMaybe (renLoc ren)
+
+    renMaybe ren (Just x) = ren x >>= return . Just
+    renMaybe ren Nothing  = return Nothing
+
+    renLoc ren (L loc x) =
+      checkInModule cwd mi loc ("Happened in the renaming of" <+> i) $ do
+        x <- ren x
+        return (L loc x)
+
+    renPair ren (x, y) = do x <- renLoc ren x
+                            y <- renLoc ren y
+                            return (x, y)
+
+    renEquation :: Status -> Equation -> Check Equation
+    renEquation b (ps,t) = do
+        (ps',vs) <- liftM unzip $ mapM (renamePattern b) ps
+        t'       <- renameTerm b (concat vs) t
+        return (ps',t')
+
+    renParam :: Status -> Param -> Check Param
+    renParam env (c,co) = do
+      co' <- renameContext env co
+      return (c,co')
+
+renameTerm :: Status -> [Ident] -> Term -> Check Term
+renameTerm env vars = ren vars where
+  ren vs trm = case trm of
+    Abs b x t    -> liftM  (Abs b x) (ren (x:vs) t)
+    Prod bt x a b -> liftM2 (Prod bt x) (ren vs a) (ren (x:vs) b)
+    Typed a b  -> liftM2 Typed (ren vs a) (ren vs b)
+    Vr x
+      | elem x vs -> return trm
+      | otherwise -> renid trm
+    Cn _   -> renid trm
+    Con _  -> renid trm
+    Q _    -> renid trm
+    QC _   -> renid trm
+    T i cs -> do
+      i' <- case i of
+        TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
+        _ -> return i
+      liftM (T i') $ mapM (renCase vs) cs
+
+    Let (x,(m,a)) b -> do
+      m' <- case m of
+        Just ty -> liftM Just $ ren vs ty
+        _ -> return m
+      a' <- ren vs a
+      b' <- ren (x:vs) b
+      return $ Let (x,(m',a')) b'
+
+    P t@(Vr r) l                                               -- Here we have $r.l$ and this is ambiguous it could be either
+                                                               -- record projection from variable or constant $r$ or qualified expression with module $r$
+      | elem r vs -> return trm                                -- try var proj first ..
+      | otherwise -> checks [ renid' (Q (MN r,label2ident l))      -- .. and qualified expression second.
+                            , renid' t >>= \t -> return (P t l) -- try as a constant at the end
+                            , checkError ("unknown qualified constant" <+> trm)
+                            ]
+
+    EPatt minp maxp p -> do
+      (p',_) <- renpatt p
+      return $ EPatt minp maxp p'
+
+    _ -> composOp (ren vs) trm
+
+  renid = renameIdentTerm env
+  renid' = renameIdentTerm' env
+  renCase vs (p,t) = do
+    (p',vs') <- renpatt p
+    t' <- ren (vs' ++ vs) t
+    return (p',t')
+  renpatt = renamePattern env
+
+-- | vars not needed in env, since patterns always overshadow old vars
+renamePattern :: Status -> Patt -> Check (Patt,[Ident])
+renamePattern env patt =
+    do r@(p',vs) <- renp patt
+       let dupl = vs \\ nub vs
+       unless (null dupl) $ checkError (hang ("[C.4.13] Pattern is not linear. All variable names on the left-hand side must be distinct.") 4
+                                             patt)
+       return r
+  where
+    renp patt = case patt of
+      PMacro c -> do
+        c' <- renid $ Vr c
+        case c' of
+          Q d -> renp $ PM d
+          _ -> checkError ("unresolved pattern" <+> patt)
+
+      PC c ps -> do
+        c' <- renid $ Cn c
+        case c' of
+          QC c -> do psvss <- mapM renp ps
+                     let (ps,vs) = unzip psvss
+                     return (PP c ps, concat vs)
+          Q  _ -> checkError ("data constructor expected but" <+> ppTerm Qualified 0 c' <+> "is found instead")
+          _    -> checkError ("unresolved data constructor" <+> ppTerm Qualified 0 c')
+
+      PP c ps -> do
+        (QC c') <- renid (QC c)
+        psvss <- mapM renp ps
+        let (ps',vs) = unzip psvss
+        return (PP c' ps', concat vs)
+
+      PM c -> do
+        x <- renid (Q c)
+        c' <- case x of
+                (Q c') -> return c'
+                _      -> checkError ("not a pattern macro" <+> ppPatt Qualified 0 patt)
+        return (PM c', [])
+
+      PV x -> checks [ renid' (Vr x) >>= \t' -> case t' of
+                                                 QC c -> return (PP c [],[])
+                                                 _    -> checkError (pp "not a constructor")
+                     , return (patt, [x])
+                     ]
+
+      PR r -> do
+        let (ls,ps) = unzip r
+        psvss <- mapM renp ps
+        let (ps',vs') = unzip psvss
+        return (PR (zip ls ps'), concat vs')
+
+      PAlt p q -> do
+        (p',vs) <- renp p
+        (q',ws) <- renp q
+        return (PAlt p' q', vs ++ ws)
+
+      PSeq minp maxp p minq maxq q -> do
+        (p',vs) <- renp p
+        (q',ws) <- renp q
+        return (PSeq minp maxp p' minq maxq q', vs ++ ws)
+
+      PRep minp maxp p -> do
+        (p',vs) <- renp p
+        return (PRep minp maxp p', vs)
+
+      PNeg p -> do
+        (p',vs) <- renp p
+        return (PNeg p', vs)
+
+      PAs x p -> do
+        (p',vs) <- renp p
+        return (PAs x p', x:vs)
+
+      _ -> return (patt,[])
+
+    renid = renameIdentTerm env
+    renid' = renameIdentTerm' env
+
+renameContext :: Status -> Context -> Check Context
+renameContext b = renc [] where
+  renc vs cont = case cont of
+    (bt,x,t) : xts
+      | x == identW -> do
+          t'   <- ren vs t
+          xts' <- renc vs xts
+          return $ (bt,x,t') : xts'
+      | otherwise -> do
+          t'   <- ren vs t
+          let vs' = x:vs
+          xts' <- renc vs' xts
+          return $ (bt,x,t') : xts'
+    _ -> return cont
+  ren = renameTerm b

src/compiler/api/GF/Compile/SubExOpt.hs

@@ -0,0 +1,141 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : SubExOpt
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- This module implements a simple common subexpression elimination
+-- for .gfo grammars, to factor out shared subterms in lin rules.
+-- It works in three phases: 
+-- 
+--   (1) collectSubterms collects recursively all subterms of forms table and (P x..y)
+--       from lin definitions (experience shows that only these forms
+--       tend to get shared) and counts how many times they occur
+--   (2) addSubexpConsts takes those subterms t that occur more than once
+--       and creates definitions of form "oper A''n = t" where n is a
+--       fresh number; notice that we assume no ids of this form are in
+--       scope otherwise
+--   (3) elimSubtermsMod goes through lins and the created opers by replacing largest
+--       possible subterms by the newly created identifiers
+-- 
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleContexts #-}
+module GF.Compile.SubExOpt (subexpModule,unsubexpModule) where 
+
+import GF.Grammar.Grammar
+import GF.Grammar.Lookup(lookupResDef)
+import GF.Infra.Ident
+import qualified GF.Grammar.Macros as C
+import GF.Data.ErrM(fromErr)
+
+import Control.Monad.State.Strict(State,evalState,get,put)
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+
+--subexpModule :: SourceModule -> SourceModule
+subexpModule (n,mo) =
+  let ljs = Map.toList (jments mo)
+      tree = evalState (getSubtermsMod n ljs) (Map.empty,0)
+      js2 = Map.fromList $ addSubexpConsts n tree $ ljs
+  in (n,mo{jments=js2})
+
+--unsubexpModule :: SourceModule -> SourceModule
+unsubexpModule sm@(i,mo)
+  | hasSub ljs = (i,mo{jments=rebuild (map unparInfo ljs)})
+  | otherwise  = sm
+  where
+    ljs = Map.toList (jments mo) 
+
+    -- perform this iff the module has opers
+    hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs]
+    unparInfo (c,info) = case info of
+      CncFun xs (Just (L loc t)) m pf -> [(c, CncFun xs (Just (L loc (unparTerm t))) m pf)]
+      ResOper (Just (L loc (EInt 8))) _ -> [] -- subexp-generated opers
+      ResOper pty (Just (L loc t)) -> [(c, ResOper pty (Just (L loc (unparTerm t))))]
+      _ -> [(c,info)]
+    unparTerm t = case t of
+      Q (m,c) | isOperIdent c -> --- name convention of subexp opers
+        fromErr t $ fmap unparTerm $ lookupResDef gr (m,c)
+      _ -> C.composSafeOp unparTerm t
+    gr = mGrammar [sm]
+    rebuild = Map.fromList . concat
+
+-- implementation
+
+type TermList = Map Term (Int,Int) -- number of occs, id
+type TermM a = State (TermList,Int) a
+
+addSubexpConsts :: 
+  ModuleName -> Map Term (Int,Int) -> [(Ident,Info)] -> [(Ident,Info)]
+addSubexpConsts mo tree lins = do
+  let opers = [oper id trm | (trm,(_,id)) <- list]
+  map mkOne $ opers ++ lins
+ where
+   mkOne (f,def) = case def of
+     CncFun xs (Just (L loc trm)) pn pf ->
+       let trm' = recomp f trm
+       in (f,CncFun xs (Just (L loc trm')) pn pf)
+     ResOper ty (Just (L loc trm)) ->
+       let trm' = recomp f trm
+       in (f,ResOper ty (Just (L loc trm')))
+     _ -> (f,def)
+   recomp f t = case Map.lookup t tree of
+     Just (_,id) | operIdent id /= f -> Q (mo, operIdent id)
+     _ -> C.composSafeOp (recomp f) t
+
+   list = Map.toList tree
+
+   oper id trm = (operIdent id, ResOper (Just (L NoLoc (EInt 8))) (Just (L NoLoc trm))) 
+   --- impossible type encoding generated opers
+
+getSubtermsMod :: ModuleName -> [(Ident,Info)] -> TermM (Map Term (Int,Int))
+getSubtermsMod mo js = do
+  mapM (getInfo (collectSubterms mo)) js
+  (tree0,_) <- get
+  return $ Map.filter (\ (nu,_) -> nu > 1) tree0
+ where
+   getInfo get fi@(f,i) = case i of
+     CncFun xs (Just (L _ trm)) pn _ -> do
+       get trm
+       return $ fi
+     ResOper ty (Just (L _ trm)) -> do
+       get trm
+       return $ fi
+     _ -> return fi
+
+collectSubterms :: ModuleName -> Term -> TermM Term
+collectSubterms mo t = case t of
+  App f a -> do
+    collect f
+    collect a
+    add t 
+  T ty cs -> do
+    let (_,ts) = unzip cs
+    mapM collect ts
+    add t
+  V ty ts -> do
+    mapM collect ts
+    add t
+----  K (KP _ _)  -> add t
+  _ -> C.composOp (collectSubterms mo) t
+ where
+   collect = collectSubterms mo
+   add t = do
+     (ts,i) <- get
+     let 
+       ((count,id),next) = case Map.lookup t ts of
+         Just (nu,id) -> ((nu+1,id), i)
+         _ ->            ((1,   i ), i+1)
+     put (Map.insert t (count,id) ts, next)
+     return t --- only because of composOp
+
+operIdent :: Int -> Ident
+operIdent i = identC (operPrefix `prefixRawIdent` (rawIdentS (show i))) ---
+
+isOperIdent :: Ident -> Bool
+isOperIdent id = isPrefixOf operPrefix (ident2raw id)
+
+operPrefix = rawIdentS ("A''")

src/compiler/api/GF/Compile/Tags.hs

@@ -0,0 +1,89 @@
+module GF.Compile.Tags
+         ( writeTags
+         , gf2gftags
+         ) where
+
+import GF.Infra.Option
+import GF.Infra.UseIO
+import GF.Data.Operations
+import GF.Grammar
+
+--import Data.List
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+--import Control.Monad
+import GF.Text.Pretty
+import System.FilePath
+
+writeTags opts gr file mo = do
+  let imports = getImports opts gr mo
+      locals  = getLocalTags [] mo
+      txt     = unlines ((Set.toList . Set.fromList) (imports++locals))
+  putPointE Normal opts ("  write file" +++ file) $ liftIO $ writeFile file txt
+
+getLocalTags x (m,mi) = 
+  [showIdent i ++ "\t" ++ k ++ "\t" ++ l ++ "\t" ++ t 
+       | (i,jment) <- Map.toList (jments mi),
+         (k,l,t)   <- getLocations jment] ++ x
+  where
+    getLocations :: Info -> [(String,String,String)]
+    getLocations (AbsCat mb_ctxt)               = maybe (loc "cat")          mb_ctxt
+    getLocations (AbsFun mb_type _ mb_eqs _)    = maybe (ltype "fun")        mb_type ++
+                                                  maybe (list (loc "def"))   mb_eqs  
+    getLocations (ResParam mb_params _)         = maybe (loc "param")        mb_params
+    getLocations (ResValue mb_type _)           = ltype "param-value"          mb_type
+    getLocations (ResOper  mb_type mb_def)      = maybe (ltype "oper-type")  mb_type ++
+                                                  maybe (loc "oper-def")     mb_def
+    getLocations (ResOverload _ defs)           = list (\(x,y) -> ltype "overload-type" x ++ 
+                                                                  loc   "overload-def"  y) defs
+    getLocations (CncCat mty md mr mprn _)      = maybe (loc "lincat")       mty ++ 
+                                                  maybe (loc "lindef")       md  ++
+                                                  maybe (loc "linref")       mr  ++
+                                                  maybe (loc "printname")    mprn
+    getLocations (CncFun _ mlin mprn _)         = maybe (loc "lin")          mlin ++
+                                                  maybe (loc "printname")    mprn
+    getLocations _                              = []
+
+    loc kind (L loc _) = [(kind,render (ppLocation (msrc mi) loc),"")]
+
+    ltype kind (L loc ty) = [(kind,render (ppLocation (msrc mi) loc),render (ppTerm Unqualified 0 ty))]
+
+    maybe f (Just x) = f x
+    maybe f Nothing  = []
+
+    list f xs = concatMap f xs
+    
+    render = renderStyle style{mode=OneLineMode}
+
+
+getImports opts gr mo@(m,mi) = concatMap toDep allOpens
+  where
+    allOpens = [(OSimple m,incl) | (m,incl) <- mextend mi] ++ 
+               [(o,MIAll) | o <- mopens mi]
+
+    toDep (OSimple m,incl)     =
+      let Ok mi = lookupModule gr m
+      in [showIdent id ++ "\t" ++ "indir" ++ "\t" ++ render m ++ "\t\t" ++ gf2gftags opts (orig mi info)
+            | (id,info) <- Map.toList (jments mi), filter incl id]
+    toDep (OQualif m1 m2,incl) =
+      let Ok mi = lookupModule gr m2
+      in [showIdent id ++ "\t" ++ "indir" ++ "\t" ++ render m2 ++ "\t" ++ render m1 ++ "\t" ++ gf2gftags opts (orig mi info)
+            | (id,info) <- Map.toList (jments mi), filter incl id]
+
+    filter MIAll          id = True
+    filter (MIOnly   ids) id = elem id ids
+    filter (MIExcept ids) id = not (elem id ids)
+
+    orig mi info =
+      case info of
+        AnyInd _ m0 -> let Ok mi0 = lookupModule gr m0
+                       in msrc mi0
+        _           ->    msrc mi 
+
+gftagsFile :: FilePath -> FilePath
+gftagsFile f = addExtension f "gf-tags"
+
+gf2gftags :: Options -> FilePath -> FilePath
+gf2gftags opts file = maybe (gftagsFile (dropExtension file))
+                            (\dir -> dir </> gftagsFile (dropExtension (takeFileName file)))
+                            (flag optOutputDir opts)

src/compiler/api/GF/Compile/TypeCheck/Abstract.hs

@@ -0,0 +1,82 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : TypeCheck
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/09/15 16:22:02 $
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.16 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Compile.TypeCheck.Abstract (-- * top-level type checking functions; TC should not be called directly.
+    checkContext,
+    checkTyp,
+    checkDef,
+    checkConstrs,
+   ) where
+
+import GF.Data.Operations
+
+import GF.Infra.CheckM
+import GF.Grammar
+import GF.Grammar.Lookup
+import GF.Grammar.Unify
+--import GF.Compile.Refresh
+--import GF.Compile.Compute.Abstract
+import GF.Compile.TypeCheck.TC
+
+import GF.Text.Pretty
+--import Control.Monad (foldM, liftM, liftM2)
+
+-- | invariant way of creating TCEnv from context
+initTCEnv gamma =
+  (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma)
+
+-- interface to TC type checker
+
+type2val :: Type -> Val
+type2val = VClos []
+
+cont2exp :: Context -> Term
+cont2exp c = mkProd c eType [] -- to check a context
+
+cont2val :: Context -> Val
+cont2val = type2val . cont2exp
+
+-- some top-level batch-mode checkers for the compiler
+
+justTypeCheck :: SourceGrammar -> Term -> Val -> Err Constraints
+justTypeCheck gr e v = do
+  (_,constrs0) <- checkExp (grammar2theory gr) (initTCEnv []) e v
+  (constrs1,_) <- unifyVal constrs0
+  return $ filter notJustMeta constrs1
+
+notJustMeta (c,k) = case (c,k) of
+    (VClos g1 (Meta m1), VClos g2 (Meta m2)) -> False
+    _ -> True
+
+grammar2theory :: SourceGrammar -> Theory
+grammar2theory gr (m,f) = case lookupFunType gr m f of
+  Ok t -> return $ type2val t
+  Bad s -> case lookupCatContext gr m f of
+    Ok cont -> return $ cont2val cont
+    _ -> Bad s
+
+checkContext :: SourceGrammar -> Context -> [Message]
+checkContext st = checkTyp st . cont2exp
+
+checkTyp :: SourceGrammar -> Type -> [Message]
+checkTyp gr typ = err (\x -> [pp x]) ppConstrs $ justTypeCheck gr typ vType
+
+checkDef :: SourceGrammar -> Fun -> Type -> Equation -> [Message]
+checkDef gr (m,fun) typ eq = err (\x -> [pp x]) ppConstrs $ do
+  (b,cs) <- checkBranch (grammar2theory gr) (initTCEnv []) eq (type2val typ)
+  (constrs,_) <- unifyVal cs
+  return $ filter notJustMeta constrs
+
+checkConstrs :: SourceGrammar -> Cat -> [Ident] -> [String]
+checkConstrs gr cat _ = [] ---- check constructors!

src/compiler/api/GF/Compile/TypeCheck/Concrete.hs

@@ -0,0 +1,852 @@
+{-# LANGUAGE PatternGuards #-}
+module GF.Compile.TypeCheck.Concrete( checkLType, inferLType, computeLType, ppType ) where
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
+
+import GF.Infra.CheckM
+import GF.Data.Operations
+
+import GF.Grammar
+import GF.Grammar.Lookup
+import GF.Grammar.Predef
+import GF.Grammar.PatternMatch
+import GF.Grammar.Lockfield (isLockLabel, lockRecType, unlockRecord)
+import GF.Compile.Compute.Concrete(normalForm)
+import GF.Compile.TypeCheck.Primitives
+
+import Data.List
+import Data.Maybe(fromMaybe,isJust,isNothing)
+import Control.Monad
+import GF.Text.Pretty
+
+computeLType :: SourceGrammar -> Context -> Type -> Check Type
+computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
+ where
+  comp g ty = case ty of
+    _ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed
+      | isPredefConstant ty     -> return ty ---- shouldn't be needed
+
+    Q (m,ident) -> checkIn ("module" <+> m) $ do
+      ty' <- lookupResDef gr (m,ident)
+      if ty' == ty then return ty else comp g ty' --- is this necessary to test?
+
+    AdHocOverload ts -> do
+     over <- getOverload gr g (Just typeType) t
+     case over of
+       Just (tr,_) -> return tr
+       _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 t)
+
+    Vr ident  -> checkLookup ident g -- never needed to compute!
+
+    App f a -> do
+      f' <- comp g f
+      a' <- comp g a
+      case f' of
+        Abs b x t -> comp ((b,x,a'):g) t
+        _ -> return $ App f' a'
+
+    Prod bt x a b -> do
+      a' <- comp g a
+      b' <- comp ((bt,x,Vr x) : g) b
+      return $ Prod bt x a' b'
+
+    Abs bt x b -> do
+      b' <- comp ((bt,x,Vr x):g) b
+      return $ Abs bt x b'
+
+    Let (x,(_,a)) b -> comp ((Explicit,x,a):g) b
+
+    ExtR r s -> do
+      r' <- comp g r
+      s' <- comp g s
+      case (r',s') of
+        (RecType rs, RecType ss) -> plusRecType r' s' >>= comp g
+        _ -> return $ ExtR r' s'
+
+    RecType fs -> do
+      let fs' = sortRec fs
+      liftM RecType $ mapPairsM (comp g) fs'
+
+    ELincat c t -> do
+      t' <- comp g t
+      lockRecType c t' ---- locking to be removed AR 20/6/2009
+
+    _ | ty == typeTok -> return typeStr
+
+    _ -> composOp (comp g) ty
+
+-- the underlying algorithms
+
+inferLType :: SourceGrammar -> Context -> Term -> Check (Term, Type)
+inferLType gr g trm = case trm of
+
+   Q (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
+                                                Just ty -> return ty
+                                                Nothing -> checkError ("unknown in Predef:" <+> ident)
+
+   Q ident -> checks [
+     termWith trm $ lookupResType gr ident >>= computeLType gr g
+     ,
+     lookupResDef gr ident >>= inferLType gr g
+     ,
+     checkError ("cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
+     ]
+
+   QC (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
+                                                 Just ty -> return ty
+                                                 Nothing -> checkError ("unknown in Predef:" <+> ident)
+
+   QC ident -> checks [
+       termWith trm $ lookupResType gr ident >>= computeLType gr g
+       ,
+       lookupResDef gr ident >>= inferLType gr g
+       ,
+       checkError ("cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
+       ]
+
+   Vr ident -> termWith trm $ checkLookup ident g
+
+   Typed e t -> do
+     t' <- computeLType gr g t
+     checkLType gr g e t'
+
+   AdHocOverload ts -> do
+     over <- getOverload gr g Nothing trm
+     case over of
+       Just trty -> return trty
+       _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm)
+
+   App f a -> do
+     over <- getOverload gr g Nothing trm
+     case over of
+       Just trty -> return trty
+       _ -> do
+         (f',fty) <- inferLType gr g f
+         fty' <- computeLType gr g fty
+         case fty' of
+           Prod bt z arg val -> do
+             a' <- justCheck g a arg
+             ty <- if z == identW
+                      then return val
+                      else substituteLType [(bt,z,a')] val
+             return (App f' a',ty)
+           _ ->
+             let term = ppTerm Unqualified 0 f
+                 funName = pp . head . words .render $ term
+              in checkError ("A function type is expected for" <+> term <+> "instead of type" <+> ppType fty $$
+                             "\n   ** Maybe you gave too many arguments to" <+> funName <+> "\n")
+
+   S f x -> do
+     (f', fty) <- inferLType gr g f
+     case fty of
+       Table arg val -> do
+         x'<- justCheck g x arg
+         return (S f' x', val)
+       _ -> checkError ("table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm))
+
+   P t i -> do
+     (t',ty) <- inferLType gr g t   --- ??
+     ty' <- computeLType gr g ty
+     let tr2 = P t' i
+     termWith tr2 $ case ty' of
+       RecType ts -> case lookup i ts of
+                       Nothing -> checkError ("unknown label" <+> i <+> "in" $$ nest 2 (ppTerm Unqualified 0 ty'))
+                       Just x  -> return x
+       _          -> checkError ("record type expected for:" <+> ppTerm Unqualified 0 t $$
+                                 " instead of the inferred:" <+> ppTerm Unqualified 0 ty')
+
+   R r -> do
+     let (ls,fs) = unzip r
+     fsts <- mapM inferM fs
+     let ts = [ty | (Just ty,_) <- fsts]
+     checkCond ("cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts)
+     return $ (R (zip ls fsts), RecType (zip ls ts))
+
+   T (TTyped arg) pts -> do
+     (_,val) <- checks $ map (inferCase (Just arg)) pts
+     checkLType gr g trm (Table arg val)
+   T (TComp arg) pts -> do
+     (_,val) <- checks $ map (inferCase (Just arg)) pts
+     checkLType gr g trm (Table arg val)
+   T ti pts -> do  -- tries to guess: good in oper type inference
+     let pts' = [pt | pt@(p,_) <- pts, isConstPatt p]
+     case pts' of
+       [] -> checkError ("cannot infer table type of" <+> ppTerm Unqualified 0 trm)
+----       PInt k : _ -> return $ Ints $ max [i | PInt i <- pts']
+       _  -> do
+         (arg,val) <- checks $ map (inferCase Nothing) pts'
+         checkLType gr g trm (Table arg val)
+   V arg pts -> do
+     (_,val) <- checks $ map (inferLType gr g) pts
+--   return (trm, Table arg val) -- old, caused issue 68
+     checkLType gr g trm (Table arg val)
+
+   K s  ->
+     let trm' = case words s of
+                  []     -> Empty
+                  [w]    -> K w
+                  (w:ws) -> foldl (\t -> C t . K) (K w) ws
+     in return (trm', typeStr)
+
+   EInt i -> return (trm, typeInt)
+
+   EFloat i -> return (trm, typeFloat)
+
+   Empty -> return (trm, typeStr)
+
+   C s1 s2 ->
+     check2 (flip (justCheck g) typeStr) C s1 s2 typeStr
+
+   Glue s1 s2 ->
+     check2 (flip (justCheck g) typeStr) Glue s1 s2 typeStr ---- typeTok
+
+---- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007
+   Strs (Cn c : ts) | c == cConflict -> do
+     checkWarn ("unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts))
+     inferLType gr g (head ts)
+
+   Strs ts -> do
+     ts' <- mapM (\t -> justCheck g t typeStr) ts
+     return (Strs ts', typeStrs)
+
+   Alts t aa -> do
+     t'  <- justCheck g t typeStr
+     aa' <- flip mapM aa (\ (c,v) -> do
+        c' <- justCheck g c typeStr
+        v' <- checks $ map (justCheck g v) [typeStrs, EPattType typeStr]
+        v' <- case v' of
+                Q q -> do t <- lookupResDef gr q
+                          t <- normalForm gr t
+                          case t of
+                            EPatt _ _ p -> mkStrs p
+                            _           -> return v'
+                _   -> return v'
+        return (c',v'))
+     return (Alts t' aa', typeStr)
+
+   RecType r -> do
+     let (ls,ts) = unzip r
+     ts' <- mapM (flip (justCheck g) typeType) ts
+     return (RecType (zip ls ts'), typeType)
+
+   ExtR r s -> do
+     (r',rT) <- inferLType gr g r
+     rT'     <- computeLType gr g rT
+
+     (s',sT) <- inferLType gr g s
+     sT'     <- computeLType gr g sT
+
+     let trm' = ExtR r' s'
+     case (rT', sT') of
+       (RecType rs, RecType ss) -> do
+         let rt = RecType ([field | field@(l,_) <- rs, notElem l (map fst ss)] ++ ss) -- select types of later fields
+         checkLType gr g trm' rt ---- return (trm', rt)
+       _ | rT' == typeType && sT' == typeType -> do
+         return (trm', typeType)
+       _ -> checkError ("records or record types expected in" <+> ppTerm Unqualified 0 trm)
+
+   Sort _     ->
+     termWith trm $ return typeType
+
+   Prod bt x a b -> do
+     a' <- justCheck g a typeType
+     b' <- justCheck ((bt,x,a'):g) b typeType
+     return (Prod bt x a' b', typeType)
+
+   Table p t  -> do
+     p' <- justCheck g p typeType --- check p partype!
+     t' <- justCheck g t typeType
+     return $ (Table p' t', typeType)
+
+   FV vs -> do
+     (_,ty) <- checks $ map (inferLType gr g) vs
+---     checkIfComplexVariantType trm ty
+     checkLType gr g trm ty
+
+   EPattType ty -> do
+     ty' <- justCheck g ty typeType
+     return (EPattType ty',typeType)
+   EPatt _ _ p -> do
+     ty <- inferPatt p
+     (minp,maxp,p') <- measurePatt gr p
+     return (EPatt minp maxp p', EPattType ty)
+
+   ELin c trm -> do
+     (trm',ty) <- inferLType gr g trm
+     ty' <- lockRecType c ty ---- lookup c; remove lock AR 20/6/2009
+     return $ (ELin c trm', ty')
+
+   _ -> checkError ("cannot infer lintype of" <+> ppTerm Unqualified 0 trm)
+
+ where
+   isPredef m = elem m [cPredef,cPredefAbs]
+
+   justCheck g ty te = checkLType gr g ty te >>= return . fst
+
+   -- for record fields, which may be typed
+   inferM (mty, t) = do
+     (t', ty') <- case mty of
+       Just ty -> checkLType gr g t ty
+       _ -> inferLType gr g t
+     return (Just ty',t')
+
+   inferCase mty (patt,term) = do
+     arg  <- maybe (inferPatt patt) return mty
+     cont <- pattContext gr g arg patt
+     (term',val) <- inferLType gr (reverse cont ++ g) term
+     return (arg,val)
+   isConstPatt p = case p of
+     PC _ ps -> True --- all isConstPatt ps
+     PP _ ps -> True --- all isConstPatt ps
+     PR ps -> all (isConstPatt . snd) ps
+     PT _ p -> isConstPatt p
+     PString _ -> True
+     PInt _ -> True
+     PFloat _ -> True
+     PChar -> True
+     PChars _ -> True
+     PSeq _ _ p _ _ q -> isConstPatt p && isConstPatt q
+     PAlt p q -> isConstPatt p && isConstPatt q
+     PRep _ _ p -> isConstPatt p
+     PNeg p -> isConstPatt p
+     PAs _ p -> isConstPatt p
+     _ -> False
+
+   inferPatt p = case p of
+     PP (q,c) ps | q /= cPredef -> liftM valTypeCnc (lookupResType gr (q,c))
+     PAs _ p  -> inferPatt p
+     PNeg p   -> inferPatt p
+     PAlt p q -> checks [inferPatt p, inferPatt q]
+     PSeq _ _ _ _ _ _ -> return $ typeStr
+     PRep _ _ _ -> return $ typeStr
+     PChar    -> return $ typeStr
+     PChars _ -> return $ typeStr
+     _ -> inferLType gr g (patt2term p) >>= return . snd
+
+measurePatt gr p =
+  case p of
+    PM q       -> do t <- lookupResDef gr q
+                     t <- normalForm gr t
+                     case t of
+                       EPatt minp maxp _ -> return (minp,maxp,p)
+                       _                 -> checkError ("Expected pattern macro, but found:" $$ nest 2 (pp t))
+    PR ass     -> do ass <- mapM (\(lbl,p) -> measurePatt gr p >>= \(_,_,p') -> return (lbl,p')) ass
+                     return (0,Nothing,PR ass)
+    PString s  -> do let len=length s
+                     return (len,Just len,p)
+    PT t p     -> do (min,max,p') <- measurePatt gr p
+                     return (min,max,PT t p')
+    PAs x p    -> do (min,max,p) <- measurePatt gr p
+                     case p of
+                       PW -> return (0,Nothing,PV x)
+                       _  -> return (min,max,PAs x p)
+    PImplArg p -> do (min,max,p') <- measurePatt gr p
+                     return (min,max,PImplArg p')
+    PNeg p     -> do (_,_,p') <- measurePatt gr p
+                     return (0,Nothing,PNeg p')
+    PAlt p1 p2 -> do (min1,max1,p1) <- measurePatt gr p1
+                     (min2,max2,p2) <- measurePatt gr p2
+                     case (p1,p2) of
+                       (PString [c1],PString [c2]) -> return (1,Just 1,PChars [c1,c2])
+                       (PString [c], PChars cs)    -> return (1,Just 1,PChars ([c]++cs))
+                       (PChars cs,   PString [c])  -> return (1,Just 1,PChars (cs++[c]))
+                       (PChars cs1,  PChars cs2)   -> return (1,Just 1,PChars (cs1++cs2))
+                       _                           -> return (min min1 min2,liftM2 max max1 max2,PAlt p1 p2)
+    PSeq _ _ p1 _ _ p2
+               -> do (min1,max1,p1) <- measurePatt gr p1
+                     (min2,max2,p2) <- measurePatt gr p2
+                     case (p1,p2) of
+                       (PW,        PW        ) -> return (0,Nothing,PW)
+                       (PString s1,PString s2) -> return (min1+min2,liftM2 (+) max1 max2,PString (s1++s2))
+                       _                       -> return (min1+min2,liftM2 (+) max1 max2,PSeq min1 max1 p1 min2 max2 p2)
+    PRep _ _ p -> do (minp,maxp,p) <- measurePatt gr p
+                     case p of
+                       PW    -> return (0,Nothing,PW)
+                       PChar -> return (0,Nothing,PW)
+                       _     -> return (0,Nothing,PRep minp maxp p)
+    PChar      -> return (1,Just 1,p)
+    PChars _   -> return (1,Just 1,p)
+    _          -> return (0,Nothing,p)
+
+-- type inference: Nothing, type checking: Just t
+-- the latter permits matching with value type
+getOverload :: SourceGrammar -> Context -> Maybe Type -> Term -> Check (Maybe (Term,Type))
+getOverload gr g mt ot = case appForm ot of
+     (f@(Q c), ts) -> case lookupOverload gr c of
+       Ok typs -> do
+         ttys <- mapM (inferLType gr g) ts
+         v <- matchOverload f typs ttys
+         return $ Just v
+       _ -> return Nothing
+     (AdHocOverload cs@(f:_), ts) -> do     --- the function name f is only used in error messages
+       let typs = concatMap collectOverloads cs
+       ttys <- mapM (inferLType gr g) ts
+       v <- matchOverload f typs ttys
+       return $ Just v
+     _ -> return Nothing
+
+ where
+   collectOverloads tr@(Q c) = case lookupOverload gr c of
+     Ok typs -> typs
+     _ -> case lookupResType gr c of
+       Ok ty -> let (args,val) = typeFormCnc ty in [(map (\(b,x,t) -> t) args,(val,tr))]
+       _ -> []
+   collectOverloads _ = [] --- constructors QC
+
+   matchOverload f typs ttys = do
+     let (tts,tys) = unzip ttys
+     let vfs = lookupOverloadInstance tys typs
+     let matches = [vf | vf@((_,v,_),_) <- vfs, matchVal mt v]
+     let showTypes ty = hsep (map ppType ty)
+
+
+     let (stys,styps) = (showTypes tys, [showTypes ty | (ty,_) <- typs])
+
+     -- to avoid strange error msg e.g. in case of unmatch record extension, show whole types if needed AR 28/1/2013
+     let (stysError,stypsError) = if elem (render stys) (map render styps)
+            then (hsep (map (ppTerm Unqualified 0) tys), [hsep (map (ppTerm Unqualified 0) ty) | (ty,_) <- typs])
+            else (stys,styps)
+
+     case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of
+       ([(_,val,fun)],_) -> return (mkApp fun tts, val)
+       ([],[(pre,val,fun)]) -> do
+         checkWarn $  "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$
+                      "for" $$
+                      nest 2 (showTypes tys) $$
+                      "using" $$
+                      nest 2 (showTypes pre)
+         return (mkApp fun tts, val)
+       ([],[]) -> do
+         checkError $ "no overload instance of" <+> ppTerm Qualified 0 f $$
+                      maybe empty (\x -> "with value type" <+> ppType x) mt $$
+                      "for argument list" $$
+                      nest 2 stysError $$
+                      "among alternatives" $$
+                      nest 2 (vcat stypsError)
+
+
+       (vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of
+         ([(val,fun)],_) -> do
+           return (mkApp fun tts, val)
+         ([],[(val,fun)]) -> do
+           checkWarn ("ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot)
+           return (mkApp fun tts, val)
+
+----- unsafely exclude irritating warning AR 24/5/2008
+-----           checkWarn $ "overloading of" +++ prt f +++
+-----             "resolved by excluding partial applications:" ++++
+-----             unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)]
+
+--- now forgiving ambiguity with a warning AR 1/2/2014
+--  This gives ad hoc overloading the same behaviour as the choice of the first match in renaming did before.
+--  But it also gives a chance to ambiguous overloadings that were banned before.
+         (nps1,nps2) -> do
+              checkWarn $  "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+>
+                  ----     "with argument types" <+> hsep (map (ppTerm Qualified 0) tys) $$
+                           "resolved by selecting the first of the alternatives" $$
+                           nest 2 (vcat [ppTerm Qualified 0 fun | (_,ty,fun) <- vfs1 ++ if null vfs1 then vfs2 else []])
+              case [(mkApp fun tts,val) | (val,fun) <- nps1 ++ nps2] of
+                 [] -> checkError $ "no alternatives left when resolving" <+> ppTerm Unqualified 0 f
+                 h:_ -> return h
+
+   matchVal mt v = elem mt [Nothing,Just v,Just (unlocked v)]
+
+   unlocked v = case v of
+     RecType fs -> RecType $ filter (not . isLockLabel . fst) (sortRec fs)
+     _ -> v
+   ---- TODO: accept subtypes
+   ---- TODO: use a trie
+   lookupOverloadInstance tys typs =
+     [((pre,mkFunType rest val, t),isExact) |
+       let lt = length tys,
+       (ty,(val,t)) <- typs, length ty >= lt,
+       let (pre,rest) = splitAt lt ty,
+       let isExact = pre == tys,
+       isExact || map unlocked pre == map unlocked tys
+     ]
+
+   noProds vfs = [(v,f) | (_,v,f) <- vfs, noProd v]
+
+   noProd ty = case ty of
+     Prod _ _ _ _ -> False
+     _ -> True
+
+checkLType :: SourceGrammar -> Context -> Term -> Type -> Check (Term, Type)
+checkLType gr g trm typ0 = do
+  typ <- computeLType gr g typ0
+
+  case trm of
+
+    Abs bt x c -> do
+      case typ of
+        Prod bt' z a b -> do
+          (c',b') <- if z == identW
+                       then checkLType gr ((bt,x,a):g) c b
+                       else do b' <- checkIn (pp "abs") $ substituteLType [(bt',z,Vr x)] b
+                               checkLType gr ((bt,x,a):g) c b'
+          return $ (Abs bt x c', Prod bt' z a b')
+        _ -> checkError $ "function type expected instead of" <+> ppType typ $$
+                          "\n   ** Double-check that the type signature of the operation" $$
+                          "matches the number of arguments given to it.\n"
+
+    App f a -> do
+       over <- getOverload gr g (Just typ) trm
+       case over of
+         Just trty -> return trty
+         _ -> do
+          (trm',ty') <- inferLType gr g trm
+          termWith trm' $ checkEqLType gr g typ ty' trm'
+
+    AdHocOverload ts -> do
+      over <- getOverload gr g Nothing trm
+      case over of
+        Just trty -> return trty
+        _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm)
+
+    Q _ -> do
+       over <- getOverload gr g (Just typ) trm
+       case over of
+         Just trty -> return trty
+         _ -> do
+          (trm',ty') <- inferLType gr g trm
+          termWith trm' $ checkEqLType gr g typ ty' trm'
+
+    T _ [] ->
+      checkError ("found empty table in type" <+> ppTerm Unqualified 0 typ)
+    T _ cs -> case typ of
+      Table arg val -> do
+        case allParamValues gr arg of
+          Ok vs -> do
+            let ps0 = map fst cs
+            ps <- testOvershadow ps0 vs
+            if null ps
+              then return ()
+              else checkWarn ("patterns never reached:" $$
+                              nest 2 (vcat (map (ppPatt Unqualified 0) ps)))
+          _ -> return () -- happens with variable types
+        cs' <- mapM (checkCase arg val) cs
+        return (T (TTyped arg) cs', typ)
+      _ -> checkError $ "table type expected for table instead of" $$ nest 2 (ppType typ)
+    V arg0 vs ->
+      case typ of
+        Table arg1 val ->
+           do arg' <- checkEqLType gr g arg0 arg1 trm
+              vs1 <- allParamValues gr arg1
+              if length vs1 == length vs
+                 then return ()
+                 else checkError $ "wrong number of values in table" <+> ppTerm Unqualified 0 trm
+              vs' <- map fst `fmap` sequence [checkLType gr g v val|v<-vs]
+              return (V arg' vs',typ)
+
+    R r -> case typ of --- why needed? because inference may be too difficult
+       RecType rr -> do
+       --let (ls,_) = unzip rr        -- labels of expected type
+         fsts <- mapM (checkM r) rr   -- check that they are found in the record
+         return $ (R fsts, typ)       -- normalize record
+
+       _ -> checkError ("record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ))
+
+    ExtR r s -> case typ of
+       _ | typ == typeType -> do
+         trm' <- computeLType gr g trm
+         case trm' of
+           RecType _ -> termWith trm' $ return typeType
+           ExtR (Vr _) (RecType _) -> termWith trm' $ return typeType
+                                      -- ext t = t ** ...
+           _ -> checkError ("invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm))
+
+       RecType rr -> do
+
+         (fields1,fields2) <- case s of
+           R ss -> return (partition (\(l,_) -> isNothing (lookup l ss)) rr)
+           _ -> do
+             (s',typ2) <- inferLType gr g s
+             case typ2 of
+               RecType ss -> return (partition (\(l,_) -> isNothing (lookup l ss)) rr)
+               _ ->  checkError ("cannot get labels from" $$ nest 2 (ppTerm Unqualified 0 typ2))
+
+         (r',_) <- checkLType gr g r (RecType fields1)
+         (s',_) <- checkLType gr g s (RecType fields2)
+
+         let withProjection t fields g f =
+               case t of
+                 R rs -> f g (\l -> case lookup l rs of
+                                      Just (_,t) -> t
+                                      Nothing    -> error (render ("no value for label" <+> l)))
+                 QC _ -> f g (\l -> P t l)
+                 Vr _ -> f g (\l -> P t l)
+                 _    -> if length fields == 1
+                           then f g (\l -> P t l)
+                           else let x = mkFreshVar (map (\(_,x,_) -> x) g) (identS "x")
+                                in Let (x, (Nothing, t)) (f ((Explicit,x,RecType fields):g) (\l -> P (Vr x) l))
+
+             rec = withProjection r' fields1 g $ \g p_r' ->
+                   withProjection s' fields2 g $ \g p_s' ->
+                     R ([(l,(Nothing,p_r' l)) | (l,_) <- fields1] ++ [(l,(Nothing,p_s' l)) | (l,_) <- fields2])
+         return (rec, typ)
+
+       ExtR ty ex -> do
+         r' <- justCheck g r ty
+         s' <- justCheck g s ex
+         return $ (ExtR r' s', typ) --- is this all? it assumes the same division in trm and typ
+
+       _ -> checkError ("record extension not meaningful for" <+> ppTerm Unqualified 0 typ)
+
+    FV vs -> do
+      ttys <- mapM (flip (checkLType gr g) typ) vs
+---      checkIfComplexVariantType trm typ
+      return (FV (map fst ttys), typ) --- typ' ?
+
+    S tab arg -> checks [ do
+      (tab',ty) <- inferLType gr g tab
+      ty'       <- computeLType gr g ty
+      case ty' of
+        Table p t -> do
+          (arg',val) <- checkLType gr g arg p
+          checkEqLType gr g typ t trm
+          return (S tab' arg', t)
+        _ -> checkError ("table type expected for applied table instead of" <+> ppType ty')
+     , do
+      (arg',ty) <- inferLType gr g arg
+      ty'       <- computeLType gr g ty
+      (tab',_)  <- checkLType gr g tab (Table ty' typ)
+      return (S tab' arg', typ)
+      ]
+    Let (x,(mty,def)) body -> case mty of
+      Just ty -> do
+        (ty0,_)    <- checkLType gr g ty typeType
+        (def',ty') <- checkLType gr g def ty0
+        body' <- justCheck ((Explicit,x,ty'):g) body typ
+        return (Let (x,(Just ty',def')) body', typ)
+      _ -> do
+        (def',ty) <- inferLType gr g def  -- tries to infer type of local constant
+        checkLType gr g (Let (x,(Just ty,def')) body) typ
+
+    ELin c tr -> do
+      tr1 <- unlockRecord c tr
+      checkLType gr g tr1 typ
+
+    _ -> do
+      (trm',ty') <- inferLType gr g trm
+      termWith trm' $ checkEqLType gr g typ ty' trm'
+ where
+   justCheck g ty te = checkLType gr g ty te >>= return . fst
+{-
+   recParts rr t = (RecType rr1,RecType rr2) where
+     (rr1,rr2) = partition (flip elem (map fst t) . fst) rr
+-}
+   checkM rms (l,ty) = case lookup l rms of
+     Just (Just ty0,t) -> do
+       checkEqLType gr g ty ty0 t
+       (t',ty') <- checkLType gr g t ty
+       return (l,(Just ty',t'))
+     Just (_,t) -> do
+       (t',ty') <- checkLType gr g t ty
+       return (l,(Just ty',t'))
+     _ -> checkError $
+            if isLockLabel l
+              then let cat = drop 5 (showIdent (label2ident l))
+                   in ppTerm Unqualified 0 (R rms) <+> "is not in the lincat of" <+> cat <>
+                      "; try wrapping it with lin" <+> cat
+              else "cannot find value for label" <+> l <+> "in" <+> ppTerm Unqualified 0 (R rms)
+
+   checkCase arg val (p,t) = do
+     cont <- pattContext gr g arg p
+     t' <- justCheck (reverse cont ++ g) t val
+     (_,_,p') <- measurePatt gr p
+     return (p',t')
+
+pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context
+pattContext env g typ p = case p of
+  PV x -> return [(Explicit,x,typ)]
+  PP (q,c) ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
+    t <- lookupResType env (q,c)
+    let (cont,v) = typeFormCnc t
+    checkCond ("wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p)
+              (length cont == length ps)
+    checkEqLType env g typ v (patt2term p)
+    mapM (\((_,_,ty),p) -> pattContext env g ty p) (zip cont ps) >>= return . concat
+  PR r -> do
+    typ' <- computeLType env g typ
+    case typ' of
+      RecType t -> do
+        let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]]
+        ----- checkWarn $ prt p ++++ show pts ----- debug
+        mapM (uncurry (pattContext env g)) pts >>= return . concat
+      _ -> checkError ("record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ')
+  PT t p' -> do
+    checkEqLType env g typ t (patt2term p')
+    pattContext env g typ p'
+
+  PAs x p -> do
+    g' <- pattContext env g typ p
+    return ((Explicit,x,typ):g')
+
+  PAlt p' q -> do
+    g1 <- pattContext env g typ p'
+    g2 <- pattContext env g typ q
+    let pts = nub ([x | pt@(_,x,_) <- g1, notElem pt g2] ++ [x | pt@(_,x,_) <- g2, notElem pt g1])
+    checkCond
+      ("incompatible bindings of" <+>
+       fsep pts <+>
+       "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts)
+    return g1 -- must be g1 == g2
+  PSeq _ _ p _ _ q -> do
+    g1 <- pattContext env g typ p
+    g2 <- pattContext env g typ q
+    return $ g1 ++ g2
+  PRep _ _ p' -> noBind typeStr p'
+  PNeg p' -> noBind typ p'
+
+  _ -> return [] ---- check types!
+ where
+   noBind typ p' = do
+    co <- pattContext env g typ p'
+    if not (null co)
+      then checkWarn ("no variable bound inside pattern" <+> ppPatt Unqualified 0 p)
+           >> return []
+      else return []
+
+checkEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check Type
+checkEqLType gr g t u trm = do
+  (b,t',u',s) <- checkIfEqLType gr g t u trm
+  case b of
+    True  -> return t'
+    False ->
+      let inferredType = ppTerm Qualified 0 u
+          expectedType = ppTerm Qualified 0 t
+          term = ppTerm Unqualified 0 trm
+          funName = pp . head . words .render $ term
+          helpfulMsg =
+            case (arrows inferredType, arrows expectedType) of
+              (0,0) -> pp "" -- None of the types is a function
+              _ -> "\n   **" <+>
+                  if expectedType `isLessApplied` inferredType
+                    then "Maybe you gave too few arguments to" <+> funName
+                    else pp "Double-check that type signature and number of arguments match."
+      in checkError $ s <+> "type of" <+> term $$
+                            "expected:" <+> expectedType $$ -- ppqType t u $$
+                            "inferred:" <+> inferredType $$ -- ppqType u t
+                            helpfulMsg
+  where
+    -- count the number of arrows in the prettyprinted term
+    arrows :: Doc -> Int
+    arrows = length . filter (=="->") . words . render
+
+    -- If prettyprinted type t has fewer arrows then prettyprinted type u,
+    -- then t is "less applied", and we can print out more helpful error msg.
+    isLessApplied :: Doc -> Doc -> Bool
+    isLessApplied t u = arrows t < arrows u
+
+checkIfEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check (Bool,Type,Type,String)
+checkIfEqLType gr g t u trm = do
+  t' <- computeLType gr g t
+  u' <- computeLType gr g u
+  case t' == u' || alpha [] t' u' of
+    True -> return (True,t',u',[])
+    -- forgive missing lock fields by only generating a warning.
+    --- better: use a flag to forgive? (AR 31/1/2006)
+    _ -> case missingLock [] t' u' of
+      Ok lo -> do
+        checkWarn $ "missing lock field" <+> fsep lo
+        return (True,t',u',[])
+      Bad s -> return (False,t',u',s)
+
+  where
+
+   -- check that u is a subtype of t
+   --- quick hack version of TC.eqVal
+   alpha g t u = case (t,u) of
+
+     -- error (the empty type!) is subtype of any other type
+     (_,u) | u == typeError -> True
+
+     -- contravariance
+     (Prod _ x a b, Prod _ y c d) -> alpha g c a && alpha ((x,y):g) b d
+
+     -- record subtyping
+     (RecType rs, RecType ts) -> all (\ (l,a) ->
+                                   any (\ (k,b) -> l == k && alpha g a b) ts) rs
+     (ExtR r s, ExtR r' s') -> alpha g r r' && alpha g s s'
+     (ExtR r s, t) -> alpha g r t || alpha g s t
+
+     -- the following say that Ints n is a subset of Int and of Ints m >= n
+     -- But why does it also allow Int as a subtype of Ints m? /TH 2014-04-04
+     (t,u) | Just m <- isTypeInts t, Just n <- isTypeInts u -> m >= n
+           | Just _ <- isTypeInts t, u == typeInt           -> True ---- check size!
+           | t == typeInt,           Just _ <- isTypeInts u -> True ---- why this ???? AR 11/12/2005
+
+     ---- this should be made in Rename
+     (Q  (m,a), Q  (n,b)) | a == b -> elem m (allExtendsPlus gr n)
+                                   || elem n (allExtendsPlus gr m)
+                                   || m == n --- for Predef
+     (QC (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n)
+                                   || elem n (allExtendsPlus gr m)
+     (QC (m,a), Q  (n,b)) | a == b -> elem m (allExtendsPlus gr n)
+                                   || elem n (allExtendsPlus gr m)
+     (Q  (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n)
+                                   || elem n (allExtendsPlus gr m)
+
+     -- contravariance
+     (Table a b,  Table c d)  -> alpha g c a && alpha g b d
+     (Vr x,       Vr y)       -> x == y || elem (x,y) g || elem (y,x) g
+     _                        -> t == u
+     --- the following should be one-way coercions only. AR 4/1/2001
+                                  || elem t sTypes && elem u sTypes
+                                  || (t == typeType && u == typePType)
+                                  || (u == typeType && t == typePType)
+
+   missingLock g t u = case (t,u) of
+     (RecType rs, RecType ts) ->
+       let
+         ls = [l | (l,a) <- rs,
+                   not (any (\ (k,b) -> alpha g a b && l == k) ts)]
+         (locks,others) = partition isLockLabel ls
+       in case others of
+         _:_ -> Bad $ render ("missing record fields:" <+> fsep (punctuate ',' (others)))
+         _ -> return locks
+     -- contravariance
+     (Prod _ x a b, Prod _ y c d) -> do
+        ls1 <- missingLock g c a
+        ls2 <- missingLock g b d
+        return $ ls1 ++ ls2
+
+     _ -> Bad ""
+
+   sTypes = [typeStr, typeTok, typeString]
+
+-- auxiliaries
+
+-- | light-weight substitution for dep. types
+substituteLType :: Context -> Type -> Check Type
+substituteLType g t = case t of
+  Vr x -> return $ maybe t id $ lookup x [(x,t) | (_,x,t) <- g]
+  _ -> composOp (substituteLType g) t
+
+termWith :: Term -> Check Type -> Check (Term, Type)
+termWith t ct = do
+  ty <- ct
+  return (t,ty)
+
+-- | compositional check\/infer of binary operations
+check2 :: (Term -> Check Term) -> (Term -> Term -> Term) ->
+          Term -> Term -> Type -> Check (Term,Type)
+check2 chk con a b t = do
+  a' <- chk a
+  b' <- chk b
+  return (con a' b', t)
+
+-- printing a type with a lock field lock_C as C
+ppType :: Type -> Doc
+ppType ty =
+  case ty of
+    RecType fs   -> case filter isLockLabel $ map fst fs of
+                      [lock] -> pp (drop 5 (showIdent (label2ident lock)))
+                      _      -> ppTerm Unqualified 0 ty
+    Prod _ x a b -> ppType a <+> "->" <+> ppType b
+    _            -> ppTerm Unqualified 0 ty
+
+checkLookup :: Ident -> Context -> Check Type
+checkLookup x g =
+  case [ty | (b,y,ty) <- g, x == y] of
+    []     -> checkError ("unknown variable" <+> x)
+    (ty:_) -> return ty

src/compiler/api/GF/Compile/TypeCheck/Primitives.hs

@@ -0,0 +1,84 @@
+module GF.Compile.TypeCheck.Primitives(typPredefined,predefMod) where
+
+import GF.Infra.Option
+import GF.Grammar
+import GF.Grammar.Predef
+import qualified Data.Map as Map
+
+typPredefined :: Ident -> Maybe Type
+typPredefined f = case Map.lookup f primitives of
+                    Just (ResOper (Just (L _ ty)) _) -> Just ty
+                    Just (ResParam _ _)              -> Just typePType
+                    Just (ResValue (L _ ty) _)       -> Just ty
+                    _                                -> Nothing
+
+predefMod = (cPredef, modInfo)
+  where
+    modInfo = ModInfo {
+       mtype   = MTResource,
+       mstatus = MSComplete,
+       mflags  = noOptions,
+       mextend = [],
+       mwith   = Nothing,
+       mopens  = [],
+       mexdeps = [],
+       msrc    = "Predef.gfo",
+       mseqs   = Nothing,
+       jments  = primitives
+    }
+
+primitives = Map.fromList
+  [ (cErrorType, ResOper (Just (noLoc typeType)) Nothing)
+  , (cInt      , ResOper (Just (noLoc typePType)) Nothing)
+  , (cFloat    , ResOper (Just (noLoc typePType)) Nothing)
+  , (cInts     , fun [typeInt] typePType)
+  , (cPBool    , ResParam (Just (noLoc [(cPTrue,[]),(cPFalse,[])])) (Just ([QC (cPredef,cPTrue), QC (cPredef,cPFalse)],2)))
+  , (cPTrue    , ResValue (noLoc typePBool) 0)
+  , (cPFalse   , ResValue (noLoc typePBool) 1)
+  , (cError    , fun [typeStr] typeError)  -- non-can. of empty set
+  , (cLength   , fun [typeTok] typeInt)
+  , (cDrop     , fun [typeInt,typeTok] typeTok)
+  , (cTake     , fun [typeInt,typeTok] typeTok)
+  , (cTk       , fun [typeInt,typeTok] typeTok)
+  , (cDp       , fun [typeInt,typeTok] typeTok)
+  , (cEqInt    , fun [typeInt,typeInt] typePBool)
+  , (cLessInt  , fun [typeInt,typeInt] typePBool)
+  , (cPlus     , fun [typeInt,typeInt] typeInt)
+  , (cEqStr    , fun [typeTok,typeTok] typePBool)
+  , (cOccur    , fun [typeTok,typeTok] typePBool)
+  , (cOccurs   , fun [typeTok,typeTok] typePBool)
+
+  , (cToUpper  , fun [typeTok] typeTok)
+  , (cToLower  , fun [typeTok] typeTok)
+  , (cIsUpper  , fun [typeTok] typePBool)
+
+----  "read"   -> 
+  , (cRead     , ResOper (Just (noLoc (mkProd -- (P : Type) -> Tok -> P
+                                         [(Explicit,varP,typePType),(Explicit,identW,typeStr)] (Vr varP) []))) Nothing)
+  , (cShow     , ResOper (Just (noLoc (mkProd -- (P : PType) -> P -> Tok
+                                         [(Explicit,varP,typePType),(Explicit,identW,Vr varP)] typeStr []))) Nothing)
+  , (cEqVal    , ResOper (Just (noLoc (mkProd -- (P : PType) -> P -> P -> PBool
+                                         [(Explicit,varP,typePType),(Explicit,identW,Vr varP),(Explicit,identW,Vr varP)] typePBool []))) Nothing)
+  , (cToStr    , ResOper (Just (noLoc (mkProd -- (L : Type)  -> L -> Str
+                                         [(Explicit,varL,typeType),(Explicit,identW,Vr varL)] typeStr []))) Nothing)
+  , (cMapStr   , ResOper (Just (noLoc (mkProd -- (L : Type)  -> (Str -> Str) -> L -> L
+                                         [(Explicit,varL,typeType),(Explicit,identW,mkFunType [typeStr] typeStr),(Explicit,identW,Vr varL)] (Vr varL) []))) Nothing)
+  , (cNonExist , ResOper (Just (noLoc (mkProd -- Str
+                                         [] typeStr []))) Nothing)
+  , (cBIND     , ResOper (Just (noLoc (mkProd -- Str
+                                         [] typeStr []))) Nothing)
+  , (cSOFT_BIND, ResOper (Just (noLoc (mkProd -- Str
+                                         [] typeStr []))) Nothing)
+  , (cSOFT_SPACE,ResOper (Just (noLoc (mkProd -- Str
+                                         [] typeStr []))) Nothing)
+  , (cCAPIT    , ResOper (Just (noLoc (mkProd -- Str
+                                         [] typeStr []))) Nothing)
+  , (cALL_CAPIT, ResOper (Just (noLoc (mkProd -- Str
+                                         [] typeStr []))) Nothing)
+  ]
+  where
+    fun from to = oper (mkFunType from to)
+    oper ty     = ResOper (Just (noLoc ty)) Nothing
+
+    varL = identS "L"
+    varP = identS "P"

src/compiler/api/GF/Compile/TypeCheck/TC.hs

@@ -0,0 +1,324 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : TC
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/02 20:50:19 $
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.11 $
+--
+-- Thierry Coquand's type checking algorithm that creates a trace
+-----------------------------------------------------------------------------
+
+module GF.Compile.TypeCheck.TC (
+    AExp(..),
+    Theory,
+    checkExp,
+    inferExp,
+    checkBranch,
+    eqVal,
+    whnf
+  ) where
+
+import GF.Data.Operations
+import GF.Grammar
+import GF.Grammar.Predef
+
+import Control.Monad
+--import Data.List (sortBy)
+import Data.Maybe
+import GF.Text.Pretty
+
+data AExp =
+     AVr   Ident Val
+   | ACn   QIdent Val
+   | AType
+   | AInt  Integer
+   | AFloat Double
+   | AStr  String
+   | AMeta MetaId Val
+   | ALet  (Ident,(Val,AExp)) AExp
+   | AApp  AExp AExp Val
+   | AAbs  Ident Val AExp
+   | AProd Ident AExp AExp
+-- -- | AEqs  [([Exp],AExp)] --- not used
+   | ARecType [ALabelling]
+   | AR    [AAssign]
+   | AP    AExp Label Val
+   | AGlue AExp AExp
+   | AData Val
+  deriving (Eq,Show)
+
+type ALabelling = (Label, AExp)
+type AAssign = (Label, (Val, AExp))
+
+type Theory = QIdent -> Err Val
+
+lookupConst :: Theory -> QIdent -> Err Val
+lookupConst th f = th f
+
+lookupVar :: Env -> Ident -> Err Val
+lookupVar g x = maybe (Bad (render ("unknown variable" <+> x))) return $ lookup x ((identW,VClos [] (Meta 0)):g)
+-- wild card IW: no error produced, ?0 instead.
+
+type TCEnv = (Int,Env,Env)
+
+--emptyTCEnv :: TCEnv
+--emptyTCEnv = (0,[],[])
+
+whnf :: Val -> Err Val
+whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug
+         case v of
+  VApp u w -> do
+    u' <- whnf u
+    w' <- whnf w
+    app u' w'
+  VClos env e -> eval env e
+  _ -> return v
+
+app :: Val -> Val -> Err Val
+app u v = case u of
+  VClos env (Abs _ x e) -> eval ((x,v):env) e
+  _ -> return $ VApp u v
+
+eval :: Env -> Term -> Err Val
+eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
+             case e of
+  Vr x    -> lookupVar env x
+  Q c   -> return $ VCn c
+  QC c  -> return $ VCn c ---- == Q ?
+  Sort c  -> return $ VType --- the only sort is Type
+  App f a -> join $ liftM2 app (eval env f) (eval env a)
+  RecType xs -> do xs <- mapM (\(l,e) -> eval env e >>= \e -> return (l,e)) xs
+                   return (VRecType xs)
+  _ -> return $ VClos env e
+
+eqVal :: Int -> Val -> Val -> Err [(Val,Val)]
+eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $
+                do
+  w1 <- whnf u1
+  w2 <- whnf u2
+  let v = VGen k
+  case (w1,w2) of
+    (VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2)
+    (VClos env1 (Abs _ x1 e1), VClos env2 (Abs _ x2 e2)) ->
+      eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)
+    (VClos env1 (Prod _ x1 a1 e1), VClos env2 (Prod _ x2 a2 e2)) ->
+      liftM2 (++)
+        (eqVal k     (VClos            env1  a1) (VClos            env2  a2))
+        (eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2))
+    (VGen i _, VGen j _) -> return [(w1,w2) | i /= j]
+    (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j]
+    --- thus ignore qualifications; valid because inheritance cannot
+    --- be qualified. Simplifies annotation. AR 17/3/2005
+    _ -> return [(w1,w2) | w1 /= w2]
+-- invariant: constraints are in whnf
+
+checkType :: Theory -> TCEnv -> Term -> Err (AExp,[(Val,Val)])
+checkType th tenv e = checkExp th tenv e vType
+
+checkExp :: Theory -> TCEnv -> Term -> Val -> Err (AExp, [(Val,Val)])
+checkExp th tenv@(k,rho,gamma) e ty = do
+  typ <- whnf ty
+  let v = VGen k
+  case e of
+    Meta m -> return $ (AMeta m typ,[])
+
+    Abs _ x t -> case typ of
+      VClos env (Prod _ y a b) -> do
+                           a' <- whnf $ VClos env a ---
+                           (t',cs) <- checkExp th
+                                          (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
+                           return (AAbs x a' t', cs)
+      _ -> Bad (render ("function type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ))
+
+    Let (x, (mb_typ, e1)) e2 -> do
+      (val,e1,cs1) <- case mb_typ of
+                        Just typ -> do (_,cs1) <- checkType th tenv typ
+                                       val <- eval rho typ
+                                       (e1,cs2) <- checkExp th tenv e1 val
+                                       return (val,e1,cs1++cs2)
+                        Nothing  -> do (e1,val,cs) <- inferExp th tenv e1
+                                       return (val,e1,cs)
+      (e2,cs2) <- checkExp th (k,rho,(x,val):gamma) e2 typ
+      return (ALet (x,(val,e1)) e2, cs1++cs2)
+
+    Prod _ x a b -> do
+      testErr (typ == vType) "expected Type"
+      (a',csa) <- checkType th tenv a
+      (b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b
+      return (AProd x a' b', csa ++ csb)
+
+    R xs ->
+      case typ of
+        VRecType ys -> do case [l | (l,_) <- ys, isNothing (lookup l xs)] of
+                            [] -> return ()
+                            ls -> fail (render ("no value given for label:" <+> fsep (punctuate ',' ls)))
+                          r <- mapM (checkAssign th tenv ys) xs
+                          let (xs,css) = unzip r
+                          return (AR xs, concat css)
+        _           -> Bad (render ("record type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ))
+
+    P r l -> do (r',cs) <- checkExp th tenv r (VRecType [(l,typ)])
+                return (AP r' l typ,cs)
+
+    Glue x y -> do cs1 <- eqVal k valAbsFloat typ
+                   (x,cs2) <- checkExp th tenv x typ
+                   (y,cs3) <- checkExp th tenv y typ
+                   return (AGlue x y,cs1++cs2++cs3)
+    _ -> checkInferExp th tenv e typ
+
+checkInferExp :: Theory -> TCEnv -> Term -> Val -> Err (AExp, [(Val,Val)])
+checkInferExp th tenv@(k,_,_) e typ = do
+  (e',w,cs1) <- inferExp th tenv e
+  cs2 <- eqVal k w typ
+  return (e',cs1 ++ cs2)
+
+inferExp :: Theory -> TCEnv -> Term -> Err (AExp, Val, [(Val,Val)])
+inferExp th tenv@(k,rho,gamma) e = case e of
+   Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x
+   Q (m,c) | m == cPredefAbs && isPredefCat c
+                     -> return (ACn (m,c) vType, vType, [])
+           | otherwise -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c)
+   QC c -> mkAnnot (ACn c) $ noConstr $ lookupConst th c ----
+   EInt i -> return (AInt i, valAbsInt, [])
+   EFloat i -> return (AFloat i, valAbsFloat, [])
+   K i -> return (AStr i, valAbsString, [])
+   Sort _ -> return (AType, vType, [])
+   RecType xs -> do r <- mapM (checkLabelling th tenv) xs
+                    let (xs,css) = unzip r
+                    return (ARecType xs, vType, concat css)
+   Let (x, (mb_typ, e1)) e2 -> do
+    (val1,e1,cs1) <- case mb_typ of
+                       Just typ -> do (_,cs1) <- checkType th tenv typ
+                                      val <- eval rho typ
+                                      (e1,cs2) <- checkExp th tenv e1 val
+                                      return (val,e1,cs1++cs2)
+                       Nothing  -> do (e1,val,cs) <- inferExp th tenv e1
+                                      return (val,e1,cs)
+    (e2,val2,cs2) <- inferExp th (k,rho,(x,val1):gamma) e2
+    return (ALet (x,(val1,e1)) e2, val2, cs1++cs2)
+   App f t -> do
+    (f',w,csf) <- inferExp th tenv f
+    typ <- whnf w
+    case typ of
+      VClos env (Prod _ x a b) -> do
+        (a',csa) <- checkExp th tenv t (VClos env a)
+        b' <- whnf $ VClos ((x,VClos rho t):env) b
+        return $ (AApp f' a' b', b', csf ++ csa)
+      _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
+   _ -> Bad (render ("cannot infer type of expression" <+> ppTerm Unqualified 0 e))
+
+checkLabelling :: Theory -> TCEnv -> Labelling -> Err (ALabelling, [(Val,Val)])
+checkLabelling th tenv (lbl,typ) = do
+  (atyp,cs) <- checkType th tenv typ
+  return ((lbl,atyp),cs)
+
+checkAssign :: Theory -> TCEnv -> [(Label,Val)] -> Assign -> Err (AAssign, [(Val,Val)])
+checkAssign th tenv@(k,rho,gamma) typs (lbl,(Just typ,exp)) = do
+  (atyp,cs1) <- checkType th tenv typ
+  val <- eval rho typ
+  cs2 <- case lookup lbl typs of
+           Nothing   -> return []
+           Just val0 -> eqVal k val val0
+  (aexp,cs3) <- checkExp th tenv exp val
+  return ((lbl,(val,aexp)),cs1++cs2++cs3)
+checkAssign th tenv@(k,rho,gamma) typs (lbl,(Nothing,exp)) = do
+  case lookup lbl typs of
+    Nothing  -> do (aexp,val,cs) <- inferExp th tenv exp
+                   return ((lbl,(val,aexp)),cs)
+    Just val -> do (aexp,cs) <- checkExp th tenv exp val
+                   return ((lbl,(val,aexp)),cs)
+
+checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Term],AExp),[(Val,Val)])
+checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
+                                  chB tenv' ps' ty
+ where
+
+  (ps',_,rho2,k') = ps2ts k ps
+  tenv' = (k, rho2++rho, gamma) ---- k' ?
+  (k,rho,gamma) = tenv
+
+  chB tenv@(k,rho,gamma) ps ty = case ps of
+    p:ps2 -> do
+      typ <- whnf ty
+      case typ of
+        VClos env (Prod _ y a b) -> do
+          a' <- whnf $ VClos env a
+          (p', sigma, binds, cs1) <- checkP tenv p y a'
+          let tenv' = (length binds, sigma ++ rho, binds ++ gamma)
+          ((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b)
+          return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
+        _ -> Bad (render ("Product expected for definiens" <+> ppTerm Unqualified 0 t <+> "instead of" <+> ppValue Unqualified 0 typ))
+    [] -> do
+      (e,cs) <- checkExp th tenv t ty
+      return (([],e),cs)
+  checkP env@(k,rho,gamma) t x a = do
+     (delta,cs) <- checkPatt th env t a
+     let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]]
+     return (VClos sigma t, sigma, delta, cs)
+
+  ps2ts k = foldr p2t ([],0,[],k)
+  p2t p (ps,i,g,k) = case p of
+     PW      -> (Meta i : ps, i+1,g,k)
+     PV x    -> (Vr x   : ps, i, upd x k g,k+1)
+     PAs x p -> p2t p (ps,i,g,k)
+     PString s -> (K s : ps, i, g, k)
+     PInt n -> (EInt n : ps, i, g, k)
+     PFloat n -> (EFloat n : ps, i, g, k)
+     PP c xs -> (mkApp (Q c) xss : ps, j, g',k')
+                    where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
+     PImplArg p -> p2t p (ps,i,g,k)
+     PTilde t -> (t : ps, i, g, k)
+     _ -> error $ render ("undefined p2t case" <+> ppPatt Unqualified 0 p <+> "in checkBranch")
+
+  upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables
+
+
+checkPatt :: Theory -> TCEnv -> Term -> Val -> Err (Binds,[(Val,Val)])
+checkPatt th tenv exp val = do
+  (aexp,_,cs) <- checkExpP tenv exp val
+  let binds = extrBinds aexp
+  return (binds,cs)
+ where
+   extrBinds aexp = case aexp of
+     AVr i v    -> [(i,v)]
+     AApp f a _ -> extrBinds f ++ extrBinds a
+     _ -> [] -- no other cases are possible
+
+--- ad hoc, to find types of variables
+   checkExpP tenv@(k,rho,gamma) exp val = case exp of
+     Meta m -> return $ (AMeta m val, val, [])
+     Vr x   -> return $ (AVr   x val, val, [])
+     EInt i -> return (AInt i, valAbsInt, [])
+     EFloat i -> return (AFloat i, valAbsFloat, [])
+     K s    -> return (AStr s, valAbsString, [])
+
+     Q c  -> do
+       typ <- lookupConst th c
+       return $ (ACn c typ, typ, [])
+     QC c  -> do
+       typ <- lookupConst th c
+       return $ (ACn c typ, typ, []) ----
+     App f t -> do
+       (f',w,csf) <- checkExpP tenv f val
+       typ <- whnf w
+       case typ of
+         VClos env (Prod _ x a b) -> do
+           (a',_,csa) <- checkExpP tenv t (VClos env a)
+           b' <- whnf $ VClos ((x,VClos rho t):env) b
+           return $ (AApp f' a' b', b', csf ++ csa)
+         _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
+     _ -> Bad (render ("cannot typecheck pattern" <+> ppTerm Unqualified 0 exp))
+
+-- auxiliaries
+
+noConstr :: Err Val -> Err (Val,[(Val,Val)])
+noConstr er = er >>= (\v -> return (v,[]))
+
+mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)])
+mkAnnot a ti = do
+  (v,cs) <- ti
+  return (a v, v, cs)

src/compiler/api/GF/Compile/Update.hs

@@ -0,0 +1,234 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Update
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/30 18:39:44 $
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.8 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Compile.Update (buildAnyTree, extendModule, rebuildModule) where
+
+import GF.Infra.Ident
+import GF.Infra.Option
+import GF.Infra.CheckM
+import GF.Grammar.Grammar
+import GF.Grammar.Printer
+import GF.Grammar.Lookup
+
+import GF.Data.Operations
+
+import Data.List
+import qualified Data.Map as Map
+import Control.Monad
+import GF.Text.Pretty
+import qualified Control.Monad.Fail as Fail
+
+-- | combine a list of definitions into a balanced binary search tree
+buildAnyTree :: Fail.MonadFail m => ModuleName -> [(Ident,Info)] -> m (Map.Map Ident Info)
+buildAnyTree m = go Map.empty
+  where
+    go map []         = return map
+    go map ((c,j):is) =
+      case Map.lookup c map of
+        Just i  -> case unifyAnyInfo m i j of
+          Ok k  -> go (Map.insert c k map) is
+          Bad _ -> fail $ render ("conflicting information in module"<+>m $$
+                                  nest 4 (ppJudgement Qualified (c,i)) $$
+                                  "and" $+$
+                                  nest 4 (ppJudgement Qualified (c,j)))
+        Nothing -> go (Map.insert c j map) is
+
+extendModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
+extendModule cwd gr (name,m)
+  ---- Just to allow inheritance in incomplete concrete (which are not
+  ---- compiled anyway), extensions are not built for them.
+  ---- Should be replaced by real control. AR 4/2/2005
+  | mstatus m == MSIncomplete && isModCnc m = return (name,m)
+  | otherwise                               = checkInModule cwd m NoLoc empty $ do
+                                                 m' <- foldM extOne m (mextend m)
+                                                 return (name,m')
+ where
+   extOne mo (n,cond) = do
+     m0 <- lookupModule gr n
+
+     -- test that the module types match, and find out if the old is complete
+     unless (sameMType (mtype m) (mtype mo))
+            (checkError ("illegal extension type to module" <+> name))
+
+     let isCompl = isCompleteModule m0
+
+     -- build extension in a way depending on whether the old module is complete
+     js1 <- extendMod gr isCompl ((n,m0), isInherited cond) name (jments mo)
+
+     -- if incomplete, throw away extension information
+     return $
+          if isCompl
+            then mo {jments = js1}
+            else mo {mextend= filter ((/=n) . fst) (mextend mo)
+                    ,mexdeps= nub (n : mexdeps mo)
+                    ,jments = js1
+                    }
+
+-- | rebuilding instance + interface, and "with" modules, prior to renaming.
+-- AR 24/10/2003
+rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
+rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ mseqs js_)) =
+  checkInModule cwd mi NoLoc empty $ do
+
+----  deps <- moduleDeps ms
+----  is   <- openInterfaces deps i
+  let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005
+  mi'  <- case mw of
+
+    -- add the information given in interface into an instance module
+    Nothing -> do
+      unless (null is || mstatus mi == MSIncomplete)
+             (checkError ("module" <+> i <+>
+                          "has open interfaces and must therefore be declared incomplete"))
+      case mt of
+        MTInstance (i0,mincl) -> do
+          m1 <- lookupModule gr i0
+          unless (isModRes m1)
+                 (checkError ("interface expected instead of" <+> i0))
+          js' <- extendMod gr False ((i0,m1), isInherited mincl) i (jments mi)
+          --- to avoid double inclusions, in instance I of I0 = J0 ** ...
+          case extends mi of
+            []  -> return mi{jments=js'}
+            j0s -> do
+                m0s <- mapM (lookupModule gr) j0s
+                let notInM0 c _  = all (not . Map.member c . jments) m0s
+                let js2 = Map.filterWithKey notInM0 js'
+                return mi{jments=js2}
+        _ -> return mi
+
+    -- add the instance opens to an incomplete module "with" instances
+    Just (ext,incl,ops) -> do
+      let (infs,insts) = unzip ops
+      let stat' = if all (flip elem infs) is
+                    then MSComplete
+                    else MSIncomplete
+      unless (stat' == MSComplete || stat == MSIncomplete)
+             (checkError ("module" <+> i <+> "remains incomplete"))
+      ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext
+      let ops1 = nub $
+                   ops_ ++ -- N.B. js has been name-resolved already
+                   [OQualif i j | (i,j) <- ops] ++
+                   [o | o <- ops0, notElem (openedModule o) infs] ++
+                   [OQualif i i | i <- insts] ++
+                   [OSimple i   | i <- insts]
+
+      --- check if me is incomplete
+      let fs1 = fs `addOptions` fs_                           -- new flags have priority
+      let js0 = Map.mapMaybeWithKey (\c j -> if isInherited incl c
+                                               then Just (globalizeLoc fpath j)
+                                               else Nothing)
+                                    js
+      let js1 = Map.union js0 js_
+      let med1= nub (ext : infs ++ insts ++ med_)
+      return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ mseqs js1
+
+  return (i,mi')
+
+-- | When extending a complete module: new information is inserted,
+-- and the process is interrupted if unification fails.
+-- If the extended module is incomplete, its judgements are just copied.
+extendMod :: Grammar ->
+             Bool -> (Module,Ident -> Bool) -> ModuleName ->
+             Map.Map Ident Info -> Check (Map.Map Ident Info)
+extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
+  where
+    try new (c,i0)
+      | not (cond c) = return new
+      | otherwise    = case Map.lookup c new of
+                         Just j -> case unifyAnyInfo name i j of
+                                     Ok k  -> return $ Map.insert c k new
+                                     Bad _ -> do (base,j) <- case j of
+                                                               AnyInd _ m -> lookupOrigInfo gr (m,c)
+                                                               _          -> return (base,j)
+                                                 (name,i) <- case i of
+                                                               AnyInd _ m -> lookupOrigInfo gr (m,c)
+                                                               _          -> return (name,i)
+                                                 checkError ("cannot unify the information" $$
+                                                             nest 4 (ppJudgement Qualified (c,i)) $$
+                                                             "in module" <+> name <+> "with" $$
+                                                             nest 4 (ppJudgement Qualified (c,j)) $$
+                                                             "in module" <+> base)
+                         Nothing-> if isCompl
+                                     then return $ Map.insert c (indirInfo name i) new
+                                     else return $ Map.insert c i new
+      where
+        i = globalizeLoc (msrc mi) i0
+
+    indirInfo :: ModuleName -> Info -> Info
+    indirInfo n info = AnyInd b n' where
+      (b,n') = case info of
+        ResValue _ _ -> (True,n)
+        ResParam _ _ -> (True,n)
+        AbsFun _ _ Nothing _ -> (True,n)
+        AnyInd b k -> (b,k)
+        _ -> (False,n) ---- canonical in Abs
+
+globalizeLoc fpath i =
+  case i of
+    AbsCat mc             -> AbsCat (fmap gl mc)
+    AbsFun mt ma md moper -> AbsFun (fmap gl mt) ma (fmap (fmap gl) md) moper
+    ResParam mt mv        -> ResParam (fmap gl mt) mv
+    ResValue t i          -> ResValue (gl t) i
+    ResOper mt m          -> ResOper (fmap gl mt) (fmap gl m)
+    ResOverload ms os     -> ResOverload ms (map (\(x,y) -> (gl x,gl y)) os)
+    CncCat mc md mr mp mpmcfg-> CncCat (fmap gl mc) (fmap gl md) (fmap gl mr) (fmap gl mp) mpmcfg
+    CncFun m  mt md mpmcfg-> CncFun m (fmap gl mt) (fmap gl md) mpmcfg
+    AnyInd b m            -> AnyInd b m
+  where
+    gl (L loc0 x) = loc `seq` L (External fpath loc) x
+      where
+        loc = case loc0 of
+                External _ loc -> loc
+                loc            -> loc
+
+unifyAnyInfo :: ModuleName -> Info -> Info -> Err Info
+unifyAnyInfo m i j = case (i,j) of
+  (AbsCat mc1, AbsCat mc2) ->
+    liftM AbsCat (unifyMaybeL mc1 mc2)
+  (AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) ->
+    liftM4 AbsFun (unifyMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) (unifyMaybe moper1 moper2) -- adding defs
+
+  (ResParam mt1 mv1, ResParam mt2 mv2) ->
+    liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2)
+  (ResValue (L l1 t1) i1, ResValue (L l2 t2) i2)
+      | t1==t2 && i1 == i2 -> return (ResValue (L l1 t1) i1)
+      | otherwise          -> fail ""
+  (_, ResOverload ms t) | elem m ms ->
+    return $ ResOverload ms t
+  (ResOper mt1 m1, ResOper mt2 m2) ->
+    liftM2 ResOper (unifyMaybeL mt1 mt2) (unifyMaybeL m1 m2)
+
+  (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) ->
+    liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2)  (unifyMaybe mpmcfg1 mpmcfg2)
+  (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) ->
+    liftM3 (CncFun m) (unifyMaybeL mt1 mt2) (unifyMaybeL md1 md2) (unifyMaybe mpmcfg1 mpmcfg2)
+
+  (AnyInd b1 m1, AnyInd b2 m2) -> do
+    testErr (b1 == b2) $ "indirection status"
+    testErr (m1 == m2) $ "different sources of indirection"
+    return i
+
+  _ -> fail "informations"
+
+-- | this is what happens when matching two values in the same module
+unifyMaybeL :: Eq a => Maybe (L a) -> Maybe (L a) -> Err (Maybe (L a))
+unifyMaybeL = unifyMaybeBy unLoc
+
+unifAbsArrity :: Maybe Int -> Maybe Int -> Err (Maybe Int)
+unifAbsArrity = unifyMaybe
+
+unifAbsDefs :: Maybe [L Equation] -> Maybe [L Equation] -> Err (Maybe [L Equation])
+unifAbsDefs (Just xs) (Just ys) = return (Just (xs ++ ys))
+unifAbsDefs Nothing   Nothing   = return Nothing
+unifAbsDefs _         _         = fail ""

src/compiler/api/GF/Compile/pgf.schema.json

@@ -0,0 +1,232 @@
+{
+  "$schema": "http://json-schema.org/draft-07/schema#",
+  "$id": "http://grammaticalframework.org/pgf.schema.json",
+  "type": "object",
+  "title": "PGF JSON Schema",
+  "required": [
+    "abstract",
+    "concretes"
+  ],
+  "properties": {
+    "abstract": {
+      "type": "object",
+      "required": [
+        "name",
+        "startcat",
+        "funs"
+      ],
+      "properties": {
+        "name": {
+          "type": "string"
+        },
+        "startcat": {
+          "type": "string"
+        },
+        "funs": {
+          "type": "object",
+          "additionalProperties": {
+            "type": "object",
+            "required": [
+              "args",
+              "cat"
+            ],
+            "properties": {
+              "args": {
+                "type": "array",
+                "items": {
+                  "type": "string"
+                }
+              },
+              "cat": {
+                "type": "string"
+              }
+            }
+          }
+        }
+      }
+    },
+    "concretes": {
+      "type": "object",
+      "additionalProperties": {
+        "required": [
+          "flags",
+          "productions",
+          "functions",
+          "sequences",
+          "categories",
+          "totalfids"
+        ],
+        "properties": {
+          "flags": {
+            "type": "object",
+            "additionalProperties": {
+              "type": ["string", "number"]
+            }
+          },
+          "productions": {
+            "type": "object",
+            "additionalProperties": {
+              "type": "array",
+              "items": {
+                "oneOf": [
+                  {
+                    "$ref": "#/definitions/apply"
+                  },
+                  {
+                    "$ref": "#/definitions/coerce"
+                  }
+                ]
+              }
+            }
+          },
+          "functions": {
+            "type": "array",
+            "items": {
+              "title": "CncFun",
+              "type": "object",
+              "properties": {
+                "name": {
+                  "type": "string"
+                },
+                "lins": {
+                  "type": "array",
+                  "items": {
+                    "type": "integer"
+                  }
+                }
+              }
+            }
+          },
+          "sequences": {
+            "type": "array",
+            "items": {
+              "type": "array",
+              "items": {
+                "$ref": "#/definitions/sym"
+              }
+            }
+          },
+          "categories": {
+            "type": "object",
+            "additionalProperties": {
+              "title": "CncCat",
+              "type": "object",
+              "required": [
+                "start",
+                "end"
+              ],
+              "properties": {
+                "start": {
+                  "type": "integer"
+                },
+                "end": {
+                  "type": "integer"
+                }
+              }
+            }
+          },
+          "totalfids": {
+            "type": "integer"
+          }
+        }
+      }
+    }
+  },
+  "definitions": {
+    "apply": {
+      "required": [
+        "type",
+        "fid",
+        "args"
+      ],
+      "properties": {
+        "type": {
+          "type": "string",
+          "enum": ["Apply"]
+        },
+        "fid": {
+          "type": "integer"
+        },
+        "args": {
+          "type": "array",
+          "items": {
+            "$ref": "#/definitions/parg"
+          }
+        }
+      }
+    },
+    "coerce": {
+      "required": [
+        "type",
+        "arg"
+      ],
+      "properties": {
+        "type": {
+          "type": "string",
+          "enum": ["Coerce"]
+        },
+        "arg": {
+          "type": "integer"
+        }
+      }
+    },
+    "parg": {
+      "required": [
+        "type",
+        "hypos",
+        "fid"
+      ],
+      "properties": {
+        "type": {
+          "type": "string",
+          "enum": ["PArg"]
+        },
+        "hypos": {
+          "type": "array",
+          "items": {
+            "type": "integer"
+          }
+        },
+        "fid": {
+          "type": "integer"
+        }
+      }
+    },
+    "sym": {
+      "title": "Sym",
+      "required": [
+        "type",
+        "args"
+      ],
+      "properties": {
+        "type": {
+          "type": "string",
+          "enum": [
+            "SymCat",
+            "SymLit",
+            "SymVar",
+            "SymKS",
+            "SymKP",
+            "SymNE"
+          ]
+        },
+        "args": {
+          "type": "array",
+          "items": {
+            "anyOf": [
+              {
+                "type": "string"
+              },
+              {
+                "type": "integer"
+              },
+              {
+                "$ref": "#/definitions/sym"
+              }
+            ]
+          }
+        }
+      }
+    }
+  }
+}

src/compiler/api/GF/CompileInParallel.hs

@@ -0,0 +1,263 @@
+-- | Parallel grammar compilation
+module GF.CompileInParallel(parallelBatchCompile) where
+import Prelude hiding (catch,(<>))
+import Control.Monad(join,ap,when,unless)
+import Control.Applicative
+import GF.Infra.Concurrency
+import GF.System.Concurrency
+import System.FilePath
+import qualified GF.System.Directory as D
+import GF.System.Catch(catch,try)
+import Data.List(nub,isPrefixOf,intercalate,partition)
+import qualified Data.Map as M
+import GF.Compile.ReadFiles(getOptionsFromFile,findFile,gfImports,gfoImports,VersionTagged(..))
+import GF.CompileOne(reuseGFO,useTheSource)
+import GF.Infra.Option
+import GF.Infra.UseIO
+import GF.Data.Operations
+import GF.Grammar.Grammar(emptyGrammar,prependModule)
+import GF.Infra.Ident(moduleNameS)
+import GF.Text.Pretty
+import GF.System.Console(TermColors(..),getTermColors)
+import qualified Data.ByteString.Lazy as BS
+-- Control.Monad.Fail import will become redundant in GHC 8.8+
+import qualified Control.Monad.Fail as Fail
+
+-- | Compile the given grammar files and everything they depend on,
+-- like 'batchCompile'. This function compiles modules in parallel.
+-- It keeps modules compiled in /present/ and /alltenses/ mode apart,
+-- storing the @.gfo@ files in separate subdirectories to avoid creating
+-- the broken PGF files that can result from mixing different modes in the
+-- same concrete syntax.
+--
+-- The first argument controls the number of jobs to run in
+-- parallel. This works if GF was compiled with GHC>=7.6, otherwise you have to
+-- use the GHC run-time flag @+RTS -N -RTS@ to enable parallelism.
+parallelBatchCompile jobs opts rootfiles0 =
+  do setJobs jobs
+     rootfiles <- mapM canonical rootfiles0
+     lib_dir  <- canonical =<< getLibraryDirectory opts
+     filepaths <- mapM (getPathFromFile lib_dir opts) rootfiles
+     let groups = groupFiles lib_dir filepaths
+         n = length groups
+     when (n>1) $ ePutStrLn "Grammar mixes present and alltenses, dividing modules into two groups"
+     (ts,sgrs) <- unzip <$> mapM (batchCompile1 lib_dir) groups
+     return (maximum ts,sgrs)
+  where
+    groupFiles lib_dir filepaths =
+        if length groups>1 then groups else [(opts,filepaths)]
+      where
+        groups = filter (not.null.snd) [(opts_p,present),(opts_a,alltenses)]
+        (present,alltenses) = partition usesPresent filepaths
+        gfoDir = flag optGFODir opts
+        gfo = maybe "" id gfoDir
+        opts_p = setGFO "present"
+        opts_a = setGFO "alltenses"
+        setGFO d = addOptions opts 
+                              (modifyFlags $ \ f->f{optGFODir=Just (gfo</>d)})
+
+        usesPresent (_,paths) = take 1 libs==["present"]
+          where
+            libs = [p|path<-paths,
+                      let (d,p0) = splitAt n path
+                          p = dropSlash p0,
+                      d==lib_dir,p `elem` all_modes]
+            n = length lib_dir  
+
+        all_modes = ["alltenses","present"]
+
+        dropSlash ('/':p) = p
+        dropSlash ('\\':p) = p
+        dropSlash p = p
+
+setJobs opt_n =
+  do ok <- setNumCapabilities opt_n
+     when (not ok) $
+       ePutStrLn $ "To set the number of concurrent threads"
+                   ++" you need to use +RTS -N"++maybe "" show opt_n
+                   ++"\n   or recompile GF with ghc>=7.6"
+
+batchCompile1 lib_dir (opts,filepaths) =
+  do cwd <- D.getCurrentDirectory
+     let rel = relativeTo lib_dir cwd
+         prelude_dir = lib_dir</>"prelude"
+         gfoDir = flag optGFODir opts
+     maybe (return ()) (D.createDirectoryIfMissing True) gfoDir
+{-
+     liftIO $ writeFile (maybe "" id gfoDir</>"paths")
+                        (unlines . map (unwords . map rel) . nub $ map snd filepaths)
+-}
+     prelude_files <- maybe [] id <$> 
+                      maybeIO (D.getDirectoryContents prelude_dir)
+     let fromPrelude f = lib_dir `isPrefixOf` f &&
+                         takeFileName f `elem` prelude_files
+         ppPath ps = "-path="<>intercalate ":" (map rel ps)
+     deps <- newMVar M.empty
+     toLog <- newLog id
+     term <- getTermColors
+     let --logStrLn = toLog . ePutStrLn
+       --ok :: CollectOutput IO a -> IO a
+         ok (CO m) = err bad good =<< tryIOE m
+           where
+              good (o,r) = do toLog o; return r
+              bad e = do toLog (redPutStrLn e); fail "failed"
+              redPutStrLn s = do ePutStr (redFg term);ePutStr s
+                                 ePutStrLn (restore term)
+     sgr <- liftIO $ newMVar emptyGrammar
+     let extendSgr sgr m =
+           modifyMVar_ sgr $ \ gr ->
+           do let gr' = prependModule gr m
+--            logStrLn $ "Finished "++show (length (modules gr'))++" modules."
+              return gr'
+     fcache <- liftIO $ newIOCache $ \ _ (imp,Hide (f,ps)) ->
+                 do (file,_,_) <- findFile gfoDir ps imp
+                    return (file,(f,ps))
+     let find f ps imp =
+           do (file',(f',ps')) <- liftIO $ readIOCache fcache (imp,Hide (f,ps))
+              when (ps'/=ps) $
+                 do (file,_,_) <- findFile gfoDir ps imp
+                    unless (file==file' || any fromPrelude [file,file']) $
+                      do eq <- liftIO $ (==) <$> BS.readFile file <*> BS.readFile file'
+                         unless eq $
+                           fail $ render $ 
+                             hang ("Ambiguous import of"<+>imp<>":") 4
+                              (hang (rel file<+>"from"<+>rel f) 4 (ppPath ps)
+                              $$
+                              hang (rel file'<+>"from"<+>rel f') 4 (ppPath ps'))
+              return file'
+         compile cache (file,paths) = readIOCache cache (file,Hide paths)
+         compile' cache (f,Hide ps) =
+           try $
+           do let compileImport f = compile cache (f,ps)
+                  findImports (f,ps) = mapM (find f ps) . nub . snd
+                                         =<< getImports opts f
+              imps <- ok (findImports (f,ps))
+              modifyMVar_ deps (return . M.insert f imps)
+              ([],tis) <- splitEither <$> parMapM compileImport imps
+              let reuse gfo = do t <- D.getModificationTime gfo
+                                 gr <- readMVar sgr
+                                 r <- lazyIO $ ok (reuseGFO opts gr gfo)
+                                 return (t,snd r)
+                  compileSrc f =
+                    do gr <- readMVar sgr
+                       (Just gfo,mo) <- ok (useTheSource opts gr f)
+                       t <- D.getModificationTime gfo
+                       return (t,mo)
+              (t,mo) <- if isGFO f
+                        then reuse f
+                        else do ts <- D.getModificationTime f
+                                let gfo = gf2gfo' gfoDir f
+                                to <- maybeIO (D.getModificationTime gfo)
+                                if to>=Just (maximum (ts:tis))
+                                  then reuse gfo
+                                  else compileSrc f
+              extendSgr sgr mo
+              return (maximum (t:tis))
+     cache <- liftIO $ newIOCache compile'
+     (es,ts) <- liftIO $ splitEither <$> parMapM (compile cache) filepaths
+     gr <- readMVar sgr
+     let cnc = moduleNameS (justModuleName (fst (last filepaths)))
+     ds <- M.toList <$> readMVar deps
+{-
+     liftIO $ writeFile (maybe "" id gfoDir</>"dependencies")
+                        (unlines [rel f++": "++unwords (map rel imps)
+                                  | (f,imps)<-ds])
+-}
+     putStrLnE $ render $
+                   length ds<+>"modules in"
+                   <+>length (nub (map (dropFileName.fst) ds))<+>"directories."
+     let n = length es
+     if n>0
+       then fail $ "Errors prevented "++show n++" module"++['s'|n/=1]++
+                   " from being compiled."
+       else return (maximum ts,(cnc,gr))
+
+splitEither es = ([x|Left x<-es],[y|Right y<-es])
+
+canonical path = liftIO $ D.canonicalizePath path `catch` const (return path)
+
+getPathFromFile lib_dir cmdline_opts file =
+  do --file <- getRealFile file
+     file_opts <- getOptionsFromFile file
+     let file_dir = dropFileName file
+         opts = addOptions (fixRelativeLibPaths file_dir lib_dir file_opts)
+                           cmdline_opts
+     paths <- mapM canonical . nub . (file_dir :) =<< extendPathEnv opts
+     return (file,nub paths)
+
+getImports opts file =
+    if isGFO file then gfoImports' file else gfImports opts file
+  where
+    gfoImports' file = check =<< gfoImports file
+      where
+        check (Tagged imps) = return imps
+        check WrongVersion = raise $ file++": .gfo file version mismatch"
+
+relativeTo lib_dir cwd path =
+    if length librel<length cwdrel then librel else cwdrel
+  where
+    librel = "%"</>makeRelative lib_dir path
+    cwdrel = makeRelative cwd path
+
+--------------------------------------------------------------------------------
+
+data IOCache arg res
+    = IOCache { op::arg->IO res,
+                cache::MVar (M.Map arg (MVar res)) }
+
+newIOCache op =
+   do v <- newMVar M.empty
+      let cache = IOCache (op cache) v
+      return cache
+
+readIOCache (IOCache op cacheVar) arg =
+  join $ modifyMVar cacheVar $ \ cache ->
+    case M.lookup arg cache of
+       Nothing -> do v <- newEmptyMVar
+                     let doit = do res <- op arg
+                                   putMVar v res
+                                   return res
+                     return (M.insert arg v cache,doit)
+       Just v  -> do return (cache,readMVar v)
+
+
+newtype Hide a = Hide {reveal::a}
+instance Eq (Hide a) where _ == _ = True
+instance Ord (Hide a) where compare _ _ = EQ
+
+--------------------------------------------------------------------------------
+newtype CollectOutput m a = CO {unCO::m (m (),a)}
+{-
+runCO (CO m) = do (o,x) <- m
+                  o
+                  return x
+-}
+instance Functor m => Functor (CollectOutput m) where
+   fmap f (CO m) = CO (fmap (fmap f) m)
+
+instance (Functor m,Monad m) => Applicative (CollectOutput m) where 
+  pure = return
+  (<*>) = ap
+
+instance Monad m => Monad (CollectOutput m) where
+  return x = CO (return (return (),x))
+  CO m >>= f = CO $ do (o1,x) <- m
+                       let CO m2 = f x
+                       (o2,y) <- m2
+                       return (o1>>o2,y)
+instance MonadIO m => MonadIO (CollectOutput m) where
+  liftIO io = CO $ do x <- liftIO io
+                      return (return (),x)
+
+instance Output m => Output (CollectOutput m) where
+  ePutStr   s = CO (return (ePutStr s,()))
+  ePutStrLn s = CO (return (ePutStrLn s,()))
+  putStrLnE s = CO (return (putStrLnE s,()))
+  putStrE   s = CO (return (putStrE s,()))
+
+instance Fail.MonadFail m => Fail.MonadFail (CollectOutput m) where
+  fail = CO . fail
+
+instance ErrorMonad m => ErrorMonad (CollectOutput m) where
+  raise e = CO (raise e)
+  handle (CO m) h = CO $ handle m (unCO . h)

src/compiler/api/GF/CompileOne.hs

@@ -0,0 +1,152 @@
+module GF.CompileOne(-- ** Compiling a single module
+                     OneOutput,CompiledModule,
+                     compileOne,reuseGFO,useTheSource
+                     --, CompileSource, compileSourceModule
+                     ) where
+
+-- The main compiler passes
+import GF.Compile.GetGrammar(getSourceModule)
+import GF.Compile.Rename(renameModule)
+import GF.Compile.CheckGrammar(checkModule)
+import GF.Compile.SubExOpt(subexpModule,unsubexpModule)
+import GF.Compile.GeneratePMCFG(generatePMCFG)
+import GF.Compile.Update(extendModule,rebuildModule)
+import GF.Compile.Tags(writeTags,gf2gftags)
+
+import GF.Grammar.Grammar
+import GF.Grammar.Printer(ppModule,TermPrintQual(..))
+import GF.Grammar.Binary(decodeModule,encodeModule)
+
+import GF.Infra.Option
+import GF.Infra.UseIO(FullPath,IOE,isGFO,gf2gfo,MonadIO(..),Output(..),putPointE,dumpOut,warnOut)
+import GF.Infra.CheckM(runCheck')
+import GF.Data.Operations(ErrorMonad,liftErr,(+++))
+
+import GF.System.Directory(doesFileExist,getCurrentDirectory,renameFile)
+import System.FilePath(makeRelative)
+import System.Random(randomIO)
+import qualified Data.Map as Map
+import GF.Text.Pretty(render,(<+>),($$)) --Doc,
+import Control.Monad((<=<))
+import qualified Control.Monad.Fail as Fail
+
+type OneOutput = (Maybe FullPath,CompiledModule)
+type CompiledModule = Module
+
+compileOne, reuseGFO, useTheSource ::
+    (Output m,ErrorMonad m,MonadIO m, Fail.MonadFail m) =>
+    Options -> Grammar -> FullPath -> m OneOutput
+
+-- | Compile a given source file (or just load a .gfo file),
+-- given a 'Grammar' containing everything it depends on.
+-- Calls 'reuseGFO' or 'useTheSource'.
+compileOne opts srcgr file =
+    if isGFO file
+    then reuseGFO opts srcgr file
+    else do b1 <- doesFileExist file
+            if b1 then useTheSource opts srcgr file
+                  else reuseGFO opts srcgr (gf2gfo opts file)
+
+-- | Read a compiled GF module.
+-- Also undo common subexp optimization, to enable normal computations.
+reuseGFO opts srcgr file =
+  do cwd <- getCurrentDirectory
+     let rfile = makeRelative cwd file
+     sm00 <- putPointE Verbose opts ("+ reading" +++ rfile) $
+             decodeModule file
+     let sm0 = (fst sm00,(snd sm00){mflags=mflags (snd sm00) `addOptions` opts})
+
+     dumpOut opts Source (ppModule Internal sm0)
+
+     let sm1 = unsubexpModule sm0
+     (sm,warnings) <- -- putPointE Normal opts "creating indirections" $ 
+                      runCheck' opts $ extendModule cwd srcgr sm1
+     warnOut opts warnings
+
+     if flag optTagsOnly opts
+       then writeTags opts srcgr (gf2gftags opts file) sm1
+       else return ()
+
+     return (Just file,sm)
+
+--useTheSource :: Options -> Grammar -> FullPath -> IOE OneOutput
+-- | Compile GF module from source. It both returns the result and
+-- stores it in a @.gfo@ file
+-- (or a tags file, if running with the @-tags@ option)
+useTheSource opts srcgr file =
+      do cwd <- getCurrentDirectory
+         let rfile = makeRelative cwd file
+         sm <- putpOpt ("- parsing" +++ rfile)
+                       ("- compiling" +++ rfile ++ "... ")
+                       (getSourceModule opts file)
+         dumpOut opts Source (ppModule Internal sm)
+         compileSourceModule opts cwd (Just file) srcgr sm
+  where
+    putpOpt v m act
+       | verbAtLeast opts Verbose = putPointE Normal opts v act
+       | verbAtLeast opts Normal  = putStrE m >> act
+       | otherwise                = putPointE Verbose opts v act
+
+type CompileSource = Grammar -> Module -> IOE OneOutput
+
+--compileSourceModule :: Options -> InitPath -> Maybe FilePath -> CompileSource
+compileSourceModule opts cwd mb_gfFile gr =
+    if flag optTagsOnly opts
+    then generateTags <=< ifComplete middle               <=< frontend
+    else generateGFO  <=< ifComplete (backend <=< middle) <=< frontend
+  where
+    -- Apply to all modules
+    frontend = runPass Extend  "" . extendModule cwd gr
+           <=< runPass Rebuild "" . rebuildModule cwd gr
+
+    -- Apply to complete modules
+    middle   = runPass TypeCheck "type checking" . checkModule opts cwd gr
+           <=< runPass Rename    "renaming"      . renameModule cwd gr
+
+    -- Apply to complete modules when not generating tags
+    backend mo3 =
+      do if isModCnc (snd mo3) && flag optPMCFG opts
+          then runPassI "generating PMCFG" $ fmap fst $ runCheck' opts (generatePMCFG opts cwd gr mo3)
+          else runPassI "" $ return mo3
+
+    ifComplete yes mo@(_,mi) =
+      if isCompleteModule mi then yes mo else return mo
+
+    generateGFO mo =
+      do let mb_gfo = fmap (gf2gfo opts) mb_gfFile
+         maybeM (flip (writeGFO opts cwd) mo) mb_gfo
+         return (mb_gfo,mo)
+
+    generateTags mo =
+      do maybeM (flip (writeTags opts gr) mo . gf2gftags opts) mb_gfFile
+         return (Nothing,mo)
+
+    putpp s = if null s then id else putPointE Verbose opts ("  "++s++" ")
+
+    -- * Running a compiler pass, with impedance matching
+    runPass = runPass' fst fst snd (liftErr . runCheck' opts)
+    runPassI = runPass2e id id Canon
+    runPass2e lift dump = runPass' id dump (const "") lift
+
+    runPass' ret dump warn lift pass pp m =
+        do out <- putpp pp $ lift m
+           warnOut opts (warn out)
+           dumpOut opts pass (ppModule Internal (dump out))
+           return (ret out)
+
+    maybeM f = maybe (return ()) f
+
+
+--writeGFO :: Options -> InitPath -> FilePath -> SourceModule -> IOE ()
+writeGFO opts cwd file mo =
+    putPointE Normal opts ("  write file" +++ rfile) $
+      do n <- liftIO randomIO --avoid name clashes when compiling with 'make -j'
+         let tmp = file++".tmp" ++show (n::Int)
+         encodeModule tmp mo2
+         renameFile tmp file
+  where
+    rfile = makeRelative cwd file
+    mo2 = (m,mi{jments=Map.filter notAnyInd (jments mi)})
+    (m,mi) = subexpModule mo
+
+    notAnyInd x = case x of AnyInd{} -> False; _ -> True

src/compiler/api/GF/Compiler.hs

@@ -0,0 +1,201 @@
+module GF.Compiler (mainGFC, writeGrammar, writeOutputs) where
+
+import PGF2
+import PGF2.Transactions
+import GF.Compile as S(batchCompile,link,srcAbsName)
+import GF.CompileInParallel as P(parallelBatchCompile)
+import GF.Compile.Export
+import GF.Compile.ConcreteToHaskell(concretes2haskell)
+import GF.Compile.GrammarToCanonical--(concretes2canonical)
+import GF.Compile.CFGtoPGF
+import GF.Compile.GetGrammar
+import GF.Grammar.BNFC
+import GF.Grammar.CFG
+
+--import GF.Infra.Ident(showIdent)
+import GF.Infra.UseIO
+import GF.Infra.Option
+import GF.Infra.CheckM
+import GF.Data.ErrM
+import GF.System.Directory
+import GF.Text.Pretty(render,render80)
+
+import Data.Maybe
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.ByteString.Lazy as BSL
+import GF.Grammar.CanonicalJSON (encodeJSON)
+import System.FilePath
+import Control.Monad(when,unless,forM_,foldM)
+
+-- | Compile the given GF grammar files. The result is a number of @.gfo@ files
+-- and, depending on the options, a @.pgf@ file. (@gf -batch@, @gf -make@)
+mainGFC :: Options -> [FilePath] -> IO ()
+mainGFC opts fs = do
+  r <- tryIOE (case () of
+                 _ | null fs -> fail $ "No input files."
+                 _ | all (extensionIs ".cf")  fs -> compileCFFiles opts fs
+                 _ | all (\f -> extensionIs ".gf" f || extensionIs ".gfo" f)  fs -> compileSourceFiles opts fs
+                 _ | all (extensionIs ".pgf") fs -> unionPGFFiles opts fs
+                 _ -> fail $ "Don't know what to do with these input files: " ++ unwords fs)
+  case r of
+    Ok x    -> return x
+    Bad msg -> die $ if flag optVerbosity opts == Normal
+                       then ('\n':msg)
+                       else msg
+ where
+   extensionIs ext = (== ext) .  takeExtension
+
+compileSourceFiles :: Options -> [FilePath] -> IOE ()
+compileSourceFiles opts fs = 
+    do output <- batchCompile opts fs
+       exportCanonical output
+       unless (flag optStopAfterPhase opts == Compile) $
+           linkGrammars opts output
+  where
+    batchCompile = maybe batchCompile' parallelBatchCompile (flag optJobs opts)
+    batchCompile' opts fs = do (t,cnc_gr) <- S.batchCompile opts fs
+                               return (t,[cnc_gr])
+
+    exportCanonical (_time, canonical) =
+      do when (FmtHaskell `elem` ofmts && haskellOption opts HaskellConcrete) $
+           mapM_ cnc2haskell canonical
+         when (FmtCanonicalGF `elem` ofmts) $
+           do createDirectoryIfMissing False "canonical"
+              mapM_ abs2canonical canonical
+              mapM_ cnc2canonical canonical
+         when (FmtCanonicalJson `elem` ofmts) $ mapM_ grammar2json canonical
+      where
+        ofmts = flag optOutputFormats opts
+
+    cnc2haskell (cnc,gr) = do
+      (res,_) <- runCheck (concretes2haskell opts (srcAbsName gr cnc) gr)
+      mapM_ writeExport res
+
+    abs2canonical (cnc,gr) = do
+      (canAbs,_) <- runCheck (abstract2canonical absname gr)
+      writeExport ("canonical/"++render absname++".gf",render80 canAbs)
+      where
+        absname = srcAbsName gr cnc
+
+    cnc2canonical (cnc,gr) = do
+      (res,_) <- runCheck (concretes2canonical opts (srcAbsName gr cnc) gr)
+      mapM_ (writeExport.fmap render80) res
+
+    grammar2json (cnc,gr) = do
+      (gr_canon,_) <- runCheck (grammar2canonical opts absname gr)
+      return (encodeJSON (render absname ++ ".json") gr_canon)
+      where
+        absname = srcAbsName gr cnc
+
+    writeExport (path,s) = writing opts path $ writeUTF8File path s
+
+
+-- | Create a @.pgf@ file (and possibly files in other formats, if specified
+-- in the 'Options') from the output of 'parallelBatchCompile'.
+-- If a @.pgf@ file by the same name already exists and it is newer than the
+-- source grammar files (as indicated by the 'UTCTime' argument), it is not
+-- recreated. Calls 'writeGrammar' and 'writeOutputs'.
+linkGrammars opts (t_src,[])                      = return ()
+linkGrammars opts (t_src,cnc_gr@(cnc,gr):cnc_grs) =
+    do let abs = render (srcAbsName gr cnc)
+           pgfFile = outputPath opts (grammarName' opts abs<.>"pgf")
+       t_pgf <- if outputJustPGF opts
+                then maybeIO $ getModificationTime pgfFile
+                else return Nothing
+       if t_pgf >= Just t_src
+         then putIfVerb opts $ pgfFile ++ " is up-to-date."
+         else do pgf <- link opts Nothing cnc_gr
+                 pgf <- foldM (link opts . Just) pgf cnc_grs
+                 writeGrammar opts pgf
+                 writeOutputs opts pgf
+
+compileCFFiles :: Options -> [FilePath] -> IOE ()
+compileCFFiles opts fs = do
+  bnfc_rules <- fmap concat $ mapM (getBNFCRules opts) fs
+  let rules = bnfc2cf bnfc_rules
+  startCat <- case rules of
+                (Rule cat _ _ : _) -> return cat
+                _                  -> fail "empty CFG"
+  probs <- liftIO (maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts))
+  let pgf = cf2pgf opts (last fs) (mkCFG startCat Set.empty rules) probs
+  unless (flag optStopAfterPhase opts == Compile) $
+     do writeGrammar opts pgf
+        writeOutputs opts pgf
+
+unionPGFFiles :: Options -> [FilePath] -> IOE ()
+unionPGFFiles opts fs =
+    if outputJustPGF opts
+    then maybe doIt checkFirst (flag optName opts)
+    else doIt
+  where
+    checkFirst name =
+      do let pgfFile = outputPath opts (name <.> "pgf")
+         sourceTime <- maximum `fmap` mapM getModificationTime fs
+         targetTime <- maybeIO $ getModificationTime pgfFile
+         if targetTime >= Just sourceTime
+           then putIfVerb opts $ pgfFile ++ " is up-to-date."
+           else doIt
+
+    doIt =
+      case fs of
+        []     -> return ()
+        (f:fs) -> do mb_probs <- case flag optProbsFile opts of
+                                   Nothing   -> return Nothing
+                                   Just file -> fmap Just (readProbabilitiesFromFile file)
+                     pgf <- if snd (flag optLinkTargets opts)
+                              then case flag optName opts of
+                                     Just name -> do let fname = maybe id (</>) (flag optOutputDir opts) (name<.>"ngf")
+                                                     putStrLnE ("(Boot image "++fname++")")
+                                                     exists <- doesFileExist fname
+                                                     if exists
+                                                       then removeFile fname
+                                                       else return ()
+                                                     echo (\f -> bootNGFWithProbs f mb_probs fname) f
+                                     Nothing   -> do putStrLnE $ "To boot from a list of .pgf files add option -name"
+                                                     echo (\f -> readPGFWithProbs f mb_probs) f
+                              else echo (\f -> readPGFWithProbs f mb_probs) f
+                     pgf <- foldM (\pgf -> echo (modifyPGF pgf . mergePGF)) pgf fs
+                     let pgfFile = outputPath opts (grammarName opts pgf <.> "pgf")
+                     if pgfFile `elem` fs
+                       then putStrLnE $ "Refusing to overwrite " ++ pgfFile
+                       else writeGrammar opts pgf
+                     writeOutputs opts pgf
+
+    echo read f = putPointE Normal opts ("Reading " ++ f ++ "...") (liftIO (read f))
+
+
+-- | Export the PGF to the 'OutputFormat's specified in the 'Options'.
+-- Calls 'exportPGF'.
+writeOutputs :: Options -> PGF -> IOE ()
+writeOutputs opts pgf = do
+  sequence_ [writeOutput opts name str 
+                 | fmt <- flag optOutputFormats opts,
+                   (name,str) <- exportPGF opts fmt pgf]
+
+-- | Write the result of compiling a grammar (e.g. with 'compileToPGF' or
+-- 'link') to a @.pgf@ file.
+-- A split PGF file is output if the @-split-pgf@ option is used.
+writeGrammar :: Options -> PGF -> IOE ()
+writeGrammar opts pgf =
+  if fst (flag optLinkTargets opts)
+    then do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
+            writing opts outfile (writePGF outfile pgf Nothing)
+    else return ()
+
+writeOutput :: Options -> FilePath-> String -> IOE ()
+writeOutput opts file str = writing opts path $ writeUTF8File path str
+  where path = outputPath opts file
+
+-- * Useful helper functions
+
+grammarName :: Options -> PGF -> String
+grammarName opts pgf = grammarName' opts (abstractName pgf)
+grammarName' opts abs = fromMaybe abs (flag optName opts)
+
+outputJustPGF opts = null (flag optOutputFormats opts)
+
+outputPath opts file = maybe id (</>) (flag optOutputDir opts) file
+
+writing opts path io =
+    putPointE Normal opts ("Writing " ++ path ++ "...") $ liftIO io

src/compiler/api/GF/CompilerAPI.hs

@@ -0,0 +1,107 @@
+module GF.CompilerAPI where
+
+-- started by AR 28/1/2011 - STILL DUMMY
+
+import GF.Compile
+-- SHOULD IMPORT MUCH LESS
+
+-- the main compiler passes
+import GF.Compile.GetGrammar
+import GF.Compile.Rename
+import GF.Compile.CheckGrammar
+import GF.Compile.Optimize
+import GF.Compile.SubExOpt
+import GF.Compile.GrammarToPGF
+import GF.Compile.ReadFiles
+import GF.Compile.Update
+import GF.Compile.Refresh
+
+import GF.Grammar.Grammar
+import GF.Grammar.Lookup
+import GF.Grammar.Printer
+import GF.Grammar.Binary
+
+import GF.Infra.Ident
+import GF.Infra.Option
+import GF.Infra.Modules
+import GF.Infra.UseIO
+import GF.Infra.CheckM
+
+import GF.Data.Operations
+
+import Control.Monad
+import System.IO
+import System.Directory
+import System.FilePath
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Data.List(nub)
+import Data.Maybe (isNothing)
+import Data.Binary
+import qualified Data.ByteString.Char8 as BS
+import GF.Text.Pretty
+
+import PGF.CId
+import PGF.Data
+import PGF.Macros
+import PGF.Optimize
+import PGF.Probabilistic
+
+-- the main types
+
+type GF  = GF.Grammar.SourceGrammar
+type PGF = PGF.PGF
+
+-- some API functions - should take Options and perhaps some Env; return error msgs
+
+exBasedGF :: FilePath -> IO GF
+
+multiGF   :: FilePath -> IO GF
+
+getGF     :: FilePath -> IO GF
+
+cfGF      :: FilePath -> IO GF
+
+ebnfGF    :: FilePath -> IO GF
+
+emitGFO   :: GF -> IO ()
+
+readGFO   :: FilePath -> IO GF
+
+gf2pgf    :: GF -> PGF
+
+emitPGF   :: PGF -> IO ()
+
+readPGF   :: FilePath -> IO PGF
+
+emitJSGF  :: PGF -> IO ()
+
+emitSLF   :: PGF -> IO ()
+
+
+
+exBasedGF = error "no exBasedGF"
+
+multiGF = error "no multiGF"
+
+getGF = error "no getGF"
+
+cfGF = error "no cfGF"
+
+ebnfGF = error "no ebnfGF"
+
+emitGFO = error "no emitGFO"
+
+readGFO = error "no readGFO"
+
+gf2pgf = error "no gf2pgf" 
+
+emitPGF = error "no emitPGF"
+
+readPGF = error "no readPGF"
+
+emitJSGF = error "no emitJSGF"
+
+emitSLF = error "no emitSLF"
+
+

src/compiler/api/GF/Data/BacktrackM.hs

@@ -0,0 +1,103 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : BacktrackM
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:22:00 $
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.4 $
+--
+-- Backtracking state monad, with r\/o environment
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+module GF.Data.BacktrackM (
+                    -- * the backtracking state monad
+                    BacktrackM,
+                    -- * monad specific utilities
+                    member,
+                    cut,
+                    -- * running the monad
+                    foldBM,          runBM,
+                    foldSolutions,   solutions,
+                    foldFinalStates, finalStates,
+
+                    -- * reexport the 'MonadState' class
+                    module Control.Monad.State.Class,
+                  ) where
+
+import Data.List
+import Control.Applicative
+import Control.Monad
+import Control.Monad.State.Class
+import qualified Control.Monad.Fail as Fail
+
+----------------------------------------------------------------------
+-- Combining endomorphisms and continuations
+-- a la Ralf Hinze
+
+-- BacktrackM = state monad transformer over the backtracking monad
+
+newtype BacktrackM s a = BM (forall b . (a -> s -> b -> b) -> s -> b -> b)
+
+-- * running the monad
+
+runBM :: BacktrackM s a -> s -> [(s,a)]
+runBM (BM m) s = m (\x s xs -> (s,x) : xs) s []
+
+foldBM :: (a -> s -> b -> b) -> b -> BacktrackM s a -> s -> b
+foldBM f b (BM m) s = m f s b
+
+foldSolutions   :: (a -> b -> b) -> b -> BacktrackM s a -> s -> b
+foldSolutions f b (BM m) s = m (\x s b -> f x b) s b
+
+solutions   :: BacktrackM s a  -> s -> [a]
+solutions = foldSolutions (:) []
+
+foldFinalStates :: (s -> b -> b) -> b -> BacktrackM s () -> s -> b
+foldFinalStates f b (BM m) s = m (\x s b -> f s b) s b
+
+finalStates :: BacktrackM s () -> s -> [s]
+finalStates bm = map fst . runBM bm
+
+instance Applicative (BacktrackM s) where
+    pure = return
+    (<*>) = ap
+
+instance Monad (BacktrackM s) where
+    return a   = BM (\c s b -> c a s b)
+    BM m >>= k = BM (\c s b -> m (\a s b -> unBM (k a) c s b) s b)
+        where unBM (BM m) = m
+
+#if !(MIN_VERSION_base(4,13,0))
+    fail = Fail.fail
+#endif
+
+instance Fail.MonadFail (BacktrackM s) where
+    fail _ = mzero
+
+instance Functor (BacktrackM s) where
+    fmap f (BM m) = BM (\c s b -> m (\a s b -> c (f a) s b) s b)
+
+instance Alternative (BacktrackM s) where
+   empty = mzero
+   (<|>) = mplus
+
+instance MonadPlus (BacktrackM s) where
+    mzero                 = BM (\c s b -> b)
+    (BM f) `mplus` (BM g) = BM (\c s b -> g c s $! f c s b)
+
+instance MonadState s (BacktrackM s) where
+  get = BM (\c s b -> c s s b)
+  put s = BM (\c _ b -> c () s b)
+
+-- * specific functions on the backtracking monad
+
+member :: [a] -> BacktrackM s a
+member xs = BM (\c s b -> foldl' (\b x -> c x s b) b xs)
+
+cut :: BacktrackM s a -> BacktrackM s [(s,a)]
+cut f = BM (\c s b -> c (runBM f s) s b)

src/compiler/api/GF/Data/ErrM.hs

@@ -0,0 +1,68 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : ErrM
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:22:00 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.5 $
+--
+-- hack for BNFC generated files. AR 21/9/2003
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP #-}
+module GF.Data.ErrM where
+
+import Control.Monad (MonadPlus(..),ap)
+import Control.Applicative
+import qualified Control.Monad.Fail as Fail
+
+-- | Like 'Maybe' type with error msgs
+data Err a = Ok a | Bad String
+  deriving (Read, Show, Eq)
+
+-- | Analogue of 'maybe'
+err :: (String -> b) -> (a -> b) -> Err a -> b 
+err d f e = case e of
+  Ok a -> f a
+  Bad s -> d s
+
+-- | Analogue of 'fromMaybe'
+fromErr :: a -> Err a -> a
+fromErr a = err (const a) id
+
+instance Monad Err where
+  return      = Ok
+  Ok a  >>= f = f a
+  Bad s >>= f = Bad s
+
+#if !(MIN_VERSION_base(4,13,0))
+  -- Monad(fail) will be removed in GHC 8.8+
+  fail = Fail.fail
+#endif
+
+instance Fail.MonadFail Err where
+  fail        = Bad
+
+
+
+-- | added 2\/10\/2003 by PEB
+instance Functor Err where
+  fmap f (Ok a) = Ok (f a)
+  fmap f (Bad s) = Bad s
+
+instance Applicative Err where
+  pure = return
+  (<*>) = ap
+
+-- | added by KJ
+instance MonadPlus Err where
+    mzero = Bad "error (no reason given)"
+    mplus (Ok a)  _ = Ok a
+    mplus (Bad s) b = b
+
+instance Alternative Err where
+    empty = mzero
+    (<|>) = mplus

src/compiler/api/GF/Data/Graph.hs

@@ -0,0 +1,178 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Graph
+-- Maintainer  : BB
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/10 16:43:44 $
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.2 $
+--
+-- A simple graph module.
+-----------------------------------------------------------------------------
+module GF.Data.Graph ( Graph(..), Node, Edge, NodeInfo
+                        , newGraph, nodes, edges
+                        , nmap, emap, newNode, newNodes, newEdge, newEdges
+                        , insertEdgeWith
+                        , removeNode, removeNodes
+                        , nodeInfo
+                        , getIncoming, getOutgoing, getNodeLabel
+                        , inDegree, outDegree
+                        , nodeLabel
+                        , edgeFrom, edgeTo, edgeLabel
+                        , reverseGraph, mergeGraphs, renameNodes
+                       ) where
+
+--import GF.Data.Utilities
+
+import Data.List
+import Data.Maybe
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+data Graph n a b = Graph [n] ![Node n a] ![Edge n b]
+    deriving (Eq,Show)
+
+type Node n a = (n,a)
+type Edge n b = (n,n,b)
+
+type NodeInfo n a b = Map n (a, [Edge n b], [Edge n b])
+
+-- | Create a new empty graph.
+newGraph :: [n] -> Graph n a b
+newGraph ns = Graph ns [] []
+
+-- | Get all the nodes in the graph.
+nodes :: Graph n a b -> [Node n a]
+nodes (Graph _ ns _) = ns
+
+-- | Get all the edges in the graph.
+edges :: Graph n a b -> [Edge n b]
+edges (Graph _ _ es) = es
+
+-- | Map a function over the node labels.
+nmap :: (a -> c) -> Graph n a b -> Graph n c b
+nmap f (Graph c ns es) = Graph c [(n,f l) | (n,l) <- ns] es
+
+-- | Map a function over the edge labels.
+emap :: (b -> c) -> Graph n a b -> Graph n a c
+emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es]
+
+-- | Add a node to the graph.
+newNode :: a               -- ^ Node label
+        -> Graph n a b
+        -> (Graph n a b,n) -- ^ Node graph and name of new node
+newNode l (Graph (c:cs) ns es) = (Graph cs ((c,l):ns) es, c)
+
+newNodes :: [a] -> Graph n a b -> (Graph n a b,[Node n a])
+newNodes ls g = (g', zip ns ls)
+  where (g',ns) = mapAccumL (flip newNode) g ls
+-- lazy version:
+--newNodes ls (Graph cs ns es) = (Graph cs' (ns'++ns) es, ns')
+--  where (xs,cs') = splitAt (length ls) cs
+--        ns' = zip xs ls
+
+newEdge :: Edge n b -> Graph n a b -> Graph n a b
+newEdge e (Graph c ns es) = Graph c ns (e:es)
+
+newEdges :: [Edge n b] -> Graph n a b -> Graph n a b
+newEdges es g = foldl' (flip newEdge) g es
+-- lazy version:
+-- newEdges es' (Graph c ns es) = Graph c ns (es'++es)
+
+insertEdgeWith :: Eq n =>
+                  (b -> b -> b) -> Edge n b -> Graph n a b -> Graph n a b
+insertEdgeWith f e@(x,y,l) (Graph c ns es) = Graph c ns (h es)
+  where h [] = [e]
+        h (e'@(x',y',l'):es') | x' == x && y' == y = (x',y', f l l'):es'
+                              | otherwise = e':h es'
+
+-- | Remove a node and all edges to and from that node.
+removeNode :: Ord n => n -> Graph n a b -> Graph n a b
+removeNode n = removeNodes (Set.singleton n)
+
+-- | Remove a set of nodes and all edges to and from those nodes.
+removeNodes :: Ord n => Set n -> Graph n a b -> Graph n a b
+removeNodes xs (Graph c ns es) = Graph c ns' es'
+  where
+  keepNode n = not (Set.member n xs)
+  ns' = [ x | x@(n,_) <- ns, keepNode n ]
+  es' = [ e | e@(f,t,_) <- es, keepNode f && keepNode t ]
+
+-- | Get a map of node names to info about each node.
+nodeInfo :: Ord n => Graph n a b -> NodeInfo n a b
+nodeInfo g = Map.fromList [ (n, (x, fn inc n, fn out n)) | (n,x) <- nodes g ]
+  where
+  inc = groupEdgesBy edgeTo g
+  out = groupEdgesBy edgeFrom g
+  fn m n = fromMaybe [] (Map.lookup n m)
+
+groupEdgesBy :: (Ord n) => (Edge n b -> n) -- ^ Gets the node to group by
+             -> Graph n a b -> Map n [Edge n b]
+groupEdgesBy f g = Map.fromListWith (++) [(f e, [e]) | e <- edges g]
+
+lookupNode :: Ord n => NodeInfo n a b -> n -> (a, [Edge n b], [Edge n b])
+lookupNode i n = fromJust $ Map.lookup n i
+
+getIncoming :: Ord n => NodeInfo n a b -> n -> [Edge n b]
+getIncoming i n = let (_,inc,_) = lookupNode i n in inc
+
+getOutgoing :: Ord n => NodeInfo n a b -> n -> [Edge n b]
+getOutgoing i n = let (_,_,out) = lookupNode i n in out
+
+inDegree :: Ord n => NodeInfo n a b -> n -> Int
+inDegree i n = length $ getIncoming i n
+
+outDegree :: Ord n => NodeInfo n a b -> n -> Int
+outDegree i n = length $ getOutgoing i n
+
+getNodeLabel :: Ord n => NodeInfo n a b -> n -> a
+getNodeLabel i n = let (l,_,_) = lookupNode i n in l
+
+nodeLabel :: Node n a -> a
+nodeLabel = snd
+
+edgeFrom :: Edge n b -> n
+edgeFrom (f,_,_) = f
+
+edgeTo :: Edge n b -> n
+edgeTo (_,t,_) = t
+
+edgeLabel :: Edge n b -> b
+edgeLabel (_,_,l) = l
+
+reverseGraph :: Graph n a b -> Graph n a b
+reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ]
+
+-- | Add the nodes from the second graph to the first graph.
+--   The nodes in the second graph will be renamed using the name
+--   supply in the first graph.
+--   This function is more efficient when the second graph
+--   is smaller than the first.
+mergeGraphs :: Ord m => Graph n a b -> Graph m a b
+            -> (Graph n a b, m -> n) -- ^ The new graph and a function translating
+                                      --  the old names of nodes in the second graph
+                                      --  to names in the new graph.
+mergeGraphs (Graph c ns1 es1) g2 = (Graph c' (ns2++ns1) (es2++es1), newName)
+  where
+  (xs,c') = splitAt (length (nodes g2)) c
+  newNames = Map.fromList (zip (map fst (nodes g2)) xs)
+  newName n = fromJust $ Map.lookup n newNames
+  Graph _ ns2 es2 = renameNodes newName undefined g2
+
+-- | Rename the nodes in the graph.
+renameNodes :: (n -> m) -- ^ renaming function
+            -> [m] -- ^ infinite supply of fresh node names, to
+                   --   use when adding nodes in the future.
+            -> Graph n a b -> Graph m a b
+renameNodes newName c (Graph _ ns es) = Graph c ns' es'
+    where ns' = map' (\ (n,x) -> (newName n,x)) ns
+          es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es
+
+-- | A strict 'map'
+map' :: (a -> b) -> [a] -> [b]
+map' _ [] = []
+map' f (x:xs) = ((:) $! f x) $! map' f xs

src/compiler/api/GF/Data/Graphviz.hs

@@ -0,0 +1,116 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Graphviz
+-- Maintainer  : BB
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/09/15 18:10:44 $
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.2 $
+--
+-- Graphviz DOT format representation and printing.
+-----------------------------------------------------------------------------
+
+module GF.Data.Graphviz (
+                          Graph(..), GraphType(..),
+                          Node(..), Edge(..),
+                          Attr,
+                          addSubGraphs,
+                          setName,
+                          setAttr,
+                          prGraphviz
+                        ) where
+
+import Data.Char
+
+import GF.Data.Utilities
+
+-- | Graph type, graph ID, graph attirbutes, graph nodes, graph edges, subgraphs
+data Graph = Graph {
+                    gType :: GraphType,
+                    gId :: Maybe String,
+                    gAttrs :: [Attr],
+                    gNodes :: [Node],
+                    gEdges :: [Edge],
+                    gSubgraphs :: [Graph]
+                   }
+  deriving (Show)
+
+data GraphType = Directed | Undirected
+  deriving (Show)
+
+data Node = Node String [Attr]
+  deriving Show
+
+data Edge = Edge String String [Attr]
+  deriving Show
+
+type Attr = (String,String)
+
+--
+-- * Graph construction
+--
+
+addSubGraphs :: [Graph] -> Graph -> Graph
+addSubGraphs gs g = g { gSubgraphs = gs ++ gSubgraphs g }
+
+setName :: String -> Graph -> Graph
+setName n g = g { gId = Just n }
+
+setAttr :: String -> String -> Graph -> Graph
+setAttr n v g = g { gAttrs = tableSet n v (gAttrs g) }
+
+--
+-- * Pretty-printing
+--
+
+prGraphviz :: Graph -> String
+prGraphviz g@(Graph t i _ _ _ _) =
+    graphtype t ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}\n"
+
+prSubGraph :: Graph -> String
+prSubGraph g@(Graph _ i _ _ _ _) =
+    "subgraph" ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}"
+
+prGraph :: Graph -> String
+prGraph (Graph t id at ns es ss) =
+    unlines $ map (++";") (map prAttr at
+                           ++ map prNode ns
+                           ++ map (prEdge t) es
+                           ++ map prSubGraph ss)
+
+graphtype :: GraphType -> String
+graphtype Directed = "digraph"
+graphtype Undirected = "graph"
+
+prNode :: Node -> String
+prNode (Node n at) = esc n ++ " " ++ prAttrList at
+
+prEdge :: GraphType -> Edge -> String
+prEdge t (Edge x y at) = esc x ++ " " ++ edgeop t ++ " " ++ esc y ++ " " ++ prAttrList at
+
+edgeop :: GraphType -> String
+edgeop Directed = "->"
+edgeop Undirected = "--"
+
+prAttrList :: [Attr] -> String
+prAttrList [] = ""
+prAttrList at = "[" ++ join "," (map prAttr at) ++ "]"
+
+prAttr :: Attr -> String
+prAttr (n,v) = esc n ++ " = " ++ esc v
+
+esc :: String -> String
+esc s | needEsc s = "\"" ++ concat [ if shouldEsc c then ['\\',c] else [c] | c <- s ] ++ "\""
+      | otherwise = s
+  where shouldEsc = (`elem` ['"', '\\'])
+
+needEsc :: String -> Bool
+needEsc [] = True
+needEsc xs | all isDigit xs = False
+needEsc (x:xs) = not (isIDFirst x && all isIDChar xs)
+
+isIDFirst, isIDChar :: Char -> Bool
+isIDFirst c = c `elem` (['_']++['a'..'z']++['A'..'Z'])
+isIDChar c = isIDFirst c || isDigit c

src/compiler/api/GF/Data/Operations.hs

@@ -0,0 +1,269 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Operations
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/11 16:12:41 $
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.22 $
+--
+-- some auxiliary GF operations. AR 19\/6\/1998 -- 6\/2\/2001
+--
+-- Copyright (c) Aarne Ranta 1998-2000, under GNU General Public License (see GPL)
+-----------------------------------------------------------------------------
+
+module GF.Data.Operations (
+     -- ** The Error monad
+     Err(..), err, maybeErr, testErr, fromErr, errIn,
+     lookupErr,
+
+     -- ** Error monad class
+     ErrorMonad(..), checks, --doUntil, allChecks, checkAgain,
+                 liftErr,
+
+     -- ** Checking
+     checkUnique, unifyMaybeBy, unifyMaybe,
+
+         -- ** Monadic operations on lists and pairs
+     mapPairsM, pairM,
+
+     -- ** Printing
+     indent, (+++), (++-), (++++), (+++-), (+++++),
+     prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly,
+     prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
+     numberedParagraphs, prConjList, prIfEmpty, wrapLines,
+
+     -- ** Topological sorting
+     topoTest, topoTest2,
+
+     -- ** Misc
+     readIntArg,
+     iterFix,  chunks,
+
+    ) where
+
+import Data.Char (isSpace, toUpper, isSpace, isDigit)
+import Data.List (nub, partition, (\\))
+import qualified Data.Map as Map
+import Data.Map (Map)
+--import Control.Applicative(Applicative(..))
+import Control.Monad (liftM,liftM2) --,ap
+
+import GF.Data.ErrM
+import GF.Data.Relation
+import qualified Control.Monad.Fail as Fail
+
+infixr 5 +++
+infixr 5 ++-
+infixr 5 ++++
+infixr 5 +++++
+
+-- the Error monad
+
+-- | Add msg s to 'Maybe' failures
+maybeErr :: ErrorMonad m => String -> Maybe a -> m a
+maybeErr s = maybe (raise s) return
+
+testErr :: ErrorMonad m => Bool -> String -> m ()
+testErr cond msg = if cond then return () else raise msg
+
+errIn :: ErrorMonad m => String -> m a -> m a
+errIn msg m = handle m (\s -> raise (s ++++ "OCCURRED IN" ++++ msg))
+
+lookupErr :: (ErrorMonad m,Eq a,Show a) => a -> [(a,b)] -> m b
+lookupErr a abs = maybeErr ("Unknown" +++ show a) (lookup a abs)
+
+mapPairsM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)]
+mapPairsM f xys = mapM (\ (x,y) -> liftM ((,) x) (f y)) xys
+
+pairM :: Monad m => (b -> m c) -> (b,b) -> m (c,c)
+pairM op (t1,t2) = liftM2 (,) (op t1) (op t2)
+
+-- checking
+
+checkUnique :: (Show a, Eq a) => [a] -> [String]
+checkUnique ss = ["overloaded" +++ show s | s <- nub overloads] where
+  overloads = filter overloaded ss
+  overloaded s = length (filter (==s) ss) > 1
+
+-- | this is what happens when matching two values in the same module
+unifyMaybe :: (Eq a, Fail.MonadFail m) => Maybe a -> Maybe a -> m (Maybe a)
+unifyMaybe = unifyMaybeBy id
+
+unifyMaybeBy :: (Eq b, Fail.MonadFail m) => (a->b) -> Maybe a -> Maybe a -> m (Maybe a)
+unifyMaybeBy f (Just p1) (Just p2)
+  | f p1==f p2                     = return (Just p1)
+  | otherwise                      = fail ""
+unifyMaybeBy _ Nothing   mp2       = return mp2
+unifyMaybeBy _ mp1       _         = return mp1
+
+-- printing
+
+indent :: Int -> String -> String
+indent i s = replicate i ' ' ++ s
+
+(+++), (++-), (++++), (+++-), (+++++) :: String -> String -> String
+a +++ b   = a ++ " "    ++ b
+
+a ++- ""  = a
+a ++- b   = a +++ b
+
+a ++++ b  = a ++ "\n"   ++ b
+
+a +++- "" = a
+a +++- b  = a ++++ b
+
+a +++++ b = a ++ "\n\n" ++ b
+
+
+prUpper :: String -> String
+prUpper s = s1 ++ s2' where
+ (s1,s2) = span isSpace s
+ s2' = case s2 of
+   c:t -> toUpper c : t
+   _ -> s2
+
+prReplicate :: Int -> String -> String
+prReplicate n s = concat (replicate n s)
+
+prTList :: String -> [String] -> String
+prTList t ss = case ss of
+  []   -> ""
+  [s]  -> s
+  s:ss -> s ++ t ++ prTList t ss
+
+prQuotedString :: String -> String
+prQuotedString x = "\"" ++ restoreEscapes x ++ "\""
+
+prParenth :: String -> String
+prParenth s = if s == "" then "" else "(" ++ s ++ ")"
+
+prCurly, prBracket :: String -> String
+prCurly   s = "{" ++ s ++ "}"
+prBracket s = "[" ++ s ++ "]"
+
+prArgList, prSemicList, prCurlyList :: [String] -> String
+prArgList   = prParenth . prTList ","
+prSemicList = prTList " ; "
+prCurlyList = prCurly . prSemicList
+
+restoreEscapes :: String -> String
+restoreEscapes s =
+  case s of
+    []       -> []
+    '"' : t  -> '\\' : '"'  : restoreEscapes t
+    '\\': t  -> '\\' : '\\' : restoreEscapes t
+    c   : t  -> c : restoreEscapes t
+
+numberedParagraphs :: [[String]] -> [String]
+numberedParagraphs t = case t of
+  []   -> []
+  p:[] -> p
+  _    -> concat [(show n ++ ".") : s | (n,s) <- zip [1..] t]
+
+prConjList :: String -> [String] -> String
+prConjList c []     = ""
+prConjList c [s]    = s
+prConjList c [s,t]  = s +++ c +++ t
+prConjList c (s:tt) = s ++ "," +++ prConjList c tt
+
+prIfEmpty :: String -> String -> String -> String -> String
+prIfEmpty em _    _    [] = em
+prIfEmpty em nem1 nem2 s  = nem1 ++ s ++ nem2
+
+-- | Thomas Hallgren's wrap lines
+wrapLines :: Int -> String -> String
+wrapLines n "" = ""
+wrapLines n s@(c:cs) =
+      if isSpace c
+      then c:wrapLines (n+1) cs
+      else case lex s of
+            [(w,rest)] -> if n'>=76
+                          then '\n':w++wrapLines l rest
+                          else w++wrapLines n' rest
+               where n' = n+l
+                     l = length w
+            _ -> s -- give up!!
+
+-- | Topological sorting with test of cyclicity
+topoTest :: Ord a => [(a,[a])] -> Either [a] [[a]]
+topoTest = topologicalSort . mkRel'
+
+-- | Topological sorting with test of cyclicity, new version /TH 2012-06-26
+topoTest2 :: Ord a => [(a,[a])] -> Either [[a]] [[a]]
+topoTest2 g0 = maybe (Right cycles) Left (tsort g)
+  where
+    g = g0++[(n,[])|n<-nub (concatMap snd g0)\\map fst g0]
+
+    cycles = findCycles (mkRel' g)
+
+    tsort nes =
+      case partition (null.snd) nes of
+        ([],[]) -> Just []
+        ([],_) -> Nothing
+        (ns,rest) -> (leaves:) `fmap` tsort [(n,es \\ leaves) | (n,es)<-rest]
+            where leaves = map fst ns
+
+
+-- | Fix point iterator (for computing e.g. transitive closures or reachability)
+iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a]
+iterFix more start = iter start start
+  where
+    iter old new = if (null new')
+                      then old
+                      else iter (new' ++ old) new'
+      where
+        new' = filter (`notElem` old) (more new)
+
+-- | chop into separator-separated parts
+chunks :: Eq a => a -> [a] -> [[a]]
+chunks sep ws = case span (/= sep) ws of
+  (a,_:b) -> a : bs where bs = chunks sep b
+  (a, []) -> if null a then [] else [a]
+
+readIntArg :: String -> Int
+readIntArg n = if (not (null n) && all isDigit n) then read n else 0
+
+class (Functor m,Monad m) => ErrorMonad m where
+  raise   :: String -> m a
+  handle  :: m a -> (String -> m a) -> m a
+  handle_ :: m a -> m a -> m a
+  handle_ a b =  a `handle` (\_ -> b)
+
+instance ErrorMonad Err where
+  raise  = Bad
+  handle a@(Ok _) _ = a
+  handle (Bad i) f  = f i
+
+liftErr e = err raise return e
+{-
+instance ErrorMonad (STM s) where
+  raise msg = STM (\s -> raise msg)
+  handle (STM f) g = STM (\s -> (f s)
+                                `handle` (\e -> let STM g' = (g e) in
+                                                    g' s))
+
+-}
+
+-- | if the first check fails try another one
+checkAgain :: ErrorMonad m => m a -> m a -> m a
+checkAgain c1 c2 = handle_ c1 c2
+
+checks :: ErrorMonad m => [m a] -> m a
+checks [] = raise "no chance to pass"
+checks cs = foldr1 checkAgain cs
+{-
+allChecks :: ErrorMonad m => [m a] -> m [a]
+allChecks ms = case ms of
+  (m: ms) -> let rs = allChecks ms in handle_ (liftM2 (:) m rs) rs
+  _ -> return []
+
+doUntil :: ErrorMonad m => (a -> Bool) -> [m a] -> m a
+doUntil cond ms = case ms of
+  a:as -> do
+    v <- a
+    if cond v then return v else doUntil cond as
+  _ -> raise "no result"
+-}

src/compiler/api/GF/Data/Relation.hs

@@ -0,0 +1,193 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Relation
+-- Maintainer  : BB
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/26 17:13:13 $
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.1 $
+--
+-- A simple module for relations.
+-----------------------------------------------------------------------------
+
+module GF.Data.Relation (Rel, mkRel, mkRel'
+                           , allRelated , isRelatedTo
+                           , transitiveClosure
+                           , reflexiveClosure, reflexiveClosure_
+                           , symmetricClosure
+                           , symmetricSubrelation, reflexiveSubrelation
+                           , reflexiveElements
+                           , equivalenceClasses
+                           , isTransitive, isReflexive, isSymmetric
+                           , isEquivalence
+                           , isSubRelationOf
+                           , topologicalSort, findCycles) where
+
+import Data.Foldable (toList)
+--import Data.List
+import Data.Maybe
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import GF.Data.Utilities
+
+type Rel a = Map a (Set a)
+
+-- | Creates a relation from a list of related pairs.
+mkRel :: Ord a => [(a,a)] -> Rel a
+mkRel ps = relates ps Map.empty
+
+-- | Creates a relation from a list pairs of elements and the elements
+--   related to them.
+mkRel' :: Ord a => [(a,[a])] -> Rel a
+mkRel' xs = Map.fromListWith Set.union [(x,Set.fromList ys) | (x,ys) <- xs]
+
+relToList :: Ord a => Rel a -> [(a,a)]
+relToList r = [ (x,y) | (x,ys) <- Map.toList r, y <- Set.toList ys ]
+
+-- | Add a pair to the relation.
+relate :: Ord a => a -> a -> Rel a -> Rel a
+relate x y r = Map.insertWith Set.union x (Set.singleton y) r
+
+-- | Add a list of pairs to the relation.
+relates :: Ord a => [(a,a)] -> Rel a -> Rel a
+relates ps r = foldl (\r' (x,y) -> relate x y r') r ps
+
+-- | Checks if an element is related to another.
+isRelatedTo :: Ord a => Rel a -> a  -> a -> Bool
+isRelatedTo r x y = maybe False (y `Set.member`) (Map.lookup x r)
+
+-- | Get the set of elements to which a given element is related.
+allRelated :: Ord a => Rel a -> a -> Set a
+allRelated r x = fromMaybe Set.empty (Map.lookup x r)
+
+-- | Get all elements in the relation.
+domain :: Ord a => Rel a -> Set a
+domain r = foldl Set.union (Map.keysSet r) (Map.elems r)
+
+reverseRel :: Ord a => Rel a -> Rel a
+reverseRel r = mkRel [(y,x) | (x,y) <- relToList r]
+
+-- | Keep only pairs for which both elements are in the given set.
+intersectSetRel :: Ord a => Set a -> Rel a -> Rel a
+intersectSetRel s = filterRel (\x y -> x `Set.member` s && y `Set.member` s)
+
+transitiveClosure :: Ord a => Rel a -> Rel a
+transitiveClosure r = fix (Map.map growSet) r
+  where growSet ys = foldl Set.union ys (map (allRelated r) $ Set.toList ys)
+
+reflexiveClosure_ :: Ord a => [a] -- ^ The set over which the relation is defined.
+                  -> Rel a -> Rel a
+reflexiveClosure_ u r = relates [(x,x) | x <- u] r
+
+-- | Uses 'domain'
+reflexiveClosure :: Ord a => Rel a -> Rel a
+reflexiveClosure r = reflexiveClosure_ (Set.toList $ domain r) r
+
+symmetricClosure :: Ord a => Rel a -> Rel a
+symmetricClosure r = relates [ (y,x) | (x,y) <- relToList r ] r
+
+symmetricSubrelation :: Ord a => Rel a -> Rel a
+symmetricSubrelation r = filterRel (flip $ isRelatedTo r) r
+
+reflexiveSubrelation :: Ord a => Rel a -> Rel a
+reflexiveSubrelation r = intersectSetRel (reflexiveElements r) r
+
+-- | Get the set of elements which are related to themselves.
+reflexiveElements :: Ord a => Rel a -> Set a
+reflexiveElements r = Set.fromList [ x | (x,ys) <- Map.toList r, x `Set.member` ys ]
+
+-- | Keep the related pairs for which the predicate is true.
+filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a
+filterRel p = fst . purgeEmpty . Map.mapWithKey (Set.filter . p)
+
+-- | Remove keys that map to no elements.
+purgeEmpty :: Ord a => Rel a -> (Rel a, Set a)
+purgeEmpty r = let (r',r'') = Map.partition (not . Set.null) r
+                in (r', Map.keysSet r'')
+
+-- | Get the equivalence classes from an equivalence relation.
+equivalenceClasses :: Ord a => Rel a -> [Set a]
+equivalenceClasses r = equivalenceClasses_ (Map.keys r) r
+ where equivalenceClasses_ [] _ = []
+       equivalenceClasses_ (x:xs) r = ys:equivalenceClasses_ zs r
+          where ys = allRelated r x
+                zs = [x' | x' <- xs, not (x' `Set.member` ys)]
+
+isTransitive :: Ord a => Rel a -> Bool
+isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r,
+                      y <- Set.toList ys, z <- Set.toList (allRelated r y)]
+
+isReflexive :: Ord a => Rel a -> Bool
+isReflexive r = all (\ (x,ys) -> x `Set.member` ys) (Map.toList r)
+
+isSymmetric :: Ord a => Rel a -> Bool
+isSymmetric r = and [isRelatedTo r y x | (x,y) <- relToList r]
+
+isEquivalence :: Ord a => Rel a -> Bool
+isEquivalence r = isReflexive r && isSymmetric r && isTransitive r
+
+isSubRelationOf :: Ord a => Rel a -> Rel a -> Bool
+isSubRelationOf r1 r2 = all (uncurry (isRelatedTo r2)) (relToList r1)
+
+-- | Returns 'Left' if there are cycles, and 'Right' if there are cycles.
+topologicalSort :: Ord a => Rel a -> Either [a] [[a]]
+topologicalSort r = tsort r' noIncoming Seq.empty
+  where r' = relToRel' r
+        noIncoming = Seq.fromList [x | (x,(is,_)) <- Map.toList r', Set.null is]
+
+tsort :: Ord a => Rel' a -> Seq a -> Seq a -> Either [a] [[a]]
+tsort r xs l = case Seq.viewl xs of
+                 Seq.EmptyL | isEmpty' r -> Left (toList l)
+                            | otherwise  -> Right (findCycles (rel'ToRel r))
+                 x Seq.:< xs -> tsort r' (xs Seq.>< Seq.fromList new) (l Seq.|> x)
+                     where (r',_,os) = remove x r
+                           new = [o | o <- Set.toList os, Set.null (incoming o r')]
+
+findCycles :: Ord a => Rel a -> [[a]]
+findCycles = map Set.toList . equivalenceClasses . reflexiveSubrelation . symmetricSubrelation . transitiveClosure
+
+--
+-- * Alternative representation that keeps both incoming and outgoing edges
+--
+
+-- | Keeps both incoming and outgoing edges.
+type Rel' a = Map a (Set a, Set a)
+
+isEmpty' :: Ord a => Rel' a -> Bool
+isEmpty' = Map.null
+
+relToRel' :: Ord a => Rel a -> Rel' a
+relToRel' r = Map.unionWith (\ (i,_) (_,o) -> (i,o)) ir or
+  where ir = Map.map (\s -> (s,Set.empty)) $ reverseRel r
+        or = Map.map (\s -> (Set.empty,s)) $ r
+
+rel'ToRel :: Ord a => Rel' a -> Rel a
+rel'ToRel = Map.map snd
+
+-- | Removes an element from a relation.
+-- Returns the new relation, and the set of incoming and outgoing edges
+-- of the removed element.
+remove :: Ord a => a -> Rel' a -> (Rel' a, Set a, Set a)
+remove x r = let (mss,r') = Map.updateLookupWithKey (\_ _ -> Nothing) x r
+              in case mss of
+                   -- element was not in the relation
+                   Nothing      -> (r', Set.empty, Set.empty)
+                   -- remove element from all incoming and outgoing sets
+                   -- of other elements
+                   Just (is,os) ->
+                       let r''  = foldr (\i -> Map.adjust (\ (is',os') -> (is', Set.delete x os')) i) r'  $ Set.toList is
+                           r''' = foldr (\o -> Map.adjust (\ (is',os') -> (Set.delete x is', os')) o) r'' $ Set.toList os
+                        in (r''', is, os)
+
+incoming :: Ord a => a -> Rel' a -> Set a
+incoming x r = maybe Set.empty fst $ Map.lookup x r
+
+--outgoing :: Ord a => a -> Rel' a -> Set a
+--outgoing x r = maybe Set.empty snd $ Map.lookup x r

src/compiler/api/GF/Data/SortedList.hs

@@ -0,0 +1,127 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : Peter Ljunglöf
+-- Stability   : stable
+-- Portability : portable
+--
+-- > CVS $Date: 2005/04/21 16:22:08 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.3 $
+--
+-- Sets as sorted lists
+--
+--    * /O(n)/   union, difference and intersection 
+--
+--    * /O(n log n)/ creating a set from a list (=sorting)
+--
+--    * /O(n^2)/ fixed point iteration
+-----------------------------------------------------------------------------
+
+module GF.Data.SortedList
+    ( -- * type declarations
+      SList, SMap,
+      -- * set operations		    
+      nubsort, union, 
+      (<++>), (<\\>), (<**>), 
+      limit,
+      hasCommonElements, subset, 
+      -- * map operations
+      groupPairs, groupUnion,
+      unionMap, mergeMap
+    ) where
+
+import Data.List (groupBy)
+import GF.Data.Utilities (split, foldMerge)
+
+-- | The list must be sorted and contain no duplicates.
+type SList a = [a]
+
+-- | A sorted map also has unique keys, 
+-- i.e. 'map fst m :: SList a', if 'm :: SMap a b'
+type SMap a b = SList (a, b)
+
+-- | Group a set of key-value pairs into a sorted map
+groupPairs :: Ord a => SList (a, b) -> SMap a (SList b)
+groupPairs = map mapFst . groupBy eqFst
+    where mapFst as = (fst (head as), map snd as)
+	  eqFst a b = fst a == fst b
+
+-- | Group a set of key-(sets-of-values) pairs into a sorted map
+groupUnion :: (Ord a, Ord b) => SList (a, SList b) -> SMap a (SList b)
+groupUnion = map unionSnd . groupPairs
+    where unionSnd (a, bs) = (a, union bs)
+
+-- | True is the two sets has common elements
+hasCommonElements :: Ord a => SList a -> SList a -> Bool
+hasCommonElements as bs = not (null (as <**> bs))
+
+-- | True if the first argument is a subset of the second argument
+subset :: Ord a => SList a -> SList a -> Bool
+xs `subset` ys = null (xs <\\> ys)
+
+-- | Create a set from any list.
+-- This function can also be used as an alternative to @nub@ in @List.hs@
+nubsort :: Ord a => [a] -> SList a
+nubsort = union . map return
+
+-- | the union of a list of sorted maps
+unionMap :: Ord a => (b -> b -> b) 
+	 -> [SMap a b] -> SMap a b
+unionMap plus = foldMerge (mergeMap plus) []
+
+-- | merging two sorted maps
+mergeMap :: Ord a => (b -> b -> b) 
+	 -> SMap a b -> SMap a b -> SMap a b 
+mergeMap plus [] abs = abs
+mergeMap plus abs [] = abs
+mergeMap plus abs@(ab@(a,bs):abs') cds@(cd@(c,ds):cds')
+    = case compare a c of
+        EQ -> (a, plus bs ds) : mergeMap plus abs' cds'
+	LT -> ab : mergeMap plus abs' cds
+	GT -> cd : mergeMap plus abs  cds'
+
+-- | The union of a list of sets
+union :: Ord a => [SList a] -> SList a
+union = foldMerge (<++>) []
+
+-- | The union of two sets
+(<++>) :: Ord a => SList a -> SList a -> SList a 
+[] <++> bs = bs
+as <++> [] = as
+as@(a:as') <++> bs@(b:bs') = case compare a b of
+			       LT -> a : (as' <++> bs)
+			       GT -> b : (as  <++> bs')
+			       EQ -> a : (as' <++> bs')
+
+-- | The difference of two sets
+(<\\>) :: Ord a => SList a -> SList a -> SList a 
+[] <\\> bs = []
+as <\\> [] = as
+as@(a:as') <\\> bs@(b:bs') = case compare a b of
+			       LT -> a : (as' <\\> bs)
+			       GT ->     (as  <\\> bs')
+			       EQ ->     (as' <\\> bs')
+
+-- | The intersection of two sets
+(<**>) :: Ord a => SList a -> SList a -> SList a
+[] <**> bs = []
+as <**> [] = []
+as@(a:as') <**> bs@(b:bs') = case compare a b of
+			       LT ->     (as' <**> bs)
+			       GT ->     (as  <**> bs')
+			       EQ -> a : (as' <**> bs')
+
+-- | A fixed point iteration 
+limit :: Ord a => (a -> SList a)  -- ^ The iterator function
+      -> SList a                  -- ^ The initial set
+      -> SList a                  -- ^ The result of the iteration
+limit more start = limit' start start
+    where limit' chart agenda | null new' = chart
+			      | otherwise = limit' (chart <++> new') new'
+	      where new = union (map more agenda)
+		    new'= new <\\> chart
+
+
+
+
+

src/compiler/api/GF/Data/Str.hs

@@ -0,0 +1,134 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Str
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:22:09 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.8 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Data.Str (
+  Str, Tok,        --- constructors no longer needed in PrGrammar
+  str2strings, str, sstr, --sstrV, str2allStrings,
+  plusStr, glueStr, --prStr, isZeroTok,
+  strTok --, allItems
+) where
+
+--import GF.Data.Operations(prQuotedString)
+import Data.List (isPrefixOf) --, intersperse, isSuffixOf
+
+-- | abstract token list type. AR 2001, revised and simplified 20\/4\/2003
+newtype Str = Str [Tok]  deriving (Read, Show, Eq, Ord)
+
+-- | notice that having both pre and post would leave to inconsistent situations:
+--
+-- > pre {"x" ; "y" / "a"} ++ post {"b" ; "a" / "x"}
+--
+-- always violates a condition expressed by the one or the other
+data Tok = 
+   TK String
+ | TN Ss [(Ss, [String])] -- ^ variants depending on next string 
+--- | TP Ss [(Ss, [String])] -- variants depending on previous string
+    deriving (Eq, Ord, Show, Read)
+
+
+-- | a variant can itself be a token list, but for simplicity only a list of strings
+-- i.e. not itself containing variants
+type Ss = [String]
+
+-- matching functions in both ways
+
+matchPrefix :: Ss -> [(Ss,[String])] -> [String] -> Ss
+matchPrefix s vs t =
+  head $ [u | t':_ <- [unmarkup t],
+              (u,as) <- vs,
+              any (`isPrefixOf` t') as]
+         ++ [s]
+{-
+matchSuffix :: String -> Ss -> [(Ss,[String])] -> Ss
+matchSuffix t s vs = 
+  head ([u | (u,as) <- vs, any (\c -> isSuffixOf c t) as] ++ [s])
+-}
+unmarkup :: [String] -> [String]
+unmarkup = filter (not . isXMLtag) where
+  isXMLtag s = case s of
+    '<':cs@(_:_) -> last cs == '>'
+    _ -> False
+
+str2strings :: Str -> Ss
+str2strings (Str st) = alls st where 
+  alls st = case st of
+    TK s     : ts   -> s                   : alls ts
+    TN ds vs : ts   -> matchPrefix ds vs t ++ t where t = alls ts
+----    u :TP ds vs: ts -> [u] ++ matchSuffix u ds vs ++ alls ts
+    []              -> []
+{-
+str2allStrings :: Str -> [Ss]
+str2allStrings (Str st) = alls st where 
+  alls st = case st of
+    TK s     : ts -> [s        : t | t <- alls ts]
+    TN ds vs : [] -> [ds      ++ v | v <- map fst vs]
+    TN ds vs : ts -> [matchPrefix ds vs t ++ t | t <- alls ts]
+    []            -> [[]]
+-}
+sstr :: Str -> String
+sstr = unwords . str2strings
+{-
+-- | to handle a list of variants
+sstrV :: [Str] -> String
+sstrV ss = case ss of
+  []  -> "*"
+  _   -> unwords $ intersperse "/" $ map (unwords . str2strings) ss
+-}
+str :: String -> Str
+str s = if null s then Str [] else Str [itS s]
+
+itS :: String -> Tok
+itS s = TK s
+{-
+isZeroTok :: Str -> Bool
+isZeroTok t = case t of
+  Str [] -> True
+  Str [TK []] -> True
+  _ -> False
+-}
+strTok :: Ss -> [(Ss,[String])] -> Str
+strTok ds vs = Str [TN ds vs]
+{-
+prStr :: Str -> String
+prStr = prQuotedString . sstr
+-}
+plusStr :: Str -> Str -> Str
+plusStr (Str ss) (Str tt) = Str (ss ++ tt)
+
+glueStr :: Str -> Str -> Str
+glueStr (Str ss) (Str tt) = Str $ case (ss,tt) of
+  ([],_) -> tt
+  (_,[]) -> ss
+  _ -> init ss ++ glueIt (last ss) (head tt) ++ tail tt
+ where
+   glueIt t u = case (t,u) of
+     (TK s, TK s') -> return $ TK $ s ++ s'
+     (TN ds vs, TN es ws) -> return $ TN (glues (matchPrefix ds vs es) es) 
+                               [(glues (matchPrefix ds vs w) w,cs) | (w,cs) <- ws]
+     (TN ds vs, TK s) -> map TK $ glues (matchPrefix ds vs [s]) [s]
+     (TK s, TN es ws) -> return $ TN (glues [s] es) [(glues [s] w, c) | (w,c) <- ws]
+
+glues :: [[a]] -> [[a]] -> [[a]]
+glues ss tt = case (ss,tt) of
+  ([],_) -> tt
+  (_,[]) -> ss
+  _ -> init ss ++ [last ss ++ head tt] ++ tail tt
+{-
+-- | to create the list of all lexical items
+allItems :: Str -> [String]
+allItems (Str s) = concatMap allOne s where
+  allOne t = case t of
+    TK s -> [s]
+    TN ds vs -> ds ++ concatMap fst vs
+-}

src/compiler/api/GF/Data/Utilities.hs

@@ -0,0 +1,207 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/26 18:47:16 $
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.6 $
+--
+-- Basic functions not in the standard libraries
+-----------------------------------------------------------------------------
+
+
+module GF.Data.Utilities(module GF.Data.Utilities) where
+
+import Data.Maybe
+import Data.List
+import Control.Monad (MonadPlus(..),liftM,when)
+import qualified Data.Set as Set
+
+-- * functions on lists
+
+sameLength :: [a] -> [a] -> Bool
+sameLength [] [] = True
+sameLength (_:xs) (_:ys) = sameLength xs ys
+sameLength _ _ = False
+
+notLongerThan, longerThan :: Int -> [a] -> Bool
+notLongerThan n = null . snd . splitAt n
+longerThan    n = not . notLongerThan n
+
+lookupList :: Eq a => a -> [(a, b)] -> [b]
+lookupList a [] = []
+lookupList a (p:ps) | a == fst p = snd p : lookupList a ps
+                    | otherwise  =         lookupList a ps
+
+split :: [a] -> ([a], [a])
+split (x : y : as) = (x:xs, y:ys)
+    where (xs, ys) = split as
+split as = (as, [])
+
+splitBy :: (a -> Bool) -> [a] -> ([a], [a])
+splitBy p [] = ([], [])
+splitBy p (a : as) = if p a then (a:xs, ys) else (xs, a:ys)
+    where (xs, ys) = splitBy p as
+
+foldMerge :: (a -> a -> a) -> a -> [a] -> a
+foldMerge merge zero = fm
+    where fm [] = zero
+          fm [a] = a
+          fm abs = let (as, bs) = split abs in fm as `merge` fm bs
+
+select :: [a] -> [(a, [a])]
+select [] = []
+select (x:xs) = (x,xs) : [ (y,x:ys) | (y,ys) <- select xs ]
+
+updateNth :: (a -> a) -> Int -> [a] -> [a]
+updateNth update 0 (a : as) = update a : as
+updateNth update n (a : as) = a : updateNth update (n-1) as
+
+updateNthM :: Monad m => (a -> m a) -> Int -> [a] -> m [a]
+updateNthM update 0 (a : as) = liftM (:as) (update a)
+updateNthM update n (a : as) = liftM (a:)  (updateNthM update (n-1) as)
+
+-- | Like 'init', but returns the empty list when the input is empty.
+safeInit :: [a] -> [a]
+safeInit [] = []
+safeInit xs = init xs
+
+-- | Sorts and then groups elements given an ordering of the
+--   elements.
+sortGroupBy :: (a -> a -> Ordering) -> [a] -> [[a]]
+sortGroupBy f = groupBy (compareEq f) . sortBy f
+
+-- | Take the union of a list of lists.
+unionAll :: Eq a => [[a]] -> [a]
+unionAll = nub . concat
+
+-- | Like 'lookup', but fails if the argument is not found,
+--   instead of returning Nothing.
+lookup' :: (Show a, Eq a) => a -> [(a,b)] -> b
+lookup' x = fromMaybe (error $ "Not found: " ++ show x) . lookup x
+
+-- | Like 'find', but fails if nothing is found.
+find' :: (a -> Bool) -> [a] -> a
+find' p = fromJust . find p
+
+-- | Set a value in a lookup table.
+tableSet :: Eq a => a -> b -> [(a,b)] -> [(a,b)]
+tableSet x y [] = [(x,y)]
+tableSet x y (p@(x',_):xs) | x' == x = (x,y):xs
+                           | otherwise = p:tableSet x y xs
+
+-- | Group tuples by their first elements.
+buildMultiMap :: Ord a => [(a,b)] -> [(a,[b])]
+buildMultiMap = map (\g -> (fst (head g), map snd g) )
+                 . sortGroupBy (compareBy fst)
+
+-- * equality functions
+
+-- | Use an ordering function as an equality predicate.
+compareEq :: (a -> a -> Ordering) -> a -> a -> Bool
+compareEq f x y = case f x y of
+                             EQ -> True
+                             _ -> False
+
+-- * ordering functions
+
+compareBy :: Ord b => (a -> b) -> a -> a -> Ordering
+compareBy f = both f compare
+
+both :: (a -> b) -> (b -> b -> c) -> a -> a -> c
+both f g x y = g (f x) (f y)
+
+-- * functions on pairs
+
+apFst :: (a -> a') -> (a, b) -> (a', b)
+apFst f (a, b) = (f a, b)
+
+apSnd :: (b -> b') -> (a, b) -> (a, b')
+apSnd f (a, b) = (a, f b)
+
+apBoth :: (a -> b) -> (a, a) -> (b, b)
+apBoth f (x, y) = (f x, f y)
+
+-- * functions on lists of pairs
+
+mapFst = map . apFst
+mapSnd = map . apSnd
+mapBoth = map . apBoth
+
+-- * functions on monads
+
+-- | Return the given value if the boolean is true, els return 'mzero'.
+whenMP :: MonadPlus m => Bool -> a -> m a
+whenMP b x = if b then return x else mzero
+
+whenM bm m = flip when m =<< bm
+
+repeatM m = whenM m (repeatM m)
+
+-- * functions on Maybes
+
+-- | Returns true if the argument is Nothing or Just []
+nothingOrNull :: Maybe [a] -> Bool
+nothingOrNull = maybe True null
+
+-- * functions on functions
+
+-- | Apply all the functions in the list to the argument.
+foldFuns :: [a -> a] -> a -> a
+foldFuns fs x = foldl (flip ($)) x fs
+
+-- | Fixpoint iteration.
+fix :: Eq a => (a -> a) -> a -> a
+fix f x = let x' = f x in if x' == x then x else fix f x'
+
+-- * functions on strings
+
+-- | Join a number of lists by using the given glue
+--   between the lists.
+join :: [a] -- ^ glue
+     -> [[a]] -- ^ lists to join
+     -> [a]
+join g = concat . intersperse g
+
+-- * ShowS-functions
+
+nl :: ShowS
+nl = showChar '\n'
+
+sp :: ShowS
+sp = showChar ' '
+
+wrap :: String -> ShowS -> String -> ShowS
+wrap o s c = showString o . s . showString c
+
+concatS :: [ShowS] -> ShowS
+concatS = foldr (.) id
+
+unwordsS :: [ShowS] -> ShowS
+unwordsS = joinS " "
+
+unlinesS :: [ShowS] -> ShowS
+unlinesS = joinS "\n"
+
+joinS :: String -> [ShowS] -> ShowS
+joinS glue = concatS . intersperse (showString glue)
+
+
+
+-- | Like 'Data.List.nub', but O(n log n) instead of O(n^2), since it uses a set to lookup previous things.
+--   The result list is stable (the elements are returned in the order they occur), and lazy.
+--   Requires that the list elements can be compared by Ord.
+--   Code ruthlessly taken from <http://hpaste.org/54411>
+nub' :: Ord a => [a] -> [a]
+nub' = loop Set.empty
+    where loop _    []            = []
+          loop seen (x : xs)
+              | Set.member x seen = loop seen xs
+              | otherwise         = x : loop (Set.insert x seen) xs
+
+
+-- | Replace all occurences of an element by another element.
+replace :: Eq a => a -> a -> [a] -> [a]
+replace x y = map (\z -> if z == x then y else z)

src/compiler/api/GF/Data/XML.hs

@@ -0,0 +1,57 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : XML
+--
+-- Utilities for creating XML documents.
+----------------------------------------------------------------------
+module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML) where
+
+import GF.Data.Utilities
+
+data XML = Data String | CData String | Tag String [Attr] [XML] | ETag String [Attr] | Comment String | Empty
+ deriving (Ord,Eq,Show)
+
+type Attr = (String,String)
+
+comments :: [String] -> [XML]
+comments = map Comment
+
+showXMLDoc :: XML -> String
+showXMLDoc xml = showsXMLDoc xml ""
+
+showsXMLDoc :: XML -> ShowS
+showsXMLDoc xml = showString header . showsXML xml
+  where header = "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
+
+showsXML :: XML -> ShowS
+showsXML = showsX 0 where
+  showsX i x = ind i . case x of
+    (Data s) -> showString s
+    (CData s) -> showString "<![CDATA[" . showString s .showString "]]>"
+    (ETag t as) -> showChar '<' . showString t . showsAttrs as . showString "/>"
+    (Tag t as cs) -> 
+      showChar '<' . showString t . showsAttrs as . showChar '>' . 
+      concatS (map (showsX (i+1)) cs) . ind i . 
+      showString "</" . showString t . showChar '>'
+    (Comment c) -> showString "<!-- " . showString c . showString " -->"
+    (Empty) -> id
+  ind i = showString ("\n" ++ replicate (2*i) ' ')
+
+showsAttrs :: [Attr] -> ShowS
+showsAttrs = concatS . map (showChar ' ' .) . map showsAttr
+
+showsAttr :: Attr -> ShowS
+showsAttr (n,v) = showString n . showString "=\"" . showString (escape v) . showString "\""
+
+escape :: String -> String
+escape = concatMap escChar
+  where
+  escChar '<'  = "&lt;"
+  escChar '>'  = "&gt;"
+  escChar '&'  = "&amp;"
+  escChar '"'  = "&quot;"
+  escChar c    = [c]
+
+bottomUpXML :: (XML -> XML) -> XML -> XML
+bottomUpXML f (Tag n attrs cs) = f (Tag n attrs (map (bottomUpXML f) cs))
+bottomUpXML f x = f x

src/compiler/api/GF/Data/Zipper.hs

@@ -0,0 +1,257 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Zipper
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/06/11 20:27:05 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.9 $
+--
+-- Gérard Huet's zipper (JFP 7 (1997)). AR 10\/8\/2001
+-----------------------------------------------------------------------------
+
+module GF.Data.Zipper (-- * types
+	       Tr(..),
+	       Path(..),
+	       Loc(..),
+	       -- * basic (original) functions
+	       leaf,
+	       goLeft, goRight, goUp, goDown,
+	       changeLoc,
+	       changeNode,
+	       forgetNode,
+	       -- * added sequential representation
+	       goAhead,
+	       goBack,
+	       -- ** n-ary versions
+	       goAheadN,
+	       goBackN,
+	       -- * added mappings between locations and trees
+	       loc2tree,
+	       loc2treeMarked,
+	       tree2loc,
+	       goRoot,
+	       goLast,
+	       goPosition,
+	       getPosition,
+	       keepPosition,
+	       -- * added some utilities
+	       traverseCollect,
+	       scanTree,
+	       mapTr,
+	       mapTrM,
+	       mapPath,
+	       mapPathM,
+	       mapLoc,
+	       mapLocM,
+	       foldTr,
+	       foldTrM,
+	       mapSubtrees,
+	       mapSubtreesM,
+	       changeRoot,
+	       nthSubtree,
+	       arityTree
+	      ) where
+
+import GF.Data.Operations
+
+newtype Tr a = Tr (a,[Tr a]) deriving (Show,Eq)
+    
+data Path a = 
+    Top 
+  | Node ([Tr a], (Path a, a), [Tr a]) 
+   deriving Show
+
+leaf :: a -> Tr a
+leaf a = Tr (a,[])
+
+newtype Loc a = Loc (Tr a, Path a)     deriving Show
+
+goLeft, goRight, goUp, goDown :: Loc a -> Err (Loc a)
+goLeft (Loc (t,p)) = case p of
+  Top -> Bad "left of top"
+  Node (l:left, upv, right) -> return $ Loc (l, Node (left,upv,t:right))
+  Node _ -> Bad "left of first"
+goRight (Loc (t,p)) = case p of
+  Top -> Bad "right of top"
+  Node (left, upv, r:right) -> return $ Loc (r, Node (t:left,upv,right))
+  Node _ -> Bad "right of first"
+goUp (Loc (t,p)) = case p of
+  Top -> Bad "up of top"
+  Node (left, (up,v), right) -> 
+    return $ Loc (Tr (v, reverse left ++ (t:right)), up)
+goDown (Loc (t,p)) = case t of
+  Tr (v,(t1:trees)) -> return $ Loc (t1,Node ([],(p,v),trees))
+  _ -> Bad "down of empty"
+
+changeLoc :: Loc a -> Tr a -> Err (Loc a)
+changeLoc (Loc (_,p)) t = return $ Loc (t,p)
+
+changeNode :: (a -> a) -> Loc a -> Loc a
+changeNode f (Loc (Tr (n,ts),p)) = Loc (Tr (f n, ts),p)
+
+forgetNode :: Loc a -> Err (Loc a)
+forgetNode (Loc (Tr (n,[t]),p)) = return $ Loc (t,p)
+forgetNode _ = Bad $ "not a one-branch tree"
+
+-- added sequential representation
+
+-- | a successor function
+goAhead :: Loc a -> Err (Loc a) 
+goAhead s@(Loc (t,p)) = case (t,p) of
+  (Tr (_,_:_),Node (_,_,_:_)) -> goDown s
+  (Tr (_,[]), _)              -> upsRight s
+  (_,         _)              -> goDown s
+ where
+   upsRight t = case goRight t of
+     Ok t' -> return t'
+     Bad _ -> goUp t >>= upsRight
+
+-- | a predecessor function
+goBack :: Loc a -> Err (Loc a) 
+goBack s@(Loc (t,p)) = case goLeft s of
+  Ok s' -> downRight s'
+  _     -> goUp s
+ where
+   downRight s = case goDown s of
+     Ok s' -> case goRight s' of
+       Ok s'' -> downRight s''
+       _ -> downRight s'       
+     _     -> return s
+
+-- n-ary versions
+
+goAheadN :: Int ->  Loc a -> Err (Loc a)
+goAheadN i st
+  | i < 1     = return st
+  | otherwise = goAhead st >>= goAheadN (i-1)
+
+goBackN :: Int ->  Loc a -> Err (Loc a)
+goBackN i st
+  | i < 1     = return st
+  | otherwise = goBack st >>= goBackN (i-1)
+
+-- added mappings between locations and trees
+
+loc2tree :: Loc a -> Tr a
+loc2tree (Loc (t,p)) = case p of
+  Top -> t
+  Node (left,(p',v),right) -> 
+    loc2tree (Loc (Tr (v, reverse left ++ (t : right)),p'))
+
+loc2treeMarked :: Loc a -> Tr (a, Bool)
+loc2treeMarked (Loc (Tr (a,ts),p)) = 
+  loc2tree (Loc (Tr (mark a, map (mapTr nomark) ts), mapPath nomark p)) 
+ where 
+   (mark, nomark) = (\a -> (a,True), \a -> (a, False))
+
+tree2loc :: Tr a -> Loc a
+tree2loc t = Loc (t,Top)
+
+goRoot :: Loc a -> Loc a
+goRoot = tree2loc . loc2tree
+
+goLast :: Loc a -> Err (Loc a)
+goLast = rep goAhead where
+  rep f s = err (const (return s)) (rep f) (f s)
+
+goPosition :: [Int] -> Loc a -> Err (Loc a)
+goPosition p = go p . goRoot where
+  go []     s = return s
+  go (p:ps) s = goDown s >>= apply p goRight >>= go ps
+
+getPosition :: Loc a -> [Int]
+getPosition = reverse . getp where 
+  getp (Loc (t,p)) = case p of
+    Top -> []
+    Node (left,(p',v),_) -> length left : getp (Loc (Tr (v, []),p'))
+
+keepPosition :: (Loc a -> Err (Loc a)) -> (Loc a -> Err (Loc a))
+keepPosition f s = do
+  let p = getPosition s
+  s' <- f s
+  goPosition p s'
+
+apply :: Monad m => Int -> (a -> m a) -> a -> m a
+apply n f a = case n of
+  0 -> return a
+  _ -> f a >>= apply (n-1) f
+
+-- added some utilities
+
+traverseCollect :: Path a -> [a]
+traverseCollect p = reverse $ case p of
+  Top -> []
+  Node (_, (p',v), _) -> v : traverseCollect p'
+
+scanTree :: Tr a -> [a]
+scanTree (Tr (a,ts)) = a : concatMap scanTree ts
+
+mapTr :: (a -> b) -> Tr a -> Tr b
+mapTr f (Tr (x,ts)) = Tr (f x, map (mapTr f) ts)
+
+mapTrM :: Monad m => (a -> m b) -> Tr a -> m (Tr b)
+mapTrM f (Tr (x,ts)) = do
+  fx  <- f x
+  fts <- mapM (mapTrM f) ts
+  return $ Tr (fx,fts)
+
+mapPath :: (a -> b) -> Path a -> Path b
+mapPath f p = case p of
+  Node (ts1, (p,v), ts2) -> 
+    Node (map (mapTr f) ts1, (mapPath f p, f v), map (mapTr f) ts2)
+  Top -> Top
+
+mapPathM :: Monad m => (a -> m b) -> Path a -> m (Path b)
+mapPathM f p = case p of
+  Node (ts1, (p,v), ts2) -> do
+    ts1' <- mapM (mapTrM f) ts1
+    p'   <- mapPathM f p
+    v'   <- f v 
+    ts2' <- mapM (mapTrM f) ts2
+    return $ Node (ts1', (p',v'), ts2')
+  Top -> return Top
+
+mapLoc :: (a -> b) -> Loc a -> Loc b
+mapLoc f (Loc (t,p)) = Loc (mapTr f t, mapPath f p)
+
+mapLocM :: Monad m => (a -> m b) -> Loc a -> m (Loc b)
+mapLocM f (Loc (t,p)) = do
+  t' <- mapTrM f t
+  p' <- mapPathM f p
+  return $ (Loc (t',p'))
+
+foldTr :: (a -> [b] -> b) -> Tr a -> b
+foldTr f (Tr (x,ts)) = f x (map (foldTr f) ts)
+
+foldTrM :: Monad m => (a -> [b] -> m b) -> Tr a -> m b
+foldTrM f (Tr (x,ts)) = do
+  fts <- mapM (foldTrM f) ts
+  f x fts
+
+mapSubtrees :: (Tr a -> Tr a) -> Tr a -> Tr a
+mapSubtrees f t = let Tr (x,ts) = f t in Tr (x, map (mapSubtrees f) ts)
+
+mapSubtreesM :: Monad m => (Tr a -> m (Tr a)) -> Tr a -> m (Tr a)
+mapSubtreesM f t = do
+  Tr (x,ts) <- f t
+  ts' <- mapM (mapSubtreesM f) ts
+  return $ Tr (x, ts')
+
+-- | change the root without moving the pointer
+changeRoot :: (a -> a) -> Loc a -> Loc a
+changeRoot f loc = case loc of
+  Loc (Tr (a,ts),Top) -> Loc (Tr (f a,ts),Top)
+  Loc (t, Node (left,pv,right)) -> Loc (t, Node (left,chPath pv,right))
+ where
+   chPath pv = case pv of 
+     (Top,a) -> (Top, f a)
+     (Node (left,pv,right),v) -> (Node (left, chPath pv,right),v)
+
+nthSubtree :: Int -> Tr a -> Err (Tr a)
+nthSubtree n (Tr (a,ts)) = ts !? n
+
+arityTree :: Tr a -> Int
+arityTree (Tr (_,ts)) = length ts

src/compiler/api/GF/Grammar.hs

@@ -0,0 +1,29 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Abstract
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:22:18 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.4 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Grammar
+           ( module GF.Grammar.Grammar,
+             module GF.Grammar.Values,
+             module GF.Grammar.Macros,
+             module GF.Grammar.Parser,
+             module GF.Grammar.Printer,
+             module GF.Infra.Ident
+           ) where
+
+import GF.Grammar.Grammar
+import GF.Grammar.Values
+import GF.Grammar.Macros
+import GF.Grammar.Parser
+import GF.Grammar.Printer
+import GF.Infra.Ident

src/compiler/api/GF/Grammar/Analyse.hs

@@ -0,0 +1,155 @@
+module GF.Grammar.Analyse (
+        stripSourceGrammar,
+        constantDepsTerm,
+        sizeTerm,
+        sizeConstant,
+        sizesModule,
+        sizesGrammar,
+        printSizesGrammar
+        ) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Text.Pretty(render)
+--import GF.Infra.Option ---
+import GF.Grammar.Macros
+import GF.Grammar.Lookup
+
+import GF.Data.Operations
+
+import qualified Data.Map as Map
+import Data.List (nub)
+--import Debug.Trace
+
+stripSourceGrammar :: Grammar -> Grammar
+stripSourceGrammar sgr = mGrammar [(i, m{jments = Map.map stripInfo (jments m)}) | (i,m) <- modules sgr]
+
+stripInfo :: Info -> Info
+stripInfo i = case i of
+  AbsCat _ -> i
+  AbsFun mt mi me mb -> AbsFun mt mi Nothing mb
+  ResParam mp mt -> ResParam mp Nothing
+  ResValue lt _ -> i ----
+  ResOper mt md -> ResOper mt Nothing
+  ResOverload is fs -> ResOverload is [(lty, L loc (EInt 0)) | (lty,L loc _) <- fs]
+  CncCat mty mte _ mtf mpmcfg -> CncCat mty Nothing Nothing Nothing Nothing
+  CncFun mict mte mtf mpmcfg -> CncFun mict Nothing Nothing Nothing
+  AnyInd b f -> i
+
+constantsInTerm :: Term -> [QIdent]
+constantsInTerm = nub . consts where
+  consts t = case t of
+    Q c  -> [c]
+    QC c -> [c]
+    _ -> collectOp consts t
+
+constantDeps :: Grammar -> QIdent -> Err [QIdent]
+constantDeps sgr f = return $ nub $ iterFix more start where
+  start = constants f
+  more  = concatMap constants
+  constants c = (c :) $ fromErr [] $ do
+    ts  <- termsOfConstant sgr c
+    return $ concatMap constantsInTerm ts
+
+getIdTerm :: Term -> Err QIdent
+getIdTerm t = case t of
+  Q i  -> return i
+  QC i -> return i
+  P (Vr r) l -> return (MN r,label2ident l) --- needed if term is received from parser
+  _ -> Bad ("expected qualified constant, not " ++ show t)
+
+constantDepsTerm :: Grammar -> Term -> Err [Term]
+constantDepsTerm sgr t = do
+  i <- getIdTerm t
+  cs <- constantDeps sgr i
+  return $ map Q cs  --- losing distinction Q/QC
+
+termsOfConstant :: Grammar -> QIdent -> Err [Term]
+termsOfConstant sgr c = case lookupOverload sgr c of
+  Ok tts -> return $ concat [[ty,tr] | (_,(ty,tr)) <- tts]
+  _ -> return $
+         [ty | Ok ty <- [lookupResType sgr c]] ++  -- type sig may be missing
+         [ty | Ok ty <- [lookupResDef sgr c]]
+
+sizeConstant :: Grammar -> Term -> Int
+sizeConstant sgr t = err (const 0) id $ do
+  c  <- getIdTerm t
+  fmap (sum . map sizeTerm) $ termsOfConstant sgr c
+
+-- the number of constructors in a term, ignoring position information and unnecessary types
+-- ground terms count as 1, i.e. as "one work" each
+sizeTerm :: Term -> Int
+sizeTerm t = case t of
+  App c a      -> sizeTerm c + sizeTerm a  -- app nodes don't count 
+  Abs _ _ b    -> 2 + sizeTerm b
+  Prod _ _ a b -> 2 + sizeTerm a + sizeTerm b 
+  S c a        -> 1 + sizeTerm c + sizeTerm a
+  Table a c    -> 1 + sizeTerm a + sizeTerm c
+  ExtR a c     -> 1 + sizeTerm a + sizeTerm c
+  R r          -> 1 + sum [1 + sizeTerm a | (_,(_,a)) <- r]  -- label counts as 1, type ignored
+  RecType r    -> 1 + sum [1 + sizeTerm a | (_,a)     <- r]  -- label counts as 1
+  P t i        -> 2 + sizeTerm t
+  T _ cc       -> 1 + sum [1 + sizeTerm (patt2term p) + sizeTerm v | (p,v) <- cc]
+  V ty cc      -> 1 + sizeTerm ty + sum [1 + sizeTerm v | v <- cc]
+  Let (x,(mt,a)) b -> 2 + maybe 0 sizeTerm mt + sizeTerm a + sizeTerm b
+  C s1 s2      -> 1 + sizeTerm s1 + sizeTerm s2 
+  Glue s1 s2   -> 1 + sizeTerm s1 + sizeTerm s2 
+  Alts t aa    -> 1 + sizeTerm t + sum [sizeTerm p + sizeTerm v | (p,v) <- aa]
+  FV ts        -> 1 + sum (map sizeTerm ts)
+  Strs tt      -> 1 + sum (map sizeTerm tt)
+  _            -> 1
+
+
+-- the size of a judgement
+sizeInfo :: Info -> Int
+sizeInfo i = case i of
+  AbsCat (Just (L _ co)) -> 1 + sum [1 + sizeTerm ty | (_,_,ty) <- co]
+  AbsFun mt mi me mb -> 1 + msize mt + 
+    sum [sum (map (sizeTerm . patt2term) ps) + sizeTerm t | Just es <- [me], L _ (ps,t) <- es]
+  ResParam mp mt -> 
+    1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just (L _ ps) <- [mp], (_,co) <- ps]
+  ResValue _ _ -> 0
+  ResOper mt md -> 1 + msize mt + msize md
+  ResOverload is fs -> 1 + sum [sizeTerm ty + sizeTerm tr | (L _ ty, L _ tr) <- fs]
+  CncCat mty _ _ _ _ -> 1 + msize mty   -- ignoring lindef, linref and printname
+  CncFun mict mte mtf _ -> 1 + msize mte  -- ignoring type and printname
+  AnyInd b f -> -1  -- just to ignore these in the size
+  _ -> 0
+ where 
+  msize mt = case mt of
+    Just (L _ t) -> sizeTerm t
+    _ -> 0
+{-
+-- the size of a module
+sizeModule :: SourceModule -> Int
+sizeModule = fst . sizesModule
+-}
+sizesModule :: SourceModule -> (Int, [(Ident,Int)])
+sizesModule (_,m) = 
+  let 
+    js = Map.toList (jments m) 
+    tb = [(i,k) | (i,j) <- js, let k = sizeInfo j, k >= 0]
+  in (length tb + sum (map snd tb),tb)
+{-
+-- the size of a grammar
+sizeGrammar :: Grammar -> Int
+sizeGrammar = fst . sizesGrammar
+-}
+sizesGrammar :: Grammar -> (Int,[(ModuleName,(Int,[(Ident,Int)]))])
+sizesGrammar g = 
+  let 
+    ms = modules g 
+    mz = [(i,sizesModule m) | m@(i,j) <- ms]
+  in (length mz + sum (map (fst . snd) mz), mz)
+
+printSizesGrammar :: Grammar -> String
+printSizesGrammar g = unlines $ 
+  ("total" +++ show s):
+  [render m +++ "total" +++ show i ++++ 
+   unlines [indent 2 (showIdent j +++ show k) | (j,k) <- js]
+     | (m,(i,js)) <- sg
+  ]
+ where
+   (s,sg) = sizesGrammar g
+
+

src/compiler/api/GF/Grammar/BNFC.hs

@@ -0,0 +1,109 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : CFEG 
+-- Maintainer  : Gleb Lobanov 
+-- Stability   : (experimental)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2016/03/16 19:59:00 $ 
+-- > CVS $Author: Gleb Lobanov $
+-- > CVS $Revision: 0.1 $
+--
+-- Contains a function to convert extended CF grammars to CF grammars. 
+-----------------------------------------------------------------------------
+
+module GF.Grammar.BNFC(BNFCRule(..), BNFCSymbol, Symbol(..), CFTerm(..), bnfc2cf) where
+
+import GF.Grammar.CFG
+import Data.List (partition)
+
+type IsList = Bool
+type BNFCSymbol = Symbol (Cat, IsList) Token
+data BNFCRule = BNFCRule {
+                 lhsCat :: Cat,
+                 ruleRhs :: [BNFCSymbol],
+                 ruleName :: CFTerm }
+              | BNFCCoercions {
+                 coerCat :: Cat,
+                 coerNum :: Integer }
+              | BNFCTerminator {
+                 termNonEmpty :: Bool,
+                 termCat :: Cat,
+                 termSep :: String }
+              | BNFCSeparator {
+                 sepNonEmpty :: Bool,
+                 sepCat :: Cat,
+                 sepSep :: String }
+              deriving (Eq, Ord, Show)
+
+type IsNonempty  = Bool
+type IsSeparator = Bool
+type SepTermSymb = String 
+type SepMap      = [(Cat, (IsNonempty, IsSeparator, SepTermSymb))]
+
+bnfc2cf :: [BNFCRule] -> [ParamCFRule]
+bnfc2cf rules = concatMap (transformRules (map makeSepTerm rules1)) rules2
+  where (rules1,rules2) = partition isSepTerm rules
+        makeSepTerm (BNFCTerminator ne c s) = (c, (ne, False, s))
+        makeSepTerm (BNFCSeparator  ne c s) = (c, (ne, True,  s))
+
+isSepTerm :: BNFCRule -> Bool
+isSepTerm (BNFCTerminator {}) = True
+isSepTerm (BNFCSeparator  {}) = True
+isSepTerm _                   = False
+
+transformRules :: SepMap -> BNFCRule -> [ParamCFRule]
+transformRules sepMap (BNFCRule c smbs@(s:ss) r) = Rule (c,[0]) cfSmbs r : rls
+  where smbs'   = map (transformSymb sepMap) smbs
+        cfSmbs  = [snd s | s            <- smbs']
+        ids = filter (/= "") [fst s | s <- smbs']
+        rls = concatMap (createListRules sepMap) ids
+transformRules sepMap (BNFCCoercions c num) = rules ++ [lastRule]
+          where rules = map (fRules c)  [0..num-1]
+                lastRule = Rule (c',[0]) ss rn
+                  where c' = c ++ show num
+                        ss = [Terminal "(", NonTerminal (c,[0]), Terminal ")"]
+                        rn = CFObj ("coercion_" ++ c) []
+
+fRules c n = Rule (c',[0]) ss rn
+   where c' = if n == 0 then c else c ++ show n
+         ss = [NonTerminal (c ++ show (n+1),[0])]
+         rn = CFObj ("coercion_" ++ c') []
+
+transformSymb :: SepMap -> BNFCSymbol -> (String, ParamCFSymbol)
+transformSymb sepMap s = case s of
+  NonTerminal (c,False) -> ("", NonTerminal (c,[0]))
+  NonTerminal (c,True ) -> let needsCoercion = 
+                                 case lookup c sepMap of
+                                   Just (ne, isSep, symb) -> isSep && symb /= "" && not ne
+                                   Nothing                -> False
+                           in (c , NonTerminal ("List" ++ c,if needsCoercion then [0,1] else [0]))
+  Terminal t            -> ("", Terminal t)
+
+createListRules :: SepMap -> String -> [ParamCFRule]
+createListRules sepMap c =
+  case lookup c sepMap of
+    Just (ne, isSep, symb) -> createListRules' ne isSep symb c
+    Nothing                -> createListRules' False True "" c
+
+createListRules':: IsNonempty -> IsSeparator -> SepTermSymb -> String -> [ParamCFRule]
+createListRules' ne isSep symb c = ruleBase : ruleCons
+  where ruleBase = Rule ("List" ++ c,[0]) smbs rn
+          where smbs = if isSep
+                       then [NonTerminal (c,[0]) | ne]
+                       else [NonTerminal (c,[0]) | ne] ++
+                            [Terminal symb | symb /= "" && ne]
+                rn   = CFObj ("Base" ++ c) []
+        ruleCons
+          | isSep && symb /= "" && not ne = [Rule ("List" ++ c,[1]) smbs0 rn
+                                            ,Rule ("List" ++ c,[1]) smbs1 rn]
+          | otherwise                     = [Rule ("List" ++ c,[0]) smbs  rn]
+          where smbs0 =[NonTerminal (c,[0])] ++
+                       [NonTerminal ("List" ++ c,[0])]
+                smbs1 =[NonTerminal (c,[0])] ++
+                       [Terminal symb] ++
+                       [NonTerminal ("List" ++ c,[1])]
+                smbs = [NonTerminal (c,[0])] ++
+                       [Terminal symb | symb /= ""] ++
+                       [NonTerminal ("List" ++ c,[0])]
+                rn   = CFObj ("Cons" ++ c) []

src/compiler/api/GF/Grammar/Binary.hs

@@ -0,0 +1,382 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.Grammar.Binary
+-- Maintainer  : Krasimir Angelov
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-----------------------------------------------------------------------------
+
+module GF.Grammar.Binary(VersionTagged(..),decodeModuleHeader,decodeModule,encodeModule) where
+
+import Prelude hiding (catch)
+import Control.Monad
+import Control.Exception(catch,ErrorCall(..),throwIO)
+import Data.Binary
+import qualified Data.Map as Map(empty)
+import qualified Data.ByteString.Char8 as BS
+
+import GF.Data.Operations
+import GF.Infra.Ident
+import GF.Infra.Option
+import GF.Infra.UseIO(MonadIO(..))
+import GF.Grammar.Grammar
+
+import PGF2(Literal(..))
+import PGF2.Transactions(Symbol(..))
+
+-- Please change this every time when the GFO format is changed
+gfoVersion = "GF05"
+
+instance Binary Grammar where
+  put = put . modules
+  get = fmap mGrammar get
+
+instance Binary ModuleInfo where
+  put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,mseqs mi,jments mi)
+  get    = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,mseqs,jments) <- get
+              return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc mseqs jments)
+
+instance Binary ModuleType where
+  put MTAbstract       = putWord8 0
+  put MTResource       = putWord8 2
+  put (MTConcrete i)   = putWord8 3 >> put i
+  put MTInterface      = putWord8 4
+  put (MTInstance i)   = putWord8 5 >> put i
+  get = do tag <- getWord8
+           case tag of
+             0 -> return MTAbstract
+             2 -> return MTResource
+             3 -> get >>= return . MTConcrete
+             4 -> return MTInterface
+             5 -> get >>= return . MTInstance
+             _ -> decodingError
+
+instance Binary MInclude where
+  put MIAll         = putWord8 0
+  put (MIOnly xs)   = putWord8 1 >> put xs
+  put (MIExcept xs) = putWord8 2 >> put xs
+  get = do tag <- getWord8
+           case tag of
+             0 -> return MIAll
+             1 -> fmap MIOnly get
+             2 -> fmap MIExcept get
+             _ -> decodingError
+
+instance Binary OpenSpec where
+  put (OSimple i)   = putWord8 0 >> put i
+  put (OQualif i j) = putWord8 1 >> put (i,j)
+  get = do tag <- getWord8
+           case tag of
+             0 -> get >>= return . OSimple
+             1 -> get >>= \(i,j) -> return (OQualif i j)
+             _ -> decodingError
+
+instance Binary ModuleStatus where
+  put MSComplete   = putWord8 0
+  put MSIncomplete = putWord8 1
+  get = do tag <- getWord8
+           case tag of
+             0 -> return MSComplete
+             1 -> return MSIncomplete
+             _ -> decodingError
+
+instance Binary Options where
+  put = put . optionsGFO
+  get = do opts <- get
+           case parseModuleOptions ["--" ++ flag ++ "=" ++ toString value | (flag,value) <- opts] of
+             Ok  x   -> return x
+             Bad msg -> fail msg
+           where
+             toString (LStr s) = s
+             toString (LInt n) = show n
+             toString (LFlt d) = show d
+
+instance Binary LParam where
+  put (LParam r rs) = put (r,rs)
+  get = get >>= \(r,rs) -> return (LParam r rs)
+
+instance Binary PArg where
+  put (PArg x y) = put (x,y)
+  get = get >>= \(x,y) -> return (PArg x y)
+
+instance Binary Production where
+  put (Production ps args res rules) = put (ps,args,res,rules)
+  get = get >>= \(ps,args,res,rules) -> return (Production ps args res rules)
+
+instance Binary Info where
+  put (AbsCat x)       = putWord8 0 >> put x
+  put (AbsFun w x y z) = putWord8 1 >> put (w,x,y,z)
+  put (ResParam x y)   = putWord8 2 >> put (x,y)
+  put (ResValue x y)   = putWord8 3 >> put (x,y)
+  put (ResOper x y)    = putWord8 4 >> put (x,y)
+  put (ResOverload x y)= putWord8 5 >> put (x,y)
+  put (CncCat v w x y z)=putWord8 6 >> put (v,w,x,y,z)
+  put (CncFun w x y z) = putWord8 7 >> put (w,x,y,z)
+  put (AnyInd x y)     = putWord8 8 >> put (x,y)
+  get = do tag <- getWord8
+           case tag of
+             0 -> get >>= \x         -> return (AbsCat x)
+             1 -> get >>= \(w,x,y,z) -> return (AbsFun w x y z)
+             2 -> get >>= \(x,y)     -> return (ResParam x y)
+             3 -> get >>= \(x,y)     -> return (ResValue x y)
+             4 -> get >>= \(x,y)     -> return (ResOper x y)
+             5 -> get >>= \(x,y)     -> return (ResOverload x y)
+             6 -> get >>= \(v,w,x,y,z)->return (CncCat v w x y z)
+             7 -> get >>= \(w,x,y,z) -> return (CncFun w x y z)
+             8 -> get >>= \(x,y)     -> return (AnyInd x y)
+             _ -> decodingError
+
+instance Binary Location where
+  put NoLoc          = putWord8 0
+  put (Local x y)    = putWord8 1 >> put (x,y)
+  put (External x y) = putWord8 2 >> put (x,y)
+  get = do tag <- getWord8
+           case tag of
+             0 ->                   return NoLoc
+             1 -> get >>= \(x,y) -> return (Local x y)
+             2 -> get >>= \(x,y) -> return (External x y)
+
+instance Binary a => Binary (L a) where
+  put (L x y) = put (x,y)
+  get = get >>= \(x,y) -> return (L x y)
+
+instance Binary Term where
+  put (Vr x)        = putWord8 0  >> put x
+  put (Cn x)        = putWord8 1  >> put x
+  put (Con x)       = putWord8 2  >> put x
+  put (Sort x)      = putWord8 3  >> put x
+  put (EInt x)      = putWord8 4  >> put x
+  put (EFloat x)    = putWord8 5  >> put x
+  put (K x)         = putWord8 6  >> put x
+  put (Empty)       = putWord8 7
+  put (App x y)     = putWord8 8  >> put (x,y)
+  put (Abs x y z)   = putWord8 9 >> put (x,y,z)
+  put (Meta x)      = putWord8 10 >> put x
+  put (ImplArg x)   = putWord8 11 >> put x
+  put (Prod w x y z)= putWord8 12 >> put (w,x,y,z)
+  put (Typed x y)   = putWord8 13 >> put (x,y)
+  put (Example x y) = putWord8 14 >> put (x,y)
+  put (RecType x)   = putWord8 15 >> put x
+  put (R x)         = putWord8 16 >> put x
+  put (P x y)       = putWord8 17 >> put (x,y)
+  put (ExtR x y)    = putWord8 18 >> put (x,y)
+  put (Table x y)   = putWord8 19 >> put (x,y)
+  put (T x y)       = putWord8 20 >> put (x,y)
+  put (V x y)       = putWord8 21 >> put (x,y)
+  put (S x y)       = putWord8 22 >> put (x,y)
+  put (Let x y)     = putWord8 23 >> put (x,y)
+  put (Q x)         = putWord8 24 >> put x
+  put (QC x)        = putWord8 25 >> put x
+  put (C x y)       = putWord8 26 >> put (x,y)
+  put (Glue x y)    = putWord8 27 >> put (x,y)
+  put (EPatt x y z) = putWord8 28 >> put (x,y,z)
+  put (EPattType x) = putWord8 29 >> put x
+  put (ELincat x y) = putWord8 30 >> put (x,y)
+  put (ELin x y)    = putWord8 31 >> put (x,y)
+  put (FV x)        = putWord8 32 >> put x
+  put (Alts x y)    = putWord8 33 >> put (x,y)
+  put (Strs x)      = putWord8 34 >> put x
+
+  get = do tag <- getWord8
+           case tag of
+             0  -> get >>= \x       -> return (Vr x)
+             1  -> get >>= \x       -> return (Cn x)
+             2  -> get >>= \x       -> return (Con x)
+             3  -> get >>= \x       -> return (Sort x)
+             4  -> get >>= \x       -> return (EInt x)
+             5  -> get >>= \x       -> return (EFloat x)
+             6  -> get >>= \x       -> return (K x)
+             7  ->                     return (Empty)
+             8  -> get >>= \(x,y)   -> return (App x y)
+             9  -> get >>= \(x,y,z) -> return (Abs x y z)
+             10 -> get >>= \x       -> return (Meta x)
+             11 -> get >>= \x       -> return (ImplArg x)
+             12 -> get >>= \(w,x,y,z)->return (Prod w x y z)
+             13 -> get >>= \(x,y)   -> return (Typed x y)
+             14 -> get >>= \(x,y)   -> return (Example x y)
+             15 -> get >>= \x       -> return (RecType x)
+             16 -> get >>= \x       -> return (R x)
+             17 -> get >>= \(x,y)   -> return (P x y)
+             18 -> get >>= \(x,y)   -> return (ExtR x y)
+             19 -> get >>= \(x,y)   -> return (Table x y)
+             20 -> get >>= \(x,y)   -> return (T x y)
+             21 -> get >>= \(x,y)   -> return (V x y)
+             22 -> get >>= \(x,y)   -> return (S x y)
+             23 -> get >>= \(x,y)   -> return (Let x y)
+             24 -> get >>= \x       -> return (Q  x)
+             25 -> get >>= \x       -> return (QC x)
+             26 -> get >>= \(x,y)   -> return (C x y)
+             27 -> get >>= \(x,y)   -> return (Glue x y)
+             28 -> get >>= \(x,y,z) -> return (EPatt x y z)
+             29 -> get >>= \x       -> return (EPattType x)
+             30 -> get >>= \(x,y)   -> return (ELincat x y)
+             31 -> get >>= \(x,y)   -> return (ELin x y)
+             32 -> get >>= \x       -> return (FV x)
+             33 -> get >>= \(x,y)   -> return (Alts x y)
+             34 -> get >>= \x       -> return (Strs x)
+             _  -> decodingError
+
+instance Binary Patt where
+  put (PC x y)     = putWord8  0 >> put (x,y)
+  put (PP x y)     = putWord8  1 >> put (x,y)
+  put (PV x)       = putWord8  2 >> put x
+  put (PW)         = putWord8  3
+  put (PR x)       = putWord8  4 >> put x
+  put (PString x)  = putWord8  5 >> put x
+  put (PInt    x)  = putWord8  6 >> put x
+  put (PFloat  x)  = putWord8  7 >> put x
+  put (PT x y)     = putWord8  8 >> put (x,y)
+  put (PAs  x y)   = putWord8 10 >> put (x,y)
+  put (PNeg x)     = putWord8 11 >> put x
+  put (PAlt x y)   = putWord8 12 >> put (x,y)
+  put (PSeq minx maxx x miny maxy y)   = putWord8 13 >> put (minx,maxx,x,miny,maxy,y)
+  put (PRep minx maxx x)= putWord8 14 >> put (minx,maxx,x)
+  put (PChar)      = putWord8 15
+  put (PChars x)   = putWord8 16 >> put x
+  put (PMacro x)   = putWord8 17 >> put x
+  put (PM x)       = putWord8 18 >> put x
+  put (PTilde x)   = putWord8 19 >> put x
+  put (PImplArg x) = putWord8 20 >> put x
+  get = do tag <- getWord8
+           case tag of
+             0  -> get >>= \(x,y)   -> return (PC x y)
+             1  -> get >>= \(x,y)   -> return (PP x y)
+             2  -> get >>= \x       -> return (PV x)
+             3  ->                     return (PW)
+             4  -> get >>= \x       -> return (PR x)
+             5  -> get >>= \x       -> return (PString x)
+             6  -> get >>= \x       -> return (PInt    x)
+             7  -> get >>= \x       -> return (PFloat  x)
+             8  -> get >>= \(x,y)   -> return (PT x y)
+             10 -> get >>= \(x,y)   -> return (PAs  x y)
+             11 -> get >>= \x       -> return (PNeg x)
+             12 -> get >>= \(x,y)   -> return (PAlt x y)
+             13 -> get >>= \(minx,maxx,x,miny,maxy,y) -> return (PSeq minx maxx x miny maxy y)
+             14 -> get >>= \(minx,maxx,x)-> return (PRep minx maxx x)
+             15 ->                     return (PChar)
+             16 -> get >>= \x       -> return (PChars x)
+             17 -> get >>= \x       -> return (PMacro x)
+             18 -> get >>= \x       -> return (PM x)
+             19 -> get >>= \x       -> return (PTilde x)
+             20 -> get >>= \x       -> return (PImplArg x)
+             _  -> decodingError
+
+instance Binary TInfo where
+  put TRaw       = putWord8 0
+  put (TTyped t) = putWord8 1 >> put t
+  put (TComp  t) = putWord8 2 >> put t
+  put (TWild  t) = putWord8 3 >> put t
+  get = do tag <- getWord8
+           case tag of
+             0 -> return TRaw
+             1 -> fmap TTyped get
+             2 -> fmap TComp  get
+             3 -> fmap TWild  get
+             _ -> decodingError
+
+instance Binary Label where
+  put (LIdent bs) = putWord8 0 >> put bs
+  put (LVar i)    = putWord8 1 >> put i
+  get = do tag <- getWord8
+           case tag of
+             0 -> fmap LIdent get
+             1 -> fmap LVar   get
+             _ -> decodingError
+
+instance Binary BindType where
+  put Explicit = putWord8 0
+  put Implicit = putWord8 1
+  get = do tag <- getWord8
+           case tag of
+             0 -> return Explicit
+             1 -> return Implicit
+             _ -> decodingError
+
+instance Binary Literal where
+  put (LStr s) = putWord8 0 >> put s
+  put (LInt i) = putWord8 1 >> put i
+  put (LFlt d) = putWord8 2 >> put d
+  get = do tag <- getWord8
+           case tag of
+             0 -> liftM  LStr get
+             1 -> liftM  LInt get
+             2 -> liftM  LFlt get
+             _ -> decodingError
+
+instance Binary Symbol where
+  put (SymCat d r)       = putWord8 0 >> put (d,r)
+  put (SymLit d r)       = putWord8 1 >> put (d,r)
+  put (SymVar n l)       = putWord8 2 >> put (n,l)
+  put (SymKS ts)         = putWord8 3 >> put ts
+  put (SymKP d vs)       = putWord8 4 >> put (d,vs)
+  put SymBIND            = putWord8 5
+  put SymSOFT_BIND       = putWord8 6
+  put SymNE              = putWord8 7
+  put SymSOFT_SPACE      = putWord8 8
+  put SymCAPIT           = putWord8 9
+  put SymALL_CAPIT       = putWord8 10
+  get = do tag <- getWord8
+           case tag of
+             0 -> liftM2 SymCat get get
+             1 -> liftM2 SymLit get get
+             2 -> liftM2 SymVar get get
+             3 -> liftM  SymKS  get
+             4 -> liftM2 (\d vs -> SymKP d vs) get get
+             5 -> return SymBIND
+             6 -> return SymSOFT_BIND
+             7 -> return SymNE
+             8 -> return SymSOFT_SPACE
+             9 -> return SymCAPIT
+             10-> return SymALL_CAPIT
+             _ -> decodingError
+
+--putGFOVersion = mapM_ (putWord8 . fromIntegral . ord) gfoVersion
+--getGFOVersion = replicateM (length gfoVersion) (fmap (chr . fromIntegral) getWord8)
+--putGFOVersion = put gfoVersion
+--getGFOVersion = get :: Get VersionMagic
+
+
+data VersionTagged a = Tagged {unV::a} | WrongVersion
+
+instance Binary a => Binary (VersionTagged a) where
+  put (Tagged a) = put (gfoBinVersion,a)
+  get = do ver <- get
+           if ver==gfoBinVersion
+             then fmap Tagged get
+             else return WrongVersion
+
+instance Functor VersionTagged where
+  fmap f (Tagged a) = Tagged (f a)
+  fmap f WrongVersion = WrongVersion
+
+gfoBinVersion = (b1,b2,b3,b4)
+  where [b1,b2,b3,b4] = map (toEnum.fromEnum) gfoVersion :: [Word8]
+
+
+decodeModule :: MonadIO io => FilePath -> io SourceModule
+decodeModule fpath = liftIO $ check =<< decodeFile' fpath
+  where
+    check (Tagged m) = return m
+    check _ = fail ".gfo file version mismatch"
+
+-- | Read just the module header, the returned 'Module' will have an empty body
+decodeModuleHeader :: MonadIO io => FilePath -> io (VersionTagged Module)
+decodeModuleHeader = liftIO . fmap (fmap conv) . decodeFile'
+  where
+    conv (m,mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc) =
+        (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Nothing Map.empty)
+
+encodeModule :: MonadIO io => FilePath -> SourceModule -> io ()
+encodeModule fpath mo = liftIO $ encodeFile fpath (Tagged mo)
+
+-- | like 'decodeFile' but adds file name to error message if there was an error
+decodeFile' fpath = addFPath fpath (decodeFile fpath)
+
+-- | Adds file name to error message if there was an error,
+-- | but laziness can cause errors to slip through
+addFPath fpath m = m `catch` handle
+  where
+    handle (ErrorCall msg) = throwIO (ErrorCall (fpath++": "++msg))
+
+decodingError = fail "This file was compiled with different version of GF"

src/compiler/api/GF/Grammar/CFG.hs

@@ -0,0 +1,385 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.Grammar.CFG
+--
+-- Context-free grammar representation and manipulation.
+----------------------------------------------------------------------
+module GF.Grammar.CFG(Cat,Token, module GF.Grammar.CFG) where
+
+import GF.Data.Utilities
+import PGF2(Fun,Cat)
+import PGF2.Transactions(Token)
+import GF.Data.Relation
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.List
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+--
+-- * Types
+--
+
+data Symbol c t = NonTerminal c | Terminal t
+  deriving (Eq, Ord, Show)
+
+data Rule c t = Rule { 
+      ruleLhs  :: c,
+      ruleRhs  :: [Symbol c t],
+      ruleName :: CFTerm 
+    }
+  deriving (Eq, Ord, Show)
+
+data Grammar c t = Grammar { 
+      cfgStartCat     :: c,
+      cfgExternalCats :: Set c,
+      cfgRules        :: Map c (Set (Rule c t)) }
+  deriving (Eq, Ord, Show)
+
+data CFTerm
+    = CFObj Fun [CFTerm] -- ^ an abstract syntax function with arguments
+    | CFAbs Int CFTerm -- ^ A lambda abstraction. The Int is the variable id.
+    | CFApp CFTerm CFTerm -- ^ Application
+    | CFRes Int -- ^ The result of the n:th (0-based) non-terminal
+    | CFVar Int -- ^ A lambda-bound variable
+    | CFMeta Fun -- ^ A metavariable
+  deriving (Eq, Ord, Show)
+
+type CFSymbol = Symbol  Cat Token
+type CFRule   = Rule    Cat Token
+type CFG      = Grammar Cat Token
+
+type Param         = Int
+type ParamCFSymbol = Symbol (Cat,[Param]) Token
+type ParamCFRule   = Rule    (Cat,[Param]) Token
+type ParamCFG      = Grammar (Cat,[Param]) Token
+
+--
+-- * Grammar filtering
+--
+
+-- | Removes all directly and indirectly cyclic productions.
+--   FIXME: this may be too aggressive, only one production
+--   needs to be removed to break a given cycle. But which
+--   one should we pick?
+--   FIXME: Does not (yet) remove productions which are cyclic
+--   because of empty productions.
+removeCycles :: (Ord c,Ord t) => Grammar c t -> Grammar c t
+removeCycles = onRules f
+  where f rs = filter (not . isCycle) rs
+          where alias = transitiveClosure $ mkRel [(c,c') | Rule c [NonTerminal c'] _ <- rs]
+                isCycle (Rule c [NonTerminal c'] _) = isRelatedTo alias c' c
+                isCycle _ = False
+
+-- | Better bottom-up filter that also removes categories which contain no finite
+-- strings.
+bottomUpFilter :: (Ord c,Ord t) => Grammar c t -> Grammar c t
+bottomUpFilter gr = fix grow (gr { cfgRules = Map.empty })
+  where grow g = g `unionCFG` filterCFG (all (okSym g) . ruleRhs) gr
+        okSym g = symbol (`elem` allCats g) (const True)
+
+-- | Removes categories which are not reachable from any external category.
+topDownFilter :: (Ord c,Ord t) => Grammar c t -> Grammar c t
+topDownFilter cfg = filterCFGCats (`Set.member` keep) cfg
+  where
+    rhsCats = [ (ruleLhs r, c') | r <- allRules cfg, c' <- filterCats (ruleRhs r) ]
+    uses = reflexiveClosure_ (allCats cfg) $ transitiveClosure $ mkRel rhsCats
+    keep = Set.unions $ map (allRelated uses) $ Set.toList $ cfgExternalCats cfg
+
+-- | Merges categories with identical right-hand-sides.
+-- FIXME: handle probabilities
+mergeIdentical :: CFG -> CFG
+mergeIdentical g = onRules (map subst) g
+  where
+    -- maps categories to their replacement
+    m = Map.fromList [(y,concat (intersperse "+" xs)) 
+                          | (_,xs) <- buildMultiMap [(rulesKey rs,c) | (c,rs) <- Map.toList (cfgRules g)], y <- xs]
+    -- build data to compare for each category: a set of name,rhs pairs
+    rulesKey = Set.map (\ (Rule _ r n) -> (n,r))
+    subst (Rule c r n) = Rule (substCat c) (map (mapSymbol substCat id) r) n
+    substCat c = Map.findWithDefault (error $ "mergeIdentical: " ++ c) c m
+
+-- | Keeps only the start category as an external category.
+purgeExternalCats :: Grammar c t -> Grammar c t
+purgeExternalCats cfg = cfg { cfgExternalCats = Set.singleton (cfgStartCat cfg) }
+
+--
+-- * Removing left recursion
+--
+
+-- The LC_LR algorithm from
+-- http://research.microsoft.com/users/bobmoore/naacl2k-proc-rev.pdf
+removeLeftRecursion :: CFG -> CFG
+removeLeftRecursion gr 
+    = gr { cfgRules = groupProds $ concat [scheme1, scheme2, scheme3, scheme4] }
+  where
+    scheme1 = [Rule a [x,NonTerminal a_x] n' | 
+               a <- retainedLeftRecursive, 
+               x <- properLeftCornersOf a,
+               not (isLeftRecursive x),
+               let a_x = mkCat (NonTerminal a) x,
+               -- this is an extension of LC_LR to avoid generating
+               -- A-X categories for which there are no productions:
+               a_x `Set.member` newCats,
+               let n' = symbol (\_ -> CFApp (CFRes 1) (CFRes 0))
+                               (\_ -> CFRes 0) x] 
+    scheme2 = [Rule a_x (beta++[NonTerminal a_b]) n' | 
+               a <- retainedLeftRecursive, 
+               b@(NonTerminal b') <- properLeftCornersOf a,
+               isLeftRecursive b,
+               Rule _ (x:beta) n <- catRules gr b', 
+               let a_x = mkCat (NonTerminal a) x,
+               let a_b = mkCat (NonTerminal a) b,
+               let i = length $ filterCats beta,
+               let n' = symbol (\_ -> CFAbs 1 (CFApp (CFRes i) (shiftTerm n)))
+                               (\_ -> CFApp (CFRes i) n) x]
+    scheme3 = [Rule a_x beta n' |
+               a <- retainedLeftRecursive, 
+               x <- properLeftCornersOf a,
+               Rule _ (x':beta) n <- catRules gr a,
+               x == x',
+               let a_x = mkCat (NonTerminal a) x,
+               let n' = symbol (\_ -> CFAbs 1 (shiftTerm n)) 
+                               (\_ -> n) x]
+    scheme4 = catSetRules gr $ Set.fromList $ filter (not . isLeftRecursive . NonTerminal) cats
+
+    newCats = Set.fromList (map ruleLhs (scheme2 ++ scheme3))
+
+    shiftTerm :: CFTerm -> CFTerm
+    shiftTerm (CFObj f ts) = CFObj f (map shiftTerm ts)
+    shiftTerm (CFRes 0) = CFVar 1
+    shiftTerm (CFRes n) = CFRes (n-1)
+    shiftTerm t = t
+    -- note: the rest don't occur in the original grammar
+
+    cats = allCats gr
+--  rules = allRules gr
+
+    directLeftCorner = mkRel [(NonTerminal c,t) | Rule c (t:_) _ <- allRules gr]
+--  leftCorner = reflexiveClosure_ (map NonTerminal cats) $ transitiveClosure directLeftCorner
+    properLeftCorner = transitiveClosure directLeftCorner
+    properLeftCornersOf = Set.toList . allRelated properLeftCorner . NonTerminal
+--  isProperLeftCornerOf = flip (isRelatedTo properLeftCorner)
+
+    leftRecursive = reflexiveElements properLeftCorner
+    isLeftRecursive = (`Set.member` leftRecursive)
+
+    retained = cfgStartCat gr `Set.insert`
+                Set.fromList [a | r <- allRules (filterCFGCats (not . isLeftRecursive . NonTerminal) gr),
+                                  NonTerminal a <- ruleRhs r]
+--  isRetained = (`Set.member` retained)
+
+    retainedLeftRecursive = filter (isLeftRecursive . NonTerminal) $ Set.toList retained
+
+    mkCat :: CFSymbol -> CFSymbol -> Cat
+    mkCat x y = showSymbol x ++ "-" ++ showSymbol y
+        where showSymbol = symbol id show
+
+-- | Get the sets of mutually recursive non-terminals for a grammar.
+mutRecCats :: Ord c
+           => Bool    -- ^ If true, all categories will be in some set.
+                      --   If false, only recursive categories will be included.
+           -> Grammar c t -> [Set c]
+mutRecCats incAll g = equivalenceClasses $ refl $ symmetricSubrelation $ transitiveClosure r
+  where r = mkRel [(c,c') | Rule c ss _ <- allRules g, NonTerminal c' <- ss]
+        refl = if incAll then reflexiveClosure_ (allCats g) else reflexiveSubrelation
+
+--
+-- * Approximate context-free grammars with regular grammars.
+--
+
+makeSimpleRegular :: CFG -> CFG
+makeSimpleRegular = makeRegular . topDownFilter . bottomUpFilter . removeCycles
+
+-- Use the transformation algorithm from \"Regular Approximation of Context-free
+-- Grammars through Approximation\", Mohri and Nederhof, 2000
+-- to create an over-generating regular grammar for a context-free 
+-- grammar
+makeRegular :: CFG -> CFG
+makeRegular g = g { cfgRules = groupProds $ concatMap trSet (mutRecCats True g) }
+  where trSet cs | allXLinear cs rs = rs
+                 | otherwise = concatMap handleCat (Set.toList cs)
+            where rs = catSetRules g cs
+                  handleCat c = [Rule c' [] (mkCFTerm (c++"-empty"))] -- introduce A' -> e
+                                ++ concatMap (makeRightLinearRules c) (catRules g c)
+                      where c' = newCat c
+                  makeRightLinearRules b' (Rule c ss n) = 
+                      case ys of
+                              [] -> newRule b' (xs ++ [NonTerminal (newCat c)]) n -- no non-terminals left
+                              (NonTerminal b:zs) -> newRule b' (xs ++ [NonTerminal b]) n 
+                                        ++ makeRightLinearRules (newCat b) (Rule c zs n)
+                      where (xs,ys) = break (`catElem` cs) ss
+                            -- don't add rules on the form A -> A
+                            newRule c rhs n | rhs == [NonTerminal c] = []
+                                            | otherwise = [Rule c rhs n]
+        newCat c = c ++ "$"
+
+--
+-- * CFG Utilities
+--
+
+mkCFG :: (Ord c,Ord t) => c -> Set c -> [Rule c t] -> Grammar c t
+mkCFG start ext rs = Grammar { cfgStartCat = start, cfgExternalCats = ext, cfgRules = groupProds rs }
+
+groupProds :: (Ord c,Ord t) => [Rule c t] -> Map c (Set (Rule c t))
+groupProds = Map.fromListWith Set.union . map (\r -> (ruleLhs r,Set.singleton r))
+
+uniqueFuns :: [Rule c t] -> [Rule c t]
+uniqueFuns = snd . mapAccumL uniqueFun Set.empty
+  where
+    uniqueFun funs (Rule cat items (CFObj fun args)) = (Set.insert fun' funs,Rule cat items (CFObj fun' args))
+      where
+        fun' = head [fun'|suffix<-"":map show ([2..]::[Int]),
+                          let fun'=fun++suffix,
+                          not (fun' `Set.member` funs)]
+
+-- | Gets all rules in a CFG.
+allRules :: Grammar c t -> [Rule c t]
+allRules = concatMap Set.toList . Map.elems . cfgRules
+
+-- | Gets all rules in a CFG, grouped by their LHS categories.
+allRulesGrouped :: Grammar c t -> [(c,[Rule c t])]
+allRulesGrouped = Map.toList . Map.map Set.toList . cfgRules
+
+-- | Gets all categories which have rules.
+allCats :: Grammar c t -> [c]
+allCats = Map.keys . cfgRules
+
+-- | Gets all categories which have rules or occur in a RHS.
+allCats' :: (Ord c,Ord t) => Grammar c t -> [c]
+allCats' cfg = Set.toList (Map.keysSet (cfgRules cfg) `Set.union` 
+                           Set.fromList [c | rs <- Map.elems (cfgRules cfg), 
+                                             r  <- Set.toList rs, 
+                                             NonTerminal c <- ruleRhs r])
+
+-- | Gets all rules for the given category.
+catRules :: Ord c => Grammar c t -> c -> [Rule c t]
+catRules gr c = Set.toList $ Map.findWithDefault Set.empty c (cfgRules gr)
+
+-- | Gets all rules for categories in the given set.
+catSetRules :: CFG -> Set Cat -> [CFRule]
+catSetRules gr cs = allRules $ filterCFGCats (`Set.member` cs) gr
+
+mapCFGCats :: (Ord c,Ord c',Ord t) => (c -> c') -> Grammar c t -> Grammar c' t
+mapCFGCats f cfg = Grammar (f (cfgStartCat cfg)) 
+                           (Set.map f (cfgExternalCats cfg))
+                           (groupProds [Rule (f lhs) (map (mapSymbol f id) rhs) t | Rule lhs rhs t <- allRules cfg])
+
+onRules :: (Ord c,Ord t) => ([Rule c t] -> [Rule c t]) -> Grammar c t -> Grammar c t
+onRules f cfg = cfg { cfgRules = groupProds $ f $ allRules cfg }
+
+-- | Clean up CFG after rules have been removed.
+cleanCFG :: Ord c => Grammar c t -> Grammar c t
+cleanCFG cfg = cfg{ cfgRules = Map.filter (not . Set.null) (cfgRules cfg) }
+
+-- | Combine two CFGs.
+unionCFG :: (Ord c,Ord t) => Grammar c t -> Grammar c t -> Grammar c t
+unionCFG x y = x { cfgRules = Map.unionWith Set.union (cfgRules x) (cfgRules y) }
+
+filterCFG :: (Rule c t -> Bool) -> Grammar c t -> Grammar c t
+filterCFG p cfg = cfg { cfgRules = Map.mapMaybe filterRules (cfgRules cfg) }
+  where
+    filterRules rules = 
+      let rules' = Set.filter p rules
+      in if Set.null rules' then Nothing else Just rules'
+
+filterCFGCats :: (c -> Bool) -> Grammar c t -> Grammar c t
+filterCFGCats p cfg = cfg { cfgRules = Map.filterWithKey (\c _ -> p c) (cfgRules cfg) }
+
+countCats :: Ord c => Grammar c t -> Int
+countCats = Map.size . cfgRules . cleanCFG
+
+countRules :: Grammar c t -> Int
+countRules = length . allRules
+
+prCFG :: CFG -> String
+prCFG = prProductions . map prRule . allRules
+    where 
+      prRule r = (ruleLhs r, unwords (map prSym (ruleRhs r)))
+      prSym = symbol id (\t -> "\""++ t ++"\"")
+
+prProductions :: [(Cat,String)] -> String
+prProductions prods = 
+    unlines [rpad maxLHSWidth lhs ++ " ::= " ++ rhs | (lhs,rhs) <- prods]
+    where
+      maxLHSWidth = maximum $ 0:(map (length . fst) prods)
+      rpad n s = s ++ replicate (n - length s) ' '
+
+prCFTerm :: CFTerm -> String
+prCFTerm = pr 0
+  where
+    pr p (CFObj f args) = paren p (f ++ " (" ++ concat (intersperse "," (map (pr 0) args)) ++ ")")
+    pr p (CFAbs i t) = paren p ("\\x" ++ show i ++ ". " ++ pr 0 t)
+    pr p (CFApp t1 t2) = paren p (pr 1 t1 ++ "(" ++ pr 0 t2 ++ ")")
+    pr _ (CFRes i) = "$" ++ show i
+    pr _ (CFVar i) = "x" ++ show i
+    pr _ (CFMeta c) = "?" ++ c
+    paren 0 x = x
+    paren 1 x = "(" ++ x ++ ")"
+
+--
+-- * CFRule Utilities
+--
+
+ruleFun :: Rule c t -> Fun
+ruleFun (Rule _ _ t) = f t
+  where f (CFObj n _) = n
+        f (CFApp _ x) = f x
+        f (CFAbs _ x) = f x
+        f _ = ""
+
+-- | Check if any of the categories used on the right-hand side
+--   are in the given list of categories.
+anyUsedBy :: Eq c => [c] -> Rule c t -> Bool
+anyUsedBy cs (Rule _ ss _) = any (`elem` cs) (filterCats ss)
+
+mkCFTerm :: String -> CFTerm
+mkCFTerm n = CFObj n []
+
+ruleIsNonRecursive :: Ord c => Set c -> Rule c t -> Bool
+ruleIsNonRecursive cs = noCatsInSet cs . ruleRhs
+
+-- | Check if all the rules are right-linear, or all the rules are
+--   left-linear, with respect to given categories.
+allXLinear :: Ord c => Set c -> [Rule c t] -> Bool
+allXLinear cs rs = all (isRightLinear cs) rs || all (isLeftLinear cs) rs
+
+-- | Checks if a context-free rule is right-linear.
+isRightLinear :: Ord c
+              => Set c    -- ^ The categories to consider
+              -> Rule c t -- ^ The rule to check for right-linearity
+              -> Bool
+isRightLinear cs = noCatsInSet cs . safeInit . ruleRhs
+
+-- | Checks if a context-free rule is left-linear.
+isLeftLinear :: Ord c
+             => Set c    -- ^ The categories to consider
+             -> Rule c t -- ^ The rule to check for left-linearity
+             -> Bool
+isLeftLinear cs = noCatsInSet cs . drop 1 . ruleRhs
+
+
+--
+-- * Symbol utilities
+--
+
+symbol :: (c -> a) -> (t -> a) -> Symbol c t -> a
+symbol fc ft (NonTerminal cat) = fc cat
+symbol fc ft (Terminal tok) = ft tok
+
+mapSymbol :: (c -> c') -> (t -> t') -> Symbol c t -> Symbol c' t'
+mapSymbol fc ft = symbol (NonTerminal . fc) (Terminal . ft)
+
+filterCats :: [Symbol c t] -> [c]
+filterCats syms = [ cat | NonTerminal cat <- syms ]
+
+filterToks :: [Symbol c t] -> [t]
+filterToks syms = [ tok | Terminal tok <- syms ]
+
+-- | Checks if a symbol is a non-terminal of one of the given categories.
+catElem :: Ord c => Symbol c t -> Set c -> Bool
+catElem s cs = symbol (`Set.member` cs) (const False) s
+
+noCatsInSet :: Ord c => Set c -> [Symbol c t] -> Bool
+noCatsInSet cs = not . any (`catElem` cs)

src/compiler/api/GF/Grammar/Canonical.hs

@@ -0,0 +1,304 @@
+-- |
+-- Module    :  GF.Grammar.Canonical
+-- Stability :  provisional
+--
+-- Abstract syntax for canonical GF grammars, i.e. what's left after
+-- high-level constructions such as functors and opers have been eliminated
+-- by partial evaluation. This is intended as a common intermediate
+-- representation to simplify export to other formats.
+
+{-# LANGUAGE DeriveTraversable #-}
+module GF.Grammar.Canonical where
+
+import Prelude hiding ((<>))
+import GF.Text.Pretty
+import GF.Infra.Ident (RawIdent)
+import PGF(Literal(..))
+
+-- | A Complete grammar
+data Grammar = Grammar Abstract [Concrete] deriving Show
+
+--------------------------------------------------------------------------------
+-- ** Abstract Syntax
+
+-- | Abstract Syntax
+data Abstract = Abstract ModId Flags [CatDef] [FunDef] deriving Show
+abstrName (Abstract mn _ _ _) = mn
+
+data CatDef   = CatDef CatId [CatId]        deriving Show
+data FunDef   = FunDef FunId Type           deriving Show
+data Type     = Type [TypeBinding] TypeApp  deriving Show
+data TypeApp  = TypeApp CatId [Type]        deriving Show
+
+data TypeBinding = TypeBinding VarId Type   deriving Show
+
+--------------------------------------------------------------------------------
+-- ** Concreate syntax
+
+-- | Concrete Syntax
+data Concrete  = Concrete ModId ModId Flags [ParamDef] [LincatDef] [LinDef]
+                 deriving Show
+concName (Concrete cnc _ _ _ _ _) = cnc
+
+data ParamDef  = ParamDef ParamId [ParamValueDef]
+               | ParamAliasDef ParamId LinType
+               deriving Show
+data LincatDef = LincatDef CatId LinType  deriving Show
+data LinDef    = LinDef FunId [VarId] LinValue  deriving Show
+
+-- | Linearization type, RHS of @lincat@
+data LinType = FloatType
+             | IntType
+             | ParamType ParamType
+             | RecordType [RecordRowType]
+             | StrType
+             | TableType LinType LinType
+             | TupleType [LinType]
+              deriving (Eq,Ord,Show)
+
+newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
+
+-- | Linearization value, RHS of @lin@
+data LinValue = ConcatValue LinValue LinValue
+              | LiteralValue Literal
+              | ErrorValue String
+              | ParamConstant ParamValue
+              | PredefValue PredefId
+              | RecordValue [RecordRowValue]
+              | TableValue LinType [TableRowValue]
+---           | VTableValue LinType [LinValue]
+              | TupleValue [LinValue]
+              | VariantValue [LinValue]
+              | VarValue VarValueId
+              | PreValue [([String], LinValue)] LinValue
+              | Projection LinValue LabelId
+              | Selection LinValue LinValue
+              | CommentedValue String LinValue
+              deriving (Eq,Ord,Show)
+
+data LinPattern = ParamPattern ParamPattern
+                | RecordPattern [RecordRow LinPattern]
+                | TuplePattern [LinPattern]
+                | WildPattern
+                deriving (Eq,Ord,Show)
+
+type ParamValue = Param LinValue
+type ParamPattern = Param LinPattern
+type ParamValueDef = Param ParamId
+
+data Param arg = Param ParamId [arg]
+                 deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
+
+type RecordRowType  = RecordRow LinType
+type RecordRowValue = RecordRow LinValue
+type TableRowValue  = TableRow LinValue
+
+data RecordRow rhs = RecordRow LabelId    rhs
+                     deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
+data TableRow  rhs = TableRow  LinPattern rhs
+                     deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
+
+-- *** Identifiers in Concrete Syntax
+
+newtype PredefId = PredefId Id        deriving (Eq,Ord,Show)
+newtype LabelId  = LabelId Id         deriving (Eq,Ord,Show)
+data VarValueId  = VarValueId QualId  deriving (Eq,Ord,Show)
+
+-- | Name of param type or param value
+newtype ParamId = ParamId QualId  deriving (Eq,Ord,Show)
+
+--------------------------------------------------------------------------------
+-- ** Used in both Abstract and Concrete Syntax
+
+newtype ModId = ModId Id  deriving (Eq,Ord,Show)
+
+newtype CatId = CatId Id  deriving (Eq,Ord,Show)
+newtype FunId = FunId Id  deriving (Eq,Show)
+
+data VarId = Anonymous | VarId Id  deriving Show
+
+newtype Flags = Flags [(FlagName,Literal)] deriving Show
+type FlagName = Id
+
+
+-- *** Identifiers
+
+type Id = RawIdent
+data QualId = Qual ModId Id | Unqual Id  deriving (Eq,Ord,Show)
+
+--------------------------------------------------------------------------------
+-- ** Pretty printing
+
+instance Pretty Grammar where
+  pp (Grammar abs cncs) = abs $+$ vcat cncs
+
+instance Pretty Abstract where
+  pp (Abstract m flags cats funs) =
+    "abstract" <+> m <+> "=" <+> "{" $$
+       flags $$
+       "cat" <+> fsep cats $$
+       "fun" <+> vcat funs $$
+       "}"
+
+instance Pretty CatDef where
+  pp (CatDef c cs) = hsep (c:cs)<>";"
+
+instance Pretty FunDef where
+  pp (FunDef f ty) = f <+> ":" <+> ty <>";"
+
+instance Pretty Type where
+  pp (Type bs ty) = sep (punctuate " ->" (map pp bs ++ [pp ty]))
+
+instance PPA Type where
+  ppA (Type [] (TypeApp c [])) = pp c
+  ppA t = parens t
+
+instance Pretty TypeBinding where
+  pp (TypeBinding Anonymous (Type [] tapp)) = pp tapp
+  pp (TypeBinding Anonymous ty) = parens ty
+  pp (TypeBinding (VarId x) ty) = parens (x<+>":"<+>ty)
+
+instance Pretty TypeApp where
+ pp (TypeApp c targs) = c<+>hsep (map ppA targs)
+
+instance Pretty VarId where
+  pp Anonymous = pp "_"
+  pp (VarId x) = pp x
+
+--------------------------------------------------------------------------------
+
+instance Pretty Concrete where
+  pp (Concrete cncid absid flags params lincats lins) =
+      "concrete" <+> cncid <+> "of" <+> absid <+> "=" <+> "{" $$
+      vcat params $$
+      section "lincat" lincats $$
+      section "lin" lins $$
+      "}"
+    where
+      section name [] = empty
+      section name ds = name <+> vcat (map (<> ";") ds)
+
+instance Pretty ParamDef where
+  pp (ParamDef p pvs) = hang ("param"<+> p <+> "=") 4 (punctuate " |" pvs)<>";"
+  pp (ParamAliasDef p t) = hang ("oper"<+> p <+> "=") 4 t<>";"
+
+instance PPA arg => Pretty (Param arg) where
+  pp (Param p ps) = pp p<+>sep (map ppA ps)
+
+instance PPA arg => PPA (Param arg) where
+  ppA (Param p []) = pp p
+  ppA pv = parens pv
+
+instance Pretty LincatDef where
+  pp (LincatDef c lt) = hang (c <+> "=") 4 lt
+
+instance Pretty LinType where
+ pp lt = case lt of
+           FloatType -> pp "Float"
+           IntType -> pp "Int"
+           ParamType pt -> pp pt
+           RecordType rs -> block rs
+           StrType -> pp "Str"
+           TableType pt lt -> sep [pt <+> "=>",pp lt]
+           TupleType lts -> "<"<>punctuate "," lts<>">"
+
+instance RhsSeparator LinType  where rhsSep _ = pp ":"
+
+instance Pretty ParamType where
+  pp (ParamTypeId p) = pp p
+
+instance Pretty LinDef where
+  pp (LinDef f xs lv) = hang (f<+>hsep xs<+>"=") 4 lv
+
+instance Pretty LinValue where
+  pp lv = case lv of
+            ConcatValue v1 v2 -> sep [v1 <+> "++",pp v2]
+            ErrorValue s -> "Predef.error"<+>doubleQuotes s
+            ParamConstant pv -> pp pv
+            Projection lv l -> ppA lv<>"."<>l
+            Selection tv pv -> ppA tv<>"!"<>ppA pv
+            VariantValue vs -> "variants"<+>block vs
+            CommentedValue s v -> "{-" <+> s <+> "-}" $$ v
+            _ -> ppA lv
+
+instance PPA LinValue where
+  ppA lv = case lv of
+             LiteralValue l -> ppA l
+             ParamConstant pv -> ppA pv
+             PredefValue p -> ppA p
+             RecordValue [] -> pp "<>"
+             RecordValue rvs -> block rvs
+             PreValue alts def ->
+               "pre"<+>block (map alt alts++["_"<+>"=>"<+>def])
+               where
+                 alt (ss,lv) = hang (hcat (punctuate "|" (map doubleQuotes ss)))
+                                    2 ("=>"<+>lv)
+             TableValue _ tvs -> "table"<+>block tvs
+--           VTableValue t ts -> "table"<+>t<+>brackets (semiSep ts)
+             TupleValue lvs -> "<"<>punctuate "," lvs<>">"
+             VarValue v -> pp v
+             _ -> parens lv
+
+instance Pretty Literal where pp = ppA
+
+instance PPA Literal where
+  ppA l = case l of
+            LFlt f -> pp f
+            LInt n -> pp n
+            LStr s -> doubleQuotes s -- hmm
+
+instance RhsSeparator LinValue where rhsSep _ = pp "="
+
+instance Pretty LinPattern where
+  pp p =
+    case p of
+      ParamPattern pv -> pp pv
+      _ -> ppA p
+
+instance PPA LinPattern where
+  ppA p =
+    case p of
+      ParamPattern pv -> ppA pv
+      RecordPattern r -> block r
+      TuplePattern ps -> "<"<>punctuate "," ps<>">"
+      WildPattern     -> pp "_"
+
+instance RhsSeparator LinPattern where rhsSep _ = pp "="
+
+instance RhsSeparator rhs => Pretty (RecordRow rhs) where
+  pp (RecordRow l v) = hang (l<+>rhsSep v) 2 v
+
+instance Pretty rhs => Pretty (TableRow rhs) where
+  pp (TableRow l v) = hang (l<+>"=>") 2 v
+
+--------------------------------------------------------------------------------
+instance Pretty ModId where pp (ModId s) = pp s
+instance Pretty CatId where pp (CatId s) = pp s
+instance Pretty FunId where pp (FunId s) = pp s
+instance Pretty LabelId where pp (LabelId s) = pp s
+instance Pretty PredefId where pp = ppA
+instance PPA    PredefId where ppA (PredefId s) = "Predef."<>s
+instance Pretty ParamId where pp = ppA
+instance PPA    ParamId where ppA (ParamId s) = pp s
+instance Pretty VarValueId where pp (VarValueId s) = pp s
+
+instance Pretty QualId where pp = ppA
+
+instance PPA QualId where
+  ppA (Qual m n) = m<>"_"<>n -- hmm
+  ppA (Unqual n) = pp n
+
+instance Pretty Flags where
+  pp (Flags []) = empty
+  pp (Flags flags) = "flags" <+> vcat (map ppFlag flags)
+    where
+      ppFlag (name,value) = name <+> "=" <+> value <>";"
+
+--------------------------------------------------------------------------------
+-- | Pretty print atomically (i.e. wrap it in parentheses if necessary)
+class Pretty a => PPA a where ppA :: a -> Doc
+
+class Pretty rhs => RhsSeparator rhs where rhsSep :: rhs -> Doc
+
+semiSep xs = punctuate ";" xs
+block xs = braces (semiSep xs)

src/compiler/api/GF/Grammar/CanonicalJSON.hs

@@ -0,0 +1,289 @@
+module GF.Grammar.CanonicalJSON (
+  encodeJSON
+  ) where
+
+import Text.JSON
+import Control.Applicative ((<|>))
+import Data.Ratio (denominator, numerator)
+import GF.Grammar.Canonical
+import Control.Monad (guard)
+import GF.Infra.Ident (RawIdent,showRawIdent,rawIdentS)
+import PGF(Literal(..))
+
+encodeJSON :: FilePath -> Grammar -> IO ()
+encodeJSON fpath g = writeFile fpath (encode g)
+
+
+-- in general we encode grammars using JSON objects/records,
+-- except for newtypes/coercions/direct values
+
+-- the top-level definitions use normal record labels,
+-- but recursive types/values/ids use labels staring with a "."
+
+instance JSON Grammar where
+  showJSON (Grammar abs cncs) = makeObj [("abstract", showJSON abs), ("concretes", showJSON cncs)]
+
+  readJSON o = Grammar <$> o!"abstract" <*> o!"concretes"
+
+
+--------------------------------------------------------------------------------
+-- ** Abstract Syntax
+
+instance JSON Abstract where
+  showJSON (Abstract absid flags cats funs)
+    = makeObj [("abs", showJSON absid),
+               ("flags", showJSON flags),
+               ("cats", showJSON cats),
+               ("funs", showJSON funs)]
+
+  readJSON o = Abstract
+    <$> o!"abs"
+    <*>(o!"flags" <|> return (Flags []))
+    <*> o!"cats"
+    <*> o!"funs"
+
+instance JSON CatDef where
+  -- non-dependent categories are encoded as simple strings:
+  showJSON (CatDef c []) = showJSON c
+  showJSON (CatDef c cs) = makeObj [("cat", showJSON c), ("args", showJSON cs)]
+
+  readJSON o = CatDef <$> readJSON o <*> return []
+    <|>        CatDef <$> o!"cat" <*> o!"args"
+
+instance JSON FunDef where
+  showJSON (FunDef f ty) = makeObj [("fun", showJSON f), ("type", showJSON ty)]
+
+  readJSON o = FunDef <$> o!"fun" <*> o!"type"
+
+instance JSON Type where
+  showJSON (Type bs ty) = makeObj [(".args", showJSON bs), (".result", showJSON ty)]
+
+  readJSON o = Type <$> o!".args" <*> o!".result"
+
+instance JSON TypeApp where
+  -- non-dependent categories are encoded as simple strings:
+  showJSON (TypeApp c [])   = showJSON c
+  showJSON (TypeApp c args) = makeObj [(".cat", showJSON c), (".args", showJSON args)]
+
+  readJSON o = TypeApp <$> readJSON o <*> return []
+    <|>        TypeApp <$> o!".cat" <*> o!".args"
+
+instance JSON TypeBinding where
+  -- non-dependent categories are encoded as simple strings:
+  showJSON (TypeBinding Anonymous (Type [] (TypeApp c []))) = showJSON c
+  showJSON (TypeBinding x ty) = makeObj [(".var", showJSON x), (".type", showJSON ty)]
+
+  readJSON o = do c <- readJSON o
+                  return (TypeBinding Anonymous (Type [] (TypeApp c [])))
+           <|> TypeBinding <$> o!".var" <*> o!".type"
+
+
+--------------------------------------------------------------------------------
+-- ** Concrete syntax
+
+instance JSON Concrete where
+  showJSON (Concrete cncid absid flags params lincats lins)
+    = makeObj [("cnc", showJSON cncid),
+               ("abs", showJSON absid),
+               ("flags", showJSON flags),
+               ("params", showJSON params),
+               ("lincats", showJSON lincats),
+               ("lins", showJSON lins)]
+
+  readJSON o = Concrete
+    <$> o!"cnc"
+    <*> o!"abs"
+    <*>(o!"flags" <|> return (Flags []))
+    <*> o!"params"
+    <*> o!"lincats"
+    <*> o!"lins"
+
+instance JSON ParamDef where
+  showJSON (ParamDef      p pvs) = makeObj [("param", showJSON p), ("values", showJSON pvs)]
+  showJSON (ParamAliasDef p t)   = makeObj [("param", showJSON p), ("alias", showJSON t)]
+
+  readJSON o = ParamDef      <$> o!"param" <*> o!"values"
+    <|>        ParamAliasDef <$> o!"param" <*> o!"alias"
+
+instance JSON LincatDef where
+  showJSON (LincatDef c lt) = makeObj [("cat", showJSON c), ("lintype", showJSON lt)]
+
+  readJSON o = LincatDef <$> o!"cat" <*> o!"lintype"
+
+instance JSON LinDef where
+  showJSON (LinDef f xs lv) = makeObj [("fun", showJSON f), ("args", showJSON xs), ("lin", showJSON lv)]
+
+  readJSON o = LinDef <$> o!"fun" <*> o!"args" <*> o!"lin"
+
+instance JSON LinType where
+  -- the basic types (Str, Float, Int) are encoded as strings:
+  showJSON (StrType)         = showJSON "Str"
+  showJSON (FloatType)       = showJSON "Float"
+  showJSON (IntType)         = showJSON "Int"
+  -- parameters are also encoded as strings:
+  showJSON (ParamType pt)    = showJSON pt
+  -- tables/tuples are encoded as JSON objects:
+  showJSON (TableType pt lt) = makeObj [(".tblarg", showJSON pt), (".tblval", showJSON lt)]
+  showJSON (TupleType lts)   = makeObj [(".tuple",  showJSON lts)]
+  -- records are encoded as records:
+  showJSON (RecordType rows) = showJSON rows
+
+  readJSON o = StrType   <$ parseString "Str"   o
+    <|>        FloatType <$ parseString "Float" o
+    <|>        IntType   <$ parseString "Int"   o
+    <|>        ParamType <$> readJSON o
+    <|>        TableType  <$> o!".tblarg" <*> o!".tblval"
+    <|>        TupleType  <$> o!".tuple"
+    <|>        RecordType <$> readJSON o
+
+instance JSON LinValue where
+  showJSON (LiteralValue  l ) = showJSON l
+  -- most values are encoded as JSON objects:
+  showJSON (ParamConstant pv) = makeObj [(".param",    showJSON pv)]
+  showJSON (PredefValue   p ) = makeObj [(".predef",   showJSON p)]
+  showJSON (TableValue t tvs) = makeObj [(".tblarg",   showJSON t), (".tblrows", showJSON tvs)]
+  showJSON (TupleValue   lvs) = makeObj [(".tuple",    showJSON lvs)]
+  showJSON (VarValue      v ) = makeObj [(".var",      showJSON v)]
+  showJSON (ErrorValue    s ) = makeObj [(".error",    showJSON s)]
+  showJSON (Projection lv l ) = makeObj [(".project",  showJSON lv), (".label", showJSON l)]
+  showJSON (Selection  tv pv) = makeObj [(".select",   showJSON tv), (".key", showJSON pv)]
+  showJSON (VariantValue  vs) = makeObj [(".variants", showJSON vs)]
+  showJSON (PreValue pre def) = makeObj [(".pre",      showJSON pre),(".default", showJSON def)]
+  -- records are encoded directly as JSON records:
+  showJSON (RecordValue rows) = showJSON rows
+  -- concatenation is encoded as a JSON array:
+  showJSON v@(ConcatValue _ _) = showJSON (flatten v [])
+    where flatten (ConcatValue v v') = flatten v . flatten v'
+          flatten  v                 = (v :)
+
+  readJSON o = LiteralValue  <$> readJSON o
+    <|>        ParamConstant <$> o!".param"
+    <|>        PredefValue   <$> o!".predef"
+    <|>        TableValue    <$> o!".tblarg"  <*> o!".tblrows"
+    <|>        TupleValue    <$> o!".tuple"
+    <|>        VarValue      <$> o!".var"
+    <|>        ErrorValue    <$> o!".error"
+    <|>        Projection    <$> o!".project" <*> o!".label"
+    <|>        Selection     <$> o!".select"  <*> o!".key"
+    <|>        VariantValue  <$> o!".variants"
+    <|>        PreValue      <$> o!".pre"     <*> o!".default"
+    <|>        RecordValue   <$> readJSON o
+    <|>        do vs <- readJSON o :: Result [LinValue]
+                  return (foldr1 ConcatValue vs)
+
+instance JSON Literal where
+  -- basic values (Str, Float, Int) are encoded as JSON strings/numbers:
+  showJSON (LStr s) = showJSON s
+  showJSON (LFlt f) = showJSON f
+  showJSON (LInt n) = showJSON n
+
+  readJSON = readBasicJSON LStr LInt LFlt
+
+instance JSON LinPattern where
+  -- wildcards and patterns without arguments are encoded as strings:
+  showJSON (WildPattern) = showJSON "_"
+  showJSON (ParamPattern (Param p [])) = showJSON p
+  -- complex patterns are encoded as JSON objects:
+  showJSON (ParamPattern pv) = showJSON pv
+  -- and records as records:
+  showJSON (RecordPattern r) = showJSON r
+
+  readJSON o = do  p  <- parseString "_" o; return WildPattern
+    <|>        do  p  <- readJSON o; return (ParamPattern (Param p []))
+    <|>        ParamPattern  <$> readJSON o
+    <|>        RecordPattern <$> readJSON o
+
+instance JSON arg => JSON (Param arg) where
+  -- parameters without arguments are encoded as strings:
+  showJSON (Param p [])   = showJSON p
+  showJSON (Param p args) = makeObj [(".paramid", showJSON p), (".args", showJSON args)]
+
+  readJSON o = Param <$> readJSON o <*> return []
+    <|>        Param <$> o!".paramid" <*> o!".args"
+
+instance JSON a => JSON (RecordRow a) where
+  -- record rows and lists of record rows are both encoded as JSON records (i.e., objects)
+  showJSON  row  = showJSONs [row]
+  showJSONs rows = makeObj (map toRow rows)
+    where toRow (RecordRow (LabelId lbl) val) = (showRawIdent lbl, showJSON val)
+
+  readJSON  obj = head <$> readJSONs obj
+  readJSONs obj = mapM fromRow (assocsJSObject obj)
+    where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
+                                      return (RecordRow (LabelId (rawIdentS lbl)) value)
+
+instance JSON rhs => JSON (TableRow rhs) where
+  showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
+
+  readJSON o = TableRow <$> o!".pattern" <*> o!".value"
+
+
+-- *** Identifiers in Concrete Syntax
+
+instance JSON PredefId   where showJSON (PredefId    s) = showJSON s ; readJSON = fmap PredefId    . readJSON
+instance JSON LabelId    where showJSON (LabelId     s) = showJSON s ; readJSON = fmap LabelId     . readJSON
+instance JSON VarValueId where showJSON (VarValueId  s) = showJSON s ; readJSON = fmap VarValueId  . readJSON
+instance JSON ParamId    where showJSON (ParamId     s) = showJSON s ; readJSON = fmap ParamId     . readJSON
+instance JSON ParamType  where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON
+
+
+--------------------------------------------------------------------------------
+-- ** Used in both Abstract and Concrete Syntax
+
+instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON
+instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON
+instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON
+
+instance JSON VarId where
+  -- the anonymous variable is the underscore:
+  showJSON Anonymous = showJSON "_"
+  showJSON (VarId x) = showJSON x
+
+  readJSON o = do parseString "_" o; return Anonymous
+    <|>        VarId <$> readJSON o
+
+instance JSON QualId where
+  showJSON (Qual (ModId m) n) = showJSON (showRawIdent m++"."++showRawIdent n)
+  showJSON (Unqual n) = showJSON n
+
+  readJSON o = do qualid <- readJSON o
+                  let (mod, id) = span (/= '.') qualid
+                  return $ if null mod then Unqual (rawIdentS id) else Qual (ModId (rawIdentS mod)) (rawIdentS id)
+
+instance JSON RawIdent where
+  showJSON i = showJSON $ showRawIdent i
+  readJSON o = rawIdentS <$> readJSON o
+
+instance JSON Flags where
+  -- flags are encoded directly as JSON records (i.e., objects):
+  showJSON (Flags fs) = makeObj [(showRawIdent f, showJSON v) | (f, v) <- fs]
+
+  readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
+    where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
+                                      return (rawIdentS lbl, value)
+
+--------------------------------------------------------------------------------
+-- ** Convenience functions
+
+parseString :: String -> JSValue -> Result ()
+parseString s o = guard . (== s) =<< readJSON o
+
+(!) :: JSON a => JSValue -> String -> Result a
+obj ! key = maybe (fail $ "CanonicalJSON.(!): Could not find key: " ++ show key)
+            readJSON
+            (lookup key (assocsJSObject obj))
+
+assocsJSObject :: JSValue -> [(String, JSValue)]
+assocsJSObject (JSObject o) = fromJSObject o
+assocsJSObject (JSArray  _) = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found an Array"
+assocsJSObject  jsvalue     = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found " ++ show jsvalue
+
+
+readBasicJSON :: (JSON int, Integral int, JSON flt, RealFloat flt) =>
+                 (String -> v) -> (int -> v) -> (flt -> v) -> JSValue -> Result v
+readBasicJSON str int flt o
+  =   str        <$> readJSON o
+  <|> int_or_flt <$> readJSON o
+  where int_or_flt f | f == fromIntegral n = int n
+                     | otherwise           = flt f
+          where n = round f

src/compiler/api/GF/Grammar/EBNF.hs

@@ -0,0 +1,149 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : EBNF
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:13 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.5 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Grammar.EBNF (EBNF, ERule, ERHS(..), ebnf2cf) where
+
+import GF.Data.Operations
+import GF.Grammar.CFG
+
+type EBNF = [ERule]
+type ERule = (ECat, ERHS)
+type ECat = (String,[Int])
+type ETok = String
+
+data ERHS =
+   ETerm ETok
+ | ENonTerm ECat
+ | ESeq  ERHS ERHS
+ | EAlt  ERHS ERHS
+ | EStar ERHS
+ | EPlus ERHS
+ | EOpt  ERHS
+ | EEmpty
+
+type CFRHS = [ParamCFSymbol]
+type CFJustRule = ((Cat,[Param]), CFRHS)
+
+ebnf2cf :: EBNF -> [ParamCFRule]
+ebnf2cf ebnf = 
+  [Rule cat items (mkCFF i cat) | (i,(cat,items)) <- zip [0..] (normEBNF ebnf)]
+  where
+    mkCFF i (c,_) = CFObj ("Mk" ++ c ++ "_" ++ show i) []
+
+normEBNF :: EBNF -> [CFJustRule]
+normEBNF erules = let
+  erules1 = [normERule ([i],r) | (i,r) <- zip [0..] erules]
+  erules2 = erules1 ---refreshECats erules1 --- this seems to be just bad !
+  erules3 = concat (map pickERules erules2)
+--erules4 = nubERules erules3
+ in [(mkCFCatE cat, map eitem2cfitem its) | (cat,itss) <- erules3, its <- itss]
+{-
+refreshECats :: [NormERule] -> [NormERule]
+refreshECats rules = [recas [i] rule | (i,rule) <- zip [0..] rules] where
+ recas ii (cat,its) = (updECat ii cat, [recss ii 0 s | s <- its])
+ recss ii n [] = []
+ recss ii n (s:ss) = recit (ii ++ [n]) s : recss ii (n+1) ss
+ recit ii it = case it of
+   EINonTerm cat  -> EINonTerm (updECat ii cat)
+   EIStar (cat,t) -> EIStar (updECat ii cat, [recss ii 0 s | s <- t])
+   EIPlus (cat,t) -> EIPlus (updECat ii cat, [recss ii 0 s | s <- t])
+   EIOpt  (cat,t) -> EIOpt  (updECat ii cat, [recss ii 0 s | s <- t])
+   _ -> it
+-}
+pickERules :: NormERule -> [NormERule]
+pickERules rule@(cat,alts) = rule : concat (map pics (concat alts)) where
+ pics it = case it of
+   EIStar ru@(cat,t) -> mkEStarRules cat ++ pickERules ru
+   EIPlus ru@(cat,t) -> mkEPlusRules cat ++ pickERules ru
+   EIOpt  ru@(cat,t) -> mkEOptRules cat ++ pickERules ru
+   _ -> []
+ mkEStarRules cat = [(cat', [[],[EINonTerm cat, EINonTerm cat']])] 
+                                        where cat' = mkNewECat cat "Star"
+ mkEPlusRules cat = [(cat', [[EINonTerm cat],[EINonTerm cat, EINonTerm cat']])] 
+                                        where cat' = mkNewECat cat "Plus"
+ mkEOptRules cat  = [(cat', [[],[EINonTerm cat]])] 
+                                        where cat' = mkNewECat cat "Opt"
+{-
+nubERules :: [NormERule] -> [NormERule]
+nubERules rules = nub optim where 
+  optim = map (substERules (map mkSubst replaces)) irreducibles
+  (replaces,irreducibles) = partition reducible rules
+  reducible (cat,[items]) = isNewCat cat && all isOldIt items
+  reducible _ = False
+  isNewCat (_,ints) = ints == []
+  isOldIt (EITerm _) = True
+  isOldIt (EINonTerm cat) = not (isNewCat cat)
+  isOldIt _ = False
+  mkSubst (cat,its) = (cat, head its) -- def of reducible: its must be singleton
+--- the optimization assumes each cat has at most one EBNF rule.
+
+substERules :: [(ECat,[EItem])] -> NormERule -> NormERule
+substERules g (cat,itss) = (cat, map sub itss) where
+  sub [] = []
+  sub (i@(EINonTerm cat') : ii) = case lookup cat g of
+                                    Just its -> its ++ sub ii 
+                                    _ -> i : sub ii
+  sub (EIStar r : ii) = EIStar (substERules g r) : ii
+  sub (EIPlus r : ii) = EIPlus (substERules g r) : ii
+  sub (EIOpt r : ii)  = EIOpt  (substERules g r) : ii
+-}
+eitem2cfitem :: EItem -> ParamCFSymbol
+eitem2cfitem it = case it of
+  EITerm a       -> Terminal a
+  EINonTerm cat  -> NonTerminal (mkCFCatE cat)
+  EIStar (cat,_) -> NonTerminal (mkCFCatE (mkNewECat cat "Star"))
+  EIPlus (cat,_) -> NonTerminal (mkCFCatE (mkNewECat cat "Plus"))
+  EIOpt  (cat,_) -> NonTerminal (mkCFCatE (mkNewECat cat "Opt"))
+
+type NormERule = (ECat,[[EItem]]) -- disjunction of sequences of items
+
+data EItem =
+   EITerm String
+ | EINonTerm ECat
+ | EIStar NormERule
+ | EIPlus NormERule
+ | EIOpt  NormERule
+  deriving Eq
+
+normERule :: ([Int],ERule) -> NormERule
+normERule (ii,(cat,rhs)) = 
+ (cat,[map (mkEItem (ii ++ [i])) r' | (i,r') <- zip [0..] (disjNorm rhs)]) where
+  disjNorm r = case r of
+    ESeq r1 r2 -> [x ++ y | x <- disjNorm r1, y <- disjNorm r2]
+    EAlt r1 r2 -> disjNorm r1 ++ disjNorm r2
+    EEmpty -> [[]]
+    _ -> [[r]]
+
+mkEItem :: [Int] -> ERHS -> EItem
+mkEItem ii rhs = case rhs of
+  ETerm a -> EITerm a
+  ENonTerm cat -> EINonTerm cat
+  EStar r -> EIStar (normERule (ii,(mkECat ii, r)))
+  EPlus r -> EIPlus (normERule (ii,(mkECat ii, r)))
+  EOpt  r -> EIOpt  (normERule (ii,(mkECat ii, r)))
+  _ -> EINonTerm ("?????",[])
+--  _ -> error "should not happen in ebnf" ---
+
+mkECat ints = ("C", ints)
+
+prECat (c,[]) = c
+prECat (c,ints) = c ++ "_" ++ prTList "_" (map show ints)
+
+mkCFCatE :: ECat -> (Cat,[Param])
+mkCFCatE c = (prECat c,[0])
+{-
+updECat _ (c,[]) = (c,[])
+updECat ii (c,_) = (c,ii)
+-}
+mkNewECat (c,ii) str = (c ++ str,ii)

src/compiler/api/GF/Grammar/Grammar.hs

@@ -0,0 +1,483 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Grammar
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:22:20 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.8 $
+--
+-- GF source abstract syntax used internally in compilation.
+--
+-- AR 23\/1\/2000 -- 30\/5\/2001 -- 4\/5\/2003
+-----------------------------------------------------------------------------
+
+module GF.Grammar.Grammar (
+        -- ** Grammar modules
+        Grammar, ModuleName, Module, ModuleInfo(..),
+        SourceGrammar, SourceModInfo, SourceModule,
+        ModuleType(..),
+        emptyGrammar, mGrammar, modules, prependModule, moduleMap,
+
+        MInclude (..), OpenSpec(..),
+        extends, isInherited, inheritAll,
+        openedModule, allDepsModule, partOfGrammar, depPathModule,
+        allExtends, allExtendsPlus, --searchPathModule,
+        
+        lookupModule,
+        isModAbs, isModRes, isModCnc,
+        sameMType, isCompilableModule, isCompleteModule,
+        allAbstracts, greatestAbstract, allResources,
+        greatestResource, allConcretes, allConcreteModules,
+        abstractOfConcrete,
+
+        ModuleStatus(..),
+
+        -- ** Judgements
+        Info(..),
+        -- ** Terms
+        Term(..),
+        Type,
+        Cat,
+        Fun,
+        QIdent,
+        BindType(..),
+        Patt(..),
+        TInfo(..),
+        Label(..),
+        MetaId,
+        Hypo,
+        Context,
+        Equation,
+        Labelling,
+        Assign,
+        Case,
+        LocalDef,
+        Param,
+        Altern,
+        Substitution,
+        varLabel, tupleLabel, linLabel, theLinLabel,
+        ident2label, label2ident,
+        -- ** Source locations
+        Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
+
+        -- ** PMCFG        
+        LIndex,LVar,LParam(..),PArg(..),Symbol(..),Production(..)
+        ) where
+
+import GF.Infra.Ident
+import GF.Infra.Option ---
+import GF.Infra.Location
+
+import GF.Data.Operations
+
+import PGF2(BindType(..))
+import PGF2.Transactions(SeqId,LIndex,LVar,LParam(..),PArg(..),Symbol(..),Production(..))
+
+import Data.Array.IArray(Array)
+import Data.Array.Unboxed(UArray)
+import qualified Data.Map as Map
+import qualified Data.Sequence as Seq
+import GF.Text.Pretty
+
+
+-- | A grammar is a self-contained collection of grammar modules
+data Grammar = MGrammar { 
+    moduleMap :: Map.Map ModuleName ModuleInfo,
+    modules :: [Module]
+  }
+
+-- | Modules
+type Module = (ModuleName, ModuleInfo)
+
+data ModuleInfo = ModInfo {
+    mtype   :: ModuleType,
+    mstatus :: ModuleStatus,
+    mflags  :: Options,
+    mextend :: [(ModuleName,MInclude)],
+    mwith   :: Maybe (ModuleName,MInclude,[(ModuleName,ModuleName)]),
+    mopens  :: [OpenSpec],
+    mexdeps :: [ModuleName],
+    msrc    :: FilePath,
+    mseqs   :: Maybe (Seq.Seq [Symbol]),
+    jments  :: Map.Map Ident Info
+  }
+
+type SourceGrammar = Grammar
+type SourceModule = Module
+type SourceModInfo = ModuleInfo
+
+instance HasSourcePath ModuleInfo where sourcePath = msrc
+
+-- | encoding the type of the module
+data ModuleType = 
+    MTAbstract 
+  | MTResource
+  | MTConcrete ModuleName
+  | MTInterface
+  | MTInstance (ModuleName,MInclude)
+  deriving (Eq,Show)
+
+data MInclude = MIAll | MIOnly [Ident] | MIExcept [Ident]
+  deriving (Eq,Show)
+
+extends :: ModuleInfo -> [ModuleName]
+extends = map fst . mextend
+
+isInherited :: MInclude -> Ident -> Bool
+isInherited c i = case c of
+  MIAll -> True
+  MIOnly is -> elem i is
+  MIExcept is -> notElem i is
+
+inheritAll :: ModuleName -> (ModuleName,MInclude)
+inheritAll i = (i,MIAll)
+
+data OpenSpec = 
+   OSimple ModuleName
+ | OQualif ModuleName ModuleName
+  deriving (Eq,Show)
+
+data ModuleStatus = 
+   MSComplete 
+ | MSIncomplete 
+  deriving (Eq,Ord,Show)
+
+openedModule :: OpenSpec -> ModuleName
+openedModule o = case o of
+  OSimple m -> m
+  OQualif _ m -> m
+
+-- | initial dependency list
+depPathModule :: ModuleInfo -> [OpenSpec]
+depPathModule m = fors m ++ exts m ++ mopens m
+  where
+    fors m = 
+      case mtype m of
+        MTConcrete i   -> [OSimple i]
+        MTInstance (i,_)   -> [OSimple i]
+        _              -> []
+    exts m = map OSimple (extends m)
+
+-- | all dependencies
+allDepsModule :: Grammar -> ModuleInfo -> [OpenSpec]
+allDepsModule gr m = iterFix add os0 where
+  os0 = depPathModule m
+  add os = [m | o <- os, Just n <- [lookup (openedModule o) mods], 
+                m <- depPathModule n]
+  mods = modules gr
+
+-- | select just those modules that a given one depends on, including itself
+partOfGrammar :: Grammar -> Module -> Grammar
+partOfGrammar gr (i,m) = mGrammar [mo | mo@(j,_) <- mods, elem j modsFor]
+  where
+    mods = modules gr
+    modsFor = (i:) $ map openedModule $ allDepsModule gr m
+
+-- | all modules that a module extends, directly or indirectly, with restricts
+allExtends :: Grammar -> ModuleName -> [Module]
+allExtends gr m =
+  case lookupModule gr m of
+    Ok mi -> (m,mi) : concatMap (allExtends gr . fst) (mextend mi)
+    _     -> []
+
+-- | the same as 'allExtends' plus that an instance extends its interface
+allExtendsPlus :: Grammar -> ModuleName -> [ModuleName]
+allExtendsPlus gr i =
+  case lookupModule gr i of
+    Ok m -> i : concatMap (allExtendsPlus gr) (exts m)
+    _    -> []
+  where
+    exts m = extends m ++ [j | MTInstance (j,_) <- [mtype m]]
+
+-- -- | initial search path: the nonqualified dependencies
+-- searchPathModule :: ModuleInfo -> [ModuleName]
+-- searchPathModule m = [i | OSimple i <- depPathModule m]
+
+prependModule :: Grammar -> Module -> Grammar
+prependModule (MGrammar mm ms) im@(i,m) = MGrammar (Map.insert i m mm) (im:ms)
+
+emptyGrammar = mGrammar []
+
+mGrammar :: [Module] -> Grammar
+mGrammar ms = MGrammar (Map.fromList ms) ms
+
+
+-- | we store the module type with the identifier
+
+abstractOfConcrete :: ErrorMonad m => Grammar -> ModuleName -> m ModuleName
+abstractOfConcrete gr c = do
+  n <- lookupModule gr c
+  case mtype n of
+    MTConcrete a -> return a
+    _ -> raise $ render ("expected concrete" <+> c)
+
+lookupModule :: ErrorMonad m => Grammar -> ModuleName -> m ModuleInfo
+lookupModule gr m = case Map.lookup m (moduleMap gr) of
+  Just i  -> return i
+  Nothing -> raise $ render ("unknown module" <+> m <+> "among" <+> hsep (map fst (modules gr)))
+
+isModAbs :: ModuleInfo -> Bool
+isModAbs m =
+  case mtype m of
+    MTAbstract -> True
+    _          -> False
+
+isModRes :: ModuleInfo -> Bool
+isModRes m =
+  case mtype m of
+    MTResource   -> True
+    MTInterface  -> True ---
+    MTInstance _ -> True
+    _            -> False
+
+isModCnc :: ModuleInfo -> Bool
+isModCnc m =
+  case mtype m of
+    MTConcrete _ -> True
+    _            -> False
+
+sameMType :: ModuleType -> ModuleType -> Bool
+sameMType m n =
+  case (n,m) of
+    (MTConcrete _, MTConcrete _) -> True
+
+    (MTInstance _, MTInstance _) -> True
+    (MTInstance _, MTResource)   -> True
+    (MTInstance _, MTConcrete _) -> True
+
+    (MTInterface,  MTInstance _) -> True
+    (MTInterface,  MTResource)   -> True    -- for reuse
+    (MTInterface,  MTAbstract)   -> True    -- for reuse
+    (MTInterface,  MTConcrete _) -> True    -- for reuse
+
+    (MTResource,   MTInstance _) -> True
+    (MTResource,   MTConcrete _) -> True    -- for reuse
+
+    _                            -> m == n
+
+-- | don't generate code for interfaces and for incomplete modules
+isCompilableModule :: ModuleInfo -> Bool
+isCompilableModule m =
+  case mtype m of
+    MTInterface -> False
+    _           -> mstatus m == MSComplete
+
+-- | interface and "incomplete M" are not complete
+isCompleteModule :: ModuleInfo -> Bool
+isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface
+
+
+-- | all abstract modules sorted from least to most dependent
+allAbstracts :: Grammar -> [ModuleName]
+allAbstracts gr = 
+ case topoTest [(i,extends m) | (i,m) <- modules gr, mtype m == MTAbstract] of
+   Left  is     -> is
+   Right cycles -> error $ render ("Cyclic abstract modules:" <+> vcat (map hsep cycles))
+
+-- | the last abstract in dependency order (head of list)
+greatestAbstract :: Grammar -> Maybe ModuleName
+greatestAbstract gr =
+  case allAbstracts gr of
+    [] -> Nothing
+    as -> return $ last as
+
+-- | all resource modules
+allResources :: Grammar -> [ModuleName]
+allResources gr = [i | (i,m) <- modules gr, isModRes m || isModCnc m]
+
+-- | the greatest resource in dependency order
+greatestResource :: Grammar -> Maybe ModuleName
+greatestResource gr =
+  case allResources gr of
+    [] -> Nothing
+    mo:_ -> Just mo ---- why not last as in Abstract? works though AR 24/5/2008
+
+-- | all concretes for a given abstract
+allConcretes :: Grammar -> ModuleName -> [ModuleName]
+allConcretes gr a =
+  [i | (i, m) <- modules gr, mtype m == MTConcrete a, isCompleteModule m]
+
+-- | all concrete modules for any abstract
+allConcreteModules :: Grammar -> [ModuleName]
+allConcreteModules gr =
+  [i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
+
+
+-- | the constructors are judgements in 
+--
+--   - abstract syntax (/ABS/)
+-- 
+--   - resource (/RES/)
+--
+--   - concrete syntax (/CNC/)
+--
+-- and indirection to module (/INDIR/)
+data Info =
+-- judgements in abstract syntax
+   AbsCat   (Maybe (L Context))                                            -- ^ (/ABS/) context of a category
+ | AbsFun   (Maybe (L Type)) (Maybe Int) (Maybe [L Equation]) (Maybe Bool) -- ^ (/ABS/) type, arrity and definition of a function
+
+-- judgements in resource
+ | ResParam (Maybe (L [Param])) (Maybe ([Term],Int)) -- ^ (/RES/) The second argument is list of all possible values
+                                                     -- and its precomputed length.
+ | ResValue (L Type) Int                             -- ^ (/RES/) to mark parameter constructors for lookup.
+                                                     -- The second argument is the offset into the list of all values
+                                                     -- where that constructor appears first.
+ | ResOper  (Maybe (L Type)) (Maybe (L Term))        -- ^ (/RES/)
+
+ | ResOverload [ModuleName] [(L Type,L Term)]        -- ^ (/RES/) idents: modules inherited
+
+-- judgements in concrete syntax
+ | CncCat  (Maybe (L Type))                     (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe ([Production],[Production])) -- ^ (/CNC/) lindef ini'zed, 
+ | CncFun  (Maybe ([Ident],Ident,Context,Type)) (Maybe (L Term))                  (Maybe (L Term)) (Maybe [Production]) -- ^ (/CNC/) type info added at 'TC'
+
+-- indirection to module Ident
+ | AnyInd Bool ModuleName                        -- ^ (/INDIR/) the 'Bool' says if canonical
+  deriving Show
+
+type Type = Term
+type Cat  = QIdent
+type Fun  = QIdent
+
+type QIdent = (ModuleName,Ident)
+
+data Term =
+   Vr Ident                      -- ^ variable
+ | Cn Ident                      -- ^ constant
+ | Con Ident                     -- ^ constructor
+ | Sort Ident                    -- ^ basic type
+ | EInt Integer                  -- ^ integer literal
+ | EFloat Double                 -- ^ floating point literal
+ | K String                      -- ^ string literal or token: @\"foo\"@
+ | Empty                         -- ^ the empty string @[]@
+
+ | App Term Term                 -- ^ application: @f a@
+ | Abs BindType Ident Term       -- ^ abstraction: @\x -> b@
+ | Meta {-# UNPACK #-} !MetaId   -- ^ metavariable: @?i@ (only parsable: ? = ?0)
+ | ImplArg Term                  -- ^ placeholder for implicit argument @{t}@
+ | Prod BindType Ident Term Term -- ^ function type: @(x : A) -> B@, @A -> B@, @({x} : A) -> B@
+ | Typed Term Term               -- ^ type-annotated term
+--
+-- /below this, the constructors are only for concrete syntax/
+ | Example Term String           -- ^ example-based term: @in M.C "foo"
+ | RecType [Labelling]           -- ^ record type: @{ p : A ; ...}@
+ | R [Assign]                    -- ^ record:      @{ p = a ; ...}@
+ | P Term Label                  -- ^ projection:  @r.p@
+ | ExtR Term Term                -- ^ extension:   @R ** {x : A}@ (both types and terms)
+ 
+ | Table Term Term               -- ^ table type:  @P => A@
+ | T TInfo [Case]                -- ^ table:       @table {p => c ; ...}@
+ | V Type [Term]                 -- ^ table given as course of values: @table T [c1 ; ... ; cn]@
+ | S Term Term                   -- ^ selection:   @t ! p@
+
+ | Let LocalDef Term             -- ^ local definition: @let {t : T = a} in b@
+
+ | Q  QIdent                     -- ^ qualified constant from a package
+ | QC QIdent                     -- ^ qualified constructor from a package
+
+ | C Term Term                   -- ^ concatenation: @s ++ t@
+ | Glue Term Term                -- ^ agglutination: @s + t@
+
+ | EPatt Int (Maybe Int) Patt    -- ^ pattern (in macro definition): # p
+ | EPattType Term                -- ^ pattern type: pattern T
+
+ | ELincat Ident Term            -- ^ boxed linearization type of Ident
+ | ELin Ident Term               -- ^ boxed linearization of type Ident
+
+ | AdHocOverload [Term]          -- ^ ad hoc overloading generated in Rename
+
+ | FV [Term]                     -- ^ alternatives in free variation: @variants { s ; ... }@
+
+ | Alts Term [(Term, Term)]      -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
+ | Strs [Term]                   -- ^ conditioning prefix strings: @strs {s ; ...}@
+ | TSymCat Int LIndex [(LIndex,(Ident,Type))]
+ | TSymVar Int Int
+  deriving (Show, Eq, Ord)
+
+-- | Patterns
+data Patt =
+   PC Ident [Patt]        -- ^ constructor pattern: @C p1 ... pn@    @C@ 
+ | PP QIdent [Patt]       -- ^ package constructor pattern: @P.C p1 ... pn@    @P.C@ 
+ | PV Ident               -- ^ variable pattern: @x@
+ | PW                     -- ^ wild card pattern: @_@
+ | PR [(Label,Patt)]      -- ^ record pattern: @{r = p ; ...}@  -- only concrete
+ | PString String         -- ^ string literal pattern: @\"foo\"@  -- only abstract
+ | PInt    Integer        -- ^ integer literal pattern: @12@    -- only abstract
+ | PFloat Double          -- ^ float literal pattern: @1.2@    -- only abstract
+ | PT Type Patt           -- ^ type-annotated pattern
+
+ | PAs Ident Patt         -- ^ as-pattern: x@p
+ 
+ | PImplArg Patt          -- ^ placeholder for pattern for implicit argument @{p}@
+ | PTilde   Term          -- ^ inaccessible pattern
+
+ -- regular expression patterns
+ | PNeg Patt              -- ^ negated pattern: -p
+ | PAlt Patt Patt         -- ^ disjunctive pattern: p1 | p2
+ | PSeq Int (Maybe Int) Patt Int (Maybe Int) Patt
+                          -- ^ sequence of token parts: p + q
+                          -- In the constructor PSeq minp maxp p minq maxq q,
+                          -- minp/maxp and minq/maxq are the minimal/maximal
+                          -- length of a matching string for p/q.
+ | PRep Int (Maybe Int) Patt
+                          -- ^ repetition of token part: p*
+                          -- In the constructor PRep minp maxp p,
+                          -- minp/maxp is the minimal/maximal length of
+                          -- a matching string for p.
+ 
+ | PChar                  -- ^ string of length one: ?
+ | PChars [Char]          -- ^ character list: ["aeiou"]
+ | PMacro Ident           -- #p
+ | PM QIdent              -- #m.p
+  deriving (Show, Eq, Ord)
+
+-- | to guide computation and type checking of tables
+data TInfo = 
+   TRaw         -- ^ received from parser; can be anything
+ | TTyped Type  -- ^ type annontated, but can be anything
+ | TComp Type   -- ^ expanded
+ | TWild Type   -- ^ just one wild card pattern, no need to expand 
+  deriving (Show, Eq, Ord)
+
+-- | record label
+data Label = 
+    LIdent RawIdent
+  | LVar Int
+   deriving (Show, Eq, Ord)
+
+type MetaId = Int
+
+type Hypo     = (BindType,Ident,Type)   -- (x:A)  (_:A)  A  ({x}:A)
+type Context  = [Hypo]                  -- (x:A)(y:B)   (x,y:A)   (_,_:A)
+type Equation = ([Patt],Term) 
+
+type Labelling = (Label, Type) 
+type Assign = (Label, (Maybe Type, Term)) 
+type Case = (Patt, Term) 
+--type Cases = ([Patt], Term) 
+type LocalDef = (Ident, (Maybe Type, Term))
+
+type Param = (Ident, Context) 
+type Altern = (Term, [(Term, Term)])
+
+type Substitution =  [(Ident, Term)]
+
+varLabel :: Int -> Label
+varLabel = LVar
+
+tupleLabel, linLabel :: Int -> Label
+tupleLabel i = LIdent $! rawIdentS ('p':show i)
+linLabel   i = LIdent $! rawIdentS ('s':show i)
+
+theLinLabel :: Label
+theLinLabel = LIdent (rawIdentS "s")
+
+ident2label :: Ident -> Label
+ident2label c = LIdent (ident2raw c)
+
+label2ident :: Label -> Ident
+label2ident (LIdent s) = identC s
+label2ident (LVar i)   = identS ('$':show i)

src/compiler/api/GF/Grammar/Lexer.x

@@ -0,0 +1,330 @@
+-- -*- haskell -*-
+{
+{-# LANGUAGE CPP #-}
+module GF.Grammar.Lexer
+         ( Token(..), Posn(..)
+         , P, runP, runPartial, token, lexer, getPosn, failLoc
+         , isReservedWord
+         ) where
+
+import Control.Applicative
+import Control.Monad(ap)
+import GF.Infra.Ident
+--import GF.Data.Operations
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString as WBS
+import qualified Data.ByteString.Internal as BS(w2c)
+import qualified Data.ByteString.UTF8 as UTF8
+import qualified Data.Map as Map
+import Data.Word(Word8)
+import Data.Char(readLitChar)
+--import Debug.Trace(trace)
+import qualified Control.Monad.Fail as Fail
+}
+
+
+$l = [a-zA-Z\192 - \255] # [\215 \247]
+$c = [A-Z\192-\221] # [\215]
+$s = [a-z\222-\255] # [\247]
+$d = [0-9]                -- digit
+$i = [$l $d _ ']          -- identifier character
+$u = [.\n]                -- universal: any character
+
+@rsyms =    -- symbols and non-identifier-like reserved words
+   \; | \= | \{ | \} | \( | \) | \~ | \* \* | \: | \- \> | \, | \[ | \] | \- | \. | \| | \% | \? | \< | \> | \@ | \# | \! | \* | \+ | \+ \+ | \\ | \\\\ | \= \> | \_ | \$ | \/ | \: \= | \: \: \=
+
+:-
+"--" [.]* ; -- Toss single line comments
+"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ;
+
+$white+ ;
+@rsyms                          { tok ident }
+\' ([. # [\' \\ \n]] | (\\ (\' | \\)))+ \' { tok (T_Ident . identS . unescapeInitTail . unpack) }
+(\_ | $l)($l | $d | \_ | \')*   { tok ident }
+
+\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t | $d+)))* \" { tok (T_String . unescapeInitTail . unpack) }
+
+(\-)? $d+                       { tok (T_Integer . read . unpack) }
+(\-)? $d+ \. $d+ (e (\-)? $d+)? { tok (T_Double  . read . unpack) }
+
+{
+unpack = UTF8.toString
+--unpack = id
+
+ident = res T_Ident . identC . rawIdentC
+
+tok f p s = f s
+
+data Token
+ = T_exclmark
+ | T_patt
+ | T_int_label
+ | T_oparen
+ | T_cparen
+ | T_tilde
+ | T_star
+ | T_starstar
+ | T_plus
+ | T_plusplus
+ | T_comma
+ | T_minus
+ | T_rarrow
+ | T_dot
+ | T_alt
+ | T_colon
+ | T_semicolon
+ | T_less
+ | T_equal
+ | T_big_rarrow
+ | T_great
+ | T_questmark
+ | T_obrack
+ | T_lam
+ | T_lamlam
+ | T_cbrack
+ | T_ocurly
+ | T_bar
+ | T_ccurly
+ | T_underscore
+ | T_at
+ | T_cfarrow
+ | T_PType
+ | T_Str
+ | T_Strs
+ | T_Tok
+ | T_Type
+ | T_abstract
+ | T_case
+ | T_cat
+ | T_concrete
+ | T_data
+ | T_def
+ | T_flags
+ | T_fn
+ | T_fun
+ | T_in
+ | T_incomplete
+ | T_instance
+ | T_interface
+ | T_let
+ | T_lin
+ | T_lincat
+ | T_lindef
+ | T_linref
+ | T_of
+ | T_open
+ | T_oper
+ | T_param
+ | T_pattern
+ | T_pre
+ | T_printname
+ | T_resource
+ | T_strs
+ | T_table
+ | T_transfer
+ | T_variants
+ | T_where
+ | T_with
+ | T_coercions
+ | T_terminator
+ | T_separator
+ | T_nonempty
+ | T_String  String          -- string literals
+ | T_Integer Integer         -- integer literals
+ | T_Double  Double          -- double precision float literals
+ | T_Ident   Ident
+ | T_EOF
+-- deriving Show -- debug
+
+res = eitherResIdent
+eitherResIdent :: (Ident -> Token) -> Ident -> Token
+eitherResIdent tv s =
+  case Map.lookup s resWords of
+    Just t  -> t
+    Nothing -> tv s
+
+isReservedWord :: Ident -> Bool
+isReservedWord ident = Map.member ident resWords
+
+resWords = Map.fromList
+ [ b "!"  T_exclmark
+ , b "#"  T_patt
+ , b "$"  T_int_label
+ , b "("  T_oparen
+ , b ")"  T_cparen
+ , b "~"  T_tilde
+ , b "*"  T_star
+ , b "**" T_starstar
+ , b "+"  T_plus
+ , b "++" T_plusplus
+ , b ","  T_comma
+ , b "-"  T_minus
+ , b "->" T_rarrow
+ , b "."  T_dot
+ , b "/"  T_alt
+ , b ":"  T_colon
+ , b ";"  T_semicolon
+ , b "<"  T_less
+ , b "="  T_equal
+ , b "=>" T_big_rarrow
+ , b ">"  T_great
+ , b "?"  T_questmark
+ , b "["  T_obrack
+ , b "]"  T_cbrack
+ , b "\\" T_lam
+ , b "\\\\" T_lamlam
+ , b "{"  T_ocurly
+ , b "}"  T_ccurly
+ , b "|"  T_bar
+ , b "_"  T_underscore
+ , b "@"  T_at
+ , b "::=" T_cfarrow
+ , b ":="  T_cfarrow
+ , b "PType"      T_PType
+ , b "Str"        T_Str
+ , b "Strs"       T_Strs
+ , b "Tok"        T_Tok
+ , b "Type"       T_Type
+ , b "abstract"   T_abstract
+ , b "case"       T_case
+ , b "cat"        T_cat
+ , b "concrete"   T_concrete
+ , b "data"       T_data
+ , b "def"        T_def
+ , b "flags"      T_flags
+ , b "fn"         T_fn
+ , b "fun"        T_fun
+ , b "in"         T_in
+ , b "incomplete" T_incomplete
+ , b "instance"   T_instance
+ , b "interface"  T_interface
+ , b "let"        T_let
+ , b "lin"        T_lin
+ , b "lincat"     T_lincat
+ , b "lindef"     T_lindef
+ , b "linref"     T_linref
+ , b "of"         T_of
+ , b "open"       T_open
+ , b "oper"       T_oper
+ , b "param"      T_param
+ , b "pattern"    T_pattern
+ , b "pre"        T_pre
+ , b "printname"  T_printname
+ , b "resource"   T_resource
+ , b "strs"       T_strs
+ , b "table"      T_table
+ , b "transfer"   T_transfer
+ , b "variants"   T_variants
+ , b "where"      T_where
+ , b "with"       T_with
+ , b "coercions"  T_coercions
+ , b "terminator" T_terminator
+ , b "separator"  T_separator
+ , b "nonempty"   T_nonempty
+ ]
+ where b s t = (identS s, t)
+
+unescapeInitTail :: String -> String
+unescapeInitTail = unesc . tail where
+  unesc s = case s of
+    []         -> []
+    '\"':[]    -> []
+    '\'':[]    -> []
+    _          -> case readLitChar s of
+                    [(c,cs)] -> c:unesc cs
+
+-------------------------------------------------------------------
+-- Alex wrapper code.
+-- A modified "posn" wrapper.
+-------------------------------------------------------------------
+
+data Posn = Pn {-# UNPACK #-} !Int
+               {-# UNPACK #-} !Int
+            deriving (Eq,Show)
+
+alexMove :: Posn -> Char -> Posn
+alexMove (Pn l c) '\n' = Pn (l+1) 1
+alexMove (Pn l c) _    = Pn l     (c+1)
+
+alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
+alexGetByte (AI p _ s) =
+  case WBS.uncons s of
+    Nothing  -> Nothing
+    Just (w,s) ->
+             let p' = alexMove p c
+                 c  = BS.w2c w
+              in p' `seq` Just (w, (AI p' c s))
+{-
+-- Not used by this lexer:
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar (AI p c s) = c
+-}
+data AlexInput = AI {-# UNPACK #-} !Posn            -- current position,
+                    {-# UNPACK #-} !Char            -- previous char
+                    {-# UNPACK #-} !BS.ByteString   -- current input string
+
+type AlexInput2 = (AlexInput,AlexInput)
+
+data ParseResult a
+  = POk AlexInput2 a
+  | PFailed Posn        -- The position of the error
+            String      -- The error message
+
+newtype P a = P { unP :: AlexInput2 -> ParseResult a }
+
+instance Functor P where
+  fmap = liftA
+
+instance Applicative P where
+  pure = return
+  (<*>) = ap
+
+instance Monad P where
+  return a    = a `seq` (P $ \s -> POk s a)
+  (P m) >>= k = P $ \ s -> case m s of
+                             POk s a          -> unP (k a) s
+                             PFailed posn err -> PFailed posn err
+
+#if !(MIN_VERSION_base(4,13,0))
+  -- Monad(fail) will be removed in GHC 8.8+
+  fail = Fail.fail
+#endif
+
+instance Fail.MonadFail P where
+  fail msg    = P $ \(_,AI posn _ _) -> PFailed posn msg
+
+
+runP :: P a -> BS.ByteString -> Either (Posn,String) a
+runP p bs = snd <$> runP' p (Pn 1 0,bs)
+
+runPartial p s = conv <$> runP' p (Pn 1 0,UTF8.fromString s)
+  where conv ((pos,rest),x) = (UTF8.toString rest,x)
+
+runP' (P f) (pos,txt) =
+  case f (dup (AI pos ' ' txt)) of
+    POk (AI pos _ rest,_) x  -> Right ((pos,rest),x)
+    PFailed pos msg -> Left  (pos,msg)
+
+dup x = (x,x)
+
+failLoc :: Posn -> String -> P a
+failLoc pos msg = P $ \_ -> PFailed pos msg
+
+lexer :: (Token -> P a) -> P a
+lexer cont = cont=<<token
+
+token :: P Token
+token = P go
+  where
+  --cont' t = trace (show t) (cont t)
+    go ai2@(_,inp@(AI pos _ str)) =
+      case alexScan inp 0 of
+        AlexEOF                -> POk (inp,inp) T_EOF
+        AlexError (AI pos _ _) -> PFailed pos "lexical error"
+        AlexSkip  inp' len     -> {-trace (show len) $-} go (inp,inp')
+        AlexToken inp' len act -> POk (inp,inp') (act pos ({-UTF8.toString-} (UTF8.take len str)))
+
+getPosn :: P Posn
+getPosn = P $ \ai2@(_,inp@(AI pos _ _)) -> POk ai2 pos
+
+}

src/compiler/api/GF/Grammar/Lockfield.hs

@@ -0,0 +1,50 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Lockfield
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/11 23:24:34 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.7 $
+--
+-- Creating and using lock fields in reused resource grammars.
+--
+-- AR 8\/2\/2005 detached from 'compile/MkResource'
+-----------------------------------------------------------------------------
+
+module GF.Grammar.Lockfield (lockRecType, unlockRecord, lockLabel, isLockLabel) where
+
+import GF.Infra.Ident
+import GF.Grammar.Grammar
+import GF.Grammar.Macros
+
+import GF.Data.Operations(ErrorMonad,Err(..))
+
+lockRecType :: ErrorMonad m => Ident -> Type -> m Type
+lockRecType c t@(RecType rs) = 
+  let lab = lockLabel c in
+  return $ if elem lab (map fst rs) || elem (showIdent c) ["String","Int"]
+    then t --- don't add an extra copy of lock field, nor predef cats
+    else RecType (rs ++ [(lockLabel c,  RecType [])])
+lockRecType c t = plusRecType t $ RecType [(lockLabel c,  RecType [])]
+
+unlockRecord :: Monad m => Ident -> Term -> m Term
+unlockRecord c ft = do
+  let (xs,t) = termFormCnc ft
+  let lock = R [(lockLabel c,  (Just (RecType []),R []))]
+  case plusRecord t lock of
+    Ok t' -> return $ mkAbs xs t'
+    _ -> return $ mkAbs xs (ExtR t lock)
+
+lockLabel :: Ident -> Label
+lockLabel c = LIdent $! prefixRawIdent lockPrefix (ident2raw c)
+
+isLockLabel :: Label -> Bool
+isLockLabel l = case l of
+  LIdent c -> isPrefixOf lockPrefix c
+  _        -> False
+
+
+lockPrefix = rawIdentS "lock_"

src/compiler/api/GF/Grammar/Lookup.hs

@@ -0,0 +1,243 @@
+{-# LANGUAGE PatternGuards #-}
+----------------------------------------------------------------------
+-- |
+-- Module      : Lookup
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/27 13:21:53 $
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.15 $
+--
+-- Lookup in source (concrete and resource) when compiling.
+--
+-- lookup in resource and concrete in compiling; for abstract, use 'Look'
+-----------------------------------------------------------------------------
+
+module GF.Grammar.Lookup (
+           lookupIdent,
+           lookupOrigInfo,
+           allOrigInfos,
+           lookupResDef,
+           lookupResType,
+           lookupOverload,
+           lookupOverloadTypes,
+           lookupParamValues,
+           allParamValues,
+           lookupAbsDef,
+           lookupLincat,
+           lookupFunType,
+           lookupCatContext,
+           allOpers, allOpersTo
+          ) where
+
+import GF.Data.Operations
+import GF.Infra.Ident
+import GF.Grammar.Macros
+import GF.Grammar.Grammar
+import GF.Grammar.Printer
+import GF.Grammar.Predef
+import GF.Grammar.Lockfield
+
+import Data.List (sortBy)
+import GF.Text.Pretty
+import qualified Data.Map as Map
+
+-- whether lock fields are added in reuse
+lock c = lockRecType c -- return
+unlock c = unlockRecord c -- return
+
+-- to look up a constant etc in a search tree --- why here? AR 29/5/2008
+lookupIdent :: ErrorMonad m => Ident -> Map.Map Ident b -> m b
+lookupIdent c t =
+  case Map.lookup c t of
+    Just v  -> return v
+    Nothing -> raise ("unknown identifier" +++ showIdent c)
+
+lookupIdentInfo :: ErrorMonad m => SourceModInfo -> Ident -> m Info
+lookupIdentInfo mo i = lookupIdent i (jments mo)
+
+lookupQIdentInfo :: ErrorMonad m => Grammar -> QIdent -> m Info
+lookupQIdentInfo gr (m,c) = flip lookupIdentInfo c =<< lookupModule gr m
+
+lookupResDef :: ErrorMonad m => Grammar -> QIdent -> m Term
+lookupResDef gr (m,c)
+  | isPredefCat c = lock c defLinType
+  | otherwise     = look m c
+  where
+    look m c = do
+      info <- lookupQIdentInfo gr (m,c)
+      case info of
+        ResOper _ (Just (L _ t)) -> return t
+        ResOper _ Nothing  -> return (Q (m,c))
+        CncCat (Just (L _ ty)) _ _ _ _ -> lock c ty
+        CncCat _ _ _ _ _         -> lock c defLinType
+
+        CncFun (Just (_,cat,_,_)) (Just (L _ tr)) _ _ -> unlock cat tr
+        CncFun _                  (Just (L _ tr)) _ _ -> return tr
+
+        AnyInd _ n        -> look n c
+        ResParam _ _      -> return (QC (m,c))
+        ResValue _ _      -> return (QC (m,c))
+        _   -> raise $ render (c <+> "is not defined in resource" <+> m)
+
+lookupResType :: ErrorMonad m => Grammar -> QIdent -> m Type
+lookupResType gr (m,c) = do
+  info <- lookupQIdentInfo gr (m,c)
+  case info of
+    ResOper (Just (L _ t)) _ -> return t
+
+    -- used in reused concrete
+    CncCat _ _ _ _ _ -> return typeType
+    CncFun (Just (_,cat,cont,val)) _ _ _ -> do
+          val' <- lock cat val
+          return $ mkProd cont val' []
+    AnyInd _ n        -> lookupResType gr (n,c)
+    ResParam _ _    -> return typePType
+    ResValue (L _ t) _ -> return t
+    _   -> raise $ render (c <+> "has no type defined in resource" <+> m)
+
+lookupOverloadTypes :: ErrorMonad m => Grammar -> QIdent -> m [(Term,Type)]
+lookupOverloadTypes gr id@(m,c) = do
+  info <- lookupQIdentInfo gr (m,c)
+  case info of
+    ResOper (Just (L _ ty)) _ -> ret ty
+
+    -- used in reused concrete
+    CncCat _ _ _ _ _ -> ret typeType
+    CncFun (Just (_,cat,cont,val)) _ _ _ -> do
+          val' <- lock cat val
+          ret $ mkProd cont val' []
+    ResParam _ _    -> ret typePType
+    ResValue (L _ t) _ -> ret t
+    ResOverload os tysts -> do
+            tss <- mapM (\x -> lookupOverloadTypes gr (x,c)) os
+            return $ [(tr,ty) | (L _ ty,L _ tr) <- tysts] ++
+                     concat tss
+    AnyInd _ n   -> lookupOverloadTypes gr (n,c)
+    _            -> raise $ render (c <+> "has no types defined in resource" <+> m)
+  where
+    ret ty = return [(Q id,ty)]
+
+lookupOverload :: ErrorMonad m => Grammar -> QIdent -> m [([Type],(Type,Term))]
+lookupOverload gr (m,c) = do
+    info <- lookupQIdentInfo gr (m,c)
+    case info of
+      ResOverload os tysts -> do
+            tss <- mapM (\x -> lookupOverload gr (x,c)) os
+            return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) |
+                      (L _ ty,L _ tr) <- tysts] ++
+                     concat tss
+
+      AnyInd _ n  -> lookupOverload gr (n,c)
+      _   -> raise $ render (c <+> "is not an overloaded operation")
+
+-- | returns the original 'Info' and the module where it was found
+lookupOrigInfo :: ErrorMonad m => Grammar -> QIdent -> m (ModuleName,Info)
+lookupOrigInfo gr (m,c) = do
+  info <- lookupQIdentInfo gr (m,c)
+  case info of
+    AnyInd _ n  -> lookupOrigInfo gr (n,c)
+    i           -> return (m,i)
+
+allOrigInfos :: Grammar -> ModuleName -> [(QIdent,Info)]
+allOrigInfos gr m = fromErr [] $ do
+  mo <- lookupModule gr m
+  return [((m,c),i) | (c,_) <- Map.toList (jments mo), Ok (m,i) <- [lookupOrigInfo gr (m,c)]]
+
+lookupParamValues :: ErrorMonad m => Grammar -> QIdent -> m [Term]
+lookupParamValues gr c = do
+  (_,info) <- lookupOrigInfo gr c
+  case info of
+    ResParam _ (Just (pvs,_)) -> return pvs
+    _                         -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined")
+
+allParamValues :: ErrorMonad m => Grammar -> Type -> m [Term]
+allParamValues cnc ptyp =
+  case ptyp of
+    _ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]]
+    QC c -> lookupParamValues cnc c
+    Q  c -> lookupResDef cnc c >>= allParamValues cnc
+    RecType r -> do
+       let (ls,tys) = unzip $ sortByFst r
+       tss <- mapM (allParamValues cnc) tys
+       return [R (zipAssign ls ts) | ts <- sequence tss]
+    Table pt vt -> do
+       pvs <- allParamValues cnc pt
+       vvs <- allParamValues cnc vt
+       return [V pt ts | ts <- sequence (replicate (length pvs) vvs)]
+    _ -> raise (render ("cannot find parameter values for" <+> ptyp))
+  where
+    -- to normalize records and record types
+    sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
+
+lookupAbsDef :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m (Maybe Int,Maybe [Equation])
+lookupAbsDef gr m c = errIn (render ("looking up absdef of" <+> c)) $ do
+  info <- lookupQIdentInfo gr (m,c)
+  case info of
+    AbsFun _ a d _ -> return (a,fmap (map unLoc) d)
+    AnyInd _ n     -> lookupAbsDef gr n c
+    _              -> return (Nothing,Nothing)
+
+lookupLincat :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Type
+lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
+lookupLincat gr m c = do
+  info <- lookupQIdentInfo gr (m,c)
+  case info of
+    CncCat (Just (L _ t)) _ _ _ _ -> return t
+    AnyInd _ n                    -> lookupLincat gr n c
+    _                             -> raise (render (c <+> "has no linearization type in" <+> m))
+
+-- | this is needed at compile time
+lookupFunType :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Type
+lookupFunType gr m c = do
+  info <- lookupQIdentInfo gr (m,c)
+  case info of
+    AbsFun (Just (L _ t)) _ _ _ -> return t
+    AnyInd _ n                  -> lookupFunType gr n c
+    _                           -> raise (render ("cannot find type of" <+> c))
+
+-- | this is needed at compile time
+lookupCatContext :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Context
+lookupCatContext gr m c = do
+  info <- lookupQIdentInfo gr (m,c)
+  case info of
+    AbsCat (Just (L _ co)) -> return co
+    AnyInd _ n             -> lookupCatContext gr n c
+    _                      -> raise (render ("unknown category" <+> c))
+
+
+-- this gives all opers and param constructors, also overloaded opers and funs, and the types, and locations
+-- notice that it only gives the modules that are reachable and the opers that are included
+
+allOpers :: Grammar -> [(QIdent,Type,Location)]
+allOpers gr =
+  [((m,op),typ,loc) |
+      (m,mi)  <- maybe [] (allExtends gr) (greatestResource gr),
+      (op,info)  <- Map.toList (jments mi),
+      L loc typ  <- typesIn info
+  ]
+  where
+    typesIn info = case info of
+      AbsFun  (Just ltyp) _ _ _ -> [ltyp]
+      ResOper (Just ltyp) _     -> [ltyp]
+      ResValue ltyp _           -> [ltyp]
+      ResOverload _ tytrs       -> [ltyp | (ltyp,_) <- tytrs]
+      CncFun  (Just (_,i,ctx,typ)) _ _ _ ->
+                                   [L NoLoc (mkProdSimple ctx (lock' i typ))]
+      _                         -> []
+
+    lock' i typ = case lock i typ of
+                    Ok t -> t
+                    _ -> typ
+
+--- not for dependent types
+allOpersTo :: Grammar -> Type -> [(QIdent,Type,Location)]
+allOpersTo gr ty = [op | op@(_,typ,_) <- allOpers gr, isProdTo ty typ] where
+  isProdTo t typ = eqProd typ t || case typ of
+    Prod _ _ a b -> isProdTo t b
+    _ -> False
+  eqProd f g = case (f,g) of
+    (Prod _ _ a1 b1, Prod _ _ a2 b2) -> eqProd a1 a2 && eqProd b1 b2
+    _ -> f == g

src/compiler/api/GF/Grammar/Macros.hs

@@ -0,0 +1,576 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Macros
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/11 16:38:00 $
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.24 $
+--
+-- Macros for constructing and analysing source code terms.
+--
+-- operations on terms and types not involving lookup in or reference to grammars
+--
+-- AR 7\/12\/1999 - 9\/5\/2000 -- 4\/6\/2001
+-----------------------------------------------------------------------------
+
+module GF.Grammar.Macros where
+
+import GF.Data.Operations
+import GF.Data.Str
+import GF.Infra.Ident
+import GF.Grammar.Grammar
+import GF.Grammar.Predef
+import GF.Grammar.Printer
+
+import Control.Monad.Identity(Identity(..))
+import qualified Data.Traversable as T(mapM)
+import qualified Data.Map as Map
+import Control.Monad (liftM, liftM2, liftM3)
+import Data.List (sortBy,nub)
+import Data.Monoid
+import GF.Text.Pretty(render,(<+>),hsep,fsep)
+import qualified Control.Monad.Fail as Fail
+
+-- ** Functions for constructing and analysing source code terms.
+
+typeForm :: Type -> (Context, Cat, [Term])
+typeForm t =
+  case t of
+    Prod b x a t  ->
+      let (x', cat, args) = typeForm t
+      in ((b,x,a):x', cat, args)
+    App c a ->
+      let (_,  cat, args) = typeForm c
+      in ([],cat,args ++ [a])
+    Q  c -> ([],c,[])
+    QC c -> ([],c,[])
+    Sort c -> ([],(MN identW, c),[])
+    _      -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t))
+
+typeFormCnc :: Type -> (Context, Type)
+typeFormCnc t =
+  case t of
+    Prod b x a t -> let (x', v) = typeFormCnc t
+                    in ((b,x,a):x',v)
+    _            -> ([],t)
+
+valCat :: Type -> Cat
+valCat typ =
+  let (_,cat,_) = typeForm typ
+  in cat
+
+valType :: Type -> Type
+valType typ =
+  let (_,cat,xx) = typeForm typ --- not optimal to do in this way
+  in mkApp (Q cat) xx
+
+valTypeCnc :: Type -> Type
+valTypeCnc typ = snd (typeFormCnc typ)
+
+typeSkeleton :: Type -> ([(Int,Cat)],Cat)
+typeSkeleton typ =
+  let (ctxt,cat,_) = typeForm typ
+  in ([(length c, v) | (b,x,t) <- ctxt, let (c,v) = typeSkeleton t], cat)
+
+catSkeleton :: Type -> ([Cat],Cat)
+catSkeleton typ =
+  let (args,val) = typeSkeleton typ
+  in (map snd args, val)
+
+funsToAndFrom :: Type -> (Cat, [(Cat,[Int])])
+funsToAndFrom t =
+  let (cs,v) = catSkeleton t
+      cis = zip cs [0..]
+  in (v, [(c,[i | (c',i) <- cis, c' == c]) | c <- cs])
+
+isRecursiveType :: Type -> Bool
+isRecursiveType t =
+  let (cc,c) = catSkeleton t -- thus recursivity on Cat level
+  in any (== c) cc
+
+isHigherOrderType :: Type -> Bool
+isHigherOrderType t = fromErr True $ do  -- pessimistic choice
+  co <- contextOfType t
+  return $ not $ null [x | (_,x,Prod _ _ _ _) <- co]
+
+contextOfType :: Monad m => Type -> m Context
+contextOfType typ = case typ of
+  Prod b x a t -> liftM ((b,x,a):) $ contextOfType t
+  _            -> return []
+
+termForm :: Monad m => Term -> m ([(BindType,Ident)], Term, [Term])
+termForm t = case t of
+   Abs b x t  ->
+     do (x', fun, args) <- termForm t
+        return ((b,x):x', fun, args)
+   App c a ->
+     do (_,fun, args) <- termForm c
+        return ([],fun,args ++ [a])
+   _       ->
+     return ([],t,[])
+
+termFormCnc :: Term -> ([(BindType,Ident)], Term)
+termFormCnc t = case t of
+   Abs b x t  -> ((b,x):xs, t') where (xs,t') = termFormCnc t
+   _          -> ([],t)
+
+appForm :: Term -> (Term, [Term])
+appForm t = case t of
+  App c a   -> (fun, args ++ [a]) where (fun, args) = appForm c
+  Typed t _ -> appForm t
+  _         -> (t,[])
+
+mkProdSimple :: Context -> Term -> Term
+mkProdSimple c t = mkProd c t []
+
+mkProd :: Context -> Term -> [Term] -> Term
+mkProd []           typ args = mkApp typ args
+mkProd ((b,x,a):dd) typ args = Prod b x a (mkProd dd typ args)
+
+mkTerm :: ([(BindType,Ident)], Term, [Term]) -> Term
+mkTerm (xx,t,aa) = mkAbs xx (mkApp t aa)
+
+mkApp :: Term -> [Term] -> Term
+mkApp = foldl App
+
+mkAbs :: [(BindType,Ident)] -> Term -> Term
+mkAbs xx t = foldr (uncurry Abs) t xx
+
+appCons :: Ident -> [Term] -> Term
+appCons = mkApp . Cn
+
+mkLet :: [LocalDef] -> Term -> Term
+mkLet defs t = foldr Let t defs
+
+mkLetUntyped :: Context -> Term -> Term
+mkLetUntyped defs = mkLet [(x,(Nothing,t)) | (_,x,t) <- defs]
+
+isVariable :: Term -> Bool
+isVariable (Vr _ ) = True
+isVariable _ = False
+
+-- *** Assignment
+
+assign :: Label -> Term -> Assign
+assign l t = (l,(Nothing,t))
+
+assignT :: Label -> Type -> Term -> Assign
+assignT l a t = (l,(Just a,t))
+
+unzipR :: [Assign] -> ([Label],[Term])
+unzipR r = (ls, map snd ts) where (ls,ts) = unzip r
+
+mkAssign :: [(Label,Term)] -> [Assign]
+mkAssign lts = [assign l t | (l,t) <- lts]
+
+projectRec :: Label -> [Assign] -> Term
+projectRec l rs =
+  case lookup l rs of
+    Just (_,t) -> t
+    Nothing    -> error (render ("no value for label" <+> l))
+
+zipAssign :: [Label] -> [Term] -> [Assign]
+zipAssign ls ts = [assign l t | (l,t) <- zip ls ts]
+
+mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))]
+mapAssignM f = mapM (\ (ls,tv) -> liftM ((,) ls) (g tv))
+  where g (t,v) = liftM2 (,) (maybe (return Nothing) (liftM Just . f) t) (f v)
+
+-- *** Records
+
+mkRecordN :: Int -> (Int -> Label) -> [Term] -> Term
+mkRecordN int lab typs = R [ assign (lab i) t | (i,t) <- zip [int..] typs]
+
+mkRecord :: (Int -> Label) -> [Term] -> Term
+mkRecord = mkRecordN 0
+
+mkRecTypeN :: Int -> (Int -> Label) -> [Type] -> Type
+mkRecTypeN int lab typs = RecType [ (lab i, t) | (i,t) <- zip [int..] typs]
+
+mkRecType :: (Int -> Label) -> [Type] -> Type
+mkRecType = mkRecTypeN 0
+
+record2subst :: Term -> Err Substitution
+record2subst t = case t of
+  R fs -> return [(identC x, t) | (LIdent x,(_,t)) <- fs]
+  _    -> Bad (render ("record expected, found" <+> ppTerm Unqualified 0 t))
+
+
+-- *** Types
+
+typeType, typePType, typeStr, typeTok, typeStrs :: Type
+
+typeType  = Sort cType
+typePType = Sort cPType
+typeStr   = Sort cStr
+typeTok   = Sort cTok
+typeStrs  = Sort cStrs
+
+typeString, typeFloat, typeInt :: Type
+typeInts :: Integer -> Type
+typePBool :: Type
+typeError :: Type
+
+typeString = cnPredef cString
+typeInt = cnPredef cInt
+typeFloat = cnPredef cFloat
+typeInts i = App (cnPredef cInts) (EInt i)
+typePBool = cnPredef cPBool
+typeError = cnPredef cErrorType
+
+isTypeInts :: Type -> Maybe Integer
+isTypeInts (App c (EInt i)) | c == cnPredef cInts = Just i
+isTypeInts _                                      = Nothing
+
+-- *** Terms
+
+isPredefConstant :: Term -> Bool
+isPredefConstant t = case t of
+  Q (mod,_) | mod == cPredef || mod == cPredefAbs -> True
+  _                                               -> False
+
+cnPredef :: Ident -> Term
+cnPredef f = Q (cPredef,f)
+
+mkSelects :: Term -> [Term] -> Term
+mkSelects t tt = foldl S t tt
+
+mkTable :: [Term] -> Term -> Term
+mkTable tt t = foldr Table t tt
+
+mkCTable :: [(BindType,Ident)] -> Term -> Term
+mkCTable ids v = foldr ccase v ids where
+  ccase (_,x) t = T TRaw [(PV x,t)]
+
+mkHypo :: Term -> Hypo
+mkHypo typ = (Explicit,identW, typ)
+
+eqStrIdent :: Ident -> Ident -> Bool
+eqStrIdent = (==)
+
+tuple2record :: [Term] -> [Assign]
+tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts]
+
+tuple2recordType :: [Term] -> [Labelling]
+tuple2recordType ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
+
+tuple2recordPatt :: [Patt] -> [(Label,Patt)]
+tuple2recordPatt ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
+
+mkCases :: Ident -> Term -> Term
+mkCases x t = T TRaw [(PV x, t)]
+
+mkWildCases :: Term -> Term
+mkWildCases = mkCases identW
+
+mkFunType :: [Type] -> Type -> Type
+mkFunType tt t = mkProd [(Explicit,identW, ty) | ty <- tt] t [] -- nondep prod
+
+--plusRecType :: Type -> Type -> Err Type
+plusRecType t1 t2 = case (t1, t2) of
+  (RecType r1, RecType r2) -> case
+    filter (`elem` (map fst r1)) (map fst r2) of
+      [] -> return (RecType (r1 ++ r2))
+      ls -> raise $ render ("clashing labels" <+> hsep ls)
+  _ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)
+
+--plusRecord :: Term -> Term -> Err Term
+plusRecord t1 t2 =
+ case (t1,t2) of
+   (R r1, R r2 ) -> return (R ([(l,v) | -- overshadowing of old fields
+                              (l,v) <- r1, not (elem l (map fst r2)) ] ++ r2))
+   (_,    FV rs) -> mapM (plusRecord t1) rs >>= return . FV
+   (FV rs,_    ) -> mapM (`plusRecord` t2) rs >>= return . FV
+   _ -> raise $ render ("cannot add records" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)
+
+-- | default linearization type
+defLinType :: Type
+defLinType = RecType [(theLinLabel,  typeStr)]
+
+-- | refreshing variables
+mkFreshVar :: [Ident] -> Ident -> Ident
+mkFreshVar olds x =
+  case maximum ((-1) : map (varIndex' rx) olds) + 1 of
+    0 -> x
+    i -> identV rx i
+  where
+    rx = ident2raw x
+
+-- | trying to preserve a given symbol
+mkFreshVarX :: [Ident] -> Ident -> Ident
+mkFreshVarX olds x = if (elem x olds) then (varX (maximum ((-1) : (map varIndex olds)) + 1)) else x
+
+-- *** Term and pattern conversion
+
+term2patt :: Term -> Err Patt
+term2patt trm = case termForm trm of
+  Ok ([], Vr x, []) | x == identW -> return PW
+                    | otherwise   -> return (PV x)
+  Ok ([], Con c, aa) -> do
+    aa' <- mapM term2patt aa
+    return (PC c aa')
+  Ok ([], QC  c, aa) -> do
+    aa' <- mapM term2patt aa
+    return (PP c aa')
+
+  Ok ([], Q c, []) -> do
+    return (PM c)
+
+  Ok ([], R r, []) -> do
+    let (ll,aa) = unzipR r
+    aa' <- mapM term2patt aa
+    return (PR (zip ll aa'))
+  Ok ([],EInt i,[]) -> return $ PInt i
+  Ok ([],EFloat i,[]) -> return $ PFloat i
+  Ok ([],K s,   []) -> return $ PString s
+
+--- encodings due to excessive use of term-patt convs. AR 7/1/2005
+  Ok ([], Cn id, [Vr a,b]) | id == cAs -> do
+    b' <- term2patt b
+    return (PAs a b')
+  Ok ([], Cn id, [a]) | id == cNeg  -> do
+    a' <- term2patt a
+    return (PNeg a')
+  Ok ([], Cn id, [a]) | id == cRep -> do
+    a' <- term2patt a
+    return (PRep 0 Nothing a')
+  Ok ([], Cn id, []) | id == cRep -> do
+    return PChar
+  Ok ([], Cn id,[K s]) | id == cChars  -> do
+    return $ PChars s
+  Ok ([], Cn id, [a,b]) | id == cSeq -> do
+    a' <- term2patt a
+    b' <- term2patt b
+    return (PSeq 0 Nothing a' 0 Nothing b')
+  Ok ([], Cn id, [a,b]) | id == cAlt -> do
+    a' <- term2patt a
+    b' <- term2patt b
+    return (PAlt a' b')
+
+  Ok ([], Cn c, []) -> do
+    return (PMacro c)
+
+  _ -> Bad $ render ("no pattern corresponds to term" <+> ppTerm Unqualified 0 trm)
+
+patt2term :: Patt -> Term
+patt2term pt = case pt of
+  PV x      -> Vr x
+  PW        -> Vr identW             --- not parsable, should not occur
+  PMacro c  -> Cn c
+  PM c      -> Q c
+
+  PC c pp   -> mkApp (Con c) (map patt2term pp)
+  PP c pp   -> mkApp (QC  c) (map patt2term pp)
+
+  PR r      -> R [assign l (patt2term p) | (l,p) <- r]
+  PT _ p    -> patt2term p
+  PInt i    -> EInt i
+  PFloat i  -> EFloat i
+  PString s -> K s
+
+  PAs x p   -> appCons cAs    [Vr x, patt2term p]            --- an encoding
+  PChar     -> appCons cChar  []                             --- an encoding
+  PChars s  -> appCons cChars [K s]                          --- an encoding
+  PSeq _ _ a _ _ b  -> appCons cSeq   [(patt2term a), (patt2term b)] --- an encoding
+  PAlt a b  -> appCons cAlt   [(patt2term a), (patt2term b)] --- an encoding
+  PRep _ _ a-> appCons cRep   [(patt2term a)]                --- an encoding
+  PNeg a    -> appCons cNeg   [(patt2term a)]                --- an encoding
+
+
+-- *** Almost compositional
+
+-- | to define compositional term functions
+composSafeOp :: (Term -> Term) -> Term -> Term
+composSafeOp op = runIdentity . composOp (return . op)
+
+-- | to define compositional term functions
+composOp :: Monad m => (Term -> m Term) -> Term -> m Term
+composOp co trm =
+ case trm of
+   App c a          -> liftM2 App (co c) (co a)
+   Abs b x t        -> liftM (Abs b x) (co t)
+   Prod b x a t     -> liftM2 (Prod b x) (co a) (co t)
+   S c a            -> liftM2 S (co c) (co a)
+   Table a c        -> liftM2 Table (co a) (co c)
+   R r              -> liftM R (mapAssignM co r)
+   RecType r        -> liftM RecType (mapPairsM co r)
+   P t i            -> liftM2 P (co t) (return i)
+   ExtR a c         -> liftM2 ExtR (co a) (co c)
+   T i cc           -> liftM2 (flip T) (mapPairsM co cc) (changeTableType co i)
+   V ty vs          -> liftM2 V (co ty) (mapM co vs)
+   Let (x,(mt,a)) b -> liftM3 let' (co a) (T.mapM co mt) (co b)
+     where let' a' mt' b' = Let (x,(mt',a')) b'
+   C s1 s2          -> liftM2 C (co s1) (co s2)
+   Glue s1 s2       -> liftM2 Glue (co s1) (co s2)
+   Alts t aa        -> liftM2 Alts (co t) (mapM (pairM co) aa)
+   FV ts            -> liftM FV (mapM co ts)
+   Strs tt          -> liftM Strs (mapM co tt)
+   EPattType ty     -> liftM EPattType (co ty)
+   ELincat c ty     -> liftM (ELincat c) (co ty)
+   ELin c ty        -> liftM (ELin c) (co ty)
+   ImplArg t        -> liftM ImplArg (co t)
+   _ -> return trm -- covers K, Vr, Cn, Sort, EPatt
+
+composSafePattOp op = runIdentity . composPattOp (return . op)
+
+composPattOp :: Monad m => (Patt -> m Patt) -> Patt -> m Patt
+composPattOp op patt =
+  case patt of
+    PC c ps         -> liftM  (PC c) (mapM op ps)
+    PP qc ps        -> liftM  (PP qc) (mapM op ps)
+    PR as           -> liftM  PR (mapPairsM op as)
+    PT ty p         -> liftM  (PT ty) (op p)
+    PAs x p         -> liftM  (PAs x) (op p)
+    PImplArg p      -> liftM  PImplArg (op p)
+    PNeg p          -> liftM  PNeg (op p)
+    PAlt p1 p2      -> liftM2 PAlt (op p1) (op p2)
+    PSeq _ _ p1 _ _ p2  -> liftM2 (\p1 p2 -> PSeq 0 Nothing p1 0 Nothing p2) (op p1) (op p2)
+    PRep _ _ p      -> liftM  (PRep 0 Nothing) (op p)
+    _               -> return patt -- covers cases without subpatterns
+
+collectOp :: Monoid m => (Term -> m) -> Term -> m
+collectOp co trm = case trm of
+  App c a      -> co c <> co a
+  Abs _ _ b    -> co b
+  Prod _ _ a b -> co a <> co b
+  S c a        -> co c <> co a
+  Table a c    -> co a <> co c
+  ExtR a c     -> co a <> co c
+  R r          -> mconcatMap (\ (_,(mt,a)) -> maybe mempty co mt <> co a) r
+  RecType r    -> mconcatMap (co . snd) r
+  P t i        -> co t
+  T _ cc       -> mconcatMap (co . snd) cc -- not from patterns --- nor from type annot
+  V _ cc       -> mconcatMap co         cc --- nor from type annot
+  Let (x,(mt,a)) b -> maybe mempty co mt <> co a <> co b
+  C s1 s2      -> co s1 <> co s2
+  Glue s1 s2   -> co s1 <> co s2
+  Alts t aa    -> let (x,y) = unzip aa in co t <> mconcatMap co (x <> y)
+  FV ts        -> mconcatMap co ts
+  Strs tt      -> mconcatMap co tt
+  _            -> mempty -- covers K, Vr, Cn, Sort
+
+mconcatMap f = mconcat . map f
+
+collectPattOp :: (Patt -> [a]) -> Patt -> [a]
+collectPattOp op patt =
+  case patt of
+    PC c ps         -> concatMap op ps
+    PP qc ps        -> concatMap op ps
+    PR as           -> concatMap (op.snd) as
+    PT ty p         -> op p
+    PAs x p         -> op p
+    PImplArg p      -> op p
+    PNeg p          -> op p
+    PAlt p1 p2      -> op p1++op p2
+    PSeq _ _ p1 _ _ p2 -> op p1++op p2
+    PRep _ _ p      -> op p
+    _               -> []     -- covers cases without subpatterns
+
+
+-- *** Misc
+
+-- | to get a string from a term that represents a sequence of terminals
+strsFromTerm :: Term -> Err [Str]
+strsFromTerm t = case t of
+  K s   -> return [str s]
+  Empty -> return [str []]
+  C s t -> do
+    s' <- strsFromTerm s
+    t' <- strsFromTerm t
+    return [plusStr x y | x <- s', y <- t']
+  Glue s t -> do
+    s' <- strsFromTerm s
+    t' <- strsFromTerm t
+    return [glueStr x y | x <- s', y <- t']
+  Alts d vs -> do
+    d0 <- strsFromTerm d
+    v0 <- mapM (strsFromTerm . fst) vs
+    c0 <- mapM (strsFromTerm . snd) vs
+  --let vs' = zip v0 c0
+    return [strTok (str2strings def) vars |
+              def  <- d0,
+              vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
+                                                          vv <- sequence v0]
+           ]
+  FV ts -> mapM strsFromTerm ts >>= return . concat
+  Strs ts -> mapM strsFromTerm ts >>= return . concat
+  _ -> raise (render ("cannot get Str from term" <+> ppTerm Unqualified 0 t))
+
+changeTableType :: Monad m => (Type -> m Type) -> TInfo -> m TInfo
+changeTableType co i = case i of
+    TTyped ty -> co ty >>= return . TTyped
+    TComp ty  -> co ty >>= return . TComp
+    TWild ty  -> co ty >>= return . TWild
+    _ -> return i
+
+-- | normalize records and record types; put s first
+
+sortRec :: [(Label,a)] -> [(Label,a)]
+sortRec = sortBy ordLabel where
+  ordLabel (r1,_) (r2,_) =
+    case (showIdent (label2ident r1), showIdent (label2ident r2)) of
+      ("s",_) -> LT
+      (_,"s") -> GT
+      (s1,s2) -> compare s1 s2
+
+-- *** Dependencies
+
+-- | dependency check, detecting circularities and returning topo-sorted list
+
+allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,[Ident])]
+allDependencies ism b =
+  [(f, nub (concatMap opty (pts i))) | (f,i) <- Map.toList b]
+  where
+    opersIn t = case t of
+      Q  (n,c) | ism n -> [c]
+      QC (n,c) | ism n -> [c]
+      _ -> collectOp opersIn t
+    opty (Just (L _ ty)) = opersIn ty
+    opty _ = []
+    pts i = case i of
+      ResOper pty pt -> [pty,pt]
+      ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts]
+      ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont) <- ps, (_,_,t) <- cont]
+      CncCat pty _ _ _ _ -> [pty]
+      CncFun _   pt _ _ -> [pt]  ---- (Maybe (Ident,(Context,Type))
+      AbsFun pty _ ptr _ -> [pty] --- ptr is def, which can be mutual
+      AbsCat (Just (L loc co)) -> [Just (L loc ty) | (_,_,ty) <- co]
+      _              -> []
+
+topoSortJments :: ErrorMonad m => SourceModule -> m [(Ident,Info)]
+topoSortJments (m,mi) = do
+  is <- either
+          return
+          (\cyc -> raise (render ("circular definitions:" <+> fsep (head cyc))))
+          (topoTest (allDependencies (==m) (jments mi)))
+  return (reverse [(i,info) | i <- is, Just info <- [Map.lookup i (jments mi)]])
+
+topoSortJments2 :: ErrorMonad m => SourceModule -> m [[(Ident,Info)]]
+topoSortJments2 (m,mi) = do
+  iss <- either
+           return
+           (\cyc -> raise (render ("circular definitions:"
+                                   <+> fsep (head cyc))))
+           (topoTest2 (allDependencies (==m) (jments mi)))
+  return
+    [[(i,info) | i<-is,Just info<-[Map.lookup i (jments mi)]] | is<-iss]
+
+
+mkStrs p = case p of
+ PAlt a b -> do
+   Strs as <- mkStrs a
+   Strs bs <- mkStrs b
+   return $ Strs $ as ++ bs
+ PSeq _ _ a _ _ b ->
+             do Strs as <- mkStrs a
+                Strs bs <- mkStrs b
+                return $ Strs $ [K (a++b) | K a <- as, K b <- bs]
+ PString s -> return $ Strs [K s]
+ PChars cs -> return $ Strs [K [c] | c <- cs]
+ PV x -> return (Vr x) --- for macros; not yet complete
+ PMacro x -> return (Vr x) --- for macros; not yet complete
+ PM c -> return (Q c) --- for macros; not yet complete
+ _ -> fail "no strs from pattern"

src/compiler/api/GF/Grammar/Parser.y

@@ -0,0 +1,818 @@
+-- -*- haskell -*-
+{
+{-# OPTIONS -fno-warn-overlapping-patterns #-}
+module GF.Grammar.Parser
+         ( P, runP, runPartial
+         , pModDef
+         , pModHeader
+         , pTerm
+         , pExp
+         , pTopDef
+         , pBNFCRules
+         , pEBNFRules
+         ) where
+
+import GF.Infra.Ident
+import GF.Infra.Option
+import GF.Data.Operations
+import GF.Grammar.Predef
+import GF.Grammar.Grammar
+import GF.Grammar.BNFC
+import GF.Grammar.EBNF
+import GF.Grammar.Macros
+import GF.Grammar.Lexer
+import GF.Compile.Update (buildAnyTree)
+import Data.List(intersperse)
+import Data.Char(isAlphaNum)
+import qualified Data.Map as Map
+
+}
+
+%name pModDef ModDef
+%name pTopDef TopDef
+%partial pModHeader ModHeader
+%partial pTerm Exp
+%name pExp Exp
+%name pBNFCRules ListCFRule
+%name pEBNFRules ListEBNFRule
+
+-- no lexer declaration
+%monad { P } { >>= } { return }
+%lexer { lexer } { T_EOF }
+%tokentype { Token }
+
+
+%token 
+ '!'          { T_exclmark  }
+ '#'          { T_patt      }
+ '$'          { T_int_label }
+ '('          { T_oparen    }
+ ')'          { T_cparen    }
+ '~'          { T_tilde     }
+ '*'          { T_star      }
+ '**'         { T_starstar  }
+ '+'          { T_plus      }
+ '++'         { T_plusplus  }
+ ','          { T_comma     }
+ '-'          { T_minus     }
+ '->'         { T_rarrow    }
+ '.'          { T_dot       }
+ '/'          { T_alt       }
+ ':'          { T_colon     }
+ ';'          { T_semicolon }
+ '<'          { T_less      }
+ '='          { T_equal     }
+ '=>'         { T_big_rarrow}
+ '>'          { T_great     }
+ '?'          { T_questmark }
+ '@'          { T_at        }
+ '['          { T_obrack    }
+ ']'          { T_cbrack    }
+ '{'          { T_ocurly    }
+ '}'          { T_ccurly    }
+ '\\'         { T_lam       }
+ '\\\\'       { T_lamlam    }
+ '_'          { T_underscore}
+ '|'          { T_bar       }
+ '::='        { T_cfarrow   }
+ 'PType'      { T_PType     }
+ 'Str'        { T_Str       }
+ 'Strs'       { T_Strs      }
+ 'Tok'        { T_Tok       }
+ 'Type'       { T_Type      }
+ 'abstract'   { T_abstract  }
+ 'case'       { T_case      }
+ 'cat'        { T_cat       }
+ 'concrete'   { T_concrete  }
+ 'data'       { T_data      }
+ 'def'        { T_def       }
+ 'flags'      { T_flags     }
+ 'fun'        { T_fun       }
+ 'in'         { T_in        }
+ 'incomplete' { T_incomplete}
+ 'instance'   { T_instance  }
+ 'interface'  { T_interface }
+ 'let'        { T_let       }
+ 'lin'        { T_lin       }
+ 'lincat'     { T_lincat    }
+ 'lindef'     { T_lindef    }
+ 'linref'     { T_linref    }
+ 'of'         { T_of        }
+ 'open'       { T_open      }
+ 'oper'       { T_oper      }
+ 'param'      { T_param     }
+ 'pattern'    { T_pattern   }
+ 'pre'        { T_pre       }
+ 'printname'  { T_printname }
+ 'resource'   { T_resource  }
+ 'strs'       { T_strs      }
+ 'table'      { T_table     }
+ 'variants'   { T_variants  }
+ 'where'      { T_where     }
+ 'with'       { T_with      }
+ 'coercions'  { T_coercions }
+ 'terminator' { T_terminator }
+ 'separator'  { T_separator }
+ 'nonempty'   { T_nonempty  }
+
+Integer       { (T_Integer $$) }
+Double        { (T_Double  $$) }
+String        { (T_String  $$) }
+Ident         { (T_Ident   $$) }
+
+
+%%
+
+ModDef :: { SourceModule }
+ModDef
+  : ComplMod ModType '=' ModBody {%
+                                   do let mstat = $1
+                                          (mtype,id) = $2
+                                          (extends,with,content) = $4
+                                          (opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) }
+                                      jments <- mapM (checkInfoType mtype) jments
+                                      defs <- buildAnyTree id jments
+                                      return (id, ModInfo mtype mstat opts extends with opens [] "" Nothing defs)  }
+
+ModHeader :: { SourceModule }
+ModHeader
+  : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
+                                               (mtype,id) = $2 ;
+                                               (extends,with,opens) = $4 }
+                                         in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing Map.empty) }
+
+ComplMod :: { ModuleStatus }
+ComplMod 
+  : {- empty -}  { MSComplete   } 
+  | 'incomplete' { MSIncomplete }
+
+ModType :: { (ModuleType,ModuleName) }
+ModType
+  : 'abstract'  ModuleName                     { (MTAbstract,      $2) }
+  | 'resource'  ModuleName                     { (MTResource,      $2) }
+  | 'interface' ModuleName                     { (MTInterface,     $2) }
+  | 'concrete'  ModuleName 'of' ModuleName     { (MTConcrete $4,   $2) }
+  | 'instance'  ModuleName 'of' Included       { (MTInstance $4,   $2) }
+
+ModHeaderBody :: { ( [(ModuleName,MInclude)]
+                   , Maybe (ModuleName,MInclude,[(ModuleName,ModuleName)])
+                   , [OpenSpec]
+                   ) }
+ModHeaderBody
+  : ListIncluded '**' Included 'with' ListInst '**' ModOpen { ($1, Just (fst $3,snd $3,$5), $7) }
+  | ListIncluded '**' Included 'with' ListInst              { ($1, Just (fst $3,snd $3,$5), []) }
+  | ListIncluded                               '**' ModOpen { ($1, Nothing,                 $3) }
+  | ListIncluded                                            { ($1, Nothing,                 []) }
+  |                   Included 'with' ListInst '**' ModOpen { ([], Just (fst $1,snd $1,$3), $5) }
+  |                   Included 'with' ListInst              { ([], Just (fst $1,snd $1,$3), []) }
+  |                                                 ModOpen { ([], Nothing,                 $1) }
+
+ModOpen :: { [OpenSpec] }
+ModOpen
+  :                 { [] }
+  | 'open' ListOpen { $2 }
+
+ModBody :: { ( [(ModuleName,MInclude)]
+             , Maybe (ModuleName,MInclude,[(ModuleName,ModuleName)])
+             , Maybe ([OpenSpec],[(Ident,Info)],Options)
+             ) }
+ModBody
+  : ListIncluded '**' Included 'with' ListInst '**' ModContent  { ($1, Just (fst $3,snd $3,$5), Just $7) }
+  | ListIncluded '**' Included 'with' ListInst                  { ($1, Just (fst $3,snd $3,$5), Nothing) }
+  | ListIncluded                               '**' ModContent  { ($1, Nothing,                 Just $3) }
+  | ListIncluded                                                { ($1, Nothing,                 Nothing) }
+  |                   Included 'with' ListInst '**' ModContent  { ([], Just (fst $1,snd $1,$3), Just $5) }
+  |                   Included 'with' ListInst                  { ([], Just (fst $1,snd $1,$3), Nothing) }
+  |                                                 ModContent  { ([], Nothing,                 Just $1) }
+  | ModBody ';'                                                 { $1                                     }
+
+ModContent :: { ([OpenSpec],[(Ident,Info)],Options) }
+ModContent
+  :                      '{' ListTopDef '}' { ([],[d | Left ds <- $2, d <- ds],concatOptions [o | Right o <- $2]) }
+  | 'open' ListOpen 'in' '{' ListTopDef '}' { ($2,[d | Left ds <- $5, d <- ds],concatOptions [o | Right o <- $5]) }
+
+ListTopDef :: { [Either [(Ident,Info)] Options] }
+ListTopDef
+  : {- empty -}       { []      } 
+  | TopDef ListTopDef { $1 : $2 }
+
+ListOpen :: { [OpenSpec] }
+ListOpen
+  : Open              { [$1]    }
+  | Open ',' ListOpen { $1 : $3 }
+
+Open :: { OpenSpec }
+Open
+  : ModuleName                   { OSimple $1    }
+  | '(' ModuleName '=' ModuleName ')' { OQualif $2 $4 }
+
+ListInst :: { [(ModuleName,ModuleName)] }
+ListInst
+  : Inst              { [$1]    }
+  | Inst ',' ListInst { $1 : $3 }
+
+Inst :: { (ModuleName,ModuleName) }
+Inst
+  : '(' ModuleName '=' ModuleName ')' { ($2,$4) }
+
+ListIncluded :: { [(ModuleName,MInclude)] }
+ListIncluded
+  : Included                  { [$1]    }
+  | Included ',' ListIncluded { $1 : $3 }
+
+Included :: { (ModuleName,MInclude) }
+Included 
+  : ModuleName                       { ($1,MIAll      ) }
+  | ModuleName     '[' ListIdent ']' { ($1,MIOnly   $3) }
+  | ModuleName '-' '[' ListIdent ']' { ($1,MIExcept $4) }
+
+TopDef :: { Either [(Ident,Info)] Options }
+TopDef
+  : 'cat'             ListCatDef      { Left  $2 }
+  | 'fun'             ListFunDef      { Left  $2 }
+  | 'def'             ListDefDef      { Left  $2 }
+  | 'data'            ListDataDef     { Left  $2 }
+  | 'param'           ListParamDef    { Left  $2 }
+  | 'oper'            ListOperDef     { Left  $2 }
+  | 'lincat'          ListTermDef     { Left  [(f, CncCat (Just e) Nothing  Nothing  Nothing Nothing) | (f,e) <- $2] }
+  | 'lindef'          ListTermDef     { Left  [(f, CncCat Nothing  (Just e) Nothing  Nothing Nothing) | (f,e) <- $2] }
+  | 'linref'          ListTermDef     { Left  [(f, CncCat Nothing  Nothing  (Just e) Nothing Nothing) | (f,e) <- $2] }
+  | 'lin'             ListLinDef      { Left  $2 }
+  | 'printname' 'cat' ListTermDef     { Left  [(f, CncCat Nothing Nothing Nothing (Just e) Nothing) | (f,e) <- $3] }
+  | 'printname' 'fun' ListTermDef     { Left  [(f, CncFun Nothing Nothing (Just e) Nothing) | (f,e) <- $3] }
+  | 'flags'           ListFlagDef     { Right $2 }
+
+CatDef :: { [(Ident,Info)] }
+CatDef
+  : Posn Ident ListDDecl                         Posn { [($2, AbsCat (Just (mkL $1 $4 $3)))]           }
+  | Posn '[' Ident ListDDecl ']'                 Posn { listCatDef (mkL $1 $6 ($3,$4,0))               }
+  | Posn '[' Ident ListDDecl ']' '{' Integer '}' Posn { listCatDef (mkL $1 $9 ($3,$4,fromIntegral $7)) }
+
+FunDef :: { [(Ident,Info)] }
+FunDef
+  : Posn ListIdent ':' Exp Posn { [(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing (Just []) (Just True)) | fun <- $2] } 
+
+DefDef :: { [(Ident,Info)] }
+DefDef
+  : Posn LhsNames '=' Exp         Posn { [(f, AbsFun Nothing (Just 0)           (Just [mkL $1 $5 ([],$4)]) Nothing) | f <- $2] }
+  | Posn LhsName ListPatt '=' Exp    Posn { [($2,AbsFun Nothing (Just (length $3)) (Just [mkL $1 $6 ($3,$5)]) Nothing)] }
+
+DataDef :: { [(Ident,Info)] }
+DataDef
+  : Posn Ident '=' ListDataConstr Posn { ($2,   AbsCat Nothing) :
+                                         [(fun, AbsFun Nothing Nothing Nothing  (Just True)) | fun <- $4] }
+  | Posn ListIdent ':' Exp Posn        { -- (snd (valCat $4), AbsCat Nothing) :
+                                         [(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing Nothing (Just True)) | fun <- $2] }                                         
+
+ParamDef :: { [(Ident,Info)] }
+ParamDef
+  : Posn LhsIdent '=' ListParConstr Posn { ($2, ResParam (Just (mkL $1 $5 [param | L loc param <- $4])) Nothing) :
+                                           [(f, ResValue (L loc (mkProdSimple co (Cn $2))) 0) | L loc (f,co) <- $4] }
+  | Posn LhsIdent                   Posn { [($2, ResParam Nothing Nothing)] }
+
+OperDef :: { [(Ident,Info)] }
+OperDef
+  : Posn LhsNames ':' Exp         Posn { [(i, info) | i <- $2,   info <- mkOverload (Just (mkL $1 $5 $4)) Nothing  ] }
+  | Posn LhsNames '=' Exp         Posn { [(i, info) | i <- $2,   info <- mkOverload Nothing   (Just (mkL $1 $5 $4))] }
+  | Posn LhsName ListArg '=' Exp     Posn { [(i, info) | i <- [$2], info <- mkOverload Nothing   (Just (mkL $1 $6 (mkAbs $3 $5)))] }
+  | Posn LhsNames ':' Exp '=' Exp Posn { [(i, info) | i <- $2,   info <- mkOverload (Just (mkL $1 $7 $4)) (Just (mkL $1 $7 $6))] }
+
+LinDef :: { [(Ident,Info)] }
+LinDef
+  : Posn LhsNames '=' Exp         Posn { [(f,  CncFun Nothing (Just (mkL $1 $5 $4)) Nothing Nothing) | f <- $2] }
+  | Posn LhsName ListArg '=' Exp     Posn { [($2, CncFun Nothing (Just (mkL $1 $6 (mkAbs $3 $5))) Nothing Nothing)] }
+
+TermDef :: { [(Ident,L Term)] }
+TermDef
+  : Posn LhsNames '=' Exp Posn { [(i,mkL $1 $5 $4) | i <- $2] }
+
+FlagDef :: { Options }
+FlagDef
+  : Posn Ident '=' Ident Posn  {% case parseModuleOptions ["--" ++ showIdent $2 ++ "=" ++ showIdent $4] of
+                                    Ok  x   -> return x
+                                    Bad msg -> failLoc $1 msg                                           } 
+  | Posn Ident '=' Double Posn {% case parseModuleOptions ["--" ++ showIdent $2 ++ "=" ++ show $4] of
+                                    Ok  x   -> return x
+                                    Bad msg -> failLoc $1 msg                                           } 
+
+ListDataConstr :: { [Ident] }
+ListDataConstr
+  : Ident                    { [$1]    }
+  | Ident '|' ListDataConstr { $1 : $3 }
+
+ParConstr :: { L Param }
+ParConstr
+  : Posn Ident ListDDecl Posn { mkL $1 $4 ($2,$3) } 
+
+ListLinDef :: { [(Ident,Info)] }
+ListLinDef
+  : LinDef ';'            { $1       } 
+  | LinDef ';' ListLinDef { $1 ++ $3 }
+
+ListDefDef :: { [(Ident,Info)] }
+ListDefDef
+  : DefDef ';'            { $1       } 
+  | DefDef ';' ListDefDef { $1 ++ $3 }
+
+ListOperDef :: { [(Ident,Info)] }
+ListOperDef
+  : OperDef ';'             { $1       } 
+  | OperDef ';' ListOperDef { $1 ++ $3 }
+
+ListCatDef :: { [(Ident,Info)] }
+ListCatDef
+  : CatDef ';'            { $1       } 
+  | CatDef ';' ListCatDef { $1 ++ $3 }
+
+ListFunDef :: { [(Ident,Info)] }
+ListFunDef
+  : FunDef ';'            { $1       }
+  | FunDef ';' ListFunDef { $1 ++ $3 }
+
+ListDataDef :: { [(Ident,Info)] }
+ListDataDef
+  : DataDef ';'             { $1       } 
+  | DataDef ';' ListDataDef { $1 ++ $3 }
+
+ListParamDef :: { [(Ident,Info)] }
+ListParamDef
+  : ParamDef ';'              { $1       } 
+  | ParamDef ';' ListParamDef { $1 ++ $3 }
+
+ListTermDef :: { [(Ident,L Term)] }
+ListTermDef
+  : TermDef ';'             { $1       } 
+  | TermDef ';' ListTermDef { $1 ++ $3 }
+
+ListFlagDef :: { Options }
+ListFlagDef
+  : FlagDef ';'               { $1               } 
+  | FlagDef ';' ListFlagDef   { addOptions $1 $3 }
+
+ListParConstr :: { [L Param] }
+ListParConstr
+  : ParConstr                   { [$1]    }
+  | ParConstr '|' ListParConstr { $1 : $3 }
+
+ListIdent :: { [Ident] }
+ListIdent
+  : Ident               { [$1]    } 
+  | Ident ',' ListIdent { $1 : $3 }
+
+ListIdent2 :: { [Ident] }
+ListIdent2 
+  : Ident               { [$1]    } 
+  | Ident ListIdent2    { $1 : $2 }
+
+LhsIdent :: { Ident }
+  : Ident     { $1 }
+  | Posn Sort {% failLoc $1 (showIdent $2++ " is a predefined constant, it can not be redefined") }
+
+LhsName :: { Ident }
+LhsName
+  : LhsIdent         { $1          }
+  | '[' LhsIdent ']' { mkListId $2 }
+
+LhsNames :: { [Ident] }
+LhsNames
+  : LhsName              { [$1]    }
+  | LhsName ',' LhsNames { $1 : $3 }
+
+LocDef :: { [(Ident, Maybe Type, Maybe Term)] }
+LocDef
+  : ListIdent ':' Exp         { [(lab,Just $3,Nothing) | lab <- $1] } 
+  | ListIdent '=' Exp         { [(lab,Nothing,Just $3) | lab <- $1] }
+  | ListIdent ':' Exp '=' Exp { [(lab,Just $3,Just $5) | lab <- $1] }
+
+ListLocDef :: { [(Ident, Maybe Type, Maybe Term)] }
+ListLocDef
+  : {- empty -}           { []       } 
+  | LocDef                { $1       }
+  | LocDef ';' ListLocDef { $1 ++ $3 }
+
+Exp :: { Term }
+Exp
+  : Exp1 '|' Exp                      { FV [$1,$3] } 
+  | '\\'   ListBind '->' Exp          { mkAbs $2 $4 }
+  | '\\\\' ListBind '=>' Exp          { mkCTable $2 $4 }
+  | Decl '->' Exp                     { mkProdSimple $1 $3 }
+  | Exp3 '=>' Exp                     { Table $1 $3 }
+  | 'let' '{' ListLocDef '}' 'in' Exp {%
+                                        do defs <- mapM tryLoc $3
+                                           return $ mkLet defs $6 }
+  | 'let' ListLocDef 'in' Exp         {%
+                                        do defs <- mapM tryLoc $2
+                                           return $ mkLet defs $4 }
+  | Exp3 'where' '{' ListLocDef '}'   {%
+                                        do defs <- mapM tryLoc $4
+                                           return $ mkLet defs $1 }
+  | 'in' Exp5 String                  { Example $2 $3 }
+  | Exp1                              { $1 }
+
+Exp1 :: { Term }
+Exp1
+  : Exp2 '++' Exp1 { C $1 $3 } 
+  | Exp2           { $1      }
+
+Exp2 :: { Term }
+Exp2
+  : Exp3 '+' Exp2 { Glue $1 $3 } 
+  | Exp3          { $1         }
+
+Exp3 :: { Term }
+Exp3
+  : Exp3 '!' Exp4                    { S $1 $3       } 
+  | 'table' '{' ListCase '}'         { T TRaw $3     }
+  | 'table' Exp6 '{' ListCase '}'    { T (TTyped $2) $4 }
+  | 'table' Exp6 '[' ListExp ']'     { V $2 $4       }
+  | Exp3 '*'  Exp4                   { case $1 of
+                                         RecType xs -> RecType (xs ++ [(tupleLabel (length xs+1),$3)])
+                                         t          -> RecType [(tupleLabel 1,$1), (tupleLabel 2,$3)]  }
+  | Exp3 '**' Exp4                   { ExtR $1 $3    }
+  | Exp4                             { $1            }
+
+Exp4 :: { Term }
+Exp4
+  : Exp4 Exp5                        { App $1 $2     }
+  | Exp4 '{' Exp '}'                 { App $1 (ImplArg $3) } 
+  | 'case' Exp 'of' '{' ListCase '}' { let annot = case $2 of
+                                             Typed _ t -> TTyped t
+                                             _         -> TRaw
+                                       in S (T annot $5) $2         }
+  | 'variants' '{' ListExp '}'       { FV $3         }
+  | 'pre' '{' ListCase '}'           {% mkAlts $3     }
+  | 'pre' '{' String ';' ListAltern '}' { Alts (K $3) $5 }
+  | 'pre' '{' Ident ';' ListAltern '}' { Alts (Vr $3) $5 }
+  | 'strs' '{' ListExp '}'           { Strs $3       }
+  | '#' Patt3                        { EPatt 0 Nothing $2 }
+  | 'pattern' Exp5                   { EPattType $2  }
+  | 'lincat' Ident Exp5              { ELincat $2 $3 }
+  | 'lin' Ident Exp5                 { ELin $2 $3 }
+  | Exp5                             { $1            }
+
+Exp5 :: { Term }
+Exp5
+  : Exp5 '.' Label            { P  $1 $3 } 
+  | Exp6                      { $1       }
+
+Exp6 :: { Term }
+Exp6 
+  : Ident                 { Vr $1 } 
+  | Sort                  { Sort $1 }
+  | String                { K $1 }
+  | Integer               { EInt $1 }
+  | Double                { EFloat $1 }
+  | '?'                   { Meta 0 }
+  | '[' ']'               { Empty }
+  | '[' Ident Exps ']'    { foldl App (Vr (mkListId $2)) $3 }
+  | '[' String ']'        { K $2 }
+  | '{' ListLocDef '}'    {% mkR $2 }
+  | '<' ListTupleComp '>' { R (tuple2record $2) }
+  | '<' Exp ':' Exp '>'   { Typed $2 $4      }
+  | '(' Exp ')'           { $2 }
+
+ListExp :: { [Term] }
+ListExp
+  : {- empty -}     { []      } 
+  | Exp             { [$1]    }
+  | Exp ';' ListExp { $1 : $3 }
+
+Exps :: { [Term] }
+Exps
+  : {- empty -}     { []      } 
+  | Exp6 Exps       { $1 : $2 }
+
+Patt :: { Patt }
+Patt
+  : Patt '|' Patt1            { PAlt $1 $3 } 
+  | Patt '+' Patt1            { PSeq 0 Nothing $1 0 Nothing $3 }
+  | Patt1                     { $1         }
+
+Patt1 :: { Patt }
+Patt1
+  : Ident ListPatt            { PC $1 $2 } 
+  | ModuleName '.' Ident ListPatt  { PP ($1,$3) $4 }
+  | Patt3 '*'                 { PRep 0 Nothing $1 }
+  | Patt2                     { $1 }
+
+Patt2 :: { Patt }
+Patt2
+  : Ident '@' Patt3           { PAs $1 $3 }
+  | '-' Patt3                 { PNeg $2 }
+  | '~' Exp6                  { PTilde $2 }
+  | Patt3                     { $1 } 
+
+Patt3 :: { Patt }
+Patt3
+  : '?'                       { PChar } 
+  | '[' String ']'            { PChars $2 }
+  | '#' Ident                 { PMacro $2 }
+  | '#' ModuleName '.' Ident  { PM ($2,$4) }
+  | '_'                       { PW }
+  | Ident                     { PV $1 }
+  | ModuleName '.' Ident      { PP ($1,$3) [] }
+  | Integer                   { PInt $1 }
+  | Double                    { PFloat  $1 }
+  | String                    { PString $1 }
+  | '{' ListPattAss '}'       { PR $2 }
+  | '<' ListPattTupleComp '>' { (PR . tuple2recordPatt) $2 }
+  | '(' Patt ')'              { $2 }
+
+PattAss :: { [(Label,Patt)] }
+PattAss
+  : ListIdent '=' Patt { [(LIdent (ident2raw i),$3) | i <- $1] } 
+
+Label :: { Label }
+Label
+  : Ident       { LIdent (ident2raw $1)   } 
+  | '$' Integer { LVar (fromIntegral $2) }
+
+Sort :: { Ident }
+Sort
+  : 'Type'  { cType  } 
+  | 'PType' { cPType }
+  | 'Tok'   { cTok   }
+  | 'Str'   { cStr   }
+  | 'Strs'  { cStrs  }
+
+ListPattAss :: { [(Label,Patt)] }
+ListPattAss
+  : {- empty -}             { []       }
+  | PattAss                 { $1       }
+  | PattAss ';' ListPattAss { $1 ++ $3 }
+
+ListPatt :: { [Patt] }
+ListPatt
+  : PattArg          { [$1]    } 
+  | PattArg ListPatt { $1 : $2 }
+
+PattArg :: { Patt }
+  : Patt2         { $1                }
+  | '{' Patt '}'  { PImplArg $2       }
+
+Arg :: { [(BindType,Ident)] }
+Arg 
+  : Ident               { [(Explicit,$1    )]      }
+  | '_'                 { [(Explicit,identW)]      }
+  | '{' ListIdent2 '}'  { [(Implicit,v) | v <- $2] }
+  
+ListArg :: { [(BindType,Ident)] }
+ListArg
+  : Arg                 { $1       } 
+  | Arg ListArg         { $1 ++ $2 }
+
+Bind :: { [(BindType,Ident)] }
+Bind
+  : Ident               { [(Explicit,$1    )]      } 
+  | '_'                 { [(Explicit,identW)]      }
+  | '{' ListIdent '}'   { [(Implicit,v) | v <- $2] }
+
+ListBind :: { [(BindType,Ident)] }
+ListBind
+  : Bind                { $1       }
+  | Bind ',' ListBind   { $1 ++ $3 }
+
+Decl :: { [Hypo] }
+Decl
+  : '(' ListBind ':' Exp ')' { [(b,x,$4) | (b,x) <- $2] } 
+  | Exp3                     { [mkHypo $1]              }
+
+ListTupleComp :: { [Term] }
+ListTupleComp
+  : {- empty -}           { []      } 
+  | Exp                   { [$1]    }
+  | Exp ',' ListTupleComp { $1 : $3 }
+
+ListPattTupleComp :: { [Patt] }
+ListPattTupleComp
+  : {- empty -}                { []      } 
+  | Patt                       { [$1]    }
+  | Patt ',' ListPattTupleComp { $1 : $3 }
+
+Case :: { Case }
+Case
+  : Patt '=>' Exp { ($1,$3) } 
+
+ListCase :: { [Case] }
+ListCase
+  : Case              { [$1]    } 
+  | Case ';' ListCase { $1 : $3 }
+
+Altern :: { (Term,Term) }
+Altern
+  : Exp '/' Exp { ($1,$3) } 
+
+ListAltern :: { [(Term,Term)] }
+ListAltern
+  : Altern                { [$1]    }
+  | Altern ';' ListAltern { $1 : $3 }
+
+DDecl :: { [Hypo] }
+DDecl
+  : '(' ListBind ':' Exp ')' { [(b,x,$4) | (b,x) <- $2] } 
+  | Exp6                     { [mkHypo $1]              }
+
+ListDDecl :: { [Hypo] }
+ListDDecl
+  : {- empty -}     { []       } 
+  | DDecl ListDDecl { $1 ++ $2 }
+
+ListCFRule :: { [BNFCRule] }
+ListCFRule
+  : CFRule            { $1       }
+  | CFRule ListCFRule { $1 ++ $2 }
+
+CFRule :: { [BNFCRule] }
+CFRule
+  : Ident '.' Ident '::=' ListCFSymbol ';' { [BNFCRule (showIdent $3) $5 (CFObj (showIdent $1) [])]
+                                           }
+  | Ident '::=' ListCFRHS ';'              { let { cat = showIdent $1;
+                                                   mkFun cat its =
+                                                     case its of {
+                                                       [] -> cat ++ "_";
+                                                       _  -> concat $ intersperse "_" (cat : filter (not . null) (map clean its)) -- CLE style
+                                                     };
+                                                   clean sym = 
+                                                     case sym of {
+                                                       Terminal    c     -> filter isAlphaNum c;
+                                                       NonTerminal (t,_) -> t
+                                                     }
+                                             } in map (\rhs -> BNFCRule cat rhs (CFObj (mkFun cat rhs) [])) $3
+                                           }
+  | 'coercions' Ident Integer ';'          { [BNFCCoercions (showIdent $2) $3]}
+  | 'terminator' NonEmpty Ident String ';' { [BNFCTerminator $2 (showIdent $3) $4] }
+  | 'separator'  NonEmpty Ident String ';' { [BNFCSeparator $2 (showIdent $3) $4] }
+
+ListCFRHS :: { [[BNFCSymbol]] }
+ListCFRHS
+  : ListCFSymbol                { [$1]    }
+  | ListCFSymbol '|' ListCFRHS  { $1 : $3 }
+
+ListCFSymbol :: { [BNFCSymbol] }
+ListCFSymbol
+  : {- empty -}           { []      } 
+  | CFSymbol ListCFSymbol { $1 : $2 }
+
+CFSymbol :: { BNFCSymbol }
+  : String                { Terminal $1 }
+  | Ident                 { NonTerminal (showIdent $1, False) }
+  | '[' Ident ']'         { NonTerminal (showIdent $2, True)  }
+
+NonEmpty :: { Bool }
+NonEmpty : 'nonempty' { True }
+        | {-empty-}  { False }
+
+
+ListEBNFRule :: { [ERule] }
+ListEBNFRule
+  : EBNFRule              { [$1]    }
+  | EBNFRule ListEBNFRule { $1 : $2 }
+
+EBNFRule :: { ERule }
+  : Ident '::=' ERHS0 ';' { ((showIdent $1,[]),$3) }
+
+ERHS0 :: { ERHS }
+  : ERHS1                 { $1         }
+  | ERHS1 '|' ERHS0       { EAlt $1 $3 }
+
+ERHS1 :: { ERHS }
+  : ERHS2                 { $1         }
+  | ERHS2 ERHS1           { ESeq $1 $2 }
+
+ERHS2 :: { ERHS }
+  : ERHS3 '*'             { EStar $1 }
+  | ERHS3 '+'             { EPlus $1 }
+  | ERHS3 '?'             { EOpt $1  }
+  | ERHS3                 { $1       }
+
+ERHS3 :: { ERHS }
+  : String                { ETerm $1 }
+  | Ident                 { ENonTerm (showIdent $1,[]) }
+  | '(' ERHS0 ')'         { $2         }
+
+ModuleName :: { ModuleName }
+  : Ident           { MN $1 }
+
+Posn :: { Posn }
+Posn
+  : {- empty -}     {% getPosn } 
+
+
+{
+
+happyError :: P a
+happyError = fail "syntax error"
+
+mkListId,mkConsId,mkBaseId  :: Ident -> Ident
+mkListId = prefixIdent "List"
+mkConsId = prefixIdent "Cons"
+mkBaseId = prefixIdent "Base"
+
+listCatDef :: L (Ident, Context, Int) -> [(Ident,Info)]
+listCatDef (L loc (id,cont,size)) = [catd,nilfund,consfund]
+  where
+    listId = mkListId id
+    baseId = mkBaseId id
+    consId = mkConsId id
+
+    catd     = (listId, AbsCat (Just (L loc cont')))
+    nilfund  = (baseId, AbsFun (Just (L loc niltyp))  Nothing Nothing (Just True))
+    consfund = (consId, AbsFun (Just (L loc constyp)) Nothing Nothing (Just True))
+
+    cont' = [(b,mkId x i,ty) | (i,(b,x,ty)) <- zip [0..] cont]
+    xs = map (\(b,x,t) -> Vr x) cont'
+    cd = mkHypo (mkApp (Vr id) xs)
+    lc = mkApp (Vr listId) xs
+
+    niltyp  = mkProdSimple (cont' ++ replicate size cd) lc
+    constyp = mkProdSimple (cont' ++ [cd, mkHypo lc]) lc
+
+    mkId x i = if x == identW then (varX i) else x
+
+tryLoc (c,mty,Just e) = return (c,(mty,e))
+tryLoc (c,_  ,_     ) = fail ("local definition of" +++ showIdent c +++ "without value")
+
+mkR []       = return $ RecType [] --- empty record always interpreted as record type
+mkR fs@(f:_) =
+  case f of
+    (lab,Just ty,Nothing) -> mapM tryRT fs >>= return . RecType
+    _                     -> mapM tryR  fs >>= return . R
+  where
+    tryRT (lab,Just ty,Nothing) = return (ident2label lab,ty)
+    tryRT (lab,_      ,_      ) = fail $ "illegal record type field" +++ showIdent lab --- manifest fields ?!
+
+    tryR (lab,mty,Just t) = return (ident2label lab,(mty,t))
+    tryR (lab,_  ,_     ) = fail $ "illegal record field" +++ showIdent lab
+
+mkOverload pdt pdf@(Just (L loc df)) =
+  case appForm df of
+    (keyw, ts@(_:_)) | isOverloading keyw -> 
+       case last ts of
+         R fs -> [ResOverload [MN m | Vr m <- ts] [(L loc ty,L loc fu) | (_,(Just ty,fu)) <- fs]]
+         _    -> [ResOper pdt pdf]
+    _         -> [ResOper pdt pdf]
+
+     -- to enable separare type signature --- not type-checked
+mkOverload pdt@(Just (L _ df)) pdf =
+  case appForm df of
+    (keyw, ts@(_:_)) | isOverloading keyw ->
+       case last ts of
+         RecType _ -> [] 
+         _         -> [ResOper pdt pdf]
+    _              -> [ResOper pdt pdf]
+mkOverload pdt pdf = [ResOper pdt pdf]
+
+isOverloading t =
+  case t of
+    Vr keyw | showIdent keyw == "overload" -> True      -- overload is a "soft keyword"
+    _                                      -> False
+
+checkInfoType mt jment@(id,info) =
+  case info of
+    AbsCat pcont         -> ifAbstract mt (locPerh pcont)
+    AbsFun pty _ pde _   -> ifAbstract mt (locPerh pty ++ maybe [] locAll pde)
+    CncCat pty pd pr ppn _->ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh pr ++ locPerh ppn)
+    CncFun _   pd ppn _  -> ifConcrete mt (locPerh pd ++ locPerh ppn)
+    ResParam pparam _    -> ifResource mt (locPerh pparam)
+    ResValue ty _        -> ifResource mt (locL ty)
+    ResOper  pty pt      -> ifOper mt pty pt
+    ResOverload _ xs     -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs])
+  where
+    locPerh = maybe [] locL
+    locAll xs = [loc | L loc x <- xs]
+    locL (L loc x) = [loc]
+    
+    illegal (Local s e:_) = failLoc (Pn s 0) "illegal definition"
+    illegal _             = return jment
+
+    ifAbstract MTAbstract     locs = return jment
+    ifAbstract _              locs = illegal locs
+
+    ifConcrete (MTConcrete _) locs = return jment
+    ifConcrete _              locs = illegal locs
+
+    ifResource (MTConcrete _) locs = return jment
+    ifResource (MTInstance _) locs = return jment
+    ifResource MTInterface    locs = return jment
+    ifResource MTResource     locs = return jment
+    ifResource _              locs = illegal locs
+    
+    ifOper MTAbstract pty pt = return (id,AbsFun pty (fmap (const 0) pt) (Just (maybe [] (\(L l t) -> [L l ([],t)]) pt)) (Just False))
+    ifOper _          pty pt = return jment
+
+mkAlts cs = case cs of
+  _:_ -> do
+    def  <- mkDef (last cs)
+    alts <- mapM mkAlt (init cs)
+    return (Alts def alts)
+  _ -> fail "empty alts"
+ where
+   mkDef (_,t) = return t
+   mkAlt (p,t) = do
+     ss <- mkStrs p
+     return (t,ss)
+
+mkL :: Posn -> Posn -> x -> L x
+mkL (Pn l1 _) (Pn l2 _) x = L (Local l1 l2) x
+
+}

src/compiler/api/GF/Grammar/PatternMatch.hs

@@ -0,0 +1,183 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : PatternMatch
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/12 12:38:29 $
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.7 $
+--
+-- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003
+-----------------------------------------------------------------------------
+
+module GF.Grammar.PatternMatch (
+                                matchPattern,
+                                testOvershadow,
+                                findMatch
+                               ) where
+
+import GF.Data.Operations
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Grammar.Macros
+--import GF.Grammar.Printer
+
+import Data.Maybe(fromMaybe)
+import Control.Monad
+import GF.Text.Pretty
+--import Debug.Trace
+
+matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution)
+matchPattern pts term =
+  if not (isInConstantForm term)
+    then raise (render ("variables occur in" <+> pp term))
+  else do
+    term' <- mkK term
+    errIn (render ("trying patterns" <+> hsep (punctuate ',' (map fst pts)))) $
+      findMatch [([p],t) | (p,t) <- pts] [term']
+ where
+  -- to capture all Str with string pattern matching
+  mkK s = case s of
+    C _ _ -> do
+      s' <- getS s
+      return (K (unwords s'))
+    _ -> return s
+
+  getS s = case s of
+    K w -> return [w]
+    C v w -> liftM2 (++) (getS v) (getS w)
+    Empty -> return []
+    _ -> raise (render ("cannot get string from" <+> s))
+
+testOvershadow :: ErrorMonad m => [Patt] -> [Term] -> m [Patt]
+testOvershadow pts vs = do
+  let numpts = zip pts [0..]
+  let cases  = [(p,EInt i) | (p,i) <- numpts]
+  ts <- mapM (liftM fst . matchPattern cases) vs
+  return [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ]
+
+findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution)
+findMatch cases terms = case cases of
+   [] -> raise (render ("no applicable case for" <+> hsep (punctuate ',' terms)))
+   (patts,_):_ | length patts /= length terms ->
+       raise (render ("wrong number of args for patterns :" <+> hsep patts <+>
+                    "cannot take" <+> hsep terms))
+   (patts,val):cc -> case mapM tryMatch (zip patts terms) of
+       Ok substs -> return (val, concat substs)
+       _         -> findMatch cc terms
+
+tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
+tryMatch (p,t) = do
+  t' <- termForm t
+  trym p t'
+ where
+  trym p t' =
+    case (p,t') of
+--    (_,(x,Typed e ty,y)) -> trym p (x,e,y) -- Add this? /TH 2013-09-05
+      (_,(x,Empty,y)) -> trym p (x,K [],y)   -- because "" = [""] = []
+      (PW, _) -> return [] -- optimization with wildcard
+      (PV x,([],K s,[])) -> return [(x,words2term (words s))]
+      (PV x,  _) -> return [(x,t)]
+      (PString s, ([],K i,[])) | s==i -> return []
+      (PInt s, ([],EInt i,[])) | s==i -> return []
+      (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
+      (PC p pp, ([], Con f, tt)) |
+            p `eqStrIdent` f && length pp == length tt ->
+         do matches <- mapM tryMatch (zip pp tt)
+            return (concat matches)
+
+      (PP (q,p) pp, ([], QC (r,f), tt)) |
+            -- q `eqStrIdent` r &&  --- not for inherited AR 10/10/2005
+            p `eqStrIdent` f && length pp == length tt ->
+         do matches <- mapM tryMatch (zip pp tt)
+            return (concat matches)
+      ---- hack for AppPredef bug
+      (PP (q,p) pp, ([], Q (r,f), tt)) |
+            -- q `eqStrIdent` r && ---
+            p `eqStrIdent` f && length pp == length tt ->
+         do matches <- mapM tryMatch (zip pp tt)
+            return (concat matches)
+
+      (PR r, ([],R r',[])) |
+            all (`elem` map fst r') (map fst r) ->
+         do matches <- mapM tryMatch
+                            [(p,snd a) | (l,p) <- r, let Just a = lookup l r']
+            return (concat matches)
+      (PT _ p',_) -> trym p' t'
+
+      (PAs x p',([],K s,[])) -> do
+         subst <- trym p' t'
+         return $ (x,words2term (words s)) : subst
+
+      (PAs x p',_) -> do
+         subst <- trym p' t'
+         return $ (x,t) : subst
+
+      (PAlt p1 p2,_) -> checks [trym p1 t', trym p2 t']
+
+      (PNeg p',_) -> case tryMatch (p',t) of
+        Bad _ -> return []
+        _ -> raise (render ("no match with negative pattern" <+> p))
+
+      (PSeq min1 max1 p1 min2 max2 p2, ([],K s, [])) -> matchPSeq min1 max1 p1 min2 max2 p2 s
+
+      (PRep _ _ p1, ([],K s, [])) -> checks [
+         trym (foldr (const (PSeq 0 Nothing p1 0 Nothing)) (PString "")
+           [1..n]) t' | n <- [0 .. length s]
+        ] >>
+        return []
+
+      (PChar,  ([],K [_], [])) -> return []
+      (PChars cs, ([],K [c], [])) | elem c cs -> return []
+
+      _ -> raise (render ("no match in case expr for" <+> t))
+
+  words2term []     = Empty
+  words2term [w]    = K w
+  words2term (w:ws) = C (K w) (words2term ws)
+
+matchPSeq min1 max1 p1 min2 max2 p2 s =
+  do let n = length s
+         lo = min1 `max` (n-fromMaybe n max2)
+         hi = (n-min2) `min` (fromMaybe n max1)
+         cuts = [splitAt i s | i <- [lo..hi]]
+     matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts]
+     return (concat matches)
+
+isInConstantForm :: Term -> Bool
+isInConstantForm trm = case trm of
+    Cn _     -> True
+    Con _    -> True
+    Q _      -> True
+    QC _     -> True
+    Abs _ _ _ -> True
+    C c a    -> isInConstantForm c && isInConstantForm a
+    App c a  -> isInConstantForm c && isInConstantForm a
+    R r      -> all (isInConstantForm . snd . snd) r
+    K _      -> True
+    Empty    -> True
+    EInt _   -> True
+    V ty ts  -> isInConstantForm ty && all isInConstantForm ts -- TH 2013-09-05
+--  Typed e t-> isInConstantForm e && isInConstantForm t -- Add this? TH 2013-09-05
+
+    _       -> False ---- isInArgVarForm trm
+{- -- unused and suspicuous, see contP in GF.Compile.Compute.Concrete instead
+varsOfPatt :: Patt -> [Ident]
+varsOfPatt p = case p of
+  PV x -> [x]
+  PC _ ps -> concat $ map varsOfPatt ps
+  PP _ ps -> concat $ map varsOfPatt ps
+  PR r    -> concat $ map (varsOfPatt . snd) r
+  PT _ q -> varsOfPatt q
+  _ -> []
+
+-- | to search matching parameter combinations in tables
+isMatchingForms :: [Patt] -> [Term] -> Bool
+isMatchingForms ps ts = all match (zip ps ts') where
+  match (PC c cs, (Cn d, ds)) = c == d && isMatchingForms cs ds
+  match _ = True
+  ts' = map appForm ts
+
+-}

src/compiler/api/GF/Grammar/Predef.hs

@@ -0,0 +1,75 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.Grammar.Predef
+-- Maintainer  : kr.angelov
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- Predefined identifiers and labels which the compiler knows
+----------------------------------------------------------------------
+
+module GF.Grammar.Predef where
+
+import GF.Infra.Ident(Ident,identS,moduleNameS)
+
+cType = identS "Type"
+cPType = identS "PType"
+cTok = identS "Tok"
+cStr = identS "Str"
+cStrs = identS "Strs"
+cPredefAbs = moduleNameS "PredefAbs"
+cPredefCnc = moduleNameS "PredefCnc"
+cPredef = moduleNameS "Predef"
+cInt = identS "Int"
+cFloat = identS "Float"
+cString = identS "String"
+cInts = identS "Ints"
+cPBool = identS "PBool"
+cErrorType = identS "Error"
+cOverload = identS "overload"
+cNonExist = identS "nonExist"
+cBIND = identS "BIND"
+cSOFT_BIND = identS "SOFT_BIND"
+cSOFT_SPACE = identS "SOFT_SPACE"
+cCAPIT = identS "CAPIT"
+cALL_CAPIT = identS "ALL_CAPIT"
+
+isPredefCat :: Ident -> Bool
+isPredefCat c = elem c [cInt,cString,cFloat]
+
+cPTrue  = identS "PTrue"
+cPFalse = identS "PFalse"
+cLength = identS "length"
+cDrop = identS "drop"
+cTake = identS "take"
+cTk = identS "tk"
+cDp = identS "dp"
+cToUpper = identS "toUpper"
+cToLower = identS "toLower"
+cIsUpper = identS "isUpper"
+cEqStr = identS "eqStr"
+cEqVal = identS "eqVal"
+cOccur = identS "occur"
+cOccurs = identS "occurs"
+cEqInt = identS "eqInt"
+cLessInt = identS "lessInt"
+cPlus = identS "plus"
+cShow = identS "show"
+cRead = identS "read"
+cToStr = identS "toStr"
+cMapStr = identS "mapStr"
+cError = identS "error"
+
+-- * Hacks: dummy identifiers used in various places.
+-- Not very nice!
+
+cMeta = identS "?"
+cAs = identS "@"
+cChar = identS "?"
+cChars = identS "[]"
+cSeq = identS "+"
+cAlt = identS "|"
+cRep = identS "*"
+cNeg = identS "-"
+cCNC = identS "CNC"
+cConflict = identS "#conflict"

src/compiler/api/GF/Grammar/Printer.hs

@@ -0,0 +1,417 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.Grammar.Printer
+-- Maintainer  : Krasimir Angelov
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleContexts #-}
+module GF.Grammar.Printer
+           ( -- ** Pretty printing
+             TermPrintQual(..)
+           , ppModule
+           , ppJudgement
+           , ppParams
+           , ppTerm
+           , ppPatt
+           , ppValue
+           , ppConstrs
+           , ppQIdent
+           , ppMeta
+           , getAbs
+           ) where
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
+
+import PGF2(Literal(..))
+import PGF2.Transactions(SeqId)
+import GF.Infra.Ident
+import GF.Infra.Option
+import GF.Grammar.Values
+import GF.Grammar.Predef
+import GF.Grammar.Grammar
+
+import GF.Text.Pretty
+import Data.Maybe (isNothing)
+import Data.List  (intersperse)
+import Data.Foldable (toList)
+import qualified Data.Map as Map
+import qualified Data.Sequence as Seq
+import qualified GHC.Show
+
+data TermPrintQual
+  = Terse | Unqualified | Qualified | Internal
+  deriving Eq
+
+instance Pretty Grammar where
+  pp = vcat . map (ppModule Qualified) . modules
+
+ppModule :: TermPrintQual -> SourceModule -> Doc
+ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
+    hdr $$
+    nest 2 (ppOptions opts $$
+            vcat (map (ppJudgement q) (Map.toList jments)) $$
+            maybe empty (ppSequences q) mseqs) $$
+    ftr
+    where
+      hdr = complModDoc <+> modTypeDoc <+> '=' <+>
+            hsep (intersperse (pp "**") $
+                  filter (not . isEmpty)  $ [ commaPunct ppExtends exts
+                                            , maybe empty ppWith with
+                                            , if null opens
+                                                then pp '{'
+                                                else "open" <+> commaPunct ppOpenSpec opens <+> "in" <+> '{'
+                                            ])
+
+      ftr = '}'
+
+      complModDoc =
+        case mstat of
+          MSComplete   -> empty
+          MSIncomplete -> pp "incomplete"
+
+      modTypeDoc =
+        case mtype of
+          MTAbstract         -> "abstract"  <+> mn
+          MTResource         -> "resource"  <+> mn
+          MTConcrete abs     -> "concrete"  <+> mn <+> "of" <+> abs
+          MTInterface        -> "interface" <+> mn
+          MTInstance ie      -> "instance"  <+> mn <+> "of" <+> ppExtends ie
+
+      ppExtends (id,MIAll        ) = pp id
+      ppExtends (id,MIOnly   incs) = id         <+> brackets (commaPunct pp incs)
+      ppExtends (id,MIExcept incs) = id <+> '-' <+> brackets (commaPunct pp incs)
+
+      ppWith (id,ext,opens) = ppExtends (id,ext) <+> "with" <+> commaPunct ppInstSpec opens
+
+ppOptions opts =
+  "flags" $$
+  nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts])
+
+ppJudgement q (id, AbsCat pcont ) =
+  "cat" <+> id <+>
+  (case pcont of
+     Just (L _ cont) -> hsep (map (ppDecl q) cont)
+     Nothing         -> empty) <+> ';'
+ppJudgement q (id, AbsFun ptype _ pexp poper) =
+  let kind | isNothing pexp      = "data"
+           | poper == Just False = "oper"
+           | otherwise           = "fun"
+  in
+  (case ptype of
+     Just (L _ typ) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';'
+     Nothing        -> empty) $$
+  (case pexp of
+     Just []  -> empty
+     Just eqs -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs]
+     Nothing  -> empty)
+ppJudgement q (id, ResParam pparams _) =
+  "param" <+> id <+>
+  (case pparams of
+     Just (L _ ps) -> '=' <+> ppParams q ps
+     _             -> empty) <+> ';'
+ppJudgement q (id, ResValue pvalue idx) =
+  "-- param constructor" <+> id <+> ':' <+>
+  (case pvalue of
+     (L _ ty) -> ppTerm q 0 ty) <+> ';' <+> parens (pp "index = " <> pp idx)
+ppJudgement q (id, ResOper  ptype pexp) =
+  "oper" <+> id <+>
+  (case ptype of {Just (L _ t) -> ':'  <+> ppTerm q 0 t; Nothing -> empty} $$
+   case pexp  of {Just (L _ e) -> '=' <+> ppTerm q 0 e; Nothing -> empty}) <+> ';'
+ppJudgement q (id, ResOverload ids defs) =
+  "oper" <+> id <+> '=' <+>
+  ("overload" <+> '{' $$
+   nest 2 (vcat [id <+> (':' <+> ppTerm q 0 ty $$ '=' <+> ppTerm q 0 e <+> ';') | (L _ ty,L _ e) <- defs]) $$
+   '}') <+> ';'
+ppJudgement q (id, CncCat mtyp pdef pref pprn mpmcfg) =
+  (case mtyp of
+     Just (L _ typ) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';'
+     Nothing        -> empty) $$
+  (case pdef of
+     Just (L _ exp) -> "lindef" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
+     Nothing        -> empty) $$
+  (case pref of
+     Just (L _ exp) -> "linref" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
+     Nothing        -> empty) $$
+  (case pprn of
+     Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
+     Nothing        -> empty) $$
+  (case (mtyp,mpmcfg,q) of
+     (Just (L _ typ),Just (lindefs,linrefs),Internal)
+                    -> "pmcfg" <+> '{' $$
+                       nest 2 (vcat (map (ppPmcfgRule (identS "lindef") [cString] id) lindefs)  $$
+                               vcat (map (ppPmcfgRule (identS "linref") [id] cString) linrefs)) $$
+                       '}'
+     _              -> empty)
+ppJudgement q (id, CncFun mtyp pdef pprn mpmcfg) =
+  (case pdef of
+     Just (L _ e) -> let (xs,e') = getAbs e
+                     in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';'
+     Nothing      -> empty) $$
+  (case pprn of
+     Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
+     Nothing        -> empty) $$
+  (case (mtyp,mpmcfg,q) of
+     (Just (args,res,_,_),Just rules,Internal)
+                    -> "pmcfg" <+> '{' $$
+                       nest 2 (vcat (map (ppPmcfgRule id args res) rules)) $$
+                       '}'
+     _              -> empty)
+ppJudgement q (id, AnyInd cann mid) =
+  case q of
+    Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
+    _        -> empty
+
+ppPmcfgRule id arg_cats res_cat (Production vars args res seqids) =
+  pp id <+> (':' <+>
+             (if null vars
+                then empty
+                else "∀{" <> hsep (punctuate ',' [ppLVar v <> '<' <> m | (v,m) <- vars]) <> '}'  <+> '.') <+>
+             ppPmcfgCat res_cat res <+> "->" <+>
+             brackets (hcat (intersperse (pp ',') (zipWith ppPArg arg_cats args))) <+> '=' <+> 
+             brackets (hcat (intersperse (pp ',') (map ppSeqId seqids))))
+
+ppPArg cat (PArg _ p) = ppPmcfgCat cat p
+
+ppPmcfgCat :: Ident -> LParam -> Doc
+ppPmcfgCat cat p = pp cat <> parens (ppLParam p)
+
+instance Pretty Term where pp = ppTerm Unqualified 0
+
+ppTerm q d (Abs b v e)   = let (xs,e') = getAbs (Abs b v e)
+                           in prec d 0 ('\\' <> commaPunct ppBind xs <+> "->" <+> ppTerm q 0 e')
+ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of
+                           ([],_) -> "table" <+> '{' $$
+                                       nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+                                     '}'
+                           (vs,e) -> prec d 0 ("\\\\" <> commaPunct pp vs <+> "=>" <+> ppTerm q 0 e)
+ppTerm q d (T (TTyped t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
+                                 nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+                                '}'
+ppTerm q d (T (TComp  t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
+                                 nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+                               '}'
+ppTerm q d (T (TWild  t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
+                                 nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+                                '}'
+ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit
+                              then prec d 0 (ppTerm q 4 a <+> "->" <+> ppTerm q 0 b)
+                              else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppTerm q 0 a) <+> "->" <+> ppTerm q 0 b)
+ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> "=>" <+> ppTerm q 0 vt)
+ppTerm q d (Let l e)    = let (ls,e') = getLet e
+                          in prec d 0 ("let" <+> vcat (map (ppLocDef q) (l:ls)) $$ "in" <+> ppTerm q 0 e')
+ppTerm q d (Example e s)=prec d 0 ("in" <+> ppTerm q 5 e <+> str s)
+ppTerm q d (C e1 e2)    =prec d 1 (hang (ppTerm q 2 e1) 2 ("++" <+> ppTerm q 1 e2))
+ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> '+'  <+> ppTerm q 2 e2)
+ppTerm q d (S x y)     = case x of
+                           T annot xs -> let e = case annot of
+                                                   TRaw     -> y
+                                                   TTyped t -> Typed y t
+                                                   TComp  t -> Typed y t
+                                                   TWild  t -> Typed y t
+                                         in "case" <+> ppTerm q 0 e <+>"of" <+> '{' $$
+                                            nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+                                           '}'
+                           _          -> prec d 3 (hang (ppTerm q 3 x) 2 ("!" <+> ppTerm q 4 y))
+ppTerm q d (ExtR x y)  = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y)
+ppTerm q d (App x y)   = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)
+ppTerm q d (V e es)    = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
+ppTerm q d (FV es)     = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))))
+ppTerm q d (AdHocOverload es)     = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
+ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
+ppTerm q d (Strs es)   = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
+ppTerm q d (EPatt _ _ p)=prec d 4 ('#' <+> ppPatt q 2 p)
+ppTerm q d (EPattType t)=prec d 4 ("pattern" <+> ppTerm q 0 t)
+ppTerm q d (P t l)     = prec d 5 (ppTerm q 5 t <> '.' <> l)
+ppTerm q d (Cn id)     = pp id
+ppTerm q d (Vr id)     = pp id
+ppTerm q d (Q  id)     = ppQIdent q id
+ppTerm q d (QC id)     = ppQIdent q id
+ppTerm q d (Sort id)   = pp id
+ppTerm q d (K s)       = str s
+ppTerm q d (EInt n)    = pp n
+ppTerm q d (EFloat f)  = pp f
+ppTerm q d (Meta i)    = ppMeta i
+ppTerm q d (Empty)     = pp "[]"
+ppTerm q d (R [])      = pp "<>" -- to distinguish from {} empty RecType
+ppTerm q d (R xs)      = braces (fsep (punctuate ';' [l <+>
+                                                       fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty},
+                                                             '=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))
+ppTerm q d (RecType xs)
+  | q == Terse         = case [cat | (l,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of
+                           [cat] -> pp cat
+                           _     -> doc
+  | otherwise          = doc
+  where
+    doc = braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs]))
+ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
+ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
+ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)
+ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t)
+ppTerm q d (TSymCat i r rs) = pp '<' <> pp i <> pp ',' <> ppLinFun (pp.fst) r rs <> pp '>'
+ppTerm q d (TSymVar i r) = pp '<' <> pp i <> pp ',' <> pp '$' <> pp r <> pp '>'
+
+ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e
+
+ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
+
+instance Pretty Patt where pp = ppPatt Unqualified 0
+
+ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '|' <+> ppPatt q 1 p2)
+ppPatt q d (PSeq _ _ p1 _ _ p2) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
+ppPatt q d (PC f ps)    = if null ps
+                            then pp f
+                            else prec d 1 (f <+> hsep (map (ppPatt q 3) ps))
+ppPatt q d (PP f ps)    = if null ps
+                            then ppQIdent q f
+                            else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps))
+ppPatt q d (PRep _ _ p) = prec d 1 (ppPatt q 3 p <> '*')
+ppPatt q d (PAs f p)    = prec d 2 (f <> '@' <> ppPatt q 3 p)
+ppPatt q d (PNeg p)     = prec d 2 ('-' <> ppPatt q 3 p)
+ppPatt q d (PChar)      = pp '?'
+ppPatt q d (PChars s)   = brackets (str s)
+ppPatt q d (PMacro id)  = '#' <> id
+ppPatt q d (PM id)      = '#' <> ppQIdent q id
+ppPatt q d PW           = pp '_'
+ppPatt q d (PV id)      = pp id
+ppPatt q d (PInt n)     = pp n
+ppPatt q d (PFloat f)   = pp f
+ppPatt q d (PString s)  = str s
+ppPatt q d (PR xs)      = braces (hsep (punctuate ';' [l <+> '=' <+> ppPatt q 0 e | (l,e) <- xs]))
+ppPatt q d (PImplArg p) = braces (ppPatt q 0 p)
+ppPatt q d (PTilde t)   = prec d 2 ('~' <> ppTerm q 6 t)
+
+ppValue :: TermPrintQual -> Int -> Val -> Doc
+ppValue q d (VGen i x)    = x <> "{-" <> i <> "-}" ---- latter part for debugging
+ppValue q d (VApp u v)    = prec d 4 (ppValue q 4 u <+> ppValue q 5 v)
+ppValue q d (VCn (_,c))   = pp c
+ppValue q d (VClos env e) = case e of
+                              Meta _ -> ppTerm q d e <> ppEnv env
+                              _      -> ppTerm q d e ---- ++ prEnv env ---- for debugging
+ppValue q d (VRecType xs) = braces (hsep (punctuate ',' [l <> '=' <> ppValue q 0 v | (l,v) <- xs]))
+ppValue q d VType         = pp "Type"
+
+ppConstrs :: Constraints -> [Doc]
+ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue Unqualified 0 w))
+
+ppEnv :: Env -> Doc
+ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e)
+
+str s = doubleQuotes (pp (foldr showLitChar "" s))
+  where
+    showLitChar c
+      | c == '"'    = showString "\\\""
+      | c > '\DEL'  = showChar c
+      | otherwise   = GHC.Show.showLitChar c
+
+ppDecl q (_,id,typ)
+  | id == identW = ppTerm q 3 typ
+  | otherwise    = parens (id <+> ':' <+> ppTerm q 0 typ)
+
+ppDDecl q (_,id,typ)
+  | id == identW = ppTerm q 6 typ
+  | otherwise    = parens (id <+> ':' <+> ppTerm q 0 typ)
+
+ppQIdent :: TermPrintQual -> QIdent -> Doc
+ppQIdent q (m,id) =
+  case q of
+    Terse       ->          pp id
+    Unqualified ->          pp id
+    Qualified   -> m <> '.' <> id
+    Internal    -> m <> '.' <> id
+
+
+instance Pretty Label where pp = pp . label2ident
+
+ppOpenSpec (OSimple id)   = pp id
+ppOpenSpec (OQualif id n) = parens (id <+> '=' <+> n)
+
+ppInstSpec (id,n) = parens (id <+> '=' <+> n)
+
+ppLocDef q (id, (mbt, e)) =
+  id <+>
+  (case mbt of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty} <+> '=' <+> ppTerm q 0 e) <+> ';'
+
+ppBind (Explicit,v) = pp v
+ppBind (Implicit,v) = braces v
+
+ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
+
+ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))
+ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
+
+ppSeqId :: SeqId -> Doc
+ppSeqId seqid = 'S' <> pp seqid
+
+ppSequences q seqs
+  | Seq.null seqs || q /= Internal = empty
+  | otherwise                      = "sequences" <+> '{' $$
+                                     nest 2 (vcat (zipWith ppSeq [0..] (toList seqs))) $$
+                                    '}'
+  where
+    ppSeq seqid seq =
+      ppSeqId seqid <+> ":=" <+> hsep (map ppSymbol seq)
+
+commaPunct f ds = (hcat (punctuate "," (map f ds)))
+
+prec d1 d2 doc
+  | d1 > d2   = parens doc
+  | otherwise = doc
+
+getAbs :: Term -> ([(BindType,Ident)], Term)
+getAbs (Abs bt v e) = let (xs,e') = getAbs e
+                      in ((bt,v):xs,e')
+getAbs e            = ([],e)
+
+getCTable :: Term -> ([Ident], Term)
+getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e
+                                in (v:vs,e')
+getCTable (T TRaw [(PW,  e)]) = let (vs,e') = getCTable e
+                                in (identW:vs,e')
+getCTable e                   = ([],e)
+
+getLet :: Term -> ([LocalDef], Term)
+getLet (Let l e) = let (ls,e') = getLet e
+                   in (l:ls,e')
+getLet e         = ([],e)
+
+ppMeta :: Int -> Doc
+ppMeta n
+  | n == 0    = pp '?'
+  | otherwise = pp '?' <> pp n
+
+ppLit (LStr s) = pp (show s)
+ppLit (LInt n) = pp n
+ppLit (LFlt d) = pp d
+
+ppSymbol (SymCat d r)= pp '<' <> pp d <> pp ',' <> ppLParam r <> pp '>'
+ppSymbol (SymLit d r)= pp '{' <> pp d <> pp ',' <> ppLParam r <> pp '}'
+ppSymbol (SymVar d r)   = pp '<' <> pp d <> pp ',' <> pp '$' <> pp r <> pp '>'
+ppSymbol (SymKS t)      = doubleQuotes (pp t)
+ppSymbol SymNE          = pp "nonExist"
+ppSymbol SymBIND        = pp "BIND"
+ppSymbol SymSOFT_BIND   = pp "SOFT_BIND"
+ppSymbol SymSOFT_SPACE  = pp "SOFT_SPACE"
+ppSymbol SymCAPIT       = pp "CAPIT"
+ppSymbol SymALL_CAPIT   = pp "ALL_CAPIT"
+ppSymbol (SymKP syms alts) = pp "pre" <+> braces (hsep (punctuate (pp ';') (hsep (map ppSymbol syms) : map ppAlt alts)))
+
+ppLParam (LParam r rs) = ppLinFun ppLVar r rs
+
+ppLinFun ppParam r rs
+  | r == 0 && not (null rs) = hcat (intersperse (pp '+') (       map ppTerm rs))
+  | otherwise               = hcat (intersperse (pp '+') (pp r : map ppTerm rs))
+  where
+    ppTerm (i,p)
+      | i == 1    = ppParam p
+      | otherwise = pp i <> pp '*' <> ppParam p
+
+ppLVar p
+  | i == 0    = pp (chars !! j)
+  | otherwise = pp (chars !! j : show i)
+  where
+    chars = "ijklmnopqr"
+    (i,j) = p `divMod` (length chars)
+
+ppAlt (syms,ps) = hsep (map ppSymbol syms) <+> pp '/' <+> hsep (map (doubleQuotes . pp) ps)

src/compiler/api/GF/Grammar/ShowTerm.hs

@@ -0,0 +1,44 @@
+module GF.Grammar.ShowTerm where
+
+import GF.Grammar.Grammar
+import GF.Grammar.Printer
+import GF.Grammar.Lookup
+import GF.Data.Operations
+
+import GF.Text.Pretty
+import Data.List  (intersperse)
+
+showTerm :: SourceGrammar -> TermPrintStyle -> TermPrintQual -> Term -> String
+showTerm gr sty q t = case sty of
+    TermPrintTable -> render $ vcat [p <+> s | (p,s) <- ppTermTabular gr q t]
+    TermPrintAll   -> render $ vcat [      s | (p,s) <- ppTermTabular gr q t]
+    TermPrintList  -> renderStyle (style{mode = OneLineMode}) $ 
+      vcat (punctuate ',' [s | (p,s) <- ppTermTabular gr q t])
+    TermPrintOne   -> render $ vcat [      s | (p,s) <- take 1 (ppTermTabular gr q t)]
+    TermPrintDefault -> render $ ppTerm q 0 t
+
+ppTermTabular :: SourceGrammar -> TermPrintQual -> Term -> [(Doc,Doc)]
+ppTermTabular gr q = pr where
+  pr t = case t of
+    R rs   -> 
+      [(lab       <+> '.' <+> path, str) | (lab,(_,val)) <- rs, (path,str) <- pr val]
+    T _ cs -> 
+      [(ppPatt q 0 patt     <+> "=>" <+> path, str) | (patt,  val ) <- cs, (path,str) <- pr val]
+    V ty cs -> 
+      let pvals = case allParamValues gr ty of
+                    Ok pvals -> pvals
+                    Bad _    -> map Meta [1..]
+      in [(ppTerm q 0 pval <+> "=>" <+> path, str) | (pval, val) <- zip pvals cs, (path,str) <- pr val]
+    _      -> [(empty,ps t)]
+  ps t = case t of
+    K s   -> pp s
+    C s u -> ps s <+> ps u
+    FV ts -> hsep (intersperse (pp '/') (map ps ts))
+    _     -> ppTerm q 0 t
+
+data TermPrintStyle
+  = TermPrintTable
+  | TermPrintAll
+  | TermPrintList
+  | TermPrintOne
+  | TermPrintDefault

src/compiler/api/GF/Grammar/Unify.hs

@@ -0,0 +1,115 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Unify
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:22:31 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.4 $
+--
+-- (c) Petri Mäenpää & Aarne Ranta, 1998--2001
+--
+-- brute-force adaptation of the old-GF program AR 21\/12\/2001 ---
+-- the only use is in 'TypeCheck.splitConstraints'
+-----------------------------------------------------------------------------
+
+module GF.Grammar.Unify (unifyVal) where
+
+import GF.Grammar
+import GF.Data.Operations
+
+import GF.Text.Pretty
+import Data.List (partition)
+
+unifyVal :: Constraints -> Err (Constraints,MetaSubst)
+unifyVal cs0 = do
+  let (cs1,cs2) = partition notSolvable cs0 
+  let (us,vs) = unzip cs2
+  let us' = map val2term us
+  let vs' = map val2term vs
+  let (ms,cs) = unifyAll (zip us' vs') []
+  return (cs1 ++ [(VClos [] t, VClos [] u) | (t,u) <- cs], 
+          [(m,          VClos [] t) | (m,t) <- ms])
+ where
+   notSolvable (v,w) = case (v,w) of -- don't consider nonempty closures
+     (VClos (_:_) _,_) -> True
+     (_,VClos (_:_) _) -> True
+     _ -> False
+
+type Unifier = [(MetaId, Term)]
+type Constrs = [(Term, Term)]
+
+unifyAll :: Constrs -> Unifier -> (Unifier,Constrs)
+unifyAll [] g = (g, [])
+unifyAll ((a@(s, t)) : l) g =
+  let (g1, c) = unifyAll l g
+  in case unify s t g1 of
+       Ok g2  -> (g2, c)
+       _      -> (g1, a : c)
+
+unify :: Term -> Term -> Unifier -> Err Unifier
+unify e1 e2 g = 
+ case (e1, e2) of 
+  (Meta s, t) -> do
+     tg <- subst_all g t
+     let sg = maybe e1 id (lookup s g)
+     if (sg == Meta s) then extend g s tg else unify sg tg g 
+  (t, Meta s) -> unify e2 e1 g
+  (Q (_,a), Q (_,b)) | (a == b)  -> return g ---- qualif?
+  (QC (_,a), QC (_,b)) | (a == b)-> return g ----
+  (Vr x, Vr y) | (x == y)        -> return g 
+  (Abs _ x b, Abs _ y c)         -> do let c' = substTerm [x] [(y,Vr x)] c 
+                                       unify b c' g
+  (App c a, App d b)            -> case unify c d g of 
+                                     Ok g1 -> unify a b g1 
+                                     _     -> Bad (render ("fail unify" <+> ppTerm Unqualified 0 e1))
+  (RecType xs,RecType ys) | xs == ys -> return g
+  _                             -> Bad (render ("fail unify" <+> ppTerm Unqualified 0 e1))
+
+extend :: Unifier -> MetaId -> Term -> Err Unifier
+extend g s t | (t == Meta s) = return g  
+             | occCheck s t  = Bad (render ("occurs check" <+> ppTerm Unqualified 0 t))
+             | True          = return ((s, t) : g) 
+
+subst_all :: Unifier -> Term -> Err Term
+subst_all s u =
+ case (s,u) of
+  ([], t)  -> return t
+  (a : l, t) -> do
+     t' <- (subst_all l t) --- successive substs - why ?
+     return $ substMetas [a] t'
+
+substMetas :: [(MetaId,Term)] -> Term -> Term
+substMetas subst trm = case trm of
+   Meta x -> case lookup x subst of
+     Just t -> t
+     _ -> trm
+   _ -> composSafeOp (substMetas subst) trm
+
+substTerm  :: [Ident] -> Substitution -> Term -> Term
+substTerm ss g c = case c of
+  Vr x        -> maybe c id $ lookup x g
+  App f a     -> App (substTerm ss g f) (substTerm ss g a)
+  Abs b x t   -> let y = mkFreshVarX ss x in 
+                   Abs b y (substTerm (y:ss) ((x, Vr y):g) t)
+  Prod b x a t  -> let y = mkFreshVarX ss x in 
+                   Prod b y (substTerm ss g a) (substTerm (y:ss) ((x,Vr y):g) t)
+  _           -> c
+
+occCheck :: MetaId -> Term -> Bool
+occCheck s u = case u of
+    Meta v  -> s == v
+    App c a -> occCheck s c || occCheck s a
+    Abs _ x b -> occCheck s b
+    _       -> False
+
+val2term :: Val -> Term
+val2term v = case v of
+  VClos g e   -> substTerm [] (map (\(x,v) -> (x,val2term v)) g) e
+  VApp f c    -> App (val2term f) (val2term c)
+  VCn c       -> Q c
+  VGen i x    -> Vr x
+  VRecType xs -> RecType (map (\(l,v) -> (l,val2term v)) xs)
+  VType       -> typeType

src/compiler/api/GF/Grammar/Values.hs

@@ -0,0 +1,57 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Values
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:22:32 $
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.7 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Grammar.Values (
+               -- ** Values used in TC type checking
+               Val(..), Env,
+               -- ** Annotated tree used in editing
+               Binds, Constraints, MetaSubst,
+               -- ** For TC
+               valAbsInt, valAbsFloat, valAbsString, vType,
+               isPredefCat,
+               eType,
+              ) where
+
+import GF.Infra.Ident
+import GF.Grammar.Grammar
+import GF.Grammar.Predef
+
+-- values used in TC type checking
+
+data Val = VGen Int Ident | VApp Val Val | VCn QIdent | VRecType [(Label,Val)] | VType | VClos Env Term
+  deriving (Eq,Show)
+
+type Env = [(Ident,Val)]
+
+type Binds = [(Ident,Val)]
+type Constraints = [(Val,Val)]
+type MetaSubst = [(MetaId,Val)]
+
+
+-- for TC
+
+valAbsInt :: Val
+valAbsInt = VCn (cPredefAbs, cInt)
+
+valAbsFloat :: Val
+valAbsFloat = VCn (cPredefAbs, cFloat)
+
+valAbsString :: Val
+valAbsString = VCn (cPredefAbs, cString)
+
+vType :: Val
+vType = VType
+
+eType :: Term
+eType = Sort cType

src/compiler/api/GF/Haskell.hs

@@ -0,0 +1,151 @@
+-- | Abstract syntax and a pretty printer for a subset of Haskell
+{-# LANGUAGE DeriveFunctor #-}
+module GF.Haskell where
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
+import GF.Infra.Ident(Ident,identS)
+import GF.Text.Pretty
+
+-- | Top-level declarations
+data Dec = Comment String
+         | Type (ConAp Ident) Ty
+         | Data (ConAp Ident) [ConAp Ty] Deriving
+         | Class [ConAp Ident] (ConAp Ident) FunDeps [(Ident,Ty)]
+         | Instance [Ty] Ty [(Lhs,Exp)]
+         | TypeSig Ident Ty
+         | Eqn Lhs Exp
+
+-- | A type constructor applied to some arguments
+data ConAp a = ConAp Ident [a] deriving Functor
+conap0 n = ConAp n []
+tsyn0 = Type . conap0
+
+type Deriving = [Const]
+type FunDeps = [([Ident],[Ident])]
+type Lhs = (Ident,[Pat])
+lhs0 s = (identS s,[])
+
+-- | Type expressions
+data Ty  = TId Ident | TAp Ty Ty | Fun Ty Ty | ListT Ty
+
+-- | Expressions
+data Exp = Var Ident | Const Const | Ap Exp Exp | Op Exp Const Exp
+         | List [Exp] | Pair Exp Exp
+         | Lets [(Ident,Exp)] Exp | LambdaCase [(Pat,Exp)]
+type Const = String
+
+-- | Patterns
+data Pat = WildP | VarP Ident | Lit String | ConP Ident [Pat] | AsP Ident Pat
+
+tvar = TId
+tcon0 = TId
+tcon c = foldl TAp (TId c)
+
+lets [] e = e
+lets ds e = Lets ds e
+
+let1 x xe e = Lets [(x,xe)] e
+single x = List [x]
+
+plusplus (List ts1) (List ts2) = List (ts1++ts2)
+plusplus (List [t]) t2 = Op t ":" t2
+plusplus t1 t2 = Op t1 "++" t2
+
+-- | Pretty print atomically (i.e. wrap it in parentheses if necessary)
+class Pretty a => PPA a where ppA :: a -> Doc
+
+instance PPA Ident where ppA = pp
+
+instance Pretty Dec where
+  ppList = vcat
+  pp d =
+    case d of
+      Comment s -> pp s
+      Type lhs rhs -> hang ("type"<+>lhs<+>"=") 4 rhs
+      Data lhs cons ds ->
+        hang ("data"<+>lhs) 4
+             (sep (zipWith (<+>) ("=":repeat "|") cons++
+                  ["deriving"<+>parens (punctuate "," ds)|not (null ds)]))
+      Class ctx cls fds sigs ->
+        hang ("class"<+>sep [ppctx ctx,pp cls]<+>ppfds fds <+>"where") 4
+             (vcat (map ppSig sigs))
+      Instance ctx inst eqns ->
+        hang ("instance"<+>sep [ppctx ctx,pp inst]<+>"where") 4
+             (vcat (map ppEqn eqns))
+      TypeSig f ty -> hang (f<+>"::") 4 ty
+      Eqn lhs rhs -> ppEqn (lhs,rhs)
+    where
+      ppctx ctx = case ctx of
+                    [] -> empty
+                    [p] -> p <+> "=>"
+                    ps -> parens (fsep (punctuate "," ps)) <+> "=>"
+
+      ppfds [] = empty
+      ppfds fds = "|"<+>fsep (punctuate "," [hsep as<+>"->"<+>bs|(as,bs)<-fds])
+
+      ppEqn ((f,ps),e) = hang (f<+>fsep (map ppA ps)<+>"=") 4 e
+
+      ppSig (f,ty) = f<+>"::"<+>ty
+
+instance PPA a => Pretty (ConAp a) where
+  pp (ConAp c as) = c<+>fsep (map ppA as)
+
+instance Pretty Ty where
+  pp = ppT
+    where
+      ppT t = case flatFun t of t:ts -> sep (ppB t:["->"<+>ppB t|t<-ts])
+      ppB t = case flatTAp t of t:ts -> ppA t<+>sep (map ppA ts)
+
+      flatFun (Fun t1 t2) = t1:flatFun t2 -- right associative
+      flatFun t = [t]
+
+      flatTAp (TAp t1 t2) = flatTAp t1++[t2] -- left associative
+      flatTAp t = [t]
+
+instance PPA Ty where
+  ppA t =
+    case t of
+      TId c -> pp c
+      ListT t -> brackets t
+      _ -> parens t
+
+instance Pretty Exp where
+  pp = ppT
+    where
+      ppT e =
+        case e of
+          Op e1 op e2 -> hang (ppB e1<+>op) 2 (ppB e2)
+          Lets bs e -> sep ["let"<+>vcat [hang (x<+>"=") 2 xe|(x,xe)<-bs],
+                            "in" <+>e]
+          LambdaCase alts ->
+              hang "\\case" 2 (vcat [hang (p<+>"->") 2 e|(p,e)<-alts])
+          _ -> ppB e
+
+      ppB e = case flatAp e of f:as -> hang (ppA f) 2 (sep (map ppA as))
+
+      flatAp (Ap t1 t2) = flatAp t1++[t2] -- left associative
+      flatAp t = [t]
+
+instance PPA Exp where
+  ppA e =
+    case e of
+      Var x -> pp x
+      Const n -> pp n
+      Pair e1 e2 -> parens (e1<>","<>e2)
+      List es -> brackets (fsep (punctuate "," es))
+      _ -> parens e
+
+instance Pretty Pat where
+  pp p =
+    case p of
+      ConP c ps -> c<+>fsep (map ppA ps)
+      _ -> ppA p
+
+instance PPA Pat where
+  ppA p =
+    case p of
+      WildP -> pp "_"
+      VarP x -> pp x
+      Lit s -> pp s
+      ConP c [] -> pp c
+      AsP x p -> x<>"@"<>ppA p
+      _ -> parens p

src/compiler/api/GF/Infra/BuildInfo.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE CPP #-}
+module GF.Infra.BuildInfo where
+import System.Info
+import Data.Version(showVersion)
+
+{-# NOINLINE buildInfo #-}
+buildInfo =
+    "Built on "++os++"/"++arch
+    ++" with "++compilerName++"-"++showVersion compilerVersion
+    ++", flags:"
+#ifdef USE_INTERRUPT
+    ++" interrupt"
+#endif
+#ifdef SERVER_MODE
+    ++" server"
+#endif

src/compiler/api/GF/Infra/CheckM.hs

@@ -0,0 +1,145 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : CheckM
+-- Maintainer  : (Maintainer)
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:22:33 $
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.5 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Infra.CheckM
+          (Check(..), CheckResult(..), Message, runCheck, runCheck',
+           checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
+           checkIn, checkInModule, checkMap, checkMapRecover,
+           accumulateError, commitCheck,
+          ) where
+
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
+import GF.Data.Operations
+--import GF.Infra.Ident
+--import GF.Grammar.Grammar(msrc) -- ,Context
+import GF.Infra.Location(ppLocation,sourcePath)
+import GF.Infra.Option(Options,noOptions,verbAtLeast,Verbosity(..))
+
+import qualified Data.Map as Map
+import GF.Text.Pretty
+import System.FilePath(makeRelative)
+import Control.Parallel.Strategies(parList,rseq,using)
+import Control.Monad(liftM,ap)
+import Control.Applicative(Applicative(..))
+import qualified Control.Monad.Fail as Fail
+
+type Message = Doc
+type Error   = Message
+type Warning = Message
+type NonFatal = ([Error],[Warning])
+data CheckResult a b = Fail Error b | Success a b
+newtype Check a
+  = Check {unCheck :: NonFatal -> CheckResult a NonFatal}
+
+instance Functor Check where fmap = liftM
+
+instance Monad Check where
+  return x = Check $ \msgs -> Success x msgs
+  f >>= g  = Check $ \ws ->
+               case unCheck f ws of
+                 Success x msgs -> unCheck (g x) msgs
+                 Fail msg msgs  -> Fail msg msgs
+
+instance Fail.MonadFail Check where
+  fail = raise
+
+instance Applicative Check where
+  pure = return
+  (<*>) = ap
+
+instance ErrorMonad Check where
+  raise s = checkError (pp s)
+  handle f h = handle' f (h . render)
+
+handle' f h = Check (\msgs -> case unCheck f {-ctxt-} msgs of
+                                Success x msgs -> Success x msgs
+                                Fail msg msgs  -> unCheck (h msg) msgs)
+
+-- | Report a fatal error
+checkError :: Message -> Check a
+checkError msg = Check (\msgs -> Fail msg msgs)
+
+checkCond :: Message -> Bool -> Check ()
+checkCond s b = if b then return () else checkError s
+
+-- | warnings should be reversed in the end
+checkWarn :: Message -> Check ()
+checkWarn msg = Check $ \(es,ws) -> Success () (es,("Warning:" <+> msg) : ws)
+
+checkWarnings ms = mapM_ checkWarn ms
+
+-- | Report a nonfatal (accumulated) error
+checkAccumError :: Message -> Check ()
+checkAccumError msg = Check $ \(es,ws) -> Success () (msg:es,ws)
+
+-- | Turn a fatal error into a nonfatal (accumulated) error
+accumulateError :: (a -> Check a) -> a -> Check a
+accumulateError chk a =
+    handle' (chk a) $ \ msg -> do checkAccumError msg; return a
+
+-- |  Turn accumulated errors into a fatal error
+commitCheck :: Check a -> Check a
+commitCheck c =
+    Check $ \msgs0@(es0,ws0) ->
+    case unCheck c ([],[]) of
+      (Success v ([],ws)) -> Success v (es0,ws++ws0)
+      (Success _ msgs)    -> bad msgs0 msgs
+      (Fail    e (es,ws)) -> bad msgs0 ((e:es),ws)
+  where
+    bad (es0,ws0) (es,ws) = (Fail (list es) (es0,ws++ws0))
+    list = vcat . reverse
+
+-- | Run an error check, report errors and warnings
+runCheck c = runCheck' noOptions c
+
+-- | Run an error check, report errors and (optionally) warnings
+runCheck' :: ErrorMonad m => Options -> Check a -> m (a,String)
+runCheck' opts c =
+    case unCheck c ([],[]) of
+      Success v ([],ws) -> return (v,render (wlist ws))
+      Success v msgs    -> bad msgs
+      Fail    e (es,ws) -> bad ((e:es),ws)
+  where
+    bad (es,ws) = raise (render $ wlist ws $$ list es)
+    list = vcat . reverse
+    wlist ws = if verbAtLeast opts Normal then list ws else empty
+
+checkMap :: (Ord a) => (a -> b -> Check b) -> Map.Map a b -> Check (Map.Map a b)
+checkMap f map = do xs <- mapM (\(k,v) -> do v <- f k v
+                                             return (k,v)) (Map.toList map)
+                    return (Map.fromAscList xs)
+
+checkMapRecover :: (Ord a) => (a -> b -> Check b) -> Map.Map a b -> Check (Map.Map a b)
+checkMapRecover f = fmap Map.fromList . mapM f' . Map.toList
+  where f' (k,v) = fmap ((,)k) (f k v)
+
+checkIn :: Doc -> Check a -> Check a
+checkIn msg c = Check $ \msgs0 ->
+    case unCheck c ([],[]) of
+      Fail msg  msgs -> Fail (augment1 msg) (augment msgs0 msgs)
+      Success v msgs -> Success v (augment msgs0 msgs)
+  where
+    augment (es0,ws0) (es,ws) = (augment' es0 es,augment' ws0 ws)
+
+    augment' msgs0 []    = msgs0
+    augment' msgs0 msgs' = (msg $$ nest 3 (vcat (reverse msgs'))):msgs0
+
+    augment1 msg' = msg $$ nest 3 msg'
+
+-- | Augment error messages with a relative path to the source module and
+-- an contextual hint (which can be left 'empty')
+checkInModule cwd mi loc context =
+    checkIn (ppLocation relpath loc <> ':' $$ nest 2 context)
+  where
+    relpath = makeRelative cwd (sourcePath mi)

src/compiler/api/GF/Infra/Concurrency.hs

@@ -0,0 +1,48 @@
+-- | Lifted concurrency operators and a some useful concurrency abstractions
+module GF.Infra.Concurrency(
+    module GF.Infra.Concurrency,
+    C.forkIO,
+    C.MVar,C.modifyMVar,C.modifyMVar_,
+    C.Chan
+ ) where
+import qualified Control.Concurrent as C
+import System.IO.Unsafe(unsafeInterleaveIO)
+import Control.Monad((<=<))
+import Control.Monad.Trans(MonadIO(..))
+
+-- * Futures
+
+newtype Future a = Future {now::IO a}
+
+spawn io = do v <- newEmptyMVar
+              C.forkIO $ putMVar v =<< io
+              return (Future (readMVar v))
+
+parMapM f = mapM now <=< mapM (spawn . f)
+
+-- * Single-threaded logging
+
+newLog put =
+  do logchan <- newChan
+     liftIO $ C.forkIO (mapM_ put =<< getChanContents logchan)
+     return (writeChan logchan)
+
+-- * Lifted concurrency operators
+
+newMVar x = liftIO $ C.newMVar x
+readMVar v = liftIO $ C.readMVar v
+putMVar v = liftIO . C.putMVar v
+
+newEmptyMVar :: MonadIO io => io (C.MVar a)
+newEmptyMVar = liftIO C.newEmptyMVar
+
+newChan :: MonadIO io => io (C.Chan a)
+newChan = liftIO C.newChan
+
+getChanContents ch = liftIO $ C.getChanContents ch
+writeChan ch = liftIO . C.writeChan ch
+
+
+-- * Delayed IO
+
+lazyIO = unsafeInterleaveIO

src/compiler/api/GF/Infra/Dependencies.hs

@@ -0,0 +1,74 @@
+module GF.Infra.Dependencies (
+  depGraph
+  ) where
+
+import GF.Grammar.Grammar
+--import GF.Infra.Ident(Ident)
+import GF.Text.Pretty(render)
+
+import Data.List (nub,isPrefixOf)
+
+-- the list gives the only modules to show, e.g. to hide the library details
+depGraph :: Maybe [String] -> Grammar -> String
+depGraph only = prDepGraph . grammar2moddeps only
+
+prDepGraph :: [(ModuleName,ModDeps)] -> String
+prDepGraph deps = unlines $ [
+  "digraph {"
+  ] ++
+  map mkNode deps ++
+  concatMap mkArrows deps ++ [
+  "}"
+  ]
+ where
+   mkNode (i,dep) = unwords [render i, "[",nodeAttr (modtype dep),"]"]
+   nodeAttr ty = case ty of
+       MTAbstract   -> "style = \"solid\", shape = \"box\""
+       MTConcrete _ -> "style = \"solid\", shape = \"ellipse\""
+       _ -> "style = \"dashed\", shape = \"ellipse\""
+   mkArrows (i,dep) = 
+     [unwords [render i,"->",render j,"[",arrowAttr "of","]"] | j <- ofs dep] ++
+     [unwords [render i,"->",render j,"[",arrowAttr "ex","]"] | j <- extendeds dep] ++
+     [unwords [render i,"->",render j,"[",arrowAttr "op","]"] | j <- openeds dep] ++
+     [unwords [render i,"->",render j,"[",arrowAttr "ed","]"] | j <- extrads dep]
+   arrowAttr s = case s of
+     "of" -> "style = \"solid\", arrowhead = \"empty\""
+     "ex" -> "style = \"solid\""
+     "op" -> "style = \"dashed\""
+     "ed" -> "style = \"dotted\""
+
+data ModDeps = ModDeps {
+  modtype    :: ModuleType,
+  ofs        :: [ModuleName],
+  extendeds  :: [ModuleName],
+  openeds    :: [ModuleName],
+  extrads    :: [ModuleName],
+  functors   :: [ModuleName],
+  interfaces :: [ModuleName],
+  instances  :: [ModuleName]
+  }
+
+noModDeps = ModDeps MTAbstract [] [] [] [] [] [] []
+
+grammar2moddeps :: Maybe [String] -> Grammar -> [(ModuleName,ModDeps)]
+grammar2moddeps monly gr = [(i,depMod i m) | (i,m) <- modules gr, yes i]
+  where
+    depMod i m = 
+        noModDeps{
+          modtype = mtype m,
+          ofs     = case mtype m of 
+                     MTConcrete i -> [i | yes i]
+                     MTInstance (i,_) -> [i | yes i]
+                     _ -> [],
+          extendeds = nub $ filter yes $ map fst (mextend m),
+          openeds = nub $ filter yes $ map openedModule (mopens m),
+          extrads = nub $ filter yes $ mexdeps m
+          }
+    yes i = case monly of 
+      Just only -> match (render i) only
+      _ -> True
+    match s os = any (\x -> doMatch x s) os
+    doMatch x s = case last x of 
+      '*' -> isPrefixOf (init x) s
+      _   -> x == s
+

src/compiler/api/GF/Infra/GetOpt.hs

@@ -0,0 +1,381 @@
+-- This is a version of System.Console.GetOpt which has been hacked to
+-- support long options with a single dash. Since we don't want the annoying
+-- clash with short options that start with the same character as a long
+-- one, we don't allow short options to be given together (e.g. -zxf),
+-- nor do we allow options to be given as any unique prefix.
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Console.GetOpt
+-- Copyright   :  (c) Sven Panne 2002-2005
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- This library provides facilities for parsing the command-line options
+-- in a standalone program.  It is essentially a Haskell port of the GNU 
+-- @getopt@ library.
+--
+-----------------------------------------------------------------------------
+
+{-
+Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small
+changes Dec. 1997)
+
+Two rather obscure features are missing: The Bash 2.0 non-option hack
+(if you don't already know it, you probably don't want to hear about
+it...) and the recognition of long options with a single dash
+(e.g. '-help' is recognised as '--help', as long as there is no short
+option 'h').
+
+Other differences between GNU's getopt and this implementation:
+
+* To enforce a coherent description of options and arguments, there
+  are explanation fields in the option/argument descriptor.
+
+* Error messages are now more informative, but no longer POSIX
+  compliant... :-(
+
+And a final Haskell advertisement: The GNU C implementation uses well
+over 1100 lines, we need only 195 here, including a 46 line example! 
+:-)
+-}
+
+--module System.Console.GetOpt (
+module GF.Infra.GetOpt (
+   -- * GetOpt
+   getOpt, getOpt',
+   usageInfo,
+   ArgOrder(..),
+   OptDescr(..),
+   ArgDescr(..),
+
+   -- * Examples
+
+   -- |To hopefully illuminate the role of the different data structures,
+   -- here are the command-line options for a (very simple) compiler,
+   -- done in two different ways.
+   -- The difference arises because the type of 'getOpt' is
+   -- parameterized by the type of values derived from flags.
+
+   -- ** Interpreting flags as concrete values
+   -- $example1
+
+   -- ** Interpreting flags as transformations of an options record
+   -- $example2
+) where
+
+import Prelude -- necessary to get dependencies right
+
+--import Data.List ( isPrefixOf, find )
+
+-- |What to do with options following non-options
+data ArgOrder a
+  = RequireOrder                -- ^ no option processing after first non-option
+  | Permute                     -- ^ freely intersperse options and non-options
+  | ReturnInOrder (String -> a) -- ^ wrap non-options into options
+
+{-|
+Each 'OptDescr' describes a single option.
+
+The arguments to 'Option' are:
+
+* list of short option characters
+
+* list of long option strings (without \"--\")
+
+* argument descriptor
+
+* explanation of option for user
+-}
+data OptDescr a =              -- description of a single options:
+   Option [Char]                --    list of short option characters
+          [String]              --    list of long option strings (without "--")
+          (ArgDescr a)          --    argument descriptor
+          String                --    explanation of option for user
+
+-- |Describes whether an option takes an argument or not, and if so
+-- how the argument is injected into a value of type @a@.
+data ArgDescr a
+   = NoArg                   a         -- ^   no argument expected
+   | ReqArg (String       -> a) String -- ^   option requires argument
+   | OptArg (Maybe String -> a) String -- ^   optional argument
+
+data OptKind a                -- kind of cmd line arg (internal use only):
+   = Opt       a                --    an option
+   | UnreqOpt  String           --    an un-recognized option
+   | NonOpt    String           --    a non-option
+   | EndOfOpts                  --    end-of-options marker (i.e. "--")
+   | OptErr    String           --    something went wrong...
+
+-- | Return a string describing the usage of a command, derived from
+-- the header (first argument) and the options described by the 
+-- second argument.
+usageInfo :: String                    -- header
+          -> [OptDescr a]              -- option descriptors
+          -> String                    -- nicely formatted decription of options
+usageInfo header optDescr = unlines (header:table)
+   where (ss,ls,ds)     = (unzip3 . concatMap fmtOpt) optDescr
+         table          = zipWith3 paste (sameLen ss) (sameLen ls) ds
+         paste x y z    = "  " ++ x ++ "  " ++ y ++ "  " ++ z
+         sameLen xs     = flushLeft ((maximum . map length) xs) xs
+         flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]
+
+fmtOpt :: OptDescr a -> [(String,String,String)]
+fmtOpt (Option sos los ad descr) =
+   case lines descr of
+     []     -> [(sosFmt,losFmt,"")]
+     (d:ds) ->  (sosFmt,losFmt,d) : [ ("","",d') | d' <- ds ]
+   where sepBy _  []     = ""
+         sepBy _  [x]    = x
+         sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs
+         sosFmt = sepBy ',' (map (fmtShort ad) sos)
+         losFmt = sepBy ',' (map (fmtLong  ad) los)
+
+fmtShort :: ArgDescr a -> Char -> String
+fmtShort (NoArg  _   ) so = "-" ++ [so]
+fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad
+fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]"
+
+fmtLong :: ArgDescr a -> String -> String
+fmtLong (NoArg  _   ) lo = "--" ++ lo
+fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad
+fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"
+
+{-|
+Process the command-line, and return the list of values that matched
+(and those that didn\'t). The arguments are:
+
+* The order requirements (see 'ArgOrder')
+
+* The option descriptions (see 'OptDescr')
+
+* The actual command line arguments (presumably got from 
+  'System.Environment.getArgs').
+
+'getOpt' returns a triple consisting of the option arguments, a list
+of non-options, and a list of error messages.
+-}
+getOpt :: ArgOrder a                   -- non-option handling
+       -> [OptDescr a]                 -- option descriptors
+       -> [String]                     -- the command-line arguments
+       -> ([a],[String],[String])      -- (options,non-options,error messages)
+getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us)
+   where (os,xs,us,es) = getOpt' ordering optDescr args
+
+{-|
+This is almost the same as 'getOpt', but returns a quadruple
+consisting of the option arguments, a list of non-options, a list of
+unrecognized options, and a list of error messages.
+-}
+getOpt' :: ArgOrder a                         -- non-option handling
+        -> [OptDescr a]                       -- option descriptors
+        -> [String]                           -- the command-line arguments
+        -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages)
+getOpt' _        _        []         =  ([],[],[],[])
+getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering
+   where procNextOpt (Opt o)      _                 = (o:os,xs,us,es)
+         procNextOpt (UnreqOpt u) _                 = (os,xs,u:us,es)
+         procNextOpt (NonOpt x)   RequireOrder      = ([],x:rest,[],[])
+         procNextOpt (NonOpt x)   Permute           = (os,x:xs,us,es)
+         procNextOpt (NonOpt x)   (ReturnInOrder f) = (f x :os, xs,us,es)
+         procNextOpt EndOfOpts    RequireOrder      = ([],rest,[],[])
+         procNextOpt EndOfOpts    Permute           = ([],rest,[],[])
+         procNextOpt EndOfOpts    (ReturnInOrder f) = (map f rest,[],[],[])
+         procNextOpt (OptErr e)   _                 = (os,xs,us,e:es)
+
+         (opt,rest) = getNext arg args optDescr
+         (os,xs,us,es) = getOpt' ordering optDescr rest
+
+-- take a look at the next cmd line arg and decide what to do with it
+getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
+getNext ('-':'-':[]) rest _        = (EndOfOpts,rest)
+getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr
+getNext ('-'    :xs) rest optDescr = longOpt xs rest optDescr
+getNext a            rest _        = (NonOpt a,rest)
+
+-- handle long option
+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
+longOpt ls rs optDescr = long ads arg rs
+   where (opt,arg) = break (=='=') ls
+         options   = [ o | o@(Option ss xs _ _) <- optDescr
+                         , opt `elem` map (:[]) ss || opt `elem` xs ]
+         ads       = [ ad | Option _ _ ad _ <- options ]
+         optStr    = ("--"++opt)
+
+         long (_:_:_)      _        rest     = (errAmbig options optStr,rest)
+         long [NoArg  a  ] []       rest     = (Opt a,rest)
+         long [NoArg  _  ] ('=':_)  rest     = (errNoArg optStr,rest)
+         long [ReqArg _ d] []       []       = (errReq d optStr,[])
+         long [ReqArg f _] []       (r:rest) = (Opt (f r),rest)
+         long [ReqArg f _] ('=':xs) rest     = (Opt (f xs),rest)
+         long [OptArg f _] []       rest     = (Opt (f Nothing),rest)
+         long [OptArg f _] ('=':xs) rest     = (Opt (f (Just xs)),rest)
+         long _            _        rest     = (UnreqOpt ("--"++ls),rest)
+
+
+-- miscellaneous error formatting
+
+errAmbig :: [OptDescr a] -> String -> OptKind a
+errAmbig ods optStr = OptErr (usageInfo header ods)
+   where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"
+
+errReq :: String -> String -> OptKind a
+errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")
+
+errUnrec :: String -> String
+errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"
+
+errNoArg :: String -> OptKind a
+errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")
+
+{-
+-----------------------------------------------------------------------------------------
+-- and here a small and hopefully enlightening example:
+
+data Flag = Verbose | Version | Name String | Output String | Arg String   deriving Show
+
+options :: [OptDescr Flag]
+options =
+   [Option ['v']     ["verbose"]           (NoArg Verbose)      "verbosely list files",
+    Option ['V','?'] ["version","release"] (NoArg Version)      "show version info",
+    Option ['o']     ["output"]            (OptArg out "FILE")  "use FILE for dump",
+    Option ['n']     ["name"]              (ReqArg Name "USER") "only dump USER's files"]
+
+out :: Maybe String -> Flag
+out Nothing  = Output "stdout"
+out (Just o) = Output o
+
+test :: ArgOrder Flag -> [String] -> String
+test order cmdline = case getOpt order options cmdline of
+                        (o,n,[]  ) -> "options=" ++ show o ++ "  args=" ++ show n ++ "\n"
+                        (_,_,errs) -> concat errs ++ usageInfo header options
+   where header = "Usage: foobar [OPTION...] files..."
+
+-- example runs:
+-- putStr (test RequireOrder ["foo","-v"])
+--    ==> options=[]  args=["foo", "-v"]
+-- putStr (test Permute ["foo","-v"])
+--    ==> options=[Verbose]  args=["foo"]
+-- putStr (test (ReturnInOrder Arg) ["foo","-v"])
+--    ==> options=[Arg "foo", Verbose]  args=[]
+-- putStr (test Permute ["foo","--","-v"])
+--    ==> options=[]  args=["foo", "-v"]
+-- putStr (test Permute ["-?o","--name","bar","--na=baz"])
+--    ==> options=[Version, Output "stdout", Name "bar", Name "baz"]  args=[]
+-- putStr (test Permute ["--ver","foo"])
+--    ==> option `--ver' is ambiguous; could be one of:
+--          -v      --verbose             verbosely list files
+--          -V, -?  --version, --release  show version info   
+--        Usage: foobar [OPTION...] files...
+--          -v        --verbose             verbosely list files  
+--          -V, -?    --version, --release  show version info     
+--          -o[FILE]  --output[=FILE]       use FILE for dump     
+--          -n USER   --name=USER           only dump USER's files
+-----------------------------------------------------------------------------------------
+-}
+
+{- $example1
+
+A simple choice for the type associated with flags is to define a type
+@Flag@ as an algebraic type representing the possible flags and their
+arguments:
+
+>    module Opts1 where
+>    
+>    import System.Console.GetOpt
+>    import Data.Maybe ( fromMaybe )
+>    
+>    data Flag 
+>     = Verbose  | Version 
+>     | Input String | Output String | LibDir String
+>       deriving Show
+>    
+>    options :: [OptDescr Flag]
+>    options =
+>     [ Option ['v']     ["verbose"] (NoArg Verbose)       "chatty output on stderr"
+>     , Option ['V','?'] ["version"] (NoArg Version)       "show version number"
+>     , Option ['o']     ["output"]  (OptArg outp "FILE")  "output FILE"
+>     , Option ['c']     []          (OptArg inp  "FILE")  "input FILE"
+>     , Option ['L']     ["libdir"]  (ReqArg LibDir "DIR") "library directory"
+>     ]
+>    
+>    inp,outp :: Maybe String -> Flag
+>    outp = Output . fromMaybe "stdout"
+>    inp  = Input  . fromMaybe "stdin"
+>    
+>    compilerOpts :: [String] -> IO ([Flag], [String])
+>    compilerOpts argv = 
+>       case getOpt Permute options argv of
+>          (o,n,[]  ) -> return (o,n)
+>          (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
+>      where header = "Usage: ic [OPTION...] files..."
+
+Then the rest of the program will use the constructed list of flags
+to determine it\'s behaviour.
+
+-}
+
+{- $example2
+
+A different approach is to group the option values in a record of type
+@Options@, and have each flag yield a function of type
+@Options -> Options@ transforming this record.
+
+>    module Opts2 where
+>
+>    import System.Console.GetOpt
+>    import Data.Maybe ( fromMaybe )
+>
+>    data Options = Options
+>     { optVerbose     :: Bool
+>     , optShowVersion :: Bool
+>     , optOutput      :: Maybe FilePath
+>     , optInput       :: Maybe FilePath
+>     , optLibDirs     :: [FilePath]
+>     } deriving Show
+>
+>    defaultOptions    = Options
+>     { optVerbose     = False
+>     , optShowVersion = False
+>     , optOutput      = Nothing
+>     , optInput       = Nothing
+>     , optLibDirs     = []
+>     }
+>
+>    options :: [OptDescr (Options -> Options)]
+>    options =
+>     [ Option ['v']     ["verbose"]
+>         (NoArg (\ opts -> opts { optVerbose = True }))
+>         "chatty output on stderr"
+>     , Option ['V','?'] ["version"]
+>         (NoArg (\ opts -> opts { optShowVersion = True }))
+>         "show version number"
+>     , Option ['o']     ["output"]
+>         (OptArg ((\ f opts -> opts { optOutput = Just f }) . fromMaybe "output")
+>                 "FILE")
+>         "output FILE"
+>     , Option ['c']     []
+>         (OptArg ((\ f opts -> opts { optInput = Just f }) . fromMaybe "input")
+>                 "FILE")
+>         "input FILE"
+>     , Option ['L']     ["libdir"]
+>         (ReqArg (\ d opts -> opts { optLibDirs = optLibDirs opts ++ [d] }) "DIR")
+>         "library directory"
+>     ]
+>
+>    compilerOpts :: [String] -> IO (Options, [String])
+>    compilerOpts argv =
+>       case getOpt Permute options argv of
+>          (o,n,[]  ) -> return (foldl (flip id) defaultOptions o, n)
+>          (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
+>      where header = "Usage: ic [OPTION...] files..."
+
+Similarly, each flag could yield a monadic function transforming a record,
+of type @Options -> IO Options@ (or any other monad), allowing option
+processing to perform actions of the chosen monad, e.g. printing help or
+version messages, checking that file arguments exist, etc.
+
+-}

src/compiler/api/GF/Infra/Ident.hs

@@ -0,0 +1,137 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Ident
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/15 11:43:33 $
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.8 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Infra.Ident (-- ** Identifiers
+  ModuleName(..), moduleNameS,
+  Ident, ident2utf8, showIdent, prefixIdent,
+  -- *** Normal identifiers (returned by the parser)
+  identS, identC, identW,
+  -- *** Special identifiers for internal use
+  identV,
+  varStr, varX, varIndex, varIndex',
+  -- *** Raw identifiers
+  RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
+  isPrefixOf, showRawIdent
+) where
+
+import qualified Data.ByteString.UTF8 as UTF8
+import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
+                 -- Limit use of BS functions to the ones that work correctly on
+                 -- UTF-8-encoded bytestrings!
+import Data.Char(isDigit)
+import Data.Binary(Binary(..))
+import GF.Text.Pretty
+
+
+-- | Module names
+newtype ModuleName = MN Ident deriving (Eq,Ord)
+
+moduleNameS = MN . identS
+
+instance Show ModuleName where showsPrec d (MN m) = showsPrec d m
+instance Pretty ModuleName where pp (MN m) = pp m
+
+instance Binary ModuleName where
+  put (MN id) = put id
+  get = fmap MN get
+
+-- | the constructors labelled /INTERNAL/ are
+-- internal representation never returned by the parser
+data Ident =
+   IC  {-# UNPACK #-} !RawIdent                                           -- ^ raw identifier after parsing, resolved in Rename
+ | IW                                                                     -- ^ wildcard
+--
+-- below this constructor: internal representation never returned by the parser
+ | IV  {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int                       -- ^ /INTERNAL/ variable
+  deriving (Eq, Ord, Show, Read)
+
+-- | Identifiers are stored as UTF-8-encoded bytestrings.
+-- (It is also possible to use regular Haskell 'String's, with somewhat
+-- reduced performance and increased memory use.)
+newtype RawIdent = Id { rawId2utf8 :: UTF8.ByteString }
+  deriving (Eq, Ord, Show, Read)
+
+pack = UTF8.fromString
+unpack = UTF8.toString
+
+rawIdentS = Id . pack
+rawIdentC = Id
+showRawIdent = unpack . rawId2utf8
+
+prefixRawIdent (Id x) (Id y) = Id (BS.append x y)
+isPrefixOf (Id x) (Id y) = BS.isPrefixOf x y
+
+instance Binary Ident where
+  put id = put (ident2utf8 id)
+  get    = do bs <- get
+              if bs == wild
+                then return identW
+                else return (identC (rawIdentC bs))
+
+instance Binary RawIdent where
+  put = put . rawId2utf8
+  get = fmap rawIdentC get
+
+-- | This function should be used with care, since the returned ByteString is
+-- UTF-8-encoded.
+ident2utf8 :: Ident -> UTF8.ByteString
+ident2utf8 i = case i of
+  IC (Id s) -> s
+  IV (Id s) n -> BS.append s (pack ('_':show n))
+  IW -> wild
+
+ident2raw :: Ident -> RawIdent
+ident2raw = Id . ident2utf8
+
+showIdent :: Ident -> String
+showIdent i = unpack $! ident2utf8 i
+
+instance Pretty Ident where pp = pp . showIdent
+
+instance Pretty RawIdent where pp = pp . showRawIdent
+
+identS :: String -> Ident
+identS = identC . rawIdentS
+
+identC :: RawIdent -> Ident
+identW :: Ident
+
+prefixIdent :: String -> Ident -> Ident
+prefixIdent pref = identC . Id . BS.append (pack pref) . ident2utf8
+
+identV :: RawIdent -> Int -> Ident
+
+(identC, identV, identW) =
+    (IC,     IV,     IW)
+
+-- | used in lin defaults
+varStr :: Ident
+varStr = identS "str"
+
+-- | refreshing variables
+varX :: Int -> Ident
+varX = identV (rawIdentS "x")
+
+wild = pack "_"
+
+varIndex :: Ident -> Int
+varIndex (IV _ n) = n
+varIndex _ = -1 --- other than IV should not count
+
+varIndex' :: RawIdent -> Ident -> Int
+varIndex' x (IC y)
+  | x == y    = 0
+varIndex' x (IV y n)
+  | x == y    = n
+varIndex' _ _ = -1 --- other than IV should not count

src/compiler/api/GF/Infra/Location.hs

@@ -0,0 +1,41 @@
+-- | Source locations
+module GF.Infra.Location where
+import Prelude hiding ((<>))
+import GF.Text.Pretty
+
+-- ** Source locations
+
+class HasSourcePath a where sourcePath :: a -> FilePath
+
+data Location 
+  = NoLoc
+  | Local Int Int
+  | External FilePath Location
+  deriving (Show,Eq,Ord)
+
+-- | Attaching location information
+data L a = L Location a deriving Show
+
+instance Functor L where fmap f (L loc x) = L loc (f x)
+
+unLoc :: L a -> a
+unLoc (L _ x) = x
+
+noLoc = L NoLoc
+
+ppLocation :: FilePath -> Location -> Doc
+ppLocation fpath NoLoc          = pp fpath
+ppLocation fpath (External p l) = ppLocation p l
+ppLocation fpath (Local b e) =
+    opt (fpath/="") (fpath <> ":") <> b <> opt (b/=e) ("-" <> e)
+  where
+    opt False x = empty
+    opt True x = x
+
+ppL (L loc x) msg = hang (loc<>":") 4 ("In"<+>x<>":"<+>msg)
+
+
+instance Pretty Location where pp = ppLocation ""
+
+instance Pretty a => Pretty (L a) where pp (L loc x) = loc<>":"<>x
+

src/compiler/api/GF/Infra/Option.hs

@@ -0,0 +1,642 @@
+module GF.Infra.Option
+    (
+     -- ** Command line options
+     -- *** Option types
+     Options,
+     Flags(..),
+     Mode(..), Phase(..), Verbosity(..), RetainMode(..),
+     OutputFormat(..),
+     SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..),
+     Dump(..), Pass(..), Recomp(..),
+     outputFormatsExpl,
+     -- *** Option parsing
+     parseOptions, parseModuleOptions, fixRelativeLibPaths,
+     -- *** Option pretty-printing
+     optionsGFO,
+     optionsPGF,
+     -- *** Option manipulation
+     addOptions, concatOptions, noOptions,
+     modifyFlags,
+     helpMessage,
+     -- *** Checking specific options
+     flag, cfgTransform, haskellOption, readOutputFormat,
+     isLexicalCat, isLiteralCat, renameEncoding, getEncoding, defaultEncoding,
+     -- *** Setting specific options
+     setOptimization, setCFGTransform,
+     -- *** Convenience methods for checking options
+     verbAtLeast, dump
+    ) where
+
+import Control.Monad
+import Data.Char (toLower, isDigit)
+import Data.List
+import Data.Maybe
+import GF.Infra.Ident
+import GF.Infra.GetOpt
+import GF.Grammar.Predef
+import System.FilePath
+import PGF2(Literal(..))
+
+import GF.Data.Operations(Err,ErrorMonad(..),liftErr)
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import qualified Control.Monad.Fail as Fail
+
+usageHeader :: String
+usageHeader = unlines
+ ["Usage: gf [OPTIONS] [FILE [...]]",
+  "",
+  "How each FILE is handled depends on the file name suffix:",
+  "",
+  ".gf Normal or old GF source, will be compiled.",
+  ".gfo Compiled GF source, will be loaded as is.",
+  ".gfe Example-based GF source, will be converted to .gf and compiled.",
+  ".ebnf Extended BNF format, will be converted to .gf and compiled.",
+  ".cf Context-free (BNF) format, will be converted to .gf and compiled.",
+  "",
+  "If multiple FILES are given, they must be normal GF source, .gfo or .gfe files.",
+  "For the other input formats, only one file can be given.",
+  "",
+  "Command-line options:"]
+
+
+helpMessage :: String
+helpMessage = usageInfo usageHeader optDescr
+
+
+-- FIXME: do we really want multi-line errors?
+errors :: ErrorMonad err => [String] -> err a
+errors = raise . unlines
+
+-- Types
+
+data Mode = ModeVersion | ModeHelp
+          | ModeInteractive | ModeRun
+          | ModeCompiler
+          | ModeServer {-port::-}Int
+  deriving (Show,Eq,Ord)
+
+data Verbosity = Quiet | Normal | Verbose | Debug
+  deriving (Show,Eq,Ord,Enum,Bounded)
+
+data Phase = Preproc | Convert | Compile | Link
+  deriving (Show,Eq,Ord)
+
+data OutputFormat = FmtPGFPretty
+                  | FmtCanonicalGF
+                  | FmtCanonicalJson
+                  | FmtJavaScript
+                  | FmtJSON
+                  | FmtPython
+                  | FmtHaskell
+                  | FmtJava
+                  | FmtBNF
+                  | FmtEBNF
+                  | FmtRegular
+                  | FmtNoLR
+                  | FmtSRGS_XML
+                  | FmtSRGS_XML_NonRec
+                  | FmtSRGS_ABNF
+                  | FmtSRGS_ABNF_NonRec
+                  | FmtJSGF
+                  | FmtGSL
+                  | FmtVoiceXML
+                  | FmtSLF
+                  | FmtRegExp
+                  | FmtFA
+                  | FmtLR
+  deriving (Eq,Ord)
+
+data SISRFormat =
+    -- | SISR Working draft 1 April 2003
+    --   <http://www.w3.org/TR/2003/WD-semantic-interpretation-20030401/>
+    SISR_WD20030401
+  | SISR_1_0
+ deriving (Show,Eq,Ord)
+
+data Optimization = OptStem | OptCSE | OptExpand | OptParametrize
+  deriving (Show,Eq,Ord)
+
+data CFGTransform = CFGNoLR
+                  | CFGRegular
+                  | CFGTopDownFilter
+                  | CFGBottomUpFilter
+                  | CFGStartCatOnly
+                  | CFGMergeIdentical
+                  | CFGRemoveCycles
+  deriving (Show,Eq,Ord)
+
+data HaskellOption = HaskellNoPrefix
+                   | HaskellGADT
+                   | HaskellLexical
+                   | HaskellConcrete
+                   | HaskellVariants
+                   | HaskellData
+                   | HaskellPGF2
+  deriving (Show,Eq,Ord)
+
+data Warning = WarnMissingLincat
+  deriving (Show,Eq,Ord)
+
+newtype Dump = Dump Pass deriving (Show,Eq,Ord)
+data Pass = Source | Rebuild | Extend | Rename | TypeCheck | Refresh | Optimize | Canon
+  deriving (Show,Eq,Ord)
+
+data Recomp = AlwaysRecomp | RecompIfNewer | NeverRecomp
+  deriving (Show,Eq,Ord)
+
+data RetainMode = RetainAll | RetainSource | RetainCompiled
+  deriving Show
+
+data Flags = Flags {
+      optMode            :: Mode,
+      optStopAfterPhase  :: Phase,
+      optVerbosity       :: Verbosity,
+      optShowCPUTime     :: Bool,
+      optOutputFormats   :: [OutputFormat],
+      optLinkTargets     :: (Bool,Bool), -- pgf,ngf files
+      optBlank           :: Maybe String,
+      optSISR            :: Maybe SISRFormat,
+      optHaskellOptions  :: Set HaskellOption,
+      optLexicalCats     :: Set String,
+      optLiteralCats     :: Set Ident,
+      optGFODir          :: Maybe FilePath,
+      optOutputDir       :: Maybe FilePath,
+      optGFLibPath       :: Maybe FilePath,
+      optDocumentRoot    :: Maybe FilePath, -- For --server mode
+      optRecomp          :: Recomp,
+      optProbsFile       :: Maybe FilePath,
+      optRetainResource  :: RetainMode,
+      optName            :: Maybe String,
+      optPreprocessors   :: [String],
+      optEncoding        :: Maybe String,
+      optPMCFG           :: Bool,
+      optOptimizations   :: Set Optimization,
+      optOptimizePGF     :: Bool,
+      optCFGTransforms   :: Set CFGTransform,
+      optLibraryPath     :: [FilePath],
+      optStartCat        :: Maybe String,
+      optSpeechLanguage  :: Maybe String,
+      optLexer           :: Maybe String,
+      optUnlexer         :: Maybe String,
+      optWarnings        :: [Warning],
+      optDump            :: [Dump],
+      optTagsOnly        :: Bool,
+      optHeuristicFactor :: Maybe Double,
+      optCaseSensitive   :: Bool,
+      optPlusAsBind      :: Bool,
+      optJobs            :: Maybe (Maybe Int)
+    }
+  deriving Show
+
+newtype Options = Options (Flags -> Flags)
+
+instance Show Options where
+    show (Options o) = show (o defaultFlags)
+
+-- Option parsing
+
+parseOptions :: ErrorMonad err =>
+                [String]                   -- ^ list of string arguments
+             -> err (Options, [FilePath])
+parseOptions args
+  | not (null errs) = errors errs
+  | otherwise       = do opts <- concatOptions `fmap` liftErr (sequence optss)
+                         return (opts, files)
+  where
+    (optss, files, errs) = getOpt RequireOrder optDescr args
+
+parseModuleOptions :: ErrorMonad err =>
+                      [String]                   -- ^ list of string arguments
+                   -> err Options
+parseModuleOptions args = do
+  (opts,nonopts) <- parseOptions args
+  if null nonopts
+    then return opts
+    else errors $ map ("Non-option among module options: " ++) nonopts
+
+fixRelativeLibPaths curr_dir lib_dir (Options o) = Options (fixPathFlags . o)
+  where
+    fixPathFlags f@(Flags{optLibraryPath=path}) = f{optLibraryPath=concatMap (\dir -> [curr_dir </> dir, lib_dir </> dir]) path}
+
+-- Showing options
+
+-- | Pretty-print the options that are preserved in .gfo files.
+optionsGFO :: Options -> [(String,Literal)]
+optionsGFO opts = optionsPGF opts
+      ++ [("coding", LStr (getEncoding opts))]
+
+-- | Pretty-print the options that are preserved in .pgf files.
+optionsPGF :: Options -> [(String,Literal)]
+optionsPGF opts =
+         maybe [] (\x -> [("language",LStr x)]) (flag optSpeechLanguage opts)
+      ++ maybe [] (\x -> [("startcat",LStr x)]) (flag optStartCat opts)
+      ++ maybe [] (\x -> [("heuristic_search_factor",LFlt x)]) (flag optHeuristicFactor opts)
+      ++ (if flag optCaseSensitive opts then [] else [("case_sensitive",LStr "off")])
+
+-- Option manipulation
+
+flag :: (Flags -> a) -> Options -> a
+flag f (Options o) = f (o defaultFlags)
+
+addOptions :: Options -> Options -> Options
+addOptions (Options o1) (Options o2) = Options (o2 . o1)
+
+noOptions :: Options
+noOptions = Options id
+
+concatOptions :: [Options] -> Options
+concatOptions = foldr addOptions noOptions
+
+modifyFlags :: (Flags -> Flags) -> Options
+modifyFlags = Options
+
+getEncoding :: Options -> String
+getEncoding = renameEncoding . maybe defaultEncoding id . flag optEncoding
+defaultEncoding = "UTF-8"
+
+-- Default options
+
+defaultFlags :: Flags
+defaultFlags = Flags {
+      optMode            = ModeInteractive,
+      optStopAfterPhase  = Compile,
+      optVerbosity       = Normal,
+      optShowCPUTime     = False,
+      optOutputFormats   = [],
+      optLinkTargets     = (True,False),
+      optBlank           = Nothing,
+      optSISR            = Nothing,
+      optHaskellOptions  = Set.empty,
+      optLiteralCats     = Set.fromList [cString,cInt,cFloat],
+      optLexicalCats     = Set.empty,
+      optGFODir          = Nothing,
+      optOutputDir       = Nothing,
+      optGFLibPath       = Nothing,
+      optDocumentRoot    = Nothing,
+      optRecomp          = RecompIfNewer,
+      optProbsFile       = Nothing,
+      optRetainResource  = RetainCompiled,
+
+      optName            = Nothing,
+      optPreprocessors   = [],
+      optEncoding        = Nothing,
+      optPMCFG           = True,
+      optOptimizations   = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize],
+      optOptimizePGF     = False,
+      optCFGTransforms   = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter,
+                                         CFGTopDownFilter, CFGMergeIdentical],
+      optLibraryPath     = [],
+      optStartCat        = Nothing,
+      optSpeechLanguage  = Nothing,
+      optLexer           = Nothing,
+      optUnlexer         = Nothing,
+      optWarnings        = [],
+      optDump            = [],
+      optTagsOnly        = False,
+      optHeuristicFactor = Nothing,
+      optCaseSensitive   = True,
+      optPlusAsBind      = False,
+      optJobs            = Nothing
+    }
+
+-- | Option descriptions
+{-# NOINLINE optDescr #-}
+optDescr :: [OptDescr (Err Options)]
+optDescr =
+    [
+     Option ['?','h'] ["help"] (NoArg (mode ModeHelp)) "Show help message.",
+     Option ['V'] ["version"] (NoArg (mode ModeVersion)) "Display GF version number.",
+     Option ['v'] ["verbose"] (OptArg verbosity "N") "Set verbosity (default 1). -v alone is the same as -v 2.",
+     Option ['q','s'] ["quiet"] (NoArg (verbosity (Just "0"))) "Quiet, same as -v 0.",
+     Option [] ["batch"] (NoArg (mode ModeCompiler)) "Run in batch compiler mode.",
+     Option ['j'] ["jobs"] (OptArg jobs "N") "Compile N modules in parallel with -batch (default 1).",
+     Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).",
+     Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).",
+     Option [] ["server"] (OptArg modeServer "port") $
+       "Run in HTTP server mode on given port (default "++show defaultPort++").",
+     Option [] ["document-root"] (ReqArg gfDocuRoot "DIR")
+           "Overrides the default document root for --server mode.",
+     Option [] ["tags"] (NoArg (set $ \o -> o{optMode = ModeCompiler, optTagsOnly = True})) "Build TAGS file and exit.",
+     Option ['E'] [] (NoArg (phase Preproc)) "Stop after preprocessing (with --preproc).",
+     Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.",
+     Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo (default) .",
+     Option [] ["make"] (NoArg (liftM2 addOptions (mode ModeCompiler) (phase Link))) "Build .pgf file and other output files and exit.",
+     Option [] ["boot"] (NoArg (set $ \o -> o {optLinkTargets = (True,True)})) "Boot an .ngf database for fast grammar reloading",
+     Option [] ["boot-only"] (NoArg (set $ \o -> o {optLinkTargets = (False,True)})) "Boot the .ngf database and don't write a .pgf file",
+     Option [] ["blank"] (ReqArg (\x -> set $ \o -> o { optBlank = Just x }) "ABSTR_NAME") "Create a blank database with an empty abstract syntax.",
+     Option [] ["cpu"] (NoArg (cpu True)) "Show compilation CPU time statistics.",
+     Option [] ["no-cpu"] (NoArg (cpu False)) "Don't show compilation CPU time statistics (default).",
+     Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').",
+     Option ['f'] ["output-format"] (ReqArg outFmt "FMT")
+        (unlines ["Output format. FMT can be one of:",
+                  "Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)",
+                  "Multiple concrete: pgf (default), json, js, pgf_pretty, prolog, python, ...", -- gar,
+                  "Single concrete only: bnf, ebnf, fa, gsl, jsgf, regexp, slf, srgs_xml, srgs_abnf, vxml, ....", -- cf, lbnf,
+                  "Abstract only: haskell, ..."]), -- prolog_abs,
+     Option [] ["sisr"] (ReqArg sisrFmt "FMT")
+        (unlines ["Include SISR tags in generated speech recognition grammars.",
+                  "FMT can be one of: old, 1.0"]),
+     Option [] ["haskell"] (ReqArg hsOption "OPTION")
+            ("Turn on an optional feature when generating Haskell data types. OPTION = "
+             ++ concat (intersperse " | " (map fst haskellOptionNames))),
+     Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]")
+            "Treat CAT as a lexical category.",
+     Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]")
+            "Treat CAT as a literal category.",
+     Option ['D'] ["output-dir"] (ReqArg outDir "DIR")
+           "Save output files (other than .gfo files) in DIR.",
+     Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR")
+           "Overrides the value of GF_LIB_PATH.",
+     Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp))
+                 "Always recompile from source.",
+     Option [] ["recomp-if-newer"] (NoArg (recomp RecompIfNewer))
+                 "(default) Recompile from source if the source is newer than the .gfo file.",
+     Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp))
+                 "Never recompile from source, if there is already .gfo file.",
+     Option [] ["retain"]   (NoArg (set $ \o -> o { optRetainResource = RetainAll })) "Retain the source and well as the compiled grammar.",
+     Option [] ["resource"] (NoArg (set $ \o -> o { optRetainResource = RetainSource })) "Load the source grammar as a resource only.",
+     Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from file.",
+     Option ['n'] ["name"] (ReqArg name "NAME")
+           (unlines ["Use NAME as the name of the output. This is used in the output file names, ",
+                     "with suffixes depending on the formats, and, when relevant, ",
+                     "internally in the output."]),
+     Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.",
+     Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.",
+     Option [] ["preproc"] (ReqArg preproc "CMD")
+                 (unlines ["Use CMD to preprocess input files.",
+                           "Multiple preprocessors can be used by giving this option multiple times."]),
+     Option [] ["coding"] (ReqArg coding "ENCODING")
+                ("Character encoding of the source grammar, ENCODING = utf8, latin1, cp1251, ..."),
+     Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.",
+     Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.",
+     Option [] ["lexer"] (ReqArg lexer "LEXER") "Use lexer LEXER.",
+     Option [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.",
+     Option [] ["pmcfg"] (NoArg (pmcfg True)) "Generate PMCFG (default).",
+     Option [] ["no-pmcfg"] (NoArg (pmcfg False)) "Don't generate PMCFG (useful for libraries).",
+     Option [] ["optimize"] (ReqArg optimize "OPT")
+                "Select an optimization package. OPT = all | values | parametrize | none",
+     Option [] ["optimize-pgf"] (NoArg (optimize_pgf True))
+                "Enable or disable global grammar optimization. This could significantly reduce the size of the final PGF file",
+     Option [] ["cfg"] (ReqArg cfgTransform "TRANS") "Enable or disable specific CFG transformations. TRANS = merge, no-merge, bottomup, no-bottomup, ...",
+     Option [] ["heuristic_search_factor"] (ReqArg (readDouble (\d o -> o { optHeuristicFactor = Just d })) "FACTOR") "Set the heuristic search factor for statistical parsing",
+     Option [] ["case_sensitive"] (onOff (\v -> set $ \o -> o{optCaseSensitive=v}) True) "Set the parser in case-sensitive/insensitive mode [sensitive by default]",
+     Option [] ["plus-as-bind"] (NoArg (set $ \o -> o{optPlusAsBind=True})) "Uses of (+) with runtime variables automatically generate BIND (experimental feature).",
+     dumpOption "source" Source,
+     dumpOption "rebuild" Rebuild,
+     dumpOption "extend" Extend,
+     dumpOption "rename" Rename,
+     dumpOption "tc" TypeCheck,
+     dumpOption "refresh" Refresh,
+     dumpOption "opt" Optimize,
+     dumpOption "canon" Canon
+    ]
+ where phase       x = set $ \o -> o { optStopAfterPhase = x }
+       mode        x = set $ \o -> o { optMode = x }
+       defaultPort   = 41296
+       modeServer    = maybe (ms defaultPort) readPort
+         where
+           ms = mode . ModeServer
+           readPort p = maybe err ms (readMaybe p)
+                 where err = fail $ "Bad server port: "++p
+
+       jobs          = maybe (setjobs Nothing) number
+           where
+             number s = maybe err (setjobs . Just) (readMaybe s)
+               where err = fail $ "Bad number of jobs: " ++ s
+             setjobs j = set $ \ o -> o { optJobs = Just j }
+
+       verbosity mv  = case mv of
+                           Nothing -> set $ \o -> o { optVerbosity = Verbose }
+                           Just v  -> case readMaybe v >>= toEnumBounded of
+                                        Just i  -> set $ \o -> o { optVerbosity = i }
+                                        Nothing -> fail $ "Bad verbosity: " ++ show v
+       cpu         x = set $ \o -> o { optShowCPUTime = x }
+       gfoDir      x = set $ \o -> o { optGFODir = Just x }
+       outFmt      x = readOutputFormat x >>= \f ->
+                         set $ \o -> o { optOutputFormats = optOutputFormats o ++ [f] }
+       sisrFmt     x = case x of
+                         "old" -> set $ \o -> o { optSISR = Just SISR_WD20030401 }
+                         "1.0" -> set $ \o -> o { optSISR = Just SISR_1_0 }
+                         _     -> fail $ "Unknown SISR format: " ++ show x
+       hsOption    x = case lookup x haskellOptionNames of
+                         Just p  -> set $ \o -> o { optHaskellOptions = Set.insert p (optHaskellOptions o) }
+                         Nothing -> fail $ "Unknown Haskell option: " ++ x
+                                            ++ " Known: " ++ show (map fst haskellOptionNames)
+       literalCat  x = set $ \o -> o { optLiteralCats = foldr Set.insert (optLiteralCats o) ((map identS . splitBy (==',')) x) }
+       lexicalCat  x = set $ \o -> o { optLexicalCats = foldr Set.insert (optLexicalCats o) (splitBy (==',') x) }
+       outDir      x = set $ \o -> o { optOutputDir = Just x }
+       gfLibPath   x = set $ \o -> o { optGFLibPath = Just x }
+       gfDocuRoot  x = set $ \o -> o { optDocumentRoot = Just x }
+       recomp      x = set $ \o -> o { optRecomp = x }
+       probsFile   x = set $ \o -> o { optProbsFile = Just x }
+
+       name        x = set $ \o -> o { optName = Just x }
+       addLibDir   x = set $ \o -> o { optLibraryPath = x:optLibraryPath o }
+       setLibPath  x = set $ \o -> o { optLibraryPath = splitInModuleSearchPath x }
+       preproc     x = set $ \o -> o { optPreprocessors = optPreprocessors o ++ [x] }
+       coding      x = set $ \o -> o { optEncoding = Just x }
+       startcat    x = set $ \o -> o { optStartCat = Just x }
+       language    x = set $ \o -> o { optSpeechLanguage = Just x }
+       lexer       x = set $ \o -> o { optLexer = Just x }
+       unlexer     x = set $ \o -> o { optUnlexer = Just x }
+
+       pmcfg       x = set $ \o -> o { optPMCFG = x }
+
+       optimize    x = case lookup x optimizationPackages of
+                         Just p  -> set $ \o -> o { optOptimizations = p }
+                         Nothing -> fail $ "Unknown optimization package: " ++ x
+
+       optimize_pgf x = set $ \o -> o { optOptimizePGF = x }
+
+       cfgTransform x = let (x', b) = case x of
+                                        'n':'o':'-':rest -> (rest, False)
+                                        _                -> (x, True)
+                         in case lookup x' cfgTransformNames of
+                              Just t  -> set $ setCFGTransform' t b
+                              Nothing -> fail $ "Unknown CFG transformation: " ++ x'
+                                                ++ " Known: " ++ show (map fst cfgTransformNames)
+
+       readDouble f x = case reads x of
+                          [(d,"")] -> set $ f d
+                          _        -> fail "A floating point number is expected"
+
+       dumpOption s d = Option [] ["dump-"++s] (NoArg (set $ \o -> o { optDump = Dump d:optDump o})) ("Dump output of the " ++ s ++ " phase.")
+
+       set = return . Options
+
+outputFormats :: [(String,OutputFormat)]
+outputFormats = map fst outputFormatsExpl
+
+outputFormatsExpl :: [((String,OutputFormat),String)]
+outputFormatsExpl =
+    [(("pgf_pretty",   FmtPGFPretty),"human-readable pgf"),
+     (("canonical_gf", FmtCanonicalGF),"Canonical GF source files"),
+     (("canonical_json", FmtCanonicalJson),"Canonical JSON source files"),
+     (("json",         FmtJSON),"JSON (whole grammar)"),
+     (("haskell",      FmtHaskell),"Haskell (abstract syntax)"),
+     (("java",         FmtJava),"Java (abstract syntax)"),
+     (("bnf",          FmtBNF),"BNF (context-free grammar)"),
+     (("ebnf",         FmtEBNF),"Extended BNF"),
+     (("regular",      FmtRegular),"* regular grammar"),
+     (("nolr",         FmtNoLR),"* context-free with no left recursion"),
+     (("srgs_xml",     FmtSRGS_XML),"SRGS speech recognition format in XML"),
+     (("srgs_xml_nonrec",     FmtSRGS_XML_NonRec),"SRGS XML, recursion eliminated"),
+     (("srgs_abnf",    FmtSRGS_ABNF),"SRGS speech recognition format in ABNF"),
+     (("srgs_abnf_nonrec",    FmtSRGS_ABNF_NonRec),"SRGS ABNF, recursion eliminated"),
+     (("jsgf",         FmtJSGF),"JSGF speech recognition format"),
+     (("gsl",          FmtGSL),"Nuance speech recognition format"),
+     (("vxml",         FmtVoiceXML),"Voice XML based on abstract syntax"),
+     (("slf",          FmtSLF),"SLF speech recognition format"),
+     (("regexp",       FmtRegExp),"regular expression"),
+     (("fa",           FmtFA),"finite automaton in graphviz format"),
+     (("lr",           FmtLR),"LR(0) automaton for PMCFG in graphviz format")
+     ]
+
+instance Show OutputFormat where
+    show = lookupShow outputFormats
+
+instance Read OutputFormat where
+    readsPrec = lookupReadsPrec outputFormats
+
+optimizationPackages :: [(String, Set Optimization)]
+optimizationPackages =
+    [("all",         Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
+     ("values",      Set.fromList [OptStem,OptCSE,OptExpand]),
+     ("noexpand",    Set.fromList [OptStem,OptCSE]),
+
+     -- deprecated
+     ("all_subs",    Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
+     ("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
+     ("none",        Set.fromList [OptStem,OptCSE,OptExpand])
+    ]
+
+cfgTransformNames :: [(String, CFGTransform)]
+cfgTransformNames =
+    [("nolr",         CFGNoLR),
+     ("regular",      CFGRegular),
+     ("topdown",      CFGTopDownFilter),
+     ("bottomup",     CFGBottomUpFilter),
+     ("startcatonly", CFGStartCatOnly),
+     ("merge",        CFGMergeIdentical),
+     ("removecycles", CFGRemoveCycles)]
+
+haskellOptionNames :: [(String, HaskellOption)]
+haskellOptionNames =
+    [("noprefix", HaskellNoPrefix),
+     ("gadt",     HaskellGADT),
+     ("lexical",  HaskellLexical),
+     ("concrete", HaskellConcrete),
+     ("variants", HaskellVariants),
+     ("data",     HaskellData),
+     ("pgf2",     HaskellPGF2)]
+
+-- | This is for bacward compatibility. Since GHC 6.12 we
+-- started using the native Unicode support in GHC but it
+-- uses different names for the code pages.
+renameEncoding :: String -> String
+renameEncoding "utf8"                      = "UTF-8"
+renameEncoding "latin1"                    = "CP1252"
+renameEncoding ('c':'p':s) | all isDigit s = 'C':'P':s
+renameEncoding s                           = s
+
+lookupShow :: Eq a => [(String,a)] -> a -> String
+lookupShow xs z = fromMaybe "lookupShow" $ lookup z [(y,x) | (x,y) <- xs]
+
+lookupReadsPrec :: [(String,a)] -> Int -> ReadS a
+lookupReadsPrec xs _ s = [(z,rest) | (x,rest) <- lex s, (y,z) <- xs, y == x]
+
+onOff :: Fail.MonadFail m => (Bool -> m a) -> Bool -> ArgDescr (m a)
+onOff f def = OptArg g "[on,off]"
+  where g ma = maybe (return def) readOnOff ma >>= f
+        readOnOff x = case map toLower x of
+                        "on"  -> return True
+                        "off" -> return False
+                        _     -> fail $ "Expected [on,off], got: " ++ show x
+
+readOutputFormat :: Fail.MonadFail m => String -> m OutputFormat
+readOutputFormat s =
+    maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats
+
+-- FIXME: this is a copy of the function in GF.Devel.UseIO.
+splitInModuleSearchPath :: String -> [FilePath]
+splitInModuleSearchPath s = case break isPathSep s of
+  (f,_:cs) -> f : splitInModuleSearchPath cs
+  (f,_)    -> [f]
+  where
+    isPathSep :: Char -> Bool
+    isPathSep c = c == ':' || c == ';'
+
+--
+-- * Convenience functions for checking options
+--
+
+verbAtLeast :: Options -> Verbosity -> Bool
+verbAtLeast opts v = flag optVerbosity opts >= v
+
+dump :: Options -> Dump -> Bool
+dump opts d = flag ((d `elem`) . optDump) opts
+
+cfgTransform :: Options -> CFGTransform -> Bool
+cfgTransform opts t = Set.member t (flag optCFGTransforms opts)
+
+haskellOption :: Options -> HaskellOption -> Bool
+haskellOption opts o = Set.member o (flag optHaskellOptions opts)
+
+isLiteralCat :: Options -> Ident -> Bool
+isLiteralCat opts c = Set.member c (flag optLiteralCats opts)
+
+isLexicalCat :: Options -> String -> Bool
+isLexicalCat opts c = Set.member c (flag optLexicalCats opts)
+
+--
+-- * Convenience functions for setting options
+--
+
+setOptimization :: Optimization -> Bool -> Options
+setOptimization o b = modifyFlags (setOptimization' o b)
+
+setOptimization' :: Optimization -> Bool -> Flags -> Flags
+setOptimization' o b f = f { optOptimizations = toggle o b (optOptimizations f)}
+
+setCFGTransform :: CFGTransform -> Bool -> Options
+setCFGTransform t b = modifyFlags (setCFGTransform' t b)
+
+setCFGTransform' :: CFGTransform -> Bool -> Flags -> Flags
+setCFGTransform' t b f = f { optCFGTransforms = toggle t b (optCFGTransforms f) }
+
+toggle :: Ord a => a -> Bool -> Set a -> Set a
+toggle o True  = Set.insert o
+toggle o False = Set.delete o
+
+--
+-- * General utilities
+--
+
+readMaybe :: Read a => String -> Maybe a
+readMaybe s = case reads s of
+                [(x,"")] -> Just x
+                _        -> Nothing
+
+toEnumBounded :: (Bounded a, Enum a, Ord a) => Int -> Maybe a
+toEnumBounded i = let mi = minBound
+                      ma = maxBound `asTypeOf` mi
+                   in if i >= fromEnum mi && i <= fromEnum ma
+                        then Just (toEnum i `asTypeOf` mi)
+                        else Nothing
+
+splitBy :: (a -> Bool) -> [a] -> [[a]]
+splitBy _ [] = []
+splitBy p s = case break p s of
+                (l, _ : t@(_ : _)) -> l : splitBy p t
+                (l, _) -> [l]
+
+instance Functor OptDescr where
+    fmap f (Option cs ss d s) = Option cs ss (fmap f d) s
+
+instance Functor ArgDescr where
+    fmap f (NoArg x)    = NoArg (f x)
+    fmap f (ReqArg g s) = ReqArg (f . g) s
+    fmap f (OptArg g s) = OptArg (f . g) s

src/compiler/api/GF/Infra/SIO.hs

@@ -0,0 +1,145 @@
+-- | Shell IO: a monad that can restrict acesss to arbitrary IO and has the
+-- ability to capture output that normally would be sent to stdout.
+{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-}
+module GF.Infra.SIO(
+       -- * The SIO monad
+       SIO,MonadSIO(..),
+       -- * Running SIO operations
+       runSIO,hRunSIO,captureSIO,
+       -- * Unrestricted, safe operations
+       -- ** From the standard libraries
+       getCPUTime,getCurrentDirectory,getLibraryDirectory,
+       newStdGen,print,putStr,putStrLn,
+       -- ** Specific to GF
+       importGrammar,importSource, link,
+       putStrLnFlush,runInterruptibly,
+       modifyPGF, checkoutPGF,
+       startTransaction, commitTransaction, rollbackTransaction,
+       inTransaction,
+       -- * Restricted accesss to arbitrary (potentially unsafe) IO operations
+       -- | If the environment variable GF_RESTRICTED is defined, these
+       -- operations will fail. Otherwise, they will be executed normally.
+       -- Output to stdout will /not/ be captured or redirected.
+       restricted,restrictedSystem
+  ) where
+import Prelude hiding (putStr,putStrLn,print)
+import Control.Applicative(Applicative(..))
+import Control.Monad(liftM,ap)
+import Control.Monad.Trans(MonadTrans(..))
+import System.IO(hPutStr,hFlush,stdout)
+import System.IO.Error(isUserError,ioeGetErrorString)
+import GF.System.Catch(try)
+import System.Process(system)
+import System.Environment(getEnv)
+import Control.Concurrent.Chan(newChan,writeChan,getChanContents)
+import GF.Infra.UseIO(Output(..))
+import GF.Data.Operations(ErrorMonad(..))
+import qualified System.CPUTime as IO(getCPUTime)
+import qualified System.Directory as IO(getCurrentDirectory)
+import qualified System.Random as IO(newStdGen)
+import qualified GF.Infra.UseIO as IO(getLibraryDirectory)
+import qualified GF.System.Signal as IO(runInterruptibly)
+import qualified GF.Command.Importing as GF(importGrammar, importSource)
+import qualified GF.Compile as GF(link)
+import qualified Control.Monad.Fail as Fail
+import qualified PGF2.Transactions as PGFT
+import Control.Exception
+
+-- * The SIO monad
+
+type PutStr = String -> IO ()
+newtype SIO a = SIO {unS::PutStr->IO a}
+
+instance Functor SIO where fmap = liftM
+
+instance Applicative SIO where
+  pure = return
+  (<*>) = ap
+
+instance Monad SIO where
+  return x = SIO (const (return x))
+  SIO m1 >>= xm2 = SIO $ \ h -> m1 h >>= \ x -> unS (xm2 x) h
+
+instance Fail.MonadFail SIO where
+  fail = lift0 . fail
+
+instance Output SIO where
+  ePutStr = lift0 . ePutStr
+  ePutStrLn = lift0 . ePutStrLn
+  putStrLnE = putStrLnFlush
+  putStrE = putStr
+
+instance ErrorMonad SIO where
+  raise = fail
+  handle m h = SIO $ \putStr ->
+                 catch (unS m putStr) $
+                    \e -> if isUserError e
+                            then unS (h (ioeGetErrorString e)) putStr
+                            else ioError e
+
+class {- Monad m => -} MonadSIO m where liftSIO :: SIO a -> m a
+-- ^ If the Monad m superclass is included, then the generic instance
+-- for monad transformers below would require UndecidableInstances
+
+instance MonadSIO SIO where liftSIO = id
+
+instance (MonadTrans t,Monad m,MonadSIO m) => MonadSIO (t m) where
+  liftSIO = lift . liftSIO
+
+-- * Running SIO operations
+
+-- | Run normally
+runSIO           = hRunSIO stdout
+
+-- | Redirect 'stdout' to the given handle
+hRunSIO h sio    = unS sio (\s->hPutStr h s>>hFlush h)
+
+-- | Capture 'stdout'
+captureSIO :: SIO a -> IO (String,a)
+captureSIO sio   = do ch <- newChan
+                      result <- unS sio (writeChan ch . Just)
+                      writeChan ch Nothing
+                      output <- fmap takeJust (getChanContents ch)
+                      return (output,result)
+                   where
+                     takeJust (Just xs:ys) = xs++takeJust ys
+                     takeJust _ = []
+
+-- * Restricted accesss to arbitrary (potentially unsafe) IO operations
+
+restricted io    = SIO (const (restrictedIO io))
+restrictedSystem = restricted . system
+
+restrictedIO io =
+    either (const io) (const $ fail message) =<< GF.System.Catch.try (getEnv "GF_RESTRICTED")
+  where
+    message =
+      "This operation is not allowed when GF is running in restricted mode."
+
+-- * Unrestricted, safe IO operations
+
+lift0 io         = SIO $ const io
+lift1 f io       = SIO $ f . unS io
+
+putStr           = putStrFlush
+putStrFlush s    = SIO ($ s)
+putStrLn         = putStrLnFlush
+putStrLnFlush s  = putStr s >> putStrFlush "\n"
+print x          = putStrLn (show x)
+
+getCPUTime           = lift0   IO.getCPUTime
+getCurrentDirectory  = lift0   IO.getCurrentDirectory
+getLibraryDirectory  = lift0 . IO.getLibraryDirectory
+newStdGen            = lift0   IO.newStdGen
+runInterruptibly     = lift1   IO.runInterruptibly
+
+importGrammar readNGF pgf opts files = lift0 $ GF.importGrammar readNGF pgf opts files
+importSource      opts files = lift0 $ GF.importSource      opts files
+link opts pgf src = lift0 $ GF.link opts pgf src
+
+modifyPGF   gr t = lift0 (PGFT.modifyPGF gr t)
+checkoutPGF gr = lift0 (PGFT.checkoutPGF gr)
+startTransaction gr = lift0 (PGFT.startTransaction gr)
+commitTransaction tr = lift0 (PGFT.commitTransaction tr)
+rollbackTransaction tr = lift0 (PGFT.rollbackTransaction tr)
+inTransaction tr f = lift0 (PGFT.inTransaction tr f)

src/compiler/api/GF/Infra/UseIO.hs

@@ -0,0 +1,273 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : UseIO
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/08/08 09:01:25 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.17 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Infra.UseIO(-- ** Files and IO
+                      module GF.Infra.UseIO,
+                      -- *** Reused
+                      MonadIO(..),liftErr) where
+
+import Prelude hiding (catch)
+
+import GF.Data.Operations
+import GF.Infra.Option
+import GF.System.Catch
+import Paths_gf(getDataDir)
+
+import GF.System.Directory
+import GF.System.Console
+import GF.Text.Pretty
+import System.FilePath
+import System.IO
+import System.IO.Error(isUserError,ioeGetErrorString)
+import System.Environment
+import System.Exit
+import System.CPUTime
+import Text.Printf
+import Control.Monad(when,liftM,foldM)
+import Control.Monad.Trans(MonadIO(..))
+import Control.Monad.State(StateT,lift)
+import Control.Exception(evaluate)
+
+--putIfVerb :: MonadIO io => Options -> String -> io ()
+putIfVerb opts msg = when (verbAtLeast opts Verbose) $ putStrLnE msg
+
+-- *** GF files path and library path manipulation
+
+type FileName = String
+type InitPath = String -- ^ the directory portion of a pathname
+type FullPath = String
+
+gfLibraryPath    = "GF_LIB_PATH"
+gfGrammarPathVar = "GF_GRAMMAR_PATH"
+
+getLibraryDirectory :: MonadIO io => Options -> io FilePath
+getLibraryDirectory opts =
+  case flag optGFLibPath opts of
+    Just path -> return path
+    Nothing   -> liftIO $ catch (getEnv gfLibraryPath)
+                                (\ex -> fmap (</> "lib") getDataDir)
+
+getGrammarPath :: MonadIO io => FilePath -> io [FilePath]
+getGrammarPath lib_dir = liftIO $ do
+  catch (fmap splitSearchPath $ getEnv gfGrammarPathVar) 
+        (\_ -> return [lib_dir </> "alltenses",lib_dir </> "prelude"])     -- e.g. GF_GRAMMAR_PATH
+
+-- | extends the search path with the
+-- 'gfLibraryPath' and 'gfGrammarPathVar'
+-- environment variables. Returns only existing paths.
+extendPathEnv :: MonadIO io => Options -> io [FilePath]
+extendPathEnv opts = liftIO $ do
+  let opt_path = flag optLibraryPath opts         -- e.g. paths given as options
+  lib_dir  <- getLibraryDirectory opts                  -- e.g. GF_LIB_PATH
+  grm_path <- getGrammarPath lib_dir                   -- e.g. GF_GRAMMAR_PATH
+  let paths = opt_path ++ [lib_dir] ++ grm_path
+  ps <- liftM concat $ mapM allSubdirs paths
+  mapM canonicalizePath ps
+  where
+    allSubdirs :: FilePath -> IO [FilePath]
+    allSubdirs [] = return [[]]
+    allSubdirs p = case last p of
+      '*' -> do let path = init p
+                fs <- getSubdirs path
+                return [path </> f | f <- fs]
+      _   -> do exists <- doesDirectoryExist p
+                if exists
+                  then return [p]
+                  else do when (verbAtLeast opts Verbose) $ putStrLn ("ignore path "++p)
+                          return []
+
+getSubdirs :: FilePath -> IO [FilePath]
+getSubdirs dir = do
+  fs  <- catch (getDirectoryContents dir) (const $ return [])
+  foldM (\fs f -> do let fpath = dir </> f
+                     p <- getPermissions fpath
+                     if searchable p && not (take 1 f==".")
+                       then return (fpath:fs)
+                       else return        fs ) [] fs
+
+--------------------------------------------------------------------------------
+justModuleName :: FilePath -> String
+justModuleName = dropExtension . takeFileName
+
+isGF,isGFO :: FilePath -> Bool
+isGF  = (== ".gf")  . takeExtensions
+isGFO = (== ".gfo") . takeExtensions
+
+gfFile,gfoFile :: FilePath -> FilePath
+gfFile  f = addExtension f "gf"
+gfoFile f = addExtension f "gfo"
+
+gf2gfo :: Options -> FilePath -> FilePath
+gf2gfo = gf2gfo' . flag optGFODir
+
+gf2gfo' gfoDir file = maybe (gfoFile (dropExtension file))
+                            (\dir -> dir </> gfoFile (takeBaseName file))
+                            gfoDir
+--------------------------------------------------------------------------------
+splitInModuleSearchPath :: String -> [FilePath]
+splitInModuleSearchPath s = case break isPathSep s of
+  (f,_:cs) -> f : splitInModuleSearchPath cs
+  (f,_)    -> [f]
+  where
+    isPathSep :: Char -> Bool
+    isPathSep c = c == ':' || c == ';'
+
+--
+
+-- *** Error handling in the IO monad
+
+-- | Was: @newtype IOE a = IOE { appIOE :: IO (Err a) }@
+type IOE a = IO a
+
+--ioe :: IO (Err a) -> IOE a
+--ioe io = err fail return =<< io
+
+-- | Catch exceptions caused by calls to 'raise' or 'fail' in the 'IO' monad.
+-- To catch all 'IO' exceptions, use 'try' instead.
+tryIOE :: IOE a -> IO (Err a)
+tryIOE ioe = handle (fmap Ok ioe) (return . Bad)
+
+--runIOE :: IOE a -> IO a
+--runIOE = id
+
+-- instance MonadIO IOE where liftIO io = ioe (io >>= return . return)
+
+-- | Make raise and handle mimic behaviour of the old IOE monad
+instance ErrorMonad IO where
+  raise = fail
+  handle m h = catch m $ \ e -> if isUserError e
+                                then h (ioeGetErrorString e)
+                                else ioError e
+{-
+-- Control.Monad.Fail import will become redundant in GHC 8.8+
+import qualified Control.Monad.Fail as Fail
+
+instance Functor IOE where fmap = liftM
+
+instance Applicative IOE where
+  pure = return
+  (<*>) = ap
+
+instance  Monad IOE where
+  return a    = ioe (return (return a))
+  IOE c >>= f = IOE $ do 
+                  x <- c          -- Err a
+                  appIOE $ err raise f x         -- f :: a -> IOE a
+
+ #if !(MIN_VERSION_base(4,13,0))
+  fail = raise
+ #endif
+
+instance Fail.MonadFail IOE where
+  fail = raise
+
+
+-}
+
+-- | Print the error message and return a default value if the IO operation 'fail's
+useIOE :: a -> IOE a -> IO a
+useIOE a ioe = handle ioe (\s -> putStrLn s >> return a)
+
+maybeIO io = either (const Nothing) Just `fmap` liftIO (try io)
+{-
+--foldIOE :: (a -> b -> IOE a) -> a -> [b] -> IOE (a, Maybe String)
+foldIOE f s xs = case xs of
+  [] -> return (s,Nothing)
+  x:xx -> do
+    ev <- liftIO $ appIOE (f s x) 
+    case ev of 
+      Ok v  -> foldIOE f v xx
+      Bad m -> return $ (s, Just m)
+-}
+die :: String -> IO a
+die s = do hPutStrLn stderr s
+           exitFailure
+
+-- *** Diagnostic output
+
+class Monad m => Output m where
+  ePutStr, ePutStrLn, putStrE, putStrLnE :: String -> m ()
+
+instance Output IO where
+  ePutStr   s = hPutStr stderr s `catch` oops
+    where oops _ = return () -- prevent crash on character encoding problem
+  ePutStrLn s = hPutStrLn stderr s `catch` oops
+    where oops _ = ePutStrLn "" -- prevent crash on character encoding problem
+  putStrLnE s = putStrLn s >> hFlush stdout
+  putStrE   s = putStr s >> hFlush stdout
+{-
+instance Output IOE where
+  ePutStr   = liftIO . ePutStr
+  ePutStrLn = liftIO . ePutStrLn
+  putStrLnE = liftIO . putStrLnE
+  putStrE   = liftIO . putStrE
+-}
+
+instance Output m => Output (StateT s m) where
+  ePutStr = lift . ePutStr
+  ePutStrLn = lift . ePutStrLn
+  putStrE = lift . putStrE
+  putStrLnE = lift . putStrLnE
+
+--putPointE :: Verbosity -> Options -> String -> IO a -> IO a
+putPointE v opts msg act = do
+  when (verbAtLeast opts v) $ putStrE msg
+
+  (t,a) <- timeIt act
+
+  if flag optShowCPUTime opts
+      then do let msec = t `div` 1000000000
+              putStrLnE (printf " %5d msec" msec)
+      else when (verbAtLeast opts v) $ putStrLnE ""
+
+  return a
+
+dumpOut opts pass doc
+  | dump opts d = ePutStrLn (render ("\n\n--#" <+> show d $$ doc))
+  | otherwise   = return ()
+  where
+    d   = (Dump pass)
+
+warnOut opts warnings
+  | null warnings = return ()
+  | otherwise     = do t <- getTermColors
+                       ePutStr (blueFg t);ePutStr ws;ePutStrLn (restore t)
+  where
+    ws = if flag optVerbosity opts == Normal
+         then '\n':warnings
+         else warnings
+
+-- | Because GHC adds the confusing text "user error" for failures caused by
+-- calls to 'fail'.
+ioErrorText e = if isUserError e
+                then ioeGetErrorString e
+                else show e
+
+-- *** Timing
+
+timeIt act =
+  do t1 <- liftIO $ getCPUTime
+     a <- liftIO . evaluate =<< act
+     t2 <- liftIO $ getCPUTime
+     return (t2-t1,a)
+
+-- *** File IO
+
+writeUTF8File :: FilePath -> String -> IO ()
+writeUTF8File fpath content =
+  withFile fpath WriteMode $ \ h -> do hSetEncoding h utf8
+                                       hPutStr h content
+
+readBinaryFile path = hGetContents =<< openBinaryFile path ReadMode
+writeBinaryFile path s = withBinaryFile path WriteMode (flip hPutStr s)

src/compiler/api/GF/Interactive.hs

@@ -0,0 +1,601 @@
+{-# LANGUAGE CPP, ScopedTypeVariables, FlexibleInstances #-}
+-- | GF interactive mode
+module GF.Interactive (mainGFI,mainRunGFI,mainServerGFI) where
+
+import Prelude hiding (putStrLn,print)
+import qualified Prelude as P(putStrLn)
+import GF.Command.Interpreter(CommandEnv(..),mkCommandEnv,interpretCommandLine)
+import GF.Command.Commands(HasPGF(..),pgfCommands)
+import GF.Command.CommonCommands(commonCommands,extend)
+import GF.Command.SourceCommands
+import GF.Command.CommandInfo
+import GF.Command.Help(helpCommand)
+import GF.Command.Abstract
+import GF.Command.Parse(readCommandLine,pCommand,readTransactionCommand)
+import GF.Compile.Rename(renameSourceTerm)
+import GF.Compile.TypeCheck.Concrete(inferLType)
+import GF.Compile.TypeCheck.Primitives(predefMod)
+import GF.Compile.GeneratePMCFG(pmcfgForm,type2fields)
+import GF.Data.Operations (Err(..))
+import GF.Data.Utilities(whenM,repeatM)
+import GF.Grammar hiding (Ident,isPrefixOf)
+import GF.Infra.UseIO(ioErrorText,putStrLnE)
+import GF.Infra.SIO
+import GF.Infra.Option
+import GF.Infra.CheckM
+import qualified System.Console.Haskeline as Haskeline
+
+import PGF2
+import PGF2.Transactions hiding (modifyPGF,checkoutPGF,
+                                 startTransaction,
+                                 commitTransaction,rollbackTransaction,
+                                 inTransaction)
+
+import Data.Char
+import Data.List(isPrefixOf,sortOn)
+import qualified Data.Map as Map
+import qualified Data.Sequence as Seq
+import qualified Text.ParserCombinators.ReadP as RP
+import System.Directory(getAppUserDataDirectory)
+import Control.Exception(SomeException,fromException,evaluate,try)
+import Control.Monad.State hiding (void)
+import qualified GF.System.Signal as IO(runInterruptibly)
+import GF.Command.Messages(welcome)
+#ifdef SERVER_MODE
+import GF.Server(server)
+#endif
+
+type ReadNGF = FilePath -> IO PGF
+
+-- | Run the GF Shell in quiet mode (@gf -run@).
+mainRunGFI :: Options -> [FilePath] -> IO ()
+mainRunGFI opts files = shell (beQuiet opts) files
+
+beQuiet = addOptions (modifyFlags (\f -> f{optVerbosity=Quiet}))
+
+-- | Run the interactive GF Shell
+mainGFI :: Options -> [FilePath] -> IO ()
+mainGFI opts files = do
+  P.putStrLn welcome
+  shell opts files
+
+shell opts files =
+  flip evalStateT (emptyGFEnv opts) $
+  do mapStateT runSIO $ importInEnv readNGF opts files
+     modify $ \ gfenv0 -> gfenv0 {history = [unwords ("i":files)]}
+     repeatM (mapStateT runSIO . execute1 readNGF =<< readCommand)
+
+
+#ifdef SERVER_MODE
+-- | Run the GF Server (@gf -server@).
+-- The 'Int' argument is the port number for the HTTP service.
+mainServerGFI opts0 port files =
+  server jobs port root init execute
+  where
+    root = flag optDocumentRoot opts
+    opts = beQuiet opts0
+    jobs = join (flag optJobs opts)
+
+    init readNGF = do
+      (_, gfenv) <- runSIO (runStateT (importInEnv readNGF opts files) (emptyGFEnv opts))
+      return gfenv
+
+    execute readNGF gfenv0 cmd = do
+      (continue,gfenv) <- runStateT (execute1 readNGF cmd) gfenv0
+      return $ if continue then Just gfenv else Nothing
+
+#else
+mainServerGFI opts port files =
+  fail "GF has not been compiled with server mode support"
+#endif
+
+-- | Read a command
+readCommand :: StateT GFEnv IO String
+readCommand =
+  do opts <- gets startOpts
+     case flag optMode opts of
+       ModeRun -> lift tryGetLine
+       _       -> do gfenv <- get
+                     s <- lift (fetchCommand gfenv)
+                     put $ gfenv {history = s : history gfenv}
+                     return s
+
+timeIt act =
+  do t1 <- liftSIO $ getCPUTime
+     a <-  act
+     t2 <- liftSIO $ getCPUTime
+     return (t2-t1,a)
+
+-- | Optionally show how much CPU time was used to run an IO action
+optionallyShowCPUTime :: (Monad m,MonadSIO m) => Options -> m a -> m a
+optionallyShowCPUTime opts act
+  | not (verbAtLeast opts Normal) = act
+  | otherwise = do (dt,r) <- timeIt act
+                   liftSIO $ putStrLnFlush $ show (dt `div` 1000000000) ++ " msec"
+                   return r
+
+
+type ShellM = StateT GFEnv SIO
+
+-- | Execute a given command line, returning 'True' to continue execution,
+-- | 'False' when it is time to quit
+execute1 :: ReadNGF -> String -> ShellM Bool
+execute1 readNGF s0 =
+  do opts <- gets startOpts
+     interruptible $ optionallyShowCPUTime opts $
+       case pwords s0 of
+      -- cc, sd, so, ss and dg are now in GF.Commands.SourceCommands
+      -- special commands
+         "q" :_   -> quit
+         "!" :ws  -> system_command ws
+         "eh":ws  -> execute_history ws
+         "i" :ws  -> do import_ readNGF ws; continue
+         "r" :_   -> do gfenv0 <- get
+                        let imports = [(s,ws) | s <- history gfenv0, ("i":ws) <- [pwords s]]
+                        case imports of
+                          (s,ws):_ -> do
+                            putStrLnE $ "repeating latest import: " ++ s
+                            import_ readNGF ws
+                            continue
+                          _ -> do putStrLnE $ "no import in history"
+                                  continue
+         (w  :ws) | elem w ["c","a","d"] -> do
+                        case readTransactionCommand s0 of
+                          Just cmd -> do checkout
+                                         env <- gets pgfenv
+                                         case env of
+                                           (_,Just pgf,mb_txnid) -> transactionCommand cmd pgf mb_txnid
+                                           _                     -> fail "Import a grammar before using this command"
+                          Nothing  -> putStrLnE $ "command not parsed: "++s0
+                        continue
+                  | w == "t" -> do
+                        env <- gets pgfenv
+                        case env of
+                          (gr,Just pgf,mb_txnid) ->
+                              case ws of
+                                ["start"]     ->
+                                    case mb_txnid of
+                                      Just _  -> fail "You have already started a transaction"
+                                      Nothing -> do txnid <- lift $ startTransaction pgf
+                                                    modify (\gfenv -> gfenv{pgfenv=(gr,Just pgf,Just txnid)})
+                                ["commit"]    ->
+                                    case mb_txnid of
+                                      Just id -> do lift $ commitTransaction id
+                                                    modify (\gfenv -> gfenv{pgfenv=(gr,Just pgf,Nothing)})
+                                      Nothing -> fail "There is no active transaction"
+                                ["rollback"]  ->
+                                    case mb_txnid of
+                                      Just id -> do lift $ rollbackTransaction id
+                                                    modify (\gfenv -> gfenv{pgfenv=(gr,Just pgf,Nothing)})
+                                      Nothing -> fail "There is no active transaction"
+                                []            -> fail "The transaction command expects start, commit or rollback as an argument"
+                                _             -> fail "The only arguments to the transaction command are start, commit and rollback"
+                          _                   -> fail "Import a grammar before using this command"
+                        continue
+                                           
+      -- other special commands, working on GFEnv
+         "dc":ws  -> define_command ws
+         "dt":ws  -> define_tree ws
+      -- ordinary commands
+         _        -> do env <- gets commandenv
+                        checkout
+                        interpretCommandLine env s0
+                        continue
+  where
+    continue,stop :: ShellM Bool
+    continue = return True
+    stop = return False
+
+    checkout = do
+      gfenv <- get
+      case pgfenv gfenv of
+        (gr,Just pgf,Nothing) -> do pgf <- lift $ checkoutPGF pgf
+                                    put (gfenv{pgfenv = (gr,Just pgf,Nothing)})
+        _                     -> return ()
+
+    interruptible :: ShellM Bool -> ShellM Bool
+    interruptible act =
+      do gfenv <- get
+         mapStateT (
+           either (\e -> printException e >> return (True,gfenv)) return
+             <=< runInterruptibly) act
+
+  -- Special commands:
+
+    quit = do
+      env <- gets pgfenv
+      case env of
+        (_,_,Just _) -> fail "Commit or rollback the transaction first!"
+        _            -> do opts <- gets startOpts
+                           when (verbAtLeast opts Normal) $ putStrLnE "See you."
+                           stop
+
+    system_command ws = do lift $ restrictedSystem $ unwords ws ; continue
+
+    execute_history [w] =
+      do execute . lines =<< lift (restricted (readFile w))
+         continue
+      where
+        execute []           = return ()
+        execute (line:lines) = whenM (execute1 readNGF line) (execute lines)
+
+    execute_history _   =
+       do putStrLnE "eh command not parsed"
+          continue
+
+    define_command (f:ws) =
+        case readCommandLine (unwords ws) of
+           Just comm ->
+             do modify $
+                  \ gfenv ->
+                    let env = commandenv gfenv
+                    in gfenv {
+                         commandenv = env {
+                           commandmacros = Map.insert f comm (commandmacros env)
+                         }
+                       }
+                continue
+           _ -> dc_not_parsed
+    define_command _ = dc_not_parsed
+
+    dc_not_parsed = putStrLnE "command definition not parsed" >> continue
+
+    define_tree (f:ws) =
+        case readExpr (unwords ws) of
+          Just exp ->
+           do modify $
+                \ gfenv ->
+                  let env = commandenv gfenv
+                  in gfenv { commandenv = env {
+                               expmacros = Map.insert f exp (expmacros env) } }
+              continue
+          _ -> dt_not_parsed
+    define_tree _ = dt_not_parsed
+
+    dt_not_parsed = putStrLnE "value definition not parsed" >> continue
+
+pwords s = case words s of
+             w:ws -> getCommandOp w :ws
+             ws -> ws
+
+import_ readNGF args =
+  do case parseOptions args of
+       Ok (opts',files) -> do
+         opts <- gets startOpts
+         curr_dir <- lift getCurrentDirectory
+         lib_dir  <- lift $ getLibraryDirectory (addOptions opts opts')
+         importInEnv readNGF (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files
+       Bad err -> putStrLnE $ "Command parse error: " ++ err
+
+transactionCommand :: TransactionCommand -> PGF -> Maybe TxnID -> ShellM ()
+transactionCommand (CreateFun opts f ty) pgf mb_txnid = do
+  let prob = realToFrac (valFltOpts "prob" (1/0) opts)
+  case checkType pgf ty of
+    Left msg -> putStrLnE msg
+    Right ty -> do lift $ updatePGF pgf mb_txnid (createFunction f ty 0 [] prob >> return ())
+                   return ()
+transactionCommand (CreateCat opts c ctxt) pgf mb_txnid = do
+  let prob = realToFrac (valFltOpts "prob" (1/0) opts)
+  case checkContext pgf ctxt of
+    Left msg -> putStrLnE msg
+    Right ty -> do lift $ updatePGF pgf mb_txnid (createCategory c ctxt prob)
+                   return ()
+transactionCommand (CreateConcrete opts name) pgf mb_txnid = do
+  lift $ updatePGF pgf mb_txnid (createConcrete name (return ()))
+  return ()
+transactionCommand (CreateLin opts f t is_alter) pgf mb_txnid = do
+  sgr0 <- getGrammar
+  let (sgr,mo) = case greatestResource sgr0 of
+                   Nothing -> (mGrammar [predefMod], fst predefMod)
+                   Just mo -> (sgr0,mo)
+  lang <- optLang pgf opts
+  lift $ updatePGF pgf mb_txnid $ do
+    mb_ty <- getFunctionType f
+    case mb_ty of
+      Just ty@(DTyp _ cat _) -> 
+         alterConcrete lang $ do
+           mb_fields <- getCategoryFields cat
+           case mb_fields of
+             Just fields -> case runCheck (compileLinTerm sgr mo t (type2term mo ty)) of
+                              Ok ((prods,seqtbl,fields'),_)
+                                   | fields == fields' -> do
+                                       (if is_alter then alterLin else createLin) f prods seqtbl
+                                       return ()
+                                   | otherwise -> fail "The linearization categories in the resource and the compiled grammar does not match"
+                              Bad msg      -> fail msg
+             Nothing     -> fail ("Category "++cat++" is not in the concrete syntax")
+      _ -> fail ("Function "++f++" is not in the abstract syntax")
+  where
+    type2term mo (DTyp hypos cat _) =
+      foldr (\(b,x,ty1) ty2 -> Prod b (identS x) (type2term mo ty1) ty2)
+            (Vr (identS cat))
+            hypos
+
+    compileLinTerm sgr mo t ty = do
+      t  <- renameSourceTerm sgr mo (Typed t ty)
+      (t,ty) <- inferLType sgr [] t
+      let (ctxt,res_ty) = typeFormCnc ty
+      (prods,seqs) <- pmcfgForm sgr t ctxt res_ty Map.empty
+      return (prods,mapToSequence seqs,type2fields sgr res_ty)
+      where
+        mapToSequence m = Seq.fromList (map (Left . fst) (sortOn snd (Map.toList m)))
+
+transactionCommand (CreateLincat opts c t) pgf mb_txnid = do
+  sgr0 <- getGrammar
+  let (sgr,mo) = case greatestResource sgr0 of
+                   Nothing -> (mGrammar [predefMod], fst predefMod)
+                   Just mo -> (sgr0,mo)
+  lang <- optLang pgf opts
+  case runCheck (compileLincatTerm sgr mo t) of
+    Ok (fields,_)-> do lift $ updatePGF pgf mb_txnid (alterConcrete lang (createLincat c fields [] [] Seq.empty >> return ()))
+                       return ()
+    Bad msg      -> fail msg
+  where
+    compileLincatTerm sgr mo t = do
+      t <- renameSourceTerm sgr mo t
+      (t,_) <- inferLType sgr [] t
+      return (type2fields sgr t)
+transactionCommand (DropFun opts f) pgf mb_txnid = do
+  lift $ updatePGF pgf mb_txnid (dropFunction f)
+  return ()
+transactionCommand (DropCat opts c) pgf mb_txnid = do
+  lift $ updatePGF pgf mb_txnid (dropCategory c)
+  return ()
+transactionCommand (DropConcrete opts name) pgf mb_txnid = do
+  lift $ updatePGF pgf mb_txnid (dropConcrete name)
+  return ()
+transactionCommand (DropLin opts f) pgf mb_txnid = do
+  lang <- optLang pgf opts
+  lift $ updatePGF pgf mb_txnid (alterConcrete lang (dropLin f))
+  return ()
+transactionCommand (DropLincat opts c) pgf mb_txnid = do
+  lang <- optLang pgf opts
+  lift $ updatePGF pgf mb_txnid (alterConcrete lang (dropLincat c))
+  return ()
+
+updatePGF pgf mb_txnid f = do
+  maybe (modifyPGF pgf f >> return ())
+                                 (\txnid -> inTransaction txnid f)
+                                 mb_txnid
+
+optLang pgf opts =
+  case Map.keys (languages pgf) of
+    [lang] -> completeLang (valStrOpts "lang" lang opts)
+    _      -> case valStrOpts "lang" "" opts of
+                ""   -> fail "Specify a language to change"
+                lang -> completeLang lang
+  where
+    langs = languages pgf
+
+    completeLang la
+      | Map.member la  langs = return la
+      | Map.member la' langs = return la'
+      | otherwise            = fail "Unknown language"
+      where
+        la' = abstractName pgf ++ la
+
+
+-- | Commands that work on 'GFEnv'
+moreCommands = [
+  ("e",  emptyCommandInfo {
+     longname = "empty",
+     synopsis = "empty the environment (except the command history)",
+     exec = \ _ _ ->
+            do modify $ \ gfenv -> (emptyGFEnv (startOpts gfenv))
+                                     { history=history gfenv }
+               return void
+     }),
+  ("ph", emptyCommandInfo {
+     longname = "print_history",
+     synopsis = "print command history",
+     explanation = unlines [
+       "Prints the commands issued during the GF session.",
+       "The result is readable by the eh command.",
+       "The result can be used as a script when starting GF."
+       ],
+     examples = [
+      mkEx "ph | wf -file=foo.gfs  -- save the history into a file"
+      ],
+     exec = \ _ _ ->
+            fmap (fromString . unlines . reverse . drop 1 . history) get
+     }),
+  ("r",  emptyCommandInfo {
+     longname = "reload",
+     synopsis = "repeat the latest import command"
+     })
+  ]
+
+
+printException e = maybe (print e) (putStrLn . ioErrorText) (fromException e)
+
+fetchCommand :: GFEnv -> IO String
+fetchCommand gfenv = do
+  path <- getAppUserDataDirectory "gf_history"
+  let settings =
+        Haskeline.Settings {
+          Haskeline.complete = wordCompletion gfenv,
+          Haskeline.historyFile = Just path,
+          Haskeline.autoAddHistory = True
+        }
+  res <- IO.runInterruptibly $ Haskeline.runInputT settings (Haskeline.getInputLine (prompt gfenv))
+  case res of
+    Left  _        -> return ""
+    Right Nothing  -> return "q"
+    Right (Just s) -> return s
+
+importInEnv :: ReadNGF -> Options -> [FilePath] -> ShellM ()
+importInEnv readNGF opts files =
+  do (_,pgf0,mb_txnid) <- gets pgfenv
+     case (flag optRetainResource opts,mb_txnid) of
+       (RetainAll,Nothing)      -> do src <- lift $ importSource opts files
+                                      pgf <- lift $ link opts pgf0 src
+                                      modify $ \gfenv -> gfenv{pgfenv = (snd src,Just pgf,Nothing)}
+       (RetainSource,mb_txn)    -> do src <- lift $ importSource opts files
+                                      modify $ \gfenv -> gfenv{pgfenv = (snd src,pgf0,mb_txn)}
+       (RetainCompiled,Nothing) -> do pgf <- lift $ importPGF pgf0
+                                      modify $ \gfenv -> gfenv{pgfenv = (emptyGrammar,pgf,Nothing)}
+       _ -> fail "You must commit/rollback the transaction before loading a new grammar"
+  where
+    importPGF pgf0 =
+      do let opts' = addOptions (setOptimization OptCSE False) opts
+         pgf1 <- importGrammar readNGF pgf0 opts' files
+         if (verbAtLeast opts Normal)
+           then case pgf1 of
+                  Just pgf -> putStrLnFlush $ unwords $ "\nLanguages:" : Map.keys (languages pgf)
+                  Nothing  -> return ()
+           else return ()
+         return pgf1
+
+tryGetLine = do
+  res <- try getLine
+  case res of
+   Left (e :: SomeException) -> return "q"
+   Right l -> return l
+
+prompt env = 
+  case pgfenv env of
+    (_,mb_pgf,mb_tr) -> 
+         maybe "" abstractName mb_pgf ++ 
+         maybe "" (const " (transaction)") mb_tr ++
+         "> "
+
+type CmdEnv = (Grammar,Maybe PGF,Maybe TxnID)
+
+data GFEnv = GFEnv {
+    startOpts :: Options,
+    pgfenv :: CmdEnv,
+    commandenv :: CommandEnv ShellM,
+    history    :: [String]
+  }
+
+emptyGFEnv opts = GFEnv opts emptyCmdEnv emptyCommandEnv []
+
+emptyCmdEnv = (emptyGrammar,Nothing,Nothing)
+
+emptyCommandEnv = mkCommandEnv allCommands
+
+allCommands =
+  extend pgfCommands (helpCommand allCommands:moreCommands)
+  `Map.union` sourceCommands
+  `Map.union` commonCommands
+
+instance HasGrammar ShellM where
+  getGrammar = gets $ \gfenv ->
+    case pgfenv gfenv of
+      (gr,_,_) -> gr
+
+instance HasPGF ShellM where
+  getPGF = gets $ \gfenv ->
+    case pgfenv gfenv of
+      (_,mb_pgf,_) -> mb_pgf
+
+wordCompletion gfenv (left,right) = do
+  case wc_type (reverse left) of
+    CmplCmd pref
+      -> ret (length pref) [Haskeline.simpleCompletion name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name]
+    CmplStr (Just (Command _ opts _)) s0
+      -> case pgfenv gfenv of
+           (_,Just pgf,_) ->
+                       let langs = languages pgf
+                           optLang opts = case valStrOpts "lang" "" opts of
+                                            ""   -> case Map.minView langs of
+                                                      Nothing        -> Nothing
+                                                      Just (concr,_) -> Just concr
+                                            lang -> mplus (Map.lookup lang                       langs)
+                                                          (Map.lookup (abstractName pgf ++ lang) langs)
+                           optType opts = let readOpt str = case readType str of
+                                                              Just ty -> case checkType pgf ty of
+                                                                           Left _   -> Nothing
+                                                                           Right ty -> Just ty
+                                                              Nothing -> Nothing
+                                          in maybeStrOpts "cat" (Just (startCat pgf)) readOpt opts
+                           (rprefix,rs) = break isSpace (reverse s0)
+                           s            = reverse rs
+                           prefix       = reverse rprefix
+                       in case (optLang opts, optType opts) of
+                            (Just lang,Just cat) -> let compls = [t | ParseOk res <- [complete lang cat s prefix], (t,_,_,_) <- res]
+                                                    in ret (length prefix) (map Haskeline.simpleCompletion compls)
+                            _                    -> ret 0 []
+           _        -> ret 0 []
+    CmplOpt (Just (Command n _ _)) pref
+      -> case Map.lookup n (commands cmdEnv) of
+           Just inf -> do let flg_compls = [Haskeline.Completion ('-':flg++"=") ('-':flg) False | (flg,_) <- flags   inf, isPrefixOf pref flg]
+                              opt_compls = [Haskeline.Completion ('-':opt)      ('-':opt) True | (opt,_) <- options inf, isPrefixOf pref opt]
+                          ret (length pref+1)
+                              (flg_compls++opt_compls)
+           Nothing  -> ret (length pref) []
+    CmplIdent (Just (Command "i" _ _)) _        -- HACK: file name completion for command i
+      -> Haskeline.completeFilename (left,right)
+    CmplIdent _ pref
+      -> case pgfenv gfenv of
+           (_,Just pgf,_) -> ret (length pref) [Haskeline.simpleCompletion name | name <- functionsByPrefix pgf pref]
+           _              -> ret (length pref) []
+    _ -> ret 0 []
+  where
+    cmdEnv = commandenv gfenv
+
+    loop ps []     = Just ps
+    loop ps (t:ts) = case error "nextState ps (simpleParseInput t)" of
+                       Left  es -> Nothing
+                       Right ps -> loop ps ts
+
+    ret len xs  = return (drop len left,xs)
+
+
+data CompletionType
+  = CmplCmd                   Ident
+  | CmplStr   (Maybe Command) String
+  | CmplOpt   (Maybe Command) Ident
+  | CmplIdent (Maybe Command) Ident
+  deriving Show
+
+wc_type :: String -> CompletionType
+wc_type = cmd_name
+  where
+    cmd_name cs =
+      let cs1 = dropWhile isSpace cs
+      in go cs1 cs1
+      where
+        go x []       = CmplCmd x
+        go x (c:cs)
+          | isIdent c = go x cs
+          | otherwise = cmd x cs
+
+    cmd x []       = ret CmplIdent x "" 0
+    cmd _ ('|':cs) = cmd_name cs
+    cmd _ (';':cs) = cmd_name cs
+    cmd x ('"':cs) = str x cs cs
+    cmd x ('-':cs) = option x cs cs
+    cmd x (c  :cs)
+      | isIdent c  = ident x (c:cs) cs
+      | otherwise  = cmd x cs
+
+    option x y []       = ret CmplOpt x y 1
+    option x y ('=':cs) = optValue x y cs
+    option x y (c  :cs)
+      | isIdent c       = option x y cs
+      | otherwise       = cmd x cs
+
+    optValue x y ('"':cs) = str x y cs
+    optValue x y cs       = cmd x cs
+
+    ident x y []     = ret CmplIdent x y 0
+    ident x y (c:cs)
+      | isIdent c    = ident x y cs
+      | otherwise    = cmd x cs
+
+    str x y []          = ret CmplStr x y 1
+    str x y ('\"':cs)   = cmd x cs
+    str x y ('\\':c:cs) = str x y cs
+    str x y (c:cs)      = str x y cs
+
+    ret f x y d = f cmd y
+      where
+        x1 = take (length x - length y - d) x
+        x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1
+
+        cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of
+                [x] -> Just x
+                _   -> Nothing
+
+    isIdent c = c == '_' || c == '\'' || isAlphaNum c

src/compiler/api/GF/JavaScript/AbsJS.hs

@@ -0,0 +1,61 @@
+module GF.JavaScript.AbsJS where
+
+-- Haskell module generated by the BNF converter
+
+newtype Ident = Ident String deriving (Eq,Ord,Show)
+data Program =
+   Program [Element]
+  deriving (Eq,Ord,Show)
+
+data Element =
+   FunDef Ident [Ident] [Stmt]
+ | ElStmt Stmt
+  deriving (Eq,Ord,Show)
+
+data Stmt =
+   SCompound [Stmt]
+ | SReturnVoid
+ | SReturn Expr
+ | SDeclOrExpr DeclOrExpr
+  deriving (Eq,Ord,Show)
+
+data DeclOrExpr =
+   Decl [DeclVar]
+ | DExpr Expr
+  deriving (Eq,Ord,Show)
+
+data DeclVar =
+   DVar Ident
+ | DInit Ident Expr
+  deriving (Eq,Ord,Show)
+
+data Expr =
+   EAssign Expr Expr
+ | ENew Ident [Expr]
+ | EMember Expr Ident
+ | EIndex Expr Expr
+ | ECall Expr [Expr]
+ | EVar Ident
+ | EInt Int
+ | EDbl Double
+ | EStr String
+ | ETrue
+ | EFalse
+ | ENull
+ | EThis
+ | EFun [Ident] [Stmt]
+ | EArray [Expr]
+ | EObj [Property]
+ | ESeq [Expr]
+  deriving (Eq,Ord,Show)
+
+data Property =
+   Prop PropertyName Expr
+  deriving (Eq,Ord,Show)
+
+data PropertyName =
+   IdentPropName Ident
+ | StringPropName String
+ | IntPropName Int
+  deriving (Eq,Ord,Show)
+

src/compiler/api/GF/JavaScript/JS.cf

@@ -0,0 +1,55 @@
+entrypoints Program;
+
+Program. Program ::= [Element];
+
+FunDef.  Element ::= "function" Ident "(" [Ident] ")" "{" [Stmt] "}" ;
+ElStmt.  Element ::= Stmt;
+separator Element "" ;
+
+separator Ident "," ;
+
+SCompound.   Stmt ::= "{" [Stmt] "}" ;
+SReturnVoid. Stmt ::= "return" ";" ;
+SReturn.     Stmt ::= "return" Expr ";" ;
+SDeclOrExpr. Stmt ::= DeclOrExpr ";" ;
+separator Stmt "" ;
+
+Decl.  DeclOrExpr ::= "var" [DeclVar];
+DExpr. DeclOrExpr ::= Expr1 ;
+
+DVar.  DeclVar ::= Ident ;
+DInit. DeclVar ::= Ident "=" Expr ;
+separator DeclVar "," ;
+
+EAssign. Expr13 ::= Expr14 "=" Expr13 ;
+
+ENew.    Expr14 ::= "new" Ident "(" [Expr] ")" ;
+
+EMember. Expr15 ::= Expr15 "." Ident ;
+EIndex.  Expr15 ::= Expr15 "[" Expr "]" ;
+ECall.   Expr15 ::= Expr15 "(" [Expr] ")" ;
+
+EVar.    Expr16 ::= Ident ;
+EInt.    Expr16 ::= Integer ;
+EDbl.    Expr16 ::= Double ;
+EStr.    Expr16 ::= String ;
+ETrue.   Expr16 ::= "true" ;
+EFalse.  Expr16 ::= "false" ;
+ENull.   Expr16 ::= "null" ;
+EThis.   Expr16 ::= "this" ;
+EFun.    Expr16 ::= "function" "(" [Ident] ")" "{" [Stmt] "}" ;
+EArray.  Expr16 ::= "[" [Expr] "]" ;
+EObj.    Expr16 ::= "{" [Property] "}" ;
+
+eseq1.   Expr16  ::= "(" Expr "," [Expr] ")";
+internal ESeq. Expr16 ::= "(" [Expr] ")" ;
+define eseq1 x xs = ESeq (x:xs); 
+
+separator Expr "," ;
+coercions Expr 16 ;
+
+Prop. Property ::= PropertyName ":" Expr ;
+separator Property "," ;
+
+IdentPropName.  PropertyName ::= Ident ;
+StringPropName. PropertyName ::= String ;

src/compiler/api/GF/JavaScript/LexJS.x

@@ -0,0 +1,132 @@
+-- -*- haskell -*-
+-- This Alex file was machine-generated by the BNF converter
+{
+{-# OPTIONS -fno-warn-incomplete-patterns #-}
+module GF.JavaScript.LexJS where
+
+
+}
+
+
+$l = [a-zA-Z\192 - \255] # [\215 \247]    -- isolatin1 letter FIXME
+$c = [A-Z\192-\221] # [\215]    -- capital isolatin1 letter FIXME
+$s = [a-z\222-\255] # [\247]    -- small isolatin1 letter FIXME
+$d = [0-9]                -- digit
+$i = [$l $d _ ']          -- identifier character
+$u = [\0-\255]          -- universal: any character
+
+@rsyms =    -- symbols and non-identifier-like reserved words
+   \( | \) | \{ | \} | \, | \; | \= | \. | \[ | \] | \:
+
+:-
+
+$white+ ;
+@rsyms { tok (\p s -> PT p (TS $ share s)) }
+
+$l $i*   { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
+\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
+
+$d+      { tok (\p s -> PT p (TI $ share s))    }
+$d+ \. $d+ (e (\-)? $d+)? { tok (\p s -> PT p (TD $ share s)) }
+
+{
+
+tok f p s = f p s
+
+share :: String -> String
+share = id
+
+data Tok =
+   TS !String     -- reserved words and symbols
+ | TL !String     -- string literals
+ | TI !String     -- integer literals
+ | TV !String     -- identifiers
+ | TD !String     -- double precision float literals
+ | TC !String     -- character literals
+
+ deriving (Eq,Show,Ord)
+
+data Token = 
+   PT  Posn Tok
+ | Err Posn
+  deriving (Eq,Show,Ord)
+
+tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
+tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
+tokenPos _ = "end of file"
+
+posLineCol (Pn _ l c) = (l,c)
+mkPosToken t@(PT p _) = (posLineCol p, prToken t)
+
+prToken t = case t of
+  PT _ (TS s) -> s
+  PT _ (TI s) -> s
+  PT _ (TV s) -> s
+  PT _ (TD s) -> s
+  PT _ (TC s) -> s
+
+  _ -> show t
+
+data BTree = N | B String Tok BTree BTree deriving (Show)
+
+eitherResIdent :: (String -> Tok) -> String -> Tok
+eitherResIdent tv s = treeFind resWords
+  where
+  treeFind N = tv s
+  treeFind (B a t left right) | s < a  = treeFind left
+                              | s > a  = treeFind right
+                              | s == a = t
+
+resWords = b "return" (b "new" (b "function" (b "false" N N) N) (b "null" N N)) (b "true" (b "this" N N) (b "var" N N))
+   where b s = B s (TS s)
+
+unescapeInitTail :: String -> String
+unescapeInitTail = unesc . tail where
+  unesc s = case s of
+    '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
+    '\\':'n':cs  -> '\n' : unesc cs
+    '\\':'t':cs  -> '\t' : unesc cs
+    '"':[]    -> []
+    c:cs      -> c : unesc cs
+    _         -> []
+
+-------------------------------------------------------------------
+-- Alex wrapper code.
+-- A modified "posn" wrapper.
+-------------------------------------------------------------------
+
+data Posn = Pn !Int !Int !Int
+      deriving (Eq, Show,Ord)
+
+alexStartPos :: Posn
+alexStartPos = Pn 0 1 1
+
+alexMove :: Posn -> Char -> Posn
+alexMove (Pn a l c) '\t' = Pn (a+1)  l     (((c+7) `div` 8)*8+1)
+alexMove (Pn a l c) '\n' = Pn (a+1) (l+1)   1
+alexMove (Pn a l c) _    = Pn (a+1)  l     (c+1)
+
+type AlexInput = (Posn, -- current position,
+               Char,     -- previous char
+               String)   -- current input string
+
+tokens :: String -> [Token]
+tokens str = go (alexStartPos, '\n', str)
+    where
+      go :: (Posn, Char, String) -> [Token]
+      go inp@(pos, _, str) =
+               case alexScan inp 0 of
+                AlexEOF                -> []
+                AlexError (pos, _, _)  -> [Err pos]
+                AlexSkip  inp' len     -> go inp'
+                AlexToken inp' len act -> act pos (take len str) : (go inp')
+
+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
+alexGetChar (p, c, [])    = Nothing
+alexGetChar (p, _, (c:s)) =
+    let p' = alexMove p c
+     in p' `seq` Just (c, (p', c, s))
+
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar (p, c, s) = c
+}

src/compiler/api/GF/JavaScript/Makefile

@@ -0,0 +1,14 @@
+all:
+	happy -gca ParJS.y
+	alex -g LexJS.x
+
+bnfc:
+	(cd ../.. && bnfc -p GF.JavaScript GF/JavaScript/JS.cf)
+	-rm -f *.bak
+
+clean:
+	-rm -f *.log *.aux *.hi *.o *.dvi
+	-rm -f DocJS.ps
+distclean: clean
+	-rm -f DocJS.* LexJS.* ParJS.* LayoutJS.* SkelJS.* PrintJS.* TestJS.* AbsJS.* TestJS ErrM.* SharedString.* JS.dtd XMLJS.* Makefile*
+

src/compiler/api/GF/JavaScript/ParJS.y

@@ -0,0 +1,225 @@
+-- This Happy file was machine-generated by the BNF converter
+{
+{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}
+module GF.JavaScript.ParJS where
+import GF.JavaScript.AbsJS
+import GF.JavaScript.LexJS
+import GF.Data.ErrM
+}
+
+%name pProgram Program
+
+-- no lexer declaration
+%monad { Err } { thenM } { returnM }
+%tokentype { Token }
+
+%token 
+ '(' { PT _ (TS "(") }
+ ')' { PT _ (TS ")") }
+ '{' { PT _ (TS "{") }
+ '}' { PT _ (TS "}") }
+ ',' { PT _ (TS ",") }
+ ';' { PT _ (TS ";") }
+ '=' { PT _ (TS "=") }
+ '.' { PT _ (TS ".") }
+ '[' { PT _ (TS "[") }
+ ']' { PT _ (TS "]") }
+ ':' { PT _ (TS ":") }
+ 'false' { PT _ (TS "false") }
+ 'function' { PT _ (TS "function") }
+ 'new' { PT _ (TS "new") }
+ 'null' { PT _ (TS "null") }
+ 'return' { PT _ (TS "return") }
+ 'this' { PT _ (TS "this") }
+ 'true' { PT _ (TS "true") }
+ 'var' { PT _ (TS "var") }
+
+L_ident  { PT _ (TV $$) }
+L_integ  { PT _ (TI $$) }
+L_doubl  { PT _ (TD $$) }
+L_quoted { PT _ (TL $$) }
+L_err    { _ }
+
+
+%%
+
+Ident   :: { Ident }   : L_ident  { Ident $1 }
+Integer :: { Integer } : L_integ  { (read $1) :: Integer }
+Double  :: { Double }  : L_doubl  { (read $1) :: Double }
+String  :: { String }  : L_quoted { $1 }
+
+Program :: { Program }
+Program : ListElement { Program (reverse $1) } 
+
+
+Element :: { Element }
+Element : 'function' Ident '(' ListIdent ')' '{' ListStmt '}' { FunDef $2 $4 (reverse $7) } 
+  | Stmt { ElStmt $1 }
+
+
+ListElement :: { [Element] }
+ListElement : {- empty -} { [] } 
+  | ListElement Element { flip (:) $1 $2 }
+
+
+ListIdent :: { [Ident] }
+ListIdent : {- empty -} { [] } 
+  | Ident { (:[]) $1 }
+  | Ident ',' ListIdent { (:) $1 $3 }
+
+
+Stmt :: { Stmt }
+Stmt : '{' ListStmt '}' { SCompound (reverse $2) } 
+  | 'return' ';' { SReturnVoid }
+  | 'return' Expr ';' { SReturn $2 }
+  | DeclOrExpr ';' { SDeclOrExpr $1 }
+
+
+ListStmt :: { [Stmt] }
+ListStmt : {- empty -} { [] } 
+  | ListStmt Stmt { flip (:) $1 $2 }
+
+
+DeclOrExpr :: { DeclOrExpr }
+DeclOrExpr : 'var' ListDeclVar { Decl $2 } 
+  | Expr1 { DExpr $1 }
+
+
+DeclVar :: { DeclVar }
+DeclVar : Ident { DVar $1 } 
+  | Ident '=' Expr { DInit $1 $3 }
+
+
+ListDeclVar :: { [DeclVar] }
+ListDeclVar : {- empty -} { [] } 
+  | DeclVar { (:[]) $1 }
+  | DeclVar ',' ListDeclVar { (:) $1 $3 }
+
+
+Expr13 :: { Expr }
+Expr13 : Expr14 '=' Expr13 { EAssign $1 $3 } 
+  | Expr14 { $1 }
+
+
+Expr14 :: { Expr }
+Expr14 : 'new' Ident '(' ListExpr ')' { ENew $2 $4 } 
+  | Expr15 { $1 }
+
+
+Expr15 :: { Expr }
+Expr15 : Expr15 '.' Ident { EMember $1 $3 } 
+  | Expr15 '[' Expr ']' { EIndex $1 $3 }
+  | Expr15 '(' ListExpr ')' { ECall $1 $3 }
+  | Expr16 { $1 }
+
+
+Expr16 :: { Expr }
+Expr16 : Ident { EVar $1 } 
+  | Integer { EInt $1 }
+  | Double { EDbl $1 }
+  | String { EStr $1 }
+  | 'true' { ETrue }
+  | 'false' { EFalse }
+  | 'null' { ENull }
+  | 'this' { EThis }
+  | 'function' '(' ListIdent ')' '{' ListStmt '}' { EFun $3 (reverse $6) }
+  | '[' ListExpr ']' { EArray $2 }
+  | '{' ListProperty '}' { EObj $2 }
+  | '(' Expr ',' ListExpr ')' { eseq1_ $2 $4 }
+  | '(' Expr ')' { $2 }
+
+
+ListExpr :: { [Expr] }
+ListExpr : {- empty -} { [] } 
+  | Expr { (:[]) $1 }
+  | Expr ',' ListExpr { (:) $1 $3 }
+
+
+Expr :: { Expr }
+Expr : Expr1 { $1 } 
+
+
+Expr1 :: { Expr }
+Expr1 : Expr2 { $1 } 
+
+
+Expr2 :: { Expr }
+Expr2 : Expr3 { $1 } 
+
+
+Expr3 :: { Expr }
+Expr3 : Expr4 { $1 } 
+
+
+Expr4 :: { Expr }
+Expr4 : Expr5 { $1 } 
+
+
+Expr5 :: { Expr }
+Expr5 : Expr6 { $1 } 
+
+
+Expr6 :: { Expr }
+Expr6 : Expr7 { $1 } 
+
+
+Expr7 :: { Expr }
+Expr7 : Expr8 { $1 } 
+
+
+Expr8 :: { Expr }
+Expr8 : Expr9 { $1 } 
+
+
+Expr9 :: { Expr }
+Expr9 : Expr10 { $1 } 
+
+
+Expr10 :: { Expr }
+Expr10 : Expr11 { $1 } 
+
+
+Expr11 :: { Expr }
+Expr11 : Expr12 { $1 } 
+
+
+Expr12 :: { Expr }
+Expr12 : Expr13 { $1 } 
+
+
+Property :: { Property }
+Property : PropertyName ':' Expr { Prop $1 $3 } 
+
+
+ListProperty :: { [Property] }
+ListProperty : {- empty -} { [] } 
+  | Property { (:[]) $1 }
+  | Property ',' ListProperty { (:) $1 $3 }
+
+
+PropertyName :: { PropertyName }
+PropertyName : Ident { IdentPropName $1 } 
+  | String { StringPropName $1 }
+
+
+
+{
+
+returnM :: a -> Err a
+returnM = return
+
+thenM :: Err a -> (a -> Err b) -> Err b
+thenM = (>>=)
+
+happyError :: [Token] -> Err a
+happyError ts =
+  Bad $ "syntax error at " ++ tokenPos ts ++ 
+  case ts of
+    [] -> []
+    [Err _] -> " due to lexer error"
+    _ -> " before " ++ unwords (map prToken (take 4 ts))
+
+myLexer = tokens
+eseq1_ x_ xs_ = ESeq (x_ : xs_)
+}
+

src/compiler/api/GF/JavaScript/PrintJS.hs

@@ -0,0 +1,167 @@
+{-# OPTIONS -fno-warn-incomplete-patterns #-}
+module GF.JavaScript.PrintJS (printTree, Doc, Print(..)) where
+
+-- pretty-printer generated by the BNF converter
+
+import GF.JavaScript.AbsJS
+import Data.Char
+
+-- the top-level printing method
+printTree :: Print a => a -> String
+printTree = render . prt 0
+
+type Doc = [ShowS] -> [ShowS]
+
+doc :: ShowS -> Doc
+doc = (:)
+
+render :: Doc -> String
+render d = rend 0 (map ($ "") $ d []) "" where
+  rend i ss = case ss of
+    t:ts | not (spaceAfter t) -> showString t . rend i ts
+    t:ts@(t':_) | not (spaceBefore t') -> showString t . rend i ts
+    t:ts -> space t . rend i ts
+    []   -> id
+--new i   = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
+  space t = showString t . (\s -> if null s then "" else (' ':s))
+
+spaceAfter :: String -> Bool
+spaceAfter = (`notElem` [".","(","[","{","\n"])
+
+spaceBefore :: String -> Bool
+spaceBefore = (`notElem` [",",".",":",";","(",")","[","]","{","}","\n"])
+
+parenth :: Doc -> Doc
+parenth ss = doc (showChar '(') . ss . doc (showChar ')')
+
+concatS :: [ShowS] -> ShowS
+concatS = foldr (.) id
+
+concatD :: [Doc] -> Doc
+concatD = foldr (.) id
+{-
+replicateS :: Int -> ShowS -> ShowS
+replicateS n f = concatS (replicate n f)
+-}
+-- the printer class does the job
+class Print a where
+  prt :: Int -> a -> Doc
+  prtList :: [a] -> Doc
+  prtList = concatD . map (prt 0)
+
+instance Print a => Print [a] where
+  prt _ = prtList
+
+instance Print Char where
+  prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
+  prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
+
+mkEsc :: Char -> Char -> ShowS
+mkEsc q s = case s of
+  _ | s == q -> showChar '\\' . showChar s
+  '\\'-> showString "\\\\"
+  '\n' -> showString "\\n"
+  '\t' -> showString "\\t"
+  _ -> showChar s
+
+prPrec :: Int -> Int -> Doc -> Doc
+prPrec i j = if j<i then parenth else id
+
+
+instance Print Int where
+  prt _ x = doc (shows x)
+
+
+instance Print Double where
+  prt _ x = doc (shows x)
+
+
+instance Print Ident where
+  prt _ (Ident i) = doc (showString i)
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+
+
+instance Print Program where
+  prt i e = case e of
+   Program elements -> prPrec i 0 (concatD [prt 0 elements])
+
+
+instance Print Element where
+  prt i e = case e of
+   FunDef id ids stmts -> prPrec i 0 (concatD [doc (showString "function") , prt 0 id , doc (showString "(") , prt 0 ids , doc (showString ")") , doc (showString "{") , prt 0 stmts , doc (showString "}")])
+   ElStmt stmt -> prPrec i 0 (concatD [prt 0 stmt])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , doc (showString "\n"), prt 0 xs]) -- HACKED!
+
+instance Print Stmt where
+  prt i e = case e of
+   SCompound stmts -> prPrec i 0 (concatD [doc (showString "{") , prt 0 stmts , doc (showString "}")])
+   SReturnVoid  -> prPrec i 0 (concatD [doc (showString "return") , doc (showString ";")])
+   SReturn expr -> prPrec i 0 (concatD [doc (showString "return") , prt 0 expr , doc (showString ";")])
+   SDeclOrExpr declorexpr -> prPrec i 0 (concatD [prt 0 declorexpr , doc (showString ";")])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+
+instance Print DeclOrExpr where
+  prt i e = case e of
+   Decl declvars -> prPrec i 0 (concatD [doc (showString "var") , prt 0 declvars])
+   DExpr expr -> prPrec i 0 (concatD [prt 1 expr])
+
+
+instance Print DeclVar where
+  prt i e = case e of
+   DVar id -> prPrec i 0 (concatD [prt 0 id])
+   DInit id expr -> prPrec i 0 (concatD [prt 0 id , doc (showString "=") , prt 0 expr])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+instance Print Expr where
+  prt i e = case e of
+   EAssign expr0 expr -> prPrec i 13 (concatD [prt 14 expr0 , doc (showString "=") , prt 13 expr])
+   ENew id exprs -> prPrec i 14 (concatD [doc (showString "new") , prt 0 id , doc (showString "(") , prt 0 exprs , doc (showString ")")])
+   EMember expr id -> prPrec i 15 (concatD [prt 15 expr , doc (showString ".") , prt 0 id])
+   EIndex expr0 expr -> prPrec i 15 (concatD [prt 15 expr0 , doc (showString "[") , prt 0 expr , doc (showString "]")])
+   ECall expr exprs -> prPrec i 15 (concatD [prt 15 expr , doc (showString "(") , prt 0 exprs , doc (showString ")")])
+   EVar id -> prPrec i 16 (concatD [prt 0 id])
+   EInt n -> prPrec i 16 (concatD [prt 0 n])
+   EDbl d -> prPrec i 16 (concatD [prt 0 d])
+   EStr str -> prPrec i 16 (concatD [prt 0 str])
+   ETrue  -> prPrec i 16 (concatD [doc (showString "true")])
+   EFalse  -> prPrec i 16 (concatD [doc (showString "false")])
+   ENull  -> prPrec i 16 (concatD [doc (showString "null")])
+   EThis  -> prPrec i 16 (concatD [doc (showString "this")])
+   EFun ids stmts -> prPrec i 16 (concatD [doc (showString "function") , doc (showString "(") , prt 0 ids , doc (showString ")") , doc (showString "{") , prt 0 stmts , doc (showString "}")])
+   EArray exprs -> prPrec i 16 (concatD [doc (showString "[") , prt 0 exprs , doc (showString "]")])
+   EObj propertys -> prPrec i 16 (concatD [doc (showString "{") , prt 0 propertys , doc (showString "}")])
+   ESeq exprs -> prPrec i 16 (concatD [doc (showString "(") , prt 0 exprs , doc (showString ")")])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+instance Print Property where
+  prt i e = case e of
+   Prop propertyname expr -> prPrec i 0 (concatD [prt 0 propertyname , doc (showString ":") , prt 0 expr])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+instance Print PropertyName where
+  prt i e = case e of
+   IdentPropName id -> prPrec i 0 (concatD [prt 0 id])
+   StringPropName str -> prPrec i 0 (concatD [prt 0 str])
+   IntPropName n -> prPrec i 0 (concatD [prt 0 n])

src/compiler/api/GF/Quiz.hs

@@ -0,0 +1,102 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : TeachYourself
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:46:13 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.7 $
+--
+-- translation and morphology quiz. AR 10\/5\/2000 -- 12\/4\/2002 -- 14\/6\/2008
+--------------------------------------------------------------------------------
+
+module GF.Quiz (
+  mkQuiz,
+  translationList,
+  morphologyList
+  ) where
+
+import PGF2
+import GF.Data.Operations
+import System.Random
+import Data.List (nub)
+
+-- translation and morphology quiz. AR 10/5/2000 -- 12/4/2002
+
+-- generic quiz function
+
+mkQuiz :: String -> [(String,[String])] -> IO ()
+mkQuiz msg tts = do
+  let qas = [(q, mkAnswer as) | (q,as) <- tts]
+  teachDialogue qas msg
+
+translationList :: 
+  Maybe Expr -> PGF -> Concr -> Concr -> Type -> Int -> IO [(String,[String])]
+translationList mex pgf ig og typ number = do
+  gen <- newStdGen
+  let ts   = take number $ case mex of
+                             Just ex -> generateRandomFrom gen pgf ex
+                             Nothing -> generateRandom     gen pgf typ
+  return $ map mkOne $ ts
+ where
+   mkOne (t,p) = (norml (linearize ig t), 
+                  map norml (concatMap lins (homonyms t)))
+   homonyms t = 
+     case (parse ig typ . linearize ig) t of
+       ParseOk res -> map fst res
+       _           -> []
+   lins = nub . concatMap (map snd) . tabularLinearizeAll og
+
+morphologyList :: 
+  Maybe Expr -> PGF -> Concr -> Type -> Int -> IO [(String,[String])]
+morphologyList mex pgf ig typ number = do
+  gen <- newStdGen
+  let ts   = take (max 1 number) $ case mex of
+                                     Just ex -> generateRandomFrom gen pgf ex
+                                     Nothing -> generateRandom     gen pgf typ
+  let ss    = map (tabularLinearizeAll ig . fst) ts
+  let size  = length (head (head ss))
+  let forms = take number $ randomRs (0,size-1) gen
+  return [(snd (head pws0) +++ fst (pws0 !! i), ws) | 
+           (pwss@(pws0:_),i) <- zip ss forms, let ws = map (\pws -> snd (pws !! i)) pwss]
+
+-- | compare answer to the list of right answers, increase score and give feedback 
+mkAnswer :: [String] -> String -> (Integer, String) 
+mkAnswer as s = 
+  if (elem (norm s) as) 
+     then (1,"Yes.") 
+     else (0,"No, not" +++ s ++ ", but" ++++ unlines as)
+ where
+   norm = unwords . words
+
+norml = unwords . words
+
+
+-- * a generic quiz session
+
+type QuestionsAndAnswers = [(String, String -> (Integer,String))]
+
+teachDialogue :: QuestionsAndAnswers -> String -> IO ()
+teachDialogue qas welc = do
+  putStrLn $ welc ++++ genericTeachWelcome
+  teach (0,0) qas
+ where 
+    teach _ [] = do putStrLn "Sorry, ran out of problems"
+    teach (score,total) ((question,grade):quas) = do
+      putStr ("\n" ++ question ++ "\n> ") 
+      answer <- getLine
+      if (answer == ".") then return () else do
+        let (result, feedback) = grade answer
+            score' = score + result 
+            total' = total + 1
+        putStr (feedback ++++ "Score" +++ show score' ++ "/" ++ show total')
+        if (total' > 9 && fromInteger score' / fromInteger total' >= 0.75)
+           then do putStrLn "\nCongratulations - you passed!"
+           else teach (score',total') quas
+
+    genericTeachWelcome = 
+      "The quiz is over when you have done at least 10 examples" ++++
+      "with at least 75 % success." +++++
+      "You can interrupt the quiz by entering a line consisting of a dot ('.').\n"