{-|
Module      : DigraphQuote
Description : Template Haskell quasi-quoter for digraph table
Copyright   : (c) Eric Mertens, 2017
License     : ISC
Maintainer  : emertens@gmail.com

-}
module DigraphQuote (digraphTable) where

import Control.Monad ((<=<))
import Data.Char (chr)
import Language.Haskell.TH (Q, ExpQ, stringE)
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Numeric (readHex)

digraphTable :: QuasiQuoter
digraphTable :: QuasiQuoter
digraphTable = QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp  = String -> Q Exp
digraphTableExp
  , quotePat :: String -> Q Pat
quotePat  = forall a b. a -> b -> a
const (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Digraph table must be an expression")
  , quoteType :: String -> Q Type
quoteType = forall a b. a -> b -> a
const (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Digraph table must be an expression")
  , quoteDec :: String -> Q [Dec]
quoteDec  = forall a b. a -> b -> a
const (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Digraph table must be an expression")
  }

digraphTableExp :: String -> ExpQ
digraphTableExp :: String -> Q Exp
digraphTableExp = forall (m :: * -> *). Quote m => String -> m Exp
stringE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> Q String
parseEntry forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

-- Parse entries, empty lines are ignored, -- comments are allowed
-- Entries are a two-character digraph followed by a hexadecimal
-- representation of the replacement character's unicode value.
--
-- Examples
--
-- > "'   14
-- > AB 0123
-- > CD 0FDE -- with a comment
-- >
-- > -- with a comment
parseEntry :: String -> Q String
parseEntry :: String -> Q String
parseEntry String
line =
  case String -> [String]
words String
line of
    [Char
x,Char
y] : (Char
'U':Char
'+':String
hex) : [String]
rest
       | [(Int
n,String
"")] <- forall a. (Eq a, Num a) => ReadS a
readHex String
hex
       , [String] -> Bool
isAllowedTerminator [String]
rest   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char
x,Char
y,Int -> Char
chr Int
n]

    [String]
rest | [String] -> Bool
isAllowedTerminator [String]
rest -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"" -- skip empty lines
         | Bool
otherwise                -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Bad digraph entry: " forall a. [a] -> [a] -> [a]
++ String
line)

-- Optionally tolerate a comment
isAllowedTerminator :: [String] -> Bool
isAllowedTerminator :: [String] -> Bool
isAllowedTerminator ((Char
'-':Char
'-':String
_):[String]
_) = Bool
True
isAllowedTerminator []              = Bool
True
isAllowedTerminator [String]
_               = Bool
False