{-# 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