diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,8 @@ +# 0.1.1 + +- Add `Overloaded.TypeNats` and `Overloaded.TypeSymbols` +- Add `FromSymbol s Day` instance validating `yyyy-mm-dd` format + +# 0.1 + +- Initial release diff --git a/example/Example.hs b/example/Example.hs --- a/example/Example.hs +++ b/example/Example.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedLabels #-} -- {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Symbols:Numerals:Lists:If:Labels=Overloaded.Symbols.fromSymbol #-} +{-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Symbols:Numerals:Lists:If:Labels=Overloaded.Symbols.fromSymbol:TypeNats #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -78,7 +78,7 @@ 1 + n @?= (3 :: Natural) -- fin: Fin - let f :: Fin (N.FromGHC 5) + let f :: Fin 5 f = 2 print f diff --git a/overloaded.cabal b/overloaded.cabal --- a/overloaded.cabal +++ b/overloaded.cabal @@ -1,7 +1,7 @@ -cabal-version: 2.2 -name: overloaded -version: 0.1 -synopsis: Overloaded pragmas as a plugin +cabal-version: 2.2 +name: overloaded +version: 0.1.1 +synopsis: Overloaded pragmas as a plugin description: Implement @Overloaded@ pragmas as a source plugin . @@ -17,12 +17,13 @@ {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Strings #-} @ -license: BSD-3-Clause -license-file: LICENSE -author: Oleg Grenrus -maintainer: Oleg Grenrus -category: Plugin -tested-with: GHC ==8.6.5 || ==8.8.1 +license: BSD-3-Clause +license-file: LICENSE +author: Oleg Grenrus +maintainer: Oleg Grenrus +category: Plugin +extra-source-files: CHANGELOG.md +tested-with: GHC ==8.6.5 || ==8.8.1 source-repository head type: git @@ -41,6 +42,8 @@ Overloaded.Numerals Overloaded.Plugin Overloaded.Symbols + Overloaded.TypeNats + Overloaded.TypeSymbols -- GHC boot dependencies build-depends: @@ -49,6 +52,7 @@ , containers ^>=0.6.0.1 , ghc ^>=8.6 || ^>=8.8 , text ^>=1.2.3.0 + , time ^>=1.8.0.2 || ^>=1.9.3 -- other dependencies build-depends: @@ -96,6 +100,9 @@ Overloaded.Test.Numerals Overloaded.Test.Strings Overloaded.Test.Symbols + Overloaded.Test.TypeSymbols + Regexp.Term + Regexp.Type -- inherited dependencies build-depends: @@ -107,11 +114,13 @@ , sop-core , symbols , text + , time , vec -- test dependencies build-depends: - , generic-lens ^>=1.2.0.0 - , lens ^>=4.18 - , tasty ^>=1.2.3 - , tasty-hunit ^>=0.10.0.2 + , generic-lens ^>=1.2.0.0 + , lens ^>=4.18 + , singleton-bool ^>=0.1.5 + , tasty ^>=1.2.3 + , tasty-hunit ^>=0.10.0.2 diff --git a/src/Overloaded.hs b/src/Overloaded.hs --- a/src/Overloaded.hs +++ b/src/Overloaded.hs @@ -28,8 +28,12 @@ -- * Overloaded:Labels -- | See "GHC.OverloadedLabels" for 'GHC.OverloadedLabels.fromLabel'. - -- - -- generic-lens example! + + -- * Overloaded:TypeNats + FromNatC (..), + + -- * Overloade:TypeSymbols + FromTypeSymbolC (..), ) where import Overloaded.Chars @@ -39,3 +43,5 @@ import Overloaded.Numerals import Overloaded.Plugin import Overloaded.Symbols +import Overloaded.TypeNats +import Overloaded.TypeSymbols diff --git a/src/Overloaded/Plugin.hs b/src/Overloaded/Plugin.hs --- a/src/Overloaded/Plugin.hs +++ b/src/Overloaded/Plugin.hs @@ -16,7 +16,7 @@ import qualified ErrUtils as Err import qualified Finder import qualified GhcPlugins as GHC -import HsSyn +import HsSyn as GHC import qualified IfaceEnv import SrcLoc import qualified TcRnMonad as TcM @@ -60,6 +60,7 @@ -- * @Lists@ __is not__ like built-in @OverloadedLists@, but desugars explicit lists to 'Overloaded.Lists.cons' and 'Overloaded.Lists.nil' -- * @If@ desugars @if@-expressions to @'Overloaded.If.ifte' b t e@ -- * @Labels@ works like built-in @OverloadedLabels@ (you should enable @OverloadedLabels@ so parser recognises the syntax) +-- * @TypeNats@ and @TypeSymbols@ desugar type-level literals into @'Overloaded.TypeNats.FromNat'@ and @'Overloaded.TypeSymbols.FromTypeSymbol'@ respectively. -- -- == Known limitations -- @@ -88,7 +89,7 @@ when (opts == defaultOptions) $ warn dflags noSrcSpan $ GHC.text "No Overloaded features enabled" - let transformNoOp :: LHsExpr GhcRn -> Maybe (LHsExpr GhcRn) + let transformNoOp :: a -> Maybe a transformNoOp _ = Nothing trStr <- case optStrings of @@ -142,11 +143,27 @@ n <- lookupVarName dflags topEnv vn return $ transformLabels $ names { fromLabelName = n } - let tr = trStr /\ trNum /\ trChr /\ trLists /\ trIf /\ trLabel + trTypeNats <- case optTypeNats of + Off -> return transformNoOp + On Nothing -> return $ transformTypeNats names + On (Just vn) -> do + n <- lookupTypeName dflags topEnv vn + return $ transformTypeNats $ names { fromTypeNatName = n } - gr' <- transform dflags tr gr + trTypeSymbols <- case optTypeSymbols of + Off -> return transformNoOp + On Nothing -> return $ transformTypeSymbols names + On (Just vn) -> do + n <- lookupTypeName dflags topEnv vn + return $ transformTypeSymbols $ names { fromTypeSymbolName = n } - return (env, gr') + let tr = trStr /\ trNum /\ trChr /\ trLists /\ trIf /\ trLabel + let trT = trTypeNats /\ trTypeSymbols + + gr' <- transformType dflags trT gr + gr'' <- transform dflags tr gr' + + return (env, gr'') where args = concatMap (splitOn ":") args' @@ -156,7 +173,7 @@ infixr 9 /\ -- hello CPP ------------------------------------------------------------------------------- --- Args parasing +-- Args parsing ------------------------------------------------------------------------------- parseArgs :: GHC.DynFlags -> [String] -> TcRnTypes.TcM Options @@ -213,6 +230,12 @@ go opts "Labels" vns = do mvn <- oneName "Symbols" vns return $ opts { optLabels = On mvn } + go opts "TypeNats" vns = do + mvn <- oneName "TypeNats" vns + return $ opts { optTypeNats = On mvn } + go opts "TypeSymbols" vns = do + mvn <- oneName "TypeSymbols" vns + return $ opts { optTypeSymbols = On mvn } go opts s _ = do warn dflags noSrcSpan $ GHC.text $ "Unknown Overloaded option " ++ show s @@ -249,23 +272,27 @@ return (Just (VN (intercalate "." $ init ps) (last ps))) data Options = Options - { optStrings :: StrSym - , optNumerals :: NumNat - , optChars :: OnOff VarName - , optLists :: OnOff (V2 VarName) - , optIf :: OnOff VarName - , optLabels :: OnOff VarName + { optStrings :: StrSym + , optNumerals :: NumNat + , optChars :: OnOff VarName + , optLists :: OnOff (V2 VarName) + , optIf :: OnOff VarName + , optLabels :: OnOff VarName + , optTypeNats :: OnOff VarName + , optTypeSymbols :: OnOff VarName } deriving (Eq, Show) defaultOptions :: Options defaultOptions = Options - { optStrings = NoStr - , optNumerals = NoNum - , optChars = Off - , optLists = Off - , optIf = Off - , optLabels = Off + { optStrings = NoStr + , optNumerals = NoNum + , optChars = Off + , optLists = Off + , optIf = Off + , optLabels = Off + , optTypeNats = Off + , optTypeSymbols = Off } data StrSym @@ -399,6 +426,26 @@ transformLabels _ _ = Nothing ------------------------------------------------------------------------------- +-- OverloadedTypeNats +------------------------------------------------------------------------------- + +transformTypeNats :: Names -> LHsType GhcRn -> Maybe (LHsType GhcRn) +transformTypeNats Names {..} e@(L l (HsTyLit _ (HsNumTy _ _))) = do + let name' = L l $ HsTyVar noExt GHC.NotPromoted $ L l fromTypeNatName + Just $ L l $ HsAppTy noExt name' e +transformTypeNats _ _ = Nothing + +------------------------------------------------------------------------------- +-- OverloadedTypeSymbols +------------------------------------------------------------------------------- + +transformTypeSymbols :: Names -> LHsType GhcRn -> Maybe (LHsType GhcRn) +transformTypeSymbols Names {..} e@(L l (HsTyLit _ (HsStrTy _ _))) = do + let name' = L l $ HsTyVar noExt GHC.NotPromoted $ L l fromTypeSymbolName + Just $ L l $ HsAppTy noExt name' e +transformTypeSymbols _ _ = Nothing + +------------------------------------------------------------------------------- -- Transform ------------------------------------------------------------------------------- @@ -414,6 +461,18 @@ Just e' -> e' Nothing -> e +transformType + :: GHC.DynFlags + -> (LHsType GhcRn -> Maybe (LHsType GhcRn)) + -> HsGroup GhcRn + -> TcRnTypes.TcM (HsGroup GhcRn) +transformType _dflags f = SYB.everywhereM (SYB.mkM transform') where + transform' :: LHsType GhcRn -> TcRnTypes.TcM (LHsType GhcRn) + transform' e = do + return $ case f e of + Just e' -> e' + Nothing -> e + ------------------------------------------------------------------------------- -- Constructors ------------------------------------------------------------------------------- @@ -461,20 +520,28 @@ ghcOverloadedLabelsMN :: GHC.ModuleName ghcOverloadedLabelsMN = GHC.mkModuleName "GHC.OverloadedLabels" +overloadedTypeNatsMN :: GHC.ModuleName +overloadedTypeNatsMN = GHC.mkModuleName "Overloaded.TypeNats" + +overloadedTypeSymbolsMN :: GHC.ModuleName +overloadedTypeSymbolsMN = GHC.mkModuleName "Overloaded.TypeSymbols" + ------------------------------------------------------------------------------- -- Names ------------------------------------------------------------------------------- data Names = Names - { fromStringName :: GHC.Name - , fromSymbolName :: GHC.Name - , fromNumeralName :: GHC.Name - , fromNaturalName :: GHC.Name - , fromCharName :: GHC.Name - , nilName :: GHC.Name - , consName :: GHC.Name - , ifteName :: GHC.Name - , fromLabelName :: GHC.Name + { fromStringName :: GHC.Name + , fromSymbolName :: GHC.Name + , fromNumeralName :: GHC.Name + , fromNaturalName :: GHC.Name + , fromCharName :: GHC.Name + , nilName :: GHC.Name + , consName :: GHC.Name + , ifteName :: GHC.Name + , fromLabelName :: GHC.Name + , fromTypeNatName :: GHC.Name + , fromTypeSymbolName :: GHC.Name } getNames :: GHC.DynFlags -> GHC.HscEnv -> TcRnTypes.TcM Names @@ -489,6 +556,9 @@ ifteName <- lookupName dflags env overloadedIfMN "ifte" fromLabelName <- lookupName dflags env ghcOverloadedLabelsMN "fromLabel" + fromTypeNatName <- lookupName' dflags env overloadedTypeNatsMN "FromNat" + fromTypeSymbolName <- lookupName' dflags env overloadedTypeSymbolsMN "FromTypeSymbol" + return Names {..} lookupName :: GHC.DynFlags -> GHC.HscEnv -> GHC.ModuleName -> String -> TcM.TcM GHC.Name @@ -501,12 +571,25 @@ GHC.text "Cannot find module" GHC.<+> GHC.ppr mn fail "panic!" +lookupName' :: GHC.DynFlags -> GHC.HscEnv -> GHC.ModuleName -> String -> TcM.TcM GHC.Name +lookupName' dflags env mn vn = do + res <- liftIO $ Finder.findImportedModule env mn Nothing + case res of + GHC.Found _ md -> IfaceEnv.lookupOrig md (GHC.mkTcOcc vn) + _ -> do + liftIO $ GHC.putLogMsg dflags GHC.NoReason Err.SevError noSrcSpan (GHC.defaultErrStyle dflags) $ + GHC.text "Cannot find module" GHC.<+> GHC.ppr mn + fail "panic!" + -- | Module name and variable name data VarName = VN String String deriving (Eq, Show) lookupVarName :: GHC.DynFlags -> GHC.HscEnv -> VarName -> TcM.TcM GHC.Name lookupVarName dflags env (VN vn mn) = lookupName dflags env (GHC.mkModuleName vn) mn + +lookupTypeName :: GHC.DynFlags -> GHC.HscEnv -> VarName -> TcM.TcM GHC.Name +lookupTypeName dflags env (VN vn mn) = lookupName' dflags env (GHC.mkModuleName vn) mn ------------------------------------------------------------------------------- -- diagnostics diff --git a/src/Overloaded/Symbols.hs b/src/Overloaded/Symbols.hs --- a/src/Overloaded/Symbols.hs +++ b/src/Overloaded/Symbols.hs @@ -5,6 +5,7 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -14,12 +15,14 @@ FromSymbol (..), ) where -import Data.Proxy (Proxy (..)) -import Data.String (fromString) -import Data.Symbol.Ascii (ToList) -import GHC.Exts (Constraint) +import Data.Proxy (Proxy (..)) +import Data.String (fromString) +import Data.Symbol.Ascii (ToList) +import Data.Time.Calendar (Day, fromGregorian) +import GHC.Exts (Constraint) import GHC.TypeLits (ErrorMessage (..), KnownSymbol, Symbol, TypeError, symbolVal) +import GHC.TypeNats import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL @@ -74,3 +77,68 @@ instance (KnownSymbol s, SeqList (ToList s)) => FromSymbol s BSL.ByteString where fromSymbol = fromString (symbolVal (Proxy :: Proxy s)) + +------------------------------------------------------------------------------- +-- time +------------------------------------------------------------------------------- + +instance (KnownNat y, KnownNat m, KnownNat d, ParseDay s ~ '(y, m, d)) => FromSymbol s Day where + fromSymbol = fromGregorian (integralVal @y) (integralVal @m) (integralVal @d) + +integralVal :: forall n m. (KnownNat n, Num m) => m +integralVal = fromIntegral (natVal (Proxy :: Proxy n)) + +type family ParseDay (sym :: Symbol) :: (Nat, Nat, Nat) where + ParseDay sym = ParseDay1 sym (ToList sym) + +type a ** b = a GHC.TypeNats.* b +infixl 7 ** + +type family ParseDay1 (sym :: Symbol) (cs :: [Symbol]) :: (Nat, Nat, Nat) where + ParseDay1 sym (y1 ': y2 ': y3 ': y4 ': "-" ': m1 ': m2 ': "-" ': d1 ': d2 :' []) + = ParseDay2 sym (1000 ** TD y1 + 100 ** TD y2 + 10 ** TD y3 + TD y4) (10 ** TD m1 + TD m2) (10 ** TD d1 + TD d2) + ParseDay1 sym cs = TypeError ('ShowType sym ':<>: 'Text " doesn't look like a date (yyyy-mm-dd)") + +-- To Digit +type family TD (c :: Symbol) :: Nat where + TD "0" = 0 + TD "1" = 1 + TD "2" = 2 + TD "3" = 3 + TD "4" = 4 + TD "5" = 5 + TD "6" = 6 + TD "7" = 7 + TD "8" = 8 + TD "9" = 9 + TD c = TypeError ('ShowType c ':<>: 'Text " is not a digit") + +type family ParseDay2 (sym :: Symbol) (y :: Nat) (m :: Nat) (d :: Nat) :: (Nat, Nat, Nat) where + ParseDay2 sym y m 0 = TypeError ('Text "Zero-day in " ':<>: 'ShowType sym) + ParseDay2 sym y 0 d = TypeError ('Text "Zero-month in " ':<>: 'ShowType sym) + ParseDay2 sym y m d = ParseDay3 sym y m d (d <=? DaysIn y m) + +type family ParseDay3 (sym :: Symbol) (y :: Nat) (m :: Nat) (d :: Nat) (check :: Bool) :: (Nat, Nat, Nat) where + ParseDay3 sym y m d 'True = '(y, m , d) + ParseDay3 sym y m d 'False = TypeError ('Text "There are only " ':<>: 'ShowType (DaysIn y m) ':<>: 'Text " days in year-of-month of " ':<>: 'ShowType sym) + +type family DaysIn (y :: Nat) (m :: Nat) where + DaysIn y 1 = 31 + DaysIn y 2 = Leap (Mod y 4) (Mod y 100) (Mod y 400) + DaysIn y 3 = 31 + DaysIn y 4 = 30 + DaysIn y 5 = 31 + DaysIn y 6 = 30 + DaysIn y 7 = 31 + DaysIn y 8 = 31 + DaysIn y 9 = 30 + DaysIn y 10 = 31 + DaysIn y 11 = 30 + DaysIn y 12 = 31 + DaysIn y m = TypeError ('Text "Overflowed month " ':<>: 'ShowType m) + +type family Leap (a :: Nat) (b :: Nat) (c :: Nat) :: Nat where + Leap a b 0 = 29 + Leap a 0 c = 28 + Leap 0 b c = 29 + Leap a b c = 28 diff --git a/src/Overloaded/TypeNats.hs b/src/Overloaded/TypeNats.hs new file mode 100644 --- /dev/null +++ b/src/Overloaded/TypeNats.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +-- | Overloaded type-level natural numbers. +module Overloaded.TypeNats where + +import GHC.TypeNats (Nat) + +import qualified Data.Type.Nat as N + +-- | A way to overload type level 'Nat's. +-- +-- A number type-literal @42@ is desugared to +-- +-- @ +-- 'FromNat' 42 +-- @ +-- +-- Enabled with: +-- +-- @ +-- {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:TypeNats #-} +-- @ +-- +class FromNatC a where + type family FromNat (n :: Nat) :: a + +instance FromNatC Nat where + type FromNat n = n + +instance FromNatC N.Nat where + type FromNat n = N.FromGHC n diff --git a/src/Overloaded/TypeSymbols.hs b/src/Overloaded/TypeSymbols.hs new file mode 100644 --- /dev/null +++ b/src/Overloaded/TypeSymbols.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +-- | Overloaded type-level symbols. +module Overloaded.TypeSymbols where + +import GHC.TypeLits (Symbol) + +-- | A way to overload type level 'Symbol's. +-- +-- A symbol type-literal @"example"@ is desugared to +-- +-- @ +-- 'FromTypeSymbol' "example" +-- @ +-- +-- Enabled with: +-- +-- @ +-- {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:TypeSymbols #-} +-- @ +-- +class FromTypeSymbolC a where + type family FromTypeSymbol (s :: Symbol) :: a + +instance FromTypeSymbolC Symbol where + type FromTypeSymbol s = s diff --git a/test/Overloaded/Test/Symbols.hs b/test/Overloaded/Test/Symbols.hs --- a/test/Overloaded/Test/Symbols.hs +++ b/test/Overloaded/Test/Symbols.hs @@ -10,12 +10,13 @@ {-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Symbols #-} module Overloaded.Test.Symbols where -import Data.Proxy (Proxy (..)) -import GHC.Exts (Constraint) +import Data.Proxy (Proxy (..)) +import Data.Time.Calendar (fromGregorian) +import GHC.Exts (Constraint) import GHC.TypeLits (ErrorMessage (..), KnownSymbol, Symbol, TypeError, symbolVal) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) import Overloaded @@ -32,4 +33,6 @@ tests = testGroup "Symbols" [ testCase "NES" $ "foo" @?= NES "foo" + , testCase "Day" $ + "2020-02-29" @?= fromGregorian 2020 02 29 ] diff --git a/test/Overloaded/Test/TypeSymbols.hs b/test/Overloaded/Test/TypeSymbols.hs new file mode 100644 --- /dev/null +++ b/test/Overloaded/Test/TypeSymbols.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:TypeSymbols #-} +module Overloaded.Test.TypeSymbols where + +import Data.Singletons.Bool (SBool (..)) +import Regexp.Type (Matches) + +example :: SBool (Matches "(foo|bar*)*q[u-w]x" "fooqux") +example = STrue diff --git a/test/Regexp/Term.hs b/test/Regexp/Term.hs new file mode 100644 --- /dev/null +++ b/test/Regexp/Term.hs @@ -0,0 +1,73 @@ +module Regexp.Term where + +-- | Simple regular expressions. +data RE a + = Eps -- ^ empty string + | Chr [a] -- ^ character "sets", empty list means Empty! + | App [RE a] -- ^ append + | Alt [RE a] -- ^ union + | Str (RE a) -- ^ star + deriving (Show) + +mkApp :: [RE a] -> RE a +mkApp [] = Eps +mkApp [r] = r +mkApp rs = App rs + +mkAlt :: [RE a] -> RE a +mkAlt [] = Chr [] +mkAlt [r] = r +mkAlt rs = Alt rs + +mkStr :: RE a -> RE a +mkStr Eps = Eps +mkStr (Chr []) = Eps +mkStr (Str a) = Str a +mkStr a = Str a + +type M = Either String + +data Stack a + = ES -- empty stack + | Push [RE a] [RE a] (Stack a) + deriving (Show) + +type Result = M (RE Char) + +parse :: [Char] -> Result +parse = parseGo ES [] [] + +mkAlt', mkApp' :: [RE a] -> RE a +mkAlt' = mkAlt . reverse +mkApp' = mkApp . reverse + +parseGo + :: Stack Char -- ^ stack + -> [RE Char] -- ^ previous alternatives + -> [RE Char] -- ^ previous appendables + -> [Char] -- ^ input + -> Result +parseGo ES alt app [] = Right (mkAlt' (mkApp' app : alt)) +parseGo s alt app [] = Left (show $ "Non-empty stack at end-of-input " ++ show s) +parseGo s alt [] ('*' : cs) = Left (show "Unattached star") +parseGo s alt (x:xs) ('*' : cs) = parseGo s alt (mkStr x : xs) cs +parseGo s alt app ('|' : cs) = parseGo s (mkApp' app : alt) [] cs +parseGo s alt app ('(' : cs) = parseGo (Push alt app s) [] [] cs +parseGo s alt app (')' : cs) = case s of + ES -> Left (show $ "Unmatched ) before " ++ cs) + Push altP appP sP -> parseGo sP altP (mkAlt' (mkApp' app : alt) : appP) cs +parseGo s alt app ('[' : cs) = parseChr s alt app [] cs +parseGo s alt app (']' : cs) = Left ("Unmatched ] before " ++ cs) +parseGo s alt app (c : cs) = parseGo s alt (Chr [c] : app) cs + +parseChr + :: Stack Char -- ^ stack + -> [RE Char] -- ^ previous alternatives + -> [RE Char] -- ^ previous appendables + -> [Char] -- ^ characters accumulator + -> [Char] -- ^ input + -> Result +parseChr s alt app acc [] = Left "Non-terminated character set at end-of-input" +parseChr s alt app acc (']' : cs) = parseGo s alt (Chr acc : app) cs +parseChr s alt app acc (c : '-' : c' : cs) = parseChr s alt app ([c .. c'] ++ acc) cs +parseChr s alt app acc (c : cs) = parseChr s alt app (c : acc) cs diff --git a/test/Regexp/Type.hs b/test/Regexp/Type.hs new file mode 100644 --- /dev/null +++ b/test/Regexp/Type.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Regexp.Type ( + Parse, + Matches, + ) where + +import Data.Symbol.Ascii (ToList) +import Data.Type.Bool +import GHC.TypeLits + +import Overloaded +import Regexp.Term (RE (..), Stack (..)) + +-- $setup +-- >>> :set -XDataKinds + +instance FromTypeSymbolC (RE Symbol) where + type FromTypeSymbol s = Parse s + +------------------------------------------------------------------------------- +-- Public +------------------------------------------------------------------------------- + +-- | Parse 'Symbol' into 'RE'gular expression. +-- +-- >>> :kind! Parse "" +-- Parse "" :: RE Symbol +-- = 'Eps +-- +-- >>> :kind! Parse "(foo|bar*)*q[u-w]x" +-- Parse "(foo|bar*)*q[u-w]x" :: RE Symbol +-- = 'App +-- '['Str +-- ('Alt +-- '['App '['Chr '["b"], 'Chr '["a"], 'Str ('Chr '["r"])], +-- 'App '['Chr '["f"], 'Chr '["o"], 'Chr '["o"]]]), +-- 'Chr '["q"], 'Chr '["u", "v", "w"], 'Chr '["x"]] +-- +type family Parse (cs :: Symbol) :: RE Symbol where + Parse "" = Eps + Parse cs = ParseGo ES '[] '[] (ToList cs) + +-- | Match the regular expression against the symbol. +-- +-- >>> type Regex = Parse "(foo|bar*)*q[u-w]x" +-- >>> :kind! Matches Regex "" +-- Matches Regex "" :: Bool +-- = 'False +-- +-- >>> :kind! Matches Regex "fooqux" +-- Matches Regex "fooqux" :: Bool +-- = 'True +-- +-- >>> :kind! Matches Regex "barrrrrqwx" +-- Matches Regex "barrrrrqwx" :: Bool +-- = 'True +-- +-- >>> :kind! Matches Regex "barrrrrqwx!" +-- Matches Regex "barrrrrqwx!" :: Bool +-- = 'False +-- +type family Matches (re :: RE Symbol) (cs :: Symbol) :: Bool where + Matches re cs = MatchesGo re (ToList cs) + +------------------------------------------------------------------------------- +-- Constructors +------------------------------------------------------------------------------- + +type Empty = Chr '[] + +type family MkAlt (alts :: [RE Symbol]) :: RE Symbol where + MkAlt '[] = Empty + MkAlt '[r] = r + MkAlt rs = Alt rs + +type family MkApp (apps :: [RE Symbol]) :: RE Symbol where + MkApp '[] = Eps + MkApp '[r] = r + MkApp rs = App (Reverse rs) + +type family MkStr (r :: RE Symbol) :: RE Symbol where + MkStr Eps = Eps + MkStr (Chr '[]) = Eps + MkStr (Str r) = Str r + MkStr r = Str r + +------------------------------------------------------------------------------- +-- Parsing +------------------------------------------------------------------------------- + +type family ParseGo (s :: Stack Symbol) (alt :: [RE Symbol]) (app :: [RE Symbol]) (cs :: [Symbol]) :: RE Symbol where + ParseGo ES alt app '[] = MkAlt (MkApp app ': alt) + ParseGo s alt app '[] = TypeError ('Text "Unexpected end-of-input, there is unclosed (") + ParseGo s alt '[] ("*" : cs) = TypeError ('Text "Unattached star") + ParseGo s alt (x : xs) ("*" : cs) = ParseGo s alt (MkStr x : xs) cs + ParseGo s alt app ("|" : cs) = ParseGo s (MkApp app : alt) '[] cs + ParseGo s alt app ("(" : cs) = ParseGo (Push alt app s) '[] '[] cs + ParseGo s alt app (")" : cs) = ParseGoPop s alt app cs + ParseGo s alt app ("[" : cs) = ParseChr s alt app '[] cs + ParseGo s alt app ("]" : cs) = TypeError ('Text "Unmatched ] before " :<>: ShowType cs) + ParseGo s alt app (c : cs) = ParseGo s alt (Chr '[c] : app) cs + +type family ParseGoPop (s :: Stack Symbol) (alt :: [RE Symbol]) (app :: [RE Symbol]) (cs :: [Symbol]) :: RE Symbol where + ParseGoPop ES _ _ cs = TypeError ('Text "Unmatched ) before " :<>: ShowType cs) + ParseGoPop (Push altP appP s) alt app cs = + ParseGo s altP (MkAlt (MkApp app : alt) : appP) cs + +type family ParseChr (s :: Stack Symbol) (alt :: [RE Symbol]) (app :: [RE Symbol]) (acc :: [Symbol]) (cs :: [Symbol]) :: RE Symbol where + ParseChr s alt app acc '[] = TypeError ('Text "Non-terminated character set") + ParseChr s alt app acc ("]" : cs) = ParseGo s alt (Chr acc : app) cs + ParseChr s alt app acc (c : "-" : c' : cs) = ParseChr s alt app (Append (FromTo c c') acc) cs + ParseChr s alt app acc (c : cs) = ParseChr s alt app (c : acc) cs + +------------------------------------------------------------------------------- +-- Matching +------------------------------------------------------------------------------- + +type family MatchesGo (re :: RE Symbol) (cs :: [Symbol]) :: Bool where + MatchesGo re '[] = Nullable re + MatchesGo re (c : cs) = MatchesGo (Derivate re c) cs + +type family Nullable (re :: RE Symbol) :: Bool where + Nullable Eps = True + Nullable (Chr cs) = False + Nullable (App '[]) = True + Nullable (App (r : rs)) = Nullable r && Nullable (App rs) + Nullable (Alt '[]) = False + Nullable (Alt (r : rs)) = Nullable r || Nullable (Alt rs) + Nullable (Str r) = True + +type family Derivate (re :: RE Symbol) (c :: Symbol) :: RE Symbol where + Derivate Eps c = Empty + Derivate (Chr cs) c = DerivateChr cs c + Derivate (App rs) c = DerivateApp rs c + Derivate (Alt rs) c = DerivateAlt rs c + Derivate (Str r) c = MkApp '[ Derivate r c , Str r] + +type family DerivateChr (cs :: [Symbol]) (c :: Symbol) :: RE Symbol where + DerivateChr '[] c = Empty + DerivateChr (x ': xs) x = Eps -- non-linear match + DerivateChr (x ': xs) c = DerivateChr xs c + +type family DerivateApp (rs :: [RE Symbol]) (c :: Symbol) where + DerivateApp '[] c = Empty + DerivateApp '[r] c = Derivate r c + DerivateApp (r : rs) c = DerivateApp1 (Nullable r) r rs c + +type family DerivateApp1 (n :: Bool) (r :: RE Symbol) (rs :: [RE Symbol]) (c :: Symbol) where + DerivateApp1 False r rs c = App (Derivate r c : rs) + DerivateApp1 True r rs c = MkAlt '[ App (Derivate r c : rs), DerivateApp rs c ] + +type family DerivateAlt (rs :: [RE Symbol]) (c :: Symbol) :: RE Symbol where + DerivateAlt rs c = MkAlt (MapDerivate rs c) + +type family MapDerivate (rs :: [RE Symbol]) (c :: Symbol) :: [RE Symbol] where + MapDerivate '[] c = '[] + MapDerivate (r : rs) c = Derivate r c : MapDerivate rs c + +------------------------------------------------------------------------------- +-- List +------------------------------------------------------------------------------- + +type family Append (xs :: [k]) (ys :: [k]) :: [k] where + Append '[] ys = ys + Append (x : xs) ys = x : Append xs ys + +type family Reverse (xs :: [k]) :: [k] where + Reverse '[] = '[] + Reverse (x ': xs) = Snoc (Reverse xs) x + +type family Snoc (xs :: [k]) (x :: k) :: [k] where + Snoc '[] y = '[y] + Snoc (x ': xs) y = x ': Snoc xs y + +------------------------------------------------------------------------------- +-- FromTo +------------------------------------------------------------------------------- + +type family FromTo (a :: Symbol) (b :: Symbol) :: [Symbol] where + FromTo a b = FromTo1 a b (CmpSymbol a b) + +type family FromTo1 (a :: Symbol) (b :: Symbol) (o :: Ordering) :: [Symbol] where + FromTo1 a b EQ = '[a] + FromTo1 a b GT = '[] + FromTo1 a b LT = a ': FromTo (SuccChar a) b + +type family SuccChar (c :: Symbol) :: Symbol where + SuccChar "\NUL" = "\SOH" + SuccChar "\SOH" = "\STX" + SuccChar "\STX" = "\ETX" + SuccChar "\ETX" = "\EOT" + SuccChar "\EOT" = "\ENQ" + SuccChar "\ENQ" = "\ACK" + SuccChar "\ACK" = "\a" + SuccChar "\a" = "\b" + SuccChar "\b" = "\t" + SuccChar "\t" = "\n" + SuccChar "\n" = "\v" + SuccChar "\v" = "\f" + SuccChar "\f" = "\r" + SuccChar "\r" = "\SO" + SuccChar "\SO" = "\SI" + SuccChar "\SI" = "\DLE" + SuccChar "\DLE" = "\DC1" + SuccChar "\DC1" = "\DC2" + SuccChar "\DC2" = "\DC3" + SuccChar "\DC3" = "\DC4" + SuccChar "\DC4" = "\NAK" + SuccChar "\NAK" = "\SYN" + SuccChar "\SYN" = "\ETB" + SuccChar "\ETB" = "\CAN" + SuccChar "\CAN" = "\EM" + SuccChar "\EM" = "\SUB" + SuccChar "\SUB" = "\ESC" + SuccChar "\ESC" = "\FS" + SuccChar "\FS" = "\GS" + SuccChar "\GS" = "\RS" + SuccChar "\RS" = "\US" + SuccChar "\US" = " " + SuccChar " " = "!" + SuccChar "!" = "\"" + SuccChar "\"" = "#" + SuccChar "#" = "$" + SuccChar "$" = "%" + SuccChar "%" = "&" + SuccChar "&" = "'" + SuccChar "'" = "(" + SuccChar "(" = ")" + SuccChar ")" = "*" + SuccChar "*" = "+" + SuccChar "+" = "," + SuccChar "," = "-" + SuccChar "-" = "." + SuccChar "." = "/" + SuccChar "/" = "0" + SuccChar "0" = "1" + SuccChar "1" = "2" + SuccChar "2" = "3" + SuccChar "3" = "4" + SuccChar "4" = "5" + SuccChar "5" = "6" + SuccChar "6" = "7" + SuccChar "7" = "8" + SuccChar "8" = "9" + SuccChar "9" = ":" + SuccChar ":" = ";" + SuccChar ";" = "<" + SuccChar "<" = "=" + SuccChar "=" = ">" + SuccChar ">" = "?" + SuccChar "?" = "@" + SuccChar "@" = "A" + SuccChar "A" = "B" + SuccChar "B" = "C" + SuccChar "C" = "D" + SuccChar "D" = "E" + SuccChar "E" = "F" + SuccChar "F" = "G" + SuccChar "G" = "H" + SuccChar "H" = "I" + SuccChar "I" = "J" + SuccChar "J" = "K" + SuccChar "K" = "L" + SuccChar "L" = "M" + SuccChar "M" = "N" + SuccChar "N" = "O" + SuccChar "O" = "P" + SuccChar "P" = "Q" + SuccChar "Q" = "R" + SuccChar "R" = "S" + SuccChar "S" = "T" + SuccChar "T" = "U" + SuccChar "U" = "V" + SuccChar "V" = "W" + SuccChar "W" = "X" + SuccChar "X" = "Y" + SuccChar "Y" = "Z" + SuccChar "Z" = "[" + SuccChar "[" = "\\" + SuccChar "\\" = "]" + SuccChar "]" = "^" + SuccChar "^" = "_" + SuccChar "_" = "`" + SuccChar "`" = "a" + SuccChar "a" = "b" + SuccChar "b" = "c" + SuccChar "c" = "d" + SuccChar "d" = "e" + SuccChar "e" = "f" + SuccChar "f" = "g" + SuccChar "g" = "h" + SuccChar "h" = "i" + SuccChar "i" = "j" + SuccChar "j" = "k" + SuccChar "k" = "l" + SuccChar "l" = "m" + SuccChar "m" = "n" + SuccChar "n" = "o" + SuccChar "o" = "p" + SuccChar "p" = "q" + SuccChar "q" = "r" + SuccChar "r" = "s" + SuccChar "s" = "t" + SuccChar "t" = "u" + SuccChar "u" = "v" + SuccChar "v" = "w" + SuccChar "w" = "x" + SuccChar "x" = "y" + SuccChar "y" = "z" + SuccChar "z" = "{" + SuccChar "{" = "|" + SuccChar "|" = "}" + SuccChar "}" = "~" + SuccChar "~" = "\DEL" + SuccChar c = TypeError ('Text "SuccChar: out of ASCII range" :<>: ShowType c) +