-- | Auxiliary types and functions for use with grammars translated to Haskell
-- with @gf -output-format=haskell -haskell=concrete@
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}
module PGF.Haskell where
import Control.Applicative((<$>),(<*>))
import Control.Monad(join)
import Data.Char(toUpper)
import Data.List(isPrefixOf)
import qualified Data.Map as M

-- ** Concrete syntax

-- | For enumerating parameter values used in tables
class EnumAll a where enumAll :: [a]

-- | Tables
table :: [a] -> k -> a
table [a]
vs = let m :: Map k a
m = [(k, a)] -> Map k a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([k] -> [a] -> [(k, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [k]
forall a. EnumAll a => [a]
enumAll [a]
vs) in Map k a -> k -> a
forall k a. Ord k => Map k a -> k -> a
(M.!) Map k a
m


-- | Token sequences, output form linearization functions
type Str = [Tok] -- token sequence

-- | Tokens
data Tok = TK String | TP [([Prefix],Str)] Str | BIND | SOFT_BIND | SOFT_SPACE | CAPIT | ALL_CAPIT
         deriving (Tok -> Tok -> Bool
(Tok -> Tok -> Bool) -> (Tok -> Tok -> Bool) -> Eq Tok
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tok -> Tok -> Bool
$c/= :: Tok -> Tok -> Bool
== :: Tok -> Tok -> Bool
$c== :: Tok -> Tok -> Bool
Eq,Eq Tok
Eq Tok
-> (Tok -> Tok -> Ordering)
-> (Tok -> Tok -> Bool)
-> (Tok -> Tok -> Bool)
-> (Tok -> Tok -> Bool)
-> (Tok -> Tok -> Bool)
-> (Tok -> Tok -> Tok)
-> (Tok -> Tok -> Tok)
-> Ord Tok
Tok -> Tok -> Bool
Tok -> Tok -> Ordering
Tok -> Tok -> Tok
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Tok -> Tok -> Tok
$cmin :: Tok -> Tok -> Tok
max :: Tok -> Tok -> Tok
$cmax :: Tok -> Tok -> Tok
>= :: Tok -> Tok -> Bool
$c>= :: Tok -> Tok -> Bool
> :: Tok -> Tok -> Bool
$c> :: Tok -> Tok -> Bool
<= :: Tok -> Tok -> Bool
$c<= :: Tok -> Tok -> Bool
< :: Tok -> Tok -> Bool
$c< :: Tok -> Tok -> Bool
compare :: Tok -> Tok -> Ordering
$ccompare :: Tok -> Tok -> Ordering
$cp1Ord :: Eq Tok
Ord,Int -> Tok -> ShowS
[Tok] -> ShowS
Tok -> String
(Int -> Tok -> ShowS)
-> (Tok -> String) -> ([Tok] -> ShowS) -> Show Tok
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tok] -> ShowS
$cshowList :: [Tok] -> ShowS
show :: Tok -> String
$cshow :: Tok -> String
showsPrec :: Int -> Tok -> ShowS
$cshowsPrec :: Int -> Tok -> ShowS
Show)

type Prefix = String -- ^ To be matched with the prefix of a following token

-- | Render a token sequence as a 'String'
fromStr :: Str -> String
fromStr :: [Tok] -> String
fromStr = Bool -> ShowS -> [Tok] -> String
from Bool
False ShowS
forall a. a -> a
id
  where
    from :: Bool -> ShowS -> [Tok] -> String
from Bool
space ShowS
cap [Tok]
ts =
      case [Tok]
ts of
        [] -> []
        TK String
"":[Tok]
ts -> Bool -> ShowS -> [Tok] -> String
from Bool
space ShowS
cap [Tok]
ts
        TK String
s:[Tok]
ts -> ShowS
put String
sString -> ShowS
forall a. [a] -> [a] -> [a]
++Bool -> ShowS -> [Tok] -> String
from Bool
True ShowS
cap [Tok]
ts
        Tok
BIND:[Tok]
ts -> Bool -> ShowS -> [Tok] -> String
from Bool
False ShowS
cap [Tok]
ts
        Tok
SOFT_BIND:[Tok]
ts -> Bool -> ShowS -> [Tok] -> String
from Bool
False ShowS
cap [Tok]
ts
        Tok
SOFT_SPACE:[Tok]
ts -> Bool -> ShowS -> [Tok] -> String
from Bool
True ShowS
cap [Tok]
ts
        Tok
CAPIT:[Tok]
ts -> Bool -> ShowS -> [Tok] -> String
from Bool
space ShowS
toUpper1 [Tok]
ts
        Tok
ALL_CAPIT:[Tok]
ts -> Bool -> ShowS -> [Tok] -> String
from Bool
space ShowS
toUpperAll [Tok]
ts
        TP [([String], [Tok])]
alts [Tok]
def:[Tok]
ts -> Bool -> ShowS -> [Tok] -> String
from Bool
space ShowS
cap ([([String], [Tok])] -> [Tok] -> String -> [Tok]
forall (t :: * -> *) a a.
(Foldable t, Eq a) =>
[(t [a], a)] -> a -> [a] -> a
pick [([String], [Tok])]
alts [Tok]
def String
r[Tok] -> [Tok] -> [Tok]
forall a. [a] -> [a] -> [a]
++[String -> Tok
TK String
r]) -- hmm
          where r :: String
r = [Tok] -> String
fromStr [Tok]
ts
      where
        put :: ShowS
put String
s = [Char
' '|Bool
space]String -> ShowS
forall a. [a] -> [a] -> [a]
++ShowS
cap String
s

    toUpper1 :: ShowS
toUpper1 (Char
c:String
s) = Char -> Char
toUpper Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
s
    toUpper1 String
s     = String
s

    toUpperAll :: ShowS
toUpperAll = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper

    pick :: [(t [a], a)] -> a -> [a] -> a
pick [(t [a], a)]
alts a
def [a]
r = [a] -> a
forall a. [a] -> a
head ([a
str|(t [a]
ps,a
str)<-[(t [a], a)]
alts,([a] -> Bool) -> t [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [a]
r) t [a]
ps][a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a
def])

-- *** Common record types

-- | Overloaded function to project the @s@ field from any record type
class Has_s r a | r -> a where proj_s :: r -> a

-- | Haskell representation of the GF record type @{s:t}@
data R_s t = R_s t deriving (R_s t -> R_s t -> Bool
(R_s t -> R_s t -> Bool) -> (R_s t -> R_s t -> Bool) -> Eq (R_s t)
forall t. Eq t => R_s t -> R_s t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: R_s t -> R_s t -> Bool
$c/= :: forall t. Eq t => R_s t -> R_s t -> Bool
== :: R_s t -> R_s t -> Bool
$c== :: forall t. Eq t => R_s t -> R_s t -> Bool
Eq,Eq (R_s t)
Eq (R_s t)
-> (R_s t -> R_s t -> Ordering)
-> (R_s t -> R_s t -> Bool)
-> (R_s t -> R_s t -> Bool)
-> (R_s t -> R_s t -> Bool)
-> (R_s t -> R_s t -> Bool)
-> (R_s t -> R_s t -> R_s t)
-> (R_s t -> R_s t -> R_s t)
-> Ord (R_s t)
R_s t -> R_s t -> Bool
R_s t -> R_s t -> Ordering
R_s t -> R_s t -> R_s t
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall t. Ord t => Eq (R_s t)
forall t. Ord t => R_s t -> R_s t -> Bool
forall t. Ord t => R_s t -> R_s t -> Ordering
forall t. Ord t => R_s t -> R_s t -> R_s t
min :: R_s t -> R_s t -> R_s t
$cmin :: forall t. Ord t => R_s t -> R_s t -> R_s t
max :: R_s t -> R_s t -> R_s t
$cmax :: forall t. Ord t => R_s t -> R_s t -> R_s t
>= :: R_s t -> R_s t -> Bool
$c>= :: forall t. Ord t => R_s t -> R_s t -> Bool
> :: R_s t -> R_s t -> Bool
$c> :: forall t. Ord t => R_s t -> R_s t -> Bool
<= :: R_s t -> R_s t -> Bool
$c<= :: forall t. Ord t => R_s t -> R_s t -> Bool
< :: R_s t -> R_s t -> Bool
$c< :: forall t. Ord t => R_s t -> R_s t -> Bool
compare :: R_s t -> R_s t -> Ordering
$ccompare :: forall t. Ord t => R_s t -> R_s t -> Ordering
$cp1Ord :: forall t. Ord t => Eq (R_s t)
Ord,Int -> R_s t -> ShowS
[R_s t] -> ShowS
R_s t -> String
(Int -> R_s t -> ShowS)
-> (R_s t -> String) -> ([R_s t] -> ShowS) -> Show (R_s t)
forall t. Show t => Int -> R_s t -> ShowS
forall t. Show t => [R_s t] -> ShowS
forall t. Show t => R_s t -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [R_s t] -> ShowS
$cshowList :: forall t. Show t => [R_s t] -> ShowS
show :: R_s t -> String
$cshow :: forall t. Show t => R_s t -> String
showsPrec :: Int -> R_s t -> ShowS
$cshowsPrec :: forall t. Show t => Int -> R_s t -> ShowS
Show)
instance (EnumAll t) => EnumAll (R_s t) where enumAll :: [R_s t]
enumAll = t -> R_s t
forall t. t -> R_s t
R_s (t -> R_s t) -> [t] -> [R_s t]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t]
forall a. EnumAll a => [a]
enumAll
instance Has_s (R_s t) t where proj_s :: R_s t -> t
proj_s (R_s t
t) = t
t

-- | Coerce from any record type @{...,s:t,...}@ to the supertype @{s:t}@
to_R_s :: r -> R_s t
to_R_s r
r = t -> R_s t
forall t. t -> R_s t
R_s (r -> t
forall r a. Has_s r a => r -> a
proj_s r
r)


-- *** Variants

infixr 5 +++

-- | Concatenation with variants
f [a]
xs +++ :: f [a] -> f [a] -> f [a]
+++ f [a]
ys = [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) ([a] -> [a] -> [a]) -> f [a] -> f ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f [a]
xs f ([a] -> [a]) -> f [a] -> f [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f [a]
ys

-- | Selection from tables with variants
t -> m (m a)
t ! :: (t -> m (m a)) -> t -> m a
! t
p = m (m a) -> m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (t -> m (m a)
t t
p)
a -> m a
t !$ :: (a -> m a) -> m a -> m a
!$ m a
p = m (m a) -> m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (a -> m a
t (a -> m a) -> m a -> m (m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
p)
m (a -> m a)
t !* :: m (a -> m a) -> m a -> m a
!* m a
p = m (m a) -> m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (a -> m a)
t m (a -> m a) -> m a -> m (m a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m a
p)