[ new ] basic readFrom directive

Author: fredrikNordvallForsberg

LabMate.cabal

@@ -1,6 +1,6 @@
 cabal-version:      2.4
 name:               LabMate
-version:            0.2.0.4
+version:            0.2.0.5
 
 -- A short (one-line) description of the package.
 -- synopsis:

emacs/labmate.el

@@ -43,7 +43,7 @@
   ;; handling comments
   :syntax-table (make-syntax-table)
   ;; code for syntax highlighting
-  (font-lock-add-keywords nil '(("^\s*%>[^%\n]+" . 'labmate-directive)))
+  (font-lock-add-keywords nil '(("^\s*%>[^%\n]+" 0 'labmate-directive t)))
   (font-lock-add-keywords nil '(("^\s*%<.+" . 'labmate-response-error)))
   (font-lock-add-keywords nil '(("^\s*%<[{}]$" . 'labmate-response-delimiter)))
   (font-lock-add-keywords nil '(("^\s*%<\s*renamed[^%\n]+" . 'labmate-response-success)))

examples/imeko.m

@@ -1,22 +1,25 @@
-%%> times    :: [ 1 x 12 ] double
+%  %> dimensions V for Q over metre for `Length, kg for `Mass, sec for `Time
 
-%%> voltages :: [ 1 x 12 ] double
+%> times    :: [ 1 x 12 ] double
+%> voltages :: [ 1 x 12 ] double
 
+%> readfrom 'inputs.txt' times voltages
 
 %> z3 :: [ 3 x 1 ] double
 z3 = [ 0; 0; 0 ]
 %> i3 :: [ 3 x 1 ] double
 i3 = [ 1; 1; 1 ]
 
-% %> ddnc :: [ 12 x 4 ] double
 ddnc = [ i3  z3  i3  z3
         -i3  z3  i3  z3
          z3  i3  z3  i3
          z3 -i3  z3  i3 ]
 %> typeof ddnc
 
-%M = [ ddnc times' ]
-%%> typeof M
+M = [ ddnc times' ]
+%> typeof M
+
+x = M \ voltages'
+%> typeof x
+
 
-%x = M \ voltages
-%%> typeof x

src/Machine.hs

@@ -128,6 +128,8 @@ instance PrettyPrint DiagnosticData where
     pure ["unit $" ++ show un ++ " " ++ stat ++ " $" ++ show tn]
   pprint (UnitDs units) =
     pure ["units" ++ foldMap (\u -> " $" ++ show (nonce u)) units]
+  pprint (ReadFromD filename vars) =
+    pure ["readfrom" ++ filename ++ " " ++ show vars]
 
 instance PrettyPrint Frame where
   pprint (Declaration n UserDecl{..}) = do
@@ -165,6 +167,7 @@ data DiagnosticData
       Expr {- e, t = elab e -}
   | UnitD Nonce BOOL Nonce
   | UnitDs [WithSource String]
+  | ReadFromD String [Either String (String, TYPE)]
   deriving Show
 
 data Frame where
@@ -1966,6 +1969,15 @@ runDirective rl (dir :<=: src, body) = do
     InputFormat name | Just (InputFormatBody body) <- body -> do
       newProb $ InputFormatAction name body rl
       run
+    ReadFrom filename variables -> do
+      vs <- for variables $ \ v -> findDeclaration (UserDecl{varTy = Nothing, currentName = v, seen = False, newNames = [], capturable = False, whereAmI = MatLab}) >>= \case
+        Just (name, ty) -> do
+          pushDefinition name (E $^ M (name, Zy) $^ S0 $^ U :^ Ze)
+          pure $ Right (v, ty)
+        Nothing -> pure $ Left $ "Unknown variable " ++ v
+      push $ Diagnostic rl (ReadFromD filename vs)
+      newProb $ Done nil
+      run
     Declare xs ty -> do
       (sol, prob) <- elab "declType" emptyContext (atom SType) (TensorTask <$> ty)
       pushProblems (Sourced . fmap (DeclareAction sol) <$> xs)
@@ -2871,6 +2883,10 @@ normaliseFrame = \case
       stat <- normalise VN (atom STwo) stat
       pure $ UnitD un stat tn
     normaliseDiagnostic d@(UnitDs _) = pure d
+    normaliseDiagnostic d@(ReadFromD filename vs) = do
+      vs <- traverse (either (pure . Left)
+                     (\ (s, ty) -> (Right . (s,)) <$> normalise emptyContext (atom SType) ty)) vs
+      pure $ ReadFromD filename vs
 
 cleanup :: Mood -> Elab ()
 cleanup mood = do
@@ -2952,7 +2968,53 @@ diagnosticRun = llup >>= \case
           units ++
           [ spc dent, sym "%<}"
           ]
-
+      ReadFromD filename vars -> go vars >>= \case
+        Left err -> pure $ [ Tok "\n" Ret dump, spc dent, sym "%<", spc 1] ++ err
+        Right code -> pure $ [ Tok "\n" Ret dump, spc dent, sym "%<{"]
+                       ++ concatMap (\ x -> Tok "\n" Ret dump:spc dent:x)
+                                    (preamble ++ code) ++ [ Tok "\n" Ret dump, spc dent, sym "%<}"]
+       where
+        preamble = [[sym ("h=fopen(\'" ++ filename ++ "\');")]
+                   ,[sym "c=textscan(h,\'%f\');"]
+                   ,[sym "fclose(h);"]
+                   ,[sym "src = c{1};"]
+                   ,[sym "readPtr = 1;"]
+                   ]
+        go :: [Either String (String, TYPE)] -> Elab (Either [Tok] [[Tok]])
+        go [] = pure $ Right []
+        go (Left err:vs) = pure $ Left [ sym err ]
+        go (Right (v, ty):vs) = readFromType emptyContext v ty >>= \case
+          Right code -> go vs >>= \case
+            Left err -> pure $ Left $ err
+            Right codes -> pure $ Right $ code ++ codes
+          Left err -> pure $ Left err
+
+        readFromType :: NATTY n => Context n -> String -> Typ ^ n -> Elab (Either [Tok] [[Tok]])
+        readFromType ctx var ty = do
+          ty <- normalise ctx (atom SType) ty
+          case tagEh ty of
+            _ | ty == doubleType -< no (scopeOf ty) -> pure $ Right $ readSingle
+            Just (SAbel, [ty]) | isUnitType ty -> pure $ Right readSingle
+            Just (SMatrix, [rowGenTy, colGenTy, cellTy, rs, cs])
+              | Just (i, cellTy) <- lamNameEh cellTy, Just (j, cellTy) <- lamNameEh cellTy
+              , rs <- listView rs, cs <- listView cs, all isRight rs, all isRight cs -> do
+                  let ctx' = ctx \\\ (i, mk SAbel rowGenTy) \\\ (j, wk $ mk SAbel colGenTy)
+                  cellTy <- normalise ctx' (atom SType) cellTy
+                  case (length rs, length cs) of
+                    (1, 1) -> readFromType ctx' var cellTy
+                    (1, c) -> fmap (\ s -> [[sym ("for i = 1:" ++ show c)]] ++ map (spc 2:) s ++ [[sym "end"]])
+                                <$> (readFromType ctx' (var ++ "(i)") cellTy)
+                    (r, 1) -> fmap (\ s -> [[sym ("for i = 1:" ++ show r)]] ++ map (spc 2:) s ++ [[sym "end"]])
+                                <$> (readFromType ctx' (var ++ "(i,1)") cellTy)
+                    (r, c) -> fmap (\ s -> [[sym ("for i = 1:" ++ show r)], [spc 2, sym ("for j = 1:" ++ show c)]]
+                                     ++ map (spc 4:) s ++ [[spc 4, sym "end"], [sym "end"]])
+                                <$> (readFromType ctx' (var ++ "(i,j)") cellTy)
+            Just (SQuantity, [enumTy, exp]) -> pure $ Right $ readSingle -- TODO: require unit
+            _ -> do
+              ty <- unelabType ctx ty
+              pure $ Left ([sym "I do not know how to generate code to read from type "] ++ ty)
+         where
+          readSingle = [[sym (var ++ " = src(readPtr);")], [sym "readPtr = readPtr + 1;"]]
 
 metaStatus :: Name -> Elab Status
 metaStatus x = do

src/Parse/Matlab.hs

@@ -120,6 +120,7 @@ pdirhead :: Parser DirHeader
 pdirhead = Declare <$> psep1 (pspc <|> punc ",") (pws pnomNotLabMateKey) <* pospc <* psym "::" <* pospc <*> ptensortype
     <|> Rename <$ pkin Nom "rename" <* pospc <*> pnomNotLabMateKey <* pspc <*> pnomNotLabMateKey
     <|> InputFormat <$ pkin Nom "input" <* pospc <*> pnom
+    <|> ReadFrom <$ pkin Nom "readfrom" <* pospc <*> pstringlit <* pspc <*> psep1 pspc pnom
     <|> Typecheck <$ pkin Nom "typecheck" <* pospc <*> ptensortype <* pspc <*> pexpr topCI
     <|> SynthType <$ pkin Nom "typeof" <* pospc <*> pexpr topCI
     <|> Dimensions <$ pkin Nom "dimensions" <* pspc

src/Syntax.hs

@@ -32,6 +32,9 @@ data DirHeader
   = Declare [WithSource String] ConcreteType
   | Rename String String
   | InputFormat String {- name of function -}
+  | ReadFrom
+      String -- filename
+      [String] -- variables to generate code for
   | Typecheck ConcreteType Expr
   | SynthType Expr
   | Dimensions