{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
module Language.Happy.Arbitrary where

import           Control.Applicative  ((<|>))
import           Control.Monad.Extra  (concatMapM)
import           Data.Fix             (foldFix)
import           Data.Map             (Map)
import qualified Data.Map             as Map
import           Data.Maybe           (fromJust)
import           Data.Text            (Text)
import qualified Data.Text            as Text
import           Language.Happy.Ast   (Node, NodeF (..))
import           Language.Happy.Lexer (Lexeme, lexemeText)
import qualified Test.QuickCheck.Gen  as Gen
import           Test.QuickCheck.Gen  (Gen)

genTokens :: Text -> Node (Lexeme Text) -> Gen [Text]
genTokens :: Text -> Node (Lexeme Text) -> Gen [Text]
genTokens Text
start Node (Lexeme Text)
g = do
    case Text -> Map Text [[Text]] -> Maybe [[Text]]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
start Map Text [[Text]]
rules of
        Maybe [[Text]]
Nothing -> [Char] -> Gen [Text]
forall a. HasCallStack => [Char] -> a
error ([Char] -> Gen [Text]) -> [Char] -> Gen [Text]
forall a b. (a -> b) -> a -> b
$ [Char]
"no such rule: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack Text
start
        Just [[Text]]
r  -> Map Text Text -> Map Text [[Text]] -> [[Text]] -> Gen [Text]
expand Map Text Text
tokens Map Text [[Text]]
rules [[Text]]
r
  where
    tokens :: Map Text Text
tokens = (NodeF (Lexeme Text) (Map Text Text) -> Map Text Text)
-> Node (Lexeme Text) -> Map Text Text
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix NodeF (Lexeme Text) (Map Text Text) -> Map Text Text
terminals Node (Lexeme Text)
g
    rules :: Map Text [[Text]]
rules = (NodeF (Lexeme Text) (Map Text [[Text]]) -> Map Text [[Text]])
-> Node (Lexeme Text) -> Map Text [[Text]]
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix NodeF (Lexeme Text) (Map Text [[Text]]) -> Map Text [[Text]]
nonterminals Node (Lexeme Text)
g

expand :: Map Text Text -> Map Text [[Text]] -> [[Text]] -> Gen [Text]
expand :: Map Text Text -> Map Text [[Text]] -> [[Text]] -> Gen [Text]
expand Map Text Text
tokens Map Text [[Text]]
rules [[Text]]
r = do
    [Text]
rule <- [[Text]] -> Gen [Text]
forall a. [a] -> Gen a
Gen.elements [[Text]]
r
    let expanded :: [Either Text [[Text]]]
expanded = (Text -> Either Text [[Text]]) -> [Text] -> [Either Text [[Text]]]
forall a b. (a -> b) -> [a] -> [b]
map (Map Text Text -> Map Text [[Text]] -> Text -> Either Text [[Text]]
resolve Map Text Text
tokens Map Text [[Text]]
rules) [Text]
rule
    (Either Text [[Text]] -> Gen [Text])
-> [Either Text [[Text]]] -> Gen [Text]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (Map Text Text
-> Map Text [[Text]] -> Either Text [[Text]] -> Gen [Text]
continue Map Text Text
tokens Map Text [[Text]]
rules) [Either Text [[Text]]]
expanded

continue :: Map Text Text -> Map Text [[Text]] -> Either Text [[Text]] -> Gen [Text]
continue :: Map Text Text
-> Map Text [[Text]] -> Either Text [[Text]] -> Gen [Text]
continue Map Text Text
_ Map Text [[Text]]
_ (Left Text
token)          = [Text] -> Gen [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text
token]
continue Map Text Text
tokens Map Text [[Text]]
rules (Right [[Text]]
rule) = Map Text Text -> Map Text [[Text]] -> [[Text]] -> Gen [Text]
expand Map Text Text
tokens Map Text [[Text]]
rules [[Text]]
rule

resolve :: Map Text Text -> Map Text [[Text]] -> Text -> Either Text [[Text]]
resolve :: Map Text Text -> Map Text [[Text]] -> Text -> Either Text [[Text]]
resolve Map Text Text
tokens Map Text [[Text]]
rules Text
sym =
    Maybe (Either Text [[Text]]) -> Either Text [[Text]]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Either Text [[Text]]) -> Either Text [[Text]])
-> Maybe (Either Text [[Text]]) -> Either Text [[Text]]
forall a b. (a -> b) -> a -> b
$ (Text -> Either Text [[Text]]
forall a b. a -> Either a b
Left (Text -> Either Text [[Text]])
-> Maybe Text -> Maybe (Either Text [[Text]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
sym Map Text Text
tokens) Maybe (Either Text [[Text]])
-> Maybe (Either Text [[Text]]) -> Maybe (Either Text [[Text]])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ([[Text]] -> Either Text [[Text]]
forall a b. b -> Either a b
Right ([[Text]] -> Either Text [[Text]])
-> Maybe [[Text]] -> Maybe (Either Text [[Text]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Map Text [[Text]] -> Maybe [[Text]]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
sym Map Text [[Text]]
rules)

terminals :: NodeF (Lexeme Text) (Map Text Text) -> Map Text Text
terminals :: NodeF (Lexeme Text) (Map Text Text) -> Map Text Text
terminals NodeF (Lexeme Text) (Map Text Text)
node = case NodeF (Lexeme Text) (Map Text Text)
node of
    Token Lexeme Text
k Lexeme Text
v -> Text -> Text -> Map Text Text
forall k a. k -> a -> Map k a
Map.singleton (Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
k) (Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
v)
    NodeF (Lexeme Text) (Map Text Text)
n         -> NodeF (Lexeme Text) (Map Text Text) -> Map Text Text
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions NodeF (Lexeme Text) (Map Text Text)
n

nonterminals :: NodeF (Lexeme Text) (Map Text [[Text]]) -> Map Text [[Text]]
nonterminals :: NodeF (Lexeme Text) (Map Text [[Text]]) -> Map Text [[Text]]
nonterminals NodeF (Lexeme Text) (Map Text [[Text]])
node = case NodeF (Lexeme Text) (Map Text [[Text]])
node of
    RuleLine [Lexeme Text]
syms Lexeme Text
_     -> Text -> [[Text]] -> Map Text [[Text]]
forall k a. k -> a -> Map k a
Map.singleton Text
"" [(Lexeme Text -> Text) -> [Lexeme Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText [Lexeme Text]
syms]
    RuleDefn Lexeme Text
name [Map Text [[Text]]]
rules -> Text -> [[Text]] -> Map Text [[Text]]
forall k a. k -> a -> Map k a
Map.singleton (Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
name) ([Map Text [[Text]]] -> [[Text]]
forall k a. [Map k [a]] -> [a]
merge [Map Text [[Text]]]
rules)
    NodeF (Lexeme Text) (Map Text [[Text]])
n                   -> ([[Text]] -> [[Text]] -> [[Text]])
-> NodeF (Lexeme Text) (Map Text [[Text]]) -> Map Text [[Text]]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith [[Text]] -> [[Text]] -> [[Text]]
forall a. [a] -> [a] -> [a]
(++) NodeF (Lexeme Text) (Map Text [[Text]])
n
  where
    merge :: [Map k [a]] -> [a]
merge = [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> ([Map k [a]] -> [[a]]) -> [Map k [a]] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map k [a] -> [[a]]) -> [Map k [a]] -> [[a]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Map k [a] -> [[a]]
forall k a. Map k a -> [a]
Map.elems