mirror of
https://github.com/chrisdone/duet.git
synced 2024-10-26 11:30:19 +03:00
Make Infer take Label concrete type
This commit is contained in:
parent
c8aa9a29ff
commit
f0c34347d0
@ -79,13 +79,13 @@ import Duet.Types
|
||||
--
|
||||
-- Throws 'InferException' in case of a type error.
|
||||
typeCheckModule ::
|
||||
(MonadThrow m, Show l, Data l)
|
||||
=> Map Name (Class Type Name l) -- ^ Set of defined type-classes.
|
||||
(MonadThrow m)
|
||||
=> Map Name (Class Type Name Label) -- ^ Set of defined type-classes.
|
||||
-> [(TypeSignature Type Name Name)] -- ^ Pre-defined type signatures e.g. for built-ins or FFI.
|
||||
-> SpecialTypes Name -- ^ Special types that Haskell uses for pattern matching and literals.
|
||||
-> [Binding Type Name l] -- ^ Bindings in the module.
|
||||
-> m ( [BindGroup Type Name (TypeSignature Type Name l)]
|
||||
, Map Name (Class Type Name (TypeSignature Type Name l)))
|
||||
-> [Binding Type Name Label] -- ^ Bindings in the module.
|
||||
-> m ( [BindGroup Type Name (TypeSignature Type Name Label)]
|
||||
, Map Name (Class Type Name (TypeSignature Type Name Label)))
|
||||
typeCheckModule ce as specialTypes bgs0 = do
|
||||
(bgs, classes) <- runTypeChecker (dependencyAnalysis bgs0)
|
||||
pure (bgs, classes)
|
||||
|
@ -200,6 +200,19 @@ data StepException
|
||||
deriving (Typeable, Show)
|
||||
instance Exception StepException
|
||||
|
||||
data Label = Label
|
||||
{ labelUUID :: UUID
|
||||
} deriving (Generic, Show, Data, Typeable, Eq, Ord)
|
||||
instance NFData Label
|
||||
instance FromJSON Label
|
||||
instance ToJSON Label
|
||||
|
||||
newtype UUID = UUID String
|
||||
deriving (Ord, Eq, Show, Generic, Data, Typeable)
|
||||
instance NFData UUID
|
||||
instance FromJSON UUID
|
||||
instance ToJSON UUID
|
||||
|
||||
instance NFData (RenamerException)
|
||||
instance ToJSON (RenamerException)
|
||||
instance FromJSON (RenamerException)
|
||||
|
@ -45,8 +45,8 @@ initExpression :: forall (t :: * -> *) i. Expression t i Label
|
||||
initExpression =
|
||||
(ConstantExpression (Label {labelUUID = starterExprUUID}) (Identifier "_"))
|
||||
|
||||
starterExprUUID :: Flux.Persist.UUID
|
||||
starterExprUUID = Flux.Persist.UUID "STARTER-EXPR"
|
||||
starterExprUUID :: UUID
|
||||
starterExprUUID = UUID "STARTER-EXPR"
|
||||
|
||||
makeState :: String -> Expression UnkindedType Identifier Label -> State
|
||||
makeState ident expr =
|
||||
@ -55,18 +55,18 @@ makeState ident expr =
|
||||
, stateTypeCheck = Right ()
|
||||
, stateAST =
|
||||
ModuleNode
|
||||
(Label (Flux.Persist.UUID "STARTER-MODULE"))
|
||||
(Label (UUID "STARTER-MODULE"))
|
||||
[ BindDecl
|
||||
(Label {labelUUID = uuidD})
|
||||
(ImplicitBinding
|
||||
(ImplicitlyTypedBinding
|
||||
{ implicitlyTypedBindingLabel =
|
||||
Label (Flux.Persist.UUID "STARTER-BINDING")
|
||||
Label (UUID "STARTER-BINDING")
|
||||
, implicitlyTypedBindingId = (Identifier ident, Label uuidI)
|
||||
, implicitlyTypedBindingAlternatives =
|
||||
[ Alternative
|
||||
{ alternativeLabel =
|
||||
Label (Flux.Persist.UUID "STARTER-ALT")
|
||||
Label (UUID "STARTER-ALT")
|
||||
, alternativePatterns = []
|
||||
, alternativeExpression = expr
|
||||
}
|
||||
@ -75,8 +75,8 @@ makeState ident expr =
|
||||
]
|
||||
}
|
||||
where
|
||||
uuidD = Flux.Persist.UUID "STARTER-DECL"
|
||||
uuidI = Flux.Persist.UUID "STARTER-BINDING-ID"
|
||||
uuidD = UUID "STARTER-DECL"
|
||||
uuidI = UUID "STARTER-BINDING-ID"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Model
|
||||
@ -135,7 +135,7 @@ createContext decls = do
|
||||
do builtins <-
|
||||
setupEnv mempty [] >>=
|
||||
traverse
|
||||
(const (pure (Label {labelUUID = Flux.Persist.UUID "<GENERATED>"})))
|
||||
(const (pure (Label {labelUUID = UUID "<GENERATED>"})))
|
||||
let specials = builtinsSpecials builtins
|
||||
catch
|
||||
(do (typeClasses, signatures, renamedBindings, scope, dataTypes) <-
|
||||
|
@ -79,7 +79,7 @@ newParens = do
|
||||
uuid <- Flux.Persist.generateUUID
|
||||
ParensExpression (Label {labelUUID = uuid}) <$> newExpression
|
||||
|
||||
newBindDecl :: IO (Flux.Persist.UUID,Decl UnkindedType Identifier Label)
|
||||
newBindDecl :: IO (UUID,Decl UnkindedType Identifier Label)
|
||||
newBindDecl = do
|
||||
bgd <- fmap Label Flux.Persist.generateUUID
|
||||
implicitBinding <- fmap Label Flux.Persist.generateUUID
|
||||
|
@ -13,7 +13,6 @@ import Data.Maybe
|
||||
import Duet.IDE.Constructors
|
||||
import Duet.IDE.Types
|
||||
import Duet.Types
|
||||
import React.Flux.Persist (UUID)
|
||||
|
||||
interpretAction :: Action -> StateT State IO ()
|
||||
interpretAction =
|
||||
|
@ -9,7 +9,6 @@ import Data.Aeson
|
||||
import Data.Data
|
||||
import Duet.Types
|
||||
import GHC.Generics
|
||||
import React.Flux.Persist (UUID)
|
||||
|
||||
data State = State
|
||||
{ stateCursor :: !Cursor
|
||||
@ -53,10 +52,6 @@ data Action
|
||||
| InsertChar !Char
|
||||
deriving (Generic, NFData, Show, FromJSON, ToJSON)
|
||||
|
||||
data Label = Label
|
||||
{ labelUUID :: UUID
|
||||
} deriving (Generic, NFData, Show, FromJSON, ToJSON, Data, Typeable)
|
||||
|
||||
data Keydown
|
||||
= BackspaceKey
|
||||
| TabKey
|
||||
|
@ -9,15 +9,11 @@
|
||||
module React.Flux.Persist where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.DeepSeq
|
||||
import Control.Exception
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types
|
||||
import Data.Data
|
||||
import Data.JSString
|
||||
import Data.Typeable
|
||||
import GHC.Generics
|
||||
import GHCJS.Foreign.Callback
|
||||
import Duet.Types (UUID(..))
|
||||
import GHCJS.Marshal (FromJSVal(..), ToJSVal(..), toJSVal_aeson)
|
||||
import GHCJS.Types (JSVal, JSString)
|
||||
|
||||
@ -64,8 +60,5 @@ foreign import javascript unsafe "window['resetUUID']()"
|
||||
resetUUID :: IO ()
|
||||
resetUUID = js_resetUUID
|
||||
|
||||
newtype UUID = UUID String
|
||||
deriving (Ord, Eq, Show, NFData, FromJSON, ToJSON, Generic, Data, Typeable)
|
||||
|
||||
generateUUID :: IO UUID
|
||||
generateUUID = UUID . unpack <$> js_generateUUID
|
||||
|
Loading…
Reference in New Issue
Block a user