{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}
module Nanopass.Internal.Representation
(
Language(..)
, LanguageInfo(..)
, Nonterm(..)
, Production(..)
, TypeDesc(..)
, LangMod(..)
, NontermsEdit(..)
, ProductionsEdit(..)
, Pass(..)
, UpName, toUpName, fromUpName
, LowName, toLowName, fromLowName
, UpDotName, toUpDotName, fromUpDotName, splitUpDotName
, unDotted, upDotQualifier, upDotBase, upDotChBase
, Name(..), Validate(..)
) where
import Data.Char (isLower,isUpper,isAlphaNum)
import Data.List (intercalate)
import Data.Map (Map)
import GHC.Records (HasField(..))
import qualified Language.Haskell.TH as TH
newtype UpName = UpName String
deriving (Int -> UpName -> ShowS
[UpName] -> ShowS
UpName -> String
(Int -> UpName -> ShowS)
-> (UpName -> String) -> ([UpName] -> ShowS) -> Show UpName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UpName -> ShowS
showsPrec :: Int -> UpName -> ShowS
$cshow :: UpName -> String
show :: UpName -> String
$cshowList :: [UpName] -> ShowS
showList :: [UpName] -> ShowS
Show,UpName -> UpName -> Bool
(UpName -> UpName -> Bool)
-> (UpName -> UpName -> Bool) -> Eq UpName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UpName -> UpName -> Bool
== :: UpName -> UpName -> Bool
$c/= :: UpName -> UpName -> Bool
/= :: UpName -> UpName -> Bool
Eq,Eq UpName
Eq UpName =>
(UpName -> UpName -> Ordering)
-> (UpName -> UpName -> Bool)
-> (UpName -> UpName -> Bool)
-> (UpName -> UpName -> Bool)
-> (UpName -> UpName -> Bool)
-> (UpName -> UpName -> UpName)
-> (UpName -> UpName -> UpName)
-> Ord UpName
UpName -> UpName -> Bool
UpName -> UpName -> Ordering
UpName -> UpName -> UpName
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
$ccompare :: UpName -> UpName -> Ordering
compare :: UpName -> UpName -> Ordering
$c< :: UpName -> UpName -> Bool
< :: UpName -> UpName -> Bool
$c<= :: UpName -> UpName -> Bool
<= :: UpName -> UpName -> Bool
$c> :: UpName -> UpName -> Bool
> :: UpName -> UpName -> Bool
$c>= :: UpName -> UpName -> Bool
>= :: UpName -> UpName -> Bool
$cmax :: UpName -> UpName -> UpName
max :: UpName -> UpName -> UpName
$cmin :: UpName -> UpName -> UpName
min :: UpName -> UpName -> UpName
Ord)
toUpName :: String -> Maybe UpName
toUpName :: String -> Maybe UpName
toUpName (Char
c:String
cs) | Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isAlphaNum String
cs = UpName -> Maybe UpName
forall a. a -> Maybe a
Just (UpName -> Maybe UpName) -> UpName -> Maybe UpName
forall a b. (a -> b) -> a -> b
$ String -> UpName
UpName (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
cs)
toUpName String
_ = Maybe UpName
forall a. Maybe a
Nothing
fromUpName :: UpName -> String
fromUpName :: UpName -> String
fromUpName (UpName String
str) = String
str
newtype LowName = LowName String
deriving (Int -> LowName -> ShowS
[LowName] -> ShowS
LowName -> String
(Int -> LowName -> ShowS)
-> (LowName -> String) -> ([LowName] -> ShowS) -> Show LowName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LowName -> ShowS
showsPrec :: Int -> LowName -> ShowS
$cshow :: LowName -> String
show :: LowName -> String
$cshowList :: [LowName] -> ShowS
showList :: [LowName] -> ShowS
Show,LowName -> LowName -> Bool
(LowName -> LowName -> Bool)
-> (LowName -> LowName -> Bool) -> Eq LowName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LowName -> LowName -> Bool
== :: LowName -> LowName -> Bool
$c/= :: LowName -> LowName -> Bool
/= :: LowName -> LowName -> Bool
Eq,Eq LowName
Eq LowName =>
(LowName -> LowName -> Ordering)
-> (LowName -> LowName -> Bool)
-> (LowName -> LowName -> Bool)
-> (LowName -> LowName -> Bool)
-> (LowName -> LowName -> Bool)
-> (LowName -> LowName -> LowName)
-> (LowName -> LowName -> LowName)
-> Ord LowName
LowName -> LowName -> Bool
LowName -> LowName -> Ordering
LowName -> LowName -> LowName
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
$ccompare :: LowName -> LowName -> Ordering
compare :: LowName -> LowName -> Ordering
$c< :: LowName -> LowName -> Bool
< :: LowName -> LowName -> Bool
$c<= :: LowName -> LowName -> Bool
<= :: LowName -> LowName -> Bool
$c> :: LowName -> LowName -> Bool
> :: LowName -> LowName -> Bool
$c>= :: LowName -> LowName -> Bool
>= :: LowName -> LowName -> Bool
$cmax :: LowName -> LowName -> LowName
max :: LowName -> LowName -> LowName
$cmin :: LowName -> LowName -> LowName
min :: LowName -> LowName -> LowName
Ord)
toLowName :: String -> Maybe LowName
toLowName :: String -> Maybe LowName
toLowName (Char
c:String
cs) | Char -> Bool
isLower Char
c Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isAlphaNum String
cs = LowName -> Maybe LowName
forall a. a -> Maybe a
Just (LowName -> Maybe LowName) -> LowName -> Maybe LowName
forall a b. (a -> b) -> a -> b
$ String -> LowName
LowName (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
cs)
toLowName String
_ = Maybe LowName
forall a. Maybe a
Nothing
fromLowName :: LowName -> String
fromLowName :: LowName -> String
fromLowName (LowName String
str) = String
str
data UpDotName = UpDotName [UpName] UpName
deriving (Int -> UpDotName -> ShowS
[UpDotName] -> ShowS
UpDotName -> String
(Int -> UpDotName -> ShowS)
-> (UpDotName -> String)
-> ([UpDotName] -> ShowS)
-> Show UpDotName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UpDotName -> ShowS
showsPrec :: Int -> UpDotName -> ShowS
$cshow :: UpDotName -> String
show :: UpDotName -> String
$cshowList :: [UpDotName] -> ShowS
showList :: [UpDotName] -> ShowS
Show,UpDotName -> UpDotName -> Bool
(UpDotName -> UpDotName -> Bool)
-> (UpDotName -> UpDotName -> Bool) -> Eq UpDotName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UpDotName -> UpDotName -> Bool
== :: UpDotName -> UpDotName -> Bool
$c/= :: UpDotName -> UpDotName -> Bool
/= :: UpDotName -> UpDotName -> Bool
Eq,Eq UpDotName
Eq UpDotName =>
(UpDotName -> UpDotName -> Ordering)
-> (UpDotName -> UpDotName -> Bool)
-> (UpDotName -> UpDotName -> Bool)
-> (UpDotName -> UpDotName -> Bool)
-> (UpDotName -> UpDotName -> Bool)
-> (UpDotName -> UpDotName -> UpDotName)
-> (UpDotName -> UpDotName -> UpDotName)
-> Ord UpDotName
UpDotName -> UpDotName -> Bool
UpDotName -> UpDotName -> Ordering
UpDotName -> UpDotName -> UpDotName
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
$ccompare :: UpDotName -> UpDotName -> Ordering
compare :: UpDotName -> UpDotName -> Ordering
$c< :: UpDotName -> UpDotName -> Bool
< :: UpDotName -> UpDotName -> Bool
$c<= :: UpDotName -> UpDotName -> Bool
<= :: UpDotName -> UpDotName -> Bool
$c> :: UpDotName -> UpDotName -> Bool
> :: UpDotName -> UpDotName -> Bool
$c>= :: UpDotName -> UpDotName -> Bool
>= :: UpDotName -> UpDotName -> Bool
$cmax :: UpDotName -> UpDotName -> UpDotName
max :: UpDotName -> UpDotName -> UpDotName
$cmin :: UpDotName -> UpDotName -> UpDotName
min :: UpDotName -> UpDotName -> UpDotName
Ord)
toUpDotName :: String -> Maybe UpDotName
toUpDotName :: String -> Maybe UpDotName
toUpDotName = [UpName] -> String -> Maybe UpDotName
loop []
where
loop :: [UpName] -> String -> Maybe UpDotName
loop [UpName]
acc String
inp = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') String
inp of
([], String
_) -> Maybe UpDotName
forall a. Maybe a
Nothing
(String
_, String
".") -> Maybe UpDotName
forall a. Maybe a
Nothing
(String
str, []) -> do
UpName
endName <- String -> Maybe UpName
toUpName String
str
UpDotName -> Maybe UpDotName
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpDotName -> Maybe UpDotName) -> UpDotName -> Maybe UpDotName
forall a b. (a -> b) -> a -> b
$ [UpName] -> UpName -> UpDotName
UpDotName ([UpName] -> [UpName]
forall a. [a] -> [a]
reverse [UpName]
acc) UpName
endName
(String
str, Char
_:String
rest) -> do
UpName
qual <- String -> Maybe UpName
toUpName String
str
[UpName] -> String -> Maybe UpDotName
loop (UpName
qualUpName -> [UpName] -> [UpName]
forall a. a -> [a] -> [a]
:[UpName]
acc) String
rest
fromUpDotName :: UpDotName -> String
fromUpDotName :: UpDotName -> String
fromUpDotName (UpDotName [UpName]
strs UpName
str) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ UpName -> String
fromUpName (UpName -> String) -> [UpName] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([UpName]
strs [UpName] -> [UpName] -> [UpName]
forall a. [a] -> [a] -> [a]
++ [UpName
str])
unDotted :: UpName -> UpDotName
unDotted :: UpName -> UpDotName
unDotted UpName
x = [UpName] -> UpName -> UpDotName
UpDotName [] UpName
x
upDotQualifier :: UpDotName -> [UpName]
upDotQualifier :: UpDotName -> [UpName]
upDotQualifier (UpDotName [UpName]
xs UpName
_) = [UpName]
xs
upDotBase :: UpDotName -> UpName
upDotBase :: UpDotName -> UpName
upDotBase (UpDotName [UpName]
_ UpName
x) = UpName
x
upDotChBase :: UpDotName -> UpName -> UpDotName
upDotChBase :: UpDotName -> UpName -> UpDotName
upDotChBase (UpDotName [UpName]
xs UpName
_) UpName
y = [UpName] -> UpName -> UpDotName
UpDotName [UpName]
xs UpName
y
splitUpDotName :: UpDotName -> ([UpName], UpName)
splitUpDotName :: UpDotName -> ([UpName], UpName)
splitUpDotName (UpDotName [UpName]
xs UpName
x) = ([UpName]
xs, UpName
x)
data Validate = Valid | Unvalidated
data Name v n where
SourceName :: { forall n. Name 'Unvalidated n -> n
name_ :: n } -> Name 'Unvalidated n
ValidName :: { forall n. Name 'Valid n -> n
base_ :: n, forall n. Name 'Valid n -> Name
th :: TH.Name } -> Name 'Valid n
deriving instance (Show n) => Show (Name v n)
deriving instance (Eq n) => Eq (Name v n)
deriving instance (Ord n) => Ord (Name v n)
instance HasField "name" (Name v n) n where
getField :: Name v n -> n
getField (SourceName n
n) = n
n
getField (ValidName n
n Name
_) = n
n
data Language v n = Language
{ forall (v :: Validate) n. Language v n -> Name v n
langName :: Name v n
, forall (v :: Validate) n. Language v n -> LanguageInfo v
langInfo :: LanguageInfo v
}
deriving(Int -> Language v n -> ShowS
[Language v n] -> ShowS
Language v n -> String
(Int -> Language v n -> ShowS)
-> (Language v n -> String)
-> ([Language v n] -> ShowS)
-> Show (Language v n)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (v :: Validate) n. Show n => Int -> Language v n -> ShowS
forall (v :: Validate) n. Show n => [Language v n] -> ShowS
forall (v :: Validate) n. Show n => Language v n -> String
$cshowsPrec :: forall (v :: Validate) n. Show n => Int -> Language v n -> ShowS
showsPrec :: Int -> Language v n -> ShowS
$cshow :: forall (v :: Validate) n. Show n => Language v n -> String
show :: Language v n -> String
$cshowList :: forall (v :: Validate) n. Show n => [Language v n] -> ShowS
showList :: [Language v n] -> ShowS
Show)
data LanguageInfo v = LanguageInfo
{ forall (v :: Validate). LanguageInfo v -> [Name v LowName]
langParams :: ![Name v LowName]
, forall (v :: Validate). LanguageInfo v -> Map UpName (Nonterm v)
nonterms :: !(Map UpName (Nonterm v))
, forall (v :: Validate). LanguageInfo v -> Maybe String
originalProgram :: !(Maybe String)
, forall (v :: Validate).
LanguageInfo v -> Maybe (Language 'Valid UpDotName)
baseDefdLang :: !(Maybe (Language 'Valid UpDotName))
}
deriving(Int -> LanguageInfo v -> ShowS
[LanguageInfo v] -> ShowS
LanguageInfo v -> String
(Int -> LanguageInfo v -> ShowS)
-> (LanguageInfo v -> String)
-> ([LanguageInfo v] -> ShowS)
-> Show (LanguageInfo v)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (v :: Validate). Int -> LanguageInfo v -> ShowS
forall (v :: Validate). [LanguageInfo v] -> ShowS
forall (v :: Validate). LanguageInfo v -> String
$cshowsPrec :: forall (v :: Validate). Int -> LanguageInfo v -> ShowS
showsPrec :: Int -> LanguageInfo v -> ShowS
$cshow :: forall (v :: Validate). LanguageInfo v -> String
show :: LanguageInfo v -> String
$cshowList :: forall (v :: Validate). [LanguageInfo v] -> ShowS
showList :: [LanguageInfo v] -> ShowS
Show)
data Nonterm v = Nonterm
{ forall (v :: Validate). Nonterm v -> Name v UpName
nontermName :: !(Name v UpName)
, forall (v :: Validate). Nonterm v -> Map UpName (Production v)
productions :: !(Map UpName (Production v))
}
deriving(Int -> Nonterm v -> ShowS
[Nonterm v] -> ShowS
Nonterm v -> String
(Int -> Nonterm v -> ShowS)
-> (Nonterm v -> String)
-> ([Nonterm v] -> ShowS)
-> Show (Nonterm v)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (v :: Validate). Int -> Nonterm v -> ShowS
forall (v :: Validate). [Nonterm v] -> ShowS
forall (v :: Validate). Nonterm v -> String
$cshowsPrec :: forall (v :: Validate). Int -> Nonterm v -> ShowS
showsPrec :: Int -> Nonterm v -> ShowS
$cshow :: forall (v :: Validate). Nonterm v -> String
show :: Nonterm v -> String
$cshowList :: forall (v :: Validate). [Nonterm v] -> ShowS
showList :: [Nonterm v] -> ShowS
Show)
data Production v = Production
{ forall (v :: Validate). Production v -> Name v UpName
prodName :: !(Name v UpName)
, forall (v :: Validate). Production v -> [TypeDesc v]
subterms :: ![TypeDesc v]
}
deriving(Int -> Production v -> ShowS
[Production v] -> ShowS
Production v -> String
(Int -> Production v -> ShowS)
-> (Production v -> String)
-> ([Production v] -> ShowS)
-> Show (Production v)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (v :: Validate). Int -> Production v -> ShowS
forall (v :: Validate). [Production v] -> ShowS
forall (v :: Validate). Production v -> String
$cshowsPrec :: forall (v :: Validate). Int -> Production v -> ShowS
showsPrec :: Int -> Production v -> ShowS
$cshow :: forall (v :: Validate). Production v -> String
show :: Production v -> String
$cshowList :: forall (v :: Validate). [Production v] -> ShowS
showList :: [Production v] -> ShowS
Show)
data TypeDesc v
= RecursiveType UpName
| VarType (Name v LowName)
| CtorType (Name v UpDotName) [TypeDesc v]
| ListType (TypeDesc v)
| MaybeType (TypeDesc v)
| NonEmptyType (TypeDesc v)
| UnitType
| TupleType (TypeDesc v) (TypeDesc v) [TypeDesc v]
deriving(TypeDesc v -> TypeDesc v -> Bool
(TypeDesc v -> TypeDesc v -> Bool)
-> (TypeDesc v -> TypeDesc v -> Bool) -> Eq (TypeDesc v)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (v :: Validate). TypeDesc v -> TypeDesc v -> Bool
$c== :: forall (v :: Validate). TypeDesc v -> TypeDesc v -> Bool
== :: TypeDesc v -> TypeDesc v -> Bool
$c/= :: forall (v :: Validate). TypeDesc v -> TypeDesc v -> Bool
/= :: TypeDesc v -> TypeDesc v -> Bool
Eq,Int -> TypeDesc v -> ShowS
[TypeDesc v] -> ShowS
TypeDesc v -> String
(Int -> TypeDesc v -> ShowS)
-> (TypeDesc v -> String)
-> ([TypeDesc v] -> ShowS)
-> Show (TypeDesc v)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (v :: Validate). Int -> TypeDesc v -> ShowS
forall (v :: Validate). [TypeDesc v] -> ShowS
forall (v :: Validate). TypeDesc v -> String
$cshowsPrec :: forall (v :: Validate). Int -> TypeDesc v -> ShowS
showsPrec :: Int -> TypeDesc v -> ShowS
$cshow :: forall (v :: Validate). TypeDesc v -> String
show :: TypeDesc v -> String
$cshowList :: forall (v :: Validate). [TypeDesc v] -> ShowS
showList :: [TypeDesc v] -> ShowS
Show)
data LangMod = LangMod
{ LangMod -> UpDotName
baseLang :: UpDotName
, LangMod -> UpName
newLang :: UpName
, LangMod -> [Name 'Unvalidated LowName]
newParams :: [Name 'Unvalidated LowName]
, LangMod -> [NontermsEdit]
nontermsEdit :: [NontermsEdit]
, LangMod -> Maybe String
originalModProgram :: Maybe String
}
deriving(Int -> LangMod -> ShowS
[LangMod] -> ShowS
LangMod -> String
(Int -> LangMod -> ShowS)
-> (LangMod -> String) -> ([LangMod] -> ShowS) -> Show LangMod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LangMod -> ShowS
showsPrec :: Int -> LangMod -> ShowS
$cshow :: LangMod -> String
show :: LangMod -> String
$cshowList :: [LangMod] -> ShowS
showList :: [LangMod] -> ShowS
Show)
data NontermsEdit
= AddNonterm (Nonterm 'Unvalidated)
| ModNonterm UpName [ProductionsEdit]
| DelNonterm UpName
deriving(Int -> NontermsEdit -> ShowS
[NontermsEdit] -> ShowS
NontermsEdit -> String
(Int -> NontermsEdit -> ShowS)
-> (NontermsEdit -> String)
-> ([NontermsEdit] -> ShowS)
-> Show NontermsEdit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NontermsEdit -> ShowS
showsPrec :: Int -> NontermsEdit -> ShowS
$cshow :: NontermsEdit -> String
show :: NontermsEdit -> String
$cshowList :: [NontermsEdit] -> ShowS
showList :: [NontermsEdit] -> ShowS
Show)
data ProductionsEdit
= AddProd (Production 'Unvalidated)
| DelProd UpName
deriving(Int -> ProductionsEdit -> ShowS
[ProductionsEdit] -> ShowS
ProductionsEdit -> String
(Int -> ProductionsEdit -> ShowS)
-> (ProductionsEdit -> String)
-> ([ProductionsEdit] -> ShowS)
-> Show ProductionsEdit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProductionsEdit -> ShowS
showsPrec :: Int -> ProductionsEdit -> ShowS
$cshow :: ProductionsEdit -> String
show :: ProductionsEdit -> String
$cshowList :: [ProductionsEdit] -> ShowS
showList :: [ProductionsEdit] -> ShowS
Show)
data Pass = Pass
{ Pass -> Name 'Unvalidated UpDotName
sourceLang :: Name 'Unvalidated UpDotName
, Pass -> Name 'Unvalidated UpDotName
targetLang :: Name 'Unvalidated UpDotName
}
deriving (Int -> Pass -> ShowS
[Pass] -> ShowS
Pass -> String
(Int -> Pass -> ShowS)
-> (Pass -> String) -> ([Pass] -> ShowS) -> Show Pass
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Pass -> ShowS
showsPrec :: Int -> Pass -> ShowS
$cshow :: Pass -> String
show :: Pass -> String
$cshowList :: [Pass] -> ShowS
showList :: [Pass] -> ShowS
Show)